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 (flip (++))
 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         sourcepos <- R.getPosition
 697         ctx <- R.getState
 698         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         R.skipMany $ R.space_horizontal
 716         status_ <- status
 717         code_ <- R.option "" $ R.try code
 718         R.skipMany $ R.space_horizontal
 719         description_ <- description
 720         R.skipMany $ R.space_horizontal
 721         comments_after <- comments
 722         let tags_ =
 723                 Data.Map.unionWith (++)
 724                  (tags_of_comments comments_before)
 725                  (tags_of_comments comments_after)
 726         R.new_line
 727         (postings_unchecked, postings_not_regular) <-
 728                 ((Ledger.posting_by_Account . Data.List.map fst) *** id) .
 729                 Data.List.partition ((Posting_Type_Regular ==) . snd) <$>
 730                 R.many1_separated posting R.new_line
 731         let (virtual_postings, balanced_virtual_postings_unchecked) =
 732                 join (***) (Ledger.posting_by_Account . Data.List.map fst) $
 733                 Data.List.partition ((Posting_Type_Virtual ==) . snd)
 734                  postings_not_regular
 735         let tr_unchecked =
 736                 Transaction
 737                  { transaction_code=code_
 738                  , transaction_comments_before=comments_before
 739                  , transaction_comments_after=comments_after
 740                  , transaction_dates=(date_, dates_)
 741                  , transaction_description=description_
 742                  , transaction_postings=postings_unchecked
 743                  , transaction_postings_balance=Calc.Balance.balance
 744                  , transaction_virtual_postings=virtual_postings
 745                  , transaction_balanced_virtual_postings=balanced_virtual_postings_unchecked
 746                  , transaction_balanced_virtual_postings_balance=Calc.Balance.balance
 747                  , transaction_sourcepos=sourcepos
 748                  , transaction_status=status_
 749                  , transaction_tags=tags_
 750                  }
 751         ( transaction_postings_balance
 752          ,transaction_postings ) <-
 753                 case Calc.Balance.infer_equilibrium postings_unchecked of
 754                  (_, Left ko) -> R.fail_with "transaction infer_equilibrium"
 755                                              (Error_transaction_not_equilibrated tr_unchecked ko)
 756                  (bal, Right ok) -> return (bal, ok)
 757         ( transaction_balanced_virtual_postings_balance
 758          ,transaction_balanced_virtual_postings ) <-
 759                 case Calc.Balance.infer_equilibrium balanced_virtual_postings_unchecked of
 760                  (_, Left ko) -> R.fail_with "transaction infer_equilibrium"
 761                                              (Error_virtual_transaction_not_equilibrated tr_unchecked ko)
 762                  (bal, Right ok) -> return (bal, ok)
 763         return $
 764                 Transaction
 765                  { transaction_code=code_
 766                  , transaction_comments_before=comments_before
 767                  , transaction_comments_after=comments_after
 768                  , transaction_dates=(date_, dates_)
 769                  , transaction_description=description_
 770                  , transaction_postings
 771                  , transaction_postings_balance
 772                  , transaction_virtual_postings=virtual_postings
 773                  , transaction_balanced_virtual_postings
 774                  , transaction_balanced_virtual_postings_balance
 775                  , transaction_sourcepos=sourcepos
 776                  , transaction_status=status_
 777                  , transaction_tags=tags_
 778                  }
 779         ) <?> "transaction"
 780
 781 date_sep :: Char
 782 date_sep = '='
 783
 784 code :: Stream s m Char => ParsecT s Context m Ledger.Code
 785 code = (do
 786         fromString <$> do
 787         R.skipMany $ R.space_horizontal
 788         R.between (R.char '(') (R.char ')') $
 789                 R.many $ R.satisfy (\c -> c /= ')' && not (R.is_space_horizontal c))
 790         ) <?> "code"
 791
 792 description :: Stream s m Char => ParsecT s u m Ledger.Description
 793 description = (do
 794         fromString <$> do
 795         R.many $ R.try description_char
 796         ) <?> "description"
 797         where
 798                 description_char :: Stream s m Char => ParsecT s u m Char
 799                 description_char = do
 800                         c <- R.anyChar
 801                         case c of
 802                          _ | c == comment_begin -> R.parserZero
 803                          _ | R.is_space_horizontal c -> return c <* (R.lookAhead $ R.try $ description_char)
 804                          _ | not (Data.Char.isSpace c) -> return c
 805                          _ -> R.parserZero
 806
 807 -- * Parsing directives
 808
 809 default_year :: Stream s m Char => ParsecT s Context m ()
 810 default_year = (do
 811         year <- R.integer_of_digits 10 <$> R.many1 R.digit
 812         R.skipMany R.space_horizontal >> R.new_line
 813         context_ <- R.getState
 814         R.setState context_{context_year=year}
 815         ) <?> "default year"
 816
 817 default_unit_and_style :: Stream s m Char => ParsecT s Context m ()
 818 default_unit_and_style = (do
 819         amount_ <- amount
 820         R.skipMany R.space_horizontal >> R.new_line
 821         context_ <- R.getState
 822         R.setState context_{context_unit_and_style =
 823                 Just $
 824                  ( Amount.unit  amount_
 825                  , Amount.style amount_ )}
 826         ) <?> "default unit and style"
 827
 828 include
 829  :: Stream s (R.Error_State Error IO) Char
 830  => ParsecT s Context (R.Error_State Error IO) ()
 831 include = (do
 832         sourcepos <- R.getPosition
 833         filename <- R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
 834         context_ <- R.getState
 835         let journal_ = context_journal context_
 836         let cwd = Path.takeDirectory (R.sourceName sourcepos)
 837         file_path <- liftIO $ Path.abs cwd filename
 838         content <- do
 839                 liftIO $ Exception.catch
 840                  (liftM return $ readFile file_path)
 841                  (return . R.fail_with "include reading" . Error_reading_file file_path)
 842                 >>= id
 843         (journal_included, context_included) <- do
 844                 liftIO $
 845                         R.runParserT_with_Error (R.and_state $ journal_rec file_path)
 846                          context_{context_journal = Ledger.journal}
 847                          file_path content
 848                 >>= \x -> case x of
 849                  Right ok -> return ok
 850                  Left  ko -> R.fail_with "include parsing" (Error_including_file file_path ko)
 851         R.setState $
 852                 context_included{context_journal=
 853                         journal_{journal_includes=
 854                                 journal_included{journal_file=file_path}
 855                                 : journal_includes journal_}}
 856         ) <?> "include"
 857
 858 -- * Parsing 'Journal'
 859
 860 journal
 861  :: Stream s (R.Error_State Error IO) Char
 862  => FilePath
 863  -> ParsecT s Context (R.Error_State Error IO) Journal
 864 journal file_ = (do
 865         currentLocalTime <- liftIO $
 866                 Time.utcToLocalTime
 867                 <$> Time.getCurrentTimeZone
 868                 <*> Time.getCurrentTime
 869         let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
 870         context_ <- R.getState
 871         R.setState $ context_{context_year=currentLocalYear}
 872         journal_rec file_
 873         ) <?> "journal"
 874
 875 journal_rec
 876  :: Stream s (R.Error_State Error IO) Char
 877  => FilePath
 878  -> ParsecT s Context (R.Error_State Error IO) Journal
 879 journal_rec file_ = do
 880         last_read_time <- lift $ liftIO Time.getCurrentTime
 881         R.skipMany $ do
 882                 R.choice_try
 883                  [ R.skipMany1 R.space
 884                  , (do (R.choice_try
 885                          [ R.string "Y"        >> return default_year
 886                          , R.string "D"        >> return default_unit_and_style
 887                          , R.string "!include" >> return include
 888                          ] <?> "directive")
 889                                 >>= \r -> R.skipMany1 R.space_horizontal >> r)
 890                  , ((do
 891                                 t <- transaction
 892                                 context_' <- R.getState
 893                                 let j = context_journal context_'
 894                                 R.setState $ context_'{context_journal=
 895                                         j{journal_transactions=
 896                                                 Data.Map.insertWith (flip (++))
 897                                                  -- NOTE: flip-ing preserves order but slows down
 898                                                  -- when many transactions have the very same date.
 899                                                  (Date.to_UTC $ fst $ transaction_dates t) [t]
 900                                                  (journal_transactions j)}}
 901                                 R.new_line <|> R.eof))
 902                  , R.try (comment >> return ())
 903                  ]
 904         R.eof
 905         journal_ <- context_journal <$> R.getState
 906         return $
 907                 journal_
 908                  { journal_file = file_
 909                  , journal_last_read_time=last_read_time
 910                  , journal_includes = reverse $ journal_includes journal_
 911                  }
 912
 913 -- ** Parsing 'Journal' from a file
 914
 915 file :: FilePath -> ExceptT [R.Error Error] IO Journal
 916 file path = do
 917         ExceptT $
 918                 Exception.catch
 919                  (liftM Right $ Text.IO.readFile path) $
 920                  \ko -> return $ Left $
 921                          [ R.Error_Custom (R.initialPos path) $ Error_reading_file path ko ]
 922         >>= liftIO . R.runParserT_with_Error (journal path) nil_Context path
 923         >>= \x -> case x of
 924          Left  ko -> throwE $ ko
 925          Right ok -> ExceptT $ return $ Right ok