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