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