1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE LambdaCase #-}
4 {-# LANGUAGE NamedFieldPuns #-}
5 {-# LANGUAGE OverloadedStrings #-}
6 {-# LANGUAGE ScopedTypeVariables #-}
7 {-# LANGUAGE TupleSections #-}
8 module Hcompta.Format.Ledger.Read where
10 import Control.Applicative ((<$>), (<*>), (<*))
11 import qualified Control.Exception as Exception
12 import Control.Arrow ((***))
13 import Control.Monad (guard, join, liftM, (>=>))
14 import Control.Monad.IO.Class (liftIO)
15 import Control.Monad.Trans.Except (ExceptT(..), throwE)
16 import qualified Data.Char
17 import qualified Data.Decimal
18 import qualified Data.Either
19 import qualified Data.List
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 (pack)
31 import qualified System.FilePath.Posix as Path
33 import qualified Hcompta.Model.Account as Account
34 import Hcompta.Model.Account (Account)
35 import qualified Hcompta.Model.Amount as Amount
36 import Hcompta.Model.Amount (Amount)
37 import qualified Hcompta.Model.Amount.Style as Style
38 import qualified Hcompta.Model.Amount.Unit as Unit
39 import Hcompta.Model.Amount.Unit (Unit)
40 import qualified Hcompta.Model.Transaction as Transaction
41 import Hcompta.Model.Transaction (Transaction, Comment)
42 import qualified Hcompta.Model.Transaction.Posting as Posting
43 import Hcompta.Model.Transaction (Posting)
44 import qualified Hcompta.Model.Transaction.Tag as Tag
45 import Hcompta.Model.Transaction (Tag)
46 import qualified Hcompta.Model.Date as Date
47 import Hcompta.Model.Date (Date)
48 import Hcompta.Format.Ledger.Journal as Journal
49 import qualified Hcompta.Lib.Regex as Regex
50 import Hcompta.Lib.Regex (Regex)
51 import Hcompta.Lib.Parsec as R
52 import qualified Hcompta.Lib.Path as Path
56 { context_account_prefix :: !Account
57 , context_aliases_exact :: !(Data.Map.Map Account Account)
58 , context_aliases_joker :: ![(Account.Joker, Account)]
59 , context_aliases_regex :: ![(Regex, Account)]
60 , context_date :: !Date
61 , context_unit_and_style :: !(Maybe (Amount.Unit, Amount.Style))
62 , context_journal :: !Journal
63 , context_year :: !Date.Year
66 nil_Context :: Context
69 { context_account_prefix = []
70 , context_aliases_exact = Data.Map.empty
71 , context_aliases_joker = []
72 , context_aliases_regex = []
73 , context_date = Date.nil
74 , context_unit_and_style = Nothing
75 , context_journal = Journal.nil
76 , context_year = (\(year, _ , _) -> year) $
77 Time.toGregorian $ Time.utctDay $
78 Journal.last_read_time Journal.nil
81 -- | Parse either '-' into 'negate', or '+' or '' into 'id'.
82 sign :: (Stream s m Char, Num i) => ParsecT s u m (i -> i)
84 (R.char '-' >> return negate)
85 <|> (R.char '+' >> return id)
88 -- * Parsing 'Account'
90 account_name_sep :: Char
91 account_name_sep = ':'
93 -- | Parse an 'Account'.
94 account :: Stream s m Char => ParsecT s u m Account
96 R.notFollowedBy $ space_horizontal
97 many1_separated account_name $ R.char account_name_sep
99 -- | Parse an Account.'Account.Name'.
100 account_name :: Stream s m Char => ParsecT s u m Account.Name
103 R.many1 $ R.try account_name_char
105 account_name_char :: Stream s m Char => ParsecT s u m Char
106 account_name_char = do
109 _ | c == comment_begin -> R.parserZero
110 _ | c == account_name_sep -> R.parserZero
111 _ | c == posting_type_virtual_end
112 || c == posting_type_virtual_balanced_end ->
113 return c <* (R.lookAhead $ R.try $ account_name_char)
114 _ | is_space_horizontal c -> do
115 _ <- R.notFollowedBy $ space_horizontal
116 return c <* (R.lookAhead $ R.try $
117 ( R.try (R.char account_name_sep)
118 <|> account_name_char
120 _ | not (Data.Char.isSpace c) -> return c
123 -- | Parse an Account.'Account.Joker_Name'.
124 account_joker_name :: Stream s m Char => ParsecT s u m Account.Joker_Name
125 account_joker_name = do
126 n <- R.option Nothing $ (Just <$> account_name)
128 Nothing -> R.char account_name_sep >> (return $ Account.Joker_Any)
129 Just n' -> return $ Account.Joker_Name n'
131 -- | Parse an Account.'Account.Joker'.
132 account_joker :: Stream s m Char => ParsecT s u m Account.Joker
134 R.notFollowedBy $ space_horizontal
135 many1_separated account_joker_name $ R.char account_name_sep
137 -- | Parse a 'Regex'.
138 account_regex :: Stream s m Char => ParsecT s u m Regex
140 re <- R.many1 $ R.satisfy (not . is_space_horizontal)
143 -- | Parse an Account.'Account.Filter'.
144 account_pattern :: Stream s m Char => ParsecT s u m Account.Pattern
147 [ Account.Pattern_Exact <$> (R.char '=' >> account)
148 , Account.Pattern_Joker <$> (R.char '*' >> account_joker)
149 , Account.Pattern_Regex <$> (R.option '~' (R.char '~') >> account_regex)
152 -- * Parsing 'Amount'
154 -- | Parse an 'Amount'.
155 amount :: Stream s m Char => ParsecT s u m Amount
159 R.option Nothing $ do
161 s <- R.many $ space_horizontal
162 return $ Just $ (u, not $ null s)
163 (quantity_, style) <- do
170 , grouping_fractional
173 [ quantity '_' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
174 , quantity '_' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
175 , quantity ',' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
176 , quantity '.' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
178 let int = Data.List.concat integral
179 let frac_flat = Data.List.concat fractional
180 let frac = reverse $ Data.List.dropWhile (== '0') $ reverse $ frac_flat
181 let place = length frac
183 let mantissa = R.integer_of_digits 10 $ int ++ frac
185 ( Data.Decimal.Decimal
190 , Style.grouping_integral
191 , Style.grouping_fractional
192 , Style.precision = fromIntegral $ length frac_flat
195 (unit_, unit_side, unit_spaced) <-
198 return (u, Just Style.Side_Left, Just s)
200 R.option (Unit.nil, Nothing, Nothing) $ do
201 s <- R.many $ space_horizontal
203 return $ (u, Just Style.Side_Right, Just $ not $ null s)
206 { Amount.quantity = left_signing $ quantity_
207 , Amount.style = style
211 , Amount.unit = unit_
216 { integral :: [String]
217 , fractional :: [String]
218 , fractioning :: Maybe Style.Fractioning
219 , grouping_integral :: Maybe Style.Grouping
220 , grouping_fractional :: Maybe Style.Grouping
223 -- | Parse a 'Quantity'.
226 => Char -- ^ Integral grouping separator.
227 -> Char -- ^ Fractioning separator.
228 -> Char -- ^ Fractional grouping separator.
229 -> ParsecT s u m Quantity
230 quantity int_group_sep frac_sep frac_group_sep = do
231 (integral, grouping_integral) <- do
234 [] -> return ([], Nothing)
236 t <- R.many $ R.char int_group_sep >> R.many1 R.digit
238 return (digits, grouping_of_digits int_group_sep digits)
239 (fractional, fractioning, grouping_fractional) <-
242 _ -> R.option ([], Nothing, Nothing)) $ do
243 fractioning <- R.char frac_sep
245 t <- R.many $ R.char frac_group_sep >> R.many1 R.digit
247 return (digits, Just fractioning
248 , grouping_of_digits frac_group_sep $ reverse digits)
255 , grouping_fractional
258 grouping_of_digits :: Char -> [String] -> Maybe Style.Grouping
259 grouping_of_digits group_sep digits =
264 Style.Grouping group_sep $
265 canonicalize_grouping $
267 canonicalize_grouping :: [Int] -> [Int]
268 canonicalize_grouping groups =
269 Data.List.foldl -- NOTE: remove duplicates at beginning and reverse.
270 (\acc l0 -> case acc of
271 l1:_ -> if l0 == l1 then acc else l0:acc
273 case groups of -- NOTE: keep only longer at beginning.
274 l0:l1:t -> if l0 > l1 then groups else l1:t
277 -- | Parse an 'Unit'.
278 unit :: Stream s m Char => ParsecT s u m Unit
280 (quoted <|> unquoted) <?> "unit"
282 unquoted :: Stream s m Char => ParsecT s u m Unit
287 case Data.Char.generalCategory c of
288 Data.Char.CurrencySymbol -> True
289 Data.Char.LowercaseLetter -> True
290 Data.Char.ModifierLetter -> True
291 Data.Char.OtherLetter -> True
292 Data.Char.TitlecaseLetter -> True
293 Data.Char.UppercaseLetter -> True
295 quoted :: Stream s m Char => ParsecT s u m Unit
298 R.between (R.char '"') (R.char '"') $
304 directive_alias :: Stream s m Char => ParsecT s Context m ()
306 _ <- R.string "alias"
307 R.skipMany1 $ space_horizontal
308 pattern <- account_pattern
309 R.skipMany $ space_horizontal
311 R.skipMany $ space_horizontal
313 R.skipMany $ space_horizontal
315 Account.Pattern_Exact acct -> R.modifyState $ \ctx -> ctx{context_aliases_exact=
316 Data.Map.insert acct repl $ context_aliases_exact ctx}
317 Account.Pattern_Joker jokr -> R.modifyState $ \ctx -> ctx{context_aliases_joker=
318 (jokr, repl):context_aliases_joker ctx}
319 Account.Pattern_Regex regx -> R.modifyState $ \ctx -> ctx{context_aliases_regex=
320 (regx, repl):context_aliases_regex ctx}
323 -- | Parse the year, month and day separator: '/' or '-'.
324 date_separator :: Stream s m Char => ParsecT s u m Char
325 date_separator = R.satisfy (\c -> c == '/' || c == '-')
327 -- | Parse the hour, minute and second separator: ':'.
328 hour_separator :: Stream s m Char => ParsecT s u m Char
329 hour_separator = R.char ':'
333 -- | Parse a 'Date' in [YYYY/]MM/DD [HH:MM[:SS][TZ]] format.
334 date :: Stream s m Char => Maybe Integer -> ParsecT s u m Date
336 n0 <- R.many1 R.digit
337 day_sep <- date_separator
338 n1 <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit
339 n2 <- R.option Nothing $ R.try $ do
341 Just <$> do R.try (R.count 2 R.digit) <|> R.count 1 R.digit
343 case (n2, def_year) of
344 (Nothing, Nothing) -> fail "year or day is missing"
345 (Nothing, Just year) -> return (year, n0, n1)
346 (Just d, _) -> return (R.integer_of_digits 10 n0, n1, d)
347 let month = fromInteger $ R.integer_of_digits 10 m
348 let day = fromInteger $ R.integer_of_digits 10 d
349 guard $ month >= 1 && month <= 12
350 guard $ day >= 1 && day <= 31
351 day_ <- case Time.fromGregorianValid year month day of
352 Nothing -> fail "invalid day"
353 Just day_ -> return day_
354 (hour, minu, sec, tz) <-
355 R.option (0, 0, 0, Time.utc) $ R.try $ do
356 R.skipMany1 $ space_horizontal
357 hour <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit
358 sep <- hour_separator
359 minu <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit
360 sec <- R.option Nothing $ R.try $ do
362 Just <$> (R.try (R.count 2 R.digit) <|> R.count 1 R.digit)
364 tz <- R.option Time.utc $ R.try $ do
365 R.skipMany $ space_horizontal
368 ( R.integer_of_digits 10 hour
369 , R.integer_of_digits 10 minu
370 , maybe 0 (R.integer_of_digits 10) sec
372 guard $ hour >= 0 && hour <= 23
373 guard $ minu >= 0 && minu <= 59
374 guard $ sec >= 0 && sec <= 60 -- NOTE: allow leap second
375 tod <- case Time.makeTimeOfDayValid
379 Nothing -> fail "invalid time of day"
380 Just tod -> return tod
383 (Time.LocalTime day_ tod)
387 time_zone :: Stream s m Char => ParsecT s u m TimeZone
389 -- DOC: http://www.timeanddate.com/time/zones/
390 -- TODO: only a few time zones are suported below.
391 -- TODO: check the timeZoneSummerOnly values
393 [ R.char 'A' >> R.choice
394 [ R.string "ST" >> return (TimeZone ((-4) * 60) False "AST")
395 , R.string "DT" >> return (TimeZone ((-3) * 60) True "ADT")
396 , return (TimeZone ((-1) * 60) False "A")
398 , R.char 'B' >> R.choice
399 [ R.string "ST" >> return (TimeZone ((-11) * 60) False "BST")
400 , R.string "DT" >> return (TimeZone ((-10) * 60) True "BDT")
402 , R.char 'C' >> R.choice
403 [ R.char 'E' >> R.choice
404 [ R.string "T" >> return (TimeZone ((1) * 60) True "CET")
405 , R.string "ST" >> return (TimeZone ((2) * 60) False "CEST")
407 , R.string "ST" >> return (TimeZone ((-6) * 60) False "CST")
408 , R.string "DT" >> return (TimeZone ((-5) * 60) True "CDT")
410 , R.char 'E' >> R.choice
411 [ R.string "ST" >> return (TimeZone ((-5) * 60) False "EST")
412 , R.string "DT" >> return (TimeZone ((-4) * 60) True "EDT")
414 , R.string "GMT" >> return (TimeZone 0 False "GMT")
415 , R.char 'H' >> R.choice
416 [ R.string "ST" >> return (TimeZone ((-10) * 60) False "HST")
417 , R.string "DT" >> return (TimeZone (( -9) * 60) True "HDT")
419 , R.char 'M' >> R.choice
420 [ R.string "ST" >> return (TimeZone ((-7) * 60) False "MST")
421 , R.string "DT" >> return (TimeZone ((-6) * 60) True "MDT")
422 , return (TimeZone ((-12) * 60) False "M")
424 , R.char 'N' >> R.choice
425 [ R.string "ST" >> return (TimeZone ((-3) * 60 - 30) False "NST")
426 , return (TimeZone (1 * 60) False "N")
428 , R.char 'P' >> R.choice
429 [ R.string "ST" >> return (TimeZone ((-8) * 60) False "PST")
430 , R.string "DT" >> return (TimeZone ((-7) * 60) True "PDT")
432 , R.char 'Y' >> R.choice
433 [ R.string "ST" >> return (TimeZone ((-9) * 60) False "YST")
434 , R.string "DT" >> return (TimeZone ((-8) * 60) True "YDT")
435 , return (TimeZone (12 * 60) False "Y")
437 , R.char 'Z' >> return (TimeZone 0 False "Z")
441 time_zone_digits :: Stream s m Char => ParsecT s u m TimeZone
442 {-# INLINEABLE time_zone_digits #-}
443 time_zone_digits = do
445 hour <- R.integer_of_digits 10 <$> R.count 2 R.digit
446 _ <- R.option ':' (R.char ':')
447 minute <- R.integer_of_digits 10 <$> R.count 2 R.digit
449 { timeZoneMinutes = sign_ (fromInteger hour * 60 + fromInteger minute)
450 , timeZoneSummerOnly = False
451 , timeZoneName = Time.timeZoneOffsetString tz
455 -- * Parsing 'Comment'
457 comment_begin :: Char
460 comment :: Stream s m Char => ParsecT s u m Comment
462 _ <- R.char comment_begin
464 R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
467 comments :: Stream s m Char => ParsecT s u m [Comment]
470 R.skipMany $ R.satisfy Data.Char.isSpace
471 many1_separated comment $
474 R.try space_horizontal
475 <|> (R.new_line >> space_horizontal)
480 tag_value_sep :: Char
487 tag :: Stream s m Char => ParsecT s u m Tag
490 _ <- R.char tag_value_sep
495 tag_name :: Stream s m Char => ParsecT s u m Tag.Name
498 R.many1 $ R.satisfy (\c -> c /= tag_value_sep && not (Data.Char.isSpace c))
500 tag_value :: Stream s m Char => ParsecT s u m Tag.Value
503 R.manyTill R.anyChar $ do
505 R.try (R.char tag_sep >> R.many space_horizontal >> tag_name >> R.char tag_value_sep >> return ())
509 tags :: Stream s m Char => ParsecT s u m Tag.By_Name
512 R.many_separated tag $ do
514 R.skipMany $ space_horizontal
517 not_tag :: Stream s m Char => ParsecT s u m ()
519 R.skipMany $ R.try $ do
520 R.skipMany $ R.satisfy
521 (\c -> c /= tag_value_sep
522 && not (Data.Char.isSpace c))
525 -- * Parsing 'Posting'
527 -- | Parse a 'Posting'.
528 posting :: Stream s m Char => ParsecT s Context m (Posting, Posting.Type)
531 sourcepos <- R.getPosition
532 comments_ <- comments
533 R.skipMany1 $ space_horizontal
535 R.skipMany $ space_horizontal
536 (account_, type_) <- account_with_posting_type
540 _ <- R.count 2 (space_horizontal)
541 Amount.from_List <$> do
542 R.many_separated amount $ R.try $ do
543 R.skipMany $ space_horizontal
544 _ <- R.char amount_sep
545 R.skipMany $ space_horizontal
547 , return Data.Map.empty
549 R.skipMany $ space_horizontal
550 -- TODO: balance assertion
552 comments__ <- (comments_ ++) <$> comments
553 let tags_ = tags_of_comments comments__
555 case Data.Map.lookup "date" tags_ of
558 let date2s = Data.Map.lookup "date2" tags_ -- NOTE: support hledger's date2
559 dates_ <- (flip mapM) (dates ++ fromMaybe [] date2s) $
560 R.runParserT (date (Just $ context_year ctx) <* R.eof) () ""
562 Left err -> fail $ show err
564 case (dates, date2s) of -- NOTE: put hledger's date2 at least in second position
566 return $ context_date ctx:dates_
568 return (Posting.Posting
569 { Posting.account=account_
570 , Posting.amounts=amounts_
571 , Posting.comments=comments__
572 , Posting.dates=dates_
573 , Posting.sourcepos=sourcepos
574 , Posting.status=status_
582 tags_of_comments :: [Comment] -> Tag.By_Name
584 Data.Map.unionsWith (++)
586 ( Data.Either.either (const Data.Map.empty) id
587 . R.runParser (not_tag >> tags <* R.eof) () "" )
589 status :: Stream s m Char => ParsecT s u m Transaction.Status
592 R.skipMany $ space_horizontal
593 _ <- (R.char '*' <|> R.char '!') <?> "status"
598 -- | Parse an 'Account' with Posting.'Posting.Type'.
599 account_with_posting_type :: Stream s m Char => ParsecT s u m (Account, Posting.Type)
600 account_with_posting_type = do
602 [ (, Posting.Type_Virtual) <$> R.between (R.char posting_type_virtual_begin)
603 (R.char posting_type_virtual_end)
605 , (, Posting.Type_Virtual_Balanced) <$> R.between (R.char posting_type_virtual_balanced_begin)
606 (R.char posting_type_virtual_balanced_end)
608 , (, Posting.Type_Regular) <$> account
611 posting_type_virtual_begin :: Char
612 posting_type_virtual_begin = '('
613 posting_type_virtual_balanced_begin :: Char
614 posting_type_virtual_balanced_begin = '['
615 posting_type_virtual_end :: Char
616 posting_type_virtual_end = ')'
617 posting_type_virtual_balanced_end :: Char
618 posting_type_virtual_balanced_end = ']'
620 -- * Parsing 'Transaction'
622 transaction :: Stream s m Char => ParsecT s Context m Transaction
624 sourcepos <- R.getPosition
626 comments_before <- comments
627 date_ <- date (Just $ context_year ctx)
629 R.option [] $ R.try $ do
630 R.skipMany $ space_horizontal
632 R.skipMany $ space_horizontal
634 (date (Just $ context_year ctx)) $
636 R.many $ space_horizontal
638 >> (R.many $ space_horizontal)
639 R.skipMany $ space_horizontal
641 code_ <- R.option "" $ R.try code
642 R.skipMany $ space_horizontal
643 description_ <- description
644 R.skipMany $ space_horizontal
645 comments_after <- comments
647 Data.Map.unionWith (++)
648 (tags_of_comments comments_before)
649 (tags_of_comments comments_after)
651 postings_ <- many1_separated posting R.new_line
652 let (postings, postings__) =
653 (Posting.from_List . Data.List.map fst) *** id $
655 ((Posting.Type_Regular ==) . snd)
657 let (virtual_postings, balanced_virtual_postings) =
658 join (***) (Posting.from_List . Data.List.map fst) $
660 ((Posting.Type_Virtual ==) . snd)
663 Transaction.Transaction
664 { Transaction.code=code_
665 , Transaction.comments_before
666 , Transaction.comments_after
667 , Transaction.dates=(date_, dates_)
668 , Transaction.description=description_
669 , Transaction.postings
670 , Transaction.virtual_postings
671 , Transaction.balanced_virtual_postings
672 , Transaction.sourcepos
673 , Transaction.status=status_
674 , Transaction.tags=tags_
681 code :: Stream s m Char => ParsecT s Context m Transaction.Code
684 R.skipMany $ space_horizontal
685 R.between (R.char '(') (R.char ')') $
686 R.many $ R.satisfy (\c -> c /= ')' && not (is_space_horizontal c))
689 description :: Stream s m Char => ParsecT s u m Transaction.Description
692 R.many $ R.try description_char
695 description_char :: Stream s m Char => ParsecT s u m Char
696 description_char = do
699 _ | c == comment_begin -> R.parserZero
700 _ | is_space_horizontal c -> return c <* (R.lookAhead $ R.try $ description_char)
701 _ | not (Data.Char.isSpace c) -> return c
704 -- * Parsing directives
706 default_year :: Stream s m Char => ParsecT s Context m ()
708 year <- R.integer_of_digits 10 <$> R.many1 R.digit
709 context_ <- R.getState
710 R.setState context_{context_year=year}
712 default_unit_and_style :: Stream s m Char => ParsecT s Context m ()
713 default_unit_and_style = do
714 R.skipMany1 space_horizontal
716 R.skipMany space_horizontal >> R.new_line >> R.skipMany space_horizontal
717 context_ <- R.getState
718 R.setState context_{context_unit_and_style=Just $
719 ( Amount.unit amount_
720 , Amount.style amount_ )}
722 include :: Stream s IO Char => ParsecT s Context IO ()
724 sourcepos <- R.getPosition
725 R.skipMany1 $ space_horizontal
726 filename <- R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
727 context_ <- R.getState
728 let journal_ = context_journal context_
729 let cwd = Path.takeDirectory (R.sourceName sourcepos)
730 file_ <- liftIO $ Path.abs cwd filename
731 (journal_included, context_included) <- liftIO $
734 (\ko -> fail $ concat -- TODO: i18n by using a custom data type
738 , ":\n", show (ko::Exception.IOException)
740 >>= R.runParserT (R.and_state $ journal_rec file_)
741 context_{context_journal = Journal.nil}
744 Left ko -> fail $ show ko
745 Right ok -> return ok
747 context_included{context_journal=
748 journal_{Journal.includes=
749 journal_included{Journal.file=file_}
750 : Journal.includes journal_}}
753 -- * Parsing 'Journal'
755 journal :: Stream s IO Char => FilePath -> ParsecT s Context IO Journal
757 currentLocalTime <- liftIO $
759 <$> Time.getCurrentTimeZone
760 <*> Time.getCurrentTime
761 let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
762 context_ <- R.getState
763 R.setState $ context_{context_year=currentLocalYear}
767 journal_rec :: Stream s IO Char => FilePath -> ParsecT s Context IO Journal
768 journal_rec file_ = do
769 last_read_time <- liftIO $ Time.getCurrentTime
773 [ R.string "Y" >> return default_year
774 , R.string "D" >> return default_unit_and_style
775 , R.string "!include" >> return include
776 ] <?> "directive") >>= id)
779 context_' <- R.getState
780 let j = context_journal context_'
781 R.setState $ context_'{context_journal=
782 j{Journal.transactions=
783 Data.Map.insertWith (flip (++))
784 -- NOTE: flip-ing preserves order but slows down
785 -- when many transactions have the very same date.
786 (Date.to_UTC $ fst $ Transaction.dates t) [t]
787 (Journal.transactions j)}}
790 R.skipMany $ R.satisfy Data.Char.isSpace
792 journal_ <- context_journal <$> R.getState
795 { Journal.file = file_
796 , Journal.last_read_time
797 , Journal.includes = reverse $ Journal.includes journal_
800 -- ** Parsing 'Journal' from a file
802 file :: FilePath -> ExceptT String IO Journal
806 (liftM Right $ Text.IO.readFile path) $
807 \ko -> return $ Left $ show (ko::Exception.IOException)
808 >>= liftIO . R.runParserT (journal path) nil_Context path
810 Left ko -> throwE $ show ko
811 Right ok -> ExceptT $ return $ Right ok