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