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