1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE NamedFieldPuns #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# LANGUAGE ScopedTypeVariables #-}
6 {-# LANGUAGE TupleSections #-}
7 module Hcompta.Format.Ledger.Read where
9 import Control.Applicative ((<$>), (<*>), (<*))
10 import qualified Control.Exception as Exception
11 import Control.Arrow ((***))
12 import Control.Monad (guard, join, liftM)
13 import Control.Monad.IO.Class (liftIO)
14 import Control.Monad.Trans.Except (ExceptT(..), throwE)
15 import Control.Monad.Trans.Class (lift)
16 import qualified Data.Char
17 import qualified Data.Decimal
18 import qualified Data.Either
19 import qualified Data.List
20 import Data.List.NonEmpty (NonEmpty(..))
21 import qualified Data.Map.Strict as Data.Map
22 import Data.Maybe (fromMaybe)
23 import qualified Data.Time.Calendar as Time
24 import qualified Data.Time.Clock as Time
25 import qualified Data.Time.LocalTime as Time
26 import Data.Time.LocalTime (TimeZone(..))
27 import Data.Typeable ()
28 import qualified Text.Parsec as R hiding (satisfy, char, string, anyChar, crlf, newline, space, spaces, noneOf, oneOf)
29 import Text.Parsec (Stream, ParsecT, (<|>), (<?>))
30 import qualified Text.Parsec.Pos as R
31 import qualified Data.Text.IO as Text.IO (readFile)
32 import qualified Data.Text as Text
33 import qualified System.FilePath.Posix as Path
35 import qualified Hcompta.Calc.Balance as Calc.Balance
36 import qualified Hcompta.Model.Account as Account
37 import Hcompta.Model.Account (Account)
38 import qualified Hcompta.Model.Amount as Amount
39 import Hcompta.Model.Amount (Amount)
40 import qualified Hcompta.Model.Amount.Style as Style
41 import qualified Hcompta.Model.Amount.Unit as Unit
42 import Hcompta.Model.Amount.Unit (Unit)
43 import qualified Hcompta.Model.Transaction as Transaction
44 import Hcompta.Model.Transaction (Transaction, Comment)
45 import qualified Hcompta.Model.Transaction.Posting as Posting
46 import Hcompta.Model.Transaction (Posting)
47 import qualified Hcompta.Model.Transaction.Tag as Tag
48 import Hcompta.Model.Transaction (Tag)
49 import qualified Hcompta.Model.Date as Date
50 import Hcompta.Model.Date (Date)
51 import Hcompta.Format.Ledger.Journal as Journal
52 import qualified Hcompta.Lib.Regex as Regex
53 import Hcompta.Lib.Regex (Regex)
54 import qualified Hcompta.Lib.Parsec as R
55 import qualified Hcompta.Lib.Path as Path
59 { context_account_prefix :: !(Maybe Account)
60 , context_aliases_exact :: !(Data.Map.Map Account Account)
61 , context_aliases_joker :: ![(Account.Joker, Account)]
62 , context_aliases_regex :: ![(Regex, Account)]
63 , context_date :: !Date
64 , context_unit_and_style :: !(Maybe (Amount.Unit, Amount.Style))
65 , context_journal :: !Journal
66 , context_year :: !Date.Year
69 nil_Context :: Context
72 { context_account_prefix = Nothing
73 , context_aliases_exact = Data.Map.empty
74 , context_aliases_joker = []
75 , context_aliases_regex = []
76 , context_date = Date.nil
77 , context_unit_and_style = Nothing
78 , context_journal = Journal.nil
79 , context_year = (\(year, _ , _) -> year) $
80 Time.toGregorian $ Time.utctDay $
81 Journal.last_read_time Journal.nil
85 = Error_year_or_day_is_missing
86 | Error_invalid_day (Integer, Int, Int)
87 | Error_invalid_time_of_day (Integer, Integer, Integer)
88 | Error_transaction_not_equilibrated [Calc.Balance.Unit_Sum]
89 | Error_virtual_transaction_not_equilibrated [Calc.Balance.Unit_Sum]
90 | Error_reading_file FilePath Exception.IOException
91 | Error_including_file FilePath [R.Error Error]
94 -- | Parse either '-' into 'negate', or '+' or '' into 'id'.
95 sign :: (Stream s m Char, Num i) => ParsecT s u m (i -> i)
97 (R.char '-' >> return negate)
98 <|> (R.char '+' >> return id)
101 -- * Parsing 'Account'
103 account_name_sep :: Char
104 account_name_sep = ':'
106 -- | Parse an 'Account'.
107 account :: Stream s m Char => ParsecT s u m Account
109 R.notFollowedBy $ R.space_horizontal
110 Account.from_List <$> do
111 R.many1_separated account_name $ R.char account_name_sep
113 -- | Parse an Account.'Account.Name'.
114 account_name :: Stream s m Char => ParsecT s u m Account.Name
117 R.many1 $ R.try account_name_char
119 account_name_char :: Stream s m Char => ParsecT s u m Char
120 account_name_char = do
123 _ | c == comment_begin -> R.parserZero
124 _ | c == account_name_sep -> R.parserZero
125 _ | R.is_space_horizontal c -> do
126 _ <- R.notFollowedBy $ R.space_horizontal
127 return c <* (R.lookAhead $ R.try $
128 ( R.try (R.char account_name_sep)
129 <|> account_name_char
131 _ | not (Data.Char.isSpace c) -> return c
134 -- | Parse an Account.'Account.Joker_Name'.
135 account_joker_name :: Stream s m Char => ParsecT s u m Account.Joker_Name
136 account_joker_name = do
137 n <- R.option Nothing $ (Just <$> account_name)
139 Nothing -> R.char account_name_sep >> (return $ Account.Joker_Any)
140 Just n' -> return $ Account.Joker_Name n'
142 -- | Parse an Account.'Account.Joker'.
143 account_joker :: Stream s m Char => ParsecT s u m Account.Joker
145 R.notFollowedBy $ R.space_horizontal
146 R.many1_separated account_joker_name $ R.char account_name_sep
148 -- | Parse a 'Regex'.
149 account_regex :: Stream s m Char => ParsecT s u m Regex
151 re <- R.many1 $ R.satisfy (not . R.is_space_horizontal)
154 -- | Parse an Account.'Account.Filter'.
155 account_pattern :: Stream s m Char => ParsecT s u m Account.Pattern
158 [ Account.Pattern_Exact <$> (R.char '=' >> account)
159 , Account.Pattern_Joker <$> (R.char '*' >> account_joker)
160 , Account.Pattern_Regex <$> (R.option '~' (R.char '~') >> account_regex)
163 -- * Parsing 'Amount'
165 -- | Parse an 'Amount'.
166 amount :: Stream s m Char => ParsecT s u m Amount
170 R.option Nothing $ do
172 s <- R.many $ R.space_horizontal
173 return $ Just $ (u, not $ null s)
174 (quantity_, style) <- do
181 , grouping_fractional
184 [ quantity '_' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
185 , quantity '_' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
186 , quantity ',' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
187 , quantity '.' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
189 let int = Data.List.concat integral
190 let frac_flat = Data.List.concat fractional
191 let frac = reverse $ Data.List.dropWhile (== '0') $ reverse $ frac_flat
192 let place = length frac
194 let mantissa = R.integer_of_digits 10 $ int ++ frac
196 ( Data.Decimal.Decimal
201 , Style.grouping_integral
202 , Style.grouping_fractional
203 , Style.precision = fromIntegral $ length frac_flat
206 (unit_, unit_side, unit_spaced) <-
209 return (u, Just Style.Side_Left, Just s)
211 R.option (Unit.nil, Nothing, Nothing) $ R.try $ do
212 s <- R.many $ R.space_horizontal
214 return $ (u, Just Style.Side_Right, Just $ not $ null s)
217 { Amount.quantity = left_signing $ quantity_
218 , Amount.style = style
222 , Amount.unit = unit_
227 { integral :: [String]
228 , fractional :: [String]
229 , fractioning :: Maybe Style.Fractioning
230 , grouping_integral :: Maybe Style.Grouping
231 , grouping_fractional :: Maybe Style.Grouping
234 -- | Parse a 'Quantity'.
237 => Char -- ^ Integral grouping separator.
238 -> Char -- ^ Fractioning separator.
239 -> Char -- ^ Fractional grouping separator.
240 -> ParsecT s u m Quantity
241 quantity int_group_sep frac_sep frac_group_sep = do
242 (integral, grouping_integral) <- do
245 [] -> return ([], Nothing)
247 t <- R.many $ R.char int_group_sep >> R.many1 R.digit
249 return (digits, grouping_of_digits int_group_sep digits)
250 (fractional, fractioning, grouping_fractional) <-
253 _ -> R.option ([], Nothing, Nothing)) $ do
254 fractioning <- R.char frac_sep
256 t <- R.many $ R.char frac_group_sep >> R.many1 R.digit
258 return (digits, Just fractioning
259 , grouping_of_digits frac_group_sep $ reverse digits)
266 , grouping_fractional
269 grouping_of_digits :: Char -> [String] -> Maybe Style.Grouping
270 grouping_of_digits group_sep digits =
275 Style.Grouping group_sep $
276 canonicalize_grouping $
278 canonicalize_grouping :: [Int] -> [Int]
279 canonicalize_grouping groups =
280 Data.List.foldl -- NOTE: remove duplicates at beginning and reverse.
281 (\acc l0 -> case acc of
282 l1:_ -> if l0 == l1 then acc else l0:acc
284 case groups of -- NOTE: keep only longer at beginning.
285 l0:l1:t -> if l0 > l1 then groups else l1:t
288 -- | Parse an 'Unit'.
289 unit :: Stream s m Char => ParsecT s u m Unit
291 (quoted <|> unquoted) <?> "unit"
293 unquoted :: Stream s m Char => ParsecT s u m Unit
298 case Data.Char.generalCategory c of
299 Data.Char.CurrencySymbol -> True
300 Data.Char.LowercaseLetter -> True
301 Data.Char.ModifierLetter -> True
302 Data.Char.OtherLetter -> True
303 Data.Char.TitlecaseLetter -> True
304 Data.Char.UppercaseLetter -> True
306 quoted :: Stream s m Char => ParsecT s u m Unit
309 R.between (R.char '"') (R.char '"') $
315 directive_alias :: Stream s m Char => ParsecT s Context m ()
317 _ <- R.string "alias"
318 R.skipMany1 $ R.space_horizontal
319 pattern <- account_pattern
320 R.skipMany $ R.space_horizontal
322 R.skipMany $ R.space_horizontal
324 R.skipMany $ R.space_horizontal
326 Account.Pattern_Exact acct -> R.modifyState $ \ctx -> ctx{context_aliases_exact=
327 Data.Map.insert acct repl $ context_aliases_exact ctx}
328 Account.Pattern_Joker jokr -> R.modifyState $ \ctx -> ctx{context_aliases_joker=
329 (jokr, repl):context_aliases_joker ctx}
330 Account.Pattern_Regex regx -> R.modifyState $ \ctx -> ctx{context_aliases_regex=
331 (regx, repl):context_aliases_regex ctx}
334 -- | Parse the year, month and day separator: '/' or '-'.
335 date_separator :: Stream s m Char => ParsecT s u m Char
336 date_separator = R.satisfy (\c -> c == '/' || c == '-')
338 -- | Parse the hour, minute and second separator: ':'.
339 hour_separator :: Stream s m Char => ParsecT s u m Char
340 hour_separator = R.char ':'
344 -- | Parse a 'Date' in [YYYY/]MM/DD [HH:MM[:SS][TZ]] format.
346 :: (Stream s (R.Error_State Error m) Char, Monad m)
347 => Maybe Integer -> ParsecT s u (R.Error_State Error m) Date
349 n0 <- R.many1 R.digit
350 day_sep <- date_separator
351 n1 <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit
352 n2 <- R.option Nothing $ R.try $ do
354 Just <$> do R.try (R.count 2 R.digit) <|> R.count 1 R.digit
356 case (n2, def_year) of
357 (Nothing, Nothing) -> R.fail_with "date" (Error_year_or_day_is_missing)
358 (Nothing, Just year) -> return (year, n0, n1)
359 (Just d, _) -> return (R.integer_of_digits 10 n0, n1, d)
360 let month = fromInteger $ R.integer_of_digits 10 m
361 let day = fromInteger $ R.integer_of_digits 10 d
362 guard $ month >= 1 && month <= 12
363 guard $ day >= 1 && day <= 31
364 day_ <- case Time.fromGregorianValid year month day of
365 Nothing -> R.fail_with "date" (Error_invalid_day (year, month, day))
366 Just day_ -> return day_
367 (hour, minu, sec, tz) <-
368 R.option (0, 0, 0, Time.utc) $ R.try $ do
369 R.skipMany1 $ R.space_horizontal
370 hour <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit
371 sep <- hour_separator
372 minu <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit
373 sec <- R.option Nothing $ R.try $ do
375 Just <$> (R.try (R.count 2 R.digit) <|> R.count 1 R.digit)
376 tz <- R.option Time.utc $ R.try $ do
377 R.skipMany $ R.space_horizontal
380 ( R.integer_of_digits 10 hour
381 , R.integer_of_digits 10 minu
382 , maybe 0 (R.integer_of_digits 10) sec
384 tod <- case Time.makeTimeOfDayValid
388 Nothing -> R.fail_with "date" (Error_invalid_time_of_day (hour, minu, sec))
389 Just tod -> return tod
392 (Time.LocalTime day_ tod)
396 time_zone :: Stream s m Char => ParsecT s u m TimeZone
398 -- DOC: http://www.timeanddate.com/time/zones/
399 -- TODO: only a few time zones are suported below.
400 -- TODO: check the timeZoneSummerOnly values
402 [ R.char 'A' >> R.choice
403 [ R.string "ST" >> return (TimeZone ((-4) * 60) False "AST")
404 , R.string "DT" >> return (TimeZone ((-3) * 60) True "ADT")
405 , return (TimeZone ((-1) * 60) False "A")
407 , R.char 'B' >> R.choice
408 [ R.string "ST" >> return (TimeZone ((-11) * 60) False "BST")
409 , R.string "DT" >> return (TimeZone ((-10) * 60) True "BDT")
411 , R.char 'C' >> R.choice
412 [ R.char 'E' >> R.choice
413 [ R.string "T" >> return (TimeZone ((1) * 60) True "CET")
414 , R.string "ST" >> return (TimeZone ((2) * 60) False "CEST")
416 , R.string "ST" >> return (TimeZone ((-6) * 60) False "CST")
417 , R.string "DT" >> return (TimeZone ((-5) * 60) True "CDT")
419 , R.char 'E' >> R.choice
420 [ R.string "ST" >> return (TimeZone ((-5) * 60) False "EST")
421 , R.string "DT" >> return (TimeZone ((-4) * 60) True "EDT")
423 , R.string "GMT" >> return (TimeZone 0 False "GMT")
424 , R.char 'H' >> R.choice
425 [ R.string "ST" >> return (TimeZone ((-10) * 60) False "HST")
426 , R.string "DT" >> return (TimeZone (( -9) * 60) True "HDT")
428 , R.char 'M' >> R.choice
429 [ R.string "ST" >> return (TimeZone ((-7) * 60) False "MST")
430 , R.string "DT" >> return (TimeZone ((-6) * 60) True "MDT")
431 , return (TimeZone ((-12) * 60) False "M")
433 , R.char 'N' >> R.choice
434 [ R.string "ST" >> return (TimeZone ((-3) * 60 - 30) False "NST")
435 , return (TimeZone (1 * 60) False "N")
437 , R.char 'P' >> R.choice
438 [ R.string "ST" >> return (TimeZone ((-8) * 60) False "PST")
439 , R.string "DT" >> return (TimeZone ((-7) * 60) True "PDT")
441 , R.char 'Y' >> R.choice
442 [ R.string "ST" >> return (TimeZone ((-9) * 60) False "YST")
443 , R.string "DT" >> return (TimeZone ((-8) * 60) True "YDT")
444 , return (TimeZone (12 * 60) False "Y")
446 , R.char 'Z' >> return (TimeZone 0 False "Z")
450 time_zone_digits :: Stream s m Char => ParsecT s u m TimeZone
451 {-# INLINEABLE time_zone_digits #-}
452 time_zone_digits = do
454 hour <- R.integer_of_digits 10 <$> R.count 2 R.digit
455 _ <- R.option ':' (R.char ':')
456 minute <- R.integer_of_digits 10 <$> R.count 2 R.digit
458 { timeZoneMinutes = sign_ (fromInteger hour * 60 + fromInteger minute)
459 , timeZoneSummerOnly = False
460 , timeZoneName = Time.timeZoneOffsetString tz
464 -- * Parsing 'Comment'
466 comment_begin :: Char
469 comment :: Stream s m Char => ParsecT s u m Comment
471 _ <- R.char comment_begin
473 R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
476 comments :: Stream s m Char => ParsecT s u m [Comment]
480 R.many1_separated comment (R.new_line >> R.skipMany R.space_horizontal)
486 tag_value_sep :: Char
493 tag :: Stream s m Char => ParsecT s u m Tag
496 _ <- R.char tag_value_sep
501 tag_name :: Stream s m Char => ParsecT s u m Tag.Name
504 R.many1 $ R.satisfy (\c -> c /= tag_value_sep && not (Data.Char.isSpace c))
506 tag_value :: Stream s m Char => ParsecT s u m Tag.Value
509 R.manyTill R.anyChar $ do
511 R.try (R.char tag_sep >> R.many R.space_horizontal >> tag_name >> R.char tag_value_sep >> return ())
515 tags :: Stream s m Char => ParsecT s u m Tag.By_Name
518 R.many_separated tag $ do
520 R.skipMany $ R.space_horizontal
523 not_tag :: Stream s m Char => ParsecT s u m ()
525 R.skipMany $ R.try $ do
526 R.skipMany $ R.satisfy
527 (\c -> c /= tag_value_sep
528 && not (Data.Char.isSpace c))
531 -- * Parsing 'Posting'
533 -- | Parse a 'Posting'.
535 :: (Stream s (R.Error_State Error m) Char, Monad m)
536 => ParsecT s Context (R.Error_State Error m) (Posting, Posting.Type)
539 sourcepos <- R.getPosition
540 R.skipMany1 $ R.space_horizontal
542 R.skipMany $ R.space_horizontal
544 let (type_, account_) = posting_type acct
548 _ <- R.count 2 R.space_horizontal
549 R.skipMany $ R.space_horizontal
551 if u == Unit.nil then id
553 Data.Map.adjust (\a ->
554 a{ Amount.style = s{Style.precision = Style.precision $ Amount.style a}
557 (context_unit_and_style ctx) .
558 Amount.from_List <$> do
559 R.many_separated amount $ do
560 R.skipMany $ R.space_horizontal
561 _ <- R.char amount_sep
562 R.skipMany $ R.space_horizontal
564 , return Data.Map.empty
566 R.skipMany $ R.space_horizontal
567 -- TODO: balance assertion
569 comments_ <- comments
570 let tags_ = tags_of_comments comments_
572 case Data.Map.lookup "date" tags_ of
575 let date2s = Data.Map.lookup "date2" tags_ -- NOTE: support hledger's date2
577 (flip mapM) (dates ++ fromMaybe [] date2s) $ \s ->
578 R.runParserT_with_Error_fail "tag date"
579 (date (Just $ context_year ctx) <* R.eof) ()
581 >>= \dates_ -> case (dates, date2s) of -- NOTE: put hledger's date2 at least in second position
583 return $ context_date ctx:dates_
585 return (Posting.Posting
586 { Posting.account=account_
587 , Posting.amounts=amounts_
588 , Posting.comments=comments_
589 , Posting.dates=dates_
590 , Posting.sourcepos=sourcepos
591 , Posting.status=status_
599 tags_of_comments :: [Comment] -> Tag.By_Name
601 Data.Map.unionsWith (++)
603 ( Data.Either.either (const Data.Map.empty) id
604 . R.runParser (not_tag >> tags <* R.eof) () "" )
606 status :: Stream s m Char => ParsecT s u m Transaction.Status
609 R.skipMany $ R.space_horizontal
610 _ <- (R.char '*' <|> R.char '!')
615 -- | Return the Posting.'Posting.Type' and stripped 'Account' of the given 'Account'.
616 posting_type :: Account -> (Posting.Type, Account)
618 fromMaybe (Posting.Type_Regular, acct) $ do
621 case Text.stripPrefix virtual_begin name of
624 Text.stripSuffix virtual_end name'
625 >>= return . Text.strip
626 guard $ not $ Text.null name''
627 Just (Posting.Type_Virtual, name'':|[])
630 Text.stripPrefix virtual_balanced_begin name
631 >>= Text.stripSuffix virtual_balanced_end
632 >>= return . Text.strip
633 guard $ not $ Text.null name'
634 Just (Posting.Type_Virtual_Balanced, name':|[])
635 first_name:|acct' -> do
636 let rev_acct' = Data.List.reverse acct'
637 let last_name = Data.List.head rev_acct'
638 case Text.stripPrefix virtual_begin first_name
639 >>= return . Text.stripStart of
640 Just first_name' -> do
642 Text.stripSuffix virtual_end last_name
643 >>= return . Text.stripEnd
644 guard $ not $ Text.null first_name'
645 guard $ not $ Text.null last_name'
647 ( Posting.Type_Virtual
649 Data.List.reverse (last_name':Data.List.tail rev_acct')
653 Text.stripPrefix virtual_balanced_begin first_name
654 >>= return . Text.stripStart
656 Text.stripSuffix virtual_balanced_end last_name
657 >>= return . Text.stripEnd
658 guard $ not $ Text.null first_name'
659 guard $ not $ Text.null last_name'
661 ( Posting.Type_Virtual_Balanced
663 Data.List.reverse (last_name':Data.List.tail rev_acct')
666 virtual_begin = Text.singleton posting_type_virtual_begin
667 virtual_end = Text.singleton posting_type_virtual_end
668 virtual_balanced_begin = Text.singleton posting_type_virtual_balanced_begin
669 virtual_balanced_end = Text.singleton posting_type_virtual_balanced_end
671 posting_type_virtual_begin :: Char
672 posting_type_virtual_begin = '('
673 posting_type_virtual_balanced_begin :: Char
674 posting_type_virtual_balanced_begin = '['
675 posting_type_virtual_end :: Char
676 posting_type_virtual_end = ')'
677 posting_type_virtual_balanced_end :: Char
678 posting_type_virtual_balanced_end = ']'
680 -- * Parsing 'Transaction'
683 :: (Stream s (R.Error_State Error m) Char, Monad m)
684 => ParsecT s Context (R.Error_State Error m) Transaction
686 sourcepos <- R.getPosition
692 _ -> return x <* R.new_line
693 date_ <- date (Just $ context_year ctx)
695 R.option [] $ R.try $ do
696 R.skipMany $ R.space_horizontal
698 R.skipMany $ R.space_horizontal
700 (date (Just $ context_year ctx)) $
702 R.many $ R.space_horizontal
704 >> (R.many $ R.space_horizontal)
705 R.skipMany $ R.space_horizontal
707 code_ <- R.option "" $ R.try code
708 R.skipMany $ R.space_horizontal
709 description_ <- description
710 R.skipMany $ R.space_horizontal
711 comments_after <- comments
713 Data.Map.unionWith (++)
714 (tags_of_comments comments_before)
715 (tags_of_comments comments_after)
717 (postings_unchecked, postings_not_regular) <-
718 ((Posting.from_List . Data.List.map fst) *** id) .
719 Data.List.partition ((Posting.Type_Regular ==) . snd) <$>
720 R.many1_separated posting R.new_line
721 let (virtual_postings, balanced_virtual_postings_unchecked) =
722 join (***) (Posting.from_List . Data.List.map fst) $
723 Data.List.partition ((Posting.Type_Virtual ==) . snd)
726 case snd $ Calc.Balance.infer_equilibrium postings_unchecked of
727 Left ko -> R.fail_with "transaction infer_equilibrium" (Error_transaction_not_equilibrated ko)
728 Right ok -> return ok
729 balanced_virtual_postings <-
730 case snd $ Calc.Balance.infer_equilibrium balanced_virtual_postings_unchecked of
731 Left ko -> R.fail_with "transaction infer_equilibrium" (Error_virtual_transaction_not_equilibrated ko)
732 Right ok -> return ok
734 Transaction.Transaction
735 { Transaction.code=code_
736 , Transaction.comments_before
737 , Transaction.comments_after
738 , Transaction.dates=(date_, dates_)
739 , Transaction.description=description_
740 , Transaction.postings
741 , Transaction.virtual_postings
742 , Transaction.balanced_virtual_postings
743 , Transaction.sourcepos
744 , Transaction.status=status_
745 , Transaction.tags=tags_
752 code :: Stream s m Char => ParsecT s Context m Transaction.Code
755 R.skipMany $ R.space_horizontal
756 R.between (R.char '(') (R.char ')') $
757 R.many $ R.satisfy (\c -> c /= ')' && not (R.is_space_horizontal c))
760 description :: Stream s m Char => ParsecT s u m Transaction.Description
763 R.many $ R.try description_char
766 description_char :: Stream s m Char => ParsecT s u m Char
767 description_char = do
770 _ | c == comment_begin -> R.parserZero
771 _ | R.is_space_horizontal c -> return c <* (R.lookAhead $ R.try $ description_char)
772 _ | not (Data.Char.isSpace c) -> return c
775 -- * Parsing directives
777 default_year :: Stream s m Char => ParsecT s Context m ()
779 year <- R.integer_of_digits 10 <$> R.many1 R.digit
780 R.skipMany R.space_horizontal >> R.new_line
781 context_ <- R.getState
782 R.setState context_{context_year=year}
785 default_unit_and_style :: Stream s m Char => ParsecT s Context m ()
786 default_unit_and_style = (do
788 R.skipMany R.space_horizontal >> R.new_line
789 context_ <- R.getState
790 R.setState context_{context_unit_and_style =
792 ( Amount.unit amount_
793 , Amount.style amount_ )}
794 ) <?> "default unit and style"
797 :: Stream s (R.Error_State Error IO) Char
798 => ParsecT s Context (R.Error_State Error IO) ()
800 sourcepos <- R.getPosition
801 filename <- R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
802 context_ <- R.getState
803 let journal_ = context_journal context_
804 let cwd = Path.takeDirectory (R.sourceName sourcepos)
805 file_path <- liftIO $ Path.abs cwd filename
807 liftIO $ Exception.catch
808 (liftM return $ readFile file_path)
809 (return . R.fail_with "include reading" . Error_reading_file file_path)
811 (journal_included, context_included) <- do
813 R.runParserT_with_Error (R.and_state $ journal_rec file_path)
814 context_{context_journal = Journal.nil}
817 Right ok -> return ok
818 Left ko -> R.fail_with "include parsing" (Error_including_file file_path ko)
820 context_included{context_journal=
821 journal_{Journal.includes=
822 journal_included{Journal.file=file_path}
823 : Journal.includes journal_}}
826 -- * Parsing 'Journal'
829 :: Stream s (R.Error_State Error IO) Char
831 -> ParsecT s Context (R.Error_State Error IO) Journal
833 currentLocalTime <- liftIO $
835 <$> Time.getCurrentTimeZone
836 <*> Time.getCurrentTime
837 let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
838 context_ <- R.getState
839 R.setState $ context_{context_year=currentLocalYear}
844 :: Stream s (R.Error_State Error IO) Char
846 -> ParsecT s Context (R.Error_State Error IO) Journal
847 journal_rec file_ = do
848 last_read_time <- lift $ liftIO Time.getCurrentTime
851 [ R.skipMany1 R.space
853 [ R.string "Y" >> return default_year
854 , R.string "D" >> return default_unit_and_style
855 , R.string "!include" >> return include
857 >>= \r -> R.skipMany1 R.space_horizontal >> r)
860 context_' <- R.getState
861 let j = context_journal context_'
862 R.setState $ context_'{context_journal=
863 j{Journal.transactions=
864 Data.Map.insertWith (flip (++))
865 -- NOTE: flip-ing preserves order but slows down
866 -- when many transactions have the very same date.
867 (Date.to_UTC $ fst $ Transaction.dates t) [t]
868 (Journal.transactions j)}}
869 R.new_line <|> R.eof))
870 , R.try (comment >> return ())
873 journal_ <- context_journal <$> R.getState
876 { Journal.file = file_
877 , Journal.last_read_time
878 , Journal.includes = reverse $ Journal.includes journal_
881 -- ** Parsing 'Journal' from a file
883 file :: FilePath -> ExceptT [R.Error Error] IO Journal
887 (liftM Right $ Text.IO.readFile path) $
888 \ko -> return $ Left $
889 [ R.Error_Custom (R.initialPos path) $ Error_reading_file path ko ]
890 >>= liftIO . R.runParserT_with_Error (journal path) nil_Context path
892 Left ko -> throwE $ ko
893 Right ok -> ExceptT $ return $ Right ok