lib/Hcompta/Format/Ledger/Read.hs

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