lib/Hcompta/Format/Ledger/Read.hs

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