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