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