]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Format/Ledger/Read.hs
Suppression : Lib.Foldable : Composition déjà dans Data.Functor.Compose.
[comptalang.git] / lib / Hcompta / Format / Ledger / Read.hs
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
8
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 Data.String (fromString)
24 import qualified Data.Time.Calendar as Time
25 import qualified Data.Time.Clock as Time
26 import qualified Data.Time.LocalTime as Time
27 import Data.Time.LocalTime (TimeZone(..))
28 import Data.Typeable ()
29 import qualified Text.Parsec as R hiding
30 ( char
31 , anyChar
32 , crlf
33 , newline
34 , noneOf
35 , oneOf
36 , satisfy
37 , space
38 , spaces
39 , string
40 )
41 import Text.Parsec (Stream, ParsecT, (<|>), (<?>))
42 import qualified Text.Parsec.Pos as R
43 import qualified Data.Text.IO as Text.IO (readFile)
44 import qualified Data.Text as Text
45 import qualified System.FilePath.Posix as Path
46
47 import qualified Hcompta.Calc.Balance as Balance
48 import qualified Hcompta.Model.Account as Account
49 import Hcompta.Model.Account (Account)
50 import qualified Hcompta.Model.Amount as Amount
51 import Hcompta.Model.Amount (Amount)
52 import qualified Hcompta.Model.Amount.Style as Style
53 import qualified Hcompta.Model.Amount.Unit as Unit
54 import Hcompta.Model.Amount.Unit (Unit)
55 import qualified Hcompta.Model.Date as Date
56 import Hcompta.Model.Date (Date)
57 import qualified Hcompta.Format.Ledger as Ledger
58 import Hcompta.Format.Ledger
59 ( Comment
60 , Journal(..)
61 , Posting(..), Posting_Type(..)
62 , Tag, Tag_Name, Tag_Value, Tag_by_Name
63 , Transaction(..)
64 )
65 import qualified Hcompta.Lib.Regex as Regex
66 import Hcompta.Lib.Regex (Regex)
67 import qualified Hcompta.Lib.Parsec as R
68 import qualified Hcompta.Lib.Path as Path
69
70 data Context
71 = Context
72 { context_account_prefix :: !(Maybe Account)
73 , context_aliases_exact :: !(Data.Map.Map Account Account)
74 , context_aliases_joker :: ![(Account.Joker, Account)]
75 , context_aliases_regex :: ![(Regex, Account)]
76 , context_date :: !Date
77 , context_unit_and_style :: !(Maybe (Amount.Unit, Amount.Style))
78 , context_journal :: !Journal
79 , context_year :: !Date.Year
80 } deriving (Show)
81
82 nil_Context :: Context
83 nil_Context =
84 Context
85 { context_account_prefix = Nothing
86 , context_aliases_exact = Data.Map.empty
87 , context_aliases_joker = []
88 , context_aliases_regex = []
89 , context_date = Date.nil
90 , context_unit_and_style = Nothing
91 , context_journal = Ledger.journal
92 , context_year = (\(year, _ , _) -> year) $
93 Time.toGregorian $ Time.utctDay $
94 journal_last_read_time Ledger.journal
95 }
96
97 data Error
98 = Error_year_or_day_is_missing
99 | Error_invalid_date (Integer, Int, Int)
100 | Error_invalid_time_of_day (Int, Int, Integer)
101 | Error_transaction_not_equilibrated Transaction [Balance.Unit_Sum (Balance.Posting_Amount Ledger.Posting)]
102 | Error_virtual_transaction_not_equilibrated Transaction [Balance.Unit_Sum (Balance.Posting_Amount Ledger.Posting)]
103 | Error_reading_file FilePath Exception.IOException
104 | Error_including_file FilePath [R.Error Error]
105 deriving (Show)
106
107 -- | Parse either '-' into 'negate', or '+' or '' into 'id'.
108 sign :: (Stream s m Char, Num i) => ParsecT s u m (i -> i)
109 sign =
110 (R.char '-' >> return negate)
111 <|> (R.char '+' >> return id)
112 <|> return id
113
114 -- * Parsing 'Account'
115
116 account_name_sep :: Char
117 account_name_sep = ':'
118
119 -- | Parse an 'Account'.
120 account :: Stream s m Char => ParsecT s u m Account
121 account = do
122 R.notFollowedBy $ R.space_horizontal
123 Account.from_List <$> do
124 R.many1_separated account_name $ R.char account_name_sep
125
126 -- | Parse an Account.'Account.Name'.
127 account_name :: Stream s m Char => ParsecT s u m Account.Name
128 account_name = do
129 fromString <$> do
130 R.many1 $ R.try account_name_char
131 where
132 account_name_char :: Stream s m Char => ParsecT s u m Char
133 account_name_char = do
134 c <- R.anyChar
135 case c of
136 _ | c == comment_begin -> R.parserZero
137 _ | c == account_name_sep -> R.parserZero
138 _ | R.is_space_horizontal c -> do
139 _ <- R.notFollowedBy $ R.space_horizontal
140 return c <* (R.lookAhead $ R.try $
141 ( R.try (R.char account_name_sep)
142 <|> account_name_char
143 ))
144 _ | not (Data.Char.isSpace c) -> return c
145 _ -> R.parserZero
146
147 -- | Parse an Account.'Account.Joker_Name'.
148 account_joker_name :: Stream s m Char => ParsecT s u m Account.Joker_Name
149 account_joker_name = do
150 n <- R.option Nothing $ (Just <$> account_name)
151 case n of
152 Nothing -> R.char account_name_sep >> (return $ Account.Joker_Any)
153 Just n' -> return $ Account.Joker_Name n'
154
155 -- | Parse an Account.'Account.Joker'.
156 account_joker :: Stream s m Char => ParsecT s u m Account.Joker
157 account_joker = do
158 R.notFollowedBy $ R.space_horizontal
159 R.many1_separated account_joker_name $ R.char account_name_sep
160
161 -- | Parse a 'Regex'.
162 account_regex :: Stream s m Char => ParsecT s u m Regex
163 account_regex = do
164 re <- R.many1 $ R.satisfy (not . R.is_space_horizontal)
165 Regex.of_StringM re
166
167 -- | Parse an Account.'Account.Filter'.
168 account_pattern :: Stream s m Char => ParsecT s u m Account.Pattern
169 account_pattern = do
170 R.choice_try
171 [ Account.Pattern_Exact <$> (R.char '=' >> account)
172 , Account.Pattern_Joker <$> (R.char '*' >> account_joker)
173 , Account.Pattern_Regex <$> (R.option '~' (R.char '~') >> account_regex)
174 ]
175
176 -- * Parsing 'Amount'
177
178 -- | Parse an 'Amount'.
179 amount :: Stream s m Char => ParsecT s u m Amount
180 amount = do
181 left_signing <- sign
182 left_unit <-
183 R.option Nothing $ do
184 u <- unit
185 s <- R.many $ R.space_horizontal
186 return $ Just $ (u, not $ null s)
187 (quantity_, style) <- do
188 signing <- sign
189 Quantity
190 { integral
191 , fractional
192 , fractioning
193 , grouping_integral
194 , grouping_fractional
195 } <-
196 R.choice_try
197 [ quantity '_' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
198 , quantity '_' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
199 , quantity ',' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
200 , quantity '.' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
201 ] <?> "quantity"
202 let int = Data.List.concat integral
203 let frac_flat = Data.List.concat fractional
204 let frac = reverse $ Data.List.dropWhile (== '0') $ reverse $ frac_flat
205 let place = length frac
206 guard (place <= 255)
207 let mantissa = R.integer_of_digits 10 $ int ++ frac
208 return $
209 ( Data.Decimal.Decimal
210 (fromIntegral place)
211 (signing mantissa)
212 , Style.nil
213 { Style.fractioning
214 , Style.grouping_integral
215 , Style.grouping_fractional
216 , Style.precision = fromIntegral $ length frac_flat
217 }
218 )
219 (unit_, unit_side, unit_spaced) <-
220 case left_unit of
221 Just (u, s) ->
222 return (u, Just Style.Side_Left, Just s)
223 Nothing ->
224 R.option (Unit.nil, Nothing, Nothing) $ R.try $ do
225 s <- R.many $ R.space_horizontal
226 u <- unit
227 return $ (u, Just Style.Side_Right, Just $ not $ null s)
228 return $
229 Amount.Amount
230 { Amount.quantity = left_signing $ quantity_
231 , Amount.style = style
232 { Style.unit_side
233 , Style.unit_spaced
234 }
235 , Amount.unit = unit_
236 }
237
238 data Quantity
239 = Quantity
240 { integral :: [String]
241 , fractional :: [String]
242 , fractioning :: Maybe Style.Fractioning
243 , grouping_integral :: Maybe Style.Grouping
244 , grouping_fractional :: Maybe Style.Grouping
245 }
246
247 -- | Parse a 'Quantity'.
248 quantity
249 :: Stream s m Char
250 => Char -- ^ Integral grouping separator.
251 -> Char -- ^ Fractioning separator.
252 -> Char -- ^ Fractional grouping separator.
253 -> ParsecT s u m Quantity
254 quantity int_group_sep frac_sep frac_group_sep = do
255 (integral, grouping_integral) <- do
256 h <- R.many R.digit
257 case h of
258 [] -> return ([], Nothing)
259 _ -> do
260 t <- R.many $ R.char int_group_sep >> R.many1 R.digit
261 let digits = h:t
262 return (digits, grouping_of_digits int_group_sep digits)
263 (fractional, fractioning, grouping_fractional) <-
264 (case integral of
265 [] -> id
266 _ -> R.option ([], Nothing, Nothing)) $ do
267 fractioning <- R.char frac_sep
268 h <- R.many R.digit
269 t <- R.many $ R.char frac_group_sep >> R.many1 R.digit
270 let digits = h:t
271 return (digits, Just fractioning
272 , grouping_of_digits frac_group_sep $ reverse digits)
273 return $
274 Quantity
275 { integral
276 , fractional
277 , fractioning
278 , grouping_integral
279 , grouping_fractional
280 }
281 where
282 grouping_of_digits :: Char -> [String] -> Maybe Style.Grouping
283 grouping_of_digits group_sep digits =
284 case digits of
285 [] -> Nothing
286 [_] -> Nothing
287 _ -> Just $
288 Style.Grouping group_sep $
289 canonicalize_grouping $
290 map length $ digits
291 canonicalize_grouping :: [Int] -> [Int]
292 canonicalize_grouping groups =
293 Data.List.foldl -- NOTE: remove duplicates at beginning and reverse.
294 (\acc l0 -> case acc of
295 l1:_ -> if l0 == l1 then acc else l0:acc
296 _ -> l0:acc) [] $
297 case groups of -- NOTE: keep only longer at beginning.
298 l0:l1:t -> if l0 > l1 then groups else l1:t
299 _ -> groups
300
301 -- | Parse an 'Unit'.
302 unit :: Stream s m Char => ParsecT s u m Unit
303 unit =
304 (quoted <|> unquoted) <?> "unit"
305 where
306 unquoted :: Stream s m Char => ParsecT s u m Unit
307 unquoted =
308 fromString <$> do
309 R.many1 $
310 R.satisfy $ \c ->
311 case Data.Char.generalCategory c of
312 Data.Char.CurrencySymbol -> True
313 Data.Char.LowercaseLetter -> True
314 Data.Char.ModifierLetter -> True
315 Data.Char.OtherLetter -> True
316 Data.Char.TitlecaseLetter -> True
317 Data.Char.UppercaseLetter -> True
318 _ -> False
319 quoted :: Stream s m Char => ParsecT s u m Unit
320 quoted =
321 fromString <$> do
322 R.between (R.char '"') (R.char '"') $
323 R.many1 $
324 R.noneOf ";\n\""
325
326 -- * Directives
327
328 directive_alias :: Stream s m Char => ParsecT s Context m ()
329 directive_alias = do
330 _ <- R.string "alias"
331 R.skipMany1 $ R.space_horizontal
332 pattern <- account_pattern
333 R.skipMany $ R.space_horizontal
334 _ <- R.char '='
335 R.skipMany $ R.space_horizontal
336 repl <- account
337 R.skipMany $ R.space_horizontal
338 case pattern of
339 Account.Pattern_Exact acct -> R.modifyState $ \ctx -> ctx{context_aliases_exact=
340 Data.Map.insert acct repl $ context_aliases_exact ctx}
341 Account.Pattern_Joker jokr -> R.modifyState $ \ctx -> ctx{context_aliases_joker=
342 (jokr, repl):context_aliases_joker ctx}
343 Account.Pattern_Regex regx -> R.modifyState $ \ctx -> ctx{context_aliases_regex=
344 (regx, repl):context_aliases_regex ctx}
345 return ()
346
347 -- | Parse the year, month and day separator: '/' or '-'.
348 date_separator :: Stream s m Char => ParsecT s u m Char
349 date_separator = R.satisfy (\c -> c == '/' || c == '-')
350
351 -- | Parse the hour, minute and second separator: ':'.
352 hour_separator :: Stream s m Char => ParsecT s u m Char
353 hour_separator = R.char ':'
354
355 -- * Parsing 'Date'
356
357 -- | Parse a 'Date' in [YYYY/]MM/DD [HH:MM[:SS][TZ]] format.
358 date
359 :: (Stream s (R.Error_State Error m) Char, Monad m)
360 => Maybe Integer -> ParsecT s u (R.Error_State Error m) Date
361 date def_year = (do
362 n0 <- R.many1 R.digit
363 day_sep <- date_separator
364 n1 <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit
365 n2 <- R.option Nothing $ R.try $ do
366 _ <- R.char day_sep
367 Just <$> do R.try (R.count 2 R.digit) <|> R.count 1 R.digit
368 (year, m, d) <-
369 case (n2, def_year) of
370 (Nothing, Nothing) -> R.fail_with "date" (Error_year_or_day_is_missing)
371 (Nothing, Just year) -> return (year, n0, n1)
372 (Just d, _) -> return (R.integer_of_digits 10 n0, n1, d)
373 let month = fromInteger $ R.integer_of_digits 10 m
374 let day = fromInteger $ R.integer_of_digits 10 d
375 guard $ month >= 1 && month <= 12
376 guard $ day >= 1 && day <= 31
377 day_ <- case Time.fromGregorianValid year month day of
378 Nothing -> R.fail_with "date" (Error_invalid_date (year, month, day))
379 Just day_ -> return day_
380 (hour, minu, sec, tz) <-
381 R.option (0, 0, 0, Time.utc) $ R.try $ do
382 R.skipMany1 $ R.space_horizontal
383 hour <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit
384 sep <- hour_separator
385 minu <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit
386 sec <- R.option Nothing $ R.try $ do
387 _ <- R.char sep
388 Just <$> (R.try (R.count 2 R.digit) <|> R.count 1 R.digit)
389 tz <- R.option Time.utc $ R.try $ do
390 R.skipMany $ R.space_horizontal
391 time_zone
392 return
393 ( fromInteger $ R.integer_of_digits 10 hour
394 , fromInteger $ R.integer_of_digits 10 minu
395 , maybe 0 (R.integer_of_digits 10) sec
396 , tz )
397 tod <- case Time.makeTimeOfDayValid hour minu (fromInteger sec) of
398 Nothing -> R.fail_with "date" (Error_invalid_time_of_day (hour, minu, sec))
399 Just tod -> return tod
400 return $
401 Time.ZonedTime
402 (Time.LocalTime day_ tod)
403 tz
404 ) <?> "date"
405
406 time_zone :: Stream s m Char => ParsecT s u m TimeZone
407 time_zone =
408 -- DOC: http://www.timeanddate.com/time/zones/
409 -- TODO: only a few time zones are suported below.
410 -- TODO: check the timeZoneSummerOnly values
411 R.choice
412 [ R.char 'A' >> R.choice
413 [ R.string "ST" >> return (TimeZone ((-4) * 60) False "AST")
414 , R.string "DT" >> return (TimeZone ((-3) * 60) True "ADT")
415 , return (TimeZone ((-1) * 60) False "A")
416 ]
417 , R.char 'B' >> R.choice
418 [ R.string "ST" >> return (TimeZone ((-11) * 60) False "BST")
419 , R.string "DT" >> return (TimeZone ((-10) * 60) True "BDT")
420 ]
421 , R.char 'C' >> R.choice
422 [ R.char 'E' >> R.choice
423 [ R.string "T" >> return (TimeZone ((1) * 60) True "CET")
424 , R.string "ST" >> return (TimeZone ((2) * 60) False "CEST")
425 ]
426 , R.string "ST" >> return (TimeZone ((-6) * 60) False "CST")
427 , R.string "DT" >> return (TimeZone ((-5) * 60) True "CDT")
428 ]
429 , R.char 'E' >> R.choice
430 [ R.string "ST" >> return (TimeZone ((-5) * 60) False "EST")
431 , R.string "DT" >> return (TimeZone ((-4) * 60) True "EDT")
432 ]
433 , R.string "GMT" >> return (TimeZone 0 False "GMT")
434 , R.char 'H' >> R.choice
435 [ R.string "ST" >> return (TimeZone ((-10) * 60) False "HST")
436 , R.string "DT" >> return (TimeZone (( -9) * 60) True "HDT")
437 ]
438 , R.char 'M' >> R.choice
439 [ R.string "ST" >> return (TimeZone ((-7) * 60) False "MST")
440 , R.string "DT" >> return (TimeZone ((-6) * 60) True "MDT")
441 , return (TimeZone ((-12) * 60) False "M")
442 ]
443 , R.char 'N' >> R.choice
444 [ R.string "ST" >> return (TimeZone ((-3) * 60 - 30) False "NST")
445 , return (TimeZone (1 * 60) False "N")
446 ]
447 , R.char 'P' >> R.choice
448 [ R.string "ST" >> return (TimeZone ((-8) * 60) False "PST")
449 , R.string "DT" >> return (TimeZone ((-7) * 60) True "PDT")
450 ]
451 , R.char 'Y' >> R.choice
452 [ R.string "ST" >> return (TimeZone ((-9) * 60) False "YST")
453 , R.string "DT" >> return (TimeZone ((-8) * 60) True "YDT")
454 , return (TimeZone (12 * 60) False "Y")
455 ]
456 , R.char 'Z' >> return (TimeZone 0 False "Z")
457 , time_zone_digits
458 ]
459
460 time_zone_digits :: Stream s m Char => ParsecT s u m TimeZone
461 {-# INLINEABLE time_zone_digits #-}
462 time_zone_digits = do
463 sign_ <- sign
464 hour <- R.integer_of_digits 10 <$> R.count 2 R.digit
465 _ <- R.option ':' (R.char ':')
466 minute <- R.integer_of_digits 10 <$> R.count 2 R.digit
467 let tz = TimeZone
468 { timeZoneMinutes = sign_ (fromInteger hour * 60 + fromInteger minute)
469 , timeZoneSummerOnly = False
470 , timeZoneName = Time.timeZoneOffsetString tz
471 }
472 return tz
473
474 -- * Parsing 'Comment'
475
476 comment_begin :: Char
477 comment_begin = ';'
478
479 comment :: Stream s m Char => ParsecT s u m Comment
480 comment = (do
481 _ <- R.char comment_begin
482 fromString <$> do
483 R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
484 ) <?> "comment"
485
486 comments :: Stream s m Char => ParsecT s u m [Comment]
487 comments = (do
488 R.try $ do
489 _ <- R.spaces
490 R.many1_separated comment (R.new_line >> R.skipMany R.space_horizontal)
491 <|> return []
492 ) <?> "comments"
493
494 -- * Parsing 'Tag'
495
496 tag_value_sep :: Char
497 tag_value_sep = ':'
498
499 tag_sep :: Char
500 tag_sep = ','
501
502 -- | Parse a 'Tag'.
503 tag :: Stream s m Char => ParsecT s u m Tag
504 tag = (do
505 n <- tag_name
506 _ <- R.char tag_value_sep
507 v <- tag_value
508 return (n, v)
509 ) <?> "tag"
510
511 tag_name :: Stream s m Char => ParsecT s u m Tag_Name
512 tag_name = do
513 fromString <$> do
514 R.many1 $ R.satisfy (\c -> c /= tag_value_sep && not (Data.Char.isSpace c))
515
516 tag_value :: Stream s m Char => ParsecT s u m Tag_Value
517 tag_value = do
518 fromString <$> do
519 R.manyTill R.anyChar $ do
520 R.lookAhead $ do
521 R.try (R.char tag_sep >> R.many R.space_horizontal >> tag_name >> R.char tag_value_sep >> return ())
522 <|> R.try R.new_line
523 <|> R.eof
524
525 tags :: Stream s m Char => ParsecT s u m Tag_by_Name
526 tags = do
527 Ledger.tag_by_Name <$> do
528 R.many_separated tag $ do
529 _ <- R.char tag_sep
530 R.skipMany $ R.space_horizontal
531 return ()
532
533 not_tag :: Stream s m Char => ParsecT s u m ()
534 not_tag = do
535 R.skipMany $ R.try $ do
536 R.skipMany $ R.satisfy
537 (\c -> c /= tag_value_sep
538 && not (Data.Char.isSpace c))
539 R.space_horizontal
540
541 -- * Parsing 'Posting'
542
543 -- | Parse a 'Posting'.
544 posting
545 :: (Stream s (R.Error_State Error m) Char, Monad m)
546 => ParsecT s Context (R.Error_State Error m) (Posting, Posting_Type)
547 posting = (do
548 ctx <- R.getState
549 sourcepos <- R.getPosition
550 R.skipMany1 $ R.space_horizontal
551 status_ <- status
552 R.skipMany $ R.space_horizontal
553 acct <- account
554 let (type_, account_) = posting_type acct
555 amounts_ <-
556 R.choice_try
557 [ do
558 _ <- R.count 2 R.space_horizontal
559 R.skipMany $ R.space_horizontal
560 maybe id (\(u, s) ->
561 if u == Unit.nil then id
562 else
563 Data.Map.adjust (\a ->
564 a{ Amount.style = s{Style.precision = Style.precision $ Amount.style a}
565 , Amount.unit = u })
566 Unit.nil)
567 (context_unit_and_style ctx) .
568 Amount.from_List <$> do
569 R.many_separated amount $ do
570 R.skipMany $ R.space_horizontal
571 _ <- R.char amount_sep
572 R.skipMany $ R.space_horizontal
573 return ()
574 , return Data.Map.empty
575 ] <?> "amounts"
576 R.skipMany $ R.space_horizontal
577 -- TODO: balance assertion
578 -- TODO: conversion
579 comments_ <- comments
580 let tags_ = tags_of_comments comments_
581 dates_ <-
582 case Data.Map.lookup "date" tags_ of
583 Nothing -> return []
584 Just dates -> do
585 let date2s = Data.Map.lookup "date2" tags_ -- NOTE: support hledger's date2
586 do
587 (flip mapM) (dates ++ fromMaybe [] date2s) $ \s ->
588 R.runParserT_with_Error_fail "tag date"
589 (date (Just $ context_year ctx) <* R.eof) ()
590 (Text.unpack s) s
591 >>= \dates_ -> case (dates, date2s) of -- NOTE: put hledger's date2 at least in second position
592 ([], Just (_:_)) ->
593 return $ context_date ctx:dates_
594 _ -> return $ dates_
595 return (Posting
596 { posting_account=account_
597 , posting_amounts=amounts_
598 , posting_comments=comments_
599 , posting_dates=dates_
600 , posting_sourcepos=sourcepos
601 , posting_status=status_
602 , posting_tags=tags_
603 }, type_)
604 ) <?> "posting"
605
606 amount_sep :: Char
607 amount_sep = '+'
608
609 tags_of_comments :: [Comment] -> Tag_by_Name
610 tags_of_comments =
611 Data.Map.unionsWith (++)
612 . Data.List.map
613 ( Data.Either.either (const Data.Map.empty) id
614 . R.runParser (not_tag >> tags <* R.eof) () "" )
615
616 status :: Stream s m Char => ParsecT s u m Ledger.Status
617 status = (do
618 ( R.try $ do
619 R.skipMany $ R.space_horizontal
620 _ <- (R.char '*' <|> R.char '!')
621 return True )
622 <|> return False
623 ) <?> "status"
624
625 -- | Return the 'Posting_Type' and stripped 'Account' of the given 'Account'.
626 posting_type :: Account -> (Posting_Type, Account)
627 posting_type acct =
628 fromMaybe (Posting_Type_Regular, acct) $ do
629 case acct of
630 name:|[] ->
631 case Text.stripPrefix virtual_begin name of
632 Just name' -> do
633 name'' <-
634 Text.stripSuffix virtual_end name'
635 >>= return . Text.strip
636 guard $ not $ Text.null name''
637 Just (Posting_Type_Virtual, name'':|[])
638 Nothing -> do
639 name' <-
640 Text.stripPrefix virtual_balanced_begin name
641 >>= Text.stripSuffix virtual_balanced_end
642 >>= return . Text.strip
643 guard $ not $ Text.null name'
644 Just (Posting_Type_Virtual_Balanced, name':|[])
645 first_name:|acct' -> do
646 let rev_acct' = Data.List.reverse acct'
647 let last_name = Data.List.head rev_acct'
648 case Text.stripPrefix virtual_begin first_name
649 >>= return . Text.stripStart of
650 Just first_name' -> do
651 last_name' <-
652 Text.stripSuffix virtual_end last_name
653 >>= return . Text.stripEnd
654 guard $ not $ Text.null first_name'
655 guard $ not $ Text.null last_name'
656 Just $
657 ( Posting_Type_Virtual
658 , first_name':|
659 Data.List.reverse (last_name':Data.List.tail rev_acct')
660 )
661 Nothing -> do
662 first_name' <-
663 Text.stripPrefix virtual_balanced_begin first_name
664 >>= return . Text.stripStart
665 last_name' <-
666 Text.stripSuffix virtual_balanced_end last_name
667 >>= return . Text.stripEnd
668 guard $ not $ Text.null first_name'
669 guard $ not $ Text.null last_name'
670 Just $
671 ( Posting_Type_Virtual_Balanced
672 , first_name':|
673 Data.List.reverse (last_name':Data.List.tail rev_acct')
674 )
675 where
676 virtual_begin = Text.singleton posting_type_virtual_begin
677 virtual_end = Text.singleton posting_type_virtual_end
678 virtual_balanced_begin = Text.singleton posting_type_virtual_balanced_begin
679 virtual_balanced_end = Text.singleton posting_type_virtual_balanced_end
680
681 posting_type_virtual_begin :: Char
682 posting_type_virtual_begin = '('
683 posting_type_virtual_balanced_begin :: Char
684 posting_type_virtual_balanced_begin = '['
685 posting_type_virtual_end :: Char
686 posting_type_virtual_end = ')'
687 posting_type_virtual_balanced_end :: Char
688 posting_type_virtual_balanced_end = ']'
689
690 -- * Parsing 'Transaction'
691
692 transaction
693 :: (Stream s (R.Error_State Error m) Char, Monad m)
694 => ParsecT s Context (R.Error_State Error m) Transaction
695 transaction = (do
696 ctx <- R.getState
697 transaction_sourcepos <- R.getPosition
698 transaction_comments_before <-
699 comments
700 >>= \x -> case x of
701 [] -> return []
702 _ -> return x <* R.new_line
703 date_ <- date (Just $ context_year ctx)
704 dates_ <-
705 R.option [] $ R.try $ do
706 R.skipMany $ R.space_horizontal
707 _ <- R.char date_sep
708 R.skipMany $ R.space_horizontal
709 R.many_separated
710 (date (Just $ context_year ctx)) $
711 R.try $ do
712 R.many $ R.space_horizontal
713 >> R.char date_sep
714 >> (R.many $ R.space_horizontal)
715 let transaction_dates = (date_, dates_)
716 R.skipMany $ R.space_horizontal
717 transaction_status <- status
718 transaction_code <- R.option "" $ R.try code
719 R.skipMany $ R.space_horizontal
720 transaction_description <- description
721 R.skipMany $ R.space_horizontal
722 transaction_comments_after <- comments
723 let transaction_tags =
724 Data.Map.unionWith (++)
725 (tags_of_comments transaction_comments_before)
726 (tags_of_comments transaction_comments_after)
727 R.new_line
728 (postings_unchecked, postings_not_regular) <-
729 ((Ledger.posting_by_Account . Data.List.map fst) *** id) .
730 Data.List.partition ((Posting_Type_Regular ==) . snd) <$>
731 R.many1_separated posting R.new_line
732 let (transaction_virtual_postings, balanced_virtual_postings_unchecked) =
733 join (***) (Ledger.posting_by_Account . Data.List.map fst) $
734 Data.List.partition ((Posting_Type_Virtual ==) . snd)
735 postings_not_regular
736 let tr_unchecked =
737 Transaction
738 { transaction_code
739 , transaction_comments_before
740 , transaction_comments_after
741 , transaction_dates
742 , transaction_description
743 , transaction_postings=postings_unchecked
744 , transaction_virtual_postings
745 , transaction_balanced_virtual_postings=balanced_virtual_postings_unchecked
746 , transaction_sourcepos
747 , transaction_status
748 , transaction_tags
749 }
750 transaction_postings <-
751 case Balance.infer_equilibrium postings_unchecked of
752 (_, Left ko) -> R.fail_with "transaction infer_equilibrium"
753 (Error_transaction_not_equilibrated tr_unchecked ko)
754 (_bal, Right ok) -> return ok
755 transaction_balanced_virtual_postings <-
756 case Balance.infer_equilibrium balanced_virtual_postings_unchecked of
757 (_, Left ko) -> R.fail_with "transaction infer_equilibrium"
758 (Error_virtual_transaction_not_equilibrated tr_unchecked ko)
759 (_bal, Right ok) -> return ok
760 return $
761 tr_unchecked
762 { transaction_postings
763 , transaction_balanced_virtual_postings
764 }
765 ) <?> "transaction"
766
767 date_sep :: Char
768 date_sep = '='
769
770 code :: Stream s m Char => ParsecT s Context m Ledger.Code
771 code = (do
772 fromString <$> do
773 R.skipMany $ R.space_horizontal
774 R.between (R.char '(') (R.char ')') $
775 R.many $ R.satisfy (\c -> c /= ')' && not (R.is_space_horizontal c))
776 ) <?> "code"
777
778 description :: Stream s m Char => ParsecT s u m Ledger.Description
779 description = (do
780 fromString <$> do
781 R.many $ R.try description_char
782 ) <?> "description"
783 where
784 description_char :: Stream s m Char => ParsecT s u m Char
785 description_char = do
786 c <- R.anyChar
787 case c of
788 _ | c == comment_begin -> R.parserZero
789 _ | R.is_space_horizontal c -> return c <* (R.lookAhead $ R.try $ description_char)
790 _ | not (Data.Char.isSpace c) -> return c
791 _ -> R.parserZero
792
793 -- * Parsing directives
794
795 default_year :: Stream s m Char => ParsecT s Context m ()
796 default_year = (do
797 year <- R.integer_of_digits 10 <$> R.many1 R.digit
798 R.skipMany R.space_horizontal >> R.new_line
799 context_ <- R.getState
800 R.setState context_{context_year=year}
801 ) <?> "default year"
802
803 default_unit_and_style :: Stream s m Char => ParsecT s Context m ()
804 default_unit_and_style = (do
805 amount_ <- amount
806 R.skipMany R.space_horizontal >> R.new_line
807 context_ <- R.getState
808 R.setState context_{context_unit_and_style =
809 Just $
810 ( Amount.unit amount_
811 , Amount.style amount_ )}
812 ) <?> "default unit and style"
813
814 include
815 :: Stream s (R.Error_State Error IO) Char
816 => ParsecT s Context (R.Error_State Error IO) ()
817 include = (do
818 sourcepos <- R.getPosition
819 filename <- R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
820 context_ <- R.getState
821 let journal_ = context_journal context_
822 let cwd = Path.takeDirectory (R.sourceName sourcepos)
823 file_path <- liftIO $ Path.abs cwd filename
824 content <- do
825 liftIO $ Exception.catch
826 (liftM return $ readFile file_path)
827 (return . R.fail_with "include reading" . Error_reading_file file_path)
828 >>= id
829 (journal_included, context_included) <- do
830 liftIO $
831 R.runParserT_with_Error (R.and_state $ journal_rec file_path)
832 context_{context_journal = Ledger.journal}
833 file_path content
834 >>= \x -> case x of
835 Right ok -> return ok
836 Left ko -> R.fail_with "include parsing" (Error_including_file file_path ko)
837 R.setState $
838 context_included{context_journal=
839 journal_{journal_includes=
840 journal_included{journal_file=file_path}
841 : journal_includes journal_}}
842 ) <?> "include"
843
844 -- * Parsing 'Journal'
845
846 journal
847 :: Stream s (R.Error_State Error IO) Char
848 => FilePath
849 -> ParsecT s Context (R.Error_State Error IO) Journal
850 journal file_ = (do
851 currentLocalTime <- liftIO $
852 Time.utcToLocalTime
853 <$> Time.getCurrentTimeZone
854 <*> Time.getCurrentTime
855 let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
856 context_ <- R.getState
857 R.setState $ context_{context_year=currentLocalYear}
858 journal_rec file_
859 ) <?> "journal"
860
861 journal_rec
862 :: Stream s (R.Error_State Error IO) Char
863 => FilePath
864 -> ParsecT s Context (R.Error_State Error IO) Journal
865 journal_rec file_ = do
866 last_read_time <- lift $ liftIO Time.getCurrentTime
867 R.skipMany $ do
868 R.choice_try
869 [ R.skipMany1 R.space
870 , (do (R.choice_try
871 [ R.string "Y" >> return default_year
872 , R.string "D" >> return default_unit_and_style
873 , R.string "!include" >> return include
874 ] <?> "directive")
875 >>= \r -> R.skipMany1 R.space_horizontal >> r)
876 , ((do
877 t <- transaction
878 context_' <- R.getState
879 let j = context_journal context_'
880 R.setState $ context_'{context_journal=
881 j{journal_transactions=
882 Data.Map.insertWith (flip (++))
883 -- NOTE: flip-ing preserves order but slows down
884 -- when many transactions have the very same date.
885 (Date.to_UTC $ fst $ transaction_dates t) [t]
886 (journal_transactions j)}}
887 R.new_line <|> R.eof))
888 , R.try (comment >> return ())
889 ]
890 R.eof
891 journal_ <- context_journal <$> R.getState
892 return $
893 journal_
894 { journal_file = file_
895 , journal_last_read_time=last_read_time
896 , journal_includes = reverse $ journal_includes journal_
897 }
898
899 -- ** Parsing 'Journal' from a file
900
901 file :: FilePath -> ExceptT [R.Error Error] IO Journal
902 file path = do
903 ExceptT $
904 Exception.catch
905 (liftM Right $ Text.IO.readFile path) $
906 \ko -> return $ Left $
907 [ R.Error_Custom (R.initialPos path) $ Error_reading_file path ko ]
908 >>= liftIO . R.runParserT_with_Error (journal path) nil_Context path
909 >>= \x -> case x of
910 Left ko -> throwE $ ko
911 Right ok -> ExceptT $ return $ Right ok