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 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 Balance
import qualified Hcompta.Model.Account as Account
import Hcompta.Model.Account (Account)
import qualified Hcompta.Model.Amount as 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.Model.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
}
+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)
+
-- | 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 id)
<|> return id
--- * Parsing 'Account'
+-- * Read 'Account'
account_name_sep :: Char
account_name_sep = ':'
-- | Parse 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
, Account.Pattern_Regex <$> (R.option '~' (R.char '~') >> account_regex)
]
--- * Parsing 'Amount'
+-- * Read 'Amount'
-- | Parse an 'Amount'.
amount :: Stream s m Char => ParsecT s u m Amount
where
unquoted :: Stream s m Char => ParsecT s u m Unit
unquoted =
- Text.pack <$> do
+ fromString <$> do
R.many1 $
R.satisfy $ \c ->
case Data.Char.generalCategory c of
_ -> False
quoted :: Stream s m Char => ParsecT s u m Unit
quoted =
- Text.pack <$> do
+ fromString <$> do
R.between (R.char '"') (R.char '"') $
R.many1 $
R.noneOf ";\n\""
(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 = ':'
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
[ do
_ <- R.count 2 R.space_horizontal
R.skipMany $ R.space_horizontal
- maybe id
- (\(u, s) -> Data.Map.adjust (\a -> a{Amount.style=s, Amount.unit=u}) Unit.nil)
+ 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 $ do
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_ <- R.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) <-
+ ((Ledger.posting_by_Account . Data.List.map fst) *** id) .
+ 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"
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
, 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