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 qualified Data.Char
16 import qualified Data.Decimal
17 import qualified Data.Either
18 import qualified Data.List
19 import Data.List.NonEmpty (NonEmpty(..))
20 import qualified Data.Map.Strict as Data.Map
21 import Data.Maybe (fromMaybe)
22 import qualified Data.Time.Calendar as Time
23 import qualified Data.Time.Clock as Time
24 import qualified Data.Time.LocalTime as Time
25 import Data.Time.LocalTime (TimeZone(..))
26 import Data.Typeable ()
27 import qualified Text.Parsec as R
28 import Text.Parsec (Stream, ParsecT, (<|>), (<?>))
29 import qualified Data.Text.IO as Text.IO (readFile)
30 import qualified Data.Text as Text
31 import qualified System.FilePath.Posix as Path
33 import qualified Hcompta.Calc.Balance as Calc.Balance
34 import qualified Hcompta.Model.Account as Account
35 import Hcompta.Model.Account (Account)
36 import qualified Hcompta.Model.Amount as Amount
37 import Hcompta.Model.Amount (Amount)
38 import qualified Hcompta.Model.Amount.Style as Style
39 import qualified Hcompta.Model.Amount.Unit as Unit
40 import Hcompta.Model.Amount.Unit (Unit)
41 import qualified Hcompta.Model.Transaction as Transaction
42 import Hcompta.Model.Transaction (Transaction, Comment)
43 import qualified Hcompta.Model.Transaction.Posting as Posting
44 import Hcompta.Model.Transaction (Posting)
45 import qualified Hcompta.Model.Transaction.Tag as Tag
46 import Hcompta.Model.Transaction (Tag)
47 import qualified Hcompta.Model.Date as Date
48 import Hcompta.Model.Date (Date)
49 import Hcompta.Format.Ledger.Journal as Journal
50 import qualified Hcompta.Lib.Regex as Regex
51 import Hcompta.Lib.Regex (Regex)
52 import qualified Hcompta.Lib.Parsec as R
53 import qualified Hcompta.Lib.Path as Path
57 { context_account_prefix :: !(Maybe Account)
58 , context_aliases_exact :: !(Data.Map.Map Account Account)
59 , context_aliases_joker :: ![(Account.Joker, Account)]
60 , context_aliases_regex :: ![(Regex, Account)]
61 , context_date :: !Date
62 , context_unit_and_style :: !(Maybe (Amount.Unit, Amount.Style))
63 , context_journal :: !Journal
64 , context_year :: !Date.Year
67 nil_Context :: Context
70 { context_account_prefix = Nothing
71 , context_aliases_exact = Data.Map.empty
72 , context_aliases_joker = []
73 , context_aliases_regex = []
74 , context_date = Date.nil
75 , context_unit_and_style = Nothing
76 , context_journal = Journal.nil
77 , context_year = (\(year, _ , _) -> year) $
78 Time.toGregorian $ Time.utctDay $
79 Journal.last_read_time Journal.nil
82 -- | Parse either '-' into 'negate', or '+' or '' into 'id'.
83 sign :: (Stream s m Char, Num i) => ParsecT s u m (i -> i)
85 (R.char '-' >> return negate)
86 <|> (R.char '+' >> return id)
89 -- * Parsing 'Account'
91 account_name_sep :: Char
92 account_name_sep = ':'
94 -- | Parse an 'Account'.
95 account :: Stream s m Char => ParsecT s u m Account
97 R.notFollowedBy $ R.space_horizontal
98 Account.from_List <$> do
99 R.many1_separated account_name $ R.char account_name_sep
101 -- | Parse an Account.'Account.Name'.
102 account_name :: Stream s m Char => ParsecT s u m Account.Name
105 R.many1 $ R.try account_name_char
107 account_name_char :: Stream s m Char => ParsecT s u m Char
108 account_name_char = do
111 _ | c == comment_begin -> R.parserZero
112 _ | c == account_name_sep -> R.parserZero
113 _ | R.is_space_horizontal c -> do
114 _ <- R.notFollowedBy $ R.space_horizontal
115 return c <* (R.lookAhead $ R.try $
116 ( R.try (R.char account_name_sep)
117 <|> account_name_char
119 _ | not (Data.Char.isSpace c) -> return c
122 -- | Parse an Account.'Account.Joker_Name'.
123 account_joker_name :: Stream s m Char => ParsecT s u m Account.Joker_Name
124 account_joker_name = do
125 n <- R.option Nothing $ (Just <$> account_name)
127 Nothing -> R.char account_name_sep >> (return $ Account.Joker_Any)
128 Just n' -> return $ Account.Joker_Name n'
130 -- | Parse an Account.'Account.Joker'.
131 account_joker :: Stream s m Char => ParsecT s u m Account.Joker
133 R.notFollowedBy $ R.space_horizontal
134 R.many1_separated account_joker_name $ R.char account_name_sep
136 -- | Parse a 'Regex'.
137 account_regex :: Stream s m Char => ParsecT s u m Regex
139 re <- R.many1 $ R.satisfy (not . R.is_space_horizontal)
142 -- | Parse an Account.'Account.Filter'.
143 account_pattern :: Stream s m Char => ParsecT s u m Account.Pattern
146 [ Account.Pattern_Exact <$> (R.char '=' >> account)
147 , Account.Pattern_Joker <$> (R.char '*' >> account_joker)
148 , Account.Pattern_Regex <$> (R.option '~' (R.char '~') >> account_regex)
151 -- * Parsing 'Amount'
153 -- | Parse an 'Amount'.
154 amount :: Stream s m Char => ParsecT s u m Amount
158 R.option Nothing $ do
160 s <- R.many $ R.space_horizontal
161 return $ Just $ (u, not $ null s)
162 (quantity_, style) <- do
169 , grouping_fractional
172 [ quantity '_' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
173 , quantity '_' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
174 , quantity ',' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
175 , quantity '.' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
177 let int = Data.List.concat integral
178 let frac_flat = Data.List.concat fractional
179 let frac = reverse $ Data.List.dropWhile (== '0') $ reverse $ frac_flat
180 let place = length frac
182 let mantissa = R.integer_of_digits 10 $ int ++ frac
184 ( Data.Decimal.Decimal
189 , Style.grouping_integral
190 , Style.grouping_fractional
191 , Style.precision = fromIntegral $ length frac_flat
194 (unit_, unit_side, unit_spaced) <-
197 return (u, Just Style.Side_Left, Just s)
199 R.option (Unit.nil, Nothing, Nothing) $ R.try $ do
200 s <- R.many $ R.space_horizontal
202 return $ (u, Just Style.Side_Right, Just $ not $ null s)
205 { Amount.quantity = left_signing $ quantity_
206 , Amount.style = style
210 , Amount.unit = unit_
215 { integral :: [String]
216 , fractional :: [String]
217 , fractioning :: Maybe Style.Fractioning
218 , grouping_integral :: Maybe Style.Grouping
219 , grouping_fractional :: Maybe Style.Grouping
222 -- | Parse a 'Quantity'.
225 => Char -- ^ Integral grouping separator.
226 -> Char -- ^ Fractioning separator.
227 -> Char -- ^ Fractional grouping separator.
228 -> ParsecT s u m Quantity
229 quantity int_group_sep frac_sep frac_group_sep = do
230 (integral, grouping_integral) <- do
233 [] -> return ([], Nothing)
235 t <- R.many $ R.char int_group_sep >> R.many1 R.digit
237 return (digits, grouping_of_digits int_group_sep digits)
238 (fractional, fractioning, grouping_fractional) <-
241 _ -> R.option ([], Nothing, Nothing)) $ do
242 fractioning <- R.char frac_sep
244 t <- R.many $ R.char frac_group_sep >> R.many1 R.digit
246 return (digits, Just fractioning
247 , grouping_of_digits frac_group_sep $ reverse digits)
254 , grouping_fractional
257 grouping_of_digits :: Char -> [String] -> Maybe Style.Grouping
258 grouping_of_digits group_sep digits =
263 Style.Grouping group_sep $
264 canonicalize_grouping $
266 canonicalize_grouping :: [Int] -> [Int]
267 canonicalize_grouping groups =
268 Data.List.foldl -- NOTE: remove duplicates at beginning and reverse.
269 (\acc l0 -> case acc of
270 l1:_ -> if l0 == l1 then acc else l0:acc
272 case groups of -- NOTE: keep only longer at beginning.
273 l0:l1:t -> if l0 > l1 then groups else l1:t
276 -- | Parse an 'Unit'.
277 unit :: Stream s m Char => ParsecT s u m Unit
279 (quoted <|> unquoted) <?> "unit"
281 unquoted :: Stream s m Char => ParsecT s u m Unit
286 case Data.Char.generalCategory c of
287 Data.Char.CurrencySymbol -> True
288 Data.Char.LowercaseLetter -> True
289 Data.Char.ModifierLetter -> True
290 Data.Char.OtherLetter -> True
291 Data.Char.TitlecaseLetter -> True
292 Data.Char.UppercaseLetter -> True
294 quoted :: Stream s m Char => ParsecT s u m Unit
297 R.between (R.char '"') (R.char '"') $
303 directive_alias :: Stream s m Char => ParsecT s Context m ()
305 _ <- R.string "alias"
306 R.skipMany1 $ R.space_horizontal
307 pattern <- account_pattern
308 R.skipMany $ R.space_horizontal
310 R.skipMany $ R.space_horizontal
312 R.skipMany $ R.space_horizontal
314 Account.Pattern_Exact acct -> R.modifyState $ \ctx -> ctx{context_aliases_exact=
315 Data.Map.insert acct repl $ context_aliases_exact ctx}
316 Account.Pattern_Joker jokr -> R.modifyState $ \ctx -> ctx{context_aliases_joker=
317 (jokr, repl):context_aliases_joker ctx}
318 Account.Pattern_Regex regx -> R.modifyState $ \ctx -> ctx{context_aliases_regex=
319 (regx, repl):context_aliases_regex ctx}
322 -- | Parse the year, month and day separator: '/' or '-'.
323 date_separator :: Stream s m Char => ParsecT s u m Char
324 date_separator = R.satisfy (\c -> c == '/' || c == '-')
326 -- | Parse the hour, minute and second separator: ':'.
327 hour_separator :: Stream s m Char => ParsecT s u m Char
328 hour_separator = R.char ':'
332 -- | Parse a 'Date' in [YYYY/]MM/DD [HH:MM[:SS][TZ]] format.
333 date :: Stream s m Char => Maybe Integer -> ParsecT s u m Date
335 n0 <- R.many1 R.digit
336 day_sep <- date_separator
337 n1 <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit
338 n2 <- R.option Nothing $ R.try $ do
340 Just <$> do R.try (R.count 2 R.digit) <|> R.count 1 R.digit
342 case (n2, def_year) of
343 (Nothing, Nothing) -> fail "year or day is missing"
344 (Nothing, Just year) -> return (year, n0, n1)
345 (Just d, _) -> return (R.integer_of_digits 10 n0, n1, d)
346 let month = fromInteger $ R.integer_of_digits 10 m
347 let day = fromInteger $ R.integer_of_digits 10 d
348 guard $ month >= 1 && month <= 12
349 guard $ day >= 1 && day <= 31
350 day_ <- case Time.fromGregorianValid year month day of
351 Nothing -> fail "invalid day"
352 Just day_ -> return day_
353 (hour, minu, sec, tz) <-
354 R.option (0, 0, 0, Time.utc) $ R.try $ do
355 R.skipMany1 $ R.space_horizontal
356 hour <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit
357 sep <- hour_separator
358 minu <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit
359 sec <- R.option Nothing $ R.try $ do
361 Just <$> (R.try (R.count 2 R.digit) <|> R.count 1 R.digit)
363 tz <- R.option Time.utc $ R.try $ do
364 R.skipMany $ R.space_horizontal
367 ( R.integer_of_digits 10 hour
368 , R.integer_of_digits 10 minu
369 , maybe 0 (R.integer_of_digits 10) sec
371 guard $ hour >= 0 && hour <= 23
372 guard $ minu >= 0 && minu <= 59
373 guard $ sec >= 0 && sec <= 60 -- NOTE: allow leap second
374 tod <- case Time.makeTimeOfDayValid
378 Nothing -> fail "invalid time of day"
379 Just tod -> return tod
382 (Time.LocalTime day_ tod)
386 time_zone :: Stream s m Char => ParsecT s u m TimeZone
388 -- DOC: http://www.timeanddate.com/time/zones/
389 -- TODO: only a few time zones are suported below.
390 -- TODO: check the timeZoneSummerOnly values
392 [ R.char 'A' >> R.choice
393 [ R.string "ST" >> return (TimeZone ((-4) * 60) False "AST")
394 , R.string "DT" >> return (TimeZone ((-3) * 60) True "ADT")
395 , return (TimeZone ((-1) * 60) False "A")
397 , R.char 'B' >> R.choice
398 [ R.string "ST" >> return (TimeZone ((-11) * 60) False "BST")
399 , R.string "DT" >> return (TimeZone ((-10) * 60) True "BDT")
401 , R.char 'C' >> R.choice
402 [ R.char 'E' >> R.choice
403 [ R.string "T" >> return (TimeZone ((1) * 60) True "CET")
404 , R.string "ST" >> return (TimeZone ((2) * 60) False "CEST")
406 , R.string "ST" >> return (TimeZone ((-6) * 60) False "CST")
407 , R.string "DT" >> return (TimeZone ((-5) * 60) True "CDT")
409 , R.char 'E' >> R.choice
410 [ R.string "ST" >> return (TimeZone ((-5) * 60) False "EST")
411 , R.string "DT" >> return (TimeZone ((-4) * 60) True "EDT")
413 , R.string "GMT" >> return (TimeZone 0 False "GMT")
414 , R.char 'H' >> R.choice
415 [ R.string "ST" >> return (TimeZone ((-10) * 60) False "HST")
416 , R.string "DT" >> return (TimeZone (( -9) * 60) True "HDT")
418 , R.char 'M' >> R.choice
419 [ R.string "ST" >> return (TimeZone ((-7) * 60) False "MST")
420 , R.string "DT" >> return (TimeZone ((-6) * 60) True "MDT")
421 , return (TimeZone ((-12) * 60) False "M")
423 , R.char 'N' >> R.choice
424 [ R.string "ST" >> return (TimeZone ((-3) * 60 - 30) False "NST")
425 , return (TimeZone (1 * 60) False "N")
427 , R.char 'P' >> R.choice
428 [ R.string "ST" >> return (TimeZone ((-8) * 60) False "PST")
429 , R.string "DT" >> return (TimeZone ((-7) * 60) True "PDT")
431 , R.char 'Y' >> R.choice
432 [ R.string "ST" >> return (TimeZone ((-9) * 60) False "YST")
433 , R.string "DT" >> return (TimeZone ((-8) * 60) True "YDT")
434 , return (TimeZone (12 * 60) False "Y")
436 , R.char 'Z' >> return (TimeZone 0 False "Z")
440 time_zone_digits :: Stream s m Char => ParsecT s u m TimeZone
441 {-# INLINEABLE time_zone_digits #-}
442 time_zone_digits = do
444 hour <- R.integer_of_digits 10 <$> R.count 2 R.digit
445 _ <- R.option ':' (R.char ':')
446 minute <- R.integer_of_digits 10 <$> R.count 2 R.digit
448 { timeZoneMinutes = sign_ (fromInteger hour * 60 + fromInteger minute)
449 , timeZoneSummerOnly = False
450 , timeZoneName = Time.timeZoneOffsetString tz
454 -- * Parsing 'Comment'
456 comment_begin :: Char
459 comment :: Stream s m Char => ParsecT s u m Comment
461 _ <- R.char comment_begin
463 R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
466 comments :: Stream s m Char => ParsecT s u m [Comment]
470 R.many1_separated comment (R.new_line >> R.skipMany R.space_horizontal)
476 tag_value_sep :: Char
483 tag :: Stream s m Char => ParsecT s u m Tag
486 _ <- R.char tag_value_sep
491 tag_name :: Stream s m Char => ParsecT s u m Tag.Name
494 R.many1 $ R.satisfy (\c -> c /= tag_value_sep && not (Data.Char.isSpace c))
496 tag_value :: Stream s m Char => ParsecT s u m Tag.Value
499 R.manyTill R.anyChar $ do
501 R.try (R.char tag_sep >> R.many R.space_horizontal >> tag_name >> R.char tag_value_sep >> return ())
505 tags :: Stream s m Char => ParsecT s u m Tag.By_Name
508 R.many_separated tag $ do
510 R.skipMany $ R.space_horizontal
513 not_tag :: Stream s m Char => ParsecT s u m ()
515 R.skipMany $ R.try $ do
516 R.skipMany $ R.satisfy
517 (\c -> c /= tag_value_sep
518 && not (Data.Char.isSpace c))
521 -- * Parsing 'Posting'
523 -- | Parse a 'Posting'.
524 posting :: Stream s m Char => ParsecT s Context m (Posting, Posting.Type)
527 sourcepos <- R.getPosition
528 R.skipMany1 $ R.space_horizontal
530 R.skipMany $ R.space_horizontal
532 let (type_, account_) = posting_type acct
536 _ <- R.count 2 R.space_horizontal
537 R.skipMany $ R.space_horizontal
539 if u == Unit.nil then id
541 Data.Map.adjust (\a ->
542 a{ Amount.style = s{Style.precision = Style.precision $ Amount.style a}
545 (context_unit_and_style ctx) .
546 Amount.from_List <$> do
547 R.many_separated amount $ do
548 R.skipMany $ R.space_horizontal
549 _ <- R.char amount_sep
550 R.skipMany $ R.space_horizontal
552 , return Data.Map.empty
554 R.skipMany $ R.space_horizontal
555 -- TODO: balance assertion
557 comments_ <- comments
558 let tags_ = tags_of_comments comments_
560 case Data.Map.lookup "date" tags_ of
563 let date2s = Data.Map.lookup "date2" tags_ -- NOTE: support hledger's date2
564 dates_ <- (flip mapM) (dates ++ fromMaybe [] date2s) $
565 R.runParserT (date (Just $ context_year ctx) <* R.eof) () ""
567 Left ko -> fail $ show ko
568 Right ok -> return ok
569 case (dates, date2s) of -- NOTE: put hledger's date2 at least in second position
571 return $ context_date ctx:dates_
573 return (Posting.Posting
574 { Posting.account=account_
575 , Posting.amounts=amounts_
576 , Posting.comments=comments_
577 , Posting.dates=dates_
578 , Posting.sourcepos=sourcepos
579 , Posting.status=status_
587 tags_of_comments :: [Comment] -> Tag.By_Name
589 Data.Map.unionsWith (++)
591 ( Data.Either.either (const Data.Map.empty) id
592 . R.runParser (not_tag >> tags <* R.eof) () "" )
594 status :: Stream s m Char => ParsecT s u m Transaction.Status
597 R.skipMany $ R.space_horizontal
598 _ <- (R.char '*' <|> R.char '!')
603 -- | Return the Posting.'Posting.Type' and stripped 'Account' of the given 'Account'.
604 posting_type :: Account -> (Posting.Type, Account)
606 fromMaybe (Posting.Type_Regular, acct) $ do
609 case Text.stripPrefix virtual_begin name of
612 Text.stripSuffix virtual_end name'
613 >>= return . Text.strip
614 guard $ not $ Text.null name''
615 Just (Posting.Type_Virtual, name'':|[])
618 Text.stripPrefix virtual_balanced_begin name
619 >>= Text.stripSuffix virtual_balanced_end
620 >>= return . Text.strip
621 guard $ not $ Text.null name'
622 Just (Posting.Type_Virtual_Balanced, name':|[])
623 first_name:|acct' -> do
624 let rev_acct' = Data.List.reverse acct'
625 let last_name = Data.List.head rev_acct'
626 case Text.stripPrefix virtual_begin first_name
627 >>= return . Text.stripStart of
628 Just first_name' -> do
630 Text.stripSuffix virtual_end last_name
631 >>= return . Text.stripEnd
632 guard $ not $ Text.null first_name'
633 guard $ not $ Text.null last_name'
635 ( Posting.Type_Virtual
637 Data.List.reverse (last_name':Data.List.tail rev_acct')
641 Text.stripPrefix virtual_balanced_begin first_name
642 >>= return . Text.stripStart
644 Text.stripSuffix virtual_balanced_end last_name
645 >>= return . Text.stripEnd
646 guard $ not $ Text.null first_name'
647 guard $ not $ Text.null last_name'
649 ( Posting.Type_Virtual_Balanced
651 Data.List.reverse (last_name':Data.List.tail rev_acct')
654 virtual_begin = Text.singleton posting_type_virtual_begin
655 virtual_end = Text.singleton posting_type_virtual_end
656 virtual_balanced_begin = Text.singleton posting_type_virtual_balanced_begin
657 virtual_balanced_end = Text.singleton posting_type_virtual_balanced_end
659 posting_type_virtual_begin :: Char
660 posting_type_virtual_begin = '('
661 posting_type_virtual_balanced_begin :: Char
662 posting_type_virtual_balanced_begin = '['
663 posting_type_virtual_end :: Char
664 posting_type_virtual_end = ')'
665 posting_type_virtual_balanced_end :: Char
666 posting_type_virtual_balanced_end = ']'
668 -- * Parsing 'Transaction'
670 transaction :: Stream s m Char => ParsecT s Context m Transaction
672 sourcepos <- R.getPosition
678 _ -> return x <* R.new_line
679 date_ <- date (Just $ context_year ctx)
681 R.option [] $ R.try $ do
682 R.skipMany $ R.space_horizontal
684 R.skipMany $ R.space_horizontal
686 (date (Just $ context_year ctx)) $
688 R.many $ R.space_horizontal
690 >> (R.many $ R.space_horizontal)
691 R.skipMany $ R.space_horizontal
693 code_ <- R.option "" $ R.try code
694 R.skipMany $ R.space_horizontal
695 description_ <- description
696 R.skipMany $ R.space_horizontal
697 comments_after <- comments
699 Data.Map.unionWith (++)
700 (tags_of_comments comments_before)
701 (tags_of_comments comments_after)
703 (postings_unchecked, postings_not_regular) <-
704 ((Posting.from_List . Data.List.map fst) *** id) .
705 Data.List.partition ((Posting.Type_Regular ==) . snd) <$>
706 R.many1_separated posting R.new_line
707 let (virtual_postings, balanced_virtual_postings_unchecked) =
708 join (***) (Posting.from_List . Data.List.map fst) $
709 Data.List.partition ((Posting.Type_Virtual ==) . snd)
712 case Calc.Balance.infer_equilibre postings_unchecked of
713 Left _l -> fail $ "transaction not-equilibrated"
714 Right ps -> return ps
715 balanced_virtual_postings <-
716 case Calc.Balance.infer_equilibre balanced_virtual_postings_unchecked of
717 Left _l -> fail $ "virtual transaction not-equilibrated"
718 Right ps -> return ps
720 Transaction.Transaction
721 { Transaction.code=code_
722 , Transaction.comments_before
723 , Transaction.comments_after
724 , Transaction.dates=(date_, dates_)
725 , Transaction.description=description_
726 , Transaction.postings
727 , Transaction.virtual_postings
728 , Transaction.balanced_virtual_postings
729 , Transaction.sourcepos
730 , Transaction.status=status_
731 , Transaction.tags=tags_
738 code :: Stream s m Char => ParsecT s Context m Transaction.Code
741 R.skipMany $ R.space_horizontal
742 R.between (R.char '(') (R.char ')') $
743 R.many $ R.satisfy (\c -> c /= ')' && not (R.is_space_horizontal c))
746 description :: Stream s m Char => ParsecT s u m Transaction.Description
749 R.many $ R.try description_char
752 description_char :: Stream s m Char => ParsecT s u m Char
753 description_char = do
756 _ | c == comment_begin -> R.parserZero
757 _ | R.is_space_horizontal c -> return c <* (R.lookAhead $ R.try $ description_char)
758 _ | not (Data.Char.isSpace c) -> return c
761 -- * Parsing directives
763 default_year :: Stream s m Char => ParsecT s Context m ()
765 year <- R.integer_of_digits 10 <$> R.many1 R.digit
766 R.skipMany R.space_horizontal >> R.new_line
767 context_ <- R.getState
768 R.setState context_{context_year=year}
771 default_unit_and_style :: Stream s m Char => ParsecT s Context m ()
772 default_unit_and_style = (do
774 R.skipMany R.space_horizontal >> R.new_line
775 context_ <- R.getState
776 R.setState context_{context_unit_and_style =
778 ( Amount.unit amount_
779 , Amount.style amount_ )}
780 ) <?> "default unit and style"
782 include :: Stream s IO Char => ParsecT s Context IO ()
784 sourcepos <- R.getPosition
785 filename <- R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
786 context_ <- R.getState
787 let journal_ = context_journal context_
788 let cwd = Path.takeDirectory (R.sourceName sourcepos)
789 file_ <- liftIO $ Path.abs cwd filename
790 (journal_included, context_included) <- liftIO $
793 (\ko -> fail $ concat -- TODO: i18n by using a custom data type
797 , ":\n", show (ko::Exception.IOException)
799 >>= R.runParserT (R.and_state $ journal_rec file_)
800 context_{context_journal = Journal.nil}
803 Left ko -> fail $ show ko
804 Right ok -> return ok
806 context_included{context_journal=
807 journal_{Journal.includes=
808 journal_included{Journal.file=file_}
809 : Journal.includes journal_}}
812 -- * Parsing 'Journal'
814 journal :: Stream s IO Char => FilePath -> ParsecT s Context IO Journal
816 currentLocalTime <- liftIO $
818 <$> Time.getCurrentTimeZone
819 <*> Time.getCurrentTime
820 let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
821 context_ <- R.getState
822 R.setState $ context_{context_year=currentLocalYear}
826 journal_rec :: Stream s IO Char => FilePath -> ParsecT s Context IO Journal
827 journal_rec file_ = do
828 last_read_time <- liftIO $ Time.getCurrentTime
831 [ R.skipMany1 R.space
833 [ R.string "Y" >> return default_year
834 , R.string "D" >> return default_unit_and_style
835 , R.string "!include" >> return include
837 >>= \r -> R.skipMany1 R.space_horizontal >> r)
840 context_' <- R.getState
841 let j = context_journal context_'
842 R.setState $ context_'{context_journal=
843 j{Journal.transactions=
844 Data.Map.insertWith (flip (++))
845 -- NOTE: flip-ing preserves order but slows down
846 -- when many transactions have the very same date.
847 (Date.to_UTC $ fst $ Transaction.dates t) [t]
848 (Journal.transactions j)}}
849 R.new_line <|> R.eof))
850 , R.try (comment >> return ())
853 journal_ <- context_journal <$> R.getState
856 { Journal.file = file_
857 , Journal.last_read_time
858 , Journal.includes = reverse $ Journal.includes journal_
861 -- ** Parsing 'Journal' from a file
863 file :: FilePath -> ExceptT String IO Journal
867 (liftM Right $ Text.IO.readFile path) $
868 \ko -> return $ Left $ show (ko::Exception.IOException)
869 >>= liftIO . R.runParserT (journal path) nil_Context path
871 Left ko -> throwE $ show ko
872 Right ok -> ExceptT $ return $ Right ok