]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Format/Ledger/Read.hs
Ajout : CLI.Command.Journal : chronométrage du parsage.
[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 Control.Monad.Trans.Class (lift)
16 import qualified Data.Char
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 Data.String (fromString)
23 import qualified Data.Time.Calendar as Time
24 import qualified Data.Time.Clock as Time
25 import qualified Data.Time.LocalTime as Time
26 import Data.Typeable ()
27 import qualified Text.Parsec as R hiding
28 ( char
29 , anyChar
30 , crlf
31 , newline
32 , noneOf
33 , oneOf
34 , satisfy
35 , space
36 , spaces
37 , string
38 )
39 import Text.Parsec (Stream, ParsecT, (<|>), (<?>))
40 import qualified Text.Parsec.Pos as R
41 import qualified Data.Text.IO as Text.IO (readFile)
42 import qualified Data.Text as Text
43 import qualified System.FilePath.Posix as Path
44
45 import qualified Hcompta.Balance as Balance
46 import qualified Hcompta.Account as Account
47 import Hcompta.Account (Account)
48 import qualified Hcompta.Amount as Amount
49 import qualified Hcompta.Amount.Style as Style
50 import qualified Hcompta.Amount.Read as Amount.Read
51 import qualified Hcompta.Amount.Unit as Unit
52 import qualified Hcompta.Date as Date
53 import Hcompta.Date (Date)
54 import qualified Hcompta.Date.Read as Date.Read
55 import qualified Hcompta.Format.Ledger as Ledger
56 import Hcompta.Format.Ledger
57 ( Comment
58 , Journal(..)
59 , Posting(..), Posting_Type(..)
60 , Tag, Tag_Name, Tag_Value, Tag_by_Name
61 , Transaction(..)
62 )
63 import qualified Hcompta.Lib.Regex as Regex
64 import Hcompta.Lib.Regex (Regex)
65 import qualified Hcompta.Lib.Parsec as R
66 import qualified Hcompta.Lib.Path as Path
67
68 data Context
69 = Context
70 { context_account_prefix :: !(Maybe Account)
71 , context_aliases_exact :: !(Data.Map.Map Account Account)
72 , context_aliases_joker :: ![(Account.Joker, Account)]
73 , context_aliases_regex :: ![(Regex, Account)]
74 , context_date :: !Date
75 , context_unit_and_style :: !(Maybe (Amount.Unit, Amount.Style))
76 , context_journal :: !Journal
77 , context_year :: !Date.Year
78 } deriving (Show)
79
80 nil_Context :: Context
81 nil_Context =
82 Context
83 { context_account_prefix = Nothing
84 , context_aliases_exact = Data.Map.empty
85 , context_aliases_joker = []
86 , context_aliases_regex = []
87 , context_date = Date.nil
88 , context_unit_and_style = Nothing
89 , context_journal = Ledger.journal
90 , context_year = (\(year, _ , _) -> year) $
91 Time.toGregorian $ Time.utctDay $
92 journal_last_read_time Ledger.journal
93 }
94
95 data Error
96 = Error_date Date.Read.Error
97 | Error_transaction_not_equilibrated Transaction [Balance.Unit_Sum (Balance.Posting_Amount Ledger.Posting)]
98 | Error_virtual_transaction_not_equilibrated Transaction [Balance.Unit_Sum (Balance.Posting_Amount Ledger.Posting)]
99 | Error_reading_file FilePath Exception.IOException
100 | Error_including_file FilePath [R.Error Error]
101 deriving (Show)
102
103 -- * Read 'Account'
104
105 account_name_sep :: Char
106 account_name_sep = ':'
107
108 -- | Read an 'Account'.
109 account :: Stream s m Char => ParsecT s u m Account
110 account = do
111 R.notFollowedBy $ R.space_horizontal
112 Account.from_List <$> do
113 R.many1_separated account_name $ R.char account_name_sep
114
115 -- | Read an Account.'Account.Name'.
116 account_name :: Stream s m Char => ParsecT s u m Account.Name
117 account_name = do
118 fromString <$> do
119 R.many1 $ R.try account_name_char
120 where
121 account_name_char :: Stream s m Char => ParsecT s u m Char
122 account_name_char = do
123 c <- R.anyChar
124 case c of
125 _ | c == comment_begin -> R.parserZero
126 _ | c == account_name_sep -> R.parserZero
127 _ | R.is_space_horizontal c -> do
128 _ <- R.notFollowedBy $ R.space_horizontal
129 return c <* (R.lookAhead $ R.try $
130 ( R.try (R.char account_name_sep)
131 <|> account_name_char
132 ))
133 _ | not (Data.Char.isSpace c) -> return c
134 _ -> R.parserZero
135
136 -- | Read an Account.'Account.Joker_Name'.
137 account_joker_name :: Stream s m Char => ParsecT s u m Account.Joker_Name
138 account_joker_name = do
139 n <- R.option Nothing $ (Just <$> account_name)
140 case n of
141 Nothing -> R.char account_name_sep >> (return $ Account.Joker_Any)
142 Just n' -> return $ Account.Joker_Name n'
143
144 -- | Read an Account.'Account.Joker'.
145 account_joker :: Stream s m Char => ParsecT s u m Account.Joker
146 account_joker = do
147 R.notFollowedBy $ R.space_horizontal
148 R.many1_separated account_joker_name $ R.char account_name_sep
149
150 -- | Read a 'Regex'.
151 account_regex :: Stream s m Char => ParsecT s u m Regex
152 account_regex = do
153 re <- R.many1 $ R.satisfy (not . R.is_space_horizontal)
154 Regex.of_StringM re
155
156 -- | Read an Account.'Account.Filter'.
157 account_pattern :: Stream s m Char => ParsecT s u m Account.Pattern
158 account_pattern = do
159 R.choice_try
160 [ Account.Pattern_Exact <$> (R.char '=' >> account)
161 , Account.Pattern_Joker <$> (R.char '*' >> account_joker)
162 , Account.Pattern_Regex <$> (R.option '~' (R.char '~') >> account_regex)
163 ]
164
165 -- * Directives
166
167 directive_alias :: Stream s m Char => ParsecT s Context m ()
168 directive_alias = do
169 _ <- R.string "alias"
170 R.skipMany1 $ R.space_horizontal
171 pattern <- account_pattern
172 R.skipMany $ R.space_horizontal
173 _ <- R.char '='
174 R.skipMany $ R.space_horizontal
175 repl <- account
176 R.skipMany $ R.space_horizontal
177 case pattern of
178 Account.Pattern_Exact acct -> R.modifyState $ \ctx -> ctx{context_aliases_exact=
179 Data.Map.insert acct repl $ context_aliases_exact ctx}
180 Account.Pattern_Joker jokr -> R.modifyState $ \ctx -> ctx{context_aliases_joker=
181 (jokr, repl):context_aliases_joker ctx}
182 Account.Pattern_Regex regx -> R.modifyState $ \ctx -> ctx{context_aliases_regex=
183 (regx, repl):context_aliases_regex ctx}
184 return ()
185
186
187 -- * Read 'Comment'
188
189 comment_begin :: Char
190 comment_begin = ';'
191
192 comment :: Stream s m Char => ParsecT s u m Comment
193 comment = (do
194 _ <- R.char comment_begin
195 fromString <$> do
196 R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
197 ) <?> "comment"
198
199 comments :: Stream s m Char => ParsecT s u m [Comment]
200 comments = (do
201 R.try $ do
202 _ <- R.spaces
203 R.many1_separated comment (R.new_line >> R.skipMany R.space_horizontal)
204 <|> return []
205 ) <?> "comments"
206
207 -- * Read 'Tag'
208
209 tag_value_sep :: Char
210 tag_value_sep = ':'
211
212 tag_sep :: Char
213 tag_sep = ','
214
215 -- | Read a 'Tag'.
216 tag :: Stream s m Char => ParsecT s u m Tag
217 tag = (do
218 n <- tag_name
219 _ <- R.char tag_value_sep
220 v <- tag_value
221 return (n, v)
222 ) <?> "tag"
223
224 tag_name :: Stream s m Char => ParsecT s u m Tag_Name
225 tag_name = do
226 fromString <$> do
227 R.many1 $ R.satisfy (\c -> c /= tag_value_sep && not (Data.Char.isSpace c))
228
229 tag_value :: Stream s m Char => ParsecT s u m Tag_Value
230 tag_value = do
231 fromString <$> do
232 R.manyTill R.anyChar $ do
233 R.lookAhead $ do
234 R.try (R.char tag_sep >> R.many R.space_horizontal >> tag_name >> R.char tag_value_sep >> return ())
235 <|> R.try R.new_line
236 <|> R.eof
237
238 tags :: Stream s m Char => ParsecT s u m Tag_by_Name
239 tags = do
240 Ledger.tag_by_Name <$> do
241 R.many_separated tag $ do
242 _ <- R.char tag_sep
243 R.skipMany $ R.space_horizontal
244 return ()
245
246 not_tag :: Stream s m Char => ParsecT s u m ()
247 not_tag = do
248 R.skipMany $ R.try $ do
249 R.skipMany $ R.satisfy
250 (\c -> c /= tag_value_sep
251 && not (Data.Char.isSpace c))
252 R.space_horizontal
253
254 -- * Read 'Posting'
255
256 posting
257 :: (Stream s (R.Error_State Error m) Char, Monad m)
258 => ParsecT s Context (R.Error_State Error m) (Posting, Posting_Type)
259 posting = (do
260 ctx <- R.getState
261 sourcepos <- R.getPosition
262 R.skipMany1 $ R.space_horizontal
263 status_ <- status
264 R.skipMany $ R.space_horizontal
265 acct <- account
266 let (type_, account_) = posting_type acct
267 amounts_ <-
268 R.choice_try
269 [ do
270 _ <- R.count 2 R.space_horizontal
271 R.skipMany $ R.space_horizontal
272 maybe id (\(u, s) ->
273 if u == Unit.nil then id
274 else
275 Data.Map.adjust (\a ->
276 a{ Amount.style = s{Style.precision = Style.precision $ Amount.style a}
277 , Amount.unit = u })
278 Unit.nil)
279 (context_unit_and_style ctx) .
280 Amount.from_List <$> do
281 R.many_separated Amount.Read.amount $ do
282 R.skipMany $ R.space_horizontal
283 _ <- R.char amount_sep
284 R.skipMany $ R.space_horizontal
285 return ()
286 , return Data.Map.empty
287 ] <?> "amounts"
288 R.skipMany $ R.space_horizontal
289 -- TODO: balance assertion
290 -- TODO: conversion
291 comments_ <- comments
292 let tags_ = tags_of_comments comments_
293 dates_ <-
294 case Data.Map.lookup "date" tags_ of
295 Nothing -> return []
296 Just dates -> do
297 let date2s = Data.Map.lookup "date2" tags_ -- NOTE: support hledger's date2
298 do
299 (flip mapM) (dates ++ fromMaybe [] date2s) $ \s ->
300 R.runParserT_with_Error_fail "tag date" id
301 (Date.Read.date Error_date (Just $ context_year ctx) <* R.eof) ()
302 (Text.unpack s) s
303 >>= \dates_ -> case (dates, date2s) of -- NOTE: put hledger's date2 at least in second position
304 ([], Just (_:_)) ->
305 return $ context_date ctx:dates_
306 _ -> return $ dates_
307 return (Posting
308 { posting_account=account_
309 , posting_amounts=amounts_
310 , posting_comments=comments_
311 , posting_dates=dates_
312 , posting_sourcepos=sourcepos
313 , posting_status=status_
314 , posting_tags=tags_
315 }, type_)
316 ) <?> "posting"
317
318 amount_sep :: Char
319 amount_sep = '+'
320
321 tags_of_comments :: [Comment] -> Tag_by_Name
322 tags_of_comments =
323 Data.Map.unionsWith (++)
324 . Data.List.map
325 ( Data.Either.either (const Data.Map.empty) id
326 . R.runParser (not_tag >> tags <* R.eof) () "" )
327
328 status :: Stream s m Char => ParsecT s u m Ledger.Status
329 status = (do
330 ( R.try $ do
331 R.skipMany $ R.space_horizontal
332 _ <- (R.char '*' <|> R.char '!')
333 return True )
334 <|> return False
335 ) <?> "status"
336
337 -- | Return the 'Posting_Type' and stripped 'Account' of the given 'Account'.
338 posting_type :: Account -> (Posting_Type, Account)
339 posting_type acct =
340 fromMaybe (Posting_Type_Regular, acct) $ do
341 case acct of
342 name:|[] ->
343 case Text.stripPrefix virtual_begin name of
344 Just name' -> do
345 name'' <-
346 Text.stripSuffix virtual_end name'
347 >>= return . Text.strip
348 guard $ not $ Text.null name''
349 Just (Posting_Type_Virtual, name'':|[])
350 Nothing -> do
351 name' <-
352 Text.stripPrefix virtual_balanced_begin name
353 >>= Text.stripSuffix virtual_balanced_end
354 >>= return . Text.strip
355 guard $ not $ Text.null name'
356 Just (Posting_Type_Virtual_Balanced, name':|[])
357 first_name:|acct' -> do
358 let rev_acct' = Data.List.reverse acct'
359 let last_name = Data.List.head rev_acct'
360 case Text.stripPrefix virtual_begin first_name
361 >>= return . Text.stripStart of
362 Just first_name' -> do
363 last_name' <-
364 Text.stripSuffix virtual_end last_name
365 >>= return . Text.stripEnd
366 guard $ not $ Text.null first_name'
367 guard $ not $ Text.null last_name'
368 Just $
369 ( Posting_Type_Virtual
370 , first_name':|
371 Data.List.reverse (last_name':Data.List.tail rev_acct')
372 )
373 Nothing -> do
374 first_name' <-
375 Text.stripPrefix virtual_balanced_begin first_name
376 >>= return . Text.stripStart
377 last_name' <-
378 Text.stripSuffix virtual_balanced_end last_name
379 >>= return . Text.stripEnd
380 guard $ not $ Text.null first_name'
381 guard $ not $ Text.null last_name'
382 Just $
383 ( Posting_Type_Virtual_Balanced
384 , first_name':|
385 Data.List.reverse (last_name':Data.List.tail rev_acct')
386 )
387 where
388 virtual_begin = Text.singleton posting_type_virtual_begin
389 virtual_end = Text.singleton posting_type_virtual_end
390 virtual_balanced_begin = Text.singleton posting_type_virtual_balanced_begin
391 virtual_balanced_end = Text.singleton posting_type_virtual_balanced_end
392
393 posting_type_virtual_begin :: Char
394 posting_type_virtual_begin = '('
395 posting_type_virtual_balanced_begin :: Char
396 posting_type_virtual_balanced_begin = '['
397 posting_type_virtual_end :: Char
398 posting_type_virtual_end = ')'
399 posting_type_virtual_balanced_end :: Char
400 posting_type_virtual_balanced_end = ']'
401
402 -- * Read 'Transaction'
403
404 transaction
405 :: (Stream s (R.Error_State Error m) Char, Monad m)
406 => ParsecT s Context (R.Error_State Error m) Transaction
407 transaction = (do
408 ctx <- R.getState
409 transaction_sourcepos <- R.getPosition
410 transaction_comments_before <-
411 comments
412 >>= \x -> case x of
413 [] -> return []
414 _ -> return x <* R.new_line
415 date_ <- Date.Read.date Error_date (Just $ context_year ctx)
416 dates_ <-
417 R.option [] $ R.try $ do
418 R.skipMany $ R.space_horizontal
419 _ <- R.char date_sep
420 R.skipMany $ R.space_horizontal
421 R.many_separated
422 (Date.Read.date Error_date (Just $ context_year ctx)) $
423 R.try $ do
424 R.many $ R.space_horizontal
425 >> R.char date_sep
426 >> (R.many $ R.space_horizontal)
427 let transaction_dates = (date_, dates_)
428 R.skipMany $ R.space_horizontal
429 transaction_status <- status
430 transaction_code <- R.option "" $ R.try code
431 R.skipMany $ R.space_horizontal
432 transaction_description <- description
433 R.skipMany $ R.space_horizontal
434 transaction_comments_after <- comments
435 let transaction_tags =
436 Data.Map.unionWith (++)
437 (tags_of_comments transaction_comments_before)
438 (tags_of_comments transaction_comments_after)
439 R.new_line
440 (postings_unchecked, postings_not_regular) <-
441 ((Ledger.posting_by_Account . Data.List.map fst) *** id) .
442 Data.List.partition ((Posting_Type_Regular ==) . snd) <$>
443 R.many1_separated posting R.new_line
444 let (transaction_virtual_postings, balanced_virtual_postings_unchecked) =
445 join (***) (Ledger.posting_by_Account . Data.List.map fst) $
446 Data.List.partition ((Posting_Type_Virtual ==) . snd)
447 postings_not_regular
448 let tr_unchecked =
449 Transaction
450 { transaction_code
451 , transaction_comments_before
452 , transaction_comments_after
453 , transaction_dates
454 , transaction_description
455 , transaction_postings=postings_unchecked
456 , transaction_virtual_postings
457 , transaction_balanced_virtual_postings=balanced_virtual_postings_unchecked
458 , transaction_sourcepos
459 , transaction_status
460 , transaction_tags
461 }
462 transaction_postings <-
463 case Balance.infer_equilibrium postings_unchecked of
464 (_, Left ko) -> R.fail_with "transaction infer_equilibrium"
465 (Error_transaction_not_equilibrated tr_unchecked ko)
466 (_bal, Right ok) -> return ok
467 transaction_balanced_virtual_postings <-
468 case Balance.infer_equilibrium balanced_virtual_postings_unchecked of
469 (_, Left ko) -> R.fail_with "transaction infer_equilibrium"
470 (Error_virtual_transaction_not_equilibrated tr_unchecked ko)
471 (_bal, Right ok) -> return ok
472 return $
473 tr_unchecked
474 { transaction_postings
475 , transaction_balanced_virtual_postings
476 }
477 ) <?> "transaction"
478
479 date_sep :: Char
480 date_sep = '='
481
482 code :: Stream s m Char => ParsecT s Context m Ledger.Code
483 code = (do
484 fromString <$> do
485 R.skipMany $ R.space_horizontal
486 R.between (R.char '(') (R.char ')') $
487 R.many $ R.satisfy (\c -> c /= ')' && not (R.is_space_horizontal c))
488 ) <?> "code"
489
490 description :: Stream s m Char => ParsecT s u m Ledger.Description
491 description = (do
492 fromString <$> do
493 R.many $ R.try description_char
494 ) <?> "description"
495 where
496 description_char :: Stream s m Char => ParsecT s u m Char
497 description_char = do
498 c <- R.anyChar
499 case c of
500 _ | c == comment_begin -> R.parserZero
501 _ | R.is_space_horizontal c -> return c <* (R.lookAhead $ R.try $ description_char)
502 _ | not (Data.Char.isSpace c) -> return c
503 _ -> R.parserZero
504
505 -- * Read directives
506
507 default_year :: Stream s m Char => ParsecT s Context m ()
508 default_year = (do
509 year <- R.integer_of_digits 10 <$> R.many1 R.digit
510 R.skipMany R.space_horizontal >> R.new_line
511 context_ <- R.getState
512 R.setState context_{context_year=year}
513 ) <?> "default year"
514
515 default_unit_and_style :: Stream s m Char => ParsecT s Context m ()
516 default_unit_and_style = (do
517 amount_ <- Amount.Read.amount
518 R.skipMany R.space_horizontal >> R.new_line
519 context_ <- R.getState
520 R.setState context_{context_unit_and_style =
521 Just $
522 ( Amount.unit amount_
523 , Amount.style amount_ )}
524 ) <?> "default unit and style"
525
526 include
527 :: Stream s (R.Error_State Error IO) Char
528 => ParsecT s Context (R.Error_State Error IO) ()
529 include = (do
530 sourcepos <- R.getPosition
531 filename <- R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
532 context_ <- R.getState
533 let journal_ = context_journal context_
534 let cwd = Path.takeDirectory (R.sourceName sourcepos)
535 file_path <- liftIO $ Path.abs cwd filename
536 content <- do
537 join $ liftIO $ Exception.catch
538 (liftM return $ readFile file_path)
539 (return . R.fail_with "include reading" . Error_reading_file file_path)
540 (journal_included, context_included) <- do
541 liftIO $
542 R.runParserT_with_Error (R.and_state $ journal_rec file_path)
543 context_{context_journal = Ledger.journal}
544 file_path content
545 >>= \x -> case x of
546 Right ok -> return ok
547 Left ko -> R.fail_with "include parsing" (Error_including_file file_path ko)
548 R.setState $
549 context_included{context_journal=
550 journal_{journal_includes=
551 journal_included{journal_file=file_path}
552 : journal_includes journal_}}
553 ) <?> "include"
554
555 -- * Read 'Journal'
556
557 journal
558 :: Stream s (R.Error_State Error IO) Char
559 => FilePath
560 -> ParsecT s Context (R.Error_State Error IO) Journal
561 journal file_ = (do
562 currentLocalTime <- liftIO $
563 Time.utcToLocalTime
564 <$> Time.getCurrentTimeZone
565 <*> Time.getCurrentTime
566 let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
567 context_ <- R.getState
568 R.setState $ context_{context_year=currentLocalYear}
569 journal_rec file_
570 ) <?> "journal"
571
572 journal_rec
573 :: Stream s (R.Error_State Error IO) Char
574 => FilePath
575 -> ParsecT s Context (R.Error_State Error IO) Journal
576 journal_rec file_ = do
577 last_read_time <- lift $ liftIO Time.getCurrentTime
578 R.skipMany $ do
579 R.choice_try
580 [ R.skipMany1 R.space
581 , (do (R.choice_try
582 [ R.string "Y" >> return default_year
583 , R.string "D" >> return default_unit_and_style
584 , R.string "!include" >> return include
585 ] <?> "directive")
586 >>= \r -> R.skipMany1 R.space_horizontal >> r)
587 , ((do
588 t <- transaction
589 context_' <- R.getState
590 let j = context_journal context_'
591 R.setState $ context_'{context_journal=
592 j{journal_transactions=
593 Data.Map.insertWith (flip (++))
594 -- NOTE: flip-ing preserves order but slows down
595 -- when many transactions have the very same date.
596 (fst $ transaction_dates t) [t]
597 (journal_transactions j)}}
598 R.new_line <|> R.eof))
599 , R.try (comment >> return ())
600 ]
601 R.eof
602 journal_ <- context_journal <$> R.getState
603 return $
604 journal_
605 { journal_file = file_
606 , journal_last_read_time=last_read_time
607 , journal_includes = reverse $ journal_includes journal_
608 }
609
610 -- ** Read 'Journal' from a file
611
612 file :: FilePath -> ExceptT [R.Error Error] IO Journal
613 file path = do
614 ExceptT $
615 Exception.catch
616 (liftM Right $ Text.IO.readFile path) $
617 \ko -> return $ Left $
618 [ R.Error_Custom (R.initialPos path) $ Error_reading_file path ko ]
619 >>= liftIO . R.runParserT_with_Error (journal path) nil_Context path
620 >>= \x -> case x of
621 Left ko -> throwE $ ko
622 Right ok -> ExceptT $ return $ Right ok