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