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