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_day (Integer, Int, Int)
 100  |   Error_invalid_time_of_day (Integer, Integer, Integer)
 101  |   Error_transaction_not_equilibrated [Calc.Balance.Unit_Sum Amount]
 102  |   Error_virtual_transaction_not_equilibrated [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_day (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                          ( R.integer_of_digits 10 hour
 394                          , R.integer_of_digits 10 minu
 395                          , maybe 0 (R.integer_of_digits 10) sec
 396                          , tz )
 397         tod <- case Time.makeTimeOfDayValid
 398          (fromInteger hour)
 399          (fromInteger minu)
 400          (fromInteger sec) of
 401          Nothing  -> R.fail_with "date" (Error_invalid_time_of_day (hour, minu, sec))
 402          Just tod -> return tod
 403         return $
 404                 Time.ZonedTime
 405                  (Time.LocalTime day_ tod)
 406                  tz
 407         ) <?> "date"
 408
 409 time_zone :: Stream s m Char => ParsecT s u m TimeZone
 410 time_zone =
 411         -- DOC: http://www.timeanddate.com/time/zones/
 412         -- TODO: only a few time zones are suported below.
 413         -- TODO: check the timeZoneSummerOnly values
 414         R.choice
 415          [ R.char 'A' >> R.choice
 416                  [ R.string "ST" >> return (TimeZone ((-4) * 60) False "AST")
 417                  , R.string "DT" >> return (TimeZone ((-3) * 60) True  "ADT")
 418                  , return (TimeZone ((-1) * 60) False "A")
 419                  ]
 420          , R.char 'B' >> R.choice
 421                  [ R.string "ST" >> return (TimeZone ((-11) * 60) False "BST")
 422                  , R.string "DT" >> return (TimeZone ((-10) * 60) True  "BDT")
 423                  ]
 424          , R.char 'C' >> R.choice
 425                  [ R.char 'E' >> R.choice
 426                          [ R.string "T"  >> return (TimeZone ((1) * 60) True  "CET")
 427                          , R.string "ST" >> return (TimeZone ((2) * 60) False "CEST")
 428                          ]
 429                  , R.string "ST" >> return (TimeZone ((-6) * 60) False "CST")
 430                  , R.string "DT" >> return (TimeZone ((-5) * 60) True  "CDT")
 431                  ]
 432          , R.char 'E' >> R.choice
 433                  [ R.string "ST" >> return (TimeZone ((-5) * 60) False "EST")
 434                  , R.string "DT" >> return (TimeZone ((-4) * 60) True  "EDT")
 435                  ]
 436          , R.string "GMT" >> return (TimeZone 0 False "GMT")
 437          , R.char 'H' >> R.choice
 438                  [ R.string "ST" >> return (TimeZone ((-10) * 60) False "HST")
 439                  , R.string "DT" >> return (TimeZone (( -9) * 60) True  "HDT")
 440                  ]
 441          , R.char 'M' >> R.choice
 442                  [ R.string "ST" >> return (TimeZone ((-7) * 60) False "MST")
 443                  , R.string "DT" >> return (TimeZone ((-6) * 60) True  "MDT")
 444                  , return (TimeZone ((-12) * 60) False "M")
 445                  ]
 446          , R.char 'N' >> R.choice
 447                  [ R.string "ST" >> return (TimeZone ((-3) * 60 - 30) False "NST")
 448                  , return (TimeZone (1 * 60) False "N")
 449                  ]
 450          , R.char 'P' >> R.choice
 451                  [ R.string "ST" >> return (TimeZone ((-8) * 60) False "PST")
 452                  , R.string "DT" >> return (TimeZone ((-7) * 60) True  "PDT")
 453                  ]
 454          , R.char 'Y' >> R.choice
 455                  [ R.string "ST" >> return (TimeZone ((-9) * 60) False "YST")
 456                  , R.string "DT" >> return (TimeZone ((-8) * 60) True  "YDT")
 457                  , return (TimeZone (12 * 60) False "Y")
 458                  ]
 459          , R.char 'Z' >> return (TimeZone 0 False "Z")
 460          , time_zone_digits
 461          ]
 462
 463 time_zone_digits :: Stream s m Char => ParsecT s u m TimeZone
 464 {-# INLINEABLE time_zone_digits #-}
 465 time_zone_digits = do
 466         sign_ <- sign
 467         hour <- R.integer_of_digits 10 <$> R.count 2 R.digit
 468         _ <- R.option ':' (R.char ':')
 469         minute <- R.integer_of_digits 10 <$> R.count 2 R.digit
 470         let tz = TimeZone
 471                  { timeZoneMinutes    = sign_ (fromInteger hour * 60 + fromInteger minute)
 472                  , timeZoneSummerOnly = False
 473                  , timeZoneName       = Time.timeZoneOffsetString tz
 474                  }
 475         return tz
 476
 477 -- * Parsing 'Comment'
 478
 479 comment_begin :: Char
 480 comment_begin = ';'
 481
 482 comment :: Stream s m Char => ParsecT s u m Comment
 483 comment = (do
 484         _ <- R.char comment_begin
 485         fromString <$> do
 486         R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
 487         ) <?> "comment"
 488
 489 comments :: Stream s m Char => ParsecT s u m [Comment]
 490 comments = (do
 491         R.try $ do
 492                 _ <- R.spaces
 493                 R.many1_separated comment (R.new_line >> R.skipMany R.space_horizontal)
 494         <|> return []
 495         ) <?> "comments"
 496
 497 -- * Parsing 'Tag'
 498
 499 tag_value_sep :: Char
 500 tag_value_sep = ':'
 501
 502 tag_sep :: Char
 503 tag_sep = ','
 504
 505 -- | Parse a 'Tag'.
 506 tag :: Stream s m Char => ParsecT s u m Tag
 507 tag = (do
 508         n <- tag_name
 509         _ <- R.char tag_value_sep
 510         v <- tag_value
 511         return (n, v)
 512         ) <?> "tag"
 513
 514 tag_name :: Stream s m Char => ParsecT s u m Tag_Name
 515 tag_name = do
 516         fromString <$> do
 517         R.many1 $ R.satisfy (\c -> c /= tag_value_sep && not (Data.Char.isSpace c))
 518
 519 tag_value :: Stream s m Char => ParsecT s u m Tag_Value
 520 tag_value = do
 521         fromString <$> do
 522         R.manyTill R.anyChar $ do
 523                 R.lookAhead $ do
 524                         R.try (R.char tag_sep >> R.many R.space_horizontal >> tag_name >> R.char tag_value_sep >> return ())
 525                         <|> R.try R.new_line
 526                         <|> R.eof
 527
 528 tags :: Stream s m Char => ParsecT s u m Tag_by_Name
 529 tags = do
 530         Ledger.tag_by_Name <$> do
 531                 R.many_separated tag $ do
 532                         _ <- R.char tag_sep
 533                         R.skipMany $ R.space_horizontal
 534                         return ()
 535
 536 not_tag :: Stream s m Char => ParsecT s u m ()
 537 not_tag = do
 538         R.skipMany $ R.try $ do
 539                 R.skipMany $ R.satisfy
 540                  (\c -> c /= tag_value_sep
 541                          && not (Data.Char.isSpace c))
 542                 R.space_horizontal
 543
 544 -- * Parsing 'Posting'
 545
 546 -- | Parse a 'Posting'.
 547 posting
 548  :: (Stream s (R.Error_State Error m) Char, Monad m)
 549  => ParsecT s Context (R.Error_State Error m) (Posting, Posting_Type)
 550 posting = (do
 551         ctx <- R.getState
 552         sourcepos <- R.getPosition
 553         R.skipMany1 $ R.space_horizontal
 554         status_ <- status
 555         R.skipMany $ R.space_horizontal
 556         acct <- account
 557         let (type_, account_) = posting_type acct
 558         amounts_ <-
 559                 R.choice_try
 560                  [ do
 561                         _ <- R.count 2 R.space_horizontal
 562                         R.skipMany $ R.space_horizontal
 563                         maybe id (\(u, s) ->
 564                                 if u == Unit.nil then id
 565                                 else
 566                                         Data.Map.adjust (\a ->
 567                                                 a{ Amount.style = s{Style.precision = Style.precision $ Amount.style a}
 568                                                  , Amount.unit  = u })
 569                                          Unit.nil)
 570                          (context_unit_and_style ctx) .
 571                          Amount.from_List <$> do
 572                                 R.many_separated amount $ do
 573                                         R.skipMany $ R.space_horizontal
 574                                         _ <- R.char amount_sep
 575                                         R.skipMany $ R.space_horizontal
 576                                         return ()
 577                  , return Data.Map.empty
 578                  ] <?> "amounts"
 579         R.skipMany $ R.space_horizontal
 580         -- TODO: balance assertion
 581         -- TODO: conversion
 582         comments_ <- comments
 583         let tags_ = tags_of_comments comments_
 584         dates_ <-
 585                 case Data.Map.lookup "date" tags_ of
 586                  Nothing -> return []
 587                  Just dates -> do
 588                         let date2s = Data.Map.lookup "date2" tags_ -- NOTE: support hledger's date2
 589                         do
 590                         (flip mapM) (dates ++ fromMaybe [] date2s) $ \s ->
 591                                 R.runParserT_with_Error_fail "tag date"
 592                                  (date (Just $ context_year ctx) <* R.eof) ()
 593                                  (Text.unpack s) s
 594                         >>= \dates_ -> case (dates, date2s) of -- NOTE: put hledger's date2 at least in second position
 595                          ([], Just (_:_)) ->
 596                                 return $ context_date ctx:dates_
 597                          _ -> return $ dates_
 598         return (Posting
 599          { posting_account=account_
 600          , posting_amounts=amounts_
 601          , posting_comments=comments_
 602          , posting_dates=dates_
 603          , posting_sourcepos=sourcepos
 604          , posting_status=status_
 605          , posting_tags=tags_
 606          }, type_)
 607         ) <?> "posting"
 608
 609 amount_sep :: Char
 610 amount_sep = '+'
 611
 612 tags_of_comments :: [Comment] -> Tag_by_Name
 613 tags_of_comments =
 614         Data.Map.unionsWith (flip (++))
 615         . Data.List.map
 616          ( Data.Either.either (const Data.Map.empty) id
 617          . R.runParser (not_tag >> tags <* R.eof) () "" )
 618
 619 status :: Stream s m Char => ParsecT s u m Ledger.Status
 620 status = (do
 621         ( R.try $ do
 622                 R.skipMany $ R.space_horizontal
 623                 _ <- (R.char '*' <|> R.char '!')
 624                 return True )
 625         <|> return False
 626         ) <?> "status"
 627
 628 -- | Return the 'Posting_Type' and stripped 'Account' of the given 'Account'.
 629 posting_type :: Account -> (Posting_Type, Account)
 630 posting_type acct =
 631         fromMaybe (Posting_Type_Regular, acct) $ do
 632                 case acct of
 633                  name:|[] ->
 634                         case Text.stripPrefix virtual_begin name of
 635                          Just name' -> do
 636                                 name'' <-
 637                                             Text.stripSuffix virtual_end name'
 638                                         >>= return . Text.strip
 639                                 guard $ not $ Text.null name''
 640                                 Just (Posting_Type_Virtual, name'':|[])
 641                          Nothing -> do
 642                                 name' <-
 643                                             Text.stripPrefix virtual_balanced_begin name
 644                                         >>= Text.stripSuffix virtual_balanced_end
 645                                         >>= return . Text.strip
 646                                 guard $ not $ Text.null name'
 647                                 Just (Posting_Type_Virtual_Balanced, name':|[])
 648                  first_name:|acct' -> do
 649                                 let rev_acct' = Data.List.reverse acct'
 650                                 let last_name = Data.List.head rev_acct'
 651                                 case Text.stripPrefix virtual_begin first_name
 652                                         >>= return . Text.stripStart of
 653                                  Just first_name' -> do
 654                                         last_name' <-
 655                                                 Text.stripSuffix virtual_end last_name
 656                                                 >>= return . Text.stripEnd
 657                                         guard $ not $ Text.null first_name'
 658                                         guard $ not $ Text.null last_name'
 659                                         Just $
 660                                                 ( Posting_Type_Virtual
 661                                                 , first_name':|
 662                                                         Data.List.reverse (last_name':Data.List.tail rev_acct')
 663                                                 )
 664                                  Nothing -> do
 665                                         first_name' <-
 666                                                 Text.stripPrefix virtual_balanced_begin first_name
 667                                                 >>= return . Text.stripStart
 668                                         last_name'  <-
 669                                                 Text.stripSuffix virtual_balanced_end last_name
 670                                                 >>= return . Text.stripEnd
 671                                         guard $ not $ Text.null first_name'
 672                                         guard $ not $ Text.null last_name'
 673                                         Just $
 674                                                 ( Posting_Type_Virtual_Balanced
 675                                                 , first_name':|
 676                                                         Data.List.reverse (last_name':Data.List.tail rev_acct')
 677                                                 )
 678         where
 679                 virtual_begin          = Text.singleton posting_type_virtual_begin
 680                 virtual_end            = Text.singleton posting_type_virtual_end
 681                 virtual_balanced_begin = Text.singleton posting_type_virtual_balanced_begin
 682                 virtual_balanced_end   = Text.singleton posting_type_virtual_balanced_end
 683
 684 posting_type_virtual_begin :: Char
 685 posting_type_virtual_begin = '('
 686 posting_type_virtual_balanced_begin :: Char
 687 posting_type_virtual_balanced_begin = '['
 688 posting_type_virtual_end :: Char
 689 posting_type_virtual_end = ')'
 690 posting_type_virtual_balanced_end :: Char
 691 posting_type_virtual_balanced_end = ']'
 692
 693 -- * Parsing 'Transaction'
 694
 695 transaction
 696  :: (Stream s (R.Error_State Error m) Char, Monad m)
 697  => ParsecT s Context (R.Error_State Error m) Transaction
 698 transaction = (do
 699         sourcepos <- R.getPosition
 700         ctx <- R.getState
 701         comments_before <-
 702                 comments
 703                 >>= \x -> case x of
 704                  [] -> return []
 705                  _  -> return x <* R.new_line
 706         date_ <- date (Just $ context_year ctx)
 707         dates_ <-
 708                 R.option [] $ R.try $ do
 709                         R.skipMany $ R.space_horizontal
 710                         _ <- R.char date_sep
 711                         R.skipMany $ R.space_horizontal
 712                         R.many_separated
 713                          (date (Just $ context_year ctx)) $
 714                                 R.try $ do
 715                                         R.many $ R.space_horizontal
 716                                         >> R.char date_sep
 717                                         >> (R.many $ R.space_horizontal)
 718         R.skipMany $ R.space_horizontal
 719         status_ <- status
 720         code_ <- R.option "" $ R.try code
 721         R.skipMany $ R.space_horizontal
 722         description_ <- description
 723         R.skipMany $ R.space_horizontal
 724         comments_after <- comments
 725         let tags_ =
 726                 Data.Map.unionWith (++)
 727                  (tags_of_comments comments_before)
 728                  (tags_of_comments comments_after)
 729         R.new_line
 730         (postings_unchecked, postings_not_regular) <-
 731                 ((Ledger.posting_by_Account . Data.List.map fst) *** id) .
 732                 Data.List.partition ((Posting_Type_Regular ==) . snd) <$>
 733                 R.many1_separated posting R.new_line
 734         let (virtual_postings, balanced_virtual_postings_unchecked) =
 735                 join (***) (Ledger.posting_by_Account . Data.List.map fst) $
 736                 Data.List.partition ((Posting_Type_Virtual ==) . snd)
 737                  postings_not_regular
 738         postings <-
 739                 case snd $ Calc.Balance.infer_equilibrium postings_unchecked of
 740                  Left  ko -> R.fail_with "transaction infer_equilibrium" (Error_transaction_not_equilibrated ko)
 741                  Right ok -> return ok
 742         balanced_virtual_postings <-
 743                 case snd $ Calc.Balance.infer_equilibrium balanced_virtual_postings_unchecked of
 744                  Left  ko -> R.fail_with "transaction infer_equilibrium" (Error_virtual_transaction_not_equilibrated ko)
 745                  Right ok -> return ok
 746         return $
 747                 Transaction
 748                  { transaction_code=code_
 749                  , transaction_comments_before=comments_before
 750                  , transaction_comments_after=comments_after
 751                  , transaction_dates=(date_, dates_)
 752                  , transaction_description=description_
 753                  , transaction_postings=postings
 754                  , transaction_virtual_postings=virtual_postings
 755                  , transaction_balanced_virtual_postings=balanced_virtual_postings
 756                  , transaction_sourcepos=sourcepos
 757                  , transaction_status=status_
 758                  , transaction_tags=tags_
 759                  }
 760         ) <?> "transaction"
 761
 762 date_sep :: Char
 763 date_sep = '='
 764
 765 code :: Stream s m Char => ParsecT s Context m Ledger.Code
 766 code = (do
 767         fromString <$> do
 768         R.skipMany $ R.space_horizontal
 769         R.between (R.char '(') (R.char ')') $
 770                 R.many $ R.satisfy (\c -> c /= ')' && not (R.is_space_horizontal c))
 771         ) <?> "code"
 772
 773 description :: Stream s m Char => ParsecT s u m Ledger.Description
 774 description = (do
 775         fromString <$> do
 776         R.many $ R.try description_char
 777         ) <?> "description"
 778         where
 779                 description_char :: Stream s m Char => ParsecT s u m Char
 780                 description_char = do
 781                         c <- R.anyChar
 782                         case c of
 783                          _ | c == comment_begin -> R.parserZero
 784                          _ | R.is_space_horizontal c -> return c <* (R.lookAhead $ R.try $ description_char)
 785                          _ | not (Data.Char.isSpace c) -> return c
 786                          _ -> R.parserZero
 787
 788 -- * Parsing directives
 789
 790 default_year :: Stream s m Char => ParsecT s Context m ()
 791 default_year = (do
 792         year <- R.integer_of_digits 10 <$> R.many1 R.digit
 793         R.skipMany R.space_horizontal >> R.new_line
 794         context_ <- R.getState
 795         R.setState context_{context_year=year}
 796         ) <?> "default year"
 797
 798 default_unit_and_style :: Stream s m Char => ParsecT s Context m ()
 799 default_unit_and_style = (do
 800         amount_ <- amount
 801         R.skipMany R.space_horizontal >> R.new_line
 802         context_ <- R.getState
 803         R.setState context_{context_unit_and_style =
 804                 Just $
 805                  ( Amount.unit  amount_
 806                  , Amount.style amount_ )}
 807         ) <?> "default unit and style"
 808
 809 include
 810  :: Stream s (R.Error_State Error IO) Char
 811  => ParsecT s Context (R.Error_State Error IO) ()
 812 include = (do
 813         sourcepos <- R.getPosition
 814         filename <- R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
 815         context_ <- R.getState
 816         let journal_ = context_journal context_
 817         let cwd = Path.takeDirectory (R.sourceName sourcepos)
 818         file_path <- liftIO $ Path.abs cwd filename
 819         content <- do
 820                 liftIO $ Exception.catch
 821                  (liftM return $ readFile file_path)
 822                  (return . R.fail_with "include reading" . Error_reading_file file_path)
 823                 >>= id
 824         (journal_included, context_included) <- do
 825                 liftIO $
 826                         R.runParserT_with_Error (R.and_state $ journal_rec file_path)
 827                          context_{context_journal = Ledger.journal}
 828                          file_path content
 829                 >>= \x -> case x of
 830                  Right ok -> return ok
 831                  Left  ko -> R.fail_with "include parsing" (Error_including_file file_path ko)
 832         R.setState $
 833                 context_included{context_journal=
 834                         journal_{journal_includes=
 835                                 journal_included{journal_file=file_path}
 836                                 : journal_includes journal_}}
 837         ) <?> "include"
 838
 839 -- * Parsing 'Journal'
 840
 841 journal
 842  :: Stream s (R.Error_State Error IO) Char
 843  => FilePath
 844  -> ParsecT s Context (R.Error_State Error IO) Journal
 845 journal file_ = (do
 846         currentLocalTime <- liftIO $
 847                 Time.utcToLocalTime
 848                 <$> Time.getCurrentTimeZone
 849                 <*> Time.getCurrentTime
 850         let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
 851         context_ <- R.getState
 852         R.setState $ context_{context_year=currentLocalYear}
 853         journal_rec file_
 854         ) <?> "journal"
 855
 856 journal_rec
 857  :: Stream s (R.Error_State Error IO) Char
 858  => FilePath
 859  -> ParsecT s Context (R.Error_State Error IO) Journal
 860 journal_rec file_ = do
 861         last_read_time <- lift $ liftIO Time.getCurrentTime
 862         R.skipMany $ do
 863                 R.choice_try
 864                  [ R.skipMany1 R.space
 865                  , (do (R.choice_try
 866                          [ R.string "Y"        >> return default_year
 867                          , R.string "D"        >> return default_unit_and_style
 868                          , R.string "!include" >> return include
 869                          ] <?> "directive")
 870                                 >>= \r -> R.skipMany1 R.space_horizontal >> r)
 871                  , ((do
 872                                 t <- transaction
 873                                 context_' <- R.getState
 874                                 let j = context_journal context_'
 875                                 R.setState $ context_'{context_journal=
 876                                         j{journal_transactions=
 877                                                 Data.Map.insertWith (flip (++))
 878                                                  -- NOTE: flip-ing preserves order but slows down
 879                                                  -- when many transactions have the very same date.
 880                                                  (Date.to_UTC $ fst $ transaction_dates t) [t]
 881                                                  (journal_transactions j)}}
 882                                 R.new_line <|> R.eof))
 883                  , R.try (comment >> return ())
 884                  ]
 885         R.eof
 886         journal_ <- context_journal <$> R.getState
 887         return $
 888                 journal_
 889                  { journal_file = file_
 890                  , journal_last_read_time=last_read_time
 891                  , journal_includes = reverse $ journal_includes journal_
 892                  }
 893
 894 -- ** Parsing 'Journal' from a file
 895
 896 file :: FilePath -> ExceptT [R.Error Error] IO Journal
 897 file path = do
 898         ExceptT $
 899                 Exception.catch
 900                  (liftM Right $ Text.IO.readFile path) $
 901                  \ko -> return $ Left $
 902                          [ R.Error_Custom (R.initialPos path) $ Error_reading_file path ko ]
 903         >>= liftIO . R.runParserT_with_Error (journal path) nil_Context path
 904         >>= \x -> case x of
 905          Left  ko -> throwE $ ko
 906          Right ok -> ExceptT $ return $ Right ok