lib/Hcompta/Format/Ledger/Read.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE LambdaCase #-}
   4 {-# LANGUAGE NamedFieldPuns #-}
   5 {-# LANGUAGE OverloadedStrings #-}
   6 {-# LANGUAGE ScopedTypeVariables #-}
   7 {-# LANGUAGE TupleSections #-}
   8 module Hcompta.Format.Ledger.Read where
   9
  10 import           Control.Applicative ((<$>), (<*>), (<*))
  11 import qualified Control.Exception as Exception
  12 import           Control.Arrow ((***))
  13 import           Control.Monad (guard, join, liftM, (>=>))
  14 import           Control.Monad.IO.Class (liftIO)
  15 import           Control.Monad.Trans.Except (ExceptT(..), throwE)
  16 import qualified Data.Char
  17 import qualified Data.Decimal
  18 import qualified Data.Either
  19 import qualified Data.List
  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 (pack)
  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 :: !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 = []
  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         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                         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                                 >=> \case
 562                                  Left err -> fail $ show err
 563                                  Right x -> return x
 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                 >>= \case
 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         >>= \case
 810          Left  ko -> throwE $ show ko
 811          Right ok -> ExceptT $ return $ Right ok