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