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