lib/Hcompta/Format/Ledger/Read.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE NamedFieldPuns #-}
   4 {-# LANGUAGE ScopedTypeVariables #-}
   5 module Hcompta.Format.Ledger.Read where
   6
   7 import           Control.Applicative ((<*), (<$>))
   8 import qualified Control.Exception as Exn
   9 import           Control.Monad (guard)
  10 -- import           Control.Monad.Error
  11 import qualified Data.Char
  12 import           Data.Data
  13 import qualified Data.Decimal
  14 import qualified Data.List
  15 -- import           Data.List.Split (wordsBy)
  16 import qualified Data.Map
  17 import           Data.Maybe
  18 import qualified Data.Time.Calendar  as Time
  19 import qualified Data.Time.Clock     as Time
  20 import qualified Data.Time.LocalTime as Time
  21 import           Data.Typeable ()
  22 import           Safe (headDef, lastDef)
  23 import qualified Text.Parsec as P
  24 import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))
  25 import           Text.Printf
  26
  27 import qualified Hcompta.Model as Model
  28 import qualified Hcompta.Model.Account as Account
  29 import           Hcompta.Model.Account (Account)
  30 import qualified Hcompta.Model.Amount as Amount
  31 import           Hcompta.Model.Amount (Amount, Conversion, Style, Unit)
  32 import qualified Hcompta.Model.Amount.Conversion as Conversion
  33 import qualified Hcompta.Model.Amount.Quantity as Quantity
  34 import qualified Hcompta.Model.Amount.Style as Style
  35 import qualified Hcompta.Model.Amount.Unit as Unit
  36 import qualified Hcompta.Model.Date as Date
  37 import           Hcompta.Format.Ledger.Journal as Journal
  38
  39 data Context
  40  =   Context
  41  { account_prefix :: !Account
  42  --, context_aliases :: ![AccountAlias]
  43  , unit_and_style :: !(Maybe (Amount.Unit, Amount.Style))
  44  , journal :: !Journal
  45  , year :: !Date.Year
  46  } deriving (Data, Eq, Read, Show, Typeable)
  47
  48 nil :: Context
  49 nil =
  50         Context
  51          { account_prefix = []
  52          , unit_and_style = Nothing
  53          , journal = Journal.nil
  54          , year = (\(year, _ , _) -> year) $
  55                 Time.toGregorian $ Time.utctDay $
  56                 Journal.last_read_time Journal.nil
  57          }
  58
  59 -- * Utilities
  60
  61 -- ** Combinators
  62
  63 -- | Like 'Text.Parsec.choice' but with 'Text.Parsec.try' on each case.
  64 choice_try :: Stream s m t => [ParsecT s st m a] -> ParsecT s st m a
  65 choice_try = P.choice . Data.List.map P.try
  66
  67 -- ** Numbers
  68
  69 -- | Return the 'Integer' obtained by multiplying the given digits
  70 --   with the power of the given base respective to their rank.
  71 integer_of_digits
  72  :: Integer -- ^ Base.
  73  -> [Char]  -- ^ Digits (MUST be recognised by 'Data.Char.digitToInt').
  74  -> Integer
  75 integer_of_digits base =
  76         Data.List.foldl (\x d ->
  77                 base*x + toInteger (Data.Char.digitToInt d)) 0
  78
  79 decimal :: Stream [Char] m Char => ParsecT [Char] st m Integer
  80 decimal = integer 10 P.digit
  81 hexadecimal :: Stream [Char] m Char => ParsecT [Char] st m Integer
  82 hexadecimal = P.oneOf "xX" >> integer 16 P.hexDigit
  83 octal :: Stream [Char] m Char => ParsecT [Char] st m Integer
  84 octal = P.oneOf "oO" >> integer 8 P.octDigit
  85
  86 -- | Parse an 'Integer'.
  87 integer :: Stream [Char] m Char
  88        => Integer -> ParsecT [Char] st m Char
  89        -> ParsecT [Char] st m Integer
  90 integer base digit = do
  91         digits <- P.many1 digit
  92         let n = integer_of_digits base digits
  93         seq n (return n)
  94
  95 -- | Parse either '-' into 'negate', or '+' or '' into 'id'.
  96 sign :: (Stream [Char] m Char, Num i) => ParsecT [Char] st m (i -> i)
  97 sign =
  98         (P.char '-' >> return negate) <|>
  99         (P.char '+' >> return id) <|>
 100         return id
 101
 102 -- ** Whites
 103
 104 -- | Return 'True' if and only if the given 'Char' is an horizontal space.
 105 is_space :: Char -> Bool
 106 is_space c = c /= '\n' && c /= '\r' && Data.Char.isSpace c
 107
 108 space :: Stream [Char] m Char => ParsecT [Char] st m Char
 109 space = P.satisfy is_space
 110
 111 -- * Parsing 'Account'.
 112
 113 -- | Parse an 'Account'.
 114 account :: Stream [Char] m Char => ParsecT [Char] st m Account
 115 account = do
 116         P.notFollowedBy $ P.satisfy is_space
 117         P.sepBy1 account_name account_separator
 118
 119 -- | Parse an Account.'Account.Name'.
 120 account_name :: Stream [Char] m Char => ParsecT [Char] st m Account.Name
 121 account_name = do
 122         P.many1 $ do
 123                 P.satisfy is_space
 124                         <* (P.lookAhead $ P.satisfy (not . Data.Char.isSpace))
 125                 <|> (P.notFollowedBy account_separator >> P.anyChar)
 126
 127 account_separator :: Stream [Char] m Char => ParsecT [Char] st m Char
 128 account_separator = P.char ':'
 129
 130 -- * Parsing 'Amount'.
 131
 132 -- | Parse an 'Amount'.
 133 amount :: Stream [Char] m Char => ParsecT [Char] st m Amount
 134 amount = do
 135         left_signing <- sign
 136         left_unit <-
 137                 P.option Nothing $ do
 138                         u <- unit
 139                         s <- P.many $ P.satisfy is_space
 140                         return $ Just $ (u, not $ null s)
 141         (quantity_, style) <- do
 142                 signing <- sign
 143                 Quantity
 144                  { integral
 145                  , fractional
 146                  , fractioning
 147                  , grouping_integral
 148                  , grouping_fractional
 149                  } <-
 150                         choice_try
 151                          [ quantity '_' ',' '_' <* (P.notFollowedBy $ P.oneOf ",._")
 152                          , quantity '_' '.' '_' <* (P.notFollowedBy $ P.oneOf ",._")
 153                          , quantity ',' '.' '_' <* (P.notFollowedBy $ P.oneOf ",._")
 154                          , quantity '.' ',' '_' <* (P.notFollowedBy $ P.oneOf ",._")
 155                          ] <?> "quantity"
 156                 let int = Data.List.concat integral
 157                 let frac_flat = Data.List.concat fractional
 158                 let frac = reverse $ Data.List.dropWhile (== '0') $ reverse $ frac_flat
 159                 let place = length frac
 160                 guard (place <= 255)
 161                 let mantissa = integer_of_digits 10 $ int ++ frac
 162                 return $
 163                  ( Data.Decimal.Decimal
 164                          (fromIntegral place)
 165                          (signing mantissa)
 166                  , Style.nil
 167                          { Style.fractioning = fractioning
 168                          , Style.grouping_integral = grouping_integral
 169                          , Style.grouping_fractional = grouping_fractional
 170                          , Style.precision = fromIntegral $ length frac_flat
 171                          }
 172                  )
 173         (unit_, side, spaced) <-
 174                 case left_unit of
 175                  Just (u, s) ->
 176                         return (u, Just Style.Side_Left, Just s)
 177                  Nothing ->
 178                         P.option (Unit.nil, Nothing, Nothing) $ do
 179                                 s <- P.many $ P.satisfy is_space
 180                                 u <- unit
 181                                 return $ (u, Just Style.Side_Right, Just $ not $ null s)
 182         return $
 183                 Amount.Amount
 184                  { Amount.conversion = Conversion.nil -- TODO
 185                  , Amount.quantity = left_signing $ quantity_
 186                  , Amount.style = style
 187                          { Style.unit_side = side
 188                          , Style.unit_spaced = spaced
 189                          }
 190                  , Amount.unit = unit_
 191                  }
 192
 193 data Quantity
 194  =   Quantity
 195  { integral :: [String]
 196  , fractional :: [String]
 197  , fractioning :: Maybe Style.Fractioning
 198  , grouping_integral :: Maybe Style.Grouping
 199  , grouping_fractional :: Maybe Style.Grouping
 200  }
 201
 202 -- | Parse a 'Quantity'.
 203 quantity
 204  :: Stream [Char] m Char
 205  => Char -- ^ Integral grouping separator.
 206  -> Char -- ^ Fractioning separator.
 207  -> Char -- ^ Fractional grouping separator.
 208  -> ParsecT [Char] st m Quantity
 209 quantity int_group_sep frac_sep frac_group_sep = do
 210         (integral, grouping_integral) <- do
 211                 h <- P.many P.digit
 212                 case h of
 213                  [] -> return ([], Nothing)
 214                  _ -> do
 215                         t <- P.many $ P.char int_group_sep >> P.many1 P.digit
 216                         let digits = h:t
 217                         return (digits, grouping_of_digits int_group_sep digits)
 218         (fractional, fractioning, grouping_fractional) <-
 219                 (case integral of
 220                  [] -> id
 221                  _ -> P.option ([], Nothing, Nothing)) $ do
 222                         fractioning <- P.char frac_sep
 223                         h <- P.many P.digit
 224                         t <- P.many $ P.char frac_group_sep >> P.many1 P.digit
 225                         let digits = h:t
 226                         return (digits, Just fractioning
 227                          , grouping_of_digits frac_group_sep $ reverse digits)
 228         return $
 229                 Quantity
 230                  { integral
 231                  , fractional
 232                  , fractioning
 233                  , grouping_integral
 234                  , grouping_fractional
 235                  }
 236         where
 237                 grouping_of_digits :: Char -> [String] -> Maybe Style.Grouping
 238                 grouping_of_digits group_sep digits =
 239                         case digits of
 240                          [] -> Nothing
 241                          [_] -> Nothing
 242                          _ -> Just $
 243                                 Style.Grouping group_sep $
 244                                 canonicalize_grouping $
 245                                 map length $ digits
 246                 canonicalize_grouping :: [Int] -> [Int]
 247                 canonicalize_grouping groups =
 248                         Data.List.foldl -- NOTE: remove duplicates at begining and reverse.
 249                          (\acc l0 -> case acc of
 250                                  l1:_ -> if l0 == l1 then acc else l0:acc
 251                                  _ -> l0:acc) [] $
 252                         case groups of -- NOTE: keep only longer at begining.
 253                          l0:l1:t -> if l0 > l1 then groups else l1:t
 254                          _ -> groups
 255
 256 -- | Parse an 'Unit'.
 257 unit :: Stream [Char] m Char => ParsecT [Char] st m Unit
 258 unit =
 259         (quoted <|> unquoted) <?> "unit"
 260         where
 261                 unquoted :: Stream [Char] m Char => ParsecT [Char] st m Unit
 262                 unquoted =
 263                         P.many1 $
 264                                 P.satisfy $ \c ->
 265                                         case Data.Char.generalCategory c of
 266                                          Data.Char.CurrencySymbol  -> True
 267                                          Data.Char.LowercaseLetter -> True
 268                                          Data.Char.ModifierLetter  -> True
 269                                          Data.Char.OtherLetter     -> True
 270                                          Data.Char.TitlecaseLetter -> True
 271                                          Data.Char.UppercaseLetter -> True
 272                                          _ -> False
 273                 quoted :: Stream [Char] m Char => ParsecT [Char] st m Unit
 274                 quoted =
 275                         P.between (P.char '"') (P.char '"') $
 276                                 P.many1 $
 277                                         P.noneOf ";\n\""