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