-{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
module Hcompta.Format.Ledger.Read where
-import Control.Applicative ((<$>), (<*>), (<*))
+-- import Control.Applicative ((<$>), (<*>), (<*))
import qualified Control.Exception as Exception
-import Control.Arrow ((***))
-import Control.Monad (guard, join, liftM, (>=>))
+import Control.Arrow ((***), first)
+import Control.Monad (guard, join, liftM, forM, void)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except (ExceptT(..), throwE)
import qualified Data.Char
-import qualified Data.Decimal
import qualified Data.Either
import qualified Data.List
+import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Map.Strict as Data.Map
import Data.Maybe (fromMaybe)
+import Data.String (fromString)
import qualified Data.Time.Calendar as Time
import qualified Data.Time.Clock as Time
import qualified Data.Time.LocalTime as Time
-import Data.Time.LocalTime (TimeZone(..))
import Data.Typeable ()
-import qualified Text.Parsec as R
+import qualified Text.Parsec as R hiding
+ ( char
+ , anyChar
+ , crlf
+ , newline
+ , noneOf
+ , oneOf
+ , satisfy
+ , space
+ , spaces
+ , string
+ , tab
+ )
import Text.Parsec (Stream, ParsecT, (<|>), (<?>))
+import qualified Text.Parsec.Pos as R
import qualified Data.Text.IO as Text.IO (readFile)
-import qualified Data.Text as Text (pack)
+import qualified Data.Text as Text
import qualified System.FilePath.Posix as Path
-import qualified Hcompta.Model.Account as Account
-import Hcompta.Model.Account (Account)
-import qualified Hcompta.Model.Amount as Amount
-import Hcompta.Model.Amount (Amount)
-import qualified Hcompta.Model.Amount.Style as Style
-import qualified Hcompta.Model.Amount.Unit as Unit
-import Hcompta.Model.Amount.Unit (Unit)
-import qualified Hcompta.Model.Transaction as Transaction
-import Hcompta.Model.Transaction (Transaction, Comment)
-import qualified Hcompta.Model.Transaction.Posting as Posting
-import Hcompta.Model.Transaction (Posting)
-import qualified Hcompta.Model.Transaction.Tag as Tag
-import Hcompta.Model.Transaction (Tag)
-import qualified Hcompta.Model.Date as Date
-import Hcompta.Model.Date (Date)
-import Hcompta.Format.Ledger.Journal as Journal
+import qualified Hcompta.Balance as Balance
+import qualified Hcompta.Account as Account
+import Hcompta.Account (Account)
+import qualified Hcompta.Amount as Amount
+import qualified Hcompta.Amount.Style as Style
+import qualified Hcompta.Amount.Read as Amount.Read
+import qualified Hcompta.Amount.Unit as Unit
+import qualified Hcompta.Date as Date
+import Hcompta.Date (Date)
+import qualified Hcompta.Date.Read as Date.Read
+import qualified Hcompta.Format.Ledger as Ledger
+import Hcompta.Format.Ledger
+ ( Comment
+ , Journal(..)
+ , Posting(..), Posting_Type(..)
+ , Tag, Tag_Name, Tag_Value, Tag_by_Name
+ , Transaction(..)
+ )
+import Hcompta.Lib.Consable (Consable(..))
import qualified Hcompta.Lib.Regex as Regex
import Hcompta.Lib.Regex (Regex)
-import Hcompta.Lib.Parsec as R
+import qualified Hcompta.Lib.Parsec as R
import qualified Hcompta.Lib.Path as Path
-data Context
+data Context f ts t
= Context
- { context_account_prefix :: !Account
+ { context_account_prefix :: !(Maybe Account)
, context_aliases_exact :: !(Data.Map.Map Account Account)
, context_aliases_joker :: ![(Account.Joker, Account)]
, context_aliases_regex :: ![(Regex, Account)]
, context_date :: !Date
+ , context_filter :: !f
+ , context_journal :: !(Journal (ts t))
, context_unit_and_style :: !(Maybe (Amount.Unit, Amount.Style))
- , context_journal :: !Journal
, context_year :: !Date.Year
} deriving (Show)
-nil_Context :: Context
-nil_Context =
+context
+ :: (Show f, Consable f ts t)
+ => f -> Journal (ts t) -> Context f ts t
+context flt context_journal =
Context
- { context_account_prefix = []
+ { context_account_prefix = Nothing
, context_aliases_exact = Data.Map.empty
, context_aliases_joker = []
, context_aliases_regex = []
, context_date = Date.nil
+ , context_filter = flt
+ , context_journal
, context_unit_and_style = Nothing
- , context_journal = Journal.nil
- , context_year = (\(year, _ , _) -> year) $
- Time.toGregorian $ Time.utctDay $
- Journal.last_read_time Journal.nil
+ , context_year = Date.year Date.nil
}
--- | Parse either '-' into 'negate', or '+' or '' into 'id'.
-sign :: (Stream s m Char, Num i) => ParsecT s u m (i -> i)
-sign =
- (R.char '-' >> return negate)
- <|> (R.char '+' >> return id)
- <|> return id
+data Error
+ = Error_date Date.Read.Error
+ | Error_transaction_not_equilibrated Transaction [Balance.Unit_Sum (Balance.Posting_Amount Ledger.Posting)]
+ | Error_virtual_transaction_not_equilibrated Transaction [Balance.Unit_Sum (Balance.Posting_Amount Ledger.Posting)]
+ | Error_reading_file FilePath Exception.IOException
+ | Error_including_file FilePath [R.Error Error]
+ deriving (Show)
--- * Parsing 'Account'
+-- * Read 'Account'
account_name_sep :: Char
account_name_sep = ':'
--- | Parse an 'Account'.
+-- | Read an 'Account'.
account :: Stream s m Char => ParsecT s u m Account
account = do
- R.notFollowedBy $ space_horizontal
- many1_separated account_name $ R.char account_name_sep
+ R.notFollowedBy $ R.space_horizontal
+ Account.from_List <$> do
+ R.many1_separated account_name $ R.char account_name_sep
--- | Parse an Account.'Account.Name'.
+-- | Read an Account.'Account.Name'.
account_name :: Stream s m Char => ParsecT s u m Account.Name
account_name = do
- Text.pack <$> do
+ fromString <$> do
R.many1 $ R.try account_name_char
where
account_name_char :: Stream s m Char => ParsecT s u m Char
case c of
_ | c == comment_begin -> R.parserZero
_ | c == account_name_sep -> R.parserZero
- _ | c == posting_type_virtual_end
- || c == posting_type_virtual_balanced_end ->
- return c <* (R.lookAhead $ R.try $ account_name_char)
- _ | is_space_horizontal c -> do
- _ <- R.notFollowedBy $ space_horizontal
+ _ | c /= '\t' && R.is_space_horizontal c -> do
+ _ <- R.notFollowedBy $ R.space_horizontal
return c <* (R.lookAhead $ R.try $
( R.try (R.char account_name_sep)
<|> account_name_char
_ | not (Data.Char.isSpace c) -> return c
_ -> R.parserZero
--- | Parse an Account.'Account.Joker_Name'.
+-- | Read an Account.'Account.Joker_Name'.
account_joker_name :: Stream s m Char => ParsecT s u m Account.Joker_Name
account_joker_name = do
n <- R.option Nothing $ (Just <$> account_name)
Nothing -> R.char account_name_sep >> (return $ Account.Joker_Any)
Just n' -> return $ Account.Joker_Name n'
--- | Parse an Account.'Account.Joker'.
+-- | Read an Account.'Account.Joker'.
account_joker :: Stream s m Char => ParsecT s u m Account.Joker
account_joker = do
- R.notFollowedBy $ space_horizontal
- many1_separated account_joker_name $ R.char account_name_sep
+ R.notFollowedBy $ R.space_horizontal
+ R.many1_separated account_joker_name $ R.char account_name_sep
--- | Parse a 'Regex'.
+-- | Read a 'Regex'.
account_regex :: Stream s m Char => ParsecT s u m Regex
account_regex = do
- re <- R.many1 $ R.satisfy (not . is_space_horizontal)
+ re <- R.many1 $ R.satisfy (not . R.is_space_horizontal)
Regex.of_StringM re
--- | Parse an Account.'Account.Filter'.
+-- | Read an Account.'Account.Filter'.
account_pattern :: Stream s m Char => ParsecT s u m Account.Pattern
account_pattern = do
R.choice_try
, Account.Pattern_Regex <$> (R.option '~' (R.char '~') >> account_regex)
]
--- * Parsing 'Amount'
-
--- | Parse an 'Amount'.
-amount :: Stream s m Char => ParsecT s u m Amount
-amount = do
- left_signing <- sign
- left_unit <-
- R.option Nothing $ do
- u <- unit
- s <- R.many $ space_horizontal
- return $ Just $ (u, not $ null s)
- (quantity_, style) <- do
- signing <- sign
- Quantity
- { integral
- , fractional
- , fractioning
- , grouping_integral
- , grouping_fractional
- } <-
- R.choice_try
- [ quantity '_' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
- , quantity '_' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
- , quantity ',' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._")
- , quantity '.' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._")
- ] <?> "quantity"
- let int = Data.List.concat integral
- let frac_flat = Data.List.concat fractional
- let frac = reverse $ Data.List.dropWhile (== '0') $ reverse $ frac_flat
- let place = length frac
- guard (place <= 255)
- let mantissa = R.integer_of_digits 10 $ int ++ frac
- return $
- ( Data.Decimal.Decimal
- (fromIntegral place)
- (signing mantissa)
- , Style.nil
- { Style.fractioning
- , Style.grouping_integral
- , Style.grouping_fractional
- , Style.precision = fromIntegral $ length frac_flat
- }
- )
- (unit_, unit_side, unit_spaced) <-
- case left_unit of
- Just (u, s) ->
- return (u, Just Style.Side_Left, Just s)
- Nothing ->
- R.option (Unit.nil, Nothing, Nothing) $ do
- s <- R.many $ space_horizontal
- u <- unit
- return $ (u, Just Style.Side_Right, Just $ not $ null s)
- return $
- Amount.Amount
- { Amount.quantity = left_signing $ quantity_
- , Amount.style = style
- { Style.unit_side
- , Style.unit_spaced
- }
- , Amount.unit = unit_
- }
-
-data Quantity
- = Quantity
- { integral :: [String]
- , fractional :: [String]
- , fractioning :: Maybe Style.Fractioning
- , grouping_integral :: Maybe Style.Grouping
- , grouping_fractional :: Maybe Style.Grouping
- }
-
--- | Parse a 'Quantity'.
-quantity
- :: Stream s m Char
- => Char -- ^ Integral grouping separator.
- -> Char -- ^ Fractioning separator.
- -> Char -- ^ Fractional grouping separator.
- -> ParsecT s u m Quantity
-quantity int_group_sep frac_sep frac_group_sep = do
- (integral, grouping_integral) <- do
- h <- R.many R.digit
- case h of
- [] -> return ([], Nothing)
- _ -> do
- t <- R.many $ R.char int_group_sep >> R.many1 R.digit
- let digits = h:t
- return (digits, grouping_of_digits int_group_sep digits)
- (fractional, fractioning, grouping_fractional) <-
- (case integral of
- [] -> id
- _ -> R.option ([], Nothing, Nothing)) $ do
- fractioning <- R.char frac_sep
- h <- R.many R.digit
- t <- R.many $ R.char frac_group_sep >> R.many1 R.digit
- let digits = h:t
- return (digits, Just fractioning
- , grouping_of_digits frac_group_sep $ reverse digits)
- return $
- Quantity
- { integral
- , fractional
- , fractioning
- , grouping_integral
- , grouping_fractional
- }
- where
- grouping_of_digits :: Char -> [String] -> Maybe Style.Grouping
- grouping_of_digits group_sep digits =
- case digits of
- [] -> Nothing
- [_] -> Nothing
- _ -> Just $
- Style.Grouping group_sep $
- canonicalize_grouping $
- map length $ digits
- canonicalize_grouping :: [Int] -> [Int]
- canonicalize_grouping groups =
- Data.List.foldl -- NOTE: remove duplicates at beginning and reverse.
- (\acc l0 -> case acc of
- l1:_ -> if l0 == l1 then acc else l0:acc
- _ -> l0:acc) [] $
- case groups of -- NOTE: keep only longer at beginning.
- l0:l1:t -> if l0 > l1 then groups else l1:t
- _ -> groups
-
--- | Parse an 'Unit'.
-unit :: Stream s m Char => ParsecT s u m Unit
-unit =
- (quoted <|> unquoted) <?> "unit"
- where
- unquoted :: Stream s m Char => ParsecT s u m Unit
- unquoted =
- Text.pack <$> do
- R.many1 $
- R.satisfy $ \c ->
- case Data.Char.generalCategory c of
- Data.Char.CurrencySymbol -> True
- Data.Char.LowercaseLetter -> True
- Data.Char.ModifierLetter -> True
- Data.Char.OtherLetter -> True
- Data.Char.TitlecaseLetter -> True
- Data.Char.UppercaseLetter -> True
- _ -> False
- quoted :: Stream s m Char => ParsecT s u m Unit
- quoted =
- Text.pack <$> do
- R.between (R.char '"') (R.char '"') $
- R.many1 $
- R.noneOf ";\n\""
-
-- * Directives
-directive_alias :: Stream s m Char => ParsecT s Context m ()
+directive_alias
+ :: (Consable f ts t, Stream s m Char)
+ => ParsecT s (Context f ts t) m ()
directive_alias = do
_ <- R.string "alias"
- R.skipMany1 $ space_horizontal
+ R.skipMany1 $ R.space_horizontal
pattern <- account_pattern
- R.skipMany $ space_horizontal
+ R.skipMany $ R.space_horizontal
_ <- R.char '='
- R.skipMany $ space_horizontal
+ R.skipMany $ R.space_horizontal
repl <- account
- R.skipMany $ space_horizontal
+ R.skipMany $ R.space_horizontal
case pattern of
Account.Pattern_Exact acct -> R.modifyState $ \ctx -> ctx{context_aliases_exact=
Data.Map.insert acct repl $ context_aliases_exact ctx}
(regx, repl):context_aliases_regex ctx}
return ()
--- | Parse the year, month and day separator: '/' or '-'.
-date_separator :: Stream s m Char => ParsecT s u m Char
-date_separator = R.satisfy (\c -> c == '/' || c == '-')
-
--- | Parse the hour, minute and second separator: ':'.
-hour_separator :: Stream s m Char => ParsecT s u m Char
-hour_separator = R.char ':'
-
--- * Parsing 'Date'
-
--- | Parse a 'Date' in [YYYY/]MM/DD [HH:MM[:SS][TZ]] format.
-date :: Stream s m Char => Maybe Integer -> ParsecT s u m Date
-date def_year = do
- n0 <- R.many1 R.digit
- day_sep <- date_separator
- n1 <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit
- n2 <- R.option Nothing $ R.try $ do
- _ <- R.char day_sep
- Just <$> do R.try (R.count 2 R.digit) <|> R.count 1 R.digit
- (year, m, d) <-
- case (n2, def_year) of
- (Nothing, Nothing) -> fail "year or day is missing"
- (Nothing, Just year) -> return (year, n0, n1)
- (Just d, _) -> return (R.integer_of_digits 10 n0, n1, d)
- let month = fromInteger $ R.integer_of_digits 10 m
- let day = fromInteger $ R.integer_of_digits 10 d
- guard $ month >= 1 && month <= 12
- guard $ day >= 1 && day <= 31
- day_ <- case Time.fromGregorianValid year month day of
- Nothing -> fail "invalid day"
- Just day_ -> return day_
- (hour, minu, sec, tz) <-
- R.option (0, 0, 0, Time.utc) $ R.try $ do
- R.skipMany1 $ space_horizontal
- hour <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit
- sep <- hour_separator
- minu <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit
- sec <- R.option Nothing $ R.try $ do
- _ <- R.char sep
- Just <$> (R.try (R.count 2 R.digit) <|> R.count 1 R.digit)
- -- DO: timezone
- tz <- R.option Time.utc $ R.try $ do
- R.skipMany $ space_horizontal
- time_zone
- return
- ( R.integer_of_digits 10 hour
- , R.integer_of_digits 10 minu
- , maybe 0 (R.integer_of_digits 10) sec
- , tz )
- guard $ hour >= 0 && hour <= 23
- guard $ minu >= 0 && minu <= 59
- guard $ sec >= 0 && sec <= 60 -- NOTE: allow leap second
- tod <- case Time.makeTimeOfDayValid
- (fromInteger hour)
- (fromInteger minu)
- (fromInteger sec) of
- Nothing -> fail "invalid time of day"
- Just tod -> return tod
- return $
- Time.ZonedTime
- (Time.LocalTime day_ tod)
- tz
- <?> "date"
-
-time_zone :: Stream s m Char => ParsecT s u m TimeZone
-time_zone =
- -- DOC: http://www.timeanddate.com/time/zones/
- -- TODO: only a few time zones are suported below.
- -- TODO: check the timeZoneSummerOnly values
- R.choice
- [ R.char 'A' >> R.choice
- [ R.string "ST" >> return (TimeZone ((-4) * 60) False "AST")
- , R.string "DT" >> return (TimeZone ((-3) * 60) True "ADT")
- , return (TimeZone ((-1) * 60) False "A")
- ]
- , R.char 'B' >> R.choice
- [ R.string "ST" >> return (TimeZone ((-11) * 60) False "BST")
- , R.string "DT" >> return (TimeZone ((-10) * 60) True "BDT")
- ]
- , R.char 'C' >> R.choice
- [ R.char 'E' >> R.choice
- [ R.string "T" >> return (TimeZone ((1) * 60) True "CET")
- , R.string "ST" >> return (TimeZone ((2) * 60) False "CEST")
- ]
- , R.string "ST" >> return (TimeZone ((-6) * 60) False "CST")
- , R.string "DT" >> return (TimeZone ((-5) * 60) True "CDT")
- ]
- , R.char 'E' >> R.choice
- [ R.string "ST" >> return (TimeZone ((-5) * 60) False "EST")
- , R.string "DT" >> return (TimeZone ((-4) * 60) True "EDT")
- ]
- , R.string "GMT" >> return (TimeZone 0 False "GMT")
- , R.char 'H' >> R.choice
- [ R.string "ST" >> return (TimeZone ((-10) * 60) False "HST")
- , R.string "DT" >> return (TimeZone (( -9) * 60) True "HDT")
- ]
- , R.char 'M' >> R.choice
- [ R.string "ST" >> return (TimeZone ((-7) * 60) False "MST")
- , R.string "DT" >> return (TimeZone ((-6) * 60) True "MDT")
- , return (TimeZone ((-12) * 60) False "M")
- ]
- , R.char 'N' >> R.choice
- [ R.string "ST" >> return (TimeZone ((-3) * 60 - 30) False "NST")
- , return (TimeZone (1 * 60) False "N")
- ]
- , R.char 'P' >> R.choice
- [ R.string "ST" >> return (TimeZone ((-8) * 60) False "PST")
- , R.string "DT" >> return (TimeZone ((-7) * 60) True "PDT")
- ]
- , R.char 'Y' >> R.choice
- [ R.string "ST" >> return (TimeZone ((-9) * 60) False "YST")
- , R.string "DT" >> return (TimeZone ((-8) * 60) True "YDT")
- , return (TimeZone (12 * 60) False "Y")
- ]
- , R.char 'Z' >> return (TimeZone 0 False "Z")
- , time_zone_digits
- ]
-
-time_zone_digits :: Stream s m Char => ParsecT s u m TimeZone
-{-# INLINEABLE time_zone_digits #-}
-time_zone_digits = do
- sign_ <- sign
- hour <- R.integer_of_digits 10 <$> R.count 2 R.digit
- _ <- R.option ':' (R.char ':')
- minute <- R.integer_of_digits 10 <$> R.count 2 R.digit
- let tz = TimeZone
- { timeZoneMinutes = sign_ (fromInteger hour * 60 + fromInteger minute)
- , timeZoneSummerOnly = False
- , timeZoneName = Time.timeZoneOffsetString tz
- }
- return tz
-
--- * Parsing 'Comment'
+-- * Read 'Comment'
comment_begin :: Char
comment_begin = ';'
comment :: Stream s m Char => ParsecT s u m Comment
-comment = do
+comment = (do
_ <- R.char comment_begin
- Text.pack <$> do
+ fromString <$> do
R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
- <?> "comment"
+ ) <?> "comment"
comments :: Stream s m Char => ParsecT s u m [Comment]
-comments = do
+comments = (do
R.try $ do
- R.skipMany $ R.satisfy Data.Char.isSpace
- many1_separated comment $
- Text.pack <$> do
- R.many1 $ do
- R.try space_horizontal
- <|> (R.new_line >> space_horizontal)
+ _ <- R.spaces
+ R.many1_separated comment (R.new_line >> R.skipMany R.space_horizontal)
<|> return []
+ ) <?> "comments"
--- * Parsing 'Tag'
+-- * Read 'Tag'
tag_value_sep :: Char
tag_value_sep = ':'
tag_sep :: Char
tag_sep = ','
--- | Parse a 'Tag'.
+-- | Read a 'Tag'.
tag :: Stream s m Char => ParsecT s u m Tag
-tag = do
+tag = (do
n <- tag_name
_ <- R.char tag_value_sep
v <- tag_value
return (n, v)
- <?> "tag"
+ ) <?> "tag"
-tag_name :: Stream s m Char => ParsecT s u m Tag.Name
+tag_name :: Stream s m Char => ParsecT s u m Tag_Name
tag_name = do
- Text.pack <$> do
+ fromString <$> do
R.many1 $ R.satisfy (\c -> c /= tag_value_sep && not (Data.Char.isSpace c))
-tag_value :: Stream s m Char => ParsecT s u m Tag.Value
+tag_value :: Stream s m Char => ParsecT s u m Tag_Value
tag_value = do
- Text.pack <$> do
+ fromString <$> do
R.manyTill R.anyChar $ do
R.lookAhead $ do
- R.try (R.char tag_sep >> R.many space_horizontal >> tag_name >> R.char tag_value_sep >> return ())
+ R.try (R.char tag_sep >> R.many R.space_horizontal >> tag_name >> void (R.char tag_value_sep))
<|> R.try R.new_line
<|> R.eof
-tags :: Stream s m Char => ParsecT s u m Tag.By_Name
+tags :: Stream s m Char => ParsecT s u m Tag_by_Name
tags = do
- Tag.from_List <$> do
+ Ledger.tag_by_Name <$> do
R.many_separated tag $ do
_ <- R.char tag_sep
- R.skipMany $ space_horizontal
+ R.skipMany $ R.space_horizontal
return ()
not_tag :: Stream s m Char => ParsecT s u m ()
R.skipMany $ R.satisfy
(\c -> c /= tag_value_sep
&& not (Data.Char.isSpace c))
- space_horizontal
+ R.space_horizontal
--- * Parsing 'Posting'
+-- * Read 'Posting'
--- | Parse a 'Posting'.
-posting :: Stream s m Char => ParsecT s Context m (Posting, Posting.Type)
-posting = do
+posting
+ :: (Consable f ts t, Stream s (R.Error_State Error m) Char, Monad m)
+ => ParsecT s (Context f ts t) (R.Error_State Error m) (Posting, Posting_Type)
+posting = (do
ctx <- R.getState
sourcepos <- R.getPosition
- comments_ <- comments
- R.skipMany1 $ space_horizontal
+ R.skipMany1 $ R.space_horizontal
status_ <- status
- R.skipMany $ space_horizontal
- (account_, type_) <- account_with_posting_type
+ R.skipMany $ R.space_horizontal
+ acct <- account
+ let (type_, account_) = posting_type acct
amounts_ <-
R.choice_try
[ do
- _ <- R.count 2 space_horizontal
- R.skipMany $ space_horizontal
- Amount.from_List <$> do
- R.many_separated amount $ R.try $ do
- R.skipMany $ space_horizontal
+ (void R.tab <|> void (R.count 2 R.space_horizontal))
+ R.skipMany $ R.space_horizontal
+ maybe id (\(u, s) ->
+ if u == Unit.nil then id
+ else
+ Data.Map.adjust (\a ->
+ a{ Amount.style = s{Style.precision = Style.precision $ Amount.style a}
+ , Amount.unit = u })
+ Unit.nil)
+ (context_unit_and_style ctx) .
+ Amount.from_List <$> do
+ R.many_separated Amount.Read.amount $ do
+ R.skipMany $ R.space_horizontal
_ <- R.char amount_sep
- R.skipMany $ space_horizontal
+ R.skipMany $ R.space_horizontal
return ()
, return Data.Map.empty
- ]
- R.skipMany $ space_horizontal
+ ] <?> "amounts"
+ R.skipMany $ R.space_horizontal
-- TODO: balance assertion
-- TODO: conversion
- comments__ <- (comments_ ++) <$> comments
- let tags_ = tags_of_comments comments__
+ comments_ <- comments
+ let tags_ = tags_of_comments comments_
dates_ <-
case Data.Map.lookup "date" tags_ of
Nothing -> return []
Just dates -> do
let date2s = Data.Map.lookup "date2" tags_ -- NOTE: support hledger's date2
- dates_ <- (flip mapM) (dates ++ fromMaybe [] date2s) $
- R.runParserT (date (Just $ context_year ctx) <* R.eof) () ""
- >=> \case
- Left err -> fail $ show err
- Right x -> return x
- case (dates, date2s) of -- NOTE: put hledger's date2 at least in second position
+ do
+ forM (dates ++ fromMaybe [] date2s) $ \s ->
+ R.runParserT_with_Error_fail "tag date" id
+ (Date.Read.date Error_date (Just $ context_year ctx) <* R.eof) ()
+ (Text.unpack s) s
+ >>= \dates_ -> case (dates, date2s) of -- NOTE: put hledger's date2 at least in second position
([], Just (_:_)) ->
return $ context_date ctx:dates_
_ -> return $ dates_
- return (Posting.Posting
- { Posting.account=account_
- , Posting.amounts=amounts_
- , Posting.comments=comments__
- , Posting.dates=dates_
- , Posting.sourcepos=sourcepos
- , Posting.status=status_
- , Posting.tags=tags_
+ return (Posting
+ { posting_account=account_
+ , posting_amounts=amounts_
+ , posting_comments=comments_
+ , posting_dates=dates_
+ , posting_sourcepos=sourcepos
+ , posting_status=status_
+ , posting_tags=tags_
}, type_)
- <?> "posting"
+ ) <?> "posting"
amount_sep :: Char
amount_sep = '+'
-tags_of_comments :: [Comment] -> Tag.By_Name
+tags_of_comments :: [Comment] -> Tag_by_Name
tags_of_comments =
Data.Map.unionsWith (++)
. Data.List.map
( Data.Either.either (const Data.Map.empty) id
. R.runParser (not_tag >> tags <* R.eof) () "" )
-status :: Stream s m Char => ParsecT s u m Transaction.Status
-status =
+status :: Stream s m Char => ParsecT s u m Ledger.Status
+status = (do
( R.try $ do
- R.skipMany $ space_horizontal
- _ <- (R.char '*' <|> R.char '!') <?> "status"
+ R.skipMany $ R.space_horizontal
+ _ <- (R.char '*' <|> R.char '!')
return True )
<|> return False
- <?> "status"
-
--- | Parse an 'Account' with Posting.'Posting.Type'.
-account_with_posting_type :: Stream s m Char => ParsecT s u m (Account, Posting.Type)
-account_with_posting_type = do
- R.choice_try
- [ (, Posting.Type_Virtual) <$> R.between (R.char posting_type_virtual_begin)
- (R.char posting_type_virtual_end)
- account
- , (, Posting.Type_Virtual_Balanced) <$> R.between (R.char posting_type_virtual_balanced_begin)
- (R.char posting_type_virtual_balanced_end)
- account
- , (, Posting.Type_Regular) <$> account
- ]
+ ) <?> "status"
+
+-- | Return the 'Posting_Type' and stripped 'Account' of the given 'Account'.
+posting_type :: Account -> (Posting_Type, Account)
+posting_type acct =
+ fromMaybe (Posting_Type_Regular, acct) $ do
+ case acct of
+ name:|[] ->
+ case Text.stripPrefix virtual_begin name of
+ Just name' -> do
+ name'' <- liftM Text.strip $ Text.stripSuffix virtual_end name'
+ guard $ not $ Text.null name''
+ Just (Posting_Type_Virtual, name'':|[])
+ Nothing -> do
+ name' <- liftM Text.strip $
+ Text.stripPrefix virtual_balanced_begin name
+ >>= Text.stripSuffix virtual_balanced_end
+ guard $ not $ Text.null name'
+ Just (Posting_Type_Virtual_Balanced, name':|[])
+ first_name:|acct' -> do
+ let rev_acct' = Data.List.reverse acct'
+ let last_name = Data.List.head rev_acct'
+ case liftM Text.stripStart $
+ Text.stripPrefix virtual_begin first_name of
+ Just first_name' -> do
+ last_name' <- liftM Text.stripEnd $
+ Text.stripSuffix virtual_end last_name
+ guard $ not $ Text.null first_name'
+ guard $ not $ Text.null last_name'
+ Just $
+ ( Posting_Type_Virtual
+ , first_name':|
+ Data.List.reverse (last_name':Data.List.tail rev_acct')
+ )
+ Nothing -> do
+ first_name' <- liftM Text.stripStart $
+ Text.stripPrefix virtual_balanced_begin first_name
+ last_name' <- liftM Text.stripEnd $
+ Text.stripSuffix virtual_balanced_end last_name
+ guard $ not $ Text.null first_name'
+ guard $ not $ Text.null last_name'
+ Just $
+ ( Posting_Type_Virtual_Balanced
+ , first_name':|
+ Data.List.reverse (last_name':Data.List.tail rev_acct')
+ )
+ where
+ virtual_begin = Text.singleton posting_type_virtual_begin
+ virtual_end = Text.singleton posting_type_virtual_end
+ virtual_balanced_begin = Text.singleton posting_type_virtual_balanced_begin
+ virtual_balanced_end = Text.singleton posting_type_virtual_balanced_end
posting_type_virtual_begin :: Char
posting_type_virtual_begin = '('
posting_type_virtual_balanced_end :: Char
posting_type_virtual_balanced_end = ']'
--- * Parsing 'Transaction'
+-- * Read 'Transaction'
-transaction :: Stream s m Char => ParsecT s Context m Transaction
-transaction = do
- sourcepos <- R.getPosition
+transaction
+ :: (Consable f ts t, Stream s (R.Error_State Error m) Char, Monad m)
+ => ParsecT s (Context f ts t) (R.Error_State Error m) Transaction
+transaction = (do
ctx <- R.getState
- comments_before <- comments
- date_ <- date (Just $ context_year ctx)
+ transaction_sourcepos <- R.getPosition
+ transaction_comments_before <-
+ comments
+ >>= \x -> case x of
+ [] -> return []
+ _ -> return x <* R.new_line
+ date_ <- Date.Read.date Error_date (Just $ context_year ctx)
dates_ <-
R.option [] $ R.try $ do
- R.skipMany $ space_horizontal
+ R.skipMany $ R.space_horizontal
_ <- R.char date_sep
- R.skipMany $ space_horizontal
+ R.skipMany $ R.space_horizontal
R.many_separated
- (date (Just $ context_year ctx)) $
+ (Date.Read.date Error_date (Just $ context_year ctx)) $
R.try $ do
- R.many $ space_horizontal
+ R.many $ R.space_horizontal
>> R.char date_sep
- >> (R.many $ space_horizontal)
- R.skipMany $ space_horizontal
- status_ <- status
- code_ <- R.option "" $ R.try code
- R.skipMany $ space_horizontal
- description_ <- description
- R.skipMany $ space_horizontal
- comments_after <- comments
- let tags_ =
+ >> (R.many $ R.space_horizontal)
+ let transaction_dates = (date_, dates_)
+ R.skipMany $ R.space_horizontal
+ transaction_status <- status
+ transaction_code <- R.option "" $ R.try code
+ R.skipMany $ R.space_horizontal
+ transaction_description <- description
+ R.skipMany $ R.space_horizontal
+ transaction_comments_after <- comments
+ let transaction_tags =
Data.Map.unionWith (++)
- (tags_of_comments comments_before)
- (tags_of_comments comments_after)
+ (tags_of_comments transaction_comments_before)
+ (tags_of_comments transaction_comments_after)
R.new_line
- postings_ <- many1_separated posting R.new_line
- let (postings, postings__) =
- (Posting.from_List . Data.List.map fst) *** id $
- Data.List.partition
- ((Posting.Type_Regular ==) . snd)
- postings_
- let (virtual_postings, balanced_virtual_postings) =
- join (***) (Posting.from_List . Data.List.map fst) $
- Data.List.partition
- ((Posting.Type_Virtual ==) . snd)
- postings__
+ (postings_unchecked, postings_not_regular) <-
+ first (Ledger.posting_by_Account . Data.List.map fst) .
+ Data.List.partition ((Posting_Type_Regular ==) . snd) <$>
+ R.many1_separated posting R.new_line
+ let (transaction_virtual_postings, balanced_virtual_postings_unchecked) =
+ join (***) (Ledger.posting_by_Account . Data.List.map fst) $
+ Data.List.partition ((Posting_Type_Virtual ==) . snd)
+ postings_not_regular
+ let tr_unchecked =
+ Transaction
+ { transaction_code
+ , transaction_comments_before
+ , transaction_comments_after
+ , transaction_dates
+ , transaction_description
+ , transaction_postings=postings_unchecked
+ , transaction_virtual_postings
+ , transaction_balanced_virtual_postings=balanced_virtual_postings_unchecked
+ , transaction_sourcepos
+ , transaction_status
+ , transaction_tags
+ }
+ transaction_postings <-
+ case Balance.infer_equilibrium postings_unchecked of
+ (_, Left ko) -> R.fail_with "transaction infer_equilibrium"
+ (Error_transaction_not_equilibrated tr_unchecked ko)
+ (_bal, Right ok) -> return ok
+ transaction_balanced_virtual_postings <-
+ case Balance.infer_equilibrium balanced_virtual_postings_unchecked of
+ (_, Left ko) -> R.fail_with "transaction infer_equilibrium"
+ (Error_virtual_transaction_not_equilibrated tr_unchecked ko)
+ (_bal, Right ok) -> return ok
return $
- Transaction.Transaction
- { Transaction.code=code_
- , Transaction.comments_before
- , Transaction.comments_after
- , Transaction.dates=(date_, dates_)
- , Transaction.description=description_
- , Transaction.postings
- , Transaction.virtual_postings
- , Transaction.balanced_virtual_postings
- , Transaction.sourcepos
- , Transaction.status=status_
- , Transaction.tags=tags_
+ tr_unchecked
+ { transaction_postings
+ , transaction_balanced_virtual_postings
}
- <?> "transaction"
+ ) <?> "transaction"
date_sep :: Char
date_sep = '='
-code :: Stream s m Char => ParsecT s Context m Transaction.Code
-code = do
- Text.pack <$> do
- R.skipMany $ space_horizontal
+code :: (Consable f ts t, Stream s m Char)
+ => ParsecT s (Context f ts t) m Ledger.Code
+code = (do
+ fromString <$> do
+ R.skipMany $ R.space_horizontal
R.between (R.char '(') (R.char ')') $
- R.many $ R.satisfy (\c -> c /= ')' && not (is_space_horizontal c))
- <?> "code"
+ R.many $ R.satisfy (\c -> c /= ')' && not (R.is_space_horizontal c))
+ ) <?> "code"
-description :: Stream s m Char => ParsecT s u m Transaction.Description
-description = do
- Text.pack <$> do
+description :: Stream s m Char => ParsecT s u m Ledger.Description
+description = (do
+ fromString <$> do
R.many $ R.try description_char
- <?> "description"
+ ) <?> "description"
where
description_char :: Stream s m Char => ParsecT s u m Char
description_char = do
c <- R.anyChar
case c of
_ | c == comment_begin -> R.parserZero
- _ | is_space_horizontal c -> return c <* (R.lookAhead $ R.try $ description_char)
+ _ | R.is_space_horizontal c -> return c <* (R.lookAhead $ R.try $ description_char)
_ | not (Data.Char.isSpace c) -> return c
_ -> R.parserZero
--- * Parsing directives
+-- * Read directives
-default_year :: Stream s m Char => ParsecT s Context m ()
-default_year = do
+default_year
+ :: (Consable f ts t, Stream s m Char)
+ => ParsecT s (Context f ts t) m ()
+default_year = (do
year <- R.integer_of_digits 10 <$> R.many1 R.digit
+ R.skipMany R.space_horizontal >> R.new_line
context_ <- R.getState
R.setState context_{context_year=year}
-
-default_unit_and_style :: Stream s m Char => ParsecT s Context m ()
-default_unit_and_style = do
- R.skipMany1 space_horizontal
- amount_ <- amount
- R.skipMany space_horizontal >> R.new_line >> R.skipMany space_horizontal
+ ) <?> "default year"
+
+default_unit_and_style
+ :: (Consable f ts t, Stream s m Char)
+ => ParsecT s (Context f ts t) m ()
+default_unit_and_style = (do
+ amount_ <- Amount.Read.amount
+ R.skipMany R.space_horizontal >> R.new_line
context_ <- R.getState
- R.setState context_{context_unit_and_style=Just $
- ( Amount.unit amount_
- , Amount.style amount_ )}
-
-include :: Stream s IO Char => ParsecT s Context IO ()
-include = do
+ R.setState context_{context_unit_and_style =
+ Just $
+ ( Amount.unit amount_
+ , Amount.style amount_ )}
+ ) <?> "default unit and style"
+
+include ::
+ ( Consable f ts Transaction
+ , Show f
+ , Show (ts Transaction)
+ , Stream s (R.Error_State Error IO) Char
+ )
+ => ParsecT s (Context f ts Transaction) (R.Error_State Error IO) ()
+include = (do
sourcepos <- R.getPosition
- R.skipMany1 $ space_horizontal
filename <- R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
context_ <- R.getState
let journal_ = context_journal context_
let cwd = Path.takeDirectory (R.sourceName sourcepos)
- file_ <- liftIO $ Path.abs cwd filename
- (journal_included, context_included) <- liftIO $
- Exception.catch
- (readFile file_)
- (\ko -> fail $ concat -- TODO: i18n by using a custom data type
- [ show sourcepos
- , " reading "
- , file_
- , ":\n", show (ko::Exception.IOException)
- ])
- >>= R.runParserT (R.and_state $ journal_rec file_)
- context_{context_journal = Journal.nil}
- file_
- >>= \case
- Left ko -> fail $ show ko
+ file_path <- liftIO $ Path.abs cwd filename
+ content <- do
+ join $ liftIO $ Exception.catch
+ (liftM return $ readFile file_path)
+ (return . R.fail_with "include reading" . Error_reading_file file_path)
+ (journal_included, context_included) <- do
+ liftIO $
+ R.runParserT_with_Error (R.and_state $ journal_rec file_path)
+ context_{context_journal = Ledger.journal}
+ file_path content
+ >>= \x -> case x of
Right ok -> return ok
+ Left ko -> R.fail_with "include parsing" (Error_including_file file_path ko)
R.setState $
context_included{context_journal=
- journal_{Journal.includes=
- journal_included{Journal.file=file_}
- : Journal.includes journal_}}
- <?> "include"
-
--- * Parsing 'Journal'
-
-journal :: Stream s IO Char => FilePath -> ParsecT s Context IO Journal
-journal file_ = do
+ journal_{journal_includes=
+ journal_included{journal_file=file_path}
+ : journal_includes journal_}}
+ ) <?> "include"
+
+-- * Read 'Journal'
+
+journal ::
+ ( Consable f ts Transaction
+ , Show f
+ , Show (ts Transaction)
+ , Stream s (R.Error_State Error IO) Char
+ )
+ => FilePath
+ -> ParsecT s (Context f ts Transaction) (R.Error_State Error IO) (Journal (ts Transaction))
+journal file_ = (do
currentLocalTime <- liftIO $
Time.utcToLocalTime
<$> Time.getCurrentTimeZone
<*> Time.getCurrentTime
let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
- context_ <- R.getState
- R.setState $ context_{context_year=currentLocalYear}
+ ctx <- R.getState
+ R.setState $ ctx{context_year=currentLocalYear}
journal_rec file_
- <?> "journal"
-
-journal_rec :: Stream s IO Char => FilePath -> ParsecT s Context IO Journal
+ ) <?> "journal"
+
+journal_rec ::
+ ( Consable f ts Transaction
+ , Show f
+ , Show (ts Transaction)
+ , Stream s (R.Error_State Error IO) Char
+ )
+ => FilePath
+ -> ParsecT s (Context f ts Transaction) (R.Error_State Error IO) (Journal (ts Transaction))
journal_rec file_ = do
- last_read_time <- liftIO $ Time.getCurrentTime
+ last_read_time <- liftIO Date.now
R.skipMany $ do
- R.skipMany1 R.space
- <|> ((R.choice_try
- [ R.string "Y" >> return default_year
- , R.string "D" >> return default_unit_and_style
+ R.choice_try
+ [ R.skipMany1 R.space
+ , (do (R.choice_try
+ [ R.string "Y" >> return default_year
+ , R.string "D" >> return default_unit_and_style
, R.string "!include" >> return include
- ] <?> "directive") >>= id)
- <|> do
- t <- transaction
- context_' <- R.getState
- let j = context_journal context_'
- R.setState $ context_'{context_journal=
- j{Journal.transactions=
- Data.Map.insertWith (flip (++))
- -- NOTE: flip-ing preserves order but slows down
- -- when many transactions have the very same date.
- (Date.to_UTC $ fst $ Transaction.dates t) [t]
- (Journal.transactions j)}}
- R.new_line <|> R.eof
-
- R.skipMany $ R.satisfy Data.Char.isSpace
+ ] <?> "directive")
+ >>= \r -> R.skipMany1 R.space_horizontal >> r)
+ , ((do
+ t <- transaction
+ ctx <- R.getState
+ let j = context_journal ctx
+ R.setState $
+ ctx{context_journal=
+ j{journal_transactions=
+ mcons (context_filter ctx) t $
+ journal_transactions j}}
+ R.new_line <|> R.eof))
+ , R.try (void $ comment)
+ ]
R.eof
journal_ <- context_journal <$> R.getState
return $
journal_
- { Journal.file = file_
- , Journal.last_read_time
- , Journal.includes = reverse $ Journal.includes journal_
+ { journal_file = file_
+ , journal_last_read_time = last_read_time
+ , journal_includes = reverse $ journal_includes journal_
}
--- ** Parsing 'Journal' from a file
-
-file :: FilePath -> ExceptT String IO Journal
-file path = do
+-- ** Read 'Journal' from a file
+
+file
+ ::
+ ( Consable f ts Transaction
+ , Show f
+ , Show (ts Transaction)
+ )
+ => Context f ts Transaction
+ -> FilePath
+ -> ExceptT [R.Error Error] IO (Journal (ts Transaction))
+file ctx path = do
ExceptT $
Exception.catch
(liftM Right $ Text.IO.readFile path) $
- \ko -> return $ Left $ show (ko::Exception.IOException)
- >>= liftIO . R.runParserT (journal path) nil_Context path
- >>= \case
- Left ko -> throwE $ show ko
+ \ko -> return $ Left $
+ [ R.Error_Custom (R.initialPos path) $ Error_reading_file path ko ]
+ >>= liftIO . R.runParserT_with_Error (journal path) ctx path
+ >>= \x -> case x of
+ Left ko -> throwE $ ko
Right ok -> ExceptT $ return $ Right ok