jcc/Hcompta/Format/JCC/Read.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE NamedFieldPuns #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE RankNTypes #-}
   6 {-# LANGUAGE ScopedTypeVariables #-}
   7 {-# LANGUAGE StandaloneDeriving #-}
   8 {-# LANGUAGE TupleSections #-}
   9 {-# LANGUAGE TypeFamilies #-}
  10 module Hcompta.Format.JCC.Read where
  11
  12 import           Control.Applicative ((<$>), (<*>), (<*))
  13 -- import           Control.Arrow ((***), first)
  14 import qualified Control.Exception as Exception
  15 import           Control.Monad (Monad(..), liftM, join)
  16 import           Control.Monad.IO.Class (liftIO)
  17 import           Control.Monad.Trans.Except (ExceptT(..), throwE)
  18 import           Data.Bool
  19 import           Data.Char (Char)
  20 import qualified Data.Char
  21 import           Data.Either (Either(..))
  22 import           Data.Eq (Eq(..))
  23 import qualified Data.List as List
  24 import           Data.Semigroup as Semigroup
  25 import           Data.List.NonEmpty (NonEmpty(..))
  26 import qualified Data.List.NonEmpty as NonEmpty
  27 import           Data.Map.Strict (Map)
  28 import qualified Data.Map.Strict as Map
  29 import           Data.Maybe (Maybe(..), maybe)
  30 import           Data.String (fromString)
  31 import           Data.Text (Text)
  32 import qualified Data.Text.IO as Text.IO (readFile)
  33 import qualified Data.Time.Calendar  as Time
  34 import qualified Data.Time.Clock     as Time
  35 import qualified Data.Time.LocalTime as Time
  36 import           Data.Typeable ()
  37 import           Prelude (($), (.), IO, FilePath, const, flip, id)
  38 import qualified System.FilePath.Posix as Path
  39 import qualified Text.Parsec as R hiding
  40                   ( char
  41                   , anyChar
  42                   , crlf
  43                   , newline
  44                   , noneOf
  45                   , oneOf
  46                   , satisfy
  47                   , space
  48                   , spaces
  49                   , string
  50                   , tab
  51                   )
  52 import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))
  53 import qualified Text.Parsec.Pos as R
  54 import           Text.Show (Show)
  55
  56 import           Hcompta.Account ( Account_Anchor
  57                                  , Account_Tag(..)
  58                                  , Account_Tags(..) )
  59 import qualified Hcompta.Account as Account
  60 import qualified Hcompta.Amount as Amount
  61 import           Hcompta.Anchor (Anchors(..))
  62 import           Hcompta.Tag (Tags(..))
  63 import qualified Hcompta.Balance as Balance
  64 import qualified Hcompta.Chart as Chart
  65 import           Hcompta.Chart (Chart(..))
  66 import           Hcompta.Date (Date)
  67 import qualified Hcompta.Date as Date
  68 import qualified Hcompta.Filter.Date.Read as Date.Read
  69 import           Hcompta.Format.JCC
  70                   ( Account
  71                   , Comment
  72                   , Journal(..)
  73                   , Posting(..)
  74                   , Transaction(..)
  75                   , Charted
  76                   )
  77 import qualified Hcompta.Format.JCC as JCC
  78 import qualified Hcompta.Format.JCC.Amount as JCC.Amount
  79 import qualified Hcompta.Format.JCC.Amount.Read as JCC.Amount.Read
  80 import qualified Hcompta.Format.JCC.Amount.Style as JCC.Amount.Style
  81 import           Hcompta.Format.JCC.Common.Read
  82 -- import qualified Hcompta.Format.JCC.Quantity as JCC.Quantity
  83 import           Hcompta.Lib.Consable (Consable(..))
  84 import qualified Hcompta.Lib.Parsec as R
  85 import qualified Hcompta.Lib.Path as Path
  86 -- import           Hcompta.Lib.Regex (Regex)
  87 import qualified Hcompta.Lib.TreeMap as TreeMap
  88 import qualified Hcompta.Polarize as Polarize
  89 import           Hcompta.Posting ( Posting_Anchor(..)
  90                                  , Posting_Anchors(..)
  91                                  , Posting_Tag(..)
  92                                  , Posting_Tags(..) )
  93 import qualified Hcompta.Posting as Posting
  94 import qualified Hcompta.Quantity as Quantity
  95 import           Hcompta.Transaction ( Transaction_Anchor(..)
  96                                      , Transaction_Anchors(..)
  97                                      , Transaction_Tag(..)
  98                                      , Transaction_Tags(..) )
  99 import qualified Hcompta.Transaction as Transaction
 100 import qualified Hcompta.Unit as Unit
 101
 102 -- * Type 'Context'
 103
 104 data Context c j
 105  =   Context
 106  { context_cons    :: Charted Transaction -> c
 107  , context_date    :: !Date
 108  , context_journal :: !(Journal j)
 109  , context_unit    :: !(Maybe JCC.Unit)
 110  , context_year    :: !Date.Year
 111  }
 112
 113 context
 114  :: Consable c j
 115  => (Charted Transaction -> c)
 116  -> Journal j
 117  -> Context c j
 118 context context_cons context_journal =
 119         Context
 120          { context_cons
 121          , context_date    = Date.nil
 122          , context_journal
 123          , context_unit    = Nothing
 124          , context_year    = Date.year Date.nil
 125          }
 126
 127 -- * Type 'Error'
 128
 129 data Error
 130  =   Error_account_anchor_unknown R.SourcePos Account_Anchor
 131  |   Error_account_anchor_not_unique R.SourcePos Account_Anchor
 132  |   Error_date Date.Read.Error
 133  |   Error_including_file FilePath [R.Error Error]
 134  |   Error_reading_file FilePath Exception.IOException
 135  |   Error_transaction_not_equilibrated
 136       JCC.Amount.Styles
 137       Transaction
 138       [( JCC.Unit
 139        , Balance.Unit_Sum Account
 140           (Polarize.Polarized JCC.Quantity)
 141        )]
 142  deriving (Show)
 143
 144 -- * Read 'Comment'
 145
 146 comment_begin :: Char
 147 comment_begin = ';'
 148
 149 comment :: Stream s m Char => ParsecT s u m Comment
 150 comment = (R.char comment_begin >> line) <?> "comment"
 151
 152 comments :: Stream s m Char => ParsecT s u m [Comment]
 153 comments = (do
 154         R.try $ do
 155                 _ <- R.spaces
 156                 R.many1_separated comment (eol >> hspaces)
 157         <|> return []
 158         ) <?> "comments"
 159
 160 -- * Read 'Account'
 161
 162 account :: Stream s m Char => ParsecT s u m JCC.Account
 163 account = do
 164         Account.from_List <$> do
 165         R.many1 (R.char account_section_sep >> account_section)
 166
 167 account_section :: Stream s m Char => ParsecT s u m Text
 168 account_section = name
 169
 170 account_section_sep :: Char
 171 account_section_sep = '/'
 172
 173 -- ** Read 'Account_Tag'
 174 account_tag_prefix :: Char
 175 account_tag_prefix = '.'
 176 account_tag_sep :: Char
 177 account_tag_sep = ':'
 178 account_tag_value_prefix :: Char
 179 account_tag_value_prefix = '='
 180
 181 account_tag :: Stream s m Char => ParsecT s u m Account_Tag
 182 account_tag = (do
 183         _ <- R.char account_tag_prefix
 184         p <- name
 185         Account.tag
 186          <$> (:|) p <$>
 187                 R.many (R.char account_tag_sep >> name)
 188          <*> (fromString <$>
 189                 R.option ""
 190                  (hspaces >> R.char transaction_tag_value_prefix >> hspaces >>
 191                         (List.concat <$> R.many (R.choice
 192                          [ R.string [account_tag_prefix   , account_tag_prefix]    >> return [account_tag_prefix]
 193                          , R.string [account_anchor_prefix, account_anchor_prefix] >> return [account_anchor_prefix]
 194                          , (\s c -> mappend s [c])
 195                                  <$> R.many space
 196                                  <*> R.satisfy (\c ->
 197                                             c /= account_tag_prefix
 198                                          && c /= account_anchor_prefix
 199                                          && is_char c)
 200                          ]))))
 201         ) <?> "account_tag"
 202
 203 -- ** Read 'Account_Anchor'
 204 account_anchor_prefix :: Char
 205 account_anchor_prefix = '~'
 206 account_anchor_sep :: Char
 207 account_anchor_sep = ':'
 208
 209 account_anchor :: Stream s m Char => ParsecT s u m Account_Anchor
 210 account_anchor = (do
 211         _ <- R.char account_anchor_prefix
 212         p <- name
 213         ps <- R.many (R.char account_anchor_sep >> name)
 214         return $ Account.anchor (p:|ps)
 215         ) <?> "account_anchor"
 216
 217 -- ** Read 'Account' 'Comment'
 218 account_comment :: Stream s m Char => ParsecT s u m Comment
 219 account_comment = comment
 220
 221 -- * Read 'Posting'
 222
 223 posting ::
 224  ( Consable c j
 225  , Monad m
 226  , Stream s (R.Error_State Error m) Char
 227  ) => ParsecT s (Context c j)
 228                 (R.Error_State Error m)
 229                 Posting
 230 posting = (do
 231         posting_sourcepos <- R.getPosition
 232         _ <- hspaces
 233         (posting_account, posting_account_anchor) <-
 234                 R.choice_try
 235                  [ (,Nothing) <$> account
 236                  , do
 237                         anchor <- account_anchor
 238                         ctx <- R.getState
 239                         let anchors = chart_anchors $ journal_chart $ context_journal ctx
 240                         case Map.lookup anchor anchors of
 241                          Just (a:|as) -> do
 242                                 sa <- R.option Nothing $ Just <$> account
 243                                 return $ ( a:|mappend as (maybe [] NonEmpty.toList sa)
 244                                          , Just (anchor, sa) )
 245                          Nothing -> R.fail_with "account anchor"
 246                                  (Error_account_anchor_unknown posting_sourcepos anchor)
 247                  ] <?> "posting_account"
 248         posting_amounts <-
 249                 R.choice_try
 250                  [ do
 251                         R.skipMany1 space
 252                         amts <-
 253                                 R.many_separated JCC.Amount.Read.amount $ do
 254                                         R.skipMany space
 255                                         _ <- R.char amount_sep
 256                                         R.skipMany space
 257                         ctx <- flip liftM R.getState $ \ctx ->
 258                                 ctx
 259                                  { context_journal=
 260                                         let jnl = context_journal ctx in
 261                                         jnl
 262                                          { JCC.journal_amount_styles =
 263                                                 List.foldl'
 264                                                  (\(JCC.Amount.Style.Styles styles) (style, amt) ->
 265                                                         JCC.Amount.Style.Styles $
 266                                                         Map.insertWith mappend
 267                                                          (Amount.amount_unit amt)
 268                                                          style styles)
 269                                                  (JCC.journal_amount_styles jnl)
 270                                                  amts
 271                                          }
 272                                  }
 273                         R.setState ctx
 274                         return $
 275                                 Map.fromListWith Quantity.quantity_add $
 276                                 List.map
 277                                  (\(_sty, amt) ->
 278                                         let unit = Amount.amount_unit amt in
 279                                         ( if unit == Unit.unit_empty
 280                                                 then maybe unit id (context_unit ctx)
 281                                                 else unit
 282                                         , Amount.amount_quantity amt
 283                                         )
 284                                  )
 285                                  amts
 286                  , return mempty
 287                  ] <?> "posting_amounts"
 288         (posting_tags, posting_anchors, posting_comments) <-
 289                 fields mempty mempty mempty
 290         return $ Posting
 291          { posting_account
 292          , posting_account_anchor
 293          , posting_amounts
 294          , posting_anchors = Posting_Anchors posting_anchors
 295          , posting_tags = Posting_Tags posting_tags
 296          , posting_comments
 297          , posting_dates = []
 298          , posting_sourcepos
 299          }
 300         ) <?> "posting"
 301         where
 302                 {-
 303                 fields :: Tags -> Anchors -> Comments
 304                  -> ParsecT s (Context c j)
 305                               (R.Error_State Error m)
 306                               (Tags, Anchors, Comments)
 307                 -}
 308                 fields
 309                  tags@(Tags tagm)
 310                  anchors@(Anchors anchs)
 311                  cmts =
 312                         R.choice_try
 313                          [ hspaces1 >> posting_comment >>= \c ->
 314                                 fields tags anchors (c:cmts)
 315                          , hspaces1 >> posting_tag >>= \(Posting_Tag (p, v)) ->
 316                                 fields (Tags $ Map.insertWith mappend p [v] tagm) anchors cmts
 317                          , hspaces1 >> posting_anchor >>= \(Posting_Anchor p) ->
 318                                 fields tags (Anchors $ Map.insert p () anchs) cmts
 319                          , hspaces  >> eol >>
 320                                 fields tags anchors cmts
 321                          , return (tags, anchors, cmts)
 322                          ]
 323
 324 amount_sep :: Char
 325 amount_sep = '+'
 326
 327 posting_comment :: Stream s m Char => ParsecT s u m Comment
 328 posting_comment = comment
 329
 330 -- ** Read 'Posting_Tag'
 331 posting_tag :: Stream s m Char => ParsecT s u m Posting_Tag
 332 posting_tag = (liftM (\(Transaction_Tag tag) -> Posting_Tag tag) transaction_tag) <?> "posting_tag"
 333
 334 -- ** Read 'Posting_Anchor'
 335 posting_anchor :: Stream s m Char => ParsecT s u m Posting_Anchor
 336 posting_anchor = (do
 337         _ <- R.char transaction_anchor_prefix
 338         Posting.anchor <$>
 339                 NonEmpty.fromList <$>
 340                 R.many1 (R.char transaction_anchor_sep >> name)
 341         ) <?> "posting_anchor"
 342
 343 -- * Read 'Transaction'
 344
 345 map_Postings_by_Account :: [Posting] -> Map Account [Posting]
 346 map_Postings_by_Account =
 347         Map.fromListWith (flip mappend) .
 348         List.map (\p -> (posting_account p, [p]))
 349
 350 transaction ::
 351  ( Consable c j
 352  , Monad m
 353  , Stream s (R.Error_State Error m) Char
 354  ) => ParsecT s (Context c j) (R.Error_State Error m) Transaction
 355 transaction = (do
 356         ctx <- R.getState
 357         transaction_sourcepos <- R.getPosition
 358         date_ <- Date.Read.date Error_date (Just $ context_year ctx)
 359         dates_ <-
 360                 R.option [] $ R.try $ do
 361                         _ <- hspaces
 362                         _ <- R.char date_sep
 363                         _ <- hspaces
 364                         R.many_separated
 365                          (Date.Read.date Error_date (Just $ context_year ctx)) $
 366                                 R.try $
 367                                         hspaces
 368                                         >> R.char date_sep
 369                                         >> hspaces
 370         let transaction_dates = (date_, dates_)
 371         _ <- hspaces
 372         transaction_wording <- wording
 373         _ <- eol
 374         (transaction_tags, transaction_anchors, transaction_comments) <-
 375                 -- return (mempty, mempty, mempty)
 376                 fields mempty mempty mempty
 377         transaction_postings_unchecked <-
 378                 map_Postings_by_Account <$> postings
 379         let transaction_unchecked =
 380                 Transaction
 381                  { transaction_anchors = Transaction_Anchors transaction_anchors
 382                  , transaction_tags = Transaction_Tags transaction_tags
 383                  , transaction_comments
 384                  , transaction_dates
 385                  , transaction_wording
 386                  , transaction_postings = transaction_postings_unchecked
 387                  , transaction_sourcepos
 388                  }
 389         let styles = JCC.journal_amount_styles $ context_journal ctx
 390         transaction_postings <-
 391                 case Balance.infer_equilibrium transaction_postings_unchecked of
 392                  (_, Left ko) -> R.fail_with "transaction infer_equilibrium" $
 393                         Error_transaction_not_equilibrated styles transaction_unchecked ko
 394                  (_bal, Right ok) -> return ok
 395         return $
 396                 transaction_unchecked
 397                  { transaction_postings
 398                  }
 399         ) <?> "transaction"
 400         where
 401                 fields
 402                  tags@(Tags tagm)
 403                  anchors@(Anchors anchs)
 404                  cmts =
 405                         R.choice_try
 406                          [ hspaces1 >> transaction_comment >>= \c ->
 407                                 fields tags anchors (c:cmts)
 408                          , hspaces1 >> transaction_tag >>= \(Transaction_Tag (p, v)) ->
 409                                 fields (Tags $ Map.insertWith mappend p [v] tagm) anchors cmts
 410                          , hspaces1 >> transaction_anchor >>= \(Transaction_Anchor p) ->
 411                                 fields tags (Anchors $ Map.insert p () anchs) cmts
 412                          , hspaces >> eol >>
 413                                 fields tags anchors cmts
 414                          , return (tags, anchors, cmts)
 415                          ]
 416
 417 postings ::
 418  (Consable c j, Monad m, Stream s (R.Error_State Error m) Char)
 419  => ParsecT s (Context c j) (R.Error_State Error m) [Posting]
 420 postings =
 421         R.many1
 422          (hspaces1 >> posting)
 423
 424 date_sep :: Char
 425 date_sep = '='
 426
 427 code :: ( Consable c j
 428         , Stream s m Char )
 429  => ParsecT s (Context c j) m JCC.Code
 430 code = (do
 431         fromString <$> do
 432         _ <- hspaces
 433         R.between (R.char '(') (R.char ')') $
 434                 R.many $ R.satisfy (\c -> c /= ')' && not (R.is_space_horizontal c))
 435         ) <?> "code"
 436
 437 wording :: Stream s m Char => ParsecT s u m JCC.Wording
 438 wording = (do
 439         fromString <$> do
 440         R.many $ R.try wording_char
 441         ) <?> "wording"
 442         where
 443                 wording_char :: Stream s m Char => ParsecT s u m Char
 444                 wording_char = do
 445                         c <- R.anyChar
 446                         case c of
 447                          _ | c == comment_begin -> R.parserZero
 448                          _ | R.is_space_horizontal c -> return c <* (R.lookAhead $ R.try $ wording_char)
 449                          _ | not (Data.Char.isSpace c) -> return c
 450                          _ -> R.parserZero
 451
 452 -- ** Read 'Transaction_Anchor'
 453
 454 transaction_anchor_prefix :: Char
 455 transaction_anchor_prefix = '@'
 456 transaction_anchor_sep :: Char
 457 transaction_anchor_sep = ':'
 458
 459 transaction_anchor :: Stream s m Char => ParsecT s u m Transaction_Anchor
 460 transaction_anchor = (do
 461         _ <- R.char transaction_anchor_prefix
 462         p <- name
 463         Transaction.anchor <$>
 464                 (:|) p <$>
 465                 R.many (R.char transaction_anchor_sep >> name)
 466         ) <?> "transaction_anchor"
 467
 468 -- ** Read 'Transaction_Tag'
 469 transaction_tag_prefix :: Char
 470 transaction_tag_prefix = '#'
 471 transaction_tag_sep :: Char
 472 transaction_tag_sep = ':'
 473 transaction_tag_value_prefix :: Char
 474 transaction_tag_value_prefix = '='
 475
 476 transaction_tag :: Stream s m Char => ParsecT s u m Transaction_Tag
 477 transaction_tag = (do
 478         _ <- R.char transaction_tag_prefix
 479         p <- name
 480         Transaction.tag
 481          <$>
 482                 (:|) p <$>
 483                 R.many (R.char transaction_tag_sep >> name)
 484          <*> (fromString <$>
 485                         R.option ""
 486                          (hspaces >> R.char transaction_tag_value_prefix >> hspaces >>
 487                                  (List.concat <$>
 488                                         R.many (R.choice
 489                                          [ R.string [transaction_tag_prefix, transaction_tag_prefix] >>
 490                                                 return [transaction_tag_prefix]
 491                                          , R.string [transaction_anchor_prefix, transaction_anchor_prefix] >>
 492                                                 return [transaction_anchor_prefix]
 493                                          , (\s c -> mappend s [c])
 494                                                  <$> R.many space
 495                                                  <*> R.satisfy (\c -> c /= transaction_tag_prefix && c /= transaction_anchor_prefix && is_char c)
 496                                          ]))))
 497         ) <?> "transaction_tag"
 498
 499 -- ** Read 'Transaction' 'Comment'
 500 transaction_comment :: Stream s m Char => ParsecT s u m Comment
 501 transaction_comment = comment
 502
 503 -- * Read directives
 504
 505 default_year
 506  :: ( Consable c j
 507     , Stream s m Char )
 508  => ParsecT s (Context c j) m ()
 509 default_year = (do
 510         year <- R.integer_of_digits 10 <$> R.many1 R.digit
 511         _ <- hspaces
 512         context_ <- R.getState
 513         R.setState context_{context_year=year}
 514         ) <?> "default year"
 515
 516 default_unit_and_style
 517  :: ( Consable c j
 518     , Stream s m Char )
 519  => ParsecT s (Context c j) m ()
 520 default_unit_and_style = (do
 521         (sty, amt) <- JCC.Amount.Read.amount
 522         _ <- hspaces
 523         ctx <- R.getState
 524         let unit = Amount.amount_unit amt
 525         R.setState ctx
 526          { context_journal =
 527                 let jnl = context_journal ctx in
 528                 jnl
 529                  { JCC.journal_amount_styles =
 530                         let JCC.Amount.Style.Styles styles =
 531                                 JCC.journal_amount_styles jnl in
 532                         JCC.Amount.Style.Styles $
 533                         Map.insertWith const unit sty styles
 534                  }
 535          , context_unit = Just unit
 536          }
 537         ) <?> "default unit and style"
 538
 539 -- * Read included 'Journal'
 540
 541 include ::
 542  ( Consable c j
 543  , Monoid j
 544  , Stream s (R.Error_State Error IO) Char
 545  )
 546  => ParsecT s (Context c j)
 547               (R.Error_State Error IO)
 548               ()
 549 include = (do
 550         sourcepos <- R.getPosition
 551         filename <- R.manyTill R.anyChar (R.lookAhead (R.try R.new_line <|> R.eof))
 552         context_including <- R.getState
 553         let journal_including = context_journal context_including
 554         let cwd = Path.takeDirectory (R.sourceName sourcepos)
 555         file_path <- liftIO $ Path.abs cwd filename
 556         content <- do
 557                 join $ liftIO $ Exception.catch
 558                  (liftM return $ Text.IO.readFile file_path)
 559                  (return . R.fail_with "include reading" . Error_reading_file file_path)
 560         (journal_included, context_included) <- do
 561                 liftIO $
 562                         R.runParserT_with_Error
 563                          (R.and_state $ journal_rec file_path)
 564                          context_including
 565                                  { context_journal=
 566                                         JCC.journal
 567                                          { journal_chart=
 568                                                 journal_chart journal_including
 569                                          , journal_amount_styles=
 570                                                 journal_amount_styles journal_including
 571                                          }
 572                                  }
 573                          file_path content
 574                 >>= \x -> case x of
 575                  Right ok -> return ok
 576                  Left  ko -> R.fail_with "include parsing" (Error_including_file file_path ko)
 577         R.setState $
 578                 context_included
 579                  { context_journal=
 580                         journal_including
 581                          { journal_includes=
 582                                 journal_included{journal_file=file_path} :
 583                                 journal_includes journal_including
 584                          , journal_chart=
 585                                 journal_chart journal_included
 586                          , journal_amount_styles=
 587                                 journal_amount_styles journal_included
 588                          }
 589                  }
 590         ) <?> "include"
 591
 592 -- * Read 'Chart'
 593
 594 chart ::
 595  ( Consable c j
 596  , Stream s (R.Error_State Error IO) Char
 597  )
 598  => ParsecT s (Context c j)
 599               (R.Error_State Error IO)
 600               ()
 601 chart = (do
 602         -- sourcepos <- R.getPosition
 603         acct <- account
 604         _ <- eol
 605         ( chart_tags
 606          , chart_anchors
 607          , _chart_comments ) <-
 608                 fields acct mempty mempty mempty
 609         let chart_accounts =
 610                 TreeMap.singleton acct $
 611                 Account_Tags chart_tags
 612         ctx <- R.getState
 613         let j = context_journal ctx
 614         R.setState $
 615                 ctx{context_journal=
 616                         j{journal_chart=
 617                                 mappend
 618                                  (journal_chart j)
 619                                  Chart.Chart
 620                                          { Chart.chart_accounts
 621                                          -- , Chart.chart_tags
 622                                          , Chart.chart_anchors
 623                                          }
 624                          }
 625                  }
 626         ) <?> "chart"
 627         where
 628                 fields
 629                  acct
 630                  tags@(Tags tagm)
 631                  anchors
 632                  cmts =
 633                         R.choice_try
 634                          [ hspaces1 >> account_comment >>= \c ->
 635                                 fields acct tags anchors (c:cmts)
 636                          , hspaces1 >> account_tag >>= \(Account_Tag (p, v)) ->
 637                                 fields acct (Tags $ Map.insertWith mappend p [v] tagm) anchors cmts
 638                          , hspaces1 >> account_anchor >>= \anchor ->
 639                                 case Map.insertLookupWithKey (\_k n _o -> n) anchor acct anchors of
 640                                  (Nothing, m) -> fields acct tags m cmts
 641                                  (Just _, _) -> do
 642                                         sourcepos <- R.getPosition
 643                                         R.fail_with "account anchor not unique"
 644                                          (Error_account_anchor_not_unique sourcepos anchor)
 645                          , hspaces >> eol >>
 646                                 fields acct tags anchors cmts
 647                          , return (tags, anchors, cmts)
 648                          ]
 649
 650 -- * Read 'Journal'
 651
 652 journal ::
 653  ( Consable c j
 654  , Monoid j
 655  , Stream s (R.Error_State Error IO) Char
 656  )
 657  => FilePath
 658  -> ParsecT s (Context c j)
 659               (R.Error_State Error IO)
 660               (Journal j)
 661 journal file_ = (do
 662         currentLocalTime <- liftIO $
 663                 Time.utcToLocalTime
 664                 <$> Time.getCurrentTimeZone
 665                 <*> Time.getCurrentTime
 666         let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
 667         ctx <- R.getState
 668         R.setState $ ctx{context_year=currentLocalYear}
 669         journal_rec file_
 670         ) <?> "journal"
 671
 672 journal_rec ::
 673  ( Consable c j
 674  , Monoid j
 675  , Stream s (R.Error_State Error IO) Char
 676  )
 677  => FilePath
 678  -> ParsecT s (Context c j)
 679               (R.Error_State Error IO)
 680               (Journal j)
 681 journal_rec file_ = do
 682         last_read_time <- liftIO Date.now
 683         loop $
 684                 R.choice_try
 685                  [ jump_comment
 686                  , jump_directive
 687                  , jump_transaction
 688                  , jump_chart
 689                  ]
 690         journal_ <- context_journal <$> R.getState
 691         return $
 692                 journal_
 693                  { journal_file = file_
 694                  , journal_last_read_time = last_read_time
 695                  , journal_includes = List.reverse $ journal_includes journal_
 696                  }
 697         where
 698                 loop
 699                  :: Stream s m Char
 700                  => ParsecT s u m (ParsecT s u m ())
 701                  -> ParsecT s u m ()
 702                 loop r = do
 703                         R.skipMany (hspaces >> R.new_line)
 704                         _ <- join r
 705                         R.skipMany (hspaces >> R.new_line)
 706                         R.try (hspaces >> R.eof) <|> loop r
 707                 jump_comment ::
 708                  ( Stream s m Char
 709                  , Consable c j
 710                  , u ~ Context c j
 711                  , m ~ R.Error_State Error IO
 712                  )
 713                  => ParsecT s u m (ParsecT s u m ())
 714                 jump_comment = do
 715                         _ <- R.spaces
 716                         _ <- R.lookAhead (R.try $ R.char comment_begin)
 717                         return $ do
 718                                 _cmts <- comments
 719                                 {-
 720                                 R.modifyState $ \ctx ->
 721                                         let j = context_journal ctx in
 722                                         ctx{context_journal=
 723                                                 j{journal_content=
 724                                                         mcons (context_filter ctx) cmts $
 725                                                                 journal_content j}}
 726                                 -}
 727                                 return ()
 728                 jump_directive ::
 729                  ( Consable c j
 730                  , Monoid j
 731                  , Stream s m Char
 732                  , u ~ Context c j
 733                  , m ~ R.Error_State Error IO
 734                  )
 735                  => ParsecT s u m (ParsecT s u m ())
 736                 jump_directive = do
 737                         let choice s = R.string s >> hspaces1
 738                         R.choice_try
 739                          [ choice "Y"        >> return default_year
 740                          , choice "D"        >> return default_unit_and_style
 741                          , choice "!include" >> return include
 742                          ] <?> "directive"
 743                 jump_transaction ::
 744                  ( Consable c j
 745                  , Stream s m Char
 746                  , u ~ Context c j
 747                  , m ~ R.Error_State Error IO
 748                  )
 749                  => ParsecT s u m (ParsecT s u m ())
 750                 jump_transaction = do
 751                         _ <- R.lookAhead $ R.try (R.many1 R.digit >> R.char Date.Read.date_separator)
 752                         return $ do
 753                                 t <- transaction
 754                                 R.modifyState $ \ctx ->
 755                                         let j = context_journal ctx in
 756                                         ctx{context_journal=
 757                                                 j{journal_content=
 758                                                         mcons
 759                                                          (context_cons ctx $ Chart.Charted (journal_chart j) t)
 760                                                          (journal_content j)}}
 761                 jump_chart ::
 762                  ( Consable c j
 763                  , Stream s m Char
 764                  , u ~ Context c j
 765                  , m ~ R.Error_State Error IO
 766                  )
 767                  => ParsecT s u m (ParsecT s u m ())
 768                 jump_chart = do
 769                         return chart
 770
 771 -- ** Read 'Journal' from a file
 772
 773 file ::
 774  ( Consable c j
 775  , Monoid j
 776  )
 777  => Context c j
 778  -> FilePath
 779  -> ExceptT [R.Error Error] IO (Journal j)
 780 file ctx path = do
 781         ExceptT $
 782                 Exception.catch
 783                  (liftM Right $ Text.IO.readFile path) $
 784                  \ko -> return $ Left $
 785                          [ R.Error_Custom (R.initialPos path) $ Error_reading_file path ko ]
 786         >>= liftIO . R.runParserT_with_Error (journal path) ctx path
 787         >>= \x -> case x of
 788          Left  ko -> throwE $ ko
 789          Right ok -> ExceptT $ return $ Right ok