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.many1_separated comment (R.new_line >> R.skipMany R.space_horizontal)
 470         <|> return []
 471         ) <?> "comments"
 472
 473 -- * Parsing 'Tag'
 474
 475 tag_value_sep :: Char
 476 tag_value_sep = ':'
 477
 478 tag_sep :: Char
 479 tag_sep = ','
 480
 481 -- | Parse a 'Tag'.
 482 tag :: Stream s m Char => ParsecT s u m Tag
 483 tag = (do
 484         n <- tag_name
 485         _ <- R.char tag_value_sep
 486         v <- tag_value
 487         return (n, v)
 488         ) <?> "tag"
 489
 490 tag_name :: Stream s m Char => ParsecT s u m Tag.Name
 491 tag_name = do
 492         Text.pack <$> do
 493         R.many1 $ R.satisfy (\c -> c /= tag_value_sep && not (Data.Char.isSpace c))
 494
 495 tag_value :: Stream s m Char => ParsecT s u m Tag.Value
 496 tag_value = do
 497         Text.pack <$> do
 498         R.manyTill R.anyChar $ do
 499                 R.lookAhead $ do
 500                         R.try (R.char tag_sep >> R.many R.space_horizontal >> tag_name >> R.char tag_value_sep >> return ())
 501                         <|> R.try R.new_line
 502                         <|> R.eof
 503
 504 tags :: Stream s m Char => ParsecT s u m Tag.By_Name
 505 tags = do
 506         Tag.from_List <$> do
 507                 R.many_separated tag $ do
 508                         _ <- R.char tag_sep
 509                         R.skipMany $ R.space_horizontal
 510                         return ()
 511
 512 not_tag :: Stream s m Char => ParsecT s u m ()
 513 not_tag = do
 514         R.skipMany $ R.try $ do
 515                 R.skipMany $ R.satisfy
 516                  (\c -> c /= tag_value_sep
 517                          && not (Data.Char.isSpace c))
 518                 R.space_horizontal
 519
 520 -- * Parsing 'Posting'
 521
 522 -- | Parse a 'Posting'.
 523 posting :: Stream s m Char => ParsecT s Context m (Posting, Posting.Type)
 524 posting = (do
 525         ctx <- R.getState
 526         sourcepos <- R.getPosition
 527         comments_ <- comments
 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_ ++) <$> 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 <- comments
 675         date_ <- date (Just $ context_year ctx)
 676         dates_ <-
 677                 R.option [] $ R.try $ do
 678                         R.skipMany $ R.space_horizontal
 679                         _ <- R.char date_sep
 680                         R.skipMany $ R.space_horizontal
 681                         R.many_separated
 682                          (date (Just $ context_year ctx)) $
 683                                 R.try $ do
 684                                         R.many $ R.space_horizontal
 685                                         >> R.char date_sep
 686                                         >> (R.many $ R.space_horizontal)
 687         R.skipMany $ R.space_horizontal
 688         status_ <- status
 689         code_ <- R.option "" $ R.try code
 690         R.skipMany $ R.space_horizontal
 691         description_ <- description
 692         R.skipMany $ R.space_horizontal
 693         comments_after <- comments
 694         let tags_ =
 695                 Data.Map.unionWith (++)
 696                  (tags_of_comments comments_before)
 697                  (tags_of_comments comments_after)
 698         R.new_line
 699         (postings_unchecked, postings_not_regular) <-
 700                 ((Posting.from_List . Data.List.map fst) *** id) .
 701                 Data.List.partition ((Posting.Type_Regular ==) . snd) <$>
 702                 R.many1_separated posting R.new_line
 703         let (virtual_postings, balanced_virtual_postings_unchecked) =
 704                 join (***) (Posting.from_List . Data.List.map fst) $
 705                 Data.List.partition ((Posting.Type_Virtual ==) . snd)
 706                  postings_not_regular
 707         postings <-
 708                 case Calc.Balance.infer_equilibre postings_unchecked of
 709                  Left _l -> fail $ "transaction not-equilibrated"
 710                  Right ps -> return ps
 711         balanced_virtual_postings <-
 712                 case Calc.Balance.infer_equilibre balanced_virtual_postings_unchecked of
 713                  Left _l -> fail $ "virtual transaction not-equilibrated"
 714                  Right ps -> return ps
 715         return $
 716                 Transaction.Transaction
 717                  { Transaction.code=code_
 718                  , Transaction.comments_before
 719                  , Transaction.comments_after
 720                  , Transaction.dates=(date_, dates_)
 721                  , Transaction.description=description_
 722                  , Transaction.postings
 723                  , Transaction.virtual_postings
 724                  , Transaction.balanced_virtual_postings
 725                  , Transaction.sourcepos
 726                  , Transaction.status=status_
 727                  , Transaction.tags=tags_
 728                  }
 729         ) <?> "transaction"
 730
 731 date_sep :: Char
 732 date_sep = '='
 733
 734 code :: Stream s m Char => ParsecT s Context m Transaction.Code
 735 code = (do
 736         Text.pack <$> do
 737         R.skipMany $ R.space_horizontal
 738         R.between (R.char '(') (R.char ')') $
 739                 R.many $ R.satisfy (\c -> c /= ')' && not (R.is_space_horizontal c))
 740         ) <?> "code"
 741
 742 description :: Stream s m Char => ParsecT s u m Transaction.Description
 743 description = (do
 744         Text.pack <$> do
 745         R.many $ R.try description_char
 746         ) <?> "description"
 747         where
 748                 description_char :: Stream s m Char => ParsecT s u m Char
 749                 description_char = do
 750                         c <- R.anyChar
 751                         case c of
 752                          _ | c == comment_begin -> R.parserZero
 753                          _ | R.is_space_horizontal c -> return c <* (R.lookAhead $ R.try $ description_char)
 754                          _ | not (Data.Char.isSpace c) -> return c
 755                          _ -> R.parserZero
 756
 757 -- * Parsing directives
 758
 759 default_year :: Stream s m Char => ParsecT s Context m ()
 760 default_year = (do
 761         year <- R.integer_of_digits 10 <$> R.many1 R.digit
 762         R.skipMany R.space_horizontal >> R.new_line
 763         context_ <- R.getState
 764         R.setState context_{context_year=year}
 765         ) <?> "default year"
 766
 767 default_unit_and_style :: Stream s m Char => ParsecT s Context m ()
 768 default_unit_and_style = (do
 769         amount_ <- amount
 770         R.skipMany R.space_horizontal >> R.new_line
 771         context_ <- R.getState
 772         R.setState context_{context_unit_and_style =
 773                 Just $
 774                  ( Amount.unit  amount_
 775                  , Amount.style amount_ )}
 776         ) <?> "default unit and style"
 777
 778 include :: Stream s IO Char => ParsecT s Context IO ()
 779 include = (do
 780         sourcepos <- R.getPosition
 781         filename <- R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
 782         context_ <- R.getState
 783         let journal_ = context_journal context_
 784         let cwd = Path.takeDirectory (R.sourceName sourcepos)
 785         file_ <- liftIO $ Path.abs cwd filename
 786         (journal_included, context_included) <- liftIO $
 787                 Exception.catch
 788                  (readFile file_)
 789                  (\ko -> fail $ concat -- TODO: i18n by using a custom data type
 790                          [ show sourcepos
 791                          , " reading "
 792                          , file_
 793                          , ":\n", show (ko::Exception.IOException)
 794                          ])
 795                 >>= R.runParserT (R.and_state $ journal_rec file_)
 796                          context_{context_journal = Journal.nil}
 797                          file_
 798                 >>= \x -> case x of
 799                  Left  ko -> fail $ show ko
 800                  Right ok -> return ok
 801         R.setState $
 802                 context_included{context_journal=
 803                         journal_{Journal.includes=
 804                                 journal_included{Journal.file=file_}
 805                                 : Journal.includes journal_}}
 806         ) <?> "include"
 807
 808 -- * Parsing 'Journal'
 809
 810 journal :: Stream s IO Char => FilePath -> ParsecT s Context IO Journal
 811 journal file_ = (do
 812         currentLocalTime <- liftIO $
 813                 Time.utcToLocalTime
 814                 <$> Time.getCurrentTimeZone
 815                 <*> Time.getCurrentTime
 816         let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
 817         context_ <- R.getState
 818         R.setState $ context_{context_year=currentLocalYear}
 819         journal_rec file_
 820         ) <?> "journal"
 821
 822 journal_rec :: Stream s IO Char => FilePath -> ParsecT s Context IO Journal
 823 journal_rec file_ = do
 824         last_read_time <- liftIO $ Time.getCurrentTime
 825         R.skipMany $ do
 826                 R.choice_try
 827                  [ R.skipMany1 R.space
 828                  , (do (R.choice_try
 829                          [ R.string "Y"        >> return default_year
 830                          , R.string "D"        >> return default_unit_and_style
 831                          , R.string "!include" >> return include
 832                          ] <?> "directive")
 833                                 >>= \r -> R.skipMany1 R.space_horizontal >> r)
 834                  , ((do
 835                                 t <- transaction
 836                                 context_' <- R.getState
 837                                 let j = context_journal context_'
 838                                 R.setState $ context_'{context_journal=
 839                                         j{Journal.transactions=
 840                                                 Data.Map.insertWith (flip (++))
 841                                                  -- NOTE: flip-ing preserves order but slows down
 842                                                  -- when many transactions have the very same date.
 843                                                  (Date.to_UTC $ fst $ Transaction.dates t) [t]
 844                                                  (Journal.transactions j)}}
 845                                 R.new_line <|> R.eof))
 846                  , R.try (comment >> return ())
 847                  ]
 848         R.eof
 849         journal_ <- context_journal <$> R.getState
 850         return $
 851                 journal_
 852                  { Journal.file = file_
 853                  , Journal.last_read_time
 854                  , Journal.includes = reverse $ Journal.includes journal_
 855                  }
 856
 857 -- ** Parsing 'Journal' from a file
 858
 859 file :: FilePath -> ExceptT String IO Journal
 860 file path = do
 861         ExceptT $
 862                 Exception.catch
 863                  (liftM Right $ Text.IO.readFile path) $
 864                  \ko -> return $ Left $ show (ko::Exception.IOException)
 865         >>= liftIO . R.runParserT (journal path) nil_Context path
 866         >>= \x -> case x of
 867          Left  ko -> throwE $ show ko
 868          Right ok -> ExceptT $ return $ Right ok