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