]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Format/Ledger/Read.hs
Ajout : CLI.Lib.Shakespeare.Leijen : et demain L’Internationale...
[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 Calc.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_day (Integer, Int, Int)
100 | Error_invalid_time_of_day (Int, Int, Integer)
101 | Error_transaction_not_equilibrated Transaction [Calc.Balance.Unit_Sum Amount]
102 | Error_virtual_transaction_not_equilibrated Transaction [Calc.Balance.Unit_Sum Amount]
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_day (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 (flip (++))
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 sourcepos <- R.getPosition
697 ctx <- R.getState
698 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 R.skipMany $ R.space_horizontal
716 status_ <- status
717 code_ <- R.option "" $ R.try code
718 R.skipMany $ R.space_horizontal
719 description_ <- description
720 R.skipMany $ R.space_horizontal
721 comments_after <- comments
722 let tags_ =
723 Data.Map.unionWith (++)
724 (tags_of_comments comments_before)
725 (tags_of_comments comments_after)
726 R.new_line
727 (postings_unchecked, postings_not_regular) <-
728 ((Ledger.posting_by_Account . Data.List.map fst) *** id) .
729 Data.List.partition ((Posting_Type_Regular ==) . snd) <$>
730 R.many1_separated posting R.new_line
731 let (virtual_postings, balanced_virtual_postings_unchecked) =
732 join (***) (Ledger.posting_by_Account . Data.List.map fst) $
733 Data.List.partition ((Posting_Type_Virtual ==) . snd)
734 postings_not_regular
735 let tr_unchecked =
736 Transaction
737 { transaction_code=code_
738 , transaction_comments_before=comments_before
739 , transaction_comments_after=comments_after
740 , transaction_dates=(date_, dates_)
741 , transaction_description=description_
742 , transaction_postings=postings_unchecked
743 , transaction_virtual_postings=virtual_postings
744 , transaction_balanced_virtual_postings=balanced_virtual_postings_unchecked
745 , transaction_sourcepos=sourcepos
746 , transaction_status=status_
747 , transaction_tags=tags_
748 }
749 postings <-
750 case snd $ Calc.Balance.infer_equilibrium postings_unchecked of
751 Left ko -> R.fail_with "transaction infer_equilibrium"
752 (Error_transaction_not_equilibrated tr_unchecked ko)
753 Right ok -> return ok
754 balanced_virtual_postings <-
755 case snd $ Calc.Balance.infer_equilibrium balanced_virtual_postings_unchecked of
756 Left ko -> R.fail_with "transaction infer_equilibrium"
757 (Error_virtual_transaction_not_equilibrated tr_unchecked ko)
758 Right ok -> return ok
759 return $
760 Transaction
761 { transaction_code=code_
762 , transaction_comments_before=comments_before
763 , transaction_comments_after=comments_after
764 , transaction_dates=(date_, dates_)
765 , transaction_description=description_
766 , transaction_postings=postings
767 , transaction_virtual_postings=virtual_postings
768 , transaction_balanced_virtual_postings=balanced_virtual_postings
769 , transaction_sourcepos=sourcepos
770 , transaction_status=status_
771 , transaction_tags=tags_
772 }
773 ) <?> "transaction"
774
775 date_sep :: Char
776 date_sep = '='
777
778 code :: Stream s m Char => ParsecT s Context m Ledger.Code
779 code = (do
780 fromString <$> do
781 R.skipMany $ R.space_horizontal
782 R.between (R.char '(') (R.char ')') $
783 R.many $ R.satisfy (\c -> c /= ')' && not (R.is_space_horizontal c))
784 ) <?> "code"
785
786 description :: Stream s m Char => ParsecT s u m Ledger.Description
787 description = (do
788 fromString <$> do
789 R.many $ R.try description_char
790 ) <?> "description"
791 where
792 description_char :: Stream s m Char => ParsecT s u m Char
793 description_char = do
794 c <- R.anyChar
795 case c of
796 _ | c == comment_begin -> R.parserZero
797 _ | R.is_space_horizontal c -> return c <* (R.lookAhead $ R.try $ description_char)
798 _ | not (Data.Char.isSpace c) -> return c
799 _ -> R.parserZero
800
801 -- * Parsing directives
802
803 default_year :: Stream s m Char => ParsecT s Context m ()
804 default_year = (do
805 year <- R.integer_of_digits 10 <$> R.many1 R.digit
806 R.skipMany R.space_horizontal >> R.new_line
807 context_ <- R.getState
808 R.setState context_{context_year=year}
809 ) <?> "default year"
810
811 default_unit_and_style :: Stream s m Char => ParsecT s Context m ()
812 default_unit_and_style = (do
813 amount_ <- amount
814 R.skipMany R.space_horizontal >> R.new_line
815 context_ <- R.getState
816 R.setState context_{context_unit_and_style =
817 Just $
818 ( Amount.unit amount_
819 , Amount.style amount_ )}
820 ) <?> "default unit and style"
821
822 include
823 :: Stream s (R.Error_State Error IO) Char
824 => ParsecT s Context (R.Error_State Error IO) ()
825 include = (do
826 sourcepos <- R.getPosition
827 filename <- R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
828 context_ <- R.getState
829 let journal_ = context_journal context_
830 let cwd = Path.takeDirectory (R.sourceName sourcepos)
831 file_path <- liftIO $ Path.abs cwd filename
832 content <- do
833 liftIO $ Exception.catch
834 (liftM return $ readFile file_path)
835 (return . R.fail_with "include reading" . Error_reading_file file_path)
836 >>= id
837 (journal_included, context_included) <- do
838 liftIO $
839 R.runParserT_with_Error (R.and_state $ journal_rec file_path)
840 context_{context_journal = Ledger.journal}
841 file_path content
842 >>= \x -> case x of
843 Right ok -> return ok
844 Left ko -> R.fail_with "include parsing" (Error_including_file file_path ko)
845 R.setState $
846 context_included{context_journal=
847 journal_{journal_includes=
848 journal_included{journal_file=file_path}
849 : journal_includes journal_}}
850 ) <?> "include"
851
852 -- * Parsing 'Journal'
853
854 journal
855 :: Stream s (R.Error_State Error IO) Char
856 => FilePath
857 -> ParsecT s Context (R.Error_State Error IO) Journal
858 journal file_ = (do
859 currentLocalTime <- liftIO $
860 Time.utcToLocalTime
861 <$> Time.getCurrentTimeZone
862 <*> Time.getCurrentTime
863 let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
864 context_ <- R.getState
865 R.setState $ context_{context_year=currentLocalYear}
866 journal_rec file_
867 ) <?> "journal"
868
869 journal_rec
870 :: Stream s (R.Error_State Error IO) Char
871 => FilePath
872 -> ParsecT s Context (R.Error_State Error IO) Journal
873 journal_rec file_ = do
874 last_read_time <- lift $ liftIO Time.getCurrentTime
875 R.skipMany $ do
876 R.choice_try
877 [ R.skipMany1 R.space
878 , (do (R.choice_try
879 [ R.string "Y" >> return default_year
880 , R.string "D" >> return default_unit_and_style
881 , R.string "!include" >> return include
882 ] <?> "directive")
883 >>= \r -> R.skipMany1 R.space_horizontal >> r)
884 , ((do
885 t <- transaction
886 context_' <- R.getState
887 let j = context_journal context_'
888 R.setState $ context_'{context_journal=
889 j{journal_transactions=
890 Data.Map.insertWith (flip (++))
891 -- NOTE: flip-ing preserves order but slows down
892 -- when many transactions have the very same date.
893 (Date.to_UTC $ fst $ transaction_dates t) [t]
894 (journal_transactions j)}}
895 R.new_line <|> R.eof))
896 , R.try (comment >> return ())
897 ]
898 R.eof
899 journal_ <- context_journal <$> R.getState
900 return $
901 journal_
902 { journal_file = file_
903 , journal_last_read_time=last_read_time
904 , journal_includes = reverse $ journal_includes journal_
905 }
906
907 -- ** Parsing 'Journal' from a file
908
909 file :: FilePath -> ExceptT [R.Error Error] IO Journal
910 file path = do
911 ExceptT $
912 Exception.catch
913 (liftM Right $ Text.IO.readFile path) $
914 \ko -> return $ Left $
915 [ R.Error_Custom (R.initialPos path) $ Error_reading_file path ko ]
916 >>= liftIO . R.runParserT_with_Error (journal path) nil_Context path
917 >>= \x -> case x of
918 Left ko -> throwE $ ko
919 Right ok -> ExceptT $ return $ Right ok