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