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