]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Format/Ledger/Read.hs
Ajout : CLI.Command.Balance : --redundant
[comptalang.git] / lib / Hcompta / Format / Ledger / Read.hs
1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE NamedFieldPuns #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# LANGUAGE ScopedTypeVariables #-}
6 {-# LANGUAGE TupleSections #-}
7 module Hcompta.Format.Ledger.Read where
8
9 import Control.Applicative ((<$>), (<*>), (<*))
10 import qualified Control.Exception as Exception
11 import Control.Arrow ((***))
12 import Control.Monad (guard, join, liftM, (>=>))
13 import Control.Monad.IO.Class (liftIO)
14 import Control.Monad.Trans.Except (ExceptT(..), throwE)
15 import qualified Data.Char
16 import qualified Data.Decimal
17 import qualified Data.Either
18 import qualified Data.List
19 import Data.List.NonEmpty (NonEmpty(..))
20 import qualified Data.Map.Strict as Data.Map
21 import Data.Maybe (fromMaybe)
22 import qualified Data.Time.Calendar as Time
23 import qualified Data.Time.Clock as Time
24 import qualified Data.Time.LocalTime as Time
25 import Data.Time.LocalTime (TimeZone(..))
26 import Data.Typeable ()
27 import qualified Text.Parsec as R
28 import Text.Parsec (Stream, ParsecT, (<|>), (<?>))
29 import qualified Data.Text.IO as Text.IO (readFile)
30 import qualified Data.Text as Text
31 import qualified System.FilePath.Posix as Path
32
33 import qualified Hcompta.Model.Account as Account
34 import Hcompta.Model.Account (Account)
35 import qualified Hcompta.Model.Amount as Amount
36 import Hcompta.Model.Amount (Amount)
37 import qualified Hcompta.Model.Amount.Style as Style
38 import qualified Hcompta.Model.Amount.Unit as Unit
39 import Hcompta.Model.Amount.Unit (Unit)
40 import qualified Hcompta.Model.Transaction as Transaction
41 import Hcompta.Model.Transaction (Transaction, Comment)
42 import qualified Hcompta.Model.Transaction.Posting as Posting
43 import Hcompta.Model.Transaction (Posting)
44 import qualified Hcompta.Model.Transaction.Tag as Tag
45 import Hcompta.Model.Transaction (Tag)
46 import qualified Hcompta.Model.Date as Date
47 import Hcompta.Model.Date (Date)
48 import Hcompta.Format.Ledger.Journal as Journal
49 import qualified Hcompta.Lib.Regex as Regex
50 import Hcompta.Lib.Regex (Regex)
51 import Hcompta.Lib.Parsec as R
52 import qualified Hcompta.Lib.Path as Path
53
54 data Context
55 = Context
56 { context_account_prefix :: !(Maybe Account)
57 , context_aliases_exact :: !(Data.Map.Map Account Account)
58 , context_aliases_joker :: ![(Account.Joker, Account)]
59 , context_aliases_regex :: ![(Regex, Account)]
60 , context_date :: !Date
61 , context_unit_and_style :: !(Maybe (Amount.Unit, Amount.Style))
62 , context_journal :: !Journal
63 , context_year :: !Date.Year
64 } deriving (Show)
65
66 nil_Context :: Context
67 nil_Context =
68 Context
69 { context_account_prefix = Nothing
70 , context_aliases_exact = Data.Map.empty
71 , context_aliases_joker = []
72 , context_aliases_regex = []
73 , context_date = Date.nil
74 , context_unit_and_style = Nothing
75 , context_journal = Journal.nil
76 , context_year = (\(year, _ , _) -> year) $
77 Time.toGregorian $ Time.utctDay $
78 Journal.last_read_time Journal.nil
79 }
80
81 -- | Parse either '-' into 'negate', or '+' or '' into 'id'.
82 sign :: (Stream s m Char, Num i) => ParsecT s u m (i -> i)
83 sign =
84 (R.char '-' >> return negate)
85 <|> (R.char '+' >> return id)
86 <|> return id
87
88 -- * Parsing 'Account'
89
90 account_name_sep :: Char
91 account_name_sep = ':'
92
93 -- | Parse an 'Account'.
94 account :: Stream s m Char => ParsecT s u m Account
95 account = do
96 R.notFollowedBy $ space_horizontal
97 Account.from_List <$> do
98 many1_separated account_name $ R.char account_name_sep
99
100 -- | Parse an Account.'Account.Name'.
101 account_name :: Stream s m Char => ParsecT s u m Account.Name
102 account_name = do
103 Text.pack <$> do
104 R.many1 $ R.try account_name_char
105 where
106 account_name_char :: Stream s m Char => ParsecT s u m Char
107 account_name_char = do
108 c <- R.anyChar
109 case c of
110 _ | c == comment_begin -> R.parserZero
111 _ | c == account_name_sep -> R.parserZero
112 _ | is_space_horizontal c -> do
113 _ <- R.notFollowedBy $ space_horizontal
114 return c <* (R.lookAhead $ R.try $
115 ( R.try (R.char account_name_sep)
116 <|> account_name_char
117 ))
118 _ | not (Data.Char.isSpace c) -> return c
119 _ -> R.parserZero
120
121 -- | Parse an Account.'Account.Joker_Name'.
122 account_joker_name :: Stream s m Char => ParsecT s u m Account.Joker_Name
123 account_joker_name = do
124 n <- R.option Nothing $ (Just <$> account_name)
125 case n of
126 Nothing -> R.char account_name_sep >> (return $ Account.Joker_Any)
127 Just n' -> return $ Account.Joker_Name n'
128
129 -- | Parse an Account.'Account.Joker'.
130 account_joker :: Stream s m Char => ParsecT s u m Account.Joker
131 account_joker = do
132 R.notFollowedBy $ space_horizontal
133 many1_separated account_joker_name $ R.char account_name_sep
134
135 -- | Parse a 'Regex'.
136 account_regex :: Stream s m Char => ParsecT s u m Regex
137 account_regex = do
138 re <- R.many1 $ R.satisfy (not . is_space_horizontal)
139 Regex.of_StringM re
140
141 -- | Parse an Account.'Account.Filter'.
142 account_pattern :: Stream s m Char => ParsecT s u m Account.Pattern
143 account_pattern = do
144 R.choice_try
145 [ Account.Pattern_Exact <$> (R.char '=' >> account)
146 , Account.Pattern_Joker <$> (R.char '*' >> account_joker)
147 , Account.Pattern_Regex <$> (R.option '~' (R.char '~') >> account_regex)
148 ]
149
150 -- * Parsing 'Amount'
151
152 -- | Parse an 'Amount'.
153 amount :: Stream s m Char => ParsecT s u m Amount
154 amount = do
155 left_signing <- sign
156 left_unit <-
157 R.option Nothing $ do
158 u <- unit
159 s <- R.many $ space_horizontal
160 return $ Just $ (u, not $ null s)
161 (quantity_, style) <- do
162 signing <- sign
163 Quantity
164 { integral
165 , fractional
166 , fractioning
167 , grouping_integral
168 , grouping_fractional
169 } <-
170 R.choice_try
171 [ quantity '_' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
172 , quantity '_' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
173 , quantity ',' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
174 , quantity '.' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
175 ] <?> "quantity"
176 let int = Data.List.concat integral
177 let frac_flat = Data.List.concat fractional
178 let frac = reverse $ Data.List.dropWhile (== '0') $ reverse $ frac_flat
179 let place = length frac
180 guard (place <= 255)
181 let mantissa = R.integer_of_digits 10 $ int ++ frac
182 return $
183 ( Data.Decimal.Decimal
184 (fromIntegral place)
185 (signing mantissa)
186 , Style.nil
187 { Style.fractioning
188 , Style.grouping_integral
189 , Style.grouping_fractional
190 , Style.precision = fromIntegral $ length frac_flat
191 }
192 )
193 (unit_, unit_side, unit_spaced) <-
194 case left_unit of
195 Just (u, s) ->
196 return (u, Just Style.Side_Left, Just s)
197 Nothing ->
198 R.option (Unit.nil, Nothing, Nothing) $ do
199 s <- R.many $ space_horizontal
200 u <- unit
201 return $ (u, Just Style.Side_Right, Just $ not $ null s)
202 return $
203 Amount.Amount
204 { Amount.quantity = left_signing $ quantity_
205 , Amount.style = style
206 { Style.unit_side
207 , Style.unit_spaced
208 }
209 , Amount.unit = unit_
210 }
211
212 data Quantity
213 = Quantity
214 { integral :: [String]
215 , fractional :: [String]
216 , fractioning :: Maybe Style.Fractioning
217 , grouping_integral :: Maybe Style.Grouping
218 , grouping_fractional :: Maybe Style.Grouping
219 }
220
221 -- | Parse a 'Quantity'.
222 quantity
223 :: Stream s m Char
224 => Char -- ^ Integral grouping separator.
225 -> Char -- ^ Fractioning separator.
226 -> Char -- ^ Fractional grouping separator.
227 -> ParsecT s u m Quantity
228 quantity int_group_sep frac_sep frac_group_sep = do
229 (integral, grouping_integral) <- do
230 h <- R.many R.digit
231 case h of
232 [] -> return ([], Nothing)
233 _ -> do
234 t <- R.many $ R.char int_group_sep >> R.many1 R.digit
235 let digits = h:t
236 return (digits, grouping_of_digits int_group_sep digits)
237 (fractional, fractioning, grouping_fractional) <-
238 (case integral of
239 [] -> id
240 _ -> R.option ([], Nothing, Nothing)) $ do
241 fractioning <- R.char frac_sep
242 h <- R.many R.digit
243 t <- R.many $ R.char frac_group_sep >> R.many1 R.digit
244 let digits = h:t
245 return (digits, Just fractioning
246 , grouping_of_digits frac_group_sep $ reverse digits)
247 return $
248 Quantity
249 { integral
250 , fractional
251 , fractioning
252 , grouping_integral
253 , grouping_fractional
254 }
255 where
256 grouping_of_digits :: Char -> [String] -> Maybe Style.Grouping
257 grouping_of_digits group_sep digits =
258 case digits of
259 [] -> Nothing
260 [_] -> Nothing
261 _ -> Just $
262 Style.Grouping group_sep $
263 canonicalize_grouping $
264 map length $ digits
265 canonicalize_grouping :: [Int] -> [Int]
266 canonicalize_grouping groups =
267 Data.List.foldl -- NOTE: remove duplicates at beginning and reverse.
268 (\acc l0 -> case acc of
269 l1:_ -> if l0 == l1 then acc else l0:acc
270 _ -> l0:acc) [] $
271 case groups of -- NOTE: keep only longer at beginning.
272 l0:l1:t -> if l0 > l1 then groups else l1:t
273 _ -> groups
274
275 -- | Parse an 'Unit'.
276 unit :: Stream s m Char => ParsecT s u m Unit
277 unit =
278 (quoted <|> unquoted) <?> "unit"
279 where
280 unquoted :: Stream s m Char => ParsecT s u m Unit
281 unquoted =
282 Text.pack <$> do
283 R.many1 $
284 R.satisfy $ \c ->
285 case Data.Char.generalCategory c of
286 Data.Char.CurrencySymbol -> True
287 Data.Char.LowercaseLetter -> True
288 Data.Char.ModifierLetter -> True
289 Data.Char.OtherLetter -> True
290 Data.Char.TitlecaseLetter -> True
291 Data.Char.UppercaseLetter -> True
292 _ -> False
293 quoted :: Stream s m Char => ParsecT s u m Unit
294 quoted =
295 Text.pack <$> do
296 R.between (R.char '"') (R.char '"') $
297 R.many1 $
298 R.noneOf ";\n\""
299
300 -- * Directives
301
302 directive_alias :: Stream s m Char => ParsecT s Context m ()
303 directive_alias = do
304 _ <- R.string "alias"
305 R.skipMany1 $ space_horizontal
306 pattern <- account_pattern
307 R.skipMany $ space_horizontal
308 _ <- R.char '='
309 R.skipMany $ space_horizontal
310 repl <- account
311 R.skipMany $ space_horizontal
312 case pattern of
313 Account.Pattern_Exact acct -> R.modifyState $ \ctx -> ctx{context_aliases_exact=
314 Data.Map.insert acct repl $ context_aliases_exact ctx}
315 Account.Pattern_Joker jokr -> R.modifyState $ \ctx -> ctx{context_aliases_joker=
316 (jokr, repl):context_aliases_joker ctx}
317 Account.Pattern_Regex regx -> R.modifyState $ \ctx -> ctx{context_aliases_regex=
318 (regx, repl):context_aliases_regex ctx}
319 return ()
320
321 -- | Parse the year, month and day separator: '/' or '-'.
322 date_separator :: Stream s m Char => ParsecT s u m Char
323 date_separator = R.satisfy (\c -> c == '/' || c == '-')
324
325 -- | Parse the hour, minute and second separator: ':'.
326 hour_separator :: Stream s m Char => ParsecT s u m Char
327 hour_separator = R.char ':'
328
329 -- * Parsing 'Date'
330
331 -- | Parse a 'Date' in [YYYY/]MM/DD [HH:MM[:SS][TZ]] format.
332 date :: Stream s m Char => Maybe Integer -> ParsecT s u m Date
333 date def_year = do
334 n0 <- R.many1 R.digit
335 day_sep <- date_separator
336 n1 <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit
337 n2 <- R.option Nothing $ R.try $ do
338 _ <- R.char day_sep
339 Just <$> do R.try (R.count 2 R.digit) <|> R.count 1 R.digit
340 (year, m, d) <-
341 case (n2, def_year) of
342 (Nothing, Nothing) -> fail "year or day is missing"
343 (Nothing, Just year) -> return (year, n0, n1)
344 (Just d, _) -> return (R.integer_of_digits 10 n0, n1, d)
345 let month = fromInteger $ R.integer_of_digits 10 m
346 let day = fromInteger $ R.integer_of_digits 10 d
347 guard $ month >= 1 && month <= 12
348 guard $ day >= 1 && day <= 31
349 day_ <- case Time.fromGregorianValid year month day of
350 Nothing -> fail "invalid day"
351 Just day_ -> return day_
352 (hour, minu, sec, tz) <-
353 R.option (0, 0, 0, Time.utc) $ R.try $ do
354 R.skipMany1 $ space_horizontal
355 hour <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit
356 sep <- hour_separator
357 minu <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit
358 sec <- R.option Nothing $ R.try $ do
359 _ <- R.char sep
360 Just <$> (R.try (R.count 2 R.digit) <|> R.count 1 R.digit)
361 -- DO: timezone
362 tz <- R.option Time.utc $ R.try $ do
363 R.skipMany $ space_horizontal
364 time_zone
365 return
366 ( R.integer_of_digits 10 hour
367 , R.integer_of_digits 10 minu
368 , maybe 0 (R.integer_of_digits 10) sec
369 , tz )
370 guard $ hour >= 0 && hour <= 23
371 guard $ minu >= 0 && minu <= 59
372 guard $ sec >= 0 && sec <= 60 -- NOTE: allow leap second
373 tod <- case Time.makeTimeOfDayValid
374 (fromInteger hour)
375 (fromInteger minu)
376 (fromInteger sec) of
377 Nothing -> fail "invalid time of day"
378 Just tod -> return tod
379 return $
380 Time.ZonedTime
381 (Time.LocalTime day_ tod)
382 tz
383 <?> "date"
384
385 time_zone :: Stream s m Char => ParsecT s u m TimeZone
386 time_zone =
387 -- DOC: http://www.timeanddate.com/time/zones/
388 -- TODO: only a few time zones are suported below.
389 -- TODO: check the timeZoneSummerOnly values
390 R.choice
391 [ R.char 'A' >> R.choice
392 [ R.string "ST" >> return (TimeZone ((-4) * 60) False "AST")
393 , R.string "DT" >> return (TimeZone ((-3) * 60) True "ADT")
394 , return (TimeZone ((-1) * 60) False "A")
395 ]
396 , R.char 'B' >> R.choice
397 [ R.string "ST" >> return (TimeZone ((-11) * 60) False "BST")
398 , R.string "DT" >> return (TimeZone ((-10) * 60) True "BDT")
399 ]
400 , R.char 'C' >> R.choice
401 [ R.char 'E' >> R.choice
402 [ R.string "T" >> return (TimeZone ((1) * 60) True "CET")
403 , R.string "ST" >> return (TimeZone ((2) * 60) False "CEST")
404 ]
405 , R.string "ST" >> return (TimeZone ((-6) * 60) False "CST")
406 , R.string "DT" >> return (TimeZone ((-5) * 60) True "CDT")
407 ]
408 , R.char 'E' >> R.choice
409 [ R.string "ST" >> return (TimeZone ((-5) * 60) False "EST")
410 , R.string "DT" >> return (TimeZone ((-4) * 60) True "EDT")
411 ]
412 , R.string "GMT" >> return (TimeZone 0 False "GMT")
413 , R.char 'H' >> R.choice
414 [ R.string "ST" >> return (TimeZone ((-10) * 60) False "HST")
415 , R.string "DT" >> return (TimeZone (( -9) * 60) True "HDT")
416 ]
417 , R.char 'M' >> R.choice
418 [ R.string "ST" >> return (TimeZone ((-7) * 60) False "MST")
419 , R.string "DT" >> return (TimeZone ((-6) * 60) True "MDT")
420 , return (TimeZone ((-12) * 60) False "M")
421 ]
422 , R.char 'N' >> R.choice
423 [ R.string "ST" >> return (TimeZone ((-3) * 60 - 30) False "NST")
424 , return (TimeZone (1 * 60) False "N")
425 ]
426 , R.char 'P' >> R.choice
427 [ R.string "ST" >> return (TimeZone ((-8) * 60) False "PST")
428 , R.string "DT" >> return (TimeZone ((-7) * 60) True "PDT")
429 ]
430 , R.char 'Y' >> R.choice
431 [ R.string "ST" >> return (TimeZone ((-9) * 60) False "YST")
432 , R.string "DT" >> return (TimeZone ((-8) * 60) True "YDT")
433 , return (TimeZone (12 * 60) False "Y")
434 ]
435 , R.char 'Z' >> return (TimeZone 0 False "Z")
436 , time_zone_digits
437 ]
438
439 time_zone_digits :: Stream s m Char => ParsecT s u m TimeZone
440 {-# INLINEABLE time_zone_digits #-}
441 time_zone_digits = do
442 sign_ <- sign
443 hour <- R.integer_of_digits 10 <$> R.count 2 R.digit
444 _ <- R.option ':' (R.char ':')
445 minute <- R.integer_of_digits 10 <$> R.count 2 R.digit
446 let tz = TimeZone
447 { timeZoneMinutes = sign_ (fromInteger hour * 60 + fromInteger minute)
448 , timeZoneSummerOnly = False
449 , timeZoneName = Time.timeZoneOffsetString tz
450 }
451 return tz
452
453 -- * Parsing 'Comment'
454
455 comment_begin :: Char
456 comment_begin = ';'
457
458 comment :: Stream s m Char => ParsecT s u m Comment
459 comment = do
460 _ <- R.char comment_begin
461 Text.pack <$> do
462 R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
463 <?> "comment"
464
465 comments :: Stream s m Char => ParsecT s u m [Comment]
466 comments = do
467 R.try $ do
468 R.skipMany $ R.satisfy Data.Char.isSpace
469 many1_separated comment $
470 Text.pack <$> do
471 R.many1 $ do
472 R.try space_horizontal
473 <|> (R.new_line >> space_horizontal)
474 <|> return []
475
476 -- * Parsing 'Tag'
477
478 tag_value_sep :: Char
479 tag_value_sep = ':'
480
481 tag_sep :: Char
482 tag_sep = ','
483
484 -- | Parse a 'Tag'.
485 tag :: Stream s m Char => ParsecT s u m Tag
486 tag = do
487 n <- tag_name
488 _ <- R.char tag_value_sep
489 v <- tag_value
490 return (n, v)
491 <?> "tag"
492
493 tag_name :: Stream s m Char => ParsecT s u m Tag.Name
494 tag_name = do
495 Text.pack <$> do
496 R.many1 $ R.satisfy (\c -> c /= tag_value_sep && not (Data.Char.isSpace c))
497
498 tag_value :: Stream s m Char => ParsecT s u m Tag.Value
499 tag_value = do
500 Text.pack <$> do
501 R.manyTill R.anyChar $ do
502 R.lookAhead $ do
503 R.try (R.char tag_sep >> R.many space_horizontal >> tag_name >> R.char tag_value_sep >> return ())
504 <|> R.try R.new_line
505 <|> R.eof
506
507 tags :: Stream s m Char => ParsecT s u m Tag.By_Name
508 tags = do
509 Tag.from_List <$> do
510 R.many_separated tag $ do
511 _ <- R.char tag_sep
512 R.skipMany $ space_horizontal
513 return ()
514
515 not_tag :: Stream s m Char => ParsecT s u m ()
516 not_tag = do
517 R.skipMany $ R.try $ do
518 R.skipMany $ R.satisfy
519 (\c -> c /= tag_value_sep
520 && not (Data.Char.isSpace c))
521 space_horizontal
522
523 -- * Parsing 'Posting'
524
525 -- | Parse a 'Posting'.
526 posting :: Stream s m Char => ParsecT s Context m (Posting, Posting.Type)
527 posting = do
528 ctx <- R.getState
529 sourcepos <- R.getPosition
530 comments_ <- comments
531 R.skipMany1 $ space_horizontal
532 status_ <- status
533 R.skipMany $ space_horizontal
534 acct <- account
535 let (type_, account_) = posting_type acct
536 amounts_ <-
537 R.choice_try
538 [ do
539 _ <- R.count 2 space_horizontal
540 R.skipMany $ space_horizontal
541 Amount.from_List <$> do
542 R.many_separated amount $ R.try $ do
543 R.skipMany $ space_horizontal
544 _ <- R.char amount_sep
545 R.skipMany $ space_horizontal
546 return ()
547 , return Data.Map.empty
548 ]
549 R.skipMany $ space_horizontal
550 -- TODO: balance assertion
551 -- TODO: conversion
552 comments__ <- (comments_ ++) <$> comments
553 let tags_ = tags_of_comments comments__
554 dates_ <-
555 case Data.Map.lookup "date" tags_ of
556 Nothing -> return []
557 Just dates -> do
558 let date2s = Data.Map.lookup "date2" tags_ -- NOTE: support hledger's date2
559 dates_ <- (flip mapM) (dates ++ fromMaybe [] date2s) $
560 R.runParserT (date (Just $ context_year ctx) <* R.eof) () ""
561 >=> \x -> case x of
562 Left ko -> fail $ show ko
563 Right ok -> return ok
564 case (dates, date2s) of -- NOTE: put hledger's date2 at least in second position
565 ([], Just (_:_)) ->
566 return $ context_date ctx:dates_
567 _ -> return $ dates_
568 return (Posting.Posting
569 { Posting.account=account_
570 , Posting.amounts=amounts_
571 , Posting.comments=comments__
572 , Posting.dates=dates_
573 , Posting.sourcepos=sourcepos
574 , Posting.status=status_
575 , Posting.tags=tags_
576 }, type_)
577 <?> "posting"
578
579 amount_sep :: Char
580 amount_sep = '+'
581
582 tags_of_comments :: [Comment] -> Tag.By_Name
583 tags_of_comments =
584 Data.Map.unionsWith (++)
585 . Data.List.map
586 ( Data.Either.either (const Data.Map.empty) id
587 . R.runParser (not_tag >> tags <* R.eof) () "" )
588
589 status :: Stream s m Char => ParsecT s u m Transaction.Status
590 status =
591 ( R.try $ do
592 R.skipMany $ space_horizontal
593 _ <- (R.char '*' <|> R.char '!') <?> "status"
594 return True )
595 <|> return False
596 <?> "status"
597
598 -- | Return the Posting.'Posting.Type' and stripped 'Account' of the given 'Account'.
599 posting_type :: Account -> (Posting.Type, Account)
600 posting_type acct =
601 fromMaybe (Posting.Type_Regular, acct) $ do
602 case acct of
603 name:|[] ->
604 case Text.stripPrefix virtual_begin name of
605 Just name' -> do
606 name'' <-
607 Text.stripSuffix virtual_end name'
608 >>= return . Text.strip
609 guard $ not $ Text.null name''
610 Just (Posting.Type_Virtual, name'':|[])
611 Nothing -> do
612 name' <-
613 Text.stripPrefix virtual_balanced_begin name
614 >>= Text.stripSuffix virtual_balanced_end
615 >>= return . Text.strip
616 guard $ not $ Text.null name'
617 Just (Posting.Type_Virtual_Balanced, name':|[])
618 first_name:|acct' -> do
619 let rev_acct' = Data.List.reverse acct'
620 let last_name = Data.List.head rev_acct'
621 case Text.stripPrefix virtual_begin first_name
622 >>= return . Text.stripStart of
623 Just first_name' -> do
624 last_name' <-
625 Text.stripSuffix virtual_end last_name
626 >>= return . Text.stripEnd
627 guard $ not $ Text.null first_name'
628 guard $ not $ Text.null last_name'
629 Just $
630 ( Posting.Type_Virtual
631 , first_name':|
632 Data.List.reverse (last_name':Data.List.tail rev_acct')
633 )
634 Nothing -> do
635 first_name' <-
636 Text.stripPrefix virtual_balanced_begin first_name
637 >>= return . Text.stripStart
638 last_name' <-
639 Text.stripSuffix virtual_balanced_end last_name
640 >>= return . Text.stripEnd
641 guard $ not $ Text.null first_name'
642 guard $ not $ Text.null last_name'
643 Just $
644 ( Posting.Type_Virtual_Balanced
645 , first_name':|
646 Data.List.reverse (last_name':Data.List.tail rev_acct')
647 )
648 where
649 virtual_begin = Text.singleton posting_type_virtual_begin
650 virtual_end = Text.singleton posting_type_virtual_end
651 virtual_balanced_begin = Text.singleton posting_type_virtual_balanced_begin
652 virtual_balanced_end = Text.singleton posting_type_virtual_balanced_end
653
654 posting_type_virtual_begin :: Char
655 posting_type_virtual_begin = '('
656 posting_type_virtual_balanced_begin :: Char
657 posting_type_virtual_balanced_begin = '['
658 posting_type_virtual_end :: Char
659 posting_type_virtual_end = ')'
660 posting_type_virtual_balanced_end :: Char
661 posting_type_virtual_balanced_end = ']'
662
663 -- * Parsing 'Transaction'
664
665 transaction :: Stream s m Char => ParsecT s Context m Transaction
666 transaction = do
667 sourcepos <- R.getPosition
668 ctx <- R.getState
669 comments_before <- comments
670 date_ <- date (Just $ context_year ctx)
671 dates_ <-
672 R.option [] $ R.try $ do
673 R.skipMany $ space_horizontal
674 _ <- R.char date_sep
675 R.skipMany $ space_horizontal
676 R.many_separated
677 (date (Just $ context_year ctx)) $
678 R.try $ do
679 R.many $ space_horizontal
680 >> R.char date_sep
681 >> (R.many $ space_horizontal)
682 R.skipMany $ space_horizontal
683 status_ <- status
684 code_ <- R.option "" $ R.try code
685 R.skipMany $ space_horizontal
686 description_ <- description
687 R.skipMany $ space_horizontal
688 comments_after <- comments
689 let tags_ =
690 Data.Map.unionWith (++)
691 (tags_of_comments comments_before)
692 (tags_of_comments comments_after)
693 R.new_line
694 postings_ <- many1_separated posting R.new_line
695 let (postings, postings__) =
696 (Posting.from_List . Data.List.map fst) *** id $
697 Data.List.partition
698 ((Posting.Type_Regular ==) . snd)
699 postings_
700 let (virtual_postings, balanced_virtual_postings) =
701 join (***) (Posting.from_List . Data.List.map fst) $
702 Data.List.partition
703 ((Posting.Type_Virtual ==) . snd)
704 postings__
705 return $
706 Transaction.Transaction
707 { Transaction.code=code_
708 , Transaction.comments_before
709 , Transaction.comments_after
710 , Transaction.dates=(date_, dates_)
711 , Transaction.description=description_
712 , Transaction.postings
713 , Transaction.virtual_postings
714 , Transaction.balanced_virtual_postings
715 , Transaction.sourcepos
716 , Transaction.status=status_
717 , Transaction.tags=tags_
718 }
719 <?> "transaction"
720
721 date_sep :: Char
722 date_sep = '='
723
724 code :: Stream s m Char => ParsecT s Context m Transaction.Code
725 code = do
726 Text.pack <$> do
727 R.skipMany $ space_horizontal
728 R.between (R.char '(') (R.char ')') $
729 R.many $ R.satisfy (\c -> c /= ')' && not (is_space_horizontal c))
730 <?> "code"
731
732 description :: Stream s m Char => ParsecT s u m Transaction.Description
733 description = do
734 Text.pack <$> do
735 R.many $ R.try description_char
736 <?> "description"
737 where
738 description_char :: Stream s m Char => ParsecT s u m Char
739 description_char = do
740 c <- R.anyChar
741 case c of
742 _ | c == comment_begin -> R.parserZero
743 _ | is_space_horizontal c -> return c <* (R.lookAhead $ R.try $ description_char)
744 _ | not (Data.Char.isSpace c) -> return c
745 _ -> R.parserZero
746
747 -- * Parsing directives
748
749 default_year :: Stream s m Char => ParsecT s Context m ()
750 default_year = do
751 year <- R.integer_of_digits 10 <$> R.many1 R.digit
752 context_ <- R.getState
753 R.setState context_{context_year=year}
754
755 default_unit_and_style :: Stream s m Char => ParsecT s Context m ()
756 default_unit_and_style = do
757 R.skipMany1 space_horizontal
758 amount_ <- amount
759 R.skipMany space_horizontal >> R.new_line >> R.skipMany space_horizontal
760 context_ <- R.getState
761 R.setState context_{context_unit_and_style=Just $
762 ( Amount.unit amount_
763 , Amount.style amount_ )}
764
765 include :: Stream s IO Char => ParsecT s Context IO ()
766 include = do
767 sourcepos <- R.getPosition
768 R.skipMany1 $ space_horizontal
769 filename <- R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
770 context_ <- R.getState
771 let journal_ = context_journal context_
772 let cwd = Path.takeDirectory (R.sourceName sourcepos)
773 file_ <- liftIO $ Path.abs cwd filename
774 (journal_included, context_included) <- liftIO $
775 Exception.catch
776 (readFile file_)
777 (\ko -> fail $ concat -- TODO: i18n by using a custom data type
778 [ show sourcepos
779 , " reading "
780 , file_
781 , ":\n", show (ko::Exception.IOException)
782 ])
783 >>= R.runParserT (R.and_state $ journal_rec file_)
784 context_{context_journal = Journal.nil}
785 file_
786 >>= \x -> case x of
787 Left ko -> fail $ show ko
788 Right ok -> return ok
789 R.setState $
790 context_included{context_journal=
791 journal_{Journal.includes=
792 journal_included{Journal.file=file_}
793 : Journal.includes journal_}}
794 <?> "include"
795
796 -- * Parsing 'Journal'
797
798 journal :: Stream s IO Char => FilePath -> ParsecT s Context IO Journal
799 journal file_ = do
800 currentLocalTime <- liftIO $
801 Time.utcToLocalTime
802 <$> Time.getCurrentTimeZone
803 <*> Time.getCurrentTime
804 let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
805 context_ <- R.getState
806 R.setState $ context_{context_year=currentLocalYear}
807 journal_rec file_
808 <?> "journal"
809
810 journal_rec :: Stream s IO Char => FilePath -> ParsecT s Context IO Journal
811 journal_rec file_ = do
812 last_read_time <- liftIO $ Time.getCurrentTime
813 R.skipMany $ do
814 R.skipMany1 R.space
815 <|> ((R.choice_try
816 [ R.string "Y" >> return default_year
817 , R.string "D" >> return default_unit_and_style
818 , R.string "!include" >> return include
819 ] <?> "directive") >>= id)
820 <|> do
821 t <- transaction
822 context_' <- R.getState
823 let j = context_journal context_'
824 R.setState $ context_'{context_journal=
825 j{Journal.transactions=
826 Data.Map.insertWith (flip (++))
827 -- NOTE: flip-ing preserves order but slows down
828 -- when many transactions have the very same date.
829 (Date.to_UTC $ fst $ Transaction.dates t) [t]
830 (Journal.transactions j)}}
831 R.new_line <|> R.eof
832
833 R.skipMany $ R.satisfy Data.Char.isSpace
834 R.eof
835 journal_ <- context_journal <$> R.getState
836 return $
837 journal_
838 { Journal.file = file_
839 , Journal.last_read_time
840 , Journal.includes = reverse $ Journal.includes journal_
841 }
842
843 -- ** Parsing 'Journal' from a file
844
845 file :: FilePath -> ExceptT String IO Journal
846 file path = do
847 ExceptT $
848 Exception.catch
849 (liftM Right $ Text.IO.readFile path) $
850 \ko -> return $ Left $ show (ko::Exception.IOException)
851 >>= liftIO . R.runParserT (journal path) nil_Context path
852 >>= \x -> case x of
853 Left ko -> throwE $ show ko
854 Right ok -> ExceptT $ return $ Right ok