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.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 Hcompta.Lib.Parsec as R
+import qualified Hcompta.Lib.Parsec as R
import qualified Hcompta.Lib.Path as Path
data Context
, 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_year_or_day_is_missing
+ | Error_invalid_date (Integer, Int, Int)
+ | Error_invalid_time_of_day (Int, Int, Integer)
+ | 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 =
-- | Parse an 'Account'.
account :: Stream s m Char => ParsecT s u m Account
account = do
- R.notFollowedBy $ space_horizontal
+ R.notFollowedBy $ R.space_horizontal
Account.from_List <$> do
- many1_separated account_name $ R.char account_name_sep
+ R.many1_separated account_name $ R.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
case c of
_ | c == comment_begin -> R.parserZero
_ | c == account_name_sep -> R.parserZero
- _ | is_space_horizontal c -> do
- _ <- R.notFollowedBy $ space_horizontal
+ _ | 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
-- | Parse 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'.
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'.
left_unit <-
R.option Nothing $ do
u <- unit
- s <- R.many $ space_horizontal
+ s <- R.many $ R.space_horizontal
return $ Just $ (u, not $ null s)
(quantity_, style) <- do
signing <- sign
Just (u, s) ->
return (u, Just Style.Side_Left, Just s)
Nothing ->
- R.option (Unit.nil, Nothing, Nothing) $ do
- s <- R.many $ space_horizontal
+ 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 $
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\""
directive_alias :: Stream s m Char => ParsecT s Context 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}
-- * 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
+date
+ :: (Stream s (R.Error_State Error m) Char, Monad m)
+ => Maybe Integer -> ParsecT s u (R.Error_State Error 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
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, Nothing) -> R.fail_with "date" (Error_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
guard $ month >= 1 && month <= 12
guard $ day >= 1 && day <= 31
day_ <- case Time.fromGregorianValid year month day of
- Nothing -> fail "invalid day"
+ Nothing -> R.fail_with "date" (Error_invalid_date (year, month, day))
Just day_ -> return day_
(hour, minu, sec, tz) <-
R.option (0, 0, 0, Time.utc) $ R.try $ do
- R.skipMany1 $ space_horizontal
+ 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 $ space_horizontal
+ R.skipMany $ R.space_horizontal
time_zone
return
- ( R.integer_of_digits 10 hour
- , R.integer_of_digits 10 minu
+ ( fromInteger $ R.integer_of_digits 10 hour
+ , fromInteger $ 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"
+ tod <- case Time.makeTimeOfDayValid hour minu (fromInteger sec) of
+ Nothing -> R.fail_with "date" (Error_invalid_time_of_day (hour, minu, sec))
Just tod -> return tod
return $
Time.ZonedTime
(Time.LocalTime day_ tod)
tz
- <?> "date"
+ ) <?> "date"
time_zone :: Stream s m Char => ParsecT s u m TimeZone
time_zone =
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'
-- | Parse 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 >> 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 $ 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'
-- | Parse a 'Posting'.
-posting :: Stream s m Char => ParsecT s Context m (Posting, Posting.Type)
-posting = do
+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 $ space_horizontal
+ R.skipMany1 $ R.space_horizontal
status_ <- status
- R.skipMany $ space_horizontal
+ 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
+ _ <- 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 $ 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) () ""
- >=> \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"
+ (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"
+ ) <?> "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')
)
-- * Parsing 'Transaction'
-transaction :: Stream s m Char => ParsecT s Context m Transaction
-transaction = do
- sourcepos <- R.getPosition
+transaction
+ :: (Stream s (R.Error_State Error m) Char, Monad m)
+ => ParsecT s Context (R.Error_State Error m) Transaction
+transaction = (do
ctx <- R.getState
- comments_before <- comments
+ transaction_sourcepos <- R.getPosition
+ transaction_comments_before <-
+ comments
+ >>= \x -> case x of
+ [] -> return []
+ _ -> return x <* R.new_line
date_ <- 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)) $
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) <-
+ ((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"
+ ) <?> "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 :: Stream s m Char => ParsecT s Context 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
default_year :: Stream s m Char => ParsecT s Context m ()
-default_year = do
+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 year"
default_unit_and_style :: Stream s m Char => ParsecT s Context m ()
-default_unit_and_style = do
- R.skipMany1 space_horizontal
+default_unit_and_style = (do
amount_ <- amount
- R.skipMany space_horizontal >> R.new_line >> R.skipMany space_horizontal
+ 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
+ :: Stream s (R.Error_State Error IO) Char
+ => ParsecT s Context (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_
+ file_path <- liftIO $ Path.abs cwd filename
+ content <- do
+ liftIO $ Exception.catch
+ (liftM return $ readFile file_path)
+ (return . R.fail_with "include reading" . Error_reading_file file_path)
+ >>= id
+ (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_}}
- <?> "include"
+ journal_{journal_includes=
+ journal_included{journal_file=file_path}
+ : journal_includes journal_}}
+ ) <?> "include"
-- * Parsing 'Journal'
-journal :: Stream s IO Char => FilePath -> ParsecT s Context IO Journal
-journal file_ = do
+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
<$> Time.getCurrentTimeZone
context_ <- R.getState
R.setState $ context_{context_year=currentLocalYear}
journal_rec file_
- <?> "journal"
+ ) <?> "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.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
+ 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.try (comment >> return ())
+ ]
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 :: 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