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
 538                          (\(u, s) -> Data.Map.adjust (\a -> a{Amount.style=s, Amount.unit=u}) Unit.nil)
 539                          (context_unit_and_style ctx) .
 540                          Amount.from_List <$> do
 541                                 R.many_separated amount $ do
 542                                         R.skipMany $ R.space_horizontal
 543                                         _ <- R.char amount_sep
 544                                         R.skipMany $ R.space_horizontal
 545                                         return ()
 546                  , return Data.Map.empty
 547                  ] <?> "amounts"
 548         R.skipMany $ R.space_horizontal
 549         -- TODO: balance assertion
 550         -- TODO: conversion
 551         comments__ <- (comments_ ++) <$> comments
 552         let tags_ = tags_of_comments comments__
 553         dates_ <-
 554                 case Data.Map.lookup "date" tags_ of
 555                  Nothing -> return []
 556                  Just dates -> do
 557                         let date2s = Data.Map.lookup "date2" tags_ -- NOTE: support hledger's date2
 558                         dates_ <- (flip mapM) (dates ++ fromMaybe [] date2s) $
 559                                 R.runParserT (date (Just $ context_year ctx) <* R.eof) () ""
 560                                 >=> \x -> case x of
 561                                  Left  ko -> fail $ show ko
 562                                  Right ok -> return ok
 563                         case (dates, date2s) of -- NOTE: put hledger's date2 at least in second position
 564                          ([], Just (_:_)) ->
 565                                 return $ context_date ctx:dates_
 566                          _ -> return $ dates_
 567         return (Posting.Posting
 568          { Posting.account=account_
 569          , Posting.amounts=amounts_
 570          , Posting.comments=comments__
 571          , Posting.dates=dates_
 572          , Posting.sourcepos=sourcepos
 573          , Posting.status=status_
 574          , Posting.tags=tags_
 575          }, type_)
 576         ) <?> "posting"
 577
 578 amount_sep :: Char
 579 amount_sep = '+'
 580
 581 tags_of_comments :: [Comment] -> Tag.By_Name
 582 tags_of_comments =
 583         Data.Map.unionsWith (++)
 584         . Data.List.map
 585          ( Data.Either.either (const Data.Map.empty) id
 586          . R.runParser (not_tag >> tags <* R.eof) () "" )
 587
 588 status :: Stream s m Char => ParsecT s u m Transaction.Status
 589 status = (do
 590         ( R.try $ do
 591                 R.skipMany $ R.space_horizontal
 592                 _ <- (R.char '*' <|> R.char '!')
 593                 return True )
 594         <|> return False
 595         ) <?> "status"
 596
 597 -- | Return the Posting.'Posting.Type' and stripped 'Account' of the given 'Account'.
 598 posting_type :: Account -> (Posting.Type, Account)
 599 posting_type acct =
 600         fromMaybe (Posting.Type_Regular, acct) $ do
 601                 case acct of
 602                  name:|[] ->
 603                         case Text.stripPrefix virtual_begin name of
 604                          Just name' -> do
 605                                 name'' <-
 606                                             Text.stripSuffix virtual_end name'
 607                                         >>= return . Text.strip
 608                                 guard $ not $ Text.null name''
 609                                 Just (Posting.Type_Virtual, name'':|[])
 610                          Nothing -> do
 611                                 name' <-
 612                                             Text.stripPrefix virtual_balanced_begin name
 613                                         >>= Text.stripSuffix virtual_balanced_end
 614                                         >>= return . Text.strip
 615                                 guard $ not $ Text.null name'
 616                                 Just (Posting.Type_Virtual_Balanced, name':|[])
 617                  first_name:|acct' -> do
 618                                 let rev_acct' = Data.List.reverse acct'
 619                                 let last_name = Data.List.head rev_acct'
 620                                 case Text.stripPrefix virtual_begin first_name
 621                                         >>= return . Text.stripStart of
 622                                  Just first_name' -> do
 623                                         last_name' <-
 624                                                 Text.stripSuffix virtual_end last_name
 625                                                 >>= return . Text.stripEnd
 626                                         guard $ not $ Text.null first_name'
 627                                         guard $ not $ Text.null last_name'
 628                                         Just $
 629                                                 ( Posting.Type_Virtual
 630                                                 , first_name':|
 631                                                         Data.List.reverse (last_name':Data.List.tail rev_acct')
 632                                                 )
 633                                  Nothing -> do
 634                                         first_name' <-
 635                                                 Text.stripPrefix virtual_balanced_begin first_name
 636                                                 >>= return . Text.stripStart
 637                                         last_name'  <-
 638                                                 Text.stripSuffix virtual_balanced_end last_name
 639                                                 >>= return . Text.stripEnd
 640                                         guard $ not $ Text.null first_name'
 641                                         guard $ not $ Text.null last_name'
 642                                         Just $
 643                                                 ( Posting.Type_Virtual_Balanced
 644                                                 , first_name':|
 645                                                         Data.List.reverse (last_name':Data.List.tail rev_acct')
 646                                                 )
 647         where
 648                 virtual_begin          = Text.singleton posting_type_virtual_begin
 649                 virtual_end            = Text.singleton posting_type_virtual_end
 650                 virtual_balanced_begin = Text.singleton posting_type_virtual_balanced_begin
 651                 virtual_balanced_end   = Text.singleton posting_type_virtual_balanced_end
 652
 653 posting_type_virtual_begin :: Char
 654 posting_type_virtual_begin = '('
 655 posting_type_virtual_balanced_begin :: Char
 656 posting_type_virtual_balanced_begin = '['
 657 posting_type_virtual_end :: Char
 658 posting_type_virtual_end = ')'
 659 posting_type_virtual_balanced_end :: Char
 660 posting_type_virtual_balanced_end = ']'
 661
 662 -- * Parsing 'Transaction'
 663
 664 transaction :: Stream s m Char => ParsecT s Context m Transaction
 665 transaction = (do
 666         sourcepos <- R.getPosition
 667         ctx <- R.getState
 668         comments_before <- comments
 669         date_ <- date (Just $ context_year ctx)
 670         dates_ <-
 671                 R.option [] $ R.try $ do
 672                         R.skipMany $ R.space_horizontal
 673                         _ <- R.char date_sep
 674                         R.skipMany $ R.space_horizontal
 675                         R.many_separated
 676                          (date (Just $ context_year ctx)) $
 677                                 R.try $ do
 678                                         R.many $ R.space_horizontal
 679                                         >> R.char date_sep
 680                                         >> (R.many $ R.space_horizontal)
 681         R.skipMany $ R.space_horizontal
 682         status_ <- status
 683         code_ <- R.option "" $ R.try code
 684         R.skipMany $ R.space_horizontal
 685         description_ <- description
 686         R.skipMany $ R.space_horizontal
 687         comments_after <- comments
 688         let tags_ =
 689                 Data.Map.unionWith (++)
 690                  (tags_of_comments comments_before)
 691                  (tags_of_comments comments_after)
 692         R.new_line
 693         postings_ <- R.many1_separated posting R.new_line
 694         let (postings, postings__) =
 695                 (Posting.from_List . Data.List.map fst) *** id $
 696                 Data.List.partition
 697                  ((Posting.Type_Regular ==) . snd)
 698                  postings_
 699         let (virtual_postings, balanced_virtual_postings) =
 700                 join (***) (Posting.from_List . Data.List.map fst) $
 701                 Data.List.partition
 702                  ((Posting.Type_Virtual ==) . snd)
 703                  postings__
 704         return $
 705                 Transaction.Transaction
 706                  { Transaction.code=code_
 707                  , Transaction.comments_before
 708                  , Transaction.comments_after
 709                  , Transaction.dates=(date_, dates_)
 710                  , Transaction.description=description_
 711                  , Transaction.postings
 712                  , Transaction.virtual_postings
 713                  , Transaction.balanced_virtual_postings
 714                  , Transaction.sourcepos
 715                  , Transaction.status=status_
 716                  , Transaction.tags=tags_
 717                  }
 718         ) <?> "transaction"
 719
 720 date_sep :: Char
 721 date_sep = '='
 722
 723 code :: Stream s m Char => ParsecT s Context m Transaction.Code
 724 code = (do
 725         Text.pack <$> do
 726         R.skipMany $ R.space_horizontal
 727         R.between (R.char '(') (R.char ')') $
 728                 R.many $ R.satisfy (\c -> c /= ')' && not (R.is_space_horizontal c))
 729         ) <?> "code"
 730
 731 description :: Stream s m Char => ParsecT s u m Transaction.Description
 732 description = (do
 733         Text.pack <$> do
 734         R.many $ R.try description_char
 735         ) <?> "description"
 736         where
 737                 description_char :: Stream s m Char => ParsecT s u m Char
 738                 description_char = do
 739                         c <- R.anyChar
 740                         case c of
 741                          _ | c == comment_begin -> R.parserZero
 742                          _ | R.is_space_horizontal c -> return c <* (R.lookAhead $ R.try $ description_char)
 743                          _ | not (Data.Char.isSpace c) -> return c
 744                          _ -> R.parserZero
 745
 746 -- * Parsing directives
 747
 748 default_year :: Stream s m Char => ParsecT s Context m ()
 749 default_year = (do
 750         year <- R.integer_of_digits 10 <$> R.many1 R.digit
 751         R.skipMany R.space_horizontal >> R.new_line
 752         context_ <- R.getState
 753         R.setState context_{context_year=year}
 754         ) <?> "default year"
 755
 756 default_unit_and_style :: Stream s m Char => ParsecT s Context m ()
 757 default_unit_and_style = (do
 758         amount_ <- amount
 759         R.skipMany R.space_horizontal >> R.new_line
 760         context_ <- R.getState
 761         R.setState context_{context_unit_and_style =
 762                 Just $
 763                  ( Amount.unit  amount_
 764                  , Amount.style amount_ )}
 765         ) <?> "default unit and style"
 766
 767 include :: Stream s IO Char => ParsecT s Context IO ()
 768 include = (do
 769         sourcepos <- R.getPosition
 770         filename <- R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
 771         context_ <- R.getState
 772         let journal_ = context_journal context_
 773         let cwd = Path.takeDirectory (R.sourceName sourcepos)
 774         file_ <- liftIO $ Path.abs cwd filename
 775         (journal_included, context_included) <- liftIO $
 776                 Exception.catch
 777                  (readFile file_)
 778                  (\ko -> fail $ concat -- TODO: i18n by using a custom data type
 779                          [ show sourcepos
 780                          , " reading "
 781                          , file_
 782                          , ":\n", show (ko::Exception.IOException)
 783                          ])
 784                 >>= R.runParserT (R.and_state $ journal_rec file_)
 785                          context_{context_journal = Journal.nil}
 786                          file_
 787                 >>= \x -> case x of
 788                  Left  ko -> fail $ show ko
 789                  Right ok -> return ok
 790         R.setState $
 791                 context_included{context_journal=
 792                         journal_{Journal.includes=
 793                                 journal_included{Journal.file=file_}
 794                                 : Journal.includes journal_}}
 795         ) <?> "include"
 796
 797 -- * Parsing 'Journal'
 798
 799 journal :: Stream s IO Char => FilePath -> ParsecT s Context IO Journal
 800 journal file_ = (do
 801         currentLocalTime <- liftIO $
 802                 Time.utcToLocalTime
 803                 <$> Time.getCurrentTimeZone
 804                 <*> Time.getCurrentTime
 805         let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
 806         context_ <- R.getState
 807         R.setState $ context_{context_year=currentLocalYear}
 808         journal_rec file_
 809         ) <?> "journal"
 810
 811 journal_rec :: Stream s IO Char => FilePath -> ParsecT s Context IO Journal
 812 journal_rec file_ = do
 813         last_read_time <- liftIO $ Time.getCurrentTime
 814         R.skipMany $ do
 815                 R.choice_try
 816                  [ R.skipMany1 R.space
 817                  , (do (R.choice_try
 818                          [ R.string "Y"        >> return default_year
 819                          , R.string "D"        >> return default_unit_and_style
 820                          , R.string "!include" >> return include
 821                          ] <?> "directive")
 822                                 >>= \r -> R.skipMany1 R.space_horizontal >> r)
 823                  , ((do
 824                                 t <- transaction
 825                                 context_' <- R.getState
 826                                 let j = context_journal context_'
 827                                 R.setState $ context_'{context_journal=
 828                                         j{Journal.transactions=
 829                                                 Data.Map.insertWith (flip (++))
 830                                                  -- NOTE: flip-ing preserves order but slows down
 831                                                  -- when many transactions have the very same date.
 832                                                  (Date.to_UTC $ fst $ Transaction.dates t) [t]
 833                                                  (Journal.transactions j)}}
 834                                 R.new_line <|> R.eof))
 835                  , R.try (comment >> return ())
 836                  ]
 837         R.eof
 838         journal_ <- context_journal <$> R.getState
 839         return $
 840                 journal_
 841                  { Journal.file = file_
 842                  , Journal.last_read_time
 843                  , Journal.includes = reverse $ Journal.includes journal_
 844                  }
 845
 846 -- ** Parsing 'Journal' from a file
 847
 848 file :: FilePath -> ExceptT String IO Journal
 849 file path = do
 850         ExceptT $
 851                 Exception.catch
 852                  (liftM Right $ Text.IO.readFile path) $
 853                  \ko -> return $ Left $ show (ko::Exception.IOException)
 854         >>= liftIO . R.runParserT (journal path) nil_Context path
 855         >>= \x -> case x of
 856          Left  ko -> throwE $ show ko
 857          Right ok -> ExceptT $ return $ Right ok