lib/Hcompta/Format/Ledger/Read.hs

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