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 qualified Data.Time.Calendar as Time
import qualified Text.Parsec as R
import Text.Parsec (Stream, ParsecT, (<|>), (<?>))
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.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.Format.Ledger.Journal as Journal
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
-- | 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
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
+ _ | 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 $
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}
-- | 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 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 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
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
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
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.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 = do
Text.pack <$> 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
Tag.from_List <$> 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 = (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
+ _ <- 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
, Posting.status=status_
, Posting.tags=tags_
}, type_)
- <?> "posting"
+ ) <?> "posting"
amount_sep :: Char
amount_sep = '+'
. R.runParser (not_tag >> tags <* R.eof) () "" )
status :: Stream s m Char => ParsecT s u m Transaction.Status
-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.'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'' <-
+ Text.stripSuffix virtual_end name'
+ >>= return . Text.strip
+ guard $ not $ Text.null 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':|[])
+ first_name:|acct' -> do
+ let rev_acct' = Data.List.reverse acct'
+ let last_name = Data.List.head rev_acct'
+ case Text.stripPrefix virtual_begin first_name
+ >>= return . Text.stripStart of
+ Just first_name' -> do
+ last_name' <-
+ Text.stripSuffix virtual_end last_name
+ >>= return . Text.stripEnd
+ 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' <-
+ Text.stripPrefix virtual_balanced_begin first_name
+ >>= return . Text.stripStart
+ last_name' <-
+ Text.stripSuffix virtual_balanced_end last_name
+ >>= return . Text.stripEnd
+ 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 = '('
-- * Parsing 'Transaction'
transaction :: Stream s m Char => ParsecT s Context m Transaction
-transaction = do
+transaction = (do
sourcepos <- R.getPosition
ctx <- R.getState
comments_before <- comments
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
+ >> (R.many $ R.space_horizontal)
+ R.skipMany $ R.space_horizontal
status_ <- status
code_ <- R.option "" $ R.try code
- R.skipMany $ space_horizontal
+ R.skipMany $ R.space_horizontal
description_ <- description
- R.skipMany $ space_horizontal
+ R.skipMany $ R.space_horizontal
comments_after <- comments
let tags_ =
Data.Map.unionWith (++)
(tags_of_comments comments_before)
(tags_of_comments 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) =
+ (postings_unchecked, postings_not_regular) <-
+ ((Posting.from_List . 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)
- postings__
+ 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
return $
Transaction.Transaction
{ Transaction.code=code_
, Transaction.status=status_
, Transaction.tags=tags_
}
- <?> "transaction"
+ ) <?> "transaction"
date_sep :: Char
date_sep = '='
code :: Stream s m Char => ParsecT s Context m Transaction.Code
-code = do
+code = (do
Text.pack <$> do
- R.skipMany $ space_horizontal
+ 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
+description = (do
Text.pack <$> 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_ )}
+ R.setState context_{context_unit_and_style =
+ Just $
+ ( Amount.unit amount_
+ , Amount.style amount_ )}
+ ) <?> "default unit and style"
include :: Stream s IO Char => ParsecT s Context IO ()
-include = do
+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_
journal_{Journal.includes=
journal_included{Journal.file=file_}
: Journal.includes journal_}}
- <?> "include"
+ ) <?> "include"
-- * Parsing 'Journal'
journal :: Stream s IO Char => FilePath -> ParsecT s Context IO Journal
-journal file_ = do
+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 file_ = do
last_read_time <- 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 $
sourcephile / git / comptalang.git / blobdiff