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 P
  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 -> (<|>) (P.try a)) P.parserZero
  88 -- choice_try = P.choice . Data.List.map P.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 <- P.many (P.try (sep >> p))
 108         return $ x:xs
 109 -- (:) <$> p <*> P.many (P.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 <- P.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 P.digit
 156 hexadecimal :: Stream s m Char => ParsecT s u m Integer
 157 hexadecimal = P.oneOf "xX" >> integer 16 P.hexDigit
 158 octal :: Stream s m Char => ParsecT s u m Integer
 159 octal = P.oneOf "oO" >> integer 8 P.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 <- P.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             (P.char '-' >> return negate)
 175         <|> (P.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 = P.satisfy is_space_horizontal <?> "horizontal-space"
 187
 188 newline :: Stream s m Char => ParsecT s u m ()
 189 newline = ((P.try (P.string "\r\n") <|> P.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         P.notFollowedBy $ space_horizontal
 200         many1_separated account_name $ P.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         P.many1 $ P.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 <- P.anyChar
 211                         case c of
 212                          _ | c == comment_begin -> P.parserZero
 213                          _ | c == account_name_sep -> P.parserZero
 214                          _ | c == posting_type_virtual_end
 215                           || c == posting_type_virtual_balanced_end ->
 216                                 return c <* (P.lookAhead $ account_name_char)
 217                          _ | is_space_horizontal c -> do
 218                                 _ <- P.notFollowedBy $ space_horizontal
 219                                 return c <* (P.lookAhead
 220                                  ( P.try (P.char account_name_sep)
 221                                  <|> account_name_char
 222                                  ))
 223                          _ | not (Data.Char.isSpace c) -> return c
 224                          _ -> P.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 <- P.option Nothing $ (Just <$> account_name)
 230         case n of
 231          Nothing -> P.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         P.notFollowedBy $ space_horizontal
 238         many1_separated account_joker_name $ P.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 <- P.many1 $ P.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 <$> (P.char '=' >> account)
 251          , Account.Pattern_Joker <$> (P.char '*' >> account_joker)
 252          , Account.Pattern_Regex <$> (P.option '~' (P.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                 P.option Nothing $ do
 263                         u <- unit
 264                         s <- P.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 '_' ',' '_' <* (P.notFollowedBy $ P.oneOf ",._")
 277                          , quantity '_' '.' '_' <* (P.notFollowedBy $ P.oneOf ",._")
 278                          , quantity ',' '.' '_' <* (P.notFollowedBy $ P.oneOf ",._")
 279                          , quantity '.' ',' '_' <* (P.notFollowedBy $ P.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                         P.option (Unit.nil, Nothing, Nothing) $ do
 304                                 s <- P.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 <- P.many P.digit
 336                 case h of
 337                  [] -> return ([], Nothing)
 338                  _ -> do
 339                         t <- P.many $ P.char int_group_sep >> P.many1 P.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                  _ -> P.option ([], Nothing, Nothing)) $ do
 346                         fractioning <- P.char frac_sep
 347                         h <- P.many P.digit
 348                         t <- P.many $ P.char frac_group_sep >> P.many1 P.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                         P.many1 $
 389                                 P.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                         P.between (P.char '"') (P.char '"') $
 402                                 P.many1 $
 403                                         P.noneOf ";\n\""
 404
 405 -- * Directives
 406
 407 directive_alias :: Stream s m Char => ParsecT s Context m ()
 408 directive_alias = do
 409         _ <- P.string "alias"
 410         P.skipMany1 $ space_horizontal
 411         pattern <- account_pattern
 412         P.skipMany $ space_horizontal
 413         _ <- P.char '='
 414         P.skipMany $ space_horizontal
 415         repl <- account
 416         P.skipMany $ space_horizontal
 417         case pattern of
 418          Account.Pattern_Exact acct -> P.modifyState $ \ctx -> ctx{context_aliases_exact=
 419                 Data.Map.insert acct repl $ context_aliases_exact ctx}
 420          Account.Pattern_Joker jokr -> P.modifyState $ \ctx -> ctx{context_aliases_joker=
 421                 (jokr, repl):context_aliases_joker ctx}
 422          Account.Pattern_Regex regx -> P.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 = P.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 = P.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 <- P.many1 P.digit
 440         day_sep <- date_separator
 441         n1 <- P.try (P.count 2 P.digit) <|> P.count 1 P.digit
 442         n2 <- P.option Nothing $ P.try $ do
 443                 _ <- P.char day_sep
 444                 Just <$> do P.try (P.count 2 P.digit) <|> P.count 1 P.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                 P.option (0, 0, 0, Time.utc) $ P.try $ do
 459                         P.skipMany1 $ space_horizontal
 460                         hour <- P.try (P.count 2 P.digit) <|> P.count 1 P.digit
 461                         sep <- hour_separator
 462                         minu <- P.try (P.count 2 P.digit) <|> P.count 1 P.digit
 463                         sec <- P.option Nothing $ P.try $ do
 464                                 _ <- P.char sep
 465                                 Just <$> (P.try (P.count 2 P.digit) <|> P.count 1 P.digit)
 466                         -- DO: timezone
 467                         tz <- P.option Time.utc $ P.try $ do
 468                                 P.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         P.choice
 496          [ P.char 'A' >> P.choice
 497                  [ P.string "ST" >> return (TimeZone ((-4) * 60) False "AST")
 498                  , P.string "DT" >> return (TimeZone ((-3) * 60) True  "ADT")
 499                  , return (TimeZone ((-1) * 60) False "A")
 500                  ]
 501          , P.char 'B' >> P.choice
 502                  [ P.string "ST" >> return (TimeZone ((-11) * 60) False "BST")
 503                  , P.string "DT" >> return (TimeZone ((-10) * 60) True  "BDT")
 504                  ]
 505          , P.char 'C' >> P.choice
 506                  [ P.char 'E' >> P.choice
 507                          [ P.string "T"  >> return (TimeZone ((1) * 60) True  "CET")
 508                          , P.string "ST" >> return (TimeZone ((2) * 60) False "CEST")
 509                          ]
 510                  , P.string "ST" >> return (TimeZone ((-6) * 60) False "CST")
 511                  , P.string "DT" >> return (TimeZone ((-5) * 60) True  "CDT")
 512                  ]
 513          , P.char 'E' >> P.choice
 514                  [ P.string "ST" >> return (TimeZone ((-5) * 60) False "EST")
 515                  , P.string "DT" >> return (TimeZone ((-4) * 60) True  "EDT")
 516                  ]
 517          , P.string "GMT" >> return (TimeZone 0 False "GMT")
 518          , P.char 'H' >> P.choice
 519                  [ P.string "ST" >> return (TimeZone ((-10) * 60) False "HST")
 520                  , P.string "DT" >> return (TimeZone (( -9) * 60) True  "HDT")
 521                  ]
 522          , P.char 'M' >> P.choice
 523                  [ P.string "ST" >> return (TimeZone ((-7) * 60) False "MST")
 524                  , P.string "DT" >> return (TimeZone ((-6) * 60) True  "MDT")
 525                  , return (TimeZone ((-12) * 60) False "M")
 526                  ]
 527          , P.char 'N' >> P.choice
 528                  [ P.string "ST" >> return (TimeZone ((-3) * 60 - 30) False "NST")
 529                  , return (TimeZone (1 * 60) False "N")
 530                  ]
 531          , P.char 'P' >> P.choice
 532                  [ P.string "ST" >> return (TimeZone ((-8) * 60) False "PST")
 533                  , P.string "DT" >> return (TimeZone ((-7) * 60) True  "PDT")
 534                  ]
 535          , P.char 'Y' >> P.choice
 536                  [ P.string "ST" >> return (TimeZone ((-9) * 60) False "YST")
 537                  , P.string "DT" >> return (TimeZone ((-8) * 60) True  "YDT")
 538                  , return (TimeZone (12 * 60) False "Y")
 539                  ]
 540          , P.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 <$> P.count 2 P.digit
 549         _ <- P.option ':' (P.char ':')
 550         minute <- integer_of_digits 10 <$> P.count 2 P.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         _ <- P.char comment_begin
 566         Text.pack <$> do
 567         P.manyTill P.anyChar (P.lookAhead newline <|> P.eof)
 568         <?> "comment"
 569
 570 comments :: Stream s m Char => ParsecT s u m [Comment]
 571 comments = do
 572         many_separated comment $
 573                 Text.pack <$> do
 574                 P.many1 $ P.satisfy Data.Char.isSpace
 575
 576 -- * Parsing 'Tag'
 577
 578 tag_value_sep :: Char
 579 tag_value_sep = ':'
 580
 581 tag_sep :: Char
 582 tag_sep = ','
 583
 584 -- | Parse a 'Tag'.
 585 tag :: Stream s m Char => ParsecT s u m Tag
 586 tag = do
 587         n <- tag_name
 588         _ <- P.char tag_value_sep
 589         v <- tag_value
 590         return (n, v)
 591         <?> "tag"
 592
 593 tag_name :: Stream s m Char => ParsecT s u m Tag.Name
 594 tag_name = do
 595         Text.pack <$> do
 596         P.many1 $ P.satisfy (\c -> c /= tag_value_sep && not (Data.Char.isSpace c))
 597
 598 tag_value :: Stream s m Char => ParsecT s u m Tag.Value
 599 tag_value = do
 600         Text.pack <$> do
 601         P.many $
 602                 P.satisfy (\c -> c /= tag_sep && c /= '\n')
 603
 604 tags :: Stream s m Char => ParsecT s u m Tag.By_Name
 605 tags = do
 606         Tag.from_List <$> do
 607                 many_separated tag $ do
 608                         P.skipMany $ space_horizontal
 609                         _ <- P.char tag_sep
 610                         P.skipMany $ space_horizontal
 611                         return ()
 612
 613 -- * Parsing 'Posting'
 614
 615 -- | Parse a 'Posting'.
 616 posting :: Stream s m Char => ParsecT s Context m (Posting, Posting.Type)
 617 posting = do
 618         ctx <- P.getState
 619         sourcepos <- P.getPosition
 620         P.skipMany1 $ space_horizontal
 621         status_ <- status
 622         P.skipMany $ space_horizontal
 623         (account_, type_) <- account_with_posting_type
 624         amounts_ <-
 625                 choice_try
 626                  [ do
 627                         _ <- P.count 2 (space_horizontal)
 628                         Amount.from_List <$> do
 629                                 many_separated amount $ P.try $ do
 630                                         P.skipMany $ space_horizontal
 631                                         _ <- P.char amount_sep
 632                                         P.skipMany $ space_horizontal
 633                                         return ()
 634                  , return Data.Map.empty
 635                  ]
 636         P.skipMany $ space_horizontal
 637         -- TODO: balance assertion
 638         -- TODO: conversion
 639         comments_ <- comments
 640         let tags_ = tags_of_comments comments_
 641         dates_ <-
 642                 case Data.Map.lookup "date" tags_ of
 643                  Nothing -> return []
 644                  Just dates -> do
 645                         let date2s = Data.Map.lookup "date2" tags_ -- NOTE: support hledger's date2
 646                         dates_ <- (flip mapM) (dates ++ fromMaybe [] date2s) $
 647                                 P.runParserT (date (Just $ context_year ctx) <* P.eof) () ""
 648                                 >=> \case
 649                                  Left err -> fail $ show err
 650                                  Right x -> return x
 651                         case (dates, date2s) of -- NOTE: put hledger's date2 at least in second position
 652                          ([], Just (_:_)) ->
 653                                 return $ context_date ctx:dates_
 654                          _ -> return $ dates_
 655         return (Posting.Posting
 656          { Posting.account=account_
 657          , Posting.amounts=amounts_
 658          , Posting.comments=comments_
 659          , Posting.dates=dates_
 660          , Posting.sourcepos=sourcepos
 661          , Posting.status=status_
 662          , Posting.tags=tags_
 663          }, type_)
 664         <?> "posting"
 665
 666 amount_sep :: Char
 667 amount_sep = '+'
 668
 669 tags_of_comments :: [Comment] -> Tag.By_Name
 670 tags_of_comments =
 671         Data.Map.unionsWith (++)
 672         . Data.List.map
 673          ( Data.Either.either (const Data.Map.empty) id
 674          . P.runParser (do
 675                         P.skipMany $ P.try $ do
 676                                 P.skipMany $ P.satisfy
 677                                  (\c -> c /= tag_value_sep
 678                                          && not (Data.Char.isSpace c))
 679                                 space_horizontal
 680                         tags <* P.eof)
 681                  () "" )
 682
 683 status :: Stream s m Char => ParsecT s u m Transaction.Status
 684 status =
 685         ( P.try $ do
 686                 P.skipMany $ space_horizontal
 687                 _ <- (P.char '*' <|> P.char '!') <?> "status"
 688                 return True )
 689         <|> return False
 690         <?> "status"
 691
 692 -- | Parse an 'Account' with Posting.'Posting.Type'.
 693 account_with_posting_type :: Stream s m Char => ParsecT s u m (Account, Posting.Type)
 694 account_with_posting_type = do
 695         choice_try
 696          [ (, Posting.Type_Virtual)          <$> P.between (P.char posting_type_virtual_begin)
 697                                                            (P.char posting_type_virtual_end)
 698                                                            account
 699          , (, Posting.Type_Virtual_Balanced) <$> P.between (P.char posting_type_virtual_balanced_begin)
 700                                                            (P.char posting_type_virtual_balanced_end)
 701                                                            account
 702          , (, Posting.Type_Regular)          <$> account
 703          ]
 704
 705 posting_type_virtual_begin :: Char
 706 posting_type_virtual_begin = '('
 707 posting_type_virtual_balanced_begin :: Char
 708 posting_type_virtual_balanced_begin = '['
 709 posting_type_virtual_end :: Char
 710 posting_type_virtual_end = ')'
 711 posting_type_virtual_balanced_end :: Char
 712 posting_type_virtual_balanced_end = ']'
 713
 714 -- * Parsing 'Transaction'
 715
 716 transaction :: Stream s m Char => ParsecT s Context m Transaction
 717 transaction = do
 718         sourcepos <- P.getPosition
 719         ctx <- P.getState
 720         comments_before <- comments
 721         date_ <- date (Just $ context_year ctx)
 722         dates_ <-
 723                 P.option [] $ P.try $ do
 724                         P.skipMany $ space_horizontal
 725                         _ <- P.char date_sep
 726                         P.skipMany $ space_horizontal
 727                         many_separated
 728                          (date (Just $ context_year ctx)) $
 729                                 P.try $ do
 730                                         P.many $ space_horizontal
 731                                         >> P.char date_sep
 732                                         >> (P.many $ space_horizontal)
 733         P.skipMany $ space_horizontal
 734         status_ <- status
 735         code_ <- P.option "" $ P.try code
 736         P.skipMany $ space_horizontal
 737         description_ <- description
 738         P.skipMany $ space_horizontal
 739         comments_after <- comments
 740         let tags_ =
 741                 Data.Map.unionWith (++) -- TODO: check order is preserved on equality, or flip (++)
 742                  (tags_of_comments comments_before)
 743                  (tags_of_comments comments_after)
 744         newline
 745         postings_ <- many1_separated posting newline
 746         let (postings, postings__) =
 747                 (Posting.from_List . Data.List.map fst) *** id $
 748                 Data.List.partition
 749                  ((Posting.Type_Regular ==) . snd)
 750                  postings_
 751         let (virtual_postings, balanced_virtual_postings) =
 752                 join (***) (Posting.from_List . Data.List.map fst) $
 753                 Data.List.partition
 754                  ((Posting.Type_Virtual ==) . snd)
 755                  postings__
 756         return $
 757                 Transaction.Transaction
 758                  { Transaction.code=code_
 759                  , Transaction.comments_before
 760                  , Transaction.comments_after
 761                  , Transaction.dates=(date_, dates_)
 762                  , Transaction.description=description_
 763                  , Transaction.postings
 764                  , Transaction.virtual_postings
 765                  , Transaction.balanced_virtual_postings
 766                  , Transaction.sourcepos
 767                  , Transaction.status=status_
 768                  , Transaction.tags=tags_
 769                  }
 770         <?> "transaction"
 771
 772 date_sep :: Char
 773 date_sep = '='
 774
 775 code :: Stream s m Char => ParsecT s Context m Transaction.Code
 776 code = do
 777         Text.pack <$> do
 778         P.skipMany $ space_horizontal
 779         P.between (P.char '(') (P.char ')') $
 780                 P.many $ P.satisfy (\c -> c /= ')' && not (is_space_horizontal c))
 781         <?> "code"
 782
 783 description :: Stream s m Char => ParsecT s u m Transaction.Description
 784 description = do
 785         Text.pack <$> do
 786         P.many $ P.try description_char
 787         <?> "description"
 788         where
 789                 description_char :: Stream s m Char => ParsecT s u m Char
 790                 description_char = do
 791                         c <- P.anyChar
 792                         case c of
 793                          _ | c == comment_begin -> P.parserZero
 794                          _ | is_space_horizontal c -> return c <* P.lookAhead description_char
 795                          _ | not (Data.Char.isSpace c) -> return c
 796                          _ -> P.parserZero
 797
 798 -- * Parsing directives
 799
 800 default_year :: Stream s m Char => ParsecT s Context m ()
 801 default_year = do
 802         year <- integer_of_digits 10 <$> P.many1 P.digit
 803         context_ <- P.getState
 804         P.setState context_{context_year=year}
 805
 806 default_unit_and_style :: Stream s m Char => ParsecT s Context m ()
 807 default_unit_and_style = do
 808         P.skipMany1 space_horizontal
 809         amount_ <- amount
 810         P.skipMany space_horizontal >> newline >> P.skipMany space_horizontal
 811         context_ <- P.getState
 812         P.setState context_{context_unit_and_style=Just $
 813          ( Amount.unit  amount_
 814          , Amount.style amount_ )}
 815
 816 include :: Stream s IO Char => ParsecT s Context IO ()
 817 include = do
 818         sourcepos <- P.getPosition
 819         P.skipMany1 $ space_horizontal
 820         filename <- P.manyTill P.anyChar (P.lookAhead newline <|> P.eof)
 821         context_ <- P.getState
 822         let journal_ = context_journal context_
 823         let cwd = Path.takeDirectory (P.sourceName sourcepos)
 824         file_ <- liftIO $ path_abs cwd filename
 825         (journal_included, context_included) <- liftIO $
 826                 Exception.catch
 827                  (readFile file_)
 828                  (\ko -> fail $ concat -- TODO: i18n by using a custom data type
 829                          [ show sourcepos
 830                          , " reading "
 831                          , file_
 832                          , ":\n", show (ko::Exception.IOException)
 833                          ])
 834                 >>= P.runParserT (and_state $ journal_rec file_)
 835                          context_{context_journal = Journal.nil}
 836                          file_
 837                 >>= \case
 838                  Left  ko -> fail $ show ko
 839                  Right ok -> return ok
 840         P.setState $
 841                 context_included{context_journal=
 842                         journal_{Journal.includes=
 843                                 journal_included{Journal.file=file_}
 844                                 : Journal.includes journal_}}
 845         <?> "include"
 846
 847 -- * Parsing 'Journal'
 848
 849 journal :: Stream s IO Char => FilePath -> ParsecT s Context IO Journal
 850 journal file_ = do
 851         currentLocalTime <- liftIO $
 852                 Time.utcToLocalTime
 853                 <$> Time.getCurrentTimeZone
 854                 <*> Time.getCurrentTime
 855         let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
 856         context_ <- P.getState
 857         P.setState $ context_{context_year=currentLocalYear}
 858         journal_rec file_
 859         <?> "journal"
 860
 861 journal_rec :: Stream s IO Char => FilePath -> ParsecT s Context IO Journal
 862 journal_rec file_ = do
 863         last_read_time <- liftIO $ Time.getCurrentTime
 864         P.skipMany $ do
 865                 P.skipMany1 P.space
 866                 <|> ((choice_try
 867                          [ P.string "Y" >> return default_year
 868                          , P.string "D" >> return default_unit_and_style
 869                          , P.string "!include" >> return include
 870                          ] <?> "directive") >>= id)
 871                 <|> do
 872                 t <- transaction
 873                 context_' <- P.getState
 874                 let j = context_journal context_'
 875                 P.setState $ context_'{context_journal=
 876                         j{Journal.transactions=
 877                                 Data.Map.insertWith (++)
 878                                  (Date.to_UTC $ fst $ Transaction.dates t) [t]
 879                                  (Journal.transactions j)}}
 880                 newline <|> P.eof
 881
 882         P.skipMany $ P.satisfy Data.Char.isSpace
 883         P.eof
 884         journal_ <- context_journal <$> P.getState
 885         return $
 886                 journal_
 887                  { Journal.file = file_
 888                  , Journal.last_read_time
 889                  , Journal.includes = reverse $ Journal.includes journal_
 890                  }
 891
 892 -- ** Parsing 'Journal' from a file
 893
 894 file :: FilePath -> ExceptT String IO Journal
 895 file path = do
 896         ExceptT $
 897                 Exception.catch
 898                  (liftM Right $ Text.IO.readFile path) $
 899                  \ko -> return $ Left $ show (ko::Exception.IOException)
 900         >>= liftIO . P.runParserT (journal path) nil_Context path
 901         >>= \case
 902          Left  ko -> throwE $ show ko
 903          Right ok -> ExceptT $ return $ Right ok