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