]> Git — Sourcephile - comptalang.git/blob - jcc/Hcompta/Format/JCC/Read.hs
Correction : Calculus.Lambda.Omega.Explicit.REPL : broutille administrative.
[comptalang.git] / jcc / Hcompta / Format / JCC / Read.hs
1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE NamedFieldPuns #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# LANGUAGE ScopedTypeVariables #-}
6 {-# LANGUAGE StandaloneDeriving #-}
7 {-# LANGUAGE TupleSections #-}
8 {-# LANGUAGE TypeFamilies #-}
9 module Hcompta.Format.JCC.Read where
10
11 import Control.Applicative ((<$>), (<*>), (<*))
12 import qualified Control.Exception as Exception
13 import Control.Monad (Monad(..), guard, liftM, join, void)
14 import Control.Monad.IO.Class (liftIO)
15 import Control.Monad.Trans.Except (ExceptT(..), throwE)
16 import Data.Time.LocalTime (TimeZone(..))
17 import Data.Bool
18 import Data.Decimal
19 import Data.Char (Char)
20 import qualified Data.Char as Char
21 import Data.Either (Either(..))
22 import Data.Eq (Eq(..))
23 import Data.Ord (Ord(..))
24 import Data.Function (($), (.), id, const, flip)
25 import qualified Data.List as List
26 import Data.List.NonEmpty (NonEmpty(..))
27 import qualified Data.List.NonEmpty as NonEmpty
28 import Data.Map.Strict (Map)
29 import qualified Data.Map.Strict as Map
30 import Data.Maybe (Maybe(..), maybe)
31 import Data.Monoid (Monoid(..))
32 import Data.String (String, fromString)
33 import Data.Text (Text)
34 import qualified Data.Text.IO as Text.IO (readFile)
35 import qualified Data.Time.Calendar as Time
36 import qualified Data.Time.Clock as Time
37 import qualified Data.Time.LocalTime as Time
38 import Data.Typeable ()
39 import Prelude (Int, Integer, Num(..), fromIntegral)
40 import qualified System.FilePath.Posix as Path
41 import System.IO (IO, FilePath)
42 import qualified Text.Parsec as R hiding
43 ( char
44 , anyChar
45 , crlf
46 , newline
47 , noneOf
48 , oneOf
49 , satisfy
50 , space
51 , spaces
52 , string
53 , tab
54 )
55 import Text.Parsec (Stream, ParsecT, (<|>), (<?>))
56 import qualified Text.Parsec.Pos as R
57 import Text.Show (Show)
58
59 import Hcompta.Anchor ( Anchors(..) )
60 import qualified Hcompta.Account as Account
61 import Hcompta.Account ( Account_Tags(..)
62 , Account_Tag(..)
63 , Account_Anchor(..)
64 )
65 import qualified Hcompta.Amount as Amount
66 import qualified Hcompta.Balance as Balance
67 import qualified Hcompta.Chart as Chart
68 import Hcompta.Date (Date)
69 import qualified Hcompta.Date as Date
70 import Hcompta.Lib.Consable (Consable(..))
71 import qualified Hcompta.Lib.Parsec as R
72 import qualified Hcompta.Lib.Path as Path
73 import Hcompta.Lib.Regex (Regex)
74 import qualified Hcompta.Lib.Regex as Regex
75 import qualified Hcompta.Lib.TreeMap as TreeMap
76 import qualified Hcompta.Polarize as Polarize
77 import qualified Hcompta.Posting as Posting
78 import Hcompta.Posting ( Posting_Tag(..)
79 , Posting_Tags(..)
80 , Posting_Anchor(..)
81 , Posting_Anchors(..)
82 )
83 import Hcompta.Tag (Tags(..))
84 import qualified Hcompta.Tag as Tag
85 import Hcompta.Transaction ( Transaction_Tags(..)
86 , Transaction_Tag(..)
87 , Transaction_Anchor(..)
88 , Transaction_Anchors(..)
89 )
90 import qualified Hcompta.Transaction as Transaction
91 import qualified Hcompta.Unit as Unit
92 import qualified Hcompta.Filter.Date.Read as Filter.Date.Read
93 import Hcompta.Filter.Date.Read (Error(..))
94
95 import Hcompta.Format.JCC
96
97 -- * Type 'Read_Context'
98
99 data Read_Context c j
100 = Read_Context
101 { read_context_account_prefix :: !(Maybe Account)
102 , read_context_aliases_exact :: !(Map Account Account)
103 , read_context_aliases_joker :: ![(Account_Joker, Account)]
104 , read_context_aliases_regex :: ![(Regex, Account)]
105 , read_context_cons :: Charted Transaction -> c
106 , read_context_date :: !Date
107 , read_context_journal :: !(Journal j)
108 , read_context_unit :: !(Maybe Unit)
109 , read_context_year :: !Date.Year
110 }
111
112 read_context
113 :: Consable c j
114 => (Charted Transaction -> c)
115 -> Journal j
116 -> Read_Context c j
117 read_context read_context_cons read_context_journal =
118 Read_Context
119 { read_context_account_prefix = Nothing
120 , read_context_aliases_exact = mempty
121 , read_context_aliases_joker = []
122 , read_context_aliases_regex = []
123 , read_context_cons
124 , read_context_date = Date.nil
125 , read_context_journal
126 , read_context_unit = Nothing
127 , read_context_year = Date.year Date.nil
128 }
129
130 -- * Type 'Read_Error'
131
132 data Read_Error
133 = Read_Error_account_anchor_unknown R.SourcePos Account_Anchor
134 | Read_Error_account_anchor_not_unique R.SourcePos Account_Anchor
135 | Read_Error_date Date_Error
136 | Read_Error_transaction_not_equilibrated
137 Amount_Styles
138 Transaction
139 [( Unit
140 , Balance.Unit_Sum Account
141 (Polarize.Polarized Quantity)
142 )]
143 | Read_Error_virtual_transaction_not_equilibrated
144 Amount_Styles
145 Transaction
146 [( Unit
147 , Balance.Unit_Sum Account
148 (Polarize.Polarized Quantity)
149 )]
150 | Read_Error_reading_file FilePath Exception.IOException
151 | Read_Error_including_file FilePath [R.Error Read_Error]
152 deriving (Show)
153
154 -- * Read common patterns
155
156 is_space :: Char -> Bool
157 is_space c =
158 case Char.generalCategory c of
159 Char.Space -> True
160 _ -> False
161 read_space :: Stream s m Char => ParsecT s u m Char
162 read_space = R.satisfy is_space
163
164 is_char :: Char -> Bool
165 is_char c =
166 case Char.generalCategory c of
167 Char.UppercaseLetter -> True
168 Char.LowercaseLetter -> True
169 Char.TitlecaseLetter -> True
170 Char.ModifierLetter -> True
171 Char.OtherLetter -> True
172
173 Char.NonSpacingMark -> True
174 Char.SpacingCombiningMark -> True
175 Char.EnclosingMark -> True
176
177 Char.DecimalNumber -> True
178 Char.LetterNumber -> True
179 Char.OtherNumber -> True
180
181 Char.ConnectorPunctuation -> True
182 Char.DashPunctuation -> True
183 Char.OpenPunctuation -> True
184 Char.ClosePunctuation -> True
185 Char.InitialQuote -> True
186 Char.FinalQuote -> True
187 Char.OtherPunctuation -> True
188
189 Char.MathSymbol -> True
190 Char.CurrencySymbol -> True
191 Char.ModifierSymbol -> True
192 Char.OtherSymbol -> True
193
194 Char.Space -> False
195 Char.LineSeparator -> False
196 Char.ParagraphSeparator -> False
197 Char.Control -> False
198 Char.Format -> False
199 Char.Surrogate -> False
200 Char.PrivateUse -> False
201 Char.NotAssigned -> False
202 read_char :: Stream s m Char => ParsecT s u m Char
203 read_char = R.satisfy is_char
204
205 is_char_active :: Char -> Bool
206 is_char_active c =
207 case c of
208 '/' -> True
209 '\\' -> True
210 '!' -> True
211 '?' -> True
212 '\'' -> True
213 '"' -> True
214 '&' -> True
215 '|' -> True
216 '-' -> True
217 '+' -> True
218 '.' -> True
219 ':' -> True
220 '=' -> True
221 '<' -> True
222 '>' -> True
223 '@' -> True
224 '#' -> True
225 '(' -> True
226 ')' -> True
227 '[' -> True
228 ']' -> True
229 '{' -> True
230 '}' -> True
231 '~' -> True
232 '*' -> True
233 '^' -> True
234 ';' -> True
235 ',' -> True
236 _ -> False
237 read_char_active :: Stream s m Char => ParsecT s u m Char
238 read_char_active = R.satisfy is_char_active
239
240 is_char_passive :: Char -> Bool
241 is_char_passive c = is_char c && not (is_char_active c)
242 read_char_passive :: Stream s m Char => ParsecT s u m Char
243 read_char_passive = R.satisfy is_char_passive
244
245 read_word :: Stream s m Char => ParsecT s u m Text
246 read_word = fromString <$> R.many read_char_passive
247
248 read_words :: Stream s m Char => ParsecT s u m [Text]
249 read_words = R.many_separated read_word read_space
250
251 read_name :: Stream s m Char => ParsecT s u m Text
252 read_name = fromString <$> R.many1 read_char_passive
253
254 read_tabulation :: Stream s m Char => ParsecT s u m Char
255 read_tabulation = R.char '\t'
256
257 read_hspace :: Stream s m Char => ParsecT s u m Char
258 read_hspace = R.char ' '
259
260 read_hspaces :: Stream s m Char => ParsecT s u m ()
261 read_hspaces = void $ R.many read_hspace
262
263 read_hspaces1 :: Stream s m Char => ParsecT s u m ()
264 read_hspaces1 = void $ R.many1 read_hspace
265
266 read_eol :: Stream s m Char => ParsecT s u m ()
267 read_eol = ((R.<|>) (void $ R.char '\n') (void $ R.try $ R.string "\r\n")) <?> "eol"
268
269 read_line :: Stream s m Char => ParsecT s u m Text
270 read_line = fromString <$>
271 R.manyTill read_char (R.lookAhead read_eol <|> R.eof)
272 -- R.many (R.notFollowedBy eol >> char)
273
274 -- * Read 'Account'
275
276 read_account :: Stream s m Char => ParsecT s u m Account
277 read_account = do
278 Account.from_List <$> do
279 R.many1 (R.char read_account_section_sep >> read_account_section)
280
281 read_account_section :: Stream s m Char => ParsecT s u m Text
282 read_account_section = read_name
283
284 read_account_section_sep :: Char
285 read_account_section_sep = '/'
286
287 read_comment_prefix :: Char
288 read_comment_prefix = ';'
289
290 read_account_section_joker :: Stream s m Char => ParsecT s u m Account_Joker_Section
291 read_account_section_joker = do
292 n <- R.option Nothing $ (Just <$> read_account_section)
293 case n of
294 Nothing -> R.char read_account_section_sep >> return Account_Joker_Any
295 Just n' -> return $ Account_Joker_Section n'
296
297 read_account_joker :: Stream s m Char => ParsecT s u m Account_Joker
298 read_account_joker = do
299 R.notFollowedBy $ R.space_horizontal
300 R.many1_separated read_account_section_joker $ R.char read_account_section_sep
301
302 read_account_regex :: Stream s m Char => ParsecT s u m Regex
303 read_account_regex = do
304 re <- R.many1 $ R.satisfy (not . R.is_space_horizontal)
305 Regex.of_StringM re
306
307 read_account_pattern :: Stream s m Char => ParsecT s u m Account_Pattern
308 read_account_pattern = do
309 R.choice_try
310 [ Account_Pattern_Exact <$> (R.char '=' >> read_account)
311 , Account_Pattern_Joker <$> (R.char '*' >> read_account_joker)
312 , Account_Pattern_Regex <$> (R.option '~' (R.char '~') >> read_account_regex)
313 ]
314
315 -- * Read 'Account'
316
317 -- ** Read 'Account_Tag'
318 read_account_tag_prefix :: Char
319 read_account_tag_prefix = '.'
320 read_account_tag_sep :: Char
321 read_account_tag_sep = ':'
322 read_account_tag_value_prefix :: Char
323 read_account_tag_value_prefix = '='
324
325 read_account_tag :: Stream s m Char => ParsecT s u m Account_Tag
326 read_account_tag = (do
327 _ <- R.char read_account_tag_prefix
328 p <- read_name
329 Account.tag
330 <$> (:|) p <$>
331 R.many (R.char read_account_tag_sep >> read_name)
332 <*> (fromString <$>
333 R.option ""
334 (read_hspaces >> R.char read_transaction_tag_value_prefix >> read_hspaces >>
335 (List.concat <$> R.many (R.choice
336 [ R.string [read_account_tag_prefix , read_account_tag_prefix] >> return [read_account_tag_prefix]
337 , R.string [read_account_anchor_prefix, read_account_anchor_prefix] >> return [read_account_anchor_prefix]
338 , (\s c -> mappend s [c])
339 <$> R.many read_space
340 <*> R.satisfy (\c ->
341 c /= read_account_tag_prefix
342 && c /= read_account_anchor_prefix
343 && is_char c)
344 ]))))
345 ) <?> "account_tag"
346
347 -- ** Read 'Account_Anchor'
348 read_account_anchor_prefix :: Char
349 read_account_anchor_prefix = '~'
350 read_account_anchor_sep :: Char
351 read_account_anchor_sep = ':'
352
353 read_account_anchor :: Stream s m Char => ParsecT s u m Account_Anchor
354 read_account_anchor = (do
355 _ <- R.char read_account_anchor_prefix
356 p <- read_name
357 ps <- R.many (R.char read_account_anchor_sep >> read_name)
358 return $ Account.anchor (p:|ps)
359 ) <?> "account_anchor"
360
361 -- ** Read 'Account' 'Comment'
362 read_account_comment :: Stream s m Char => ParsecT s u m Comment
363 read_account_comment = read_comment
364
365 -- * Read 'Quantity'
366
367 read_quantity
368 :: Stream s m Char
369 => Char -- ^ Integral grouping separator.
370 -> Char -- ^ Fractioning separator.
371 -> Char -- ^ Fractional grouping separator.
372 -> ParsecT s u m
373 ( [String] -- integral
374 , [String] -- fractional
375 , Maybe Amount_Style_Fractioning -- fractioning
376 , Maybe Amount_Style_Grouping -- grouping_integral
377 , Maybe Amount_Style_Grouping -- grouping_fractional
378 )
379 read_quantity int_group_sep frac_sep frac_group_sep = do
380 (integral, grouping_integral) <- do
381 h <- R.many R.digit
382 case h of
383 [] -> return ([], Nothing)
384 _ -> do
385 t <- R.many $ R.char int_group_sep >> R.many1 R.digit
386 let digits = h:t
387 return (digits, grouping_of_digits int_group_sep digits)
388 (fractional, fractioning, grouping_fractional) <-
389 (case integral of
390 [] -> id
391 _ -> R.option ([], Nothing, Nothing)) $ do
392 fractioning <- R.char frac_sep
393 h <- R.many R.digit
394 t <- R.many $ R.char frac_group_sep >> R.many1 R.digit
395 let digits = h:t
396 return (digits, Just fractioning
397 , grouping_of_digits frac_group_sep $ List.reverse digits)
398 return $
399 ( integral
400 , fractional
401 , fractioning
402 , grouping_integral
403 , grouping_fractional
404 )
405 where
406 grouping_of_digits :: Char -> [String] -> Maybe Amount_Style_Grouping
407 grouping_of_digits group_sep digits =
408 case digits of
409 [] -> Nothing
410 [_] -> Nothing
411 _ -> Just $
412 Amount_Style_Grouping group_sep $
413 canonicalize_grouping $
414 List.map List.length $ digits
415 canonicalize_grouping :: [Int] -> [Int]
416 canonicalize_grouping groups =
417 List.foldl' -- NOTE: remove duplicates at beginning and reverse.
418 (\acc l0 -> case acc of
419 l1:_ -> if l0 == l1 then acc else l0:acc
420 _ -> l0:acc) [] $
421 case groups of -- NOTE: keep only longer at beginning.
422 l0:l1:t -> if l0 > l1 then groups else l1:t
423 _ -> groups
424
425 -- * Read 'Unit'
426
427 read_unit :: Stream s m Char => ParsecT s u m Unit
428 read_unit =
429 (quoted <|> unquoted) <?> "unit"
430 where
431 unquoted :: Stream s m Char => ParsecT s u m Unit
432 unquoted =
433 fromString <$> do
434 R.many1 $
435 R.satisfy $ \c ->
436 case Char.generalCategory c of
437 Char.CurrencySymbol -> True
438 Char.LowercaseLetter -> True
439 Char.ModifierLetter -> True
440 Char.OtherLetter -> True
441 Char.TitlecaseLetter -> True
442 Char.UppercaseLetter -> True
443 _ -> False
444 quoted :: Stream s m Char => ParsecT s u m Unit
445 quoted =
446 fromString <$> do
447 R.between (R.char '"') (R.char '"') $
448 R.many1 $
449 R.noneOf ";\n\""
450
451 -- * Read 'Amount'
452
453 read_amount
454 :: Stream s m Char
455 => ParsecT s u m (Amount_Styled Amount)
456 read_amount = (do
457 left_signing <- read_sign
458 left_unit <-
459 R.option Nothing $ do
460 u <- read_unit
461 s <- R.many $ R.space_horizontal
462 return $ Just $ (u, not $ List.null s)
463 (qty, style) <- do
464 signing <- read_sign
465 ( amount_style_integral
466 , amount_style_fractional
467 , amount_style_fractioning
468 , amount_style_grouping_integral
469 , amount_style_grouping_fractional
470 ) <-
471 R.choice_try
472 [ read_quantity '_' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
473 , read_quantity '_' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
474 , read_quantity ',' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
475 , read_quantity '.' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
476 ] <?> "quantity"
477 let int = List.concat amount_style_integral
478 let frac = List.concat amount_style_fractional
479 let precision = List.length frac
480 guard (precision <= 255)
481 let mantissa = R.integer_of_digits 10 $ int `mappend` frac
482 return $
483 ( Data.Decimal.Decimal
484 (fromIntegral precision)
485 (signing mantissa)
486 , mempty
487 { amount_style_fractioning
488 , amount_style_grouping_integral
489 , amount_style_grouping_fractional
490 }
491 )
492 ( amount_unit
493 , amount_style_unit_side
494 , amount_style_unit_spaced ) <-
495 case left_unit of
496 Just (u, s) ->
497 return (u, Just Amount_Style_Side_Left, Just s)
498 Nothing ->
499 R.option (Unit.unit_empty, Nothing, Nothing) $ R.try $ do
500 s <- R.many R.space_horizontal
501 u <- read_unit
502 return $
503 ( u
504 , Just Amount_Style_Side_Right
505 , Just $ not $ List.null s )
506 return $
507 ( style
508 { amount_style_unit_side
509 , amount_style_unit_spaced
510 }
511 , Amount
512 { amount_quantity = left_signing qty
513 , amount_unit
514 }
515 )) <?> "amount"
516
517 -- | Parse either '-' into 'negate', or '+' or '' into 'id'.
518 read_sign :: (Stream s m Char, Num i) => ParsecT s u m (i -> i)
519 read_sign =
520 (R.char '-' >> return negate)
521 <|> (R.char '+' >> return id)
522 <|> return id
523
524 -- * Read 'Date'
525
526 type Date_Error = Filter.Date.Read.Error
527
528 -- | Read a 'Date' in @[YYYY[/-]]MM[/-]DD[_HH:MM[:SS][TZ]]@ format.
529 read_date
530 :: (Stream s (R.Error_State e m) Char, Monad m)
531 => (Date_Error -> e) -> Maybe Integer
532 -> ParsecT s u (R.Error_State e m) Date
533 read_date err def_year = (do
534 let read_2_or_1_digits = R.try (R.count 2 R.digit) <|> R.count 1 R.digit
535 n0 <- R.many1 R.digit
536 day_sep <- R.char read_date_ymd_sep
537 n1 <- read_2_or_1_digits
538 n2 <- R.option Nothing $ R.try $ do
539 _ <- R.char day_sep
540 Just <$> read_2_or_1_digits
541 (year, m, d) <-
542 case (n2, def_year) of
543 (Nothing, Nothing) -> R.fail_with "date" (err $ Error_year_or_day_is_missing)
544 (Nothing, Just year) -> return (year, n0, n1)
545 (Just d, _) -> return (R.integer_of_digits 10 n0, n1, d)
546 let month = fromInteger $ R.integer_of_digits 10 m
547 let dom = fromInteger $ R.integer_of_digits 10 d
548 day <- case Time.fromGregorianValid year month dom of
549 Nothing -> R.fail_with "date" (err $ Error_invalid_date (year, month, dom))
550 Just day -> return day
551 (hour, minu, sec, tz) <-
552 R.option (0, 0, 0, Time.utc) $ R.try $ do
553 _ <- R.char '_'
554 hour <- read_2_or_1_digits
555 sep <- R.char read_hour_separator
556 minu <- read_2_or_1_digits
557 sec <- R.option Nothing $ R.try $ do
558 _ <- R.char sep
559 Just <$> read_2_or_1_digits
560 tz <- R.option Time.utc $ R.try $
561 read_time_zone
562 return
563 ( fromInteger $ R.integer_of_digits 10 hour
564 , fromInteger $ R.integer_of_digits 10 minu
565 , maybe 0 (R.integer_of_digits 10) sec
566 , tz )
567 tod <- case Time.makeTimeOfDayValid hour minu (fromInteger sec) of
568 Nothing -> R.fail_with "date" (err $ Error_invalid_time_of_day (hour, minu, sec))
569 Just tod -> return tod
570 return $ Time.localTimeToUTC tz (Time.LocalTime day tod)
571 ) <?> "date"
572
573 -- | Separator for year, month and day: "-".
574 read_date_ymd_sep :: Char
575 read_date_ymd_sep = '-'
576
577 -- | Separator for hour, minute and second: ":".
578 read_hour_separator :: Char
579 read_hour_separator = ':'
580
581 read_time_zone :: Stream s m Char => ParsecT s u m TimeZone
582 read_time_zone = Filter.Date.Read.time_zone
583
584 read_time_zone_digits :: Stream s m Char => ParsecT s u m TimeZone
585 read_time_zone_digits = Filter.Date.Read.time_zone_digits
586
587 -- * Read 'Comment'
588
589 read_comment
590 :: Stream s m Char
591 => ParsecT s u m Comment
592 read_comment = (do
593 _ <- R.char read_comment_prefix
594 fromString <$> do
595 R.manyTill R.anyChar (R.lookAhead (R.try read_eol <|> R.eof))
596 ) <?> "comment"
597
598 -- ** Read 'Comment's
599
600 read_comments
601 :: Stream s m Char
602 => ParsecT s u m [Comment]
603 read_comments = (do
604 R.try $ do
605 _ <- R.spaces
606 R.many1_separated read_comment
607 (read_eol >> read_hspaces)
608 <|> return []
609 ) <?> "comments"
610
611 -- * Read 'Posting'
612
613 read_posting ::
614 ( Consable c j
615 , Monad m
616 , Stream s (R.Error_State Read_Error m) Char
617 ) => ParsecT s (Read_Context c j)
618 (R.Error_State Read_Error m)
619 Posting
620 read_posting = (do
621 posting_sourcepos <- R.getPosition
622 ( posting_account
623 , posting_account_anchor ) <-
624 R.choice_try
625 [ (,Nothing) <$> read_account
626 , do
627 anchor <- read_account_anchor
628 ctx <- R.getState
629 let anchors = Chart.chart_anchors $
630 journal_chart $ read_context_journal ctx
631 case Map.lookup anchor anchors of
632 Just (a:|as) -> do
633 sa <- R.option Nothing $ Just <$> read_account
634 return $ ( a:|mappend as (maybe [] NonEmpty.toList sa)
635 , Just (anchor, sa) )
636 Nothing -> R.fail_with "account anchor"
637 (Read_Error_account_anchor_unknown posting_sourcepos anchor)
638 ] <?> "posting_account"
639 posting_amounts <-
640 R.option mempty $ R.try $ do
641 (style, amt) <- read_hspaces1 >> read_amount
642 ctx <- flip liftM R.getState $ \ctx ->
643 ctx
644 { read_context_journal=
645 let jnl = read_context_journal ctx in
646 jnl
647 { journal_amount_styles =
648 let Amount_Styles styles = journal_amount_styles jnl in
649 Amount_Styles $
650 Map.insertWith mappend
651 (amount_unit amt)
652 style styles
653 }
654 }
655 R.setState ctx
656 return $
657 let unit =
658 case amount_unit amt of
659 u | u == Unit.unit_empty ->
660 maybe u id $ read_context_unit ctx
661 u -> u in
662 Map.singleton unit $
663 amount_quantity amt
664 ( posting_tags
665 , posting_anchors
666 , posting_comments ) <- read_posting_attributes
667 return $ Posting
668 { posting_account
669 , posting_account_anchor
670 , posting_amounts
671 , posting_anchors = Posting_Anchors posting_anchors
672 , posting_tags = Posting_Tags posting_tags
673 , posting_comments
674 , posting_dates = []
675 , posting_sourcepos
676 }
677 ) <?> "posting"
678
679 read_posting_attributes
680 :: Stream s (R.Error_State Read_Error m) Char
681 => ParsecT s (Read_Context c j)
682 (R.Error_State Read_Error m)
683 (Tags, Anchors, [Comment])
684 read_posting_attributes =
685 R.option mempty $ R.try $ do
686 _ <- R.many (R.try (read_hspaces >> read_eol))
687 R.choice_try
688 [ read_hspaces1 >> read_posting_anchor >>= \(Posting_Anchor p) -> do
689 (tags, Anchors anchors, cmts) <- read_posting_attributes
690 return (tags, Anchors (Map.insert p () anchors), cmts)
691 , read_hspaces1 >> read_posting_tag >>= \(Posting_Tag (p, v)) -> do
692 (Tags tags, anchors, cmts) <- read_posting_attributes
693 return (Tags (Map.insertWith mappend p [v] tags), anchors, cmts)
694 , read_hspaces >> read_comment >>= \c -> do
695 (tags, anchors, cmts) <- read_posting_attributes
696 return (tags, anchors, c:cmts)
697 ]
698
699 read_amount_sep :: Char
700 read_amount_sep = '+'
701
702 read_posting_comment :: Stream s m Char => ParsecT s u m Comment
703 read_posting_comment = read_comment
704
705 -- ** Read 'Posting_Tag'
706 read_posting_tag :: Stream s m Char => ParsecT s u m Posting_Tag
707 read_posting_tag =
708 (liftM (\(Transaction_Tag t) -> Posting_Tag t)
709 read_transaction_tag) <?> "posting_tag"
710
711 -- ** Read 'Posting_Anchor'
712 read_posting_anchor :: Stream s m Char => ParsecT s u m Posting_Anchor
713 read_posting_anchor = (do
714 _ <- R.char read_transaction_anchor_prefix
715 Posting.anchor <$>
716 NonEmpty.fromList <$>
717 R.many1 (R.char read_transaction_anchor_sep >> read_name)
718 ) <?> "posting_anchor"
719
720 -- * Read 'Transaction'
721
722 read_transaction ::
723 ( Consable c j
724 , Monad m
725 , Stream s (R.Error_State Read_Error m) Char
726 ) => ParsecT s (Read_Context c j)
727 (R.Error_State Read_Error m)
728 Transaction
729 read_transaction = (do
730 transaction_sourcepos <- R.getPosition
731 ctx <- R.getState
732 date_ <- read_date Read_Error_date (Just $ read_context_year ctx)
733 dates_ <-
734 R.option [] $ R.try $ do
735 _ <- read_hspaces
736 _ <- R.char read_transaction_date_sep
737 _ <- read_hspaces
738 R.many_separated
739 (read_date Read_Error_date (Just $ read_context_year ctx)) $
740 R.try $
741 read_hspaces
742 >> R.char read_transaction_date_sep
743 >> read_hspaces
744 let transaction_dates = (date_, dates_)
745 read_hspaces1
746 transaction_wording <- read_transaction_wording
747 ( transaction_tags
748 , transaction_anchors
749 , transaction_comments
750 ) <- read_transaction_attributes
751 transaction_postings_unchecked <-
752 postings_by_account <$> read_postings
753 let transaction_unchecked =
754 Transaction
755 { transaction_anchors = Transaction_Anchors transaction_anchors
756 , transaction_tags = Transaction_Tags transaction_tags
757 , transaction_comments
758 , transaction_dates
759 , transaction_wording
760 , transaction_postings = transaction_postings_unchecked
761 , transaction_sourcepos
762 }
763 let styles = journal_amount_styles $ read_context_journal ctx
764 transaction_postings <-
765 case Balance.infer_equilibrium transaction_postings_unchecked of
766 (_, Left ko) -> R.fail_with "transaction infer_equilibrium" $
767 Read_Error_transaction_not_equilibrated styles transaction_unchecked ko
768 (_bal, Right ok) -> return ok
769 return $
770 transaction_unchecked
771 { transaction_postings
772 }
773 ) <?> "transaction"
774
775 read_transaction_attributes
776 :: Stream s (R.Error_State Read_Error m) Char
777 => ParsecT s (Read_Context c j)
778 (R.Error_State Read_Error m)
779 (Tags, Anchors, [Comment])
780 read_transaction_attributes =
781 R.option mempty $ R.try $ do
782 _ <- R.many (R.try (read_hspaces >> read_eol))
783 R.choice_try
784 [ read_hspaces1 >> read_transaction_anchor >>= \(Transaction_Anchor p) -> do
785 (tags, Anchors anchors, cmts) <- read_transaction_attributes
786 return (tags, Anchors (Map.insert p () anchors), cmts)
787 , read_hspaces1 >> read_transaction_tag >>= \(Transaction_Tag (p, v)) -> do
788 (Tags tags, anchors, cmts) <- read_transaction_attributes
789 return (Tags (Map.insertWith mappend p [v] tags), anchors, cmts)
790 , read_hspaces >> read_comment >>= \c -> do
791 (tags, anchors, cmts) <- read_transaction_attributes
792 return (tags, anchors, c:cmts)
793 ]
794
795 read_postings ::
796 (Consable c j, Monad m, Stream s (R.Error_State Read_Error m) Char)
797 => ParsecT s (Read_Context c j) (R.Error_State Read_Error m) [Posting]
798 read_postings = R.many $ R.try (read_hspaces >> read_eol >> read_hspaces1 >> read_posting)
799
800 read_transaction_date_sep :: Char
801 read_transaction_date_sep = '='
802
803 read_transaction_wording
804 :: Stream s m Char
805 => ParsecT s u m Wording
806 read_transaction_wording =
807 fromString . List.concat <$> (do
808 R.many1 $ R.try $ do
809 s <- R.many read_hspace
810 c <- R.satisfy $ \c ->
811 c /= read_transaction_tag_prefix &&
812 c /= read_transaction_anchor_prefix &&
813 c /= read_comment_prefix &&
814 is_char c
815 cs <- R.many (R.satisfy is_char)
816 return $ mappend s (c:cs)
817 ) <?> "wording"
818
819 -- ** Read 'Transaction_Anchor'
820
821 read_transaction_anchor_prefix :: Char
822 read_transaction_anchor_prefix = '@'
823 read_transaction_anchor_sep :: Char
824 read_transaction_anchor_sep = ':'
825
826 read_transaction_anchor :: Stream s m Char => ParsecT s u m Transaction_Anchor
827 read_transaction_anchor = (do
828 _ <- R.char read_transaction_anchor_prefix
829 p <- read_name
830 Transaction.anchor <$>
831 (:|) p <$>
832 R.many (R.char read_transaction_anchor_sep >> read_name)
833 ) <?> "transaction_anchor"
834
835 -- ** Read 'Transaction_Tag'
836
837 read_transaction_tag_prefix :: Char
838 read_transaction_tag_prefix = '#'
839 read_transaction_tag_sep :: Char
840 read_transaction_tag_sep = ':'
841 read_transaction_tag_value_prefix :: Char
842 read_transaction_tag_value_prefix = '='
843
844 read_transaction_tag :: Stream s m Char => ParsecT s u m Transaction_Tag
845 read_transaction_tag = (do
846 _ <- R.char read_transaction_tag_prefix
847 p <- read_name
848 Transaction.tag
849 <$>
850 (:|) p <$>
851 R.many (R.char read_transaction_tag_sep >> read_name)
852 <*> (R.option "" $ R.try $ do
853 read_hspaces
854 _ <- R.char read_transaction_tag_value_prefix
855 read_hspaces
856 read_transaction_tag_value)
857 ) <?> "transaction_tag"
858 where
859
860 read_transaction_tag_value
861 :: Stream s m Char
862 => ParsecT s u m Tag.Value
863 read_transaction_tag_value =
864 fromString . List.concat <$> do
865 R.many1 $ R.try $ do
866 s <- R.many read_hspace
867 c <- R.satisfy $ \c ->
868 c /= read_transaction_tag_prefix &&
869 c /= read_transaction_anchor_prefix &&
870 c /= read_comment_prefix &&
871 is_char c
872 cs <- R.many (R.satisfy is_char)
873 return $ mappend s (c:cs)
874
875 -- ** Read 'Transaction' 'Comment'
876 read_transaction_comment :: Stream s m Char => ParsecT s u m Comment
877 read_transaction_comment = read_comment
878
879 -- * Read directives
880
881 read_directive_alias
882 :: (Consable c j, Stream s m Char)
883 => ParsecT s (Read_Context c j) m ()
884 read_directive_alias = do
885 _ <- R.string "alias"
886 R.skipMany1 $ R.space_horizontal
887 pattern <- read_account_pattern
888 read_hspaces
889 _ <- R.char '='
890 read_hspaces
891 repl <- read_account
892 read_hspaces
893 case pattern of
894 Account_Pattern_Exact acct ->
895 R.modifyState $ \ctx -> ctx{read_context_aliases_exact=
896 Map.insert acct repl $ read_context_aliases_exact ctx}
897 Account_Pattern_Joker jokr ->
898 R.modifyState $ \ctx -> ctx{read_context_aliases_joker=
899 (jokr, repl):read_context_aliases_joker ctx}
900 Account_Pattern_Regex regx ->
901 R.modifyState $ \ctx -> ctx{read_context_aliases_regex=
902 (regx, repl):read_context_aliases_regex ctx}
903 return ()
904
905 read_default_year
906 :: (Consable c j, Stream s m Char)
907 => ParsecT s (Read_Context c j) m ()
908 read_default_year = (do
909 year <- R.integer_of_digits 10 <$> R.many1 R.digit
910 read_hspaces
911 read_context_ <- R.getState
912 R.setState read_context_{read_context_year=year}
913 ) <?> "default year"
914
915 read_default_unit_and_style
916 :: ( Consable c j
917 , Stream s m Char )
918 => ParsecT s (Read_Context c j) m ()
919 read_default_unit_and_style = (do
920 (sty, amt) <- read_amount
921 read_hspaces
922 ctx <- R.getState
923 let unit = Amount.amount_unit amt
924 R.setState ctx
925 { read_context_journal =
926 let jnl = read_context_journal ctx in
927 jnl
928 { journal_amount_styles =
929 let Amount_Styles styles =
930 journal_amount_styles jnl in
931 Amount_Styles $
932 Map.insertWith const unit sty styles
933 }
934 , read_context_unit = Just unit
935 }
936 ) <?> "default unit and style"
937
938 read_include ::
939 ( Consable c j
940 , Monoid j
941 , Stream s (R.Error_State Read_Error IO) Char
942 ) => ParsecT s (Read_Context c j) (R.Error_State Read_Error IO) ()
943 read_include = (do
944 sourcepos <- R.getPosition
945 filename <- R.manyTill R.anyChar (R.lookAhead (R.try read_eol <|> R.eof))
946 read_context_including <- R.getState
947 let journal_including = read_context_journal read_context_including
948 let cwd = Path.takeDirectory (R.sourceName sourcepos)
949 journal_file <- liftIO $ Path.abs cwd filename
950 content <- do
951 join $ liftIO $ Exception.catch
952 (liftM return $ Text.IO.readFile journal_file)
953 (return . R.fail_with "include reading" . Read_Error_reading_file journal_file)
954 (journal_included, read_context_included) <- do
955 liftIO $
956 R.runParserT_with_Error
957 (R.and_state $ read_journal_rec journal_file)
958 read_context_including
959 { read_context_journal=
960 journal
961 { journal_chart = journal_chart journal_including
962 , journal_amount_styles = journal_amount_styles journal_including
963 }
964 }
965 journal_file content
966 >>= \x -> case x of
967 Right ok -> return ok
968 Left ko -> R.fail_with "include parsing" (Read_Error_including_file journal_file ko)
969 R.setState $
970 read_context_included
971 { read_context_journal=
972 journal_including
973 { journal_includes=
974 journal_included{journal_files=[journal_file]} :
975 journal_includes journal_including
976 , journal_chart=
977 journal_chart journal_included
978 , journal_amount_styles=
979 journal_amount_styles journal_included
980 }
981 }
982 ) <?> "include"
983
984 -- * Read 'Chart'
985
986 read_chart ::
987 ( Consable c j
988 , Stream s (R.Error_State Read_Error IO) Char
989 ) => ParsecT s (Read_Context c j)
990 (R.Error_State Read_Error IO)
991 ()
992 read_chart = (do
993 -- sourcepos <- R.getPosition
994 acct <- read_account
995 _ <- read_eol
996 ( chart_tags
997 , chart_anchors
998 , _chart_comments ) <-
999 fields acct mempty mempty mempty
1000 let chart_accounts =
1001 TreeMap.singleton acct $
1002 Account_Tags chart_tags
1003 ctx <- R.getState
1004 let j = read_context_journal ctx
1005 R.setState $
1006 ctx{read_context_journal=
1007 j{journal_chart=
1008 mappend
1009 (journal_chart j)
1010 Chart.Chart
1011 { Chart.chart_accounts
1012 -- , Chart.chart_tags
1013 , Chart.chart_anchors
1014 }
1015 }
1016 }
1017 ) <?> "chart"
1018 where
1019 fields
1020 acct
1021 tags@(Tags tagm)
1022 anchors
1023 cmts =
1024 R.choice_try
1025 [ read_hspaces1 >> read_account_comment >>= \c ->
1026 fields acct tags anchors (c:cmts)
1027 , read_hspaces1 >> read_account_tag >>= \(Account_Tag (p, v)) ->
1028 fields acct (Tags $ Map.insertWith mappend p [v] tagm) anchors cmts
1029 , read_hspaces1 >> read_account_anchor >>= \anchor ->
1030 case Map.insertLookupWithKey (\_k n _o -> n) anchor acct anchors of
1031 (Nothing, m) -> fields acct tags m cmts
1032 (Just _, _) -> do
1033 sourcepos <- R.getPosition
1034 R.fail_with "account anchor not unique"
1035 (Read_Error_account_anchor_not_unique sourcepos anchor)
1036 , read_hspaces >> read_eol >>
1037 fields acct tags anchors cmts
1038 , return (tags, anchors, cmts)
1039 ]
1040
1041 -- * Read 'Journal'
1042
1043 read_journal ::
1044 ( Consable c j
1045 , Monoid j
1046 , Stream s (R.Error_State Read_Error IO) Char
1047 ) => FilePath
1048 -> ParsecT s (Read_Context c j)
1049 (R.Error_State Read_Error IO)
1050 (Journal j)
1051 read_journal filepath = (do
1052 currentLocalTime <- liftIO $
1053 Time.utcToLocalTime
1054 <$> Time.getCurrentTimeZone
1055 <*> Time.getCurrentTime
1056 let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
1057 ctx <- R.getState
1058 R.setState $ ctx{read_context_year=currentLocalYear}
1059 read_journal_rec filepath
1060 ) <?> "journal"
1061
1062 read_journal_rec ::
1063 ( Consable c j
1064 , Monoid j
1065 , Stream s (R.Error_State Read_Error IO) Char
1066 )
1067 => FilePath
1068 -> ParsecT s (Read_Context c j)
1069 (R.Error_State Read_Error IO)
1070 (Journal j)
1071 read_journal_rec journal_file = do
1072 last_read_time <- liftIO Date.now
1073 loop $
1074 R.choice_try
1075 [ jump_comment
1076 , jump_directive
1077 , jump_transaction
1078 , jump_chart
1079 ]
1080 journal_ <- read_context_journal <$> R.getState
1081 return $
1082 journal_
1083 { journal_files = [journal_file]
1084 , journal_includes = List.reverse $ journal_includes journal_
1085 , journal_last_read_time = last_read_time
1086 }
1087 where
1088 loop
1089 :: Stream s m Char
1090 => ParsecT s u m (ParsecT s u m ())
1091 -> ParsecT s u m ()
1092 loop r = do
1093 R.skipMany (read_hspaces >> read_eol)
1094 _ <- join r
1095 R.skipMany (read_hspaces >> read_eol)
1096 R.try (read_hspaces >> R.eof) <|> loop r
1097 jump_comment ::
1098 ( Consable c j
1099 , Stream s m Char
1100 , u ~ Read_Context c j
1101 , m ~ R.Error_State Read_Error IO
1102 )
1103 => ParsecT s u m (ParsecT s u m ())
1104 jump_comment = do
1105 _ <- R.spaces
1106 _ <- R.lookAhead (R.try $ R.char read_comment_prefix)
1107 return $ do
1108 _cmts <- read_comments
1109 {-
1110 R.modifyState $ \ctx ->
1111 let j = read_context_journal ctx in
1112 ctx{read_context_journal=
1113 j{journal_content=
1114 mcons (read_context_filter ctx) cmts $
1115 journal_content j}}
1116 -}
1117 return ()
1118 jump_directive ::
1119 ( Consable c j
1120 , Monoid j
1121 , Stream s m Char
1122 , u ~ Read_Context c j
1123 , m ~ R.Error_State Read_Error IO
1124 )
1125 => ParsecT s u m (ParsecT s u m ())
1126 jump_directive = do
1127 let choice s = R.string s >> R.skipMany1 R.space_horizontal
1128 R.choice_try
1129 [ choice "Y" >> return read_default_year
1130 , choice "D" >> return read_default_unit_and_style
1131 , choice "!include" >> return read_include
1132 ] <?> "directive"
1133 jump_transaction ::
1134 ( Consable c j
1135 , Stream s m Char
1136 , u ~ Read_Context c j
1137 , m ~ R.Error_State Read_Error IO
1138 )
1139 => ParsecT s u m (ParsecT s u m ())
1140 jump_transaction = do
1141 _ <- R.lookAhead $ R.try (R.many1 R.digit >> R.char read_date_ymd_sep)
1142 return $ do
1143 t <- read_transaction
1144 R.modifyState $ \ctx ->
1145 let j = read_context_journal ctx in
1146 ctx{read_context_journal=
1147 j{journal_content=
1148 mcons
1149 (read_context_cons ctx $
1150 Chart.Charted (journal_chart j) t)
1151 (journal_content j)}}
1152 jump_chart ::
1153 ( Consable c j
1154 , Stream s m Char
1155 , u ~ Read_Context c j
1156 , m ~ R.Error_State Read_Error IO
1157 )
1158 => ParsecT s u m (ParsecT s u m ())
1159 jump_chart = do
1160 return read_chart
1161
1162 -- * Read
1163
1164 read
1165 :: (Consable c j, Monoid j)
1166 => Read_Context c j
1167 -> FilePath
1168 -> ExceptT [R.Error Read_Error] IO (Journal j)
1169 read ctx path = do
1170 ExceptT $
1171 Exception.catch
1172 (liftM Right $ Text.IO.readFile path) $
1173 \ko -> return $ Left $
1174 [R.Error_Custom (R.initialPos path) $
1175 Read_Error_reading_file path ko]
1176 >>= liftIO . R.runParserT_with_Error
1177 (read_journal path) ctx path
1178 >>= \x -> case x of
1179 Left ko -> throwE $ ko
1180 Right ok -> ExceptT $ return $ Right ok