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 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           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                          _ | 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 >> R.char tag_value_sep >> return ())
 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                         _ <- 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                         (flip mapM) (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'' <-
 350                                             Text.stripSuffix virtual_end name'
 351                                         >>= return . Text.strip
 352                                 guard $ not $ Text.null name''
 353                                 Just (Posting_Type_Virtual, name'':|[])
 354                          Nothing -> do
 355                                 name' <-
 356                                             Text.stripPrefix virtual_balanced_begin name
 357                                         >>= Text.stripSuffix virtual_balanced_end
 358                                         >>= return . Text.strip
 359                                 guard $ not $ Text.null name'
 360                                 Just (Posting_Type_Virtual_Balanced, name':|[])
 361                  first_name:|acct' -> do
 362                                 let rev_acct' = Data.List.reverse acct'
 363                                 let last_name = Data.List.head rev_acct'
 364                                 case Text.stripPrefix virtual_begin first_name
 365                                         >>= return . Text.stripStart of
 366                                  Just first_name' -> do
 367                                         last_name' <-
 368                                                 Text.stripSuffix virtual_end last_name
 369                                                 >>= return . Text.stripEnd
 370                                         guard $ not $ Text.null first_name'
 371                                         guard $ not $ Text.null last_name'
 372                                         Just $
 373                                                 ( Posting_Type_Virtual
 374                                                 , first_name':|
 375                                                         Data.List.reverse (last_name':Data.List.tail rev_acct')
 376                                                 )
 377                                  Nothing -> do
 378                                         first_name' <-
 379                                                 Text.stripPrefix virtual_balanced_begin first_name
 380                                                 >>= return . Text.stripStart
 381                                         last_name'  <-
 382                                                 Text.stripSuffix virtual_balanced_end last_name
 383                                                 >>= return . Text.stripEnd
 384                                         guard $ not $ Text.null first_name'
 385                                         guard $ not $ Text.null last_name'
 386                                         Just $
 387                                                 ( Posting_Type_Virtual_Balanced
 388                                                 , first_name':|
 389                                                         Data.List.reverse (last_name':Data.List.tail rev_acct')
 390                                                 )
 391         where
 392                 virtual_begin          = Text.singleton posting_type_virtual_begin
 393                 virtual_end            = Text.singleton posting_type_virtual_end
 394                 virtual_balanced_begin = Text.singleton posting_type_virtual_balanced_begin
 395                 virtual_balanced_end   = Text.singleton posting_type_virtual_balanced_end
 396
 397 posting_type_virtual_begin :: Char
 398 posting_type_virtual_begin = '('
 399 posting_type_virtual_balanced_begin :: Char
 400 posting_type_virtual_balanced_begin = '['
 401 posting_type_virtual_end :: Char
 402 posting_type_virtual_end = ')'
 403 posting_type_virtual_balanced_end :: Char
 404 posting_type_virtual_balanced_end = ']'
 405
 406 -- * Read 'Transaction'
 407
 408 transaction
 409  :: (Consable f ts t, Stream s (R.Error_State Error m) Char, Monad m)
 410  => ParsecT s (Context f ts t) (R.Error_State Error m) Transaction
 411 transaction = (do
 412         ctx <- R.getState
 413         transaction_sourcepos <- R.getPosition
 414         transaction_comments_before <-
 415                 comments
 416                 >>= \x -> case x of
 417                  [] -> return []
 418                  _  -> return x <* R.new_line
 419         date_ <- Date.Read.date Error_date (Just $ context_year ctx)
 420         dates_ <-
 421                 R.option [] $ R.try $ do
 422                         R.skipMany $ R.space_horizontal
 423                         _ <- R.char date_sep
 424                         R.skipMany $ R.space_horizontal
 425                         R.many_separated
 426                          (Date.Read.date Error_date (Just $ context_year ctx)) $
 427                                 R.try $ do
 428                                         R.many $ R.space_horizontal
 429                                         >> R.char date_sep
 430                                         >> (R.many $ R.space_horizontal)
 431         let transaction_dates = (date_, dates_)
 432         R.skipMany $ R.space_horizontal
 433         transaction_status <- status
 434         transaction_code <- R.option "" $ R.try code
 435         R.skipMany $ R.space_horizontal
 436         transaction_description <- description
 437         R.skipMany $ R.space_horizontal
 438         transaction_comments_after <- comments
 439         let transaction_tags =
 440                 Data.Map.unionWith (++)
 441                  (tags_of_comments transaction_comments_before)
 442                  (tags_of_comments transaction_comments_after)
 443         R.new_line
 444         (postings_unchecked, postings_not_regular) <-
 445                 ((Ledger.posting_by_Account . Data.List.map fst) *** id) .
 446                 Data.List.partition ((Posting_Type_Regular ==) . snd) <$>
 447                 R.many1_separated posting R.new_line
 448         let (transaction_virtual_postings, balanced_virtual_postings_unchecked) =
 449                 join (***) (Ledger.posting_by_Account . Data.List.map fst) $
 450                 Data.List.partition ((Posting_Type_Virtual ==) . snd)
 451                  postings_not_regular
 452         let tr_unchecked =
 453                 Transaction
 454                  { transaction_code
 455                  , transaction_comments_before
 456                  , transaction_comments_after
 457                  , transaction_dates
 458                  , transaction_description
 459                  , transaction_postings=postings_unchecked
 460                  , transaction_virtual_postings
 461                  , transaction_balanced_virtual_postings=balanced_virtual_postings_unchecked
 462                  , transaction_sourcepos
 463                  , transaction_status
 464                  , transaction_tags
 465                  }
 466         transaction_postings <-
 467                 case Balance.infer_equilibrium postings_unchecked of
 468                  (_, Left ko) -> R.fail_with "transaction infer_equilibrium"
 469                                              (Error_transaction_not_equilibrated tr_unchecked ko)
 470                  (_bal, Right ok) -> return ok
 471         transaction_balanced_virtual_postings <-
 472                 case Balance.infer_equilibrium balanced_virtual_postings_unchecked of
 473                  (_, Left ko) -> R.fail_with "transaction infer_equilibrium"
 474                                              (Error_virtual_transaction_not_equilibrated tr_unchecked ko)
 475                  (_bal, Right ok) -> return ok
 476         return $
 477                 tr_unchecked
 478                  { transaction_postings
 479                  , transaction_balanced_virtual_postings
 480                  }
 481         ) <?> "transaction"
 482
 483 date_sep :: Char
 484 date_sep = '='
 485
 486 code :: (Consable f ts t, Stream s m Char)
 487  => ParsecT s (Context f ts t) m Ledger.Code
 488 code = (do
 489         fromString <$> do
 490         R.skipMany $ R.space_horizontal
 491         R.between (R.char '(') (R.char ')') $
 492                 R.many $ R.satisfy (\c -> c /= ')' && not (R.is_space_horizontal c))
 493         ) <?> "code"
 494
 495 description :: Stream s m Char => ParsecT s u m Ledger.Description
 496 description = (do
 497         fromString <$> do
 498         R.many $ R.try description_char
 499         ) <?> "description"
 500         where
 501                 description_char :: Stream s m Char => ParsecT s u m Char
 502                 description_char = do
 503                         c <- R.anyChar
 504                         case c of
 505                          _ | c == comment_begin -> R.parserZero
 506                          _ | R.is_space_horizontal c -> return c <* (R.lookAhead $ R.try $ description_char)
 507                          _ | not (Data.Char.isSpace c) -> return c
 508                          _ -> R.parserZero
 509
 510 -- * Read directives
 511
 512 default_year
 513  :: (Consable f ts t, Stream s m Char)
 514  => ParsecT s (Context f ts t) m ()
 515 default_year = (do
 516         year <- R.integer_of_digits 10 <$> R.many1 R.digit
 517         R.skipMany R.space_horizontal >> R.new_line
 518         context_ <- R.getState
 519         R.setState context_{context_year=year}
 520         ) <?> "default year"
 521
 522 default_unit_and_style
 523  :: (Consable f ts t, Stream s m Char)
 524  => ParsecT s (Context f ts t) m ()
 525 default_unit_and_style = (do
 526         amount_ <- Amount.Read.amount
 527         R.skipMany R.space_horizontal >> R.new_line
 528         context_ <- R.getState
 529         R.setState context_{context_unit_and_style =
 530                 Just $
 531                  ( Amount.unit  amount_
 532                  , Amount.style amount_ )}
 533         ) <?> "default unit and style"
 534
 535 include ::
 536  ( Consable f ts Transaction
 537  , Show f
 538  , Show (ts Transaction)
 539  , Stream s (R.Error_State Error IO) Char
 540  )
 541  => ParsecT s (Context f ts Transaction) (R.Error_State Error IO) ()
 542 include = (do
 543         sourcepos <- R.getPosition
 544         filename <- R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
 545         context_ <- R.getState
 546         let journal_ = context_journal context_
 547         let cwd = Path.takeDirectory (R.sourceName sourcepos)
 548         file_path <- liftIO $ Path.abs cwd filename
 549         content <- do
 550                 join $ liftIO $ Exception.catch
 551                  (liftM return $ readFile file_path)
 552                  (return . R.fail_with "include reading" . Error_reading_file file_path)
 553         (journal_included, context_included) <- do
 554                 liftIO $
 555                         R.runParserT_with_Error (R.and_state $ journal_rec file_path)
 556                          context_{context_journal = Ledger.journal}
 557                          file_path content
 558                 >>= \x -> case x of
 559                  Right ok -> return ok
 560                  Left  ko -> R.fail_with "include parsing" (Error_including_file file_path ko)
 561         R.setState $
 562                 context_included{context_journal=
 563                         journal_{journal_includes=
 564                                 journal_included{journal_file=file_path}
 565                                 : journal_includes journal_}}
 566         ) <?> "include"
 567
 568 -- * Read 'Journal'
 569
 570 journal ::
 571  ( Consable f ts Transaction
 572  , Show f
 573  , Show (ts Transaction)
 574  , Stream s (R.Error_State Error IO) Char
 575  )
 576  => FilePath
 577  -> ParsecT s (Context f ts Transaction) (R.Error_State Error IO) (Journal (ts Transaction))
 578 journal file_ = (do
 579         currentLocalTime <- liftIO $
 580                 Time.utcToLocalTime
 581                 <$> Time.getCurrentTimeZone
 582                 <*> Time.getCurrentTime
 583         let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
 584         ctx <- R.getState
 585         R.setState $ ctx{context_year=currentLocalYear}
 586         journal_rec file_
 587         ) <?> "journal"
 588
 589 journal_rec ::
 590  ( Consable f ts Transaction
 591  , Show f
 592  , Show (ts Transaction)
 593  , Stream s (R.Error_State Error IO) Char
 594  )
 595  => FilePath
 596  -> ParsecT s (Context f ts Transaction) (R.Error_State Error IO) (Journal (ts Transaction))
 597 journal_rec file_ = do
 598         last_read_time <- liftIO Date.now
 599         R.skipMany $ do
 600                 R.choice_try
 601                  [ R.skipMany1 R.space
 602                  , (do (R.choice_try
 603                          [ R.string "Y"        >> return default_year
 604                          , R.string "D"        >> return default_unit_and_style
 605                          , R.string "!include" >> return include
 606                          ] <?> "directive")
 607                                 >>= \r -> R.skipMany1 R.space_horizontal >> r)
 608                  , ((do
 609                                 t <- transaction
 610                                 ctx <- R.getState
 611                                 let j = context_journal ctx
 612                                 R.setState $
 613                                         ctx{context_journal=
 614                                                 j{journal_transactions=
 615                                                         mcons (context_filter ctx) t $
 616                                                                 journal_transactions j}}
 617                                 R.new_line <|> R.eof))
 618                  , R.try (comment >> return ())
 619                  ]
 620         R.eof
 621         journal_ <- context_journal <$> R.getState
 622         return $
 623                 journal_
 624                  { journal_file = file_
 625                  , journal_last_read_time = last_read_time
 626                  , journal_includes = reverse $ journal_includes journal_
 627                  }
 628
 629 -- ** Read 'Journal' from a file
 630
 631 file
 632  ::
 633  ( Consable f ts Transaction
 634  , Show f
 635  , Show (ts Transaction)
 636  )
 637  => Context f ts Transaction
 638  -> FilePath
 639  -> ExceptT [R.Error Error] IO (Journal (ts Transaction))
 640 file ctx path = do
 641         ExceptT $
 642                 Exception.catch
 643                  (liftM Right $ Text.IO.readFile path) $
 644                  \ko -> return $ Left $
 645                          [ R.Error_Custom (R.initialPos path) $ Error_reading_file path ko ]
 646         >>= liftIO . R.runParserT_with_Error (journal path) ctx path
 647         >>= \x -> case x of
 648          Left  ko -> throwE $ ko
 649          Right ok -> ExceptT $ return $ Right ok