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