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