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