lib/Hcompta/Format/Ledger/Read.hs

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