import Control.Monad.Trans.Except (ExceptT(..), throwE)
import Control.Monad.Trans.Class (lift)
import qualified Data.Char
-import qualified Data.Decimal
import qualified Data.Either
import qualified Data.List
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Time.Calendar as Time
import qualified Data.Time.Clock as Time
import qualified Data.Time.LocalTime as Time
-import Data.Time.LocalTime (TimeZone(..))
import Data.Typeable ()
import qualified Text.Parsec as R hiding
( char
import qualified Data.Text as Text
import qualified System.FilePath.Posix as Path
-import qualified Hcompta.Calc.Balance as Calc.Balance
-import qualified Hcompta.Model.Account as Account
-import Hcompta.Model.Account (Account)
-import qualified Hcompta.Model.Amount as Amount
-import Hcompta.Model.Amount (Amount)
-import qualified Hcompta.Model.Amount.Style as Style
-import qualified Hcompta.Model.Amount.Unit as Unit
-import Hcompta.Model.Amount.Unit (Unit)
-import qualified Hcompta.Model.Date as Date
-import Hcompta.Model.Date (Date)
+import qualified Hcompta.Balance as Balance
+import qualified Hcompta.Account as Account
+import Hcompta.Account (Account)
+import qualified Hcompta.Amount as Amount
+import qualified Hcompta.Amount.Style as Style
+import qualified Hcompta.Amount.Read as Amount.Read
+import qualified Hcompta.Amount.Unit as Unit
+import qualified Hcompta.Date as Date
+import Hcompta.Date (Date)
+import qualified Hcompta.Date.Read as Date.Read
import qualified Hcompta.Format.Ledger as Ledger
import Hcompta.Format.Ledger
( Comment
}
data Error
- = Error_year_or_day_is_missing
- | Error_invalid_date (Integer, Int, Int)
- | Error_invalid_time_of_day (Int, Int, Integer)
- | Error_transaction_not_equilibrated Transaction [Calc.Balance.Unit_Sum Amount]
- | Error_virtual_transaction_not_equilibrated Transaction [Calc.Balance.Unit_Sum Amount]
+ = Error_date Date.Read.Error
+ | Error_transaction_not_equilibrated Transaction [Balance.Unit_Sum (Balance.Posting_Amount Ledger.Posting)]
+ | Error_virtual_transaction_not_equilibrated Transaction [Balance.Unit_Sum (Balance.Posting_Amount Ledger.Posting)]
| Error_reading_file FilePath Exception.IOException
| Error_including_file FilePath [R.Error Error]
deriving (Show)
--- | Parse either '-' into 'negate', or '+' or '' into 'id'.
-sign :: (Stream s m Char, Num i) => ParsecT s u m (i -> i)
-sign =
- (R.char '-' >> return negate)
- <|> (R.char '+' >> return id)
- <|> return id
-
--- * Parsing 'Account'
+-- * Read 'Account'
account_name_sep :: Char
account_name_sep = ':'
--- | Parse an 'Account'.
+-- | Read an 'Account'.
account :: Stream s m Char => ParsecT s u m Account
account = do
R.notFollowedBy $ R.space_horizontal
Account.from_List <$> do
R.many1_separated account_name $ R.char account_name_sep
--- | Parse an Account.'Account.Name'.
+-- | Read an Account.'Account.Name'.
account_name :: Stream s m Char => ParsecT s u m Account.Name
account_name = do
fromString <$> do
_ | not (Data.Char.isSpace c) -> return c
_ -> R.parserZero
--- | Parse an Account.'Account.Joker_Name'.
+-- | Read an Account.'Account.Joker_Name'.
account_joker_name :: Stream s m Char => ParsecT s u m Account.Joker_Name
account_joker_name = do
n <- R.option Nothing $ (Just <$> account_name)
Nothing -> R.char account_name_sep >> (return $ Account.Joker_Any)
Just n' -> return $ Account.Joker_Name n'
--- | Parse an Account.'Account.Joker'.
+-- | Read an Account.'Account.Joker'.
account_joker :: Stream s m Char => ParsecT s u m Account.Joker
account_joker = do
R.notFollowedBy $ R.space_horizontal
R.many1_separated account_joker_name $ R.char account_name_sep
--- | Parse a 'Regex'.
+-- | Read a 'Regex'.
account_regex :: Stream s m Char => ParsecT s u m Regex
account_regex = do
re <- R.many1 $ R.satisfy (not . R.is_space_horizontal)
Regex.of_StringM re
--- | Parse an Account.'Account.Filter'.
+-- | Read an Account.'Account.Filter'.
account_pattern :: Stream s m Char => ParsecT s u m Account.Pattern
account_pattern = do
R.choice_try
, Account.Pattern_Regex <$> (R.option '~' (R.char '~') >> account_regex)
]
--- * Parsing 'Amount'
-
--- | Parse an 'Amount'.
-amount :: Stream s m Char => ParsecT s u m Amount
-amount = do
- left_signing <- sign
- left_unit <-
- R.option Nothing $ do
- u <- unit
- s <- R.many $ R.space_horizontal
- return $ Just $ (u, not $ null s)
- (quantity_, style) <- do
- signing <- sign
- Quantity
- { integral
- , fractional
- , fractioning
- , grouping_integral
- , grouping_fractional
- } <-
- R.choice_try
- [ quantity '_' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
- , quantity '_' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
- , quantity ',' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
- , quantity '.' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
- ] <?> "quantity"
- let int = Data.List.concat integral
- let frac_flat = Data.List.concat fractional
- let frac = reverse $ Data.List.dropWhile (== '0') $ reverse $ frac_flat
- let place = length frac
- guard (place <= 255)
- let mantissa = R.integer_of_digits 10 $ int ++ frac
- return $
- ( Data.Decimal.Decimal
- (fromIntegral place)
- (signing mantissa)
- , Style.nil
- { Style.fractioning
- , Style.grouping_integral
- , Style.grouping_fractional
- , Style.precision = fromIntegral $ length frac_flat
- }
- )
- (unit_, unit_side, unit_spaced) <-
- case left_unit of
- Just (u, s) ->
- return (u, Just Style.Side_Left, Just s)
- Nothing ->
- R.option (Unit.nil, Nothing, Nothing) $ R.try $ do
- s <- R.many $ R.space_horizontal
- u <- unit
- return $ (u, Just Style.Side_Right, Just $ not $ null s)
- return $
- Amount.Amount
- { Amount.quantity = left_signing $ quantity_
- , Amount.style = style
- { Style.unit_side
- , Style.unit_spaced
- }
- , Amount.unit = unit_
- }
-
-data Quantity
- = Quantity
- { integral :: [String]
- , fractional :: [String]
- , fractioning :: Maybe Style.Fractioning
- , grouping_integral :: Maybe Style.Grouping
- , grouping_fractional :: Maybe Style.Grouping
- }
-
--- | Parse a 'Quantity'.
-quantity
- :: Stream s m Char
- => Char -- ^ Integral grouping separator.
- -> Char -- ^ Fractioning separator.
- -> Char -- ^ Fractional grouping separator.
- -> ParsecT s u m Quantity
-quantity int_group_sep frac_sep frac_group_sep = do
- (integral, grouping_integral) <- do
- h <- R.many R.digit
- case h of
- [] -> return ([], Nothing)
- _ -> do
- t <- R.many $ R.char int_group_sep >> R.many1 R.digit
- let digits = h:t
- return (digits, grouping_of_digits int_group_sep digits)
- (fractional, fractioning, grouping_fractional) <-
- (case integral of
- [] -> id
- _ -> R.option ([], Nothing, Nothing)) $ do
- fractioning <- R.char frac_sep
- h <- R.many R.digit
- t <- R.many $ R.char frac_group_sep >> R.many1 R.digit
- let digits = h:t
- return (digits, Just fractioning
- , grouping_of_digits frac_group_sep $ reverse digits)
- return $
- Quantity
- { integral
- , fractional
- , fractioning
- , grouping_integral
- , grouping_fractional
- }
- where
- grouping_of_digits :: Char -> [String] -> Maybe Style.Grouping
- grouping_of_digits group_sep digits =
- case digits of
- [] -> Nothing
- [_] -> Nothing
- _ -> Just $
- Style.Grouping group_sep $
- canonicalize_grouping $
- map length $ digits
- canonicalize_grouping :: [Int] -> [Int]
- canonicalize_grouping groups =
- Data.List.foldl -- NOTE: remove duplicates at beginning and reverse.
- (\acc l0 -> case acc of
- l1:_ -> if l0 == l1 then acc else l0:acc
- _ -> l0:acc) [] $
- case groups of -- NOTE: keep only longer at beginning.
- l0:l1:t -> if l0 > l1 then groups else l1:t
- _ -> groups
-
--- | Parse an 'Unit'.
-unit :: Stream s m Char => ParsecT s u m Unit
-unit =
- (quoted <|> unquoted) <?> "unit"
- where
- unquoted :: Stream s m Char => ParsecT s u m Unit
- unquoted =
- fromString <$> do
- R.many1 $
- R.satisfy $ \c ->
- case Data.Char.generalCategory c of
- Data.Char.CurrencySymbol -> True
- Data.Char.LowercaseLetter -> True
- Data.Char.ModifierLetter -> True
- Data.Char.OtherLetter -> True
- Data.Char.TitlecaseLetter -> True
- Data.Char.UppercaseLetter -> True
- _ -> False
- quoted :: Stream s m Char => ParsecT s u m Unit
- quoted =
- fromString <$> do
- R.between (R.char '"') (R.char '"') $
- R.many1 $
- R.noneOf ";\n\""
-
-- * Directives
directive_alias :: Stream s m Char => ParsecT s Context m ()
(regx, repl):context_aliases_regex ctx}
return ()
--- | Parse the year, month and day separator: '/' or '-'.
-date_separator :: Stream s m Char => ParsecT s u m Char
-date_separator = R.satisfy (\c -> c == '/' || c == '-')
-
--- | Parse the hour, minute and second separator: ':'.
-hour_separator :: Stream s m Char => ParsecT s u m Char
-hour_separator = R.char ':'
--- * Parsing 'Date'
-
--- | Parse a 'Date' in [YYYY/]MM/DD [HH:MM[:SS][TZ]] format.
-date
- :: (Stream s (R.Error_State Error m) Char, Monad m)
- => Maybe Integer -> ParsecT s u (R.Error_State Error m) Date
-date def_year = (do
- n0 <- R.many1 R.digit
- day_sep <- date_separator
- n1 <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit
- n2 <- R.option Nothing $ R.try $ do
- _ <- R.char day_sep
- Just <$> do R.try (R.count 2 R.digit) <|> R.count 1 R.digit
- (year, m, d) <-
- case (n2, def_year) of
- (Nothing, Nothing) -> R.fail_with "date" (Error_year_or_day_is_missing)
- (Nothing, Just year) -> return (year, n0, n1)
- (Just d, _) -> return (R.integer_of_digits 10 n0, n1, d)
- let month = fromInteger $ R.integer_of_digits 10 m
- let day = fromInteger $ R.integer_of_digits 10 d
- guard $ month >= 1 && month <= 12
- guard $ day >= 1 && day <= 31
- day_ <- case Time.fromGregorianValid year month day of
- Nothing -> R.fail_with "date" (Error_invalid_date (year, month, day))
- Just day_ -> return day_
- (hour, minu, sec, tz) <-
- R.option (0, 0, 0, Time.utc) $ R.try $ do
- R.skipMany1 $ R.space_horizontal
- hour <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit
- sep <- hour_separator
- minu <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit
- sec <- R.option Nothing $ R.try $ do
- _ <- R.char sep
- Just <$> (R.try (R.count 2 R.digit) <|> R.count 1 R.digit)
- tz <- R.option Time.utc $ R.try $ do
- R.skipMany $ R.space_horizontal
- time_zone
- return
- ( fromInteger $ R.integer_of_digits 10 hour
- , fromInteger $ R.integer_of_digits 10 minu
- , maybe 0 (R.integer_of_digits 10) sec
- , tz )
- tod <- case Time.makeTimeOfDayValid hour minu (fromInteger sec) of
- Nothing -> R.fail_with "date" (Error_invalid_time_of_day (hour, minu, sec))
- Just tod -> return tod
- return $
- Time.ZonedTime
- (Time.LocalTime day_ tod)
- tz
- ) <?> "date"
-
-time_zone :: Stream s m Char => ParsecT s u m TimeZone
-time_zone =
- -- DOC: http://www.timeanddate.com/time/zones/
- -- TODO: only a few time zones are suported below.
- -- TODO: check the timeZoneSummerOnly values
- R.choice
- [ R.char 'A' >> R.choice
- [ R.string "ST" >> return (TimeZone ((-4) * 60) False "AST")
- , R.string "DT" >> return (TimeZone ((-3) * 60) True "ADT")
- , return (TimeZone ((-1) * 60) False "A")
- ]
- , R.char 'B' >> R.choice
- [ R.string "ST" >> return (TimeZone ((-11) * 60) False "BST")
- , R.string "DT" >> return (TimeZone ((-10) * 60) True "BDT")
- ]
- , R.char 'C' >> R.choice
- [ R.char 'E' >> R.choice
- [ R.string "T" >> return (TimeZone ((1) * 60) True "CET")
- , R.string "ST" >> return (TimeZone ((2) * 60) False "CEST")
- ]
- , R.string "ST" >> return (TimeZone ((-6) * 60) False "CST")
- , R.string "DT" >> return (TimeZone ((-5) * 60) True "CDT")
- ]
- , R.char 'E' >> R.choice
- [ R.string "ST" >> return (TimeZone ((-5) * 60) False "EST")
- , R.string "DT" >> return (TimeZone ((-4) * 60) True "EDT")
- ]
- , R.string "GMT" >> return (TimeZone 0 False "GMT")
- , R.char 'H' >> R.choice
- [ R.string "ST" >> return (TimeZone ((-10) * 60) False "HST")
- , R.string "DT" >> return (TimeZone (( -9) * 60) True "HDT")
- ]
- , R.char 'M' >> R.choice
- [ R.string "ST" >> return (TimeZone ((-7) * 60) False "MST")
- , R.string "DT" >> return (TimeZone ((-6) * 60) True "MDT")
- , return (TimeZone ((-12) * 60) False "M")
- ]
- , R.char 'N' >> R.choice
- [ R.string "ST" >> return (TimeZone ((-3) * 60 - 30) False "NST")
- , return (TimeZone (1 * 60) False "N")
- ]
- , R.char 'P' >> R.choice
- [ R.string "ST" >> return (TimeZone ((-8) * 60) False "PST")
- , R.string "DT" >> return (TimeZone ((-7) * 60) True "PDT")
- ]
- , R.char 'Y' >> R.choice
- [ R.string "ST" >> return (TimeZone ((-9) * 60) False "YST")
- , R.string "DT" >> return (TimeZone ((-8) * 60) True "YDT")
- , return (TimeZone (12 * 60) False "Y")
- ]
- , R.char 'Z' >> return (TimeZone 0 False "Z")
- , time_zone_digits
- ]
-
-time_zone_digits :: Stream s m Char => ParsecT s u m TimeZone
-{-# INLINEABLE time_zone_digits #-}
-time_zone_digits = do
- sign_ <- sign
- hour <- R.integer_of_digits 10 <$> R.count 2 R.digit
- _ <- R.option ':' (R.char ':')
- minute <- R.integer_of_digits 10 <$> R.count 2 R.digit
- let tz = TimeZone
- { timeZoneMinutes = sign_ (fromInteger hour * 60 + fromInteger minute)
- , timeZoneSummerOnly = False
- , timeZoneName = Time.timeZoneOffsetString tz
- }
- return tz
-
--- * Parsing 'Comment'
+-- * Read 'Comment'
comment_begin :: Char
comment_begin = ';'
<|> return []
) <?> "comments"
--- * Parsing 'Tag'
+-- * Read 'Tag'
tag_value_sep :: Char
tag_value_sep = ':'
tag_sep :: Char
tag_sep = ','
--- | Parse a 'Tag'.
+-- | Read a 'Tag'.
tag :: Stream s m Char => ParsecT s u m Tag
tag = (do
n <- tag_name
&& not (Data.Char.isSpace c))
R.space_horizontal
--- * Parsing 'Posting'
+-- * Read 'Posting'
--- | Parse a 'Posting'.
posting
:: (Stream s (R.Error_State Error m) Char, Monad m)
=> ParsecT s Context (R.Error_State Error m) (Posting, Posting_Type)
Unit.nil)
(context_unit_and_style ctx) .
Amount.from_List <$> do
- R.many_separated amount $ do
+ R.many_separated Amount.Read.amount $ do
R.skipMany $ R.space_horizontal
_ <- R.char amount_sep
R.skipMany $ R.space_horizontal
Nothing -> return []
Just dates -> do
let date2s = Data.Map.lookup "date2" tags_ -- NOTE: support hledger's date2
- do
+ do
(flip mapM) (dates ++ fromMaybe [] date2s) $ \s ->
- R.runParserT_with_Error_fail "tag date"
- (date (Just $ context_year ctx) <* R.eof) ()
+ R.runParserT_with_Error_fail "tag date" id
+ (Date.Read.date Error_date (Just $ context_year ctx) <* R.eof) ()
(Text.unpack s) s
>>= \dates_ -> case (dates, date2s) of -- NOTE: put hledger's date2 at least in second position
([], Just (_:_)) ->
tags_of_comments :: [Comment] -> Tag_by_Name
tags_of_comments =
- Data.Map.unionsWith (flip (++))
+ Data.Map.unionsWith (++)
. Data.List.map
( Data.Either.either (const Data.Map.empty) id
. R.runParser (not_tag >> tags <* R.eof) () "" )
posting_type_virtual_balanced_end :: Char
posting_type_virtual_balanced_end = ']'
--- * Parsing 'Transaction'
+-- * Read 'Transaction'
transaction
:: (Stream s (R.Error_State Error m) Char, Monad m)
=> ParsecT s Context (R.Error_State Error m) Transaction
transaction = (do
- sourcepos <- R.getPosition
ctx <- R.getState
- comments_before <-
+ transaction_sourcepos <- R.getPosition
+ transaction_comments_before <-
comments
>>= \x -> case x of
[] -> return []
_ -> return x <* R.new_line
- date_ <- date (Just $ context_year ctx)
+ date_ <- Date.Read.date Error_date (Just $ context_year ctx)
dates_ <-
R.option [] $ R.try $ do
R.skipMany $ R.space_horizontal
_ <- R.char date_sep
R.skipMany $ R.space_horizontal
R.many_separated
- (date (Just $ context_year ctx)) $
+ (Date.Read.date Error_date (Just $ context_year ctx)) $
R.try $ do
R.many $ R.space_horizontal
>> R.char date_sep
>> (R.many $ R.space_horizontal)
+ let transaction_dates = (date_, dates_)
R.skipMany $ R.space_horizontal
- status_ <- status
- code_ <- R.option "" $ R.try code
+ transaction_status <- status
+ transaction_code <- R.option "" $ R.try code
R.skipMany $ R.space_horizontal
- description_ <- description
+ transaction_description <- description
R.skipMany $ R.space_horizontal
- comments_after <- comments
- let tags_ =
+ transaction_comments_after <- comments
+ let transaction_tags =
Data.Map.unionWith (++)
- (tags_of_comments comments_before)
- (tags_of_comments comments_after)
+ (tags_of_comments transaction_comments_before)
+ (tags_of_comments transaction_comments_after)
R.new_line
(postings_unchecked, postings_not_regular) <-
((Ledger.posting_by_Account . Data.List.map fst) *** id) .
Data.List.partition ((Posting_Type_Regular ==) . snd) <$>
R.many1_separated posting R.new_line
- let (virtual_postings, balanced_virtual_postings_unchecked) =
+ let (transaction_virtual_postings, balanced_virtual_postings_unchecked) =
join (***) (Ledger.posting_by_Account . Data.List.map fst) $
Data.List.partition ((Posting_Type_Virtual ==) . snd)
postings_not_regular
let tr_unchecked =
Transaction
- { transaction_code=code_
- , transaction_comments_before=comments_before
- , transaction_comments_after=comments_after
- , transaction_dates=(date_, dates_)
- , transaction_description=description_
+ { transaction_code
+ , transaction_comments_before
+ , transaction_comments_after
+ , transaction_dates
+ , transaction_description
, transaction_postings=postings_unchecked
- , transaction_postings_balance=Calc.Balance.balance
- , transaction_virtual_postings=virtual_postings
+ , transaction_virtual_postings
, transaction_balanced_virtual_postings=balanced_virtual_postings_unchecked
- , transaction_balanced_virtual_postings_balance=Calc.Balance.balance
- , transaction_sourcepos=sourcepos
- , transaction_status=status_
- , transaction_tags=tags_
+ , transaction_sourcepos
+ , transaction_status
+ , transaction_tags
}
- ( transaction_postings_balance
- ,transaction_postings ) <-
- case Calc.Balance.infer_equilibrium postings_unchecked of
+ transaction_postings <-
+ case Balance.infer_equilibrium postings_unchecked of
(_, Left ko) -> R.fail_with "transaction infer_equilibrium"
(Error_transaction_not_equilibrated tr_unchecked ko)
- (bal, Right ok) -> return (bal, ok)
- ( transaction_balanced_virtual_postings_balance
- ,transaction_balanced_virtual_postings ) <-
- case Calc.Balance.infer_equilibrium balanced_virtual_postings_unchecked of
+ (_bal, Right ok) -> return ok
+ transaction_balanced_virtual_postings <-
+ case Balance.infer_equilibrium balanced_virtual_postings_unchecked of
(_, Left ko) -> R.fail_with "transaction infer_equilibrium"
(Error_virtual_transaction_not_equilibrated tr_unchecked ko)
- (bal, Right ok) -> return (bal, ok)
+ (_bal, Right ok) -> return ok
return $
- Transaction
- { transaction_code=code_
- , transaction_comments_before=comments_before
- , transaction_comments_after=comments_after
- , transaction_dates=(date_, dates_)
- , transaction_description=description_
- , transaction_postings
- , transaction_postings_balance
- , transaction_virtual_postings=virtual_postings
+ tr_unchecked
+ { transaction_postings
, transaction_balanced_virtual_postings
- , transaction_balanced_virtual_postings_balance
- , transaction_sourcepos=sourcepos
- , transaction_status=status_
- , transaction_tags=tags_
}
) <?> "transaction"
_ | not (Data.Char.isSpace c) -> return c
_ -> R.parserZero
--- * Parsing directives
+-- * Read directives
default_year :: Stream s m Char => ParsecT s Context m ()
default_year = (do
default_unit_and_style :: Stream s m Char => ParsecT s Context m ()
default_unit_and_style = (do
- amount_ <- amount
+ amount_ <- Amount.Read.amount
R.skipMany R.space_horizontal >> R.new_line
context_ <- R.getState
R.setState context_{context_unit_and_style =
let cwd = Path.takeDirectory (R.sourceName sourcepos)
file_path <- liftIO $ Path.abs cwd filename
content <- do
- liftIO $ Exception.catch
+ join $ liftIO $ Exception.catch
(liftM return $ readFile file_path)
(return . R.fail_with "include reading" . Error_reading_file file_path)
- >>= id
(journal_included, context_included) <- do
liftIO $
R.runParserT_with_Error (R.and_state $ journal_rec file_path)
: journal_includes journal_}}
) <?> "include"
--- * Parsing 'Journal'
+-- * Read 'Journal'
journal
:: Stream s (R.Error_State Error IO) Char
Data.Map.insertWith (flip (++))
-- NOTE: flip-ing preserves order but slows down
-- when many transactions have the very same date.
- (Date.to_UTC $ fst $ transaction_dates t) [t]
+ (fst $ transaction_dates t) [t]
(journal_transactions j)}}
R.new_line <|> R.eof))
, R.try (comment >> return ())
, journal_includes = reverse $ journal_includes journal_
}
--- ** Parsing 'Journal' from a file
+-- ** Read 'Journal' from a file
file :: FilePath -> ExceptT [R.Error Error] IO Journal
file path = do
sourcephile / git / comptalang.git / blobdiff