import Control.Applicative ((<$>), (<*>), (<*))
import qualified Control.Exception as Exception
import Control.Arrow ((***))
-import Control.Monad (guard, join, liftM, (>=>))
+import Control.Monad (guard, join, liftM)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except (ExceptT(..), throwE)
+import Control.Monad.Trans.Class (lift)
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
+ )
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
import qualified System.FilePath.Posix as Path
-import qualified Hcompta.Calc.Balance as Calc.Balance
-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 qualified Hcompta.Lib.Regex as Regex
import Hcompta.Lib.Regex (Regex)
import qualified Hcompta.Lib.Parsec as R
, context_aliases_regex = []
, context_date = Date.nil
, context_unit_and_style = Nothing
- , context_journal = Journal.nil
+ , context_journal = Ledger.journal
, context_year = (\(year, _ , _) -> year) $
Time.toGregorian $ Time.utctDay $
- Journal.last_read_time Journal.nil
+ journal_last_read_time Ledger.journal
}
--- | 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 $ 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
_ | 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 $ 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 . 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 $ R.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) $ R.try $ do
- s <- R.many $ R.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 ()
(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 $ R.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 $ R.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
_ <- R.char comment_begin
- Text.pack <$> do
+ fromString <$> do
R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
) <?> "comment"
comments :: Stream s m Char => ParsecT s u m [Comment]
comments = (do
R.try $ do
+ _ <- 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
n <- tag_name
return (n, v)
) <?> "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 R.space_horizontal >> tag_name >> R.char tag_value_sep >> return ())
<|> 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 $ R.space_horizontal
&& not (Data.Char.isSpace c))
R.space_horizontal
--- * Parsing 'Posting'
+-- * Read 'Posting'
--- | Parse a 'Posting'.
-posting :: Stream s m Char => ParsecT s Context m (Posting, Posting.Type)
+posting
+ :: (Stream s (R.Error_State Error m) Char, Monad m)
+ => ParsecT s Context (R.Error_State Error m) (Posting, Posting_Type)
posting = (do
ctx <- R.getState
sourcepos <- R.getPosition
- comments_ <- comments
R.skipMany1 $ R.space_horizontal
status_ <- status
R.skipMany $ R.space_horizontal
Unit.nil)
(context_unit_and_style ctx) .
Amount.from_List <$> do
- R.many_separated amount $ do
+ R.many_separated Amount.Read.amount $ do
R.skipMany $ R.space_horizontal
_ <- R.char amount_sep
R.skipMany $ R.space_horizontal
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) () ""
- >=> \x -> case x of
- Left ko -> fail $ show ko
- Right ok -> return ok
- case (dates, date2s) of -- NOTE: put hledger's date2 at least in second position
+ do
+ (flip mapM) (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"
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 :: Stream s m Char => ParsecT s u m Ledger.Status
status = (do
( R.try $ do
R.skipMany $ R.space_horizontal
<|> return False
) <?> "status"
--- | Return the Posting.'Posting.Type' and stripped 'Account' of the given 'Account'.
-posting_type :: Account -> (Posting.Type, Account)
+-- | 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
+ fromMaybe (Posting_Type_Regular, acct) $ do
case acct of
name:|[] ->
case Text.stripPrefix virtual_begin name of
Text.stripSuffix virtual_end name'
>>= return . Text.strip
guard $ not $ Text.null name''
- Just (Posting.Type_Virtual, name'':|[])
+ Just (Posting_Type_Virtual, name'':|[])
Nothing -> do
name' <-
Text.stripPrefix virtual_balanced_begin name
>>= Text.stripSuffix virtual_balanced_end
>>= return . Text.strip
guard $ not $ Text.null name'
- Just (Posting.Type_Virtual_Balanced, 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'
guard $ not $ Text.null first_name'
guard $ not $ Text.null last_name'
Just $
- ( Posting.Type_Virtual
+ ( Posting_Type_Virtual
, first_name':|
Data.List.reverse (last_name':Data.List.tail rev_acct')
)
guard $ not $ Text.null first_name'
guard $ not $ Text.null last_name'
Just $
- ( Posting.Type_Virtual_Balanced
+ ( Posting_Type_Virtual_Balanced
, first_name':|
Data.List.reverse (last_name':Data.List.tail rev_acct')
)
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
+ :: (Stream s (R.Error_State Error m) Char, Monad m)
+ => ParsecT s Context (R.Error_State Error m) Transaction
transaction = (do
- sourcepos <- R.getPosition
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 $ R.space_horizontal
_ <- R.char date_sep
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 $ R.space_horizontal
>> R.char date_sep
>> (R.many $ R.space_horizontal)
+ let transaction_dates = (date_, dates_)
R.skipMany $ R.space_horizontal
- status_ <- status
- code_ <- R.option "" $ R.try code
+ transaction_status <- status
+ transaction_code <- R.option "" $ R.try code
R.skipMany $ R.space_horizontal
- description_ <- description
+ transaction_description <- description
R.skipMany $ R.space_horizontal
- comments_after <- comments
- let tags_ =
+ 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_unchecked, postings_not_regular) <-
- ((Posting.from_List . Data.List.map fst) *** id) .
- Data.List.partition ((Posting.Type_Regular ==) . snd) <$>
+ ((Ledger.posting_by_Account . Data.List.map fst) *** id) .
+ Data.List.partition ((Posting_Type_Regular ==) . snd) <$>
R.many1_separated posting R.new_line
- let (virtual_postings, balanced_virtual_postings_unchecked) =
- join (***) (Posting.from_List . Data.List.map fst) $
- Data.List.partition ((Posting.Type_Virtual ==) . snd)
+ 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
- postings <-
- case Calc.Balance.infer_equilibre postings_unchecked of
- Left _l -> fail $ "transaction not-equilibrated"
- Right ps -> return ps
- balanced_virtual_postings <-
- case Calc.Balance.infer_equilibre balanced_virtual_postings_unchecked of
- Left _l -> fail $ "virtual transaction not-equilibrated"
- Right ps -> return ps
+ 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"
date_sep :: Char
date_sep = '='
-code :: Stream s m Char => ParsecT s Context m Transaction.Code
+code :: Stream s m Char => ParsecT s Context m Ledger.Code
code = (do
- Text.pack <$> do
+ fromString <$> do
R.skipMany $ R.space_horizontal
R.between (R.char '(') (R.char ')') $
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 :: Stream s m Char => ParsecT s u m Ledger.Description
description = (do
- Text.pack <$> do
+ fromString <$> do
R.many $ R.try description_char
) <?> "description"
where
_ | 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_unit_and_style :: Stream s m Char => ParsecT s Context m ()
default_unit_and_style = (do
- amount_ <- amount
+ amount_ <- Amount.Read.amount
R.skipMany R.space_horizontal >> R.new_line
context_ <- R.getState
R.setState context_{context_unit_and_style =
, Amount.style amount_ )}
) <?> "default unit and style"
-include :: Stream s IO Char => ParsecT s Context IO ()
+include
+ :: Stream s (R.Error_State Error IO) Char
+ => ParsecT s Context (R.Error_State Error IO) ()
include = (do
sourcepos <- R.getPosition
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_
+ 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
- Left ko -> fail $ show ko
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_}}
+ journal_{journal_includes=
+ journal_included{journal_file=file_path}
+ : journal_includes journal_}}
) <?> "include"
--- * Parsing 'Journal'
+-- * Read 'Journal'
-journal :: Stream s IO Char => FilePath -> ParsecT s Context IO Journal
+journal
+ :: Stream s (R.Error_State Error IO) Char
+ => FilePath
+ -> ParsecT s Context (R.Error_State Error IO) Journal
journal file_ = (do
currentLocalTime <- liftIO $
Time.utcToLocalTime
journal_rec file_
) <?> "journal"
-journal_rec :: Stream s IO Char => FilePath -> ParsecT s Context IO Journal
+journal_rec
+ :: Stream s (R.Error_State Error IO) Char
+ => FilePath
+ -> ParsecT s Context (R.Error_State Error IO) Journal
journal_rec file_ = do
- last_read_time <- liftIO $ Time.getCurrentTime
+ last_read_time <- lift $ liftIO Time.getCurrentTime
R.skipMany $ do
R.choice_try
[ R.skipMany1 R.space
context_' <- R.getState
let j = context_journal context_'
R.setState $ context_'{context_journal=
- j{Journal.transactions=
+ 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)}}
+ (fst $ transaction_dates t) [t]
+ (journal_transactions j)}}
R.new_line <|> R.eof))
, R.try (comment >> return ())
]
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
+-- ** Read 'Journal' from a file
-file :: FilePath -> ExceptT String IO Journal
+file :: FilePath -> ExceptT [R.Error Error] IO Journal
file 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
+ \ko -> return $ Left $
+ [ R.Error_Custom (R.initialPos path) $ Error_reading_file path ko ]
+ >>= liftIO . R.runParserT_with_Error (journal path) nil_Context path
>>= \x -> case x of
- Left ko -> throwE $ show ko
+ Left ko -> throwE $ ko
Right ok -> ExceptT $ return $ Right ok
sourcephile / git / comptalang.git / blobdiff