lib/Hcompta/Format/Ledger/Read.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE NamedFieldPuns #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE ScopedTypeVariables #-}
   6 {-# LANGUAGE StandaloneDeriving #-}
   7 {-# LANGUAGE TupleSections #-}
   8 {-# LANGUAGE TypeFamilies #-}
   9 module Hcompta.Format.Ledger.Read where
  10
  11 import           Control.Applicative ((<$>), (<*>), (<*))
  12 import           Control.Arrow ((***), first)
  13 import qualified Control.Exception as Exception
  14 import           Control.Monad (Monad(..), guard, liftM, join, forM, void)
  15 import           Control.Monad.IO.Class (liftIO)
  16 import           Control.Monad.Trans.Except (ExceptT(..), throwE)
  17 import           Data.Bool
  18 import           Data.Char (Char, isSpace)
  19 import           Data.Either (Either(..), either)
  20 import           Data.Eq (Eq(..))
  21 import           Data.List
  22 import           Data.List.NonEmpty (NonEmpty(..))
  23 import qualified Data.List.NonEmpty as NonEmpty
  24 import           Data.Map.Strict (Map)
  25 import qualified Data.Map.Strict as Data.Map
  26 import           Data.Maybe (Maybe(..), fromMaybe, maybe)
  27 import           Data.Monoid (Monoid(..))
  28 import           Data.String (fromString)
  29 import qualified Data.Text as Text
  30 import qualified Data.Text.IO as Text.IO (readFile)
  31 import qualified Data.Time.Calendar  as Time
  32 import qualified Data.Time.Clock     as Time
  33 import qualified Data.Time.LocalTime as Time
  34 import           Data.Tuple (fst, snd)
  35 import           Data.Typeable ()
  36 import           Prelude (($), (.), IO, FilePath, const, flip, id)
  37 import qualified System.FilePath.Posix as Path
  38 import qualified Text.Parsec as R hiding
  39                   ( char
  40                   , anyChar
  41                   , crlf
  42                   , newline
  43                   , noneOf
  44                   , oneOf
  45                   , satisfy
  46                   , space
  47                   , spaces
  48                   , string
  49                   , tab
  50                   )
  51 import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))
  52 import qualified Text.Parsec.Pos as R
  53 import           Text.Show (Show)
  54
  55 import           Hcompta.Account (Account)
  56 import qualified Hcompta.Account as Account
  57 import qualified Hcompta.Account.Read as Account.Read
  58 import qualified Hcompta.Amount as Amount
  59 import qualified Hcompta.Amount.Read as Amount.Read
  60 import qualified Hcompta.Amount.Style as Style
  61 import qualified Hcompta.Amount.Unit as Unit
  62 import qualified Hcompta.Balance as Balance
  63 import           Hcompta.Chart (Chart)
  64 import qualified Hcompta.Chart as Chart
  65 import           Hcompta.Date (Date)
  66 import qualified Hcompta.Date as Date
  67 import qualified Hcompta.Date.Read as Date.Read
  68 import           Hcompta.Format.Ledger
  69                   ( Comment
  70                   , Journal(..)
  71                   , Posting(..)
  72                   , Transaction(..)
  73                   )
  74 import qualified Hcompta.Format.Ledger as Ledger
  75 import           Hcompta.Lib.Consable (Consable(..))
  76 import qualified Hcompta.Lib.Parsec as R
  77 import qualified Hcompta.Lib.Path as Path
  78 import           Hcompta.Lib.Regex (Regex)
  79 import qualified Hcompta.Lib.TreeMap as TreeMap
  80 import           Hcompta.Posting as Posting
  81 import           Hcompta.Tag (Tag)
  82 import qualified Hcompta.Tag as Tag
  83
  84 type CT t = (Chart, t)
  85
  86 data Context f ts t
  87  =   Context
  88  { context_account_prefix :: !(Maybe Account)
  89  , context_aliases_exact :: !(Data.Map.Map Account Account)
  90  , context_aliases_joker :: ![(Account.Joker, Account)]
  91  , context_aliases_regex :: ![(Regex, Account)]
  92  , context_date :: !Date
  93  , context_filter :: !f
  94  , context_journal :: !(Journal (ts (CT t)))
  95  , context_unit_and_style :: !(Maybe (Amount.Unit, Amount.Style))
  96  , context_year :: !Date.Year
  97  }
  98
  99 context
 100  :: (Show f, Consable f ts (Chart, t))
 101  => f -> Journal (ts (Chart, t)) -> Context f ts t
 102 context flt context_journal =
 103         Context
 104          { context_account_prefix = Nothing
 105          , context_aliases_exact = Data.Map.empty
 106          , context_aliases_joker = []
 107          , context_aliases_regex = []
 108          , context_date = Date.nil
 109          , context_filter = flt
 110          , context_journal
 111          , context_unit_and_style = Nothing
 112          , context_year = Date.year Date.nil
 113          }
 114
 115 data Error
 116  =   Error_date Date.Read.Error
 117  |   Error_transaction_not_equilibrated Transaction [Balance.Unit_Sum (Balance.Posting_Amount Ledger.Posting)]
 118  |   Error_virtual_transaction_not_equilibrated Transaction [Balance.Unit_Sum (Balance.Posting_Amount Ledger.Posting)]
 119  |   Error_reading_file FilePath Exception.IOException
 120  |   Error_including_file FilePath [R.Error Error]
 121  deriving (Show)
 122
 123 -- * Directives
 124
 125 directive_alias
 126  :: (Consable f ts (Chart, t), Stream s m Char)
 127  => ParsecT s (Context f ts t) m ()
 128 directive_alias = do
 129         _ <- R.string "alias"
 130         R.skipMany1 $ R.space_horizontal
 131         pattern <- Account.Read.pattern
 132         R.skipMany $ R.space_horizontal
 133         _ <- R.char '='
 134         R.skipMany $ R.space_horizontal
 135         repl <- Account.Read.account
 136         R.skipMany $ R.space_horizontal
 137         case pattern of
 138          Account.Pattern_Exact acct -> R.modifyState $ \ctx -> ctx{context_aliases_exact=
 139                 Data.Map.insert acct repl $ context_aliases_exact ctx}
 140          Account.Pattern_Joker jokr -> R.modifyState $ \ctx -> ctx{context_aliases_joker=
 141                 (jokr, repl):context_aliases_joker ctx}
 142          Account.Pattern_Regex regx -> R.modifyState $ \ctx -> ctx{context_aliases_regex=
 143                 (regx, repl):context_aliases_regex ctx}
 144         return ()
 145
 146 -- * Read 'Comment'
 147
 148 comment_begin :: Char
 149 comment_begin = ';'
 150
 151 comment :: Stream s m Char => ParsecT s u m Comment
 152 comment = (do
 153         _ <- R.char comment_begin
 154         fromString <$> do
 155         R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
 156         ) <?> "comment"
 157
 158 comments :: Stream s m Char => ParsecT s u m [Comment]
 159 comments = (do
 160         R.try $ do
 161                 _ <- R.spaces
 162                 R.many1_separated comment (R.new_line >> R.skipMany R.space_horizontal)
 163         <|> return []
 164         ) <?> "comments"
 165
 166 -- * Read 'Tag'
 167
 168 tag_value_sep :: Char
 169 tag_value_sep = ':'
 170
 171 tag_sep :: Char
 172 tag_sep = ','
 173
 174 tag_path_section_char :: Stream s m Char => ParsecT s u m Char
 175 tag_path_section_char =
 176         R.satisfy (\c -> c /= tag_value_sep && c /= tag_sep && not (Data.Char.isSpace c))
 177
 178 tag :: Stream s m Char => ParsecT s u m Tag
 179 tag = ((,) <$> tag_path <*> tag_value) <?> "tag"
 180
 181 tag_path :: Stream s m Char => ParsecT s u m Tag.Path
 182 tag_path = do
 183         NonEmpty.fromList <$> do
 184         R.many1 $ R.try tag_path_section
 185
 186 tag_path_section :: Stream s m Char => ParsecT s u m Tag.Section
 187 tag_path_section = do
 188         fromString <$> do
 189                 ((R.many1 $ tag_path_section_char) <* R.char tag_value_sep)
 190
 191 tag_value :: Stream s m Char => ParsecT s u m Tag.Value
 192 tag_value = do
 193         fromString <$> do
 194         R.manyTill R.anyChar $ do
 195                 R.lookAhead $ do
 196                         R.try (R.char tag_sep >> R.many R.space_horizontal >> void tag_path_section)
 197                         <|> R.try (void (R.try R.new_line))
 198                         <|> R.eof
 199
 200 tags :: Stream s m Char => ParsecT s u m (Map Tag.Path [Tag.Value])
 201 tags = do
 202         Data.Map.fromListWith (flip (++))
 203         . map (\(p, v) -> (p, [v])) <$> do
 204                 R.many_separated tag $ do
 205                         _ <- R.char tag_sep
 206                         R.skipMany $ R.space_horizontal
 207
 208 not_tag :: Stream s m Char => ParsecT s u m ()
 209 not_tag = do
 210         R.skipMany $ R.try $ do
 211                 R.skipMany $ tag_path_section_char
 212                 R.space_horizontal
 213
 214 -- * Read 'Posting'
 215
 216 posting ::
 217  ( Consable f ts (Chart, t)
 218  , Stream s (R.Error_State Error m) Char
 219  , Monad m
 220  ) => ParsecT s (Context f ts t) (R.Error_State Error m) (Posting.Posting_Type, Posting)
 221 posting = (do
 222         ctx <- R.getState
 223         posting_sourcepos <- R.getPosition
 224         R.skipMany1 $ R.space_horizontal
 225         posting_status <- status
 226         R.skipMany $ R.space_horizontal
 227         acct <- Account.Read.account
 228         let (type_, posting_account) = posting_type acct
 229         posting_amounts <-
 230                 R.choice_try
 231                  [ do
 232                         (void R.tab <|> void (R.count 2 R.space_horizontal))
 233                         R.skipMany $ R.space_horizontal
 234                         Amount.from_List .
 235                                 maybe id (\(u, s) ->
 236                                         if u == Unit.nil
 237                                         then map $ \a ->
 238                                                 a{ Amount.style = s{Style.precision = Style.precision $ Amount.style a} }
 239                                         else map $ \a ->
 240                                                 if Amount.unit a == Unit.nil
 241                                                 then a{ Amount.style = s{Style.precision = Style.precision $ Amount.style a}
 242                                                       , Amount.unit  = u }
 243                                                 else a{ Amount.style = s{Style.precision = Style.precision $ Amount.style a} }
 244                                  ) (context_unit_and_style ctx) <$> do
 245                                 R.many_separated Amount.Read.amount $ do
 246                                         R.skipMany $ R.space_horizontal
 247                                         _ <- R.char amount_sep
 248                                         R.skipMany $ R.space_horizontal
 249                                         return ()
 250                  , return Data.Map.empty
 251                  ] <?> "amounts"
 252         R.skipMany $ R.space_horizontal
 253         -- TODO: balance assertion
 254         -- TODO: conversion
 255         posting_comments <- comments
 256         let posting_tags@(Tag.Tags tags_) = tags_of_comments posting_comments
 257         posting_dates <-
 258                 case Data.Map.lookup ("date":|[]) tags_ of
 259                  Nothing -> return []
 260                  Just dates -> do
 261                         let date2s = Data.Map.lookup ("date2":|[]) tags_ -- NOTE: support hledger's date2
 262                         do
 263                         forM (dates ++ fromMaybe [] date2s) $ \s ->
 264                                 R.runParserT_with_Error_fail "tag date" id
 265                                  (Date.Read.date Error_date (Just $ context_year ctx) <* R.eof) ()
 266                                  (Text.unpack s) s
 267                         >>= \dates_ -> case (dates, date2s) of -- NOTE: put hledger's date2 at least in second position
 268                          ([], Just (_:_)) ->
 269                                 return $ context_date ctx:dates_
 270                          _ -> return $ dates_
 271         return (type_, Posting
 272          { posting_account
 273          , posting_amounts
 274          , posting_comments
 275          , posting_dates
 276          , posting_sourcepos
 277          , posting_status
 278          , posting_tags
 279          })
 280         ) <?> "posting"
 281
 282 amount_sep :: Char
 283 amount_sep = '+'
 284
 285 tags_of_comments :: [Comment] -> Tag.Tags
 286 tags_of_comments =
 287         Tag.Tags .
 288         Data.Map.unionsWith (++)
 289         . Data.List.map
 290          ( Data.Either.either (const Data.Map.empty) id
 291          . R.runParser (not_tag >> tags <* R.eof) () "" )
 292
 293 status :: Stream s m Char => ParsecT s u m Ledger.Status
 294 status = (do
 295         ( R.try $ do
 296                 R.skipMany $ R.space_horizontal
 297                 _ <- (R.char '*' <|> R.char '!')
 298                 return True )
 299         <|> return False
 300         ) <?> "status"
 301
 302 -- | Return the 'Posting_Type' and stripped 'Account' of the given 'Account'.
 303 posting_type :: Account -> (Posting_Type, Account)
 304 posting_type acct =
 305         fromMaybe (Posting_Type_Regular, acct) $ do
 306                 case acct of
 307                  name:|[] ->
 308                         case Text.stripPrefix virtual_begin name of
 309                          Just name' -> do
 310                                 name'' <- liftM Text.strip $ Text.stripSuffix virtual_end name'
 311                                 guard $ not $ Text.null name''
 312                                 Just (Posting_Type_Virtual, name'':|[])
 313                          Nothing -> do
 314                                 name' <- liftM Text.strip $
 315                                             Text.stripPrefix virtual_balanced_begin name
 316                                         >>= Text.stripSuffix virtual_balanced_end
 317                                 guard $ not $ Text.null name'
 318                                 Just (Posting_Type_Virtual_Balanced, name':|[])
 319                  first_name:|acct' -> do
 320                         let rev_acct' = Data.List.reverse acct'
 321                         let last_name = Data.List.head rev_acct'
 322                         case liftM Text.stripStart $
 323                                 Text.stripPrefix virtual_begin first_name of
 324                          Just first_name' -> do
 325                                 last_name' <- liftM Text.stripEnd $
 326                                         Text.stripSuffix virtual_end last_name
 327                                 guard $ not $ Text.null first_name'
 328                                 guard $ not $ Text.null last_name'
 329                                 Just $
 330                                         ( Posting_Type_Virtual
 331                                         , first_name':|
 332                                                 Data.List.reverse (last_name':Data.List.tail rev_acct')
 333                                         )
 334                          Nothing -> do
 335                                 first_name' <- liftM Text.stripStart $
 336                                         Text.stripPrefix virtual_balanced_begin first_name
 337                                 last_name'  <- liftM Text.stripEnd $
 338                                         Text.stripSuffix virtual_balanced_end last_name
 339                                 guard $ not $ Text.null first_name'
 340                                 guard $ not $ Text.null last_name'
 341                                 Just $
 342                                         ( Posting_Type_Virtual_Balanced
 343                                         , first_name':|
 344                                                 Data.List.reverse (last_name':Data.List.tail rev_acct')
 345                                         )
 346         where
 347                 virtual_begin          = Text.singleton posting_type_virtual_begin
 348                 virtual_end            = Text.singleton posting_type_virtual_end
 349                 virtual_balanced_begin = Text.singleton posting_type_virtual_balanced_begin
 350                 virtual_balanced_end   = Text.singleton posting_type_virtual_balanced_end
 351
 352 posting_type_virtual_begin :: Char
 353 posting_type_virtual_begin = '('
 354 posting_type_virtual_balanced_begin :: Char
 355 posting_type_virtual_balanced_begin = '['
 356 posting_type_virtual_end :: Char
 357 posting_type_virtual_end = ')'
 358 posting_type_virtual_balanced_end :: Char
 359 posting_type_virtual_balanced_end = ']'
 360
 361 -- * Read 'Transaction'
 362
 363 transaction ::
 364  ( Consable f ts (Chart, t)
 365  , Stream s (R.Error_State Error m) Char
 366  , Monad m
 367  ) => ParsecT s (Context f ts t) (R.Error_State Error m) Transaction
 368 transaction = (do
 369         ctx <- R.getState
 370         transaction_sourcepos <- R.getPosition
 371         transaction_comments_before <-
 372                 comments
 373                 >>= \x -> case x of
 374                  [] -> return []
 375                  _  -> return x <* R.new_line
 376         date_ <- Date.Read.date Error_date (Just $ context_year ctx)
 377         dates_ <-
 378                 R.option [] $ R.try $ do
 379                         R.skipMany $ R.space_horizontal
 380                         _ <- R.char date_sep
 381                         R.skipMany $ R.space_horizontal
 382                         R.many_separated
 383                          (Date.Read.date Error_date (Just $ context_year ctx)) $
 384                                 R.try $ do
 385                                         R.many $ R.space_horizontal
 386                                         >> R.char date_sep
 387                                         >> (R.many $ R.space_horizontal)
 388         let transaction_dates = (date_, dates_)
 389         R.skipMany $ R.space_horizontal
 390         transaction_status <- status
 391         transaction_code <- R.option "" $ R.try code
 392         R.skipMany $ R.space_horizontal
 393         transaction_description <- description
 394         R.skipMany $ R.space_horizontal
 395         transaction_comments_after <- comments
 396         let transaction_tags =
 397                 mappend
 398                  (tags_of_comments transaction_comments_before)
 399                  (tags_of_comments transaction_comments_after)
 400         R.new_line
 401         (postings_unchecked, postings_not_regular) <-
 402                 first (Ledger.posting_by_Account . Data.List.map snd) .
 403                 Data.List.partition ((Posting.Posting_Type_Regular ==) . fst) <$>
 404                 R.many1_separated posting R.new_line
 405         let (transaction_virtual_postings, balanced_virtual_postings_unchecked) =
 406                 join (***) (Ledger.posting_by_Account . Data.List.map snd) $
 407                 Data.List.partition ((Posting.Posting_Type_Virtual ==) . fst)
 408                  postings_not_regular
 409         let tr_unchecked =
 410                 Transaction
 411                  { transaction_code
 412                  , transaction_comments_before
 413                  , transaction_comments_after
 414                  , transaction_dates
 415                  , transaction_description
 416                  , transaction_postings=postings_unchecked
 417                  , transaction_virtual_postings
 418                  , transaction_balanced_virtual_postings=balanced_virtual_postings_unchecked
 419                  , transaction_sourcepos
 420                  , transaction_status
 421                  , transaction_tags
 422                  }
 423         transaction_postings <-
 424                 case Balance.infer_equilibrium postings_unchecked of
 425                  (_, Left ko) -> R.fail_with "transaction infer_equilibrium"
 426                                              (Error_transaction_not_equilibrated tr_unchecked ko)
 427                  (_bal, Right ok) -> return ok
 428         transaction_balanced_virtual_postings <-
 429                 case Balance.infer_equilibrium balanced_virtual_postings_unchecked of
 430                  (_, Left ko) -> R.fail_with "transaction infer_equilibrium"
 431                                              (Error_virtual_transaction_not_equilibrated tr_unchecked ko)
 432                  (_bal, Right ok) -> return ok
 433         return $
 434                 tr_unchecked
 435                  { transaction_postings
 436                  , transaction_balanced_virtual_postings
 437                  }
 438         ) <?> "transaction"
 439
 440 date_sep :: Char
 441 date_sep = '='
 442
 443 code :: (Consable f ts (CT t), Stream s m Char)
 444  => ParsecT s (Context f ts t) m Ledger.Code
 445 code = (do
 446         fromString <$> do
 447         R.skipMany $ R.space_horizontal
 448         R.between (R.char '(') (R.char ')') $
 449                 R.many $ R.satisfy (\c -> c /= ')' && not (R.is_space_horizontal c))
 450         ) <?> "code"
 451
 452 description :: Stream s m Char => ParsecT s u m Ledger.Description
 453 description = (do
 454         fromString <$> do
 455         R.many $ R.try description_char
 456         ) <?> "description"
 457         where
 458                 description_char :: Stream s m Char => ParsecT s u m Char
 459                 description_char = do
 460                         c <- R.anyChar
 461                         case c of
 462                          _ | c == comment_begin -> R.parserZero
 463                          _ | R.is_space_horizontal c -> return c <* (R.lookAhead $ R.try $ description_char)
 464                          _ | not (Data.Char.isSpace c) -> return c
 465                          _ -> R.parserZero
 466
 467 -- * Read directives
 468
 469 default_year
 470  :: (Consable f ts (CT t), Stream s m Char)
 471  => ParsecT s (Context f ts t) m ()
 472 default_year = (do
 473         year <- R.integer_of_digits 10 <$> R.many1 R.digit
 474         R.skipMany R.space_horizontal
 475         context_ <- R.getState
 476         R.setState context_{context_year=year}
 477         ) <?> "default year"
 478
 479 default_unit_and_style
 480  :: (Consable f ts (CT t), Stream s m Char)
 481  => ParsecT s (Context f ts t) m ()
 482 default_unit_and_style = (do
 483         amount_ <- Amount.Read.amount
 484         R.skipMany R.space_horizontal
 485         context_ <- R.getState
 486         R.setState context_{context_unit_and_style =
 487                 Just $
 488                  ( Amount.unit  amount_
 489                  , Amount.style amount_ )}
 490         ) <?> "default unit and style"
 491
 492 include ::
 493  ( Consable f ts (CT Transaction)
 494  , Show f
 495  , Show (ts (CT Transaction))
 496  , Stream s (R.Error_State Error IO) Char
 497  )
 498  => ParsecT s (Context f ts Transaction)
 499               (R.Error_State Error IO)
 500               ()
 501 include = (do
 502         sourcepos <- R.getPosition
 503         filename <- R.manyTill R.anyChar (R.lookAhead (R.try R.new_line <|> R.eof))
 504         context_including <- R.getState
 505         let journal_including = context_journal context_including
 506         let cwd = Path.takeDirectory (R.sourceName sourcepos)
 507         file_path <- liftIO $ Path.abs cwd filename
 508         content <- do
 509                 join $ liftIO $ Exception.catch
 510                  (liftM return $ Text.IO.readFile file_path)
 511                  (return . R.fail_with "include reading" . Error_reading_file file_path)
 512         (journal_included, context_included) <- do
 513                 liftIO $
 514                         R.runParserT_with_Error
 515                          (R.and_state $ journal_rec file_path)
 516                          context_including
 517                                  { context_journal=
 518                                         Ledger.journal
 519                                          { journal_chart=
 520                                                 journal_chart journal_including
 521                                          }
 522                                  }
 523                          file_path content
 524                 >>= \x -> case x of
 525                  Right ok -> return ok
 526                  Left  ko -> R.fail_with "include parsing" (Error_including_file file_path ko)
 527         R.setState $
 528                 context_included
 529                  { context_journal=
 530                         journal_including
 531                          { journal_includes=
 532                                 journal_included{journal_file=file_path} :
 533                                 journal_includes journal_including
 534                          , journal_chart=
 535                                 journal_chart journal_included
 536                          }
 537                  }
 538         ) <?> "include"
 539
 540 -- * Read 'Chart'
 541
 542 chart ::
 543  ( Consable f ts (CT Transaction)
 544  , Show f
 545  , Show (ts (CT Transaction))
 546  , Stream s (R.Error_State Error IO) Char
 547  )
 548  => ParsecT s (Context f ts Transaction)
 549               (R.Error_State Error IO)
 550         ()
 551 chart = (do
 552         -- sourcepos <- R.getPosition
 553         acct <- Account.Read.account
 554         R.skipMany R.space_horizontal
 555         _ <- comments
 556         R.new_line
 557         tags_ <- R.many_separated
 558          (R.skipMany1 R.space_horizontal >> tag
 559          <* R.skipMany R.space_horizontal <* comments)
 560          R.new_line
 561         R.skipMany R.space
 562         let chart_accounts =
 563                 TreeMap.singleton acct $
 564                 Tag.Tags $
 565                 Data.Map.fromListWith (flip mappend) $
 566                 map (\(p, v) -> (p, [v])) tags_
 567         let chart_tags =
 568                 foldl'
 569                  (flip (\(p:|ps, v) ->
 570                         TreeMap.insert mappend
 571                          (p:|ps `mappend` [v])
 572                          [acct]))
 573                  mempty
 574                  tags_
 575         ctx <- R.getState
 576         let j = context_journal ctx
 577         R.setState $
 578                 ctx{context_journal=
 579                         j{journal_chart=
 580                                 mappend
 581                                  (journal_chart j)
 582                                  Chart.Chart
 583                                          { Chart.chart_accounts
 584                                          , Chart.chart_tags
 585                                          }
 586                          }
 587                  }
 588         ) <?> "chart"
 589
 590 -- * Read 'Journal'
 591
 592 journal ::
 593  ( Consable f ts (CT Transaction)
 594  , Show f
 595  , Show (ts (CT Transaction))
 596  , Stream s (R.Error_State Error IO) Char
 597  )
 598  => FilePath
 599  -> ParsecT s (Context f ts Transaction)
 600               (R.Error_State Error IO)
 601               (Journal (ts (CT Transaction)))
 602 journal file_ = (do
 603         currentLocalTime <- liftIO $
 604                 Time.utcToLocalTime
 605                 <$> Time.getCurrentTimeZone
 606                 <*> Time.getCurrentTime
 607         let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
 608         ctx <- R.getState
 609         R.setState $ ctx{context_year=currentLocalYear}
 610         journal_rec file_
 611         ) <?> "journal"
 612
 613 journal_rec ::
 614  ( Consable f ts (CT Transaction)
 615  , Show f
 616  , Show (ts (CT Transaction))
 617  , Stream s (R.Error_State Error IO) Char
 618  )
 619  => FilePath
 620  -> ParsecT s (Context f ts Transaction)
 621               (R.Error_State Error IO)
 622               (Journal (ts (CT Transaction)))
 623 journal_rec file_ = do
 624         last_read_time <- liftIO Date.now
 625         loop $
 626                 R.choice_try
 627                  [ jump_comment
 628                  , jump_directive
 629                  , jump_transaction
 630                  , jump_chart
 631                  ]
 632         journal_ <- context_journal <$> R.getState
 633         return $
 634                 journal_
 635                  { journal_file = file_
 636                  , journal_last_read_time = last_read_time
 637                  , journal_includes = reverse $ journal_includes journal_
 638                  }
 639         where
 640                 loop
 641                  :: Stream s m Char
 642                  => ParsecT s u m (ParsecT s u m ())
 643                  -> ParsecT s u m ()
 644                 loop r = do
 645                         R.skipMany (R.skipMany R.space_horizontal >> R.new_line)
 646                         _ <- join r
 647                         R.skipMany (R.skipMany R.space_horizontal >> R.new_line)
 648                         R.try (R.skipMany R.space_horizontal >> R.eof) <|> loop r
 649                 jump_comment ::
 650                  ( Stream s m Char
 651                  , Consable f ts (CT Transaction)
 652                  , Show f
 653                  , Show (ts (CT Transaction))
 654                  , u ~ Context f ts Transaction
 655                  , m ~ R.Error_State Error IO
 656                  )
 657                  => ParsecT s u m (ParsecT s u m ())
 658                 jump_comment = do
 659                         _ <- R.spaces
 660                         _ <- R.lookAhead (R.try $ R.char comment_begin)
 661                         return $ do
 662                                 _cmts <- comments
 663                                 {-
 664                                 R.modifyState $ \ctx ->
 665                                         let j = context_journal ctx in
 666                                         ctx{context_journal=
 667                                                 j{journal_sections=
 668                                                         mcons (context_filter ctx) cmts $
 669                                                                 journal_sections j}}
 670                                 -}
 671                                 return ()
 672                 jump_directive ::
 673                  ( Stream s m Char
 674                  , Consable f ts (CT Transaction)
 675                  , Show f
 676                  , Show (ts (CT Transaction))
 677                  , u ~ Context f ts Transaction
 678                  , m ~ R.Error_State Error IO
 679                  )
 680                  => ParsecT s u m (ParsecT s u m ())
 681                 jump_directive = do
 682                         let choice s = R.string s >> R.skipMany1 R.space_horizontal
 683                         R.choice_try
 684                          [ choice "Y"        >> return default_year
 685                          , choice "D"        >> return default_unit_and_style
 686                          , choice "!include" >> return include
 687                          ] <?> "directive"
 688                 jump_transaction ::
 689                  ( Stream s m Char
 690                  , Consable f ts (CT Transaction)
 691                  , Show f
 692                  , Show (ts (CT Transaction))
 693                  , u ~ Context f ts Transaction
 694                  , m ~ R.Error_State Error IO
 695                  )
 696                  => ParsecT s u m (ParsecT s u m ())
 697                 jump_transaction = do
 698                         _ <- R.lookAhead $ R.try (R.many1 R.digit >> Date.Read.date_separator)
 699                         return $ do
 700                                 t <- transaction
 701                                 R.modifyState $ \ctx ->
 702                                         let j = context_journal ctx in
 703                                         ctx{context_journal=
 704                                                 j{journal_sections=
 705                                                         mcons
 706                                                          (context_filter ctx)
 707                                                          (journal_chart j, t)
 708                                                          (journal_sections j)}}
 709                 jump_chart ::
 710                  ( Stream s m Char
 711                  , Consable f ts (CT Transaction)
 712                  , Show f
 713                  , Show (ts (CT Transaction))
 714                  , u ~ Context f ts Transaction
 715                  , m ~ R.Error_State Error IO
 716                  )
 717                  => ParsecT s u m (ParsecT s u m ())
 718                 jump_chart = do
 719                         return chart
 720
 721 -- ** Read 'Journal' from a file
 722
 723 file
 724  ::
 725  ( Consable f ts (CT Transaction)
 726  , Show f
 727  , Show (ts (CT Transaction))
 728  )
 729  => Context f ts Transaction
 730  -> FilePath
 731  -> ExceptT [R.Error Error] IO (Journal (ts (CT Transaction)))
 732 file ctx path = do
 733         ExceptT $
 734                 Exception.catch
 735                  (liftM Right $ Text.IO.readFile path) $
 736                  \ko -> return $ Left $
 737                          [ R.Error_Custom (R.initialPos path) $ Error_reading_file path ko ]
 738         >>= liftIO . R.runParserT_with_Error (journal path) ctx path
 739         >>= \x -> case x of
 740          Left  ko -> throwE $ ko
 741          Right ok -> ExceptT $ return $ Right ok