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 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.Time.LocalTime (TimeZone(..))
  18 import           Data.Bool
  19 import           Data.Decimal
  20 import           Data.Char (Char)
  21 import qualified Data.Char as Char
  22 import           Data.Either (Either(..), either)
  23 import           Data.Eq (Eq(..))
  24 import           Data.Ord (Ord(..))
  25 import           Data.Function (($), (.), id, const, flip)
  26 import           Data.Functor (Functor(..))
  27 import qualified Data.List as List
  28 import           Data.List.NonEmpty (NonEmpty(..))
  29 import qualified Data.List.NonEmpty as NonEmpty
  30 import           Data.Map.Strict (Map)
  31 import qualified Data.Map.Strict as Map
  32 import           Data.Maybe (Maybe(..), fromMaybe, maybe)
  33 import           Data.Monoid (Monoid(..))
  34 import           Data.String (String, fromString)
  35 import qualified Data.Text as Text
  36 import           Data.Text (Text)
  37 import qualified Data.Text.IO as Text.IO (readFile)
  38 import qualified Data.Time.Calendar  as Time
  39 import qualified Data.Time.Clock     as Time
  40 import qualified Data.Time.LocalTime as Time
  41 import           Data.Typeable ()
  42 import           Prelude (Int, Integer, Num(..), fromIntegral)
  43 import qualified System.FilePath.Posix as Path
  44 import           System.IO (IO, FilePath)
  45 import qualified Text.Parsec as R hiding
  46                   ( char
  47                   , anyChar
  48                   , crlf
  49                   , newline
  50                   , noneOf
  51                   , oneOf
  52                   , satisfy
  53                   , space
  54                   , spaces
  55                   , string
  56                   , tab
  57                   )
  58 import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))
  59 import qualified Text.Parsec.Pos as R
  60 import           Text.Show (Show)
  61
  62 import qualified Hcompta.Account as Account
  63 import           Hcompta.Account (Account_Tags(..))
  64 import qualified Hcompta.Amount as Amount
  65 import qualified Hcompta.Balance as Balance
  66 import qualified Hcompta.Chart as Chart
  67 import           Hcompta.Date (Date)
  68 import qualified Hcompta.Date as Date
  69 import           Hcompta.Lib.Consable (Consable(..))
  70 import qualified Hcompta.Lib.Parsec as R
  71 import qualified Hcompta.Lib.Path as Path
  72 import           Hcompta.Lib.Regex (Regex)
  73 import qualified Hcompta.Lib.Regex as Regex
  74 import qualified Hcompta.Lib.TreeMap as TreeMap
  75 import qualified Hcompta.Polarize as Polarize
  76 import           Hcompta.Posting (Posting_Tags(..))
  77 import qualified Hcompta.Quantity as Quantity
  78 import           Hcompta.Tag (Tag, Tags(..))
  79 import qualified Hcompta.Tag as Tag
  80 import           Hcompta.Transaction (Transaction_Tags(..))
  81 import qualified Hcompta.Unit as Unit
  82 import qualified Hcompta.Filter.Date.Read as Filter.Date.Read
  83 import           Hcompta.Filter.Date.Read (Error(..))
  84
  85 import           Hcompta.Format.Ledger
  86
  87 -- * Type 'Read_Context'
  88
  89 data Read_Context c j
  90  =   Read_Context
  91  { read_context_account_prefix :: !(Maybe Account)
  92  , read_context_aliases_exact  :: !(Map Account Account)
  93  , read_context_aliases_joker  :: ![(Account_Joker, Account)]
  94  , read_context_aliases_regex  :: ![(Regex, Account)]
  95  , read_context_cons           :: Charted Transaction -> c
  96  , read_context_date           :: !Date
  97  , read_context_journal        :: !(Journal j)
  98  , read_context_unit           :: !(Maybe Unit)
  99  , read_context_year           :: !Date.Year
 100  }
 101
 102 read_context
 103  :: Consable c j
 104  => (Charted Transaction -> c)
 105  -> Journal j
 106  -> Read_Context c j
 107 read_context read_context_cons read_context_journal =
 108         Read_Context
 109          { read_context_account_prefix = Nothing
 110          , read_context_aliases_exact  = mempty
 111          , read_context_aliases_joker  = []
 112          , read_context_aliases_regex  = []
 113          , read_context_cons
 114          , read_context_date           = Date.nil
 115          , read_context_journal
 116          , read_context_unit           = Nothing
 117          , read_context_year           = Date.year Date.nil
 118          }
 119
 120 -- * Type 'Read_Error'
 121
 122 data Read_Error
 123  =   Read_Error_date Date_Error
 124  |   Read_Error_transaction_not_equilibrated
 125       Amount_Styles
 126       Transaction
 127       [( Unit
 128        , Balance.Unit_Sum Account
 129           (Polarize.Polarized Quantity)
 130        )]
 131  |   Read_Error_virtual_transaction_not_equilibrated
 132       Amount_Styles
 133       Transaction
 134       [( Unit
 135        , Balance.Unit_Sum Account
 136           (Polarize.Polarized Quantity)
 137        )]
 138  |   Read_Error_reading_file FilePath Exception.IOException
 139  |   Read_Error_including_file FilePath [R.Error Read_Error]
 140  deriving (Show)
 141
 142 -- * Read common patterns
 143
 144 read_hspaces :: Stream s m Char => ParsecT s u m ()
 145 read_hspaces = R.skipMany R.space_horizontal
 146
 147 -- * Read 'Account'
 148
 149 read_account :: Stream s m Char => ParsecT s u m Account
 150 read_account = do
 151         R.notFollowedBy $ R.space_horizontal
 152         Account.from_List <$> do
 153         R.many1_separated read_account_section $ R.char read_account_section_sep
 154
 155 read_account_section :: Stream s m Char => ParsecT s u m Text
 156 read_account_section = do
 157         fromString <$> (R.many1 $ R.try account_name_char)
 158         where
 159                 account_name_char :: Stream s m Char => ParsecT s u m Char
 160                 account_name_char = do
 161                         c <- R.anyChar
 162                         case c of
 163                          _ | c == read_comment_prefix -> R.parserZero
 164                          _ | c == read_account_section_sep -> R.parserZero
 165                          _ | c /= '\t' && R.is_space_horizontal c -> do
 166                                 _ <- R.notFollowedBy $ R.space_horizontal
 167                                 return c <* (R.lookAhead $ R.try $
 168                                  ( R.try (R.char read_account_section_sep)
 169                                  <|> account_name_char
 170                                  ))
 171                          _ | not (Char.isSpace c) -> return c
 172                          _ -> R.parserZero
 173
 174 read_account_section_sep :: Char
 175 read_account_section_sep = ':'
 176
 177 read_comment_prefix :: Char
 178 read_comment_prefix = ';'
 179
 180 read_account_section_joker :: Stream s m Char => ParsecT s u m Account_Joker_Section
 181 read_account_section_joker = do
 182         n <- R.option Nothing $ (Just <$> read_account_section)
 183         case n of
 184          Nothing -> R.char read_account_section_sep >> return Account_Joker_Any
 185          Just n' -> return $ Account_Joker_Section n'
 186
 187 read_account_joker :: Stream s m Char => ParsecT s u m Account_Joker
 188 read_account_joker = do
 189         R.notFollowedBy $ R.space_horizontal
 190         R.many1_separated read_account_section_joker $ R.char read_account_section_sep
 191
 192 read_account_regex :: Stream s m Char => ParsecT s u m Regex
 193 read_account_regex = do
 194         re <- R.many1 $ R.satisfy (not . R.is_space_horizontal)
 195         Regex.of_StringM re
 196
 197 read_account_pattern :: Stream s m Char => ParsecT s u m Account_Pattern
 198 read_account_pattern = do
 199         R.choice_try
 200          [ Account_Pattern_Exact <$> (R.char '=' >> read_account)
 201          , Account_Pattern_Joker <$> (R.char '*' >> read_account_joker)
 202          , Account_Pattern_Regex <$> (R.option '~' (R.char '~') >> read_account_regex)
 203          ]
 204
 205 -- * Read 'Quantity'
 206
 207 read_quantity
 208  :: Stream s m Char
 209  => Char -- ^ Integral grouping separator.
 210  -> Char -- ^ Fractioning separator.
 211  -> Char -- ^ Fractional grouping separator.
 212  -> ParsecT s u m
 213  ( [String] -- integral
 214  , [String] -- fractional
 215  , Maybe Amount_Style_Fractioning -- fractioning
 216  , Maybe Amount_Style_Grouping -- grouping_integral
 217  , Maybe Amount_Style_Grouping -- grouping_fractional
 218  )
 219 read_quantity int_group_sep frac_sep frac_group_sep = do
 220         (integral, grouping_integral) <- do
 221                 h <- R.many R.digit
 222                 case h of
 223                  [] -> return ([], Nothing)
 224                  _ -> do
 225                         t <- R.many $ R.char int_group_sep >> R.many1 R.digit
 226                         let digits = h:t
 227                         return (digits, grouping_of_digits int_group_sep digits)
 228         (fractional, fractioning, grouping_fractional) <-
 229                 (case integral of
 230                  [] -> id
 231                  _ -> R.option ([], Nothing, Nothing)) $ do
 232                         fractioning <- R.char frac_sep
 233                         h <- R.many R.digit
 234                         t <- R.many $ R.char frac_group_sep >> R.many1 R.digit
 235                         let digits = h:t
 236                         return (digits, Just fractioning
 237                          , grouping_of_digits frac_group_sep $ List.reverse digits)
 238         return $
 239          ( integral
 240          , fractional
 241          , fractioning
 242          , grouping_integral
 243          , grouping_fractional
 244          )
 245         where
 246                 grouping_of_digits :: Char -> [String] -> Maybe Amount_Style_Grouping
 247                 grouping_of_digits group_sep digits =
 248                         case digits of
 249                          []  -> Nothing
 250                          [_] -> Nothing
 251                          _   -> Just $
 252                                 Amount_Style_Grouping group_sep $
 253                                 canonicalize_grouping $
 254                                 List.map List.length $ digits
 255                 canonicalize_grouping :: [Int] -> [Int]
 256                 canonicalize_grouping groups =
 257                         List.foldl' -- NOTE: remove duplicates at beginning and reverse.
 258                          (\acc l0 -> case acc of
 259                                  l1:_ -> if l0 == l1 then acc else l0:acc
 260                                  _ -> l0:acc) [] $
 261                         case groups of -- NOTE: keep only longer at beginning.
 262                          l0:l1:t -> if l0 > l1 then groups else l1:t
 263                          _ -> groups
 264
 265 -- * Read 'Unit'
 266
 267 read_unit :: Stream s m Char => ParsecT s u m Unit
 268 read_unit =
 269         (quoted <|> unquoted) <?> "unit"
 270         where
 271                 unquoted :: Stream s m Char => ParsecT s u m Unit
 272                 unquoted =
 273                         fromString <$> do
 274                         R.many1 $
 275                                 R.satisfy $ \c ->
 276                                         case Char.generalCategory c of
 277                                          Char.CurrencySymbol  -> True
 278                                          Char.LowercaseLetter -> True
 279                                          Char.ModifierLetter  -> True
 280                                          Char.OtherLetter     -> True
 281                                          Char.TitlecaseLetter -> True
 282                                          Char.UppercaseLetter -> True
 283                                          _ -> False
 284                 quoted :: Stream s m Char => ParsecT s u m Unit
 285                 quoted =
 286                         fromString <$> do
 287                         R.between (R.char '"') (R.char '"') $
 288                                 R.many1 $
 289                                         R.noneOf ";\n\""
 290
 291 -- * Read 'Amount'
 292
 293 read_amount
 294  :: Stream s m Char
 295  => ParsecT s u m (Amount_Styled Amount)
 296 read_amount = do
 297         left_signing <- read_sign
 298         left_unit <-
 299                 R.option Nothing $ do
 300                         u <- read_unit
 301                         s <- R.many $ R.space_horizontal
 302                         return $ Just $ (u, not $ List.null s)
 303         (qty, style) <- do
 304                 signing <- read_sign
 305                 (  amount_style_integral
 306                  , amount_style_fractional
 307                  , amount_style_fractioning
 308                  , amount_style_grouping_integral
 309                  , amount_style_grouping_fractional
 310                  ) <-
 311                         R.choice_try
 312                          [ read_quantity '_' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
 313                          , read_quantity '_' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
 314                          , read_quantity ',' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
 315                          , read_quantity '.' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
 316                          ] <?> "quantity"
 317                 let int  = List.concat amount_style_integral
 318                 let frac = List.concat amount_style_fractional
 319                 let precision = List.length frac
 320                 guard (precision <= 255)
 321                 let mantissa = R.integer_of_digits 10 $ int `mappend` frac
 322                 return $
 323                  ( Data.Decimal.Decimal
 324                          (fromIntegral precision)
 325                          (signing mantissa)
 326                  , mempty
 327                          { amount_style_fractioning
 328                          , amount_style_grouping_integral
 329                          , amount_style_grouping_fractional
 330                          }
 331                  )
 332         (  amount_unit
 333          , amount_style_unit_side
 334          , amount_style_unit_spaced ) <-
 335                 case left_unit of
 336                  Just (u, s) ->
 337                         return (u, Just Amount_Style_Side_Left, Just s)
 338                  Nothing ->
 339                         R.option (Unit.unit_empty, Nothing, Nothing) $ R.try $ do
 340                                 s <- R.many R.space_horizontal
 341                                 u <- read_unit
 342                                 return $
 343                                  ( u
 344                                  , Just Amount_Style_Side_Right
 345                                  , Just $ not $ List.null s )
 346         return $
 347                 ( style
 348                  { amount_style_unit_side
 349                  , amount_style_unit_spaced
 350                  }
 351                 , Amount
 352                  { amount_quantity = left_signing qty
 353                  , amount_unit
 354                  }
 355                 )
 356
 357 -- | Parse either '-' into 'negate', or '+' or '' into 'id'.
 358 read_sign :: (Stream s m Char, Num i) => ParsecT s u m (i -> i)
 359 read_sign =
 360             (R.char '-' >> return negate)
 361         <|> (R.char '+' >> return id)
 362         <|> return id
 363
 364 -- * Read 'Date'
 365
 366 type Date_Error = Filter.Date.Read.Error
 367
 368 -- | Read a 'Date' in @[YYYY[/-]]MM[/-]DD[_HH:MM[:SS][TZ]]@ format.
 369 read_date
 370  :: (Stream s (R.Error_State e m) Char, Monad m)
 371  => (Date_Error -> e) -> Maybe Integer
 372  -> ParsecT s u (R.Error_State e m) Date
 373 read_date err def_year = (do
 374         let read_2_or_1_digits = R.try (R.count 2 R.digit) <|> R.count 1 R.digit
 375         n0 <- R.many1 R.digit
 376         day_sep <- R.char read_date_ymd_sep
 377         n1 <- read_2_or_1_digits
 378         n2 <- R.option Nothing $ R.try $ do
 379                 _ <- R.char day_sep
 380                 Just <$> read_2_or_1_digits
 381         (year, m, d) <-
 382                 case (n2, def_year) of
 383                  (Nothing, Nothing) -> R.fail_with "date" (err $ Error_year_or_day_is_missing)
 384                  (Nothing, Just year) -> return (year, n0, n1)
 385                  (Just d, _)  -> return (R.integer_of_digits 10 n0, n1, d)
 386         let month = fromInteger $ R.integer_of_digits 10 m
 387         let dom   = fromInteger $ R.integer_of_digits 10 d
 388         day <- case Time.fromGregorianValid year month dom of
 389          Nothing  -> R.fail_with "date" (err $ Error_invalid_date (year, month, dom))
 390          Just day -> return day
 391         (hour, minu, sec, tz) <-
 392                 R.option (0, 0, 0, Time.utc) $ R.try $ do
 393                         _ <- R.char '_'
 394                         hour <- read_2_or_1_digits
 395                         sep <- R.char read_hour_separator
 396                         minu <- read_2_or_1_digits
 397                         sec <- R.option Nothing $ R.try $ do
 398                                 _ <- R.char sep
 399                                 Just <$> read_2_or_1_digits
 400                         tz <- R.option Time.utc $ R.try $
 401                                 read_time_zone
 402                         return
 403                          ( fromInteger $ R.integer_of_digits 10 hour
 404                          , fromInteger $ R.integer_of_digits 10 minu
 405                          , maybe 0      (R.integer_of_digits 10) sec
 406                          , tz )
 407         tod <- case Time.makeTimeOfDayValid hour minu (fromInteger sec) of
 408          Nothing  -> R.fail_with "date" (err $ Error_invalid_time_of_day (hour, minu, sec))
 409          Just tod -> return tod
 410         return $ Time.localTimeToUTC tz (Time.LocalTime day tod)
 411         ) <?> "date"
 412
 413 -- | Separator for year, month and day: "-".
 414 read_date_ymd_sep :: Char
 415 read_date_ymd_sep = '-'
 416
 417 -- | Separator for hour, minute and second: ":".
 418 read_hour_separator :: Char
 419 read_hour_separator = ':'
 420
 421 read_time_zone :: Stream s m Char => ParsecT s u m TimeZone
 422 read_time_zone = Filter.Date.Read.time_zone
 423
 424 read_time_zone_digits :: Stream s m Char => ParsecT s u m TimeZone
 425 read_time_zone_digits = Filter.Date.Read.time_zone_digits
 426
 427 -- * Read 'Comment'
 428
 429 read_comment
 430  :: Stream s m Char
 431  => ParsecT s u m Comment
 432 read_comment = (do
 433         _ <- R.char read_comment_prefix
 434         fromString <$> do
 435         R.manyTill R.anyChar (R.lookAhead (R.try R.new_line <|> R.eof))
 436         ) <?> "comment"
 437
 438 -- ** Read 'Comment's
 439
 440 read_comments
 441  :: Stream s m Char
 442  => ParsecT s u m [Comment]
 443 read_comments = (do
 444         R.try $ do
 445                 _ <- R.spaces
 446                 R.many1_separated read_comment
 447                  (R.new_line >> read_hspaces)
 448         <|> return []
 449         ) <?> "comments"
 450
 451 -- * Read 'Tag'
 452
 453 read_tag_value_sep :: Char
 454 read_tag_value_sep = ':'
 455
 456 read_tag_sep :: Char
 457 read_tag_sep = ','
 458
 459 read_tag_path_section_char
 460  :: Stream s m Char
 461  => ParsecT s u m Char
 462 read_tag_path_section_char =
 463         R.satisfy (\c -> c /= read_tag_value_sep
 464          && c /= read_tag_sep
 465          && not (Char.isSpace c))
 466
 467 read_tag :: Stream s m Char => ParsecT s u m Tag
 468 read_tag = ((,) <$> read_tag_path <*> read_tag_value) <?> "tag"
 469
 470 read_tag_path :: Stream s m Char => ParsecT s u m Tag.Path
 471 read_tag_path = do
 472         NonEmpty.fromList <$> do
 473         R.many1 $ R.try read_tag_path_section
 474
 475 read_tag_path_section :: Stream s m Char => ParsecT s u m Tag.Section
 476 read_tag_path_section = do
 477         fromString <$> do
 478                 ((R.many1 $ read_tag_path_section_char) <* R.char read_tag_value_sep)
 479
 480 read_tag_value :: Stream s m Char => ParsecT s u m Tag.Value
 481 read_tag_value = do
 482         fromString <$> do
 483         R.manyTill R.anyChar $ do
 484                 R.lookAhead $ do
 485                         R.try (R.char read_tag_sep
 486                          >> R.many R.space_horizontal
 487                          >> void read_tag_path_section)
 488                         <|> R.try (void (R.try R.new_line))
 489                         <|> R.eof
 490
 491 -- ** Read 'Tag's
 492
 493 read_tags
 494  :: Stream s m Char
 495  => ParsecT s u m (Map Tag.Path [Tag.Value])
 496 read_tags = do
 497         Map.fromListWith (flip mappend)
 498         . List.map (\(p, v) -> (p, [v])) <$> do
 499                 R.many_separated read_tag $ do
 500                         _ <- R.char read_tag_sep
 501                         read_hspaces
 502
 503 read_not_tag :: Stream s m Char => ParsecT s u m [Char]
 504 read_not_tag = do
 505         R.many $ R.try $ do
 506                 R.skipMany $
 507                         R.satisfy (\c -> c /= read_tag_value_sep && not (Char.isSpace c))
 508                 R.space_horizontal
 509
 510 -- * Read 'Posting'
 511
 512 read_posting ::
 513  ( Consable c j
 514  , Monad m
 515  , Stream s (R.Error_State Read_Error m) Char
 516  ) => ParsecT s (Read_Context c j)
 517                 (R.Error_State Read_Error m)
 518                 (Posting_Typed Posting)
 519 read_posting = (do
 520         posting_sourcepos <- R.getPosition
 521         R.skipMany1 $ R.space_horizontal
 522         posting_status <- read_status
 523         read_hspaces
 524         acct <- read_account
 525         let Posting_Typed type_ posting_account = read_posting_type acct
 526         posting_amounts <-
 527                 R.choice_try
 528                  [ do
 529                         (void R.tab <|> void (R.count 2 R.space_horizontal))
 530                         read_hspaces
 531                         amts <-
 532                                 R.many_separated read_amount $ do
 533                                         read_hspaces
 534                                         _ <- R.char read_amount_sep
 535                                         read_hspaces
 536                         ctx <- flip liftM R.getState $ \ctx ->
 537                                 ctx
 538                                  { read_context_journal=
 539                                         let jnl = read_context_journal ctx in
 540                                         jnl
 541                                          { journal_amount_styles =
 542                                                 List.foldl'
 543                                                  (\(Amount_Styles styles) (style, amt) ->
 544                                                         Amount_Styles $
 545                                                         Map.insertWith (flip mappend) -- NOTE: prefer first style
 546                                                          (Amount.amount_unit amt)
 547                                                          style styles)
 548                                                  (journal_amount_styles jnl)
 549                                                  amts
 550                                          }
 551                                  }
 552                         R.setState ctx
 553                         return $
 554                                 Map.fromListWith Quantity.quantity_add $
 555                                 List.map
 556                                  (\(_sty, amt) ->
 557                                         let unit = Amount.amount_unit amt in
 558                                         ( if unit == Unit.unit_empty
 559                                                 then maybe unit id (read_context_unit ctx)
 560                                                 else unit
 561                                         , Amount.amount_quantity amt
 562                                         )
 563                                  )
 564                                  amts
 565                  , return mempty
 566                  ] <?> "amounts"
 567         read_hspaces
 568         -- TODO: balance assertion
 569         -- TODO: conversion
 570         posting_comments <- read_comments
 571         let posting_tags@(Tags tags_) =
 572                 tags_of_comments posting_comments
 573         posting_dates <- do
 574                 ctx <- R.getState
 575                 case Map.lookup ("date":|[]) tags_ of
 576                  Nothing -> return []
 577                  Just dates -> do
 578                         let date2s = Map.lookup ("date2":|[]) tags_ -- NOTE: support hledger's date2
 579                         do
 580                         forM (dates `mappend` fromMaybe [] date2s) $ \s ->
 581                                 R.runParserT_with_Error_fail "tag date" id
 582                                  (read_date Read_Error_date (Just $ read_context_year ctx) <* R.eof) ()
 583                                  (Text.unpack s) s
 584                         >>= \dates_ -> case (dates, date2s) of -- NOTE: put hledger's date2 at least in second position
 585                          ([], Just (_:_)) ->
 586                                 return $ read_context_date ctx:dates_
 587                          _ -> return $ dates_
 588         return $ Posting_Typed type_ Posting
 589          { posting_account
 590          , posting_amounts
 591          , posting_comments
 592          , posting_dates
 593          , posting_sourcepos
 594          , posting_status
 595          , posting_tags = Posting_Tags posting_tags
 596          }
 597         ) <?> "posting"
 598
 599 read_amount_sep :: Char
 600 read_amount_sep = '+'
 601
 602 tags_of_comments :: [Comment] -> Tags
 603 tags_of_comments =
 604         Tags .
 605         Map.unionsWith mappend
 606         . List.map
 607          ( Data.Either.either (const Map.empty) id
 608          . R.runParser (read_not_tag >> read_tags <* R.eof) () "" )
 609
 610 comments_without_tags :: [Comment] -> [Comment]
 611 comments_without_tags =
 612         List.map
 613          (\c ->
 614                 Data.Either.either (const c) Text.pack $
 615                 R.runParser
 616                  (read_not_tag <* read_tags <* R.eof)
 617                  () "" c
 618          )
 619
 620 read_status :: Stream s m Char => ParsecT s u m Status
 621 read_status = (do
 622         ( R.try $ do
 623                 read_hspaces
 624                 _ <- (R.char '*' <|> R.char '!')
 625                 return True )
 626         <|> return False
 627         ) <?> "status"
 628
 629 -- | Return the 'Posting_Type' and stripped 'Account' of the given 'Account'.
 630 read_posting_type :: Account -> (Posting_Typed Account)
 631 read_posting_type acct =
 632         fromMaybe (Posting_Typed Posting_Type_Regular acct) $ do
 633                 case acct of
 634                  name:|[] ->
 635                         case Text.stripPrefix virtual_begin name of
 636                          Just name' -> do
 637                                 name'' <- liftM Text.strip $ Text.stripSuffix virtual_end name'
 638                                 guard $ not $ Text.null name''
 639                                 Just $ Posting_Typed Posting_Type_Virtual $ name'':|[]
 640                          Nothing -> do
 641                                 name' <- liftM Text.strip $
 642                                             Text.stripPrefix virtual_balanced_begin name
 643                                         >>= Text.stripSuffix virtual_balanced_end
 644                                 guard $ not $ Text.null name'
 645                                 Just $ Posting_Typed Posting_Type_Virtual_Balanced $ name':|[]
 646                  first_name:|acct' -> do
 647                         let rev_acct' = List.reverse acct'
 648                         let last_name = List.head rev_acct'
 649                         case liftM Text.stripStart $
 650                                 Text.stripPrefix virtual_begin first_name of
 651                          Just first_name' -> do
 652                                 last_name' <- liftM Text.stripEnd $
 653                                         Text.stripSuffix virtual_end last_name
 654                                 guard $ not $ Text.null first_name'
 655                                 guard $ not $ Text.null last_name'
 656                                 Just $ Posting_Typed
 657                                         Posting_Type_Virtual $
 658                                         first_name':| List.reverse (last_name':List.tail rev_acct')
 659                          Nothing -> do
 660                                 first_name' <- liftM Text.stripStart $
 661                                         Text.stripPrefix virtual_balanced_begin first_name
 662                                 last_name'  <- liftM Text.stripEnd $
 663                                         Text.stripSuffix virtual_balanced_end last_name
 664                                 guard $ not $ Text.null first_name'
 665                                 guard $ not $ Text.null last_name'
 666                                 Just $ Posting_Typed
 667                                         Posting_Type_Virtual_Balanced $
 668                                         first_name':|List.reverse (last_name':List.tail rev_acct')
 669         where
 670                 virtual_begin          = Text.singleton read_posting_type_virtual_begin
 671                 virtual_end            = Text.singleton read_posting_type_virtual_end
 672                 virtual_balanced_begin = Text.singleton read_posting_type_virtual_balanced_begin
 673                 virtual_balanced_end   = Text.singleton read_posting_type_virtual_balanced_end
 674
 675 read_posting_type_virtual_begin :: Char
 676 read_posting_type_virtual_begin = '('
 677 read_posting_type_virtual_balanced_begin :: Char
 678 read_posting_type_virtual_balanced_begin = '['
 679 read_posting_type_virtual_end :: Char
 680 read_posting_type_virtual_end = ')'
 681 read_posting_type_virtual_balanced_end :: Char
 682 read_posting_type_virtual_balanced_end = ']'
 683
 684 -- * Read 'Transaction'
 685
 686 read_transaction ::
 687  ( Consable c j
 688  , Monad m
 689  , Stream s (R.Error_State Read_Error m) Char
 690  ) => ParsecT s (Read_Context c j)
 691               (R.Error_State Read_Error m)
 692               Transaction
 693 read_transaction = (do
 694         ctx <- R.getState
 695         transaction_sourcepos <- R.getPosition
 696         transaction_comments_before <-
 697                 read_comments
 698                 >>= \x -> case x of
 699                  [] -> return []
 700                  _  -> return x <* R.new_line
 701         date_ <- read_date Read_Error_date (Just $ read_context_year ctx)
 702         dates_ <-
 703                 R.option [] $ R.try $ do
 704                         read_hspaces
 705                         _ <- R.char read_transaction_date_sep
 706                         read_hspaces
 707                         R.many_separated
 708                          (read_date Read_Error_date (Just $ read_context_year ctx)) $
 709                                 R.try $ do
 710                                         R.many $ R.space_horizontal
 711                                         >> R.char read_transaction_date_sep
 712                                         >> (R.many $ R.space_horizontal)
 713         let transaction_dates = (date_, dates_)
 714         read_hspaces
 715         transaction_status <- read_status
 716         transaction_code <- R.option "" $ R.try read_code
 717         read_hspaces
 718         transaction_wording <- read_wording
 719         read_hspaces
 720         transaction_comments_after <- read_comments
 721         let transaction_tags =
 722                 Transaction_Tags $
 723                 mappend
 724                  (tags_of_comments transaction_comments_before)
 725                  (tags_of_comments transaction_comments_after)
 726         R.new_line
 727         (postings_unchecked, postings_not_regular) <-
 728                 first (postings_by_account . List.map
 729                  (\(Posting_Typed _ p) -> p)) .
 730                 List.partition (\(Posting_Typed pt _) ->
 731                         Posting_Type_Regular == pt) <$>
 732                 R.many1_separated read_posting R.new_line
 733         let (transaction_virtual_postings, balanced_virtual_postings_unchecked) =
 734                 join (***) (postings_by_account . List.map
 735                  (\(Posting_Typed _ p) -> p)) $
 736                 List.partition (\(Posting_Typed pt _) ->
 737                         Posting_Type_Virtual == pt)
 738                  postings_not_regular
 739         let tr_unchecked =
 740                 Transaction
 741                  { transaction_code
 742                  , transaction_comments_before
 743                  , transaction_comments_after
 744                  , transaction_dates
 745                  , transaction_wording
 746                  , transaction_postings=postings_unchecked
 747                  , transaction_sourcepos
 748                  , transaction_status
 749                  , transaction_tags
 750                  }
 751         let styles = journal_amount_styles $ read_context_journal ctx
 752         transaction_postings <-
 753                 case Balance.infer_equilibrium postings_unchecked of
 754                  (_, Left ko) -> R.fail_with "transaction infer_equilibrium" $
 755                         Read_Error_transaction_not_equilibrated styles tr_unchecked ko
 756                  (_bal, Right ok) -> return ok
 757         transaction_balanced_virtual_postings <-
 758                 case Balance.infer_equilibrium balanced_virtual_postings_unchecked of
 759                  (_, Left ko) -> R.fail_with "transaction infer_equilibrium" $
 760                         Read_Error_virtual_transaction_not_equilibrated styles tr_unchecked ko
 761                  (_bal, Right ok) -> return ok
 762         return $
 763                 tr_unchecked
 764                  { transaction_postings =
 765                         Map.unionsWith mappend
 766                          [ transaction_postings
 767                          , fmap (fmap set_virtual_tag) transaction_virtual_postings
 768                          , fmap (fmap set_virtual_tag) transaction_balanced_virtual_postings
 769                          ]
 770                  }
 771         ) <?> "transaction"
 772         where
 773                 set_virtual_tag :: Posting -> Posting
 774                 set_virtual_tag
 775                  p@Posting{posting_tags=Posting_Tags (Tags attrs)} =
 776                         p{posting_tags = Posting_Tags $ Tags $ Map.insert ("Virtual":|[]) [] attrs}
 777
 778 read_transaction_date_sep :: Char
 779 read_transaction_date_sep = '='
 780
 781 read_code
 782  :: ( Consable c j
 783     , Stream s m Char )
 784  => ParsecT s (Read_Context c j) m Code
 785 read_code = (do
 786         fromString <$> do
 787         read_hspaces
 788         R.between (R.char '(') (R.char ')') $
 789                 R.many $ R.satisfy (\c -> c /= ')' && not (R.is_space_horizontal c))
 790         ) <?> "code"
 791
 792 read_wording
 793  :: Stream s m Char
 794  => ParsecT s u m Wording
 795 read_wording = (do
 796         fromString <$> do
 797         R.many $ R.try read_wording_char
 798         ) <?> "wording"
 799         where
 800                 read_wording_char :: Stream s m Char => ParsecT s u m Char
 801                 read_wording_char = do
 802                         c <- R.anyChar
 803                         case c of
 804                          _ | c == read_comment_prefix -> R.parserZero
 805                          _ | R.is_space_horizontal c -> return c <* (R.lookAhead $ R.try $ read_wording_char)
 806                          _ | not (Char.isSpace c) -> return c
 807                          _ -> R.parserZero
 808
 809 -- * Read directives
 810
 811 read_directive_alias
 812  :: (Consable c j, Stream s m Char)
 813  => ParsecT s (Read_Context c j) m ()
 814 read_directive_alias = do
 815         _ <- R.string "alias"
 816         R.skipMany1 $ R.space_horizontal
 817         pattern <- read_account_pattern
 818         read_hspaces
 819         _ <- R.char '='
 820         read_hspaces
 821         repl <- read_account
 822         read_hspaces
 823         case pattern of
 824          Account_Pattern_Exact acct ->
 825                 R.modifyState $ \ctx -> ctx{read_context_aliases_exact=
 826                         Map.insert acct repl $ read_context_aliases_exact ctx}
 827          Account_Pattern_Joker jokr ->
 828                 R.modifyState $ \ctx -> ctx{read_context_aliases_joker=
 829                         (jokr, repl):read_context_aliases_joker ctx}
 830          Account_Pattern_Regex regx ->
 831                 R.modifyState $ \ctx -> ctx{read_context_aliases_regex=
 832                         (regx, repl):read_context_aliases_regex ctx}
 833         return ()
 834
 835 read_default_year
 836  :: (Consable c j, Stream s m Char)
 837  => ParsecT s (Read_Context c j) m ()
 838 read_default_year = (do
 839         year <- R.integer_of_digits 10 <$> R.many1 R.digit
 840         read_hspaces
 841         read_context_ <- R.getState
 842         R.setState read_context_{read_context_year=year}
 843         ) <?> "default year"
 844
 845 read_default_unit_and_style
 846  :: ( Consable c j
 847     , Stream s m Char )
 848  => ParsecT s (Read_Context c j) m ()
 849 read_default_unit_and_style = (do
 850         (sty, amt) <- read_amount
 851         read_hspaces
 852         ctx <- R.getState
 853         let unit = Amount.amount_unit amt
 854         R.setState ctx
 855          { read_context_journal =
 856                 let jnl = read_context_journal ctx in
 857                 jnl
 858                  { journal_amount_styles =
 859                         let Amount_Styles styles =
 860                                 journal_amount_styles jnl in
 861                         Amount_Styles $
 862                         Map.insertWith const unit sty styles
 863                  }
 864          , read_context_unit = Just unit
 865          }
 866         ) <?> "default unit and style"
 867
 868 read_include ::
 869  ( Consable c j
 870  , Monoid j
 871  , Stream s (R.Error_State Read_Error IO) Char
 872  ) => ParsecT s (Read_Context c j) (R.Error_State Read_Error IO) ()
 873 read_include = (do
 874         sourcepos <- R.getPosition
 875         filename <- R.manyTill R.anyChar (R.lookAhead (R.try R.new_line <|> R.eof))
 876         read_context_including <- R.getState
 877         let journal_including = read_context_journal read_context_including
 878         let cwd = Path.takeDirectory (R.sourceName sourcepos)
 879         journal_file <- liftIO $ Path.abs cwd filename
 880         content <- do
 881                 join $ liftIO $ Exception.catch
 882                  (liftM return $ Text.IO.readFile journal_file)
 883                  (return . R.fail_with "include reading" . Read_Error_reading_file journal_file)
 884         (journal_included, read_context_included) <- do
 885                 liftIO $
 886                         R.runParserT_with_Error
 887                          (R.and_state $ read_journal_rec journal_file)
 888                          read_context_including
 889                                  { read_context_journal=
 890                                         journal
 891                                          { journal_chart         = journal_chart         journal_including
 892                                          , journal_amount_styles = journal_amount_styles journal_including
 893                                          }
 894                                  }
 895                          journal_file content
 896                 >>= \x -> case x of
 897                  Right ok -> return ok
 898                  Left  ko -> R.fail_with "include parsing" (Read_Error_including_file journal_file ko)
 899         R.setState $
 900                 read_context_included
 901                  { read_context_journal=
 902                         journal_including
 903                          { journal_includes=
 904                                 journal_included{journal_files=[journal_file]} :
 905                                 journal_includes journal_including
 906                          , journal_chart=
 907                                 journal_chart journal_included
 908                          , journal_amount_styles=
 909                                 journal_amount_styles journal_included
 910                          }
 911                  }
 912         ) <?> "include"
 913
 914 -- * Read 'Chart'
 915
 916 read_chart ::
 917  ( Consable c j
 918  , Stream s (R.Error_State Read_Error IO) Char
 919  ) => ParsecT s (Read_Context c j) (R.Error_State Read_Error IO) ()
 920 read_chart = (do
 921         -- sourcepos <- R.getPosition
 922         acct <- read_account
 923         read_hspaces
 924         _ <- read_comments
 925         R.new_line
 926         tags_ <- R.many_separated
 927          (R.try (R.skipMany1 R.space_horizontal >> read_tag
 928          <* read_hspaces <* read_comments))
 929          R.new_line
 930         R.skipMany R.space
 931         let chart_accounts =
 932                 TreeMap.singleton acct $
 933                 Account_Tags $
 934                 Tag.from_List tags_
 935         {-
 936         let chart_tags =
 937                 foldl'
 938                  (flip (\(p:|ps, v) ->
 939                         TreeMap.insert mappend
 940                          (p:|ps `mappend` [v])
 941                          [acct]))
 942                  mempty
 943                  tags_
 944         -}
 945         ctx <- R.getState
 946         let j = read_context_journal ctx
 947         R.setState $
 948                 ctx{read_context_journal=
 949                         j{journal_chart=
 950                                 mappend
 951                                  (journal_chart j)
 952                                  Chart.Chart
 953                                          { Chart.chart_accounts
 954                                          , Chart.chart_anchors = mempty
 955                                          -- , Chart.chart_tags
 956                                          }
 957                          }
 958                  }
 959         ) <?> "chart"
 960
 961 -- * Read 'Journal'
 962
 963 read_journal ::
 964  ( Consable c j
 965  , Monoid j
 966  , Stream s (R.Error_State Read_Error IO) Char
 967  ) => FilePath
 968  -> ParsecT s (Read_Context c j)
 969               (R.Error_State Read_Error IO)
 970               (Journal j)
 971 read_journal filepath = (do
 972         currentLocalTime <- liftIO $
 973                 Time.utcToLocalTime
 974                 <$> Time.getCurrentTimeZone
 975                 <*> Time.getCurrentTime
 976         let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
 977         ctx <- R.getState
 978         R.setState $ ctx{read_context_year=currentLocalYear}
 979         read_journal_rec filepath
 980         ) <?> "journal"
 981
 982 read_journal_rec ::
 983  ( Consable c j
 984  , Monoid j
 985  , Stream s (R.Error_State Read_Error IO) Char
 986  )
 987  => FilePath
 988  -> ParsecT s (Read_Context c j)
 989               (R.Error_State Read_Error IO)
 990               (Journal j)
 991 read_journal_rec journal_file = do
 992         last_read_time <- liftIO Date.now
 993         loop $
 994                 R.choice_try
 995                  [ jump_comment
 996                  , jump_directive
 997                  , jump_transaction
 998                  , jump_chart
 999                  ]
1000         journal_ <- read_context_journal <$> R.getState
1001         return $
1002                 journal_
1003                  { journal_files = [journal_file]
1004                  , journal_includes = List.reverse $ journal_includes journal_
1005                  , journal_last_read_time = last_read_time
1006                  }
1007         where
1008                 loop
1009                  :: Stream s m Char
1010                  => ParsecT s u m (ParsecT s u m ())
1011                  -> ParsecT s u m ()
1012                 loop r = do
1013                         R.skipMany (read_hspaces >> R.new_line)
1014                         _ <- join r
1015                         R.skipMany (read_hspaces >> R.new_line)
1016                         R.try (read_hspaces >> R.eof) <|> loop r
1017                 jump_comment ::
1018                  ( Consable c j
1019                  , Stream s m Char
1020                  , u ~ Read_Context c j
1021                  , m ~ R.Error_State Read_Error IO
1022                  )
1023                  => ParsecT s u m (ParsecT s u m ())
1024                 jump_comment = do
1025                         _ <- R.spaces
1026                         _ <- R.lookAhead (R.try $ R.char read_comment_prefix)
1027                         return $ do
1028                                 _cmts <- read_comments
1029                                 {-
1030                                 R.modifyState $ \ctx ->
1031                                         let j = read_context_journal ctx in
1032                                         ctx{read_context_journal=
1033                                                 j{journal_content=
1034                                                         mcons (read_context_filter ctx) cmts $
1035                                                                 journal_content j}}
1036                                 -}
1037                                 return ()
1038                 jump_directive ::
1039                  ( Consable c j
1040                  , Monoid j
1041                  , Stream s m Char
1042                  , u ~ Read_Context c j
1043                  , m ~ R.Error_State Read_Error IO
1044                  )
1045                  => ParsecT s u m (ParsecT s u m ())
1046                 jump_directive = do
1047                         let choice s = R.string s >> R.skipMany1 R.space_horizontal
1048                         R.choice_try
1049                          [ choice "Y"        >> return read_default_year
1050                          , choice "D"        >> return read_default_unit_and_style
1051                          , choice "!include" >> return read_include
1052                          ] <?> "directive"
1053                 jump_transaction ::
1054                  ( Consable c j
1055                  , Stream s m Char
1056                  , u ~ Read_Context c j
1057                  , m ~ R.Error_State Read_Error IO
1058                  )
1059                  => ParsecT s u m (ParsecT s u m ())
1060                 jump_transaction = do
1061                         _ <- R.lookAhead $ R.try (R.many1 R.digit >> R.char read_date_ymd_sep)
1062                         return $ do
1063                                 t <- read_transaction
1064                                 R.modifyState $ \ctx ->
1065                                         let j = read_context_journal ctx in
1066                                         ctx{read_context_journal=
1067                                                 j{journal_content=
1068                                                         mcons
1069                                                          (read_context_cons ctx $
1070                                                                 Chart.Charted (journal_chart j) t)
1071                                                          (journal_content j)}}
1072                 jump_chart ::
1073                  ( Consable c j
1074                  , Stream s m Char
1075                  , u ~ Read_Context c j
1076                  , m ~ R.Error_State Read_Error IO
1077                  )
1078                  => ParsecT s u m (ParsecT s u m ())
1079                 jump_chart = do
1080                         return read_chart
1081
1082 -- * Read
1083
1084 read
1085  :: (Consable c j, Monoid j)
1086  => Read_Context c j
1087  -> FilePath
1088  -> ExceptT [R.Error Read_Error] IO (Journal j)
1089 read ctx path = do
1090         ExceptT $
1091                 Exception.catch
1092                  (liftM Right $ Text.IO.readFile path) $
1093                  \ko -> return $ Left $
1094                          [R.Error_Custom (R.initialPos path) $
1095                                 Read_Error_reading_file path ko]
1096         >>= liftIO . R.runParserT_with_Error
1097          (read_journal path) ctx path
1098         >>= \x -> case x of
1099          Left  ko -> throwE $ ko
1100          Right ok -> ExceptT $ return $ Right ok