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 P
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 System.Directory (getHomeDirectory)
32 import qualified System.FilePath.Posix as Path
33 import System.FilePath ((</>))
35 import qualified Hcompta.Model.Account as Account
36 import Hcompta.Model.Account (Account)
37 import qualified Hcompta.Model.Amount as Amount
38 import Hcompta.Model.Amount (Amount)
39 import qualified Hcompta.Model.Amount.Style as Style
40 import qualified Hcompta.Model.Amount.Unit as Unit
41 import Hcompta.Model.Amount.Unit (Unit)
42 import qualified Hcompta.Model.Transaction as Transaction
43 import Hcompta.Model.Transaction (Transaction, Comment)
44 import qualified Hcompta.Model.Transaction.Posting as Posting
45 import Hcompta.Model.Transaction (Posting)
46 import qualified Hcompta.Model.Transaction.Tag as Tag
47 import Hcompta.Model.Transaction (Tag)
48 import qualified Hcompta.Model.Date as Date
49 import Hcompta.Model.Date (Date)
50 import Hcompta.Format.Ledger.Journal as Journal
51 import qualified Hcompta.Lib.Regex as Regex
52 import Hcompta.Lib.Regex (Regex)
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
85 -- | Like 'Text.Parsec.choice' but with 'Text.Parsec.try' on each case.
86 choice_try :: Stream s m t => [ParsecT s u m a] -> ParsecT s u m a
87 choice_try = Data.List.foldr (\a -> (<|>) (P.try a)) P.parserZero
88 -- choice_try = P.choice . Data.List.map P.try
90 -- | Like 'Text.Parsec.sepBy' but without parsing an ending separator.
96 many_separated p sep =
97 many1_separated p sep <|> return []
99 -- | Like 'Text.Parsec.sepBy1' but without parsing an ending separator.
105 many1_separated p sep = do
107 xs <- P.many (P.try (sep >> p))
109 -- (:) <$> p <*> P.many (P.try (sep >> p))
111 -- | Make a 'Text.Parsec.ParsecT' also return its user state.
115 -> ParsecT s u m (a, u)
121 -- | Return an absolute 'FilePath', given the current working directory and a path.
123 -- * "~" as prefix is expanded to the process's user's home directory
124 -- * "-" as path is unchanged
125 -- * ~USER is not supported
126 path_abs :: FilePath -> FilePath -> IO FilePath
127 path_abs _ "-" = return "-"
130 (if Path.isRelative path
135 expand :: FilePath -> IO FilePath
137 if Path.isPathSeparator sep
138 then liftIO $ (</> p) <$> getHomeDirectory
139 else fail "~USERNAME in path is not supported"
144 -- | Return the 'Integer' obtained by multiplying the given digits
145 -- with the power of the given base respective to their rank.
147 :: Integer -- ^ Base.
148 -> [Char] -- ^ Digits (MUST be recognised by 'Data.Char.digitToInt').
150 integer_of_digits base =
151 Data.List.foldl (\x d ->
152 base*x + toInteger (Data.Char.digitToInt d)) 0
154 decimal :: Stream s m Char => ParsecT s u m Integer
155 decimal = integer 10 P.digit
156 hexadecimal :: Stream s m Char => ParsecT s u m Integer
157 hexadecimal = P.oneOf "xX" >> integer 16 P.hexDigit
158 octal :: Stream s m Char => ParsecT s u m Integer
159 octal = P.oneOf "oO" >> integer 8 P.octDigit
161 -- | Parse an 'Integer'.
162 integer :: Stream s m t
164 -> ParsecT s u m Char
165 -> ParsecT s u m Integer
166 integer base digit = do
167 digits <- P.many1 digit
168 let n = integer_of_digits base digits
171 -- | Parse either '-' into 'negate', or '+' or '' into 'id'.
172 sign :: (Stream s m Char, Num i) => ParsecT s u m (i -> i)
174 (P.char '-' >> return negate)
175 <|> (P.char '+' >> return id)
180 -- | Return 'True' if and only if the given 'Char' is an horizontal space.
181 is_space_horizontal :: Char -> Bool
182 is_space_horizontal c = c /= '\n' && c /= '\r' && Data.Char.isSpace c
184 space_horizontal :: Stream s m Char => ParsecT s u m Char
185 {-# INLINEABLE space_horizontal #-}
186 space_horizontal = P.satisfy is_space_horizontal <?> "horizontal-space"
188 newline :: Stream s m Char => ParsecT s u m ()
189 newline = ((P.try (P.string "\r\n") <|> P.try (P.string "\n")) >> return ()) <?> "newline"
191 -- * Parsing 'Account'
193 account_name_sep :: Char
194 account_name_sep = ':'
196 -- | Parse an 'Account'.
197 account :: Stream s m Char => ParsecT s u m Account
199 P.notFollowedBy $ space_horizontal
200 many1_separated account_name $ P.char account_name_sep
202 -- | Parse an Account.'Account.Name'.
203 account_name :: Stream s m Char => ParsecT s u m Account.Name
206 P.many1 $ P.try account_name_char
208 account_name_char :: Stream s m Char => ParsecT s u m Char
209 account_name_char = do
212 _ | c == comment_begin -> P.parserZero
213 _ | c == account_name_sep -> P.parserZero
214 _ | c == posting_type_virtual_end
215 || c == posting_type_virtual_balanced_end ->
216 return c <* (P.lookAhead $ P.try $ account_name_char)
217 _ | is_space_horizontal c -> do
218 _ <- P.notFollowedBy $ space_horizontal
219 return c <* (P.lookAhead $ P.try $
220 ( P.try (P.char account_name_sep)
221 <|> account_name_char
223 _ | not (Data.Char.isSpace c) -> return c
226 -- | Parse an Account.'Account.Joker_Name'.
227 account_joker_name :: Stream s m Char => ParsecT s u m Account.Joker_Name
228 account_joker_name = do
229 n <- P.option Nothing $ (Just <$> account_name)
231 Nothing -> P.char account_name_sep >> (return $ Account.Joker_Any)
232 Just n' -> return $ Account.Joker_Name n'
234 -- | Parse an Account.'Account.Joker'.
235 account_joker :: Stream s m Char => ParsecT s u m Account.Joker
237 P.notFollowedBy $ space_horizontal
238 many1_separated account_joker_name $ P.char account_name_sep
240 -- | Parse a 'Regex'.
241 account_regex :: Stream s m Char => ParsecT s u m Regex
243 re <- P.many1 $ P.satisfy (not . is_space_horizontal)
246 -- | Parse an Account.'Account.Filter'.
247 account_pattern :: Stream s m Char => ParsecT s u m Account.Pattern
250 [ Account.Pattern_Exact <$> (P.char '=' >> account)
251 , Account.Pattern_Joker <$> (P.char '*' >> account_joker)
252 , Account.Pattern_Regex <$> (P.option '~' (P.char '~') >> account_regex)
255 -- * Parsing 'Amount'
257 -- | Parse an 'Amount'.
258 amount :: Stream s m Char => ParsecT s u m Amount
262 P.option Nothing $ do
264 s <- P.many $ space_horizontal
265 return $ Just $ (u, not $ null s)
266 (quantity_, style) <- do
273 , grouping_fractional
276 [ quantity '_' ',' '_' <* (P.notFollowedBy $ P.oneOf ",._")
277 , quantity '_' '.' '_' <* (P.notFollowedBy $ P.oneOf ",._")
278 , quantity ',' '.' '_' <* (P.notFollowedBy $ P.oneOf ",._")
279 , quantity '.' ',' '_' <* (P.notFollowedBy $ P.oneOf ",._")
281 let int = Data.List.concat integral
282 let frac_flat = Data.List.concat fractional
283 let frac = reverse $ Data.List.dropWhile (== '0') $ reverse $ frac_flat
284 let place = length frac
286 let mantissa = integer_of_digits 10 $ int ++ frac
288 ( Data.Decimal.Decimal
293 , Style.grouping_integral
294 , Style.grouping_fractional
295 , Style.precision = fromIntegral $ length frac_flat
298 (unit_, unit_side, unit_spaced) <-
301 return (u, Just Style.Side_Left, Just s)
303 P.option (Unit.nil, Nothing, Nothing) $ do
304 s <- P.many $ space_horizontal
306 return $ (u, Just Style.Side_Right, Just $ not $ null s)
309 { Amount.quantity = left_signing $ quantity_
310 , Amount.style = style
314 , Amount.unit = unit_
319 { integral :: [String]
320 , fractional :: [String]
321 , fractioning :: Maybe Style.Fractioning
322 , grouping_integral :: Maybe Style.Grouping
323 , grouping_fractional :: Maybe Style.Grouping
326 -- | Parse a 'Quantity'.
329 => Char -- ^ Integral grouping separator.
330 -> Char -- ^ Fractioning separator.
331 -> Char -- ^ Fractional grouping separator.
332 -> ParsecT s u m Quantity
333 quantity int_group_sep frac_sep frac_group_sep = do
334 (integral, grouping_integral) <- do
337 [] -> return ([], Nothing)
339 t <- P.many $ P.char int_group_sep >> P.many1 P.digit
341 return (digits, grouping_of_digits int_group_sep digits)
342 (fractional, fractioning, grouping_fractional) <-
345 _ -> P.option ([], Nothing, Nothing)) $ do
346 fractioning <- P.char frac_sep
348 t <- P.many $ P.char frac_group_sep >> P.many1 P.digit
350 return (digits, Just fractioning
351 , grouping_of_digits frac_group_sep $ reverse digits)
358 , grouping_fractional
361 grouping_of_digits :: Char -> [String] -> Maybe Style.Grouping
362 grouping_of_digits group_sep digits =
367 Style.Grouping group_sep $
368 canonicalize_grouping $
370 canonicalize_grouping :: [Int] -> [Int]
371 canonicalize_grouping groups =
372 Data.List.foldl -- NOTE: remove duplicates at beginning and reverse.
373 (\acc l0 -> case acc of
374 l1:_ -> if l0 == l1 then acc else l0:acc
376 case groups of -- NOTE: keep only longer at beginning.
377 l0:l1:t -> if l0 > l1 then groups else l1:t
380 -- | Parse an 'Unit'.
381 unit :: Stream s m Char => ParsecT s u m Unit
383 (quoted <|> unquoted) <?> "unit"
385 unquoted :: Stream s m Char => ParsecT s u m Unit
390 case Data.Char.generalCategory c of
391 Data.Char.CurrencySymbol -> True
392 Data.Char.LowercaseLetter -> True
393 Data.Char.ModifierLetter -> True
394 Data.Char.OtherLetter -> True
395 Data.Char.TitlecaseLetter -> True
396 Data.Char.UppercaseLetter -> True
398 quoted :: Stream s m Char => ParsecT s u m Unit
401 P.between (P.char '"') (P.char '"') $
407 directive_alias :: Stream s m Char => ParsecT s Context m ()
409 _ <- P.string "alias"
410 P.skipMany1 $ space_horizontal
411 pattern <- account_pattern
412 P.skipMany $ space_horizontal
414 P.skipMany $ space_horizontal
416 P.skipMany $ space_horizontal
418 Account.Pattern_Exact acct -> P.modifyState $ \ctx -> ctx{context_aliases_exact=
419 Data.Map.insert acct repl $ context_aliases_exact ctx}
420 Account.Pattern_Joker jokr -> P.modifyState $ \ctx -> ctx{context_aliases_joker=
421 (jokr, repl):context_aliases_joker ctx}
422 Account.Pattern_Regex regx -> P.modifyState $ \ctx -> ctx{context_aliases_regex=
423 (regx, repl):context_aliases_regex ctx}
426 -- | Parse the year, month and day separator: '/' or '-'.
427 date_separator :: Stream s m Char => ParsecT s u m Char
428 date_separator = P.satisfy (\c -> c == '/' || c == '-')
430 -- | Parse the hour, minute and second separator: ':'.
431 hour_separator :: Stream s m Char => ParsecT s u m Char
432 hour_separator = P.char ':'
436 -- | Parse a 'Date' in [YYYY/]MM/DD [HH:MM[:SS][TZ]] format.
437 date :: Stream s m Char => Maybe Integer -> ParsecT s u m Date
439 n0 <- P.many1 P.digit
440 day_sep <- date_separator
441 n1 <- P.try (P.count 2 P.digit) <|> P.count 1 P.digit
442 n2 <- P.option Nothing $ P.try $ do
444 Just <$> do P.try (P.count 2 P.digit) <|> P.count 1 P.digit
446 case (n2, def_year) of
447 (Nothing, Nothing) -> fail "year or day is missing"
448 (Nothing, Just year) -> return (year, n0, n1)
449 (Just d, _) -> return (integer_of_digits 10 n0, n1, d)
450 let month = fromInteger $ integer_of_digits 10 m
451 let day = fromInteger $ integer_of_digits 10 d
452 guard $ month >= 1 && month <= 12
453 guard $ day >= 1 && day <= 31
454 day_ <- case Time.fromGregorianValid year month day of
455 Nothing -> fail "invalid day"
456 Just day_ -> return day_
457 (hour, minu, sec, tz) <-
458 P.option (0, 0, 0, Time.utc) $ P.try $ do
459 P.skipMany1 $ space_horizontal
460 hour <- P.try (P.count 2 P.digit) <|> P.count 1 P.digit
461 sep <- hour_separator
462 minu <- P.try (P.count 2 P.digit) <|> P.count 1 P.digit
463 sec <- P.option Nothing $ P.try $ do
465 Just <$> (P.try (P.count 2 P.digit) <|> P.count 1 P.digit)
467 tz <- P.option Time.utc $ P.try $ do
468 P.skipMany $ space_horizontal
471 ( integer_of_digits 10 hour
472 , integer_of_digits 10 minu
473 , maybe 0 (integer_of_digits 10) sec
475 guard $ hour >= 0 && hour <= 23
476 guard $ minu >= 0 && minu <= 59
477 guard $ sec >= 0 && sec <= 60 -- NOTE: allow leap second
478 tod <- case Time.makeTimeOfDayValid
482 Nothing -> fail "invalid time of day"
483 Just tod -> return tod
486 (Time.LocalTime day_ tod)
490 time_zone :: Stream s m Char => ParsecT s u m TimeZone
492 -- DOC: http://www.timeanddate.com/time/zones/
493 -- TODO: only a few time zones are suported below.
494 -- TODO: check the timeZoneSummerOnly values
496 [ P.char 'A' >> P.choice
497 [ P.string "ST" >> return (TimeZone ((-4) * 60) False "AST")
498 , P.string "DT" >> return (TimeZone ((-3) * 60) True "ADT")
499 , return (TimeZone ((-1) * 60) False "A")
501 , P.char 'B' >> P.choice
502 [ P.string "ST" >> return (TimeZone ((-11) * 60) False "BST")
503 , P.string "DT" >> return (TimeZone ((-10) * 60) True "BDT")
505 , P.char 'C' >> P.choice
506 [ P.char 'E' >> P.choice
507 [ P.string "T" >> return (TimeZone ((1) * 60) True "CET")
508 , P.string "ST" >> return (TimeZone ((2) * 60) False "CEST")
510 , P.string "ST" >> return (TimeZone ((-6) * 60) False "CST")
511 , P.string "DT" >> return (TimeZone ((-5) * 60) True "CDT")
513 , P.char 'E' >> P.choice
514 [ P.string "ST" >> return (TimeZone ((-5) * 60) False "EST")
515 , P.string "DT" >> return (TimeZone ((-4) * 60) True "EDT")
517 , P.string "GMT" >> return (TimeZone 0 False "GMT")
518 , P.char 'H' >> P.choice
519 [ P.string "ST" >> return (TimeZone ((-10) * 60) False "HST")
520 , P.string "DT" >> return (TimeZone (( -9) * 60) True "HDT")
522 , P.char 'M' >> P.choice
523 [ P.string "ST" >> return (TimeZone ((-7) * 60) False "MST")
524 , P.string "DT" >> return (TimeZone ((-6) * 60) True "MDT")
525 , return (TimeZone ((-12) * 60) False "M")
527 , P.char 'N' >> P.choice
528 [ P.string "ST" >> return (TimeZone ((-3) * 60 - 30) False "NST")
529 , return (TimeZone (1 * 60) False "N")
531 , P.char 'P' >> P.choice
532 [ P.string "ST" >> return (TimeZone ((-8) * 60) False "PST")
533 , P.string "DT" >> return (TimeZone ((-7) * 60) True "PDT")
535 , P.char 'Y' >> P.choice
536 [ P.string "ST" >> return (TimeZone ((-9) * 60) False "YST")
537 , P.string "DT" >> return (TimeZone ((-8) * 60) True "YDT")
538 , return (TimeZone (12 * 60) False "Y")
540 , P.char 'Z' >> return (TimeZone 0 False "Z")
544 time_zone_digits :: Stream s m Char => ParsecT s u m TimeZone
545 {-# INLINEABLE time_zone_digits #-}
546 time_zone_digits = do
548 hour <- integer_of_digits 10 <$> P.count 2 P.digit
549 _ <- P.option ':' (P.char ':')
550 minute <- integer_of_digits 10 <$> P.count 2 P.digit
552 { timeZoneMinutes = sign_ (fromInteger hour * 60 + fromInteger minute)
553 , timeZoneSummerOnly = False
554 , timeZoneName = Time.timeZoneOffsetString tz
558 -- * Parsing 'Comment'
560 comment_begin :: Char
563 comment :: Stream s m Char => ParsecT s u m Comment
565 _ <- P.char comment_begin
567 P.manyTill P.anyChar (P.lookAhead newline <|> P.eof)
570 comments :: Stream s m Char => ParsecT s u m [Comment]
573 P.skipMany $ P.satisfy Data.Char.isSpace
574 many1_separated comment $
577 P.try space_horizontal
578 <|> (P.newline >> space_horizontal)
583 tag_value_sep :: Char
590 tag :: Stream s m Char => ParsecT s u m Tag
593 _ <- P.char tag_value_sep
598 tag_name :: Stream s m Char => ParsecT s u m Tag.Name
601 P.many1 $ P.satisfy (\c -> c /= tag_value_sep && not (Data.Char.isSpace c))
603 tag_value :: Stream s m Char => ParsecT s u m Tag.Value
606 P.manyTill P.anyChar $ do
608 P.try (P.char tag_sep >> P.many space_horizontal >> tag_name >> P.char tag_value_sep >> return ())
612 tags :: Stream s m Char => ParsecT s u m Tag.By_Name
615 many_separated tag $ do
617 P.skipMany $ space_horizontal
620 not_tag :: Stream s m Char => ParsecT s u m ()
622 P.skipMany $ P.try $ do
623 P.skipMany $ P.satisfy
624 (\c -> c /= tag_value_sep
625 && not (Data.Char.isSpace c))
628 -- * Parsing 'Posting'
630 -- | Parse a 'Posting'.
631 posting :: Stream s m Char => ParsecT s Context m (Posting, Posting.Type)
634 sourcepos <- P.getPosition
635 comments_ <- comments
636 P.skipMany1 $ space_horizontal
638 P.skipMany $ space_horizontal
639 (account_, type_) <- account_with_posting_type
643 _ <- P.count 2 (space_horizontal)
644 Amount.from_List <$> do
645 many_separated amount $ P.try $ do
646 P.skipMany $ space_horizontal
647 _ <- P.char amount_sep
648 P.skipMany $ space_horizontal
650 , return Data.Map.empty
652 P.skipMany $ space_horizontal
653 -- TODO: balance assertion
655 comments__ <- (comments_ ++) <$> comments
656 let tags_ = tags_of_comments comments__
658 case Data.Map.lookup "date" tags_ of
661 let date2s = Data.Map.lookup "date2" tags_ -- NOTE: support hledger's date2
662 dates_ <- (flip mapM) (dates ++ fromMaybe [] date2s) $
663 P.runParserT (date (Just $ context_year ctx) <* P.eof) () ""
665 Left err -> fail $ show err
667 case (dates, date2s) of -- NOTE: put hledger's date2 at least in second position
669 return $ context_date ctx:dates_
671 return (Posting.Posting
672 { Posting.account=account_
673 , Posting.amounts=amounts_
674 , Posting.comments=comments__
675 , Posting.dates=dates_
676 , Posting.sourcepos=sourcepos
677 , Posting.status=status_
685 tags_of_comments :: [Comment] -> Tag.By_Name
687 Data.Map.unionsWith (++)
689 ( Data.Either.either (const Data.Map.empty) id
690 . P.runParser (not_tag >> tags <* P.eof) () "" )
692 status :: Stream s m Char => ParsecT s u m Transaction.Status
695 P.skipMany $ space_horizontal
696 _ <- (P.char '*' <|> P.char '!') <?> "status"
701 -- | Parse an 'Account' with Posting.'Posting.Type'.
702 account_with_posting_type :: Stream s m Char => ParsecT s u m (Account, Posting.Type)
703 account_with_posting_type = do
705 [ (, Posting.Type_Virtual) <$> P.between (P.char posting_type_virtual_begin)
706 (P.char posting_type_virtual_end)
708 , (, Posting.Type_Virtual_Balanced) <$> P.between (P.char posting_type_virtual_balanced_begin)
709 (P.char posting_type_virtual_balanced_end)
711 , (, Posting.Type_Regular) <$> account
714 posting_type_virtual_begin :: Char
715 posting_type_virtual_begin = '('
716 posting_type_virtual_balanced_begin :: Char
717 posting_type_virtual_balanced_begin = '['
718 posting_type_virtual_end :: Char
719 posting_type_virtual_end = ')'
720 posting_type_virtual_balanced_end :: Char
721 posting_type_virtual_balanced_end = ']'
723 -- * Parsing 'Transaction'
725 transaction :: Stream s m Char => ParsecT s Context m Transaction
727 sourcepos <- P.getPosition
729 comments_before <- comments
730 date_ <- date (Just $ context_year ctx)
732 P.option [] $ P.try $ do
733 P.skipMany $ space_horizontal
735 P.skipMany $ space_horizontal
737 (date (Just $ context_year ctx)) $
739 P.many $ space_horizontal
741 >> (P.many $ space_horizontal)
742 P.skipMany $ space_horizontal
744 code_ <- P.option "" $ P.try code
745 P.skipMany $ space_horizontal
746 description_ <- description
747 P.skipMany $ space_horizontal
748 comments_after <- comments
750 Data.Map.unionWith (++)
751 (tags_of_comments comments_before)
752 (tags_of_comments comments_after)
754 postings_ <- many1_separated posting newline
755 let (postings, postings__) =
756 (Posting.from_List . Data.List.map fst) *** id $
758 ((Posting.Type_Regular ==) . snd)
760 let (virtual_postings, balanced_virtual_postings) =
761 join (***) (Posting.from_List . Data.List.map fst) $
763 ((Posting.Type_Virtual ==) . snd)
766 Transaction.Transaction
767 { Transaction.code=code_
768 , Transaction.comments_before
769 , Transaction.comments_after
770 , Transaction.dates=(date_, dates_)
771 , Transaction.description=description_
772 , Transaction.postings
773 , Transaction.virtual_postings
774 , Transaction.balanced_virtual_postings
775 , Transaction.sourcepos
776 , Transaction.status=status_
777 , Transaction.tags=tags_
784 code :: Stream s m Char => ParsecT s Context m Transaction.Code
787 P.skipMany $ space_horizontal
788 P.between (P.char '(') (P.char ')') $
789 P.many $ P.satisfy (\c -> c /= ')' && not (is_space_horizontal c))
792 description :: Stream s m Char => ParsecT s u m Transaction.Description
795 P.many $ P.try description_char
798 description_char :: Stream s m Char => ParsecT s u m Char
799 description_char = do
802 _ | c == comment_begin -> P.parserZero
803 _ | is_space_horizontal c -> return c <* (P.lookAhead $ P.try $ description_char)
804 _ | not (Data.Char.isSpace c) -> return c
807 -- * Parsing directives
809 default_year :: Stream s m Char => ParsecT s Context m ()
811 year <- integer_of_digits 10 <$> P.many1 P.digit
812 context_ <- P.getState
813 P.setState context_{context_year=year}
815 default_unit_and_style :: Stream s m Char => ParsecT s Context m ()
816 default_unit_and_style = do
817 P.skipMany1 space_horizontal
819 P.skipMany space_horizontal >> newline >> P.skipMany space_horizontal
820 context_ <- P.getState
821 P.setState context_{context_unit_and_style=Just $
822 ( Amount.unit amount_
823 , Amount.style amount_ )}
825 include :: Stream s IO Char => ParsecT s Context IO ()
827 sourcepos <- P.getPosition
828 P.skipMany1 $ space_horizontal
829 filename <- P.manyTill P.anyChar (P.lookAhead newline <|> P.eof)
830 context_ <- P.getState
831 let journal_ = context_journal context_
832 let cwd = Path.takeDirectory (P.sourceName sourcepos)
833 file_ <- liftIO $ path_abs cwd filename
834 (journal_included, context_included) <- liftIO $
837 (\ko -> fail $ concat -- TODO: i18n by using a custom data type
841 , ":\n", show (ko::Exception.IOException)
843 >>= P.runParserT (and_state $ journal_rec file_)
844 context_{context_journal = Journal.nil}
847 Left ko -> fail $ show ko
848 Right ok -> return ok
850 context_included{context_journal=
851 journal_{Journal.includes=
852 journal_included{Journal.file=file_}
853 : Journal.includes journal_}}
856 -- * Parsing 'Journal'
858 journal :: Stream s IO Char => FilePath -> ParsecT s Context IO Journal
860 currentLocalTime <- liftIO $
862 <$> Time.getCurrentTimeZone
863 <*> Time.getCurrentTime
864 let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
865 context_ <- P.getState
866 P.setState $ context_{context_year=currentLocalYear}
870 journal_rec :: Stream s IO Char => FilePath -> ParsecT s Context IO Journal
871 journal_rec file_ = do
872 last_read_time <- liftIO $ Time.getCurrentTime
876 [ P.string "Y" >> return default_year
877 , P.string "D" >> return default_unit_and_style
878 , P.string "!include" >> return include
879 ] <?> "directive") >>= id)
882 context_' <- P.getState
883 let j = context_journal context_'
884 P.setState $ context_'{context_journal=
885 j{Journal.transactions=
886 Data.Map.insertWith (flip (++))
887 -- NOTE: flip-ing preserves order but slows down
888 -- when many transactions have the very same date.
889 (Date.to_UTC $ fst $ Transaction.dates t) [t]
890 (Journal.transactions j)}}
893 P.skipMany $ P.satisfy Data.Char.isSpace
895 journal_ <- context_journal <$> P.getState
898 { Journal.file = file_
899 , Journal.last_read_time
900 , Journal.includes = reverse $ Journal.includes journal_
903 -- ** Parsing 'Journal' from a file
905 file :: FilePath -> ExceptT String IO Journal
909 (liftM Right $ Text.IO.readFile path) $
910 \ko -> return $ Left $ show (ko::Exception.IOException)
911 >>= liftIO . P.runParserT (journal path) nil_Context path
913 Left ko -> throwE $ show ko
914 Right ok -> ExceptT $ return $ Right ok