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