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