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