{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoMonoLocalBinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Functor law" #-}
module Hledger.Read.Common (
Reader (..),
InputOpts(..),
HasInputOpts(..),
definputopts,
rawOptsToInputOpts,
parseAndFinaliseJournal,
initialiseAndParseJournal,
journalFinalise,
journalAddForecast,
journalAddAutoPostings,
setYear,
getYear,
setDefaultCommodityAndStyle,
getDefaultCommodityAndStyle,
getDefaultAmountStyle,
getAmountStyle,
addDeclaredAccountTags,
addDeclaredAccountType,
pushParentAccount,
popParentAccount,
getParentAccount,
addAccountAlias,
getAccountAliases,
clearAccountAliases,
journalAddFile,
statusp,
codep,
descriptionp,
datep,
datetimep,
secondarydatep,
modifiedaccountnamep,
accountnamep,
accountaliasp,
spaceandamountormissingp,
amountp,
amountp',
commoditysymbolp,
costp,
balanceassertionp,
lotcostp,
numberp,
fromRawNumber,
rawnumberp,
parseamount,
parseamount',
parsemixedamount,
parsemixedamount',
isLineCommentStart,
isSameLineCommentStart,
multilinecommentp,
emptyorcommentlinep,
emptyorcommentlinep2,
followingcommentp,
transactioncommentp,
commentlinetagsp,
postingcommentp,
bracketeddatetagsp,
doublequotedtextp,
noncommenttextp,
noncommenttext1p,
singlespacedtext1p,
singlespacednoncommenttext1p,
singlespacedtextsatisfying1p,
singlespacep,
skipNonNewlineSpaces,
skipNonNewlineSpaces1,
aliasesFromOpts,
tests_Common,
)
where
import Control.Applicative.Permutations (runPermutation, toPermutationWithDefault)
import Control.Monad (foldM, liftM2, when, unless, (>=>), (<=<))
import qualified Control.Monad.Fail as Fail (fail)
import Control.Monad.Except (ExceptT(..), liftEither, withExceptT)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.State.Strict (MonadState, evalStateT, modify', get, put)
import Control.Monad.Trans.Class (lift)
import Data.Bifunctor (bimap, second)
import Data.Char (digitToInt, isDigit, isSpace)
import Data.Decimal (DecimalRaw (Decimal), Decimal)
import Data.Either (rights)
import Data.Function ((&))
import Data.Functor ((<&>), ($>), void)
import Data.List (find, genericReplicate, union)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (catMaybes, fromMaybe, isJust, listToMaybe)
import qualified Data.Map as M
import qualified Data.Semigroup as Sem
import Data.Text (Text, stripEnd)
import qualified Data.Text as T
import Data.Time.Calendar (Day, fromGregorianValid, toGregorian)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.Time.LocalTime (LocalTime(..), TimeOfDay(..))
import Data.Word (Word8)
import System.FilePath (takeFileName)
import Text.Megaparsec
import Text.Megaparsec.Char (char, char', digitChar, newline, string)
import Text.Megaparsec.Char.Lexer (decimal)
import Hledger.Data
import Hledger.Query (Query(..), filterQuery, parseQueryTerm, queryEndDate, queryStartDate, queryIsDate, simplifyQuery)
import Hledger.Reports.ReportOptions (ReportOpts(..), queryFromFlags, rawOptsToReportOpts)
import Hledger.Utils
import Hledger.Read.InputOptions
data Reader m = Reader {
forall (m :: * -> *). Reader m -> StorageFormat
rFormat :: StorageFormat
,forall (m :: * -> *). Reader m -> [[Char]]
rExtensions :: [String]
,forall (m :: * -> *).
Reader m
-> InputOpts -> [Char] -> Text -> ExceptT [Char] IO Journal
rReadFn :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal
,forall (m :: * -> *).
Reader m -> MonadIO m => ErroringJournalParser m Journal
rParser :: MonadIO m => ErroringJournalParser m ParsedJournal
}
instance Show (Reader m) where show :: Reader m -> [Char]
show Reader m
r = StorageFormat -> [Char]
forall a. Show a => a -> [Char]
show (Reader m -> StorageFormat
forall (m :: * -> *). Reader m -> StorageFormat
rFormat Reader m
r) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" reader"
rawOptsToInputOpts :: Day -> Bool -> Bool -> RawOpts -> InputOpts
rawOptsToInputOpts :: Day -> Bool -> Bool -> RawOpts -> InputOpts
rawOptsToInputOpts Day
day Bool
usecoloronstdout Bool
postingaccttags RawOpts
rawopts =
let noinferbalancingcosts :: Bool
noinferbalancingcosts = [Char] -> RawOpts -> Bool
boolopt [Char]
"strict" RawOpts
rawopts Bool -> Bool -> Bool
|| [Char] -> RawOpts -> [Char]
stringopt [Char]
"args" RawOpts
rawopts [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"balanced"
ropts :: ReportOpts
ropts = Day -> Bool -> RawOpts -> ReportOpts
rawOptsToReportOpts Day
day Bool
usecoloronstdout RawOpts
rawopts
argsquery :: [Query]
argsquery = ((Query, [QueryOpt]) -> Query) -> [(Query, [QueryOpt])] -> [Query]
forall a b. (a -> b) -> [a] -> [b]
map (Query, [QueryOpt]) -> Query
forall a b. (a, b) -> a
fst ([(Query, [QueryOpt])] -> [Query])
-> ([Text] -> [(Query, [QueryOpt])]) -> [Text] -> [Query]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either [Char] (Query, [QueryOpt])] -> [(Query, [QueryOpt])]
forall a b. [Either a b] -> [b]
rights ([Either [Char] (Query, [QueryOpt])] -> [(Query, [QueryOpt])])
-> ([Text] -> [Either [Char] (Query, [QueryOpt])])
-> [Text]
-> [(Query, [QueryOpt])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Either [Char] (Query, [QueryOpt]))
-> [Text] -> [Either [Char] (Query, [QueryOpt])]
forall a b. (a -> b) -> [a] -> [b]
map (Day -> Text -> Either [Char] (Query, [QueryOpt])
parseQueryTerm Day
day) ([Text] -> [Query]) -> [Text] -> [Query]
forall a b. (a -> b) -> a -> b
$ ReportOpts -> [Text]
querystring_ ReportOpts
ropts
datequery :: Query
datequery = Query -> Query
simplifyQuery (Query -> Query) -> ([Query] -> Query) -> [Query] -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Query -> Bool) -> Query -> Query
filterQuery Query -> Bool
queryIsDate (Query -> Query) -> ([Query] -> Query) -> [Query] -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Query] -> Query
And ([Query] -> Query) -> [Query] -> Query
forall a b. (a -> b) -> a -> b
$ ReportOpts -> Query
queryFromFlags ReportOpts
ropts Query -> [Query] -> [Query]
forall a. a -> [a] -> [a]
: [Query]
argsquery
styles :: Map Text AmountStyle
styles = ([Char] -> Map Text AmountStyle)
-> (Map Text AmountStyle -> Map Text AmountStyle)
-> Either [Char] (Map Text AmountStyle)
-> Map Text AmountStyle
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> Map Text AmountStyle
forall {a}. [Char] -> a
err Map Text AmountStyle -> Map Text AmountStyle
forall a. a -> a
id (Either [Char] (Map Text AmountStyle) -> Map Text AmountStyle)
-> Either [Char] (Map Text AmountStyle) -> Map Text AmountStyle
forall a b. (a -> b) -> a -> b
$ RawOpts -> Either [Char] (Map Text AmountStyle)
commodityStyleFromRawOpts RawOpts
rawopts
where err :: [Char] -> a
err [Char]
e = [Char] -> a
forall {a}. [Char] -> a
error' ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [Char]
"could not parse commodity-style: '" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
e [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"'"
in InputOpts
definputopts{
mformat_ = Nothing
,mrules_file_ = maybestringopt "rules" rawopts
,aliases_ = listofstringopt "alias" rawopts
,anon_ = boolopt "obfuscate" rawopts
,new_ = boolopt "new" rawopts
,new_save_ = True
,pivot_ = stringopt "pivot" rawopts
,forecast_ = forecastPeriodFromRawOpts day rawopts
,posting_account_tags_ = postingaccttags
,verbose_tags_ = boolopt "verbose-tags" rawopts
,reportspan_ = DateSpan (Exact <$> queryStartDate False datequery) (Exact <$> queryEndDate False datequery)
,auto_ = boolopt "auto" rawopts
,infer_equity_ = boolopt "infer-equity" rawopts && conversionop_ ropts /= Just ToCost
,infer_costs_ = boolopt "infer-costs" rawopts
,balancingopts_ = defbalancingopts{
ignore_assertions_ = boolopt "ignore-assertions" rawopts
, infer_balancing_costs_ = not noinferbalancingcosts
, commodity_styles_ = Just styles
}
,strict_ = boolopt "strict" rawopts
,_ioDay = day
}
forecastPeriodFromRawOpts :: Day -> RawOpts -> Maybe DateSpan
forecastPeriodFromRawOpts :: Day -> RawOpts -> Maybe DateSpan
forecastPeriodFromRawOpts Day
d RawOpts
rawopts = do
arg <- [Char] -> RawOpts -> Maybe [Char]
maybestringopt [Char]
"forecast" RawOpts
rawopts
let period = Day -> Text -> Either HledgerParseErrors (Interval, DateSpan)
parsePeriodExpr Day
d (Text -> Either HledgerParseErrors (Interval, DateSpan))
-> (Text -> Text)
-> Text
-> Either HledgerParseErrors (Interval, DateSpan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
stripquotes (Text -> Either HledgerParseErrors (Interval, DateSpan))
-> Text -> Either HledgerParseErrors (Interval, DateSpan)
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
arg
return $ if null arg then nulldatespan else either badParse (getSpan arg) period
where
badParse :: HledgerParseErrors -> a
badParse HledgerParseErrors
e = [Char] -> a
forall {a}. [Char] -> a
usageError ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [Char]
"could not parse forecast period : "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++HledgerParseErrors -> [Char]
customErrorBundlePretty HledgerParseErrors
e
getSpan :: [Char] -> (Interval, b) -> b
getSpan [Char]
arg (Interval
interval, b
requestedspan) = case Interval
interval of
Interval
NoInterval -> b
requestedspan
Interval
_ -> [Char] -> b
forall {a}. [Char] -> a
usageError ([Char] -> b) -> [Char] -> b
forall a b. (a -> b) -> a -> b
$ [Char]
"--forecast's argument should not contain a report interval ("
[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Interval -> [Char]
forall a. Show a => a -> [Char]
show Interval
interval [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" in \"" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
arg [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\")"
commodityStyleFromRawOpts :: RawOpts -> Either String (M.Map CommoditySymbol AmountStyle)
commodityStyleFromRawOpts :: RawOpts -> Either [Char] (Map Text AmountStyle)
commodityStyleFromRawOpts RawOpts
rawOpts =
(Map Text AmountStyle
-> [Char] -> Either [Char] (Map Text AmountStyle))
-> Map Text AmountStyle
-> [[Char]]
-> Either [Char] (Map Text AmountStyle)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Map Text AmountStyle
r -> ((Text, AmountStyle) -> Map Text AmountStyle)
-> Either [Char] (Text, AmountStyle)
-> Either [Char] (Map Text AmountStyle)
forall a b. (a -> b) -> Either [Char] a -> Either [Char] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Text
c,AmountStyle
a) -> Text -> AmountStyle -> Map Text AmountStyle -> Map Text AmountStyle
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
c AmountStyle
a Map Text AmountStyle
r) (Either [Char] (Text, AmountStyle)
-> Either [Char] (Map Text AmountStyle))
-> ([Char] -> Either [Char] (Text, AmountStyle))
-> [Char]
-> Either [Char] (Map Text AmountStyle)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Either [Char] (Text, AmountStyle)
parseCommodity) Map Text AmountStyle
forall a. Monoid a => a
mempty [[Char]]
optList
where
optList :: [[Char]]
optList = [Char] -> RawOpts -> [[Char]]
listofstringopt [Char]
"commodity-style" RawOpts
rawOpts
parseCommodity :: [Char] -> Either [Char] (Text, AmountStyle)
parseCommodity [Char]
optStr = case [Char] -> Either HledgerParseErrors Amount
parseamount [Char]
optStr of
Left HledgerParseErrors
_ -> [Char] -> Either [Char] (Text, AmountStyle)
forall a b. a -> Either a b
Left [Char]
optStr
Right (Amount Text
acommodity Quantity
_ AmountStyle
astyle Maybe AmountCost
_) -> (Text, AmountStyle) -> Either [Char] (Text, AmountStyle)
forall a b. b -> Either a b
Right (Text
acommodity, AmountStyle
astyle)
parseAndFinaliseJournal :: ErroringJournalParser IO ParsedJournal -> InputOpts
-> FilePath -> Text -> ExceptT String IO Journal
parseAndFinaliseJournal :: ErroringJournalParser IO Journal
-> InputOpts -> [Char] -> Text -> ExceptT [Char] IO Journal
parseAndFinaliseJournal ErroringJournalParser IO Journal
parser InputOpts
iopts [Char]
f Text
txt =
ErroringJournalParser IO Journal
-> InputOpts -> [Char] -> Text -> ExceptT [Char] IO Journal
initialiseAndParseJournal ErroringJournalParser IO Journal
parser InputOpts
iopts [Char]
f Text
txt ExceptT [Char] IO Journal
-> (Journal -> ExceptT [Char] IO Journal)
-> ExceptT [Char] IO Journal
forall a b.
ExceptT [Char] IO a
-> (a -> ExceptT [Char] IO b) -> ExceptT [Char] IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InputOpts -> [Char] -> Text -> Journal -> ExceptT [Char] IO Journal
journalFinalise InputOpts
iopts [Char]
f Text
txt
initialiseAndParseJournal :: ErroringJournalParser IO ParsedJournal -> InputOpts
-> FilePath -> Text -> ExceptT String IO Journal
initialiseAndParseJournal :: ErroringJournalParser IO Journal
-> InputOpts -> [Char] -> Text -> ExceptT [Char] IO Journal
initialiseAndParseJournal ErroringJournalParser IO Journal
parser InputOpts
iopts [Char]
f Text
txt =
ExceptT FinalParseError IO (Either HledgerParseErrors Journal)
-> ExceptT [Char] IO Journal
forall a.
ExceptT FinalParseError IO (Either HledgerParseErrors a)
-> ExceptT [Char] IO a
prettyParseErrors (ExceptT FinalParseError IO (Either HledgerParseErrors Journal)
-> ExceptT [Char] IO Journal)
-> ExceptT FinalParseError IO (Either HledgerParseErrors Journal)
-> ExceptT [Char] IO Journal
forall a b. (a -> b) -> a -> b
$ ParsecT
HledgerParseErrorData Text (ExceptT FinalParseError IO) Journal
-> [Char]
-> Text
-> ExceptT FinalParseError IO (Either HledgerParseErrors Journal)
forall (m :: * -> *) e s a.
Monad m =>
ParsecT e s m a
-> [Char] -> s -> m (Either (ParseErrorBundle s e) a)
runParserT (ErroringJournalParser IO Journal
-> Journal
-> ParsecT
HledgerParseErrorData Text (ExceptT FinalParseError IO) Journal
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT ErroringJournalParser IO Journal
parser Journal
initJournal) [Char]
f Text
txt
where
y :: Integer
y = (Integer, Int, Int) -> Integer
forall {a} {b} {c}. (a, b, c) -> a
first3 ((Integer, Int, Int) -> Integer)
-> (Day -> (Integer, Int, Int)) -> Day -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> (Integer, Int, Int)
toGregorian (Day -> Integer) -> Day -> Integer
forall a b. (a -> b) -> a -> b
$ InputOpts -> Day
_ioDay InputOpts
iopts
initJournal :: Journal
initJournal = Journal
nulljournal{jparsedefaultyear = Just y, jincludefilestack = [f]}
prettyParseErrors :: ExceptT FinalParseError IO (Either (ParseErrorBundle Text HledgerParseErrorData) a)
-> ExceptT String IO a
prettyParseErrors :: forall a.
ExceptT FinalParseError IO (Either HledgerParseErrors a)
-> ExceptT [Char] IO a
prettyParseErrors = (HledgerParseErrors -> [Char])
-> ExceptT HledgerParseErrors IO a -> ExceptT [Char] IO a
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT HledgerParseErrors -> [Char]
customErrorBundlePretty (ExceptT HledgerParseErrors IO a -> ExceptT [Char] IO a)
-> (Either HledgerParseErrors a -> ExceptT HledgerParseErrors IO a)
-> Either HledgerParseErrors a
-> ExceptT [Char] IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either HledgerParseErrors a -> ExceptT HledgerParseErrors IO a
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
(Either HledgerParseErrors a -> ExceptT [Char] IO a)
-> (ExceptT FinalParseError IO (Either HledgerParseErrors a)
-> ExceptT [Char] IO (Either HledgerParseErrors a))
-> ExceptT FinalParseError IO (Either HledgerParseErrors a)
-> ExceptT [Char] IO a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (FinalParseError -> [Char])
-> ExceptT FinalParseError IO (Either HledgerParseErrors a)
-> ExceptT [Char] IO (Either HledgerParseErrors a)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (FinalParseErrorBundle' HledgerParseErrorData -> [Char]
finalErrorBundlePretty (FinalParseErrorBundle' HledgerParseErrorData -> [Char])
-> (FinalParseError
-> FinalParseErrorBundle' HledgerParseErrorData)
-> FinalParseError
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char]
-> Text
-> FinalParseError
-> FinalParseErrorBundle' HledgerParseErrorData
forall e.
[Char] -> Text -> FinalParseError' e -> FinalParseErrorBundle' e
attachSource [Char]
f Text
txt)
journalFinalise :: InputOpts -> FilePath -> Text -> ParsedJournal -> ExceptT String IO Journal
journalFinalise :: InputOpts -> [Char] -> Text -> Journal -> ExceptT [Char] IO Journal
journalFinalise iopts :: InputOpts
iopts@InputOpts{Bool
auto_ :: InputOpts -> Bool
auto_ :: Bool
auto_,BalancingOpts
balancingopts_ :: InputOpts -> BalancingOpts
balancingopts_ :: BalancingOpts
balancingopts_,Bool
infer_costs_ :: InputOpts -> Bool
infer_costs_ :: Bool
infer_costs_,Bool
infer_equity_ :: InputOpts -> Bool
infer_equity_ :: Bool
infer_equity_,Bool
strict_ :: InputOpts -> Bool
strict_ :: Bool
strict_,Bool
posting_account_tags_ :: InputOpts -> Bool
posting_account_tags_ :: Bool
posting_account_tags_,Bool
verbose_tags_ :: InputOpts -> Bool
verbose_tags_ :: Bool
verbose_tags_,Day
_ioDay :: InputOpts -> Day
_ioDay :: Day
_ioDay} [Char]
f Text
txt Journal
pj = do
let
BalancingOpts{Maybe (Map Text AmountStyle)
commodity_styles_ :: BalancingOpts -> Maybe (Map Text AmountStyle)
commodity_styles_ :: Maybe (Map Text AmountStyle)
commodity_styles_, Bool
ignore_assertions_ :: BalancingOpts -> Bool
ignore_assertions_ :: Bool
ignore_assertions_} = BalancingOpts
balancingopts_
fname :: [Char]
fname = [Char]
"journalFinalise " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
takeFileName [Char]
f
lbl :: [Char] -> ShowS
lbl = [Char] -> [Char] -> ShowS
lbl_ [Char]
fname
checking :: [Char] -> Bool
checking [Char]
checkname = [Char]
"check" [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
args Bool -> Bool -> Bool
&& [Char]
checkname [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
args where args :: [[Char]]
args = [[Char]]
progArgs
checkordereddates :: Bool
checkordereddates = [Char] -> Bool
checking [Char]
"ordereddates"
checkassertions :: Bool
checkassertions = Bool -> Bool
not Bool
ignore_assertions_ Bool -> Bool -> Bool
|| Bool
strict_ Bool -> Bool -> Bool
|| [Char] -> Bool
checking [Char]
"assertions"
t <- IO POSIXTime -> ExceptT [Char] IO POSIXTime
forall a. IO a -> ExceptT [Char] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO POSIXTime
getPOSIXTime
liftEither $
pj{jglobalcommoditystyles=fromMaybe mempty commodity_styles_}
& journalSetLastReadTime t
& journalAddFile (f, txt)
& journalReverse
& journalAddAccountTypes
& journalStyleAmounts
<&> journalAddForecast verbose_tags_ (forecastPeriod iopts pj)
<&> (if posting_account_tags_ then journalPostingsAddAccountTags else id)
>>= journalTagCostsAndEquityAndMaybeInferCosts verbose_tags_ False
>>= (if auto_ && not (null $ jtxnmodifiers pj)
then journalAddAutoPostings verbose_tags_ _ioDay balancingopts_
else pure)
<&> dbg9With (lbl "amounts after styling, forecasting, auto-posting".showJournalAmountsDebug)
>>= (\Journal
j -> if Bool
checkordereddates then Journal -> Either [Char] ()
journalCheckOrdereddates Journal
j Either [Char] () -> Journal -> Either [Char] Journal
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Journal
j else Journal -> Either [Char] Journal
forall a b. b -> Either a b
Right Journal
j)
>>= journalBalanceTransactions balancingopts_{ignore_assertions_=not checkassertions}
<&> dbg9With (lbl "amounts after transaction-balancing".showJournalAmountsDebug)
>>= journalInferCommodityStyles
>>= (if infer_costs_ then journalTagCostsAndEquityAndMaybeInferCosts verbose_tags_ True else pure)
<&> (if infer_equity_ then journalInferEquityFromCosts verbose_tags_ else id)
<&> dbg9With (lbl "amounts after equity-inferring".showJournalAmountsDebug)
<&> journalInferMarketPricesFromTransactions
<&> dbgJournalAcctDeclOrder (fname <> ": acct decls : ")
<&> journalRenumberAccountDeclarations
<&> dbgJournalAcctDeclOrder (fname <> ": acct decls renumbered: ")
journalAddAutoPostings :: Bool -> Day -> BalancingOpts -> Journal -> Either String Journal
journalAddAutoPostings :: Bool -> Day -> BalancingOpts -> Journal -> Either [Char] Journal
journalAddAutoPostings Bool
verbosetags Day
d BalancingOpts
bopts =
BalancingOpts -> Journal -> Either [Char] Journal
journalBalanceTransactions BalancingOpts
bopts{ignore_assertions_=True}
(Journal -> Either [Char] Journal)
-> (Journal -> Either [Char] Journal)
-> Journal
-> Either [Char] Journal
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Bool -> Day -> Journal -> Either [Char] Journal
journalModifyTransactions Bool
verbosetags Day
d
journalAddForecast :: Bool -> Maybe DateSpan -> Journal -> Journal
journalAddForecast :: Bool -> Maybe DateSpan -> Journal -> Journal
journalAddForecast Bool
_ Maybe DateSpan
Nothing Journal
j = Journal
j
journalAddForecast Bool
verbosetags (Just DateSpan
forecastspan) Journal
j = Journal
j{jtxns = jtxns j ++ forecasttxns}
where
{-# HLINT ignore "Move concatMap out" #-}
forecasttxns :: [Transaction]
forecasttxns =
(Transaction -> Transaction) -> [Transaction] -> [Transaction]
forall a b. (a -> b) -> [a] -> [b]
map (Transaction -> Transaction
txnTieKnot (Transaction -> Transaction)
-> (Transaction -> Transaction) -> Transaction -> Transaction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Posting -> Posting) -> Transaction -> Transaction
transactionTransformPostings (Map Text AmountStyle -> Posting -> Posting
forall a. HasAmounts a => Map Text AmountStyle -> a -> a
styleAmounts (Map Text AmountStyle -> Posting -> Posting)
-> Map Text AmountStyle -> Posting -> Posting
forall a b. (a -> b) -> a -> b
$ Journal -> Map Text AmountStyle
journalCommodityStyles Journal
j))
([Transaction] -> [Transaction])
-> ([PeriodicTransaction] -> [Transaction])
-> [PeriodicTransaction]
-> [Transaction]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Transaction -> Bool) -> [Transaction] -> [Transaction]
forall a. (a -> Bool) -> [a] -> [a]
filter (DateSpan -> Day -> Bool
spanContainsDate DateSpan
forecastspan (Day -> Bool) -> (Transaction -> Day) -> Transaction -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transaction -> Day
tdate)
([Transaction] -> [Transaction])
-> ([PeriodicTransaction] -> [Transaction])
-> [PeriodicTransaction]
-> [Transaction]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PeriodicTransaction -> [Transaction])
-> [PeriodicTransaction] -> [Transaction]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\PeriodicTransaction
pt -> Bool -> PeriodicTransaction -> DateSpan -> [Transaction]
runPeriodicTransaction Bool
verbosetags PeriodicTransaction
pt DateSpan
forecastspan)
([PeriodicTransaction] -> [Transaction])
-> [PeriodicTransaction] -> [Transaction]
forall a b. (a -> b) -> a -> b
$ Journal -> [PeriodicTransaction]
jperiodictxns Journal
j
setYear :: Year -> JournalParser m ()
setYear :: forall (m :: * -> *). Integer -> JournalParser m ()
setYear Integer
y = (Journal -> Journal)
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\Journal
j -> Journal
j{jparsedefaultyear=Just y})
getYear :: JournalParser m (Maybe Year)
getYear :: forall (m :: * -> *). JournalParser m (Maybe Integer)
getYear = (Journal -> Maybe Integer)
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Journal
-> StateT
Journal (ParsecT HledgerParseErrorData Text m) (Maybe Integer)
forall a b.
(a -> b)
-> StateT Journal (ParsecT HledgerParseErrorData Text m) a
-> StateT Journal (ParsecT HledgerParseErrorData Text m) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Journal -> Maybe Integer
jparsedefaultyear StateT Journal (ParsecT HledgerParseErrorData Text m) Journal
forall s (m :: * -> *). MonadState s m => m s
get
dp :: String -> TextParser m ()
dp :: forall (m :: * -> *). [Char] -> TextParser m ()
dp = TextParser m () -> [Char] -> TextParser m ()
forall a b. a -> b -> a
const (TextParser m () -> [Char] -> TextParser m ())
-> TextParser m () -> [Char] -> TextParser m ()
forall a b. (a -> b) -> a -> b
$ () -> TextParser m ()
forall a. a -> ParsecT HledgerParseErrorData Text m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
getDecimalMarkStyle :: JournalParser m (Maybe AmountStyle)
getDecimalMarkStyle :: forall (m :: * -> *). JournalParser m (Maybe AmountStyle)
getDecimalMarkStyle = do
Journal{jparsedecimalmark} <- StateT Journal (ParsecT HledgerParseErrorData Text m) Journal
forall s (m :: * -> *). MonadState s m => m s
get
let mdecmarkStyle = (\Char
c -> AmountStyle -> Maybe AmountStyle
forall a. a -> Maybe a
Just (AmountStyle -> Maybe AmountStyle)
-> AmountStyle -> Maybe AmountStyle
forall a b. (a -> b) -> a -> b
$ AmountStyle
amountstyle{asdecimalmark=Just c}) (Char -> Maybe AmountStyle) -> Maybe Char -> Maybe AmountStyle
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Char
jparsedecimalmark
return mdecmarkStyle
setDefaultCommodityAndStyle :: (CommoditySymbol,AmountStyle) -> JournalParser m ()
setDefaultCommodityAndStyle :: forall (m :: * -> *). (Text, AmountStyle) -> JournalParser m ()
setDefaultCommodityAndStyle (Text, AmountStyle)
cs = (Journal -> Journal)
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\Journal
j -> Journal
j{jparsedefaultcommodity=Just cs})
getDefaultCommodityAndStyle :: JournalParser m (Maybe (CommoditySymbol,AmountStyle))
getDefaultCommodityAndStyle :: forall (m :: * -> *). JournalParser m (Maybe (Text, AmountStyle))
getDefaultCommodityAndStyle = Journal -> Maybe (Text, AmountStyle)
jparsedefaultcommodity (Journal -> Maybe (Text, AmountStyle))
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Journal
-> StateT
Journal
(ParsecT HledgerParseErrorData Text m)
(Maybe (Text, AmountStyle))
forall a b.
(a -> b)
-> StateT Journal (ParsecT HledgerParseErrorData Text m) a
-> StateT Journal (ParsecT HledgerParseErrorData Text m) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` StateT Journal (ParsecT HledgerParseErrorData Text m) Journal
forall s (m :: * -> *). MonadState s m => m s
get
getDefaultAmountStyle :: JournalParser m (Maybe AmountStyle)
getDefaultAmountStyle :: forall (m :: * -> *). JournalParser m (Maybe AmountStyle)
getDefaultAmountStyle = ((Text, AmountStyle) -> AmountStyle)
-> Maybe (Text, AmountStyle) -> Maybe AmountStyle
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, AmountStyle) -> AmountStyle
forall a b. (a, b) -> b
snd (Maybe (Text, AmountStyle) -> Maybe AmountStyle)
-> StateT
Journal
(ParsecT HledgerParseErrorData Text m)
(Maybe (Text, AmountStyle))
-> StateT
Journal (ParsecT HledgerParseErrorData Text m) (Maybe AmountStyle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT
Journal
(ParsecT HledgerParseErrorData Text m)
(Maybe (Text, AmountStyle))
forall (m :: * -> *). JournalParser m (Maybe (Text, AmountStyle))
getDefaultCommodityAndStyle
getAmountStyle :: CommoditySymbol -> JournalParser m (Maybe AmountStyle)
getAmountStyle :: forall (m :: * -> *). Text -> JournalParser m (Maybe AmountStyle)
getAmountStyle Text
commodity = do
Journal{jdeclaredcommodities} <- StateT Journal (ParsecT HledgerParseErrorData Text m) Journal
forall s (m :: * -> *). MonadState s m => m s
get
let mspecificStyle = Text -> Map Text Commodity -> Maybe Commodity
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
commodity Map Text Commodity
jdeclaredcommodities Maybe Commodity
-> (Commodity -> Maybe AmountStyle) -> Maybe AmountStyle
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Commodity -> Maybe AmountStyle
cformat
mdefaultStyle <- fmap snd <$> getDefaultCommodityAndStyle
return $ listToMaybe $ catMaybes [mspecificStyle, mdefaultStyle]
addDeclaredAccountTags :: AccountName -> [Tag] -> JournalParser m ()
addDeclaredAccountTags :: forall (m :: * -> *). Text -> [Tag] -> JournalParser m ()
addDeclaredAccountTags Text
acct [Tag]
atags =
(Journal -> Journal)
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\Journal
j -> Journal
j{jdeclaredaccounttags = M.insertWith (flip union) acct atags (jdeclaredaccounttags j)})
addDeclaredAccountType :: AccountName -> AccountType -> JournalParser m ()
addDeclaredAccountType :: forall (m :: * -> *). Text -> AccountType -> JournalParser m ()
addDeclaredAccountType Text
acct AccountType
atype =
(Journal -> Journal)
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\Journal
j -> Journal
j{jdeclaredaccounttypes = M.insertWith (++) atype [acct] (jdeclaredaccounttypes j)})
pushParentAccount :: AccountName -> JournalParser m ()
pushParentAccount :: forall (m :: * -> *). Text -> JournalParser m ()
pushParentAccount Text
acct = (Journal -> Journal)
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\Journal
j -> Journal
j{jparseparentaccounts = acct : jparseparentaccounts j})
popParentAccount :: JournalParser m ()
popParentAccount :: forall (m :: * -> *). JournalParser m ()
popParentAccount = do
j <- StateT Journal (ParsecT HledgerParseErrorData Text m) Journal
forall s (m :: * -> *). MonadState s m => m s
get
case jparseparentaccounts j of
[] -> ErrorItem (Token Text)
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
forall e s (m :: * -> *) a.
MonadParsec e s m =>
ErrorItem (Token s) -> m a
unexpected (NonEmpty Char -> ErrorItem Char
forall t. NonEmpty t -> ErrorItem t
Tokens (Char
'E' Char -> [Char] -> NonEmpty Char
forall a. a -> [a] -> NonEmpty a
:| [Char]
"nd of apply account block with no beginning"))
(Text
_:[Text]
rest) -> Journal -> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Journal
j{jparseparentaccounts=rest}
getParentAccount :: JournalParser m AccountName
getParentAccount :: forall (m :: * -> *). JournalParser m Text
getParentAccount = (Journal -> Text)
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Journal
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Text
forall a b.
(a -> b)
-> StateT Journal (ParsecT HledgerParseErrorData Text m) a
-> StateT Journal (ParsecT HledgerParseErrorData Text m) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Text] -> Text
concatAccountNames ([Text] -> Text) -> (Journal -> [Text]) -> Journal -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> (Journal -> [Text]) -> Journal -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Journal -> [Text]
jparseparentaccounts) StateT Journal (ParsecT HledgerParseErrorData Text m) Journal
forall s (m :: * -> *). MonadState s m => m s
get
addAccountAlias :: MonadState Journal m => AccountAlias -> m ()
addAccountAlias :: forall (m :: * -> *). MonadState Journal m => AccountAlias -> m ()
addAccountAlias AccountAlias
a = (Journal -> Journal) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\(j :: Journal
j@Journal{[[Char]]
[([Char], Text)]
[(Text, AccountDeclarationInfo)]
[(Text, TagDeclarationInfo)]
[(Text, PayeeDeclarationInfo)]
[Text]
[MarketPrice]
[PriceDirective]
[TimeclockEntry]
[PeriodicTransaction]
[TransactionModifier]
[Transaction]
[AccountAlias]
Maybe Char
Maybe Integer
Maybe (Text, AmountStyle)
Map Text [Tag]
Map Text Commodity
Map Text AmountStyle
Map Text AccountType
Map AccountType [Text]
Text
POSIXTime
jparsedefaultyear :: Journal -> Maybe Integer
jincludefilestack :: Journal -> [[Char]]
jglobalcommoditystyles :: Journal -> Map Text AmountStyle
jtxnmodifiers :: Journal -> [TransactionModifier]
jtxns :: Journal -> [Transaction]
jperiodictxns :: Journal -> [PeriodicTransaction]
jparsedecimalmark :: Journal -> Maybe Char
jparsedefaultcommodity :: Journal -> Maybe (Text, AmountStyle)
jdeclaredcommodities :: Journal -> Map Text Commodity
jdeclaredaccounttags :: Journal -> Map Text [Tag]
jdeclaredaccounttypes :: Journal -> Map AccountType [Text]
jparseparentaccounts :: Journal -> [Text]
jparsedefaultyear :: Maybe Integer
jparsedefaultcommodity :: Maybe (Text, AmountStyle)
jparsedecimalmark :: Maybe Char
jparseparentaccounts :: [Text]
jparsealiases :: [AccountAlias]
jparsetimeclockentries :: [TimeclockEntry]
jincludefilestack :: [[Char]]
jdeclaredpayees :: [(Text, PayeeDeclarationInfo)]
jdeclaredtags :: [(Text, TagDeclarationInfo)]
jdeclaredaccounts :: [(Text, AccountDeclarationInfo)]
jdeclaredaccounttags :: Map Text [Tag]
jdeclaredaccounttypes :: Map AccountType [Text]
jaccounttypes :: Map Text AccountType
jdeclaredcommodities :: Map Text Commodity
jinferredcommoditystyles :: Map Text AmountStyle
jglobalcommoditystyles :: Map Text AmountStyle
jpricedirectives :: [PriceDirective]
jinferredmarketprices :: [MarketPrice]
jtxnmodifiers :: [TransactionModifier]
jperiodictxns :: [PeriodicTransaction]
jtxns :: [Transaction]
jfinalcommentlines :: Text
jfiles :: [([Char], Text)]
jlastreadtime :: POSIXTime
jlastreadtime :: Journal -> POSIXTime
jfiles :: Journal -> [([Char], Text)]
jfinalcommentlines :: Journal -> Text
jinferredmarketprices :: Journal -> [MarketPrice]
jpricedirectives :: Journal -> [PriceDirective]
jinferredcommoditystyles :: Journal -> Map Text AmountStyle
jaccounttypes :: Journal -> Map Text AccountType
jdeclaredaccounts :: Journal -> [(Text, AccountDeclarationInfo)]
jdeclaredtags :: Journal -> [(Text, TagDeclarationInfo)]
jdeclaredpayees :: Journal -> [(Text, PayeeDeclarationInfo)]
jparsetimeclockentries :: Journal -> [TimeclockEntry]
jparsealiases :: Journal -> [AccountAlias]
..}) -> Journal
j{jparsealiases=a:jparsealiases})
getAccountAliases :: MonadState Journal m => m [AccountAlias]
getAccountAliases :: forall (m :: * -> *). MonadState Journal m => m [AccountAlias]
getAccountAliases = (Journal -> [AccountAlias]) -> m Journal -> m [AccountAlias]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Journal -> [AccountAlias]
jparsealiases m Journal
forall s (m :: * -> *). MonadState s m => m s
get
clearAccountAliases :: MonadState Journal m => m ()
clearAccountAliases :: forall (m :: * -> *). MonadState Journal m => m ()
clearAccountAliases = (Journal -> Journal) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\Journal
j -> Journal
j{jparsealiases=[]})
journalAddFile :: (FilePath,Text) -> Journal -> Journal
journalAddFile :: ([Char], Text) -> Journal -> Journal
journalAddFile ([Char], Text)
f j :: Journal
j@Journal{jfiles :: Journal -> [([Char], Text)]
jfiles=[([Char], Text)]
fs} = Journal
j{jfiles=fs++[f]}
match' :: TextParser m a -> TextParser m (Text, a)
match' :: forall (m :: * -> *) a. TextParser m a -> TextParser m (Text, a)
match' TextParser m a
p = do
(!txt, p') <- TextParser m a
-> ParsecT HledgerParseErrorData Text m (Tokens Text, a)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> m (Tokens s, a)
match TextParser m a
p
pure (txt, p')
statusp :: TextParser m Status
statusp :: forall (m :: * -> *). TextParser m Status
statusp =
[TextParser m Status] -> TextParser m Status
forall (m :: * -> *) a. [TextParser m a] -> TextParser m a
choice'
[ ParsecT HledgerParseErrorData Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m Char
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token Text -> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'*' ParsecT HledgerParseErrorData Text m Char
-> TextParser m Status -> TextParser m Status
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Status -> TextParser m Status
forall a. a -> ParsecT HledgerParseErrorData Text m a
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cleared
, ParsecT HledgerParseErrorData Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m Char
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token Text -> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'!' ParsecT HledgerParseErrorData Text m Char
-> TextParser m Status -> TextParser m Status
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Status -> TextParser m Status
forall a. a -> ParsecT HledgerParseErrorData Text m a
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Pending
, Status -> TextParser m Status
forall a. a -> ParsecT HledgerParseErrorData Text m a
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Unmarked
]
codep :: TextParser m Text
codep :: forall (m :: * -> *). TextParser m Text
codep = Text
-> ParsecT HledgerParseErrorData Text m Text
-> ParsecT HledgerParseErrorData Text m Text
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Text
"" (ParsecT HledgerParseErrorData Text m Text
-> ParsecT HledgerParseErrorData Text m Text)
-> ParsecT HledgerParseErrorData Text m Text
-> ParsecT HledgerParseErrorData Text m Text
forall a b. (a -> b) -> a -> b
$ do
ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m Char
forall a.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m Char)
-> ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m Char
forall a b. (a -> b) -> a -> b
$ do
ParsecT HledgerParseErrorData Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces1
Token Text -> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'('
code <- Maybe [Char]
-> (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe [Char]
forall a. Maybe a
Nothing ((Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Tokens Text))
-> (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall a b. (a -> b) -> a -> b
$ \Token Text
c -> Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
')' Bool -> Bool -> Bool
&& Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n'
char ')' <?> "closing bracket ')' for transaction code"
pure code
descriptionp :: TextParser m Text
descriptionp :: forall (m :: * -> *). TextParser m Text
descriptionp = TextParser m Text
forall (m :: * -> *). TextParser m Text
noncommenttextp TextParser m Text -> [Char] -> TextParser m Text
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"description"
datep :: JournalParser m Day
datep :: forall (m :: * -> *). JournalParser m Day
datep = do
mYear <- JournalParser m (Maybe Integer)
forall (m :: * -> *). JournalParser m (Maybe Integer)
getYear
lift $ datep' mYear
datep' :: Maybe Year -> TextParser m Day
datep' :: forall (m :: * -> *). Maybe Integer -> TextParser m Day
datep' Maybe Integer
mYear = do
startOffset <- ParsecT HledgerParseErrorData Text m Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
d1 <- yearorintp <?> "year or month"
sep <- datesepchar <?> "date separator"
d2 <- decimal <?> "month or day"
case d1 of
Left Integer
y -> Int
-> Integer
-> Char
-> Int
-> ParsecT HledgerParseErrorData Text m Day
forall (m :: * -> *).
Int -> Integer -> Char -> Int -> TextParser m Day
fullDate Int
startOffset Integer
y Char
sep Int
d2
Right Int
m -> Int
-> Maybe Integer
-> Int
-> Int
-> ParsecT HledgerParseErrorData Text m Day
forall (m :: * -> *).
Int -> Maybe Integer -> Int -> Int -> TextParser m Day
partialDate Int
startOffset Maybe Integer
mYear Int
m Int
d2
ParsecT HledgerParseErrorData Text m Day
-> [Char] -> ParsecT HledgerParseErrorData Text m Day
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"full or partial date"
where
fullDate :: Int -> Year -> Char -> Month -> TextParser m Day
fullDate :: forall (m :: * -> *).
Int -> Integer -> Char -> Int -> TextParser m Day
fullDate Int
startOffset Integer
year Char
sep Int
month = do
sep2 <- (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
isDateSepChar ParsecT HledgerParseErrorData Text m Char
-> [Char] -> ParsecT HledgerParseErrorData Text m Char
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"date separator"
day <- decimal <?> "day"
endOffset <- getOffset
when (sep /= sep2) $
customFailure $ parseErrorAtRegion startOffset endOffset $
"This date has different separators, please use consistent separators."
case fromGregorianValid year month day of
Maybe Day
Nothing ->
HledgerParseErrorData -> ParsecT HledgerParseErrorData Text m Day
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (HledgerParseErrorData -> ParsecT HledgerParseErrorData Text m Day)
-> HledgerParseErrorData
-> ParsecT HledgerParseErrorData Text m Day
forall a b. (a -> b) -> a -> b
$ Int -> Int -> [Char] -> HledgerParseErrorData
parseErrorAtRegion Int
startOffset Int
endOffset ([Char] -> HledgerParseErrorData)
-> [Char] -> HledgerParseErrorData
forall a b. (a -> b) -> a -> b
$
[Char]
"This is not a valid date, please fix it."
Just Day
date -> Day -> ParsecT HledgerParseErrorData Text m Day
forall a. a -> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Day -> ParsecT HledgerParseErrorData Text m Day)
-> Day -> ParsecT HledgerParseErrorData Text m Day
forall a b. (a -> b) -> a -> b
$! Day
date
partialDate :: Int -> Maybe Year -> Month -> MonthDay -> TextParser m Day
partialDate :: forall (m :: * -> *).
Int -> Maybe Integer -> Int -> Int -> TextParser m Day
partialDate Int
startOffset Maybe Integer
myr Int
month Int
day = do
endOffset <- ParsecT HledgerParseErrorData Text m Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
case myr of
Just Integer
year ->
case Integer -> Int -> Int -> Maybe Day
fromGregorianValid Integer
year Int
month Int
day of
Maybe Day
Nothing ->
HledgerParseErrorData -> ParsecT HledgerParseErrorData Text m Day
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (HledgerParseErrorData -> ParsecT HledgerParseErrorData Text m Day)
-> HledgerParseErrorData
-> ParsecT HledgerParseErrorData Text m Day
forall a b. (a -> b) -> a -> b
$ Int -> Int -> [Char] -> HledgerParseErrorData
parseErrorAtRegion Int
startOffset Int
endOffset ([Char] -> HledgerParseErrorData)
-> [Char] -> HledgerParseErrorData
forall a b. (a -> b) -> a -> b
$
[Char]
"This is not a valid date, please fix it."
Just Day
date -> Day -> ParsecT HledgerParseErrorData Text m Day
forall a. a -> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Day -> ParsecT HledgerParseErrorData Text m Day)
-> Day -> ParsecT HledgerParseErrorData Text m Day
forall a b. (a -> b) -> a -> b
$! Day
date
Maybe Integer
Nothing ->
HledgerParseErrorData -> ParsecT HledgerParseErrorData Text m Day
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (HledgerParseErrorData -> ParsecT HledgerParseErrorData Text m Day)
-> HledgerParseErrorData
-> ParsecT HledgerParseErrorData Text m Day
forall a b. (a -> b) -> a -> b
$ Int -> Int -> [Char] -> HledgerParseErrorData
parseErrorAtRegion Int
startOffset Int
endOffset ([Char] -> HledgerParseErrorData)
-> [Char] -> HledgerParseErrorData
forall a b. (a -> b) -> a -> b
$
[Char]
"This partial date can not be parsed because the current year is unknown.\n"
[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
"Please make it a full date, or add a default year directive."
{-# INLINABLE datep' #-}
datetimep :: JournalParser m LocalTime
datetimep :: forall (m :: * -> *). JournalParser m LocalTime
datetimep = do
mYear <- JournalParser m (Maybe Integer)
forall (m :: * -> *). JournalParser m (Maybe Integer)
getYear
lift $ datetimep' mYear
datetimep' :: Maybe Year -> TextParser m LocalTime
datetimep' :: forall (m :: * -> *). Maybe Integer -> TextParser m LocalTime
datetimep' Maybe Integer
mYear = do
day <- Maybe Integer -> TextParser m Day
forall (m :: * -> *). Maybe Integer -> TextParser m Day
datep' Maybe Integer
mYear
skipNonNewlineSpaces1
time <- timeOfDay
optional timeZone
pure $ LocalTime day time
where
timeOfDay :: TextParser m TimeOfDay
timeOfDay :: forall (m :: * -> *). TextParser m TimeOfDay
timeOfDay = do
off1 <- ParsecT HledgerParseErrorData Text m Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
h' <- twoDigitDecimal <?> "hour"
off2 <- getOffset
unless (h' >= 0 && h' <= 23) $ customFailure $
parseErrorAtRegion off1 off2 "invalid time (bad hour)"
char ':' <?> "':' (hour-minute separator)"
off3 <- getOffset
m' <- twoDigitDecimal <?> "minute"
off4 <- getOffset
unless (m' >= 0 && m' <= 59) $ customFailure $
parseErrorAtRegion off3 off4 "invalid time (bad minute)"
s' <- option 0 $ do
char ':' <?> "':' (minute-second separator)"
off5 <- getOffset
s' <- twoDigitDecimal <?> "second"
off6 <- getOffset
unless (s' >= 0 && s' <= 59) $ customFailure $
parseErrorAtRegion off5 off6 "invalid time (bad second)"
pure s'
pure $ TimeOfDay h' m' (fromIntegral s')
twoDigitDecimal :: TextParser m Int
twoDigitDecimal :: forall (m :: * -> *). TextParser m Int
twoDigitDecimal = do
d1 <- Char -> Int
digitToInt (Char -> Int)
-> ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT HledgerParseErrorData Text m Char
ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
d2 <- digitToInt <$> (digitChar <?> "a second digit")
pure $ d1*10 + d2
timeZone :: TextParser m String
timeZone :: forall (m :: * -> *). TextParser m [Char]
timeZone = do
plusminus <- (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy ((Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Token Text))
-> (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Token Text)
forall a b. (a -> b) -> a -> b
$ \Token Text
c -> Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+'
fourDigits <- count 4 (digitChar <?> "a digit (for a time zone)")
pure $ plusminus:fourDigits
secondarydatep :: Day -> TextParser m Day
secondarydatep :: forall (m :: * -> *). Day -> TextParser m Day
secondarydatep Day
primaryDate = Token Text -> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'=' ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m Day
-> ParsecT HledgerParseErrorData Text m Day
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Maybe Integer -> ParsecT HledgerParseErrorData Text m Day
forall (m :: * -> *). Maybe Integer -> TextParser m Day
datep' (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
primaryYear)
where primaryYear :: Integer
primaryYear = (Integer, Int, Int) -> Integer
forall {a} {b} {c}. (a, b, c) -> a
first3 ((Integer, Int, Int) -> Integer) -> (Integer, Int, Int) -> Integer
forall a b. (a -> b) -> a -> b
$ Day -> (Integer, Int, Int)
toGregorian Day
primaryDate
yearorintp :: TextParser m (Either Year Int)
yearorintp :: forall (m :: * -> *). TextParser m (Either Integer Int)
yearorintp = do
yearOrMonth <- Maybe [Char]
-> (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"digit") Char -> Bool
Token Text -> Bool
isDigit
let n = Text -> Integer
readDecimal Text
yearOrMonth
return $ if T.length yearOrMonth >= 4 then Left n else Right (fromInteger n)
modifiedaccountnamep :: JournalParser m AccountName
modifiedaccountnamep :: forall (m :: * -> *). JournalParser m Text
modifiedaccountnamep = do
parent <- JournalParser m Text
forall (m :: * -> *). JournalParser m Text
getParentAccount
als <- getAccountAliases
a <- lift accountnamep
case accountNameApplyAliases als $ joinAccountNames parent a of
Right Text
a' -> Text -> JournalParser m Text
forall a.
a -> StateT Journal (ParsecT HledgerParseErrorData Text m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> JournalParser m Text) -> Text -> JournalParser m Text
forall a b. (a -> b) -> a -> b
$! Text
a'
Left [Char]
e -> [Char] -> JournalParser m Text
forall {a}. [Char] -> a
error' [Char]
err
where
err :: [Char]
err = [Char]
"problem in account alias applied to "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Text -> [Char]
T.unpack Text
a[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
": "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
e
accountnamep :: TextParser m AccountName
accountnamep :: forall (m :: * -> *). TextParser m Text
accountnamep = TextParser m Text
forall (m :: * -> *). TextParser m Text
singlespacedtext1p
doublequotedtextp :: TextParser m Text
doublequotedtextp :: forall (m :: * -> *). TextParser m Text
doublequotedtextp = ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m Text
-> ParsecT HledgerParseErrorData Text m Text
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Token Text -> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'"') (Token Text -> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'"') (ParsecT HledgerParseErrorData Text m Text
-> ParsecT HledgerParseErrorData Text m Text)
-> ParsecT HledgerParseErrorData Text m Text
-> ParsecT HledgerParseErrorData Text m Text
forall a b. (a -> b) -> a -> b
$
Maybe [Char]
-> (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe [Char]
forall a. Maybe a
Nothing ((Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Tokens Text))
-> (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall a b. (a -> b) -> a -> b
$ \Token Text
c -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char -> Bool
isNewline Char
Token Text
c Bool -> Bool -> Bool
|| Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"'
noncommenttextp :: TextParser m T.Text
= Maybe [Char]
-> (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe [Char]
forall a. Maybe a
Nothing (\Token Text
c -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char -> Bool
isSameLineCommentStart Char
Token Text
c Bool -> Bool -> Bool
|| Char -> Bool
isNewline Char
Token Text
c)
noncommenttext1p :: TextParser m T.Text
= Maybe [Char]
-> (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe [Char]
forall a. Maybe a
Nothing (\Token Text
c -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char -> Bool
isSameLineCommentStart Char
Token Text
c Bool -> Bool -> Bool
|| Char -> Bool
isNewline Char
Token Text
c)
singlespacedtext1p :: TextParser m T.Text
singlespacedtext1p :: forall (m :: * -> *). TextParser m Text
singlespacedtext1p = (Char -> Bool) -> TextParser m Text
forall (m :: * -> *). (Char -> Bool) -> TextParser m Text
singlespacedtextsatisfying1p (Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
True)
singlespacednoncommenttext1p :: TextParser m T.Text
= (Char -> Bool) -> TextParser m Text
forall (m :: * -> *). (Char -> Bool) -> TextParser m Text
singlespacedtextsatisfying1p (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSameLineCommentStart)
singlespacedtextsatisfying1p :: (Char -> Bool) -> TextParser m T.Text
singlespacedtextsatisfying1p :: forall (m :: * -> *). (Char -> Bool) -> TextParser m Text
singlespacedtextsatisfying1p Char -> Bool
f = do
firstPart <- ParsecT HledgerParseErrorData Text m Text
ParsecT HledgerParseErrorData Text m (Tokens Text)
partp
otherParts <- many $ try $ singlespacep *> partp
pure $! T.unwords $ firstPart : otherParts
where
partp :: ParsecT HledgerParseErrorData Text m (Tokens Text)
partp = Maybe [Char]
-> (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe [Char]
forall a. Maybe a
Nothing (\Token Text
c -> Char -> Bool
f Char
Token Text
c Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
isSpace Char
Token Text
c))
singlespacep :: TextParser m ()
singlespacep :: forall (m :: * -> *). TextParser m ()
singlespacep = ParsecT HledgerParseErrorData Text m Char
forall s (m :: * -> *).
(Stream s, Char ~ Token s) =>
ParsecT HledgerParseErrorData s m Char
spacenonewline ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m ()
forall a.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy ParsecT HledgerParseErrorData Text m Char
forall s (m :: * -> *).
(Stream s, Char ~ Token s) =>
ParsecT HledgerParseErrorData s m Char
spacenonewline
spaceandamountormissingp :: JournalParser m MixedAmount
spaceandamountormissingp :: forall (m :: * -> *). JournalParser m MixedAmount
spaceandamountormissingp =
MixedAmount
-> StateT
Journal (ParsecT HledgerParseErrorData Text m) MixedAmount
-> StateT
Journal (ParsecT HledgerParseErrorData Text m) MixedAmount
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option MixedAmount
missingmixedamt (StateT Journal (ParsecT HledgerParseErrorData Text m) MixedAmount
-> StateT
Journal (ParsecT HledgerParseErrorData Text m) MixedAmount)
-> StateT
Journal (ParsecT HledgerParseErrorData Text m) MixedAmount
-> StateT
Journal (ParsecT HledgerParseErrorData Text m) MixedAmount
forall a b. (a -> b) -> a -> b
$ StateT Journal (ParsecT HledgerParseErrorData Text m) MixedAmount
-> StateT
Journal (ParsecT HledgerParseErrorData Text m) MixedAmount
forall a.
StateT Journal (ParsecT HledgerParseErrorData Text m) a
-> StateT Journal (ParsecT HledgerParseErrorData Text m) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (StateT Journal (ParsecT HledgerParseErrorData Text m) MixedAmount
-> StateT
Journal (ParsecT HledgerParseErrorData Text m) MixedAmount)
-> StateT
Journal (ParsecT HledgerParseErrorData Text m) MixedAmount
-> StateT
Journal (ParsecT HledgerParseErrorData Text m) MixedAmount
forall a b. (a -> b) -> a -> b
$ do
ParsecT HledgerParseErrorData Text m ()
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
forall (m :: * -> *) a. Monad m => m a -> StateT Journal m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT HledgerParseErrorData Text m ()
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ())
-> ParsecT HledgerParseErrorData Text m ()
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
forall a b. (a -> b) -> a -> b
$ ParsecT HledgerParseErrorData Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces1
Amount -> MixedAmount
mixedAmount (Amount -> MixedAmount)
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Amount
-> StateT
Journal (ParsecT HledgerParseErrorData Text m) MixedAmount
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT Journal (ParsecT HledgerParseErrorData Text m) Amount
forall (m :: * -> *). JournalParser m Amount
amountp
amountp :: JournalParser m Amount
amountp :: forall (m :: * -> *). JournalParser m Amount
amountp = Bool -> JournalParser m Amount
forall (m :: * -> *). Bool -> JournalParser m Amount
amountp' Bool
False
amountp' :: Bool -> JournalParser m Amount
amountp' :: forall (m :: * -> *). Bool -> JournalParser m Amount
amountp' Bool
mult =
[Char]
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Amount
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Amount
forall a.
[Char]
-> StateT Journal (ParsecT HledgerParseErrorData Text m) a
-> StateT Journal (ParsecT HledgerParseErrorData Text m) a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label [Char]
"amount" (StateT Journal (ParsecT HledgerParseErrorData Text m) Amount
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Amount)
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Amount
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Amount
forall a b. (a -> b) -> a -> b
$ do
let spaces :: StateT Journal (ParsecT HledgerParseErrorData Text m) ()
spaces = ParsecT HledgerParseErrorData Text m ()
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
forall (m :: * -> *) a. Monad m => m a -> StateT Journal m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT HledgerParseErrorData Text m ()
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ())
-> ParsecT HledgerParseErrorData Text m ()
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
forall a b. (a -> b) -> a -> b
$ ParsecT HledgerParseErrorData Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces
amt <- Bool
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Amount
forall (m :: * -> *). Bool -> JournalParser m Amount
simpleamountp Bool
mult StateT Journal (ParsecT HledgerParseErrorData Text m) Amount
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Amount
forall a b.
StateT Journal (ParsecT HledgerParseErrorData Text m) a
-> StateT Journal (ParsecT HledgerParseErrorData Text m) b
-> StateT Journal (ParsecT HledgerParseErrorData Text m) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* StateT Journal (ParsecT HledgerParseErrorData Text m) ()
forall (m :: * -> *). JournalParser m ()
spaces
(mcost, _valuationexpr, _mlotcost, _mlotdate, _mlotnote) <- runPermutation $
(,,,,) <$> toPermutationWithDefault Nothing (Just <$> try (costp amt) <* spaces)
<*> toPermutationWithDefault Nothing (Just <$> valuationexprp <* spaces)
<*> toPermutationWithDefault Nothing (Just <$> lotcostp <* spaces)
<*> toPermutationWithDefault Nothing (Just <$> lotdatep <* spaces)
<*> toPermutationWithDefault Nothing (Just <$> lotnotep <* spaces)
pure $ amt { acost = mcost }
amountnobasisp :: JournalParser m Amount
amountnobasisp :: forall (m :: * -> *). JournalParser m Amount
amountnobasisp =
[Char]
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Amount
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Amount
forall a.
[Char]
-> StateT Journal (ParsecT HledgerParseErrorData Text m) a
-> StateT Journal (ParsecT HledgerParseErrorData Text m) a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label [Char]
"amount" (StateT Journal (ParsecT HledgerParseErrorData Text m) Amount
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Amount)
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Amount
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Amount
forall a b. (a -> b) -> a -> b
$ do
let spaces :: StateT Journal (ParsecT HledgerParseErrorData Text m) ()
spaces = ParsecT HledgerParseErrorData Text m ()
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
forall (m :: * -> *) a. Monad m => m a -> StateT Journal m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT HledgerParseErrorData Text m ()
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ())
-> ParsecT HledgerParseErrorData Text m ()
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
forall a b. (a -> b) -> a -> b
$ ParsecT HledgerParseErrorData Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces
amt <- Bool
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Amount
forall (m :: * -> *). Bool -> JournalParser m Amount
simpleamountp Bool
False
spaces
mprice <- optional $ costp amt <* spaces
pure $ amt { acost = mprice }
simpleamountp :: Bool -> JournalParser m Amount
simpleamountp :: forall (m :: * -> *). Bool -> JournalParser m Amount
simpleamountp Bool
mult =
do
sign <- ParsecT HledgerParseErrorData Text m (Quantity -> Quantity)
-> StateT
Journal
(ParsecT HledgerParseErrorData Text m)
(Quantity -> Quantity)
forall (m :: * -> *) a. Monad m => m a -> StateT Journal m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ParsecT HledgerParseErrorData Text m (Quantity -> Quantity)
forall a (m :: * -> *). Num a => TextParser m (a -> a)
signp
leftsymbolamountp sign <|> rightornosymbolamountp sign
where
leftsymbolamountp :: (Decimal -> Decimal) -> JournalParser m Amount
leftsymbolamountp :: forall (m :: * -> *).
(Quantity -> Quantity) -> JournalParser m Amount
leftsymbolamountp Quantity -> Quantity
sign = [Char]
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Amount
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Amount
forall a.
[Char]
-> StateT Journal (ParsecT HledgerParseErrorData Text m) a
-> StateT Journal (ParsecT HledgerParseErrorData Text m) a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label [Char]
"amount" (StateT Journal (ParsecT HledgerParseErrorData Text m) Amount
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Amount)
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Amount
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Amount
forall a b. (a -> b) -> a -> b
$ do
c <- ParsecT HledgerParseErrorData Text m Text
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Text
forall (m :: * -> *) a. Monad m => m a -> StateT Journal m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ParsecT HledgerParseErrorData Text m Text
forall (m :: * -> *). TextParser m Text
commoditysymbolp
mdecmarkStyle <- getDecimalMarkStyle
mcommodityStyle <- getAmountStyle c
let suggestedStyle = Maybe AmountStyle
mdecmarkStyle Maybe AmountStyle -> Maybe AmountStyle -> Maybe AmountStyle
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe AmountStyle
mcommodityStyle
commodityspaced <- lift skipNonNewlineSpaces'
sign2 <- lift $ signp
offBeforeNum <- getOffset
ambiguousRawNum <- lift rawnumberp
mExponent <- lift $ optional $ try exponentp
offAfterNum <- getOffset
let numRegion = (Int
offBeforeNum, Int
offAfterNum)
(q,prec,mdec,mgrps) <- lift $ interpretNumber numRegion suggestedStyle ambiguousRawNum mExponent
let s = AmountStyle
amountstyle{ascommodityside=L, ascommodityspaced=commodityspaced, asprecision=prec, asdecimalmark=mdec, asdigitgroups=mgrps}
return nullamt{acommodity=c, aquantity=sign (sign2 q), astyle=s, acost=Nothing}
rightornosymbolamountp :: (Decimal -> Decimal) -> JournalParser m Amount
rightornosymbolamountp :: forall (m :: * -> *).
(Quantity -> Quantity) -> JournalParser m Amount
rightornosymbolamountp Quantity -> Quantity
sign = [Char]
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Amount
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Amount
forall a.
[Char]
-> StateT Journal (ParsecT HledgerParseErrorData Text m) a
-> StateT Journal (ParsecT HledgerParseErrorData Text m) a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label [Char]
"amount" (StateT Journal (ParsecT HledgerParseErrorData Text m) Amount
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Amount)
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Amount
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Amount
forall a b. (a -> b) -> a -> b
$ do
offBeforeNum <- StateT Journal (ParsecT HledgerParseErrorData Text m) Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
ambiguousRawNum <- lift rawnumberp
mExponent <- lift $ optional $ try exponentp
offAfterNum <- getOffset
let numRegion = (Int
offBeforeNum, Int
offAfterNum)
mSpaceAndCommodity <- lift $ optional $ try $ (,) <$> skipNonNewlineSpaces' <*> commoditysymbolp
case mSpaceAndCommodity of
Just (Bool
commodityspaced, Text
c) -> do
mdecmarkStyle <- JournalParser m (Maybe AmountStyle)
forall (m :: * -> *). JournalParser m (Maybe AmountStyle)
getDecimalMarkStyle
mcommodityStyle <- getAmountStyle c
let msuggestedStyle = Maybe AmountStyle
mdecmarkStyle Maybe AmountStyle -> Maybe AmountStyle -> Maybe AmountStyle
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe AmountStyle
mcommodityStyle
(q,prec,mdec,mgrps) <- lift $ interpretNumber numRegion msuggestedStyle ambiguousRawNum mExponent
let s = AmountStyle
amountstyle{ascommodityside=R, ascommodityspaced=commodityspaced, asprecision=prec, asdecimalmark=mdec, asdigitgroups=mgrps}
return nullamt{acommodity=c, aquantity=sign q, astyle=s, acost=Nothing}
Maybe (Bool, Text)
Nothing -> do
mdecmarkStyle <- JournalParser m (Maybe AmountStyle)
forall (m :: * -> *). JournalParser m (Maybe AmountStyle)
getDecimalMarkStyle
mcommodityStyle <- getAmountStyle ""
mdefaultStyle <- getDefaultAmountStyle
let msuggestedStyle = Maybe AmountStyle
mdecmarkStyle Maybe AmountStyle -> Maybe AmountStyle -> Maybe AmountStyle
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe AmountStyle
mcommodityStyle Maybe AmountStyle -> Maybe AmountStyle -> Maybe AmountStyle
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe AmountStyle
mdefaultStyle
(q,prec,mdec,mgrps) <- lift $ interpretNumber numRegion msuggestedStyle ambiguousRawNum mExponent
defcs <- getDefaultCommodityAndStyle
let (c,s) = case (mult, defcs) of
(Bool
False, Just (Text
defc,AmountStyle
defs)) -> (Text
defc, AmountStyle
defs{asprecision=max (asprecision defs) prec})
(Bool, Maybe (Text, AmountStyle))
_ -> (Text
"", AmountStyle
amountstyle{asprecision=prec, asdecimalmark=mdec, asdigitgroups=mgrps})
return nullamt{acommodity=c, aquantity=sign q, astyle=s, acost=Nothing}
interpretNumber
:: (Int, Int)
-> Maybe AmountStyle
-> Either AmbiguousNumber RawNumber
-> Maybe Integer
-> TextParser m (Quantity, AmountPrecision, Maybe Char, Maybe DigitGroupStyle)
interpretNumber :: forall (m :: * -> *).
(Int, Int)
-> Maybe AmountStyle
-> Either AmbiguousNumber RawNumber
-> Maybe Integer
-> TextParser
m (Quantity, AmountPrecision, Maybe Char, Maybe DigitGroupStyle)
interpretNumber (Int, Int)
posRegion Maybe AmountStyle
msuggestedStyle Either AmbiguousNumber RawNumber
ambiguousNum Maybe Integer
mExp =
let rawNum :: RawNumber
rawNum = (AmbiguousNumber -> RawNumber)
-> (RawNumber -> RawNumber)
-> Either AmbiguousNumber RawNumber
-> RawNumber
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe AmountStyle -> AmbiguousNumber -> RawNumber
disambiguateNumber Maybe AmountStyle
msuggestedStyle) RawNumber -> RawNumber
forall a. a -> a
id Either AmbiguousNumber RawNumber
ambiguousNum
in case RawNumber
-> Maybe Integer
-> Either
[Char] (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
fromRawNumber RawNumber
rawNum Maybe Integer
mExp of
Left [Char]
errMsg -> HledgerParseErrorData
-> TextParser
m (Quantity, AmountPrecision, Maybe Char, Maybe DigitGroupStyle)
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (HledgerParseErrorData
-> TextParser
m (Quantity, AmountPrecision, Maybe Char, Maybe DigitGroupStyle))
-> HledgerParseErrorData
-> TextParser
m (Quantity, AmountPrecision, Maybe Char, Maybe DigitGroupStyle)
forall a b. (a -> b) -> a -> b
$
(Int -> Int -> [Char] -> HledgerParseErrorData)
-> (Int, Int) -> [Char] -> HledgerParseErrorData
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> [Char] -> HledgerParseErrorData
parseErrorAtRegion (Int, Int)
posRegion [Char]
errMsg
Right (Quantity
q,Word8
p,Maybe Char
d,Maybe DigitGroupStyle
g) -> (Quantity, AmountPrecision, Maybe Char, Maybe DigitGroupStyle)
-> TextParser
m (Quantity, AmountPrecision, Maybe Char, Maybe DigitGroupStyle)
forall a. a -> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Quantity
q, Word8 -> AmountPrecision
Precision Word8
p, Maybe Char
d, Maybe DigitGroupStyle
g)
parseamount :: String -> Either HledgerParseErrors Amount
parseamount :: [Char] -> Either HledgerParseErrors Amount
parseamount [Char]
s = Parsec HledgerParseErrorData Text Amount
-> [Char] -> Text -> Either HledgerParseErrors Amount
forall e s a.
Parsec e s a -> [Char] -> s -> Either (ParseErrorBundle s e) a
runParser (StateT Journal (ParsecT HledgerParseErrorData Text Identity) Amount
-> Journal -> Parsec HledgerParseErrorData Text Amount
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (StateT Journal (ParsecT HledgerParseErrorData Text Identity) Amount
forall (m :: * -> *). JournalParser m Amount
amountp StateT Journal (ParsecT HledgerParseErrorData Text Identity) Amount
-> StateT Journal (ParsecT HledgerParseErrorData Text Identity) ()
-> StateT
Journal (ParsecT HledgerParseErrorData Text Identity) Amount
forall a b.
StateT Journal (ParsecT HledgerParseErrorData Text Identity) a
-> StateT Journal (ParsecT HledgerParseErrorData Text Identity) b
-> StateT Journal (ParsecT HledgerParseErrorData Text Identity) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* StateT Journal (ParsecT HledgerParseErrorData Text Identity) ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) Journal
nulljournal) [Char]
"" ([Char] -> Text
T.pack [Char]
s)
parseamount' :: String -> Amount
parseamount' :: [Char] -> Amount
parseamount' [Char]
s =
case [Char] -> Either HledgerParseErrors Amount
parseamount [Char]
s of
Right Amount
amt -> Amount
amt
Left HledgerParseErrors
err -> [Char] -> Amount
forall {a}. [Char] -> a
error' ([Char] -> Amount) -> [Char] -> Amount
forall a b. (a -> b) -> a -> b
$ HledgerParseErrors -> [Char]
forall a. Show a => a -> [Char]
show HledgerParseErrors
err
parsemixedamount :: String -> Either HledgerParseErrors MixedAmount
parsemixedamount :: [Char] -> Either HledgerParseErrors MixedAmount
parsemixedamount = (Amount -> MixedAmount)
-> Either HledgerParseErrors Amount
-> Either HledgerParseErrors MixedAmount
forall a b.
(a -> b)
-> Either HledgerParseErrors a -> Either HledgerParseErrors b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Amount -> MixedAmount
mixedAmount (Either HledgerParseErrors Amount
-> Either HledgerParseErrors MixedAmount)
-> ([Char] -> Either HledgerParseErrors Amount)
-> [Char]
-> Either HledgerParseErrors MixedAmount
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Either HledgerParseErrors Amount
parseamount
parsemixedamount' :: String -> MixedAmount
parsemixedamount' :: [Char] -> MixedAmount
parsemixedamount' = Amount -> MixedAmount
mixedAmount (Amount -> MixedAmount)
-> ([Char] -> Amount) -> [Char] -> MixedAmount
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Amount
parseamount'
signp :: Num a => TextParser m (a -> a)
signp :: forall a (m :: * -> *). Num a => TextParser m (a -> a)
signp = ((Token Text -> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'-' ParsecT HledgerParseErrorData Text m Char
-> (a -> a) -> ParsecT HledgerParseErrorData Text m (a -> a)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> a -> a
forall a. Num a => a -> a
negate ParsecT HledgerParseErrorData Text m (a -> a)
-> ParsecT HledgerParseErrorData Text m (a -> a)
-> ParsecT HledgerParseErrorData Text m (a -> a)
forall a.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token Text -> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'+' ParsecT HledgerParseErrorData Text m Char
-> (a -> a) -> ParsecT HledgerParseErrorData Text m (a -> a)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> a -> a
forall a. a -> a
id) ParsecT HledgerParseErrorData Text m (a -> a)
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m (a -> a)
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT HledgerParseErrorData Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces) ParsecT HledgerParseErrorData Text m (a -> a)
-> ParsecT HledgerParseErrorData Text m (a -> a)
-> ParsecT HledgerParseErrorData Text m (a -> a)
forall a.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (a -> a) -> ParsecT HledgerParseErrorData Text m (a -> a)
forall a. a -> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> a
forall a. a -> a
id
commoditysymbolp :: TextParser m CommoditySymbol
commoditysymbolp :: forall (m :: * -> *). TextParser m Text
commoditysymbolp =
TextParser m Text
forall (m :: * -> *). TextParser m Text
quotedcommoditysymbolp TextParser m Text -> TextParser m Text -> TextParser m Text
forall a.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TextParser m Text
forall (m :: * -> *). TextParser m Text
simplecommoditysymbolp TextParser m Text -> [Char] -> TextParser m Text
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"commodity symbol"
quotedcommoditysymbolp :: TextParser m CommoditySymbol
quotedcommoditysymbolp :: forall (m :: * -> *). TextParser m Text
quotedcommoditysymbolp =
ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m Text
-> ParsecT HledgerParseErrorData Text m Text
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Token Text -> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'"') (Token Text -> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'"') (ParsecT HledgerParseErrorData Text m Text
-> ParsecT HledgerParseErrorData Text m Text)
-> ParsecT HledgerParseErrorData Text m Text
-> ParsecT HledgerParseErrorData Text m Text
forall a b. (a -> b) -> a -> b
$ Maybe [Char]
-> (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe [Char]
forall a. Maybe a
Nothing Char -> Bool
Token Text -> Bool
f
where f :: Char -> Bool
f Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
';' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\"'
simplecommoditysymbolp :: TextParser m CommoditySymbol
simplecommoditysymbolp :: forall (m :: * -> *). TextParser m Text
simplecommoditysymbolp = Maybe [Char]
-> (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe [Char]
forall a. Maybe a
Nothing (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isNonsimpleCommodityChar)
costp :: Amount -> JournalParser m AmountCost
costp :: forall (m :: * -> *). Amount -> JournalParser m AmountCost
costp Amount
baseAmt =
[Char]
-> StateT Journal (ParsecT HledgerParseErrorData Text m) AmountCost
-> StateT Journal (ParsecT HledgerParseErrorData Text m) AmountCost
forall a.
[Char]
-> StateT Journal (ParsecT HledgerParseErrorData Text m) a
-> StateT Journal (ParsecT HledgerParseErrorData Text m) a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label [Char]
"transaction price" (StateT Journal (ParsecT HledgerParseErrorData Text m) AmountCost
-> StateT
Journal (ParsecT HledgerParseErrorData Text m) AmountCost)
-> StateT Journal (ParsecT HledgerParseErrorData Text m) AmountCost
-> StateT Journal (ParsecT HledgerParseErrorData Text m) AmountCost
forall a b. (a -> b) -> a -> b
$ do
parenthesised <- Bool
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Bool
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Bool
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Bool
False (StateT Journal (ParsecT HledgerParseErrorData Text m) Bool
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Bool)
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Bool
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Bool
forall a b. (a -> b) -> a -> b
$ Token Text
-> StateT
Journal (ParsecT HledgerParseErrorData Text m) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'(' StateT Journal (ParsecT HledgerParseErrorData Text m) Char
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Bool
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Bool
forall a b.
StateT Journal (ParsecT HledgerParseErrorData Text m) a
-> StateT Journal (ParsecT HledgerParseErrorData Text m) b
-> StateT Journal (ParsecT HledgerParseErrorData Text m) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> StateT Journal (ParsecT HledgerParseErrorData Text m) Bool
forall a.
a -> StateT Journal (ParsecT HledgerParseErrorData Text m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
char '@'
totalCost <- char '@' $> True <|> pure False
when parenthesised $ void $ char ')'
lift skipNonNewlineSpaces
priceAmount <- simpleamountp False
let amtsign' = Quantity -> Quantity
forall a. Num a => a -> a
signum (Quantity -> Quantity) -> Quantity -> Quantity
forall a b. (a -> b) -> a -> b
$ Amount -> Quantity
aquantity Amount
baseAmt
amtsign = if Quantity
amtsign' Quantity -> Quantity -> Bool
forall a. Eq a => a -> a -> Bool
== Quantity
0 then Quantity
1 else Quantity
amtsign'
pure $ if totalCost
then TotalCost priceAmount{aquantity=amtsign * aquantity priceAmount}
else UnitCost priceAmount
valuationexprp :: JournalParser m ()
valuationexprp :: forall (m :: * -> *). JournalParser m ()
valuationexprp =
[Char]
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
forall a.
[Char]
-> StateT Journal (ParsecT HledgerParseErrorData Text m) a
-> StateT Journal (ParsecT HledgerParseErrorData Text m) a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label [Char]
"valuation expression" (StateT Journal (ParsecT HledgerParseErrorData Text m) ()
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ())
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
forall a b. (a -> b) -> a -> b
$ do
Tokens Text
-> StateT
Journal (ParsecT HledgerParseErrorData Text m) (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"(("
_ <- Text -> Text
T.strip (Text -> Text) -> ([Char] -> Text) -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack ([Char] -> Text)
-> StateT Journal (ParsecT HledgerParseErrorData Text m) [Char]
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StateT Journal (ParsecT HledgerParseErrorData Text m) Char
-> StateT Journal (ParsecT HledgerParseErrorData Text m) [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (StateT Journal (ParsecT HledgerParseErrorData Text m) Char
-> StateT Journal (ParsecT HledgerParseErrorData Text m) [Char])
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Char
-> StateT Journal (ParsecT HledgerParseErrorData Text m) [Char]
forall a b. (a -> b) -> a -> b
$ [Token Text]
-> StateT
Journal (ParsecT HledgerParseErrorData Text m) (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
noneOf [Char
')',Char
'\n'])
string "))"
return ()
balanceassertionp :: JournalParser m BalanceAssertion
balanceassertionp :: forall (m :: * -> *). JournalParser m BalanceAssertion
balanceassertionp = do
sourcepos <- StateT Journal (ParsecT HledgerParseErrorData Text m) SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
char '='
istotal <- fmap isJust $ optional $ try $ char '='
isinclusive <- fmap isJust $ optional $ try $ char '*'
lift skipNonNewlineSpaces
a <- amountnobasisp <?> "amount (for a balance assertion or assignment)"
return BalanceAssertion
{ baamount = a
, batotal = istotal
, bainclusive = isinclusive
, baposition = sourcepos
}
lotcostp :: JournalParser m ()
lotcostp :: forall (m :: * -> *). JournalParser m ()
lotcostp =
[Char]
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
forall a.
[Char]
-> StateT Journal (ParsecT HledgerParseErrorData Text m) a
-> StateT Journal (ParsecT HledgerParseErrorData Text m) a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label [Char]
"ledger-style lot cost" (StateT Journal (ParsecT HledgerParseErrorData Text m) ()
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ())
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
forall a b. (a -> b) -> a -> b
$ do
Token Text
-> StateT
Journal (ParsecT HledgerParseErrorData Text m) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'{'
doublebrace <- Bool
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Bool
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Bool
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Bool
False (StateT Journal (ParsecT HledgerParseErrorData Text m) Bool
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Bool)
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Bool
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Bool
forall a b. (a -> b) -> a -> b
$ Token Text
-> StateT
Journal (ParsecT HledgerParseErrorData Text m) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'{' StateT Journal (ParsecT HledgerParseErrorData Text m) Char
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Bool
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Bool
forall a b.
StateT Journal (ParsecT HledgerParseErrorData Text m) a
-> StateT Journal (ParsecT HledgerParseErrorData Text m) b
-> StateT Journal (ParsecT HledgerParseErrorData Text m) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> StateT Journal (ParsecT HledgerParseErrorData Text m) Bool
forall a.
a -> StateT Journal (ParsecT HledgerParseErrorData Text m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
lift skipNonNewlineSpaces
_fixed <- fmap isJust $ optional $ char '='
lift skipNonNewlineSpaces
_a <- simpleamountp False
lift skipNonNewlineSpaces
char '}'
when (doublebrace) $ void $ char '}'
lotdatep :: JournalParser m ()
lotdatep :: forall (m :: * -> *). JournalParser m ()
lotdatep =
[Char]
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
forall a.
[Char]
-> StateT Journal (ParsecT HledgerParseErrorData Text m) a
-> StateT Journal (ParsecT HledgerParseErrorData Text m) a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label [Char]
"ledger-style lot date" (StateT Journal (ParsecT HledgerParseErrorData Text m) ()
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ())
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
forall a b. (a -> b) -> a -> b
$ do
Token Text
-> StateT
Journal (ParsecT HledgerParseErrorData Text m) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'['
ParsecT HledgerParseErrorData Text m ()
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
forall (m :: * -> *) a. Monad m => m a -> StateT Journal m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ParsecT HledgerParseErrorData Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces
_d <- JournalParser m Day
forall (m :: * -> *). JournalParser m Day
datep
lift skipNonNewlineSpaces
char ']'
return ()
lotnotep :: JournalParser m ()
lotnotep :: forall (m :: * -> *). JournalParser m ()
lotnotep =
[Char]
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
forall a.
[Char]
-> StateT Journal (ParsecT HledgerParseErrorData Text m) a
-> StateT Journal (ParsecT HledgerParseErrorData Text m) a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label [Char]
"ledger-style lot note" (StateT Journal (ParsecT HledgerParseErrorData Text m) ()
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ())
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
forall a b. (a -> b) -> a -> b
$ do
Token Text
-> StateT
Journal (ParsecT HledgerParseErrorData Text m) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'('
ParsecT HledgerParseErrorData Text m ()
-> StateT Journal (ParsecT HledgerParseErrorData Text m) ()
forall (m :: * -> *) a. Monad m => m a -> StateT Journal m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ParsecT HledgerParseErrorData Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces
_note <- Text -> Text
stripEnd (Text -> Text) -> ([Char] -> Text) -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack ([Char] -> Text)
-> StateT Journal (ParsecT HledgerParseErrorData Text m) [Char]
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StateT Journal (ParsecT HledgerParseErrorData Text m) Char
-> StateT Journal (ParsecT HledgerParseErrorData Text m) [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (StateT Journal (ParsecT HledgerParseErrorData Text m) Char
-> StateT Journal (ParsecT HledgerParseErrorData Text m) [Char])
-> StateT Journal (ParsecT HledgerParseErrorData Text m) Char
-> StateT Journal (ParsecT HledgerParseErrorData Text m) [Char]
forall a b. (a -> b) -> a -> b
$ [Token Text]
-> StateT
Journal (ParsecT HledgerParseErrorData Text m) (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
noneOf [Char
')',Char
'\n'])
char ')'
return ()
numberp :: Maybe AmountStyle -> TextParser m (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
numberp :: forall (m :: * -> *).
Maybe AmountStyle
-> TextParser
m (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
numberp Maybe AmountStyle
suggestedStyle = [Char]
-> ParsecT
HledgerParseErrorData
Text
m
(Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> ParsecT
HledgerParseErrorData
Text
m
(Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
forall a.
[Char]
-> ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label [Char]
"number" (ParsecT
HledgerParseErrorData
Text
m
(Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> ParsecT
HledgerParseErrorData
Text
m
(Quantity, Word8, Maybe Char, Maybe DigitGroupStyle))
-> ParsecT
HledgerParseErrorData
Text
m
(Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> ParsecT
HledgerParseErrorData
Text
m
(Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
forall a b. (a -> b) -> a -> b
$ do
sign <- TextParser m (Quantity -> Quantity)
forall a (m :: * -> *). Num a => TextParser m (a -> a)
signp
rawNum <- either (disambiguateNumber suggestedStyle) id <$> rawnumberp
mExp <- optional $ try $ exponentp
dbg7 "numberp suggestedStyle" suggestedStyle `seq` return ()
case dbg7 "numberp quantity,precision,mdecimalpoint,mgrps"
$ fromRawNumber rawNum mExp of
Left [Char]
errMsg -> [Char]
-> ParsecT
HledgerParseErrorData
Text
m
(Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
forall a. [Char] -> ParsecT HledgerParseErrorData Text m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
Fail.fail [Char]
errMsg
Right (Quantity
q, Word8
p, Maybe Char
d, Maybe DigitGroupStyle
g) -> (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> ParsecT
HledgerParseErrorData
Text
m
(Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
forall a. a -> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Quantity -> Quantity
sign Quantity
q, Word8
p, Maybe Char
d, Maybe DigitGroupStyle
g)
exponentp :: TextParser m Integer
exponentp :: forall (m :: * -> *). TextParser m Integer
exponentp = Token Text -> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char' Char
Token Text
'e' ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m (Integer -> Integer)
-> ParsecT HledgerParseErrorData Text m (Integer -> Integer)
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT HledgerParseErrorData Text m (Integer -> Integer)
forall a (m :: * -> *). Num a => TextParser m (a -> a)
signp ParsecT HledgerParseErrorData Text m (Integer -> Integer)
-> ParsecT HledgerParseErrorData Text m Integer
-> ParsecT HledgerParseErrorData Text m Integer
forall a b.
ParsecT HledgerParseErrorData Text m (a -> b)
-> ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT HledgerParseErrorData Text m Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal ParsecT HledgerParseErrorData Text m Integer
-> [Char] -> ParsecT HledgerParseErrorData Text m Integer
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"exponent"
fromRawNumber
:: RawNumber
-> Maybe Integer
-> Either String
(Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
fromRawNumber :: RawNumber
-> Maybe Integer
-> Either
[Char] (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
fromRawNumber (WithSeparators{}) (Just Integer
_) =
[Char]
-> Either
[Char] (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
forall a b. a -> Either a b
Left [Char]
"invalid number: digit separators and exponents may not be used together"
fromRawNumber RawNumber
raw Maybe Integer
mExp = do
(quantity, precision) <- Integer -> DigitGrp -> DigitGrp -> Either [Char] (Quantity, Word8)
toQuantity (Integer -> Maybe Integer -> Integer
forall a. a -> Maybe a -> a
fromMaybe Integer
0 Maybe Integer
mExp) (RawNumber -> DigitGrp
digitGroup RawNumber
raw) (RawNumber -> DigitGrp
decimalGroup RawNumber
raw)
return (quantity, precision, mDecPt raw, digitGroupStyle raw)
where
toQuantity :: Integer -> DigitGrp -> DigitGrp -> Either String (Quantity, Word8)
toQuantity :: Integer -> DigitGrp -> DigitGrp -> Either [Char] (Quantity, Word8)
toQuantity Integer
e DigitGrp
preDecimalGrp DigitGrp
postDecimalGrp
| Integer
precision Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 = (Quantity, Word8) -> Either [Char] (Quantity, Word8)
forall a b. b -> Either a b
Right (Word8 -> Integer -> Quantity
forall i. Word8 -> i -> DecimalRaw i
Decimal Word8
0 (Integer
digitGrpNum Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
10Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(-Integer
precision)), Word8
0)
| Integer
precision Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
256 = (Quantity, Word8) -> Either [Char] (Quantity, Word8)
forall a b. b -> Either a b
Right (Word8 -> Integer -> Quantity
forall i. Word8 -> i -> DecimalRaw i
Decimal Word8
precision8 Integer
digitGrpNum, Word8
precision8)
| Bool
otherwise = [Char] -> Either [Char] (Quantity, Word8)
forall a b. a -> Either a b
Left [Char]
"invalid number: numbers with more than 255 decimal places are currently not supported"
where
digitGrpNum :: Integer
digitGrpNum = DigitGrp -> Integer
digitGroupNumber (DigitGrp -> Integer) -> DigitGrp -> Integer
forall a b. (a -> b) -> a -> b
$ DigitGrp
preDecimalGrp DigitGrp -> DigitGrp -> DigitGrp
forall a. Semigroup a => a -> a -> a
<> DigitGrp
postDecimalGrp
precision :: Integer
precision = Word -> Integer
forall a. Integral a => a -> Integer
toInteger (DigitGrp -> Word
digitGroupLength DigitGrp
postDecimalGrp) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
e
precision8 :: Word8
precision8 = Integer -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
precision :: Word8
mDecPt :: RawNumber -> Maybe Char
mDecPt (NoSeparators DigitGrp
_ Maybe (Char, DigitGrp)
mDecimals) = (Char, DigitGrp) -> Char
forall a b. (a, b) -> a
fst ((Char, DigitGrp) -> Char) -> Maybe (Char, DigitGrp) -> Maybe Char
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Char, DigitGrp)
mDecimals
mDecPt (WithSeparators Char
_ [DigitGrp]
_ Maybe (Char, DigitGrp)
mDecimals) = (Char, DigitGrp) -> Char
forall a b. (a, b) -> a
fst ((Char, DigitGrp) -> Char) -> Maybe (Char, DigitGrp) -> Maybe Char
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Char, DigitGrp)
mDecimals
decimalGroup :: RawNumber -> DigitGrp
decimalGroup (NoSeparators DigitGrp
_ Maybe (Char, DigitGrp)
mDecimals) = DigitGrp
-> ((Char, DigitGrp) -> DigitGrp)
-> Maybe (Char, DigitGrp)
-> DigitGrp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe DigitGrp
forall a. Monoid a => a
mempty (Char, DigitGrp) -> DigitGrp
forall a b. (a, b) -> b
snd Maybe (Char, DigitGrp)
mDecimals
decimalGroup (WithSeparators Char
_ [DigitGrp]
_ Maybe (Char, DigitGrp)
mDecimals) = DigitGrp
-> ((Char, DigitGrp) -> DigitGrp)
-> Maybe (Char, DigitGrp)
-> DigitGrp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe DigitGrp
forall a. Monoid a => a
mempty (Char, DigitGrp) -> DigitGrp
forall a b. (a, b) -> b
snd Maybe (Char, DigitGrp)
mDecimals
digitGroup :: RawNumber -> DigitGrp
digitGroup (NoSeparators DigitGrp
digitGrp Maybe (Char, DigitGrp)
_) = DigitGrp
digitGrp
digitGroup (WithSeparators Char
_ [DigitGrp]
digitGrps Maybe (Char, DigitGrp)
_) = [DigitGrp] -> DigitGrp
forall a. Monoid a => [a] -> a
mconcat [DigitGrp]
digitGrps
digitGroupStyle :: RawNumber -> Maybe DigitGroupStyle
digitGroupStyle (NoSeparators DigitGrp
_ Maybe (Char, DigitGrp)
_) = Maybe DigitGroupStyle
forall a. Maybe a
Nothing
digitGroupStyle (WithSeparators Char
sep [DigitGrp]
grps Maybe (Char, DigitGrp)
_) = DigitGroupStyle -> Maybe DigitGroupStyle
forall a. a -> Maybe a
Just (DigitGroupStyle -> Maybe DigitGroupStyle)
-> ([Word8] -> DigitGroupStyle) -> [Word8] -> Maybe DigitGroupStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> [Word8] -> DigitGroupStyle
DigitGroups Char
sep ([Word8] -> Maybe DigitGroupStyle)
-> [Word8] -> Maybe DigitGroupStyle
forall a b. (a -> b) -> a -> b
$ [DigitGrp] -> [Word8]
groupSizes [DigitGrp]
grps
groupSizes :: [DigitGrp] -> [Word8]
groupSizes :: [DigitGrp] -> [Word8]
groupSizes [DigitGrp]
digitGrps = [Word8] -> [Word8]
forall a. [a] -> [a]
reverse ([Word8] -> [Word8]) -> [Word8] -> [Word8]
forall a b. (a -> b) -> a -> b
$ case (DigitGrp -> Word8) -> [DigitGrp] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map (Word -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Word8) -> (DigitGrp -> Word) -> DigitGrp -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DigitGrp -> Word
digitGroupLength) [DigitGrp]
digitGrps of
(Word8
a:Word8
b:[Word8]
cs) | Word8
a Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
b -> Word8
bWord8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
:[Word8]
cs
[Word8]
gs -> [Word8]
gs
disambiguateNumber :: Maybe AmountStyle -> AmbiguousNumber -> RawNumber
disambiguateNumber :: Maybe AmountStyle -> AmbiguousNumber -> RawNumber
disambiguateNumber Maybe AmountStyle
msuggestedStyle (AmbiguousNumber DigitGrp
grp1 Char
sep DigitGrp
grp2) =
if Char -> Bool
isDecimalMark Char
sep Bool -> Bool -> Bool
&&
Bool -> (AmountStyle -> Bool) -> Maybe AmountStyle -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Char
sep Char -> AmountStyle -> Bool
`isValidDecimalBy`) Maybe AmountStyle
msuggestedStyle
then DigitGrp -> Maybe (Char, DigitGrp) -> RawNumber
NoSeparators DigitGrp
grp1 ((Char, DigitGrp) -> Maybe (Char, DigitGrp)
forall a. a -> Maybe a
Just (Char
sep, DigitGrp
grp2))
else Char -> [DigitGrp] -> Maybe (Char, DigitGrp) -> RawNumber
WithSeparators Char
sep [DigitGrp
grp1, DigitGrp
grp2] Maybe (Char, DigitGrp)
forall a. Maybe a
Nothing
where
isValidDecimalBy :: Char -> AmountStyle -> Bool
isValidDecimalBy :: Char -> AmountStyle -> Bool
isValidDecimalBy Char
c = \case
AmountStyle{asdecimalmark :: AmountStyle -> Maybe Char
asdecimalmark = Just Char
d} -> Char
d Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c
AmountStyle{asdigitgroups :: AmountStyle -> Maybe DigitGroupStyle
asdigitgroups = Just (DigitGroups Char
g [Word8]
_)} -> Char
g Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
c
AmountStyle{asprecision :: AmountStyle -> AmountPrecision
asprecision = Precision Word8
0} -> Bool
False
AmountStyle
_ -> Bool
True
rawnumberp :: TextParser m (Either AmbiguousNumber RawNumber)
rawnumberp :: forall (m :: * -> *).
TextParser m (Either AmbiguousNumber RawNumber)
rawnumberp = [Char]
-> ParsecT
HledgerParseErrorData Text m (Either AmbiguousNumber RawNumber)
-> ParsecT
HledgerParseErrorData Text m (Either AmbiguousNumber RawNumber)
forall a.
[Char]
-> ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label [Char]
"number" (ParsecT
HledgerParseErrorData Text m (Either AmbiguousNumber RawNumber)
-> ParsecT
HledgerParseErrorData Text m (Either AmbiguousNumber RawNumber))
-> ParsecT
HledgerParseErrorData Text m (Either AmbiguousNumber RawNumber)
-> ParsecT
HledgerParseErrorData Text m (Either AmbiguousNumber RawNumber)
forall a b. (a -> b) -> a -> b
$ do
rawNumber <- (RawNumber -> Either AmbiguousNumber RawNumber)
-> ParsecT HledgerParseErrorData Text m RawNumber
-> ParsecT
HledgerParseErrorData Text m (Either AmbiguousNumber RawNumber)
forall a b.
(a -> b)
-> ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RawNumber -> Either AmbiguousNumber RawNumber
forall a b. b -> Either a b
Right ParsecT HledgerParseErrorData Text m RawNumber
forall (m :: * -> *). TextParser m RawNumber
leadingDecimalPt ParsecT
HledgerParseErrorData Text m (Either AmbiguousNumber RawNumber)
-> ParsecT
HledgerParseErrorData Text m (Either AmbiguousNumber RawNumber)
-> ParsecT
HledgerParseErrorData Text m (Either AmbiguousNumber RawNumber)
forall a.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT
HledgerParseErrorData Text m (Either AmbiguousNumber RawNumber)
forall (m :: * -> *).
TextParser m (Either AmbiguousNumber RawNumber)
leadingDigits
mExtraDecimalSep <- optional $ lookAhead $ satisfy isDecimalMark
when (isJust mExtraDecimalSep) $
Fail.fail "invalid number (invalid use of separator)"
mExtraFragment <- optional $ lookAhead $ try $
char ' ' *> getOffset <* digitChar
case mExtraFragment of
Just Int
off -> HledgerParseErrorData -> ParsecT HledgerParseErrorData Text m ()
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (HledgerParseErrorData -> ParsecT HledgerParseErrorData Text m ())
-> HledgerParseErrorData -> ParsecT HledgerParseErrorData Text m ()
forall a b. (a -> b) -> a -> b
$
Int -> [Char] -> HledgerParseErrorData
parseErrorAt Int
off [Char]
"invalid number (excessive trailing digits)"
Maybe Int
Nothing -> () -> ParsecT HledgerParseErrorData Text m ()
forall a. a -> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
return $ dbg7 "rawnumberp" rawNumber
where
leadingDecimalPt :: TextParser m RawNumber
leadingDecimalPt :: forall (m :: * -> *). TextParser m RawNumber
leadingDecimalPt = do
decPt <- (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
isDecimalMark
decGrp <- digitgroupp
pure $ NoSeparators mempty (Just (decPt, decGrp))
leadingDigits :: TextParser m (Either AmbiguousNumber RawNumber)
leadingDigits :: forall (m :: * -> *).
TextParser m (Either AmbiguousNumber RawNumber)
leadingDigits = do
grp1 <- TextParser m DigitGrp
forall (m :: * -> *). TextParser m DigitGrp
digitgroupp
withSeparators grp1 <|> fmap Right (trailingDecimalPt grp1)
<|> pure (Right $ NoSeparators grp1 Nothing)
withSeparators :: DigitGrp -> TextParser m (Either AmbiguousNumber RawNumber)
withSeparators :: forall (m :: * -> *).
DigitGrp -> TextParser m (Either AmbiguousNumber RawNumber)
withSeparators DigitGrp
grp1 = do
(sep, grp2) <- ParsecT HledgerParseErrorData Text m (Char, DigitGrp)
-> ParsecT HledgerParseErrorData Text m (Char, DigitGrp)
forall a.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT HledgerParseErrorData Text m (Char, DigitGrp)
-> ParsecT HledgerParseErrorData Text m (Char, DigitGrp))
-> ParsecT HledgerParseErrorData Text m (Char, DigitGrp)
-> ParsecT HledgerParseErrorData Text m (Char, DigitGrp)
forall a b. (a -> b) -> a -> b
$ (,) (Char -> DigitGrp -> (Char, DigitGrp))
-> ParsecT HledgerParseErrorData Text m Char
-> ParsecT
HledgerParseErrorData Text m (DigitGrp -> (Char, DigitGrp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
isDigitSeparatorChar ParsecT HledgerParseErrorData Text m (DigitGrp -> (Char, DigitGrp))
-> ParsecT HledgerParseErrorData Text m DigitGrp
-> ParsecT HledgerParseErrorData Text m (Char, DigitGrp)
forall a b.
ParsecT HledgerParseErrorData Text m (a -> b)
-> ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT HledgerParseErrorData Text m DigitGrp
forall (m :: * -> *). TextParser m DigitGrp
digitgroupp
grps <- many $ try $ char sep *> digitgroupp
let digitGroups = DigitGrp
grp1 DigitGrp -> [DigitGrp] -> [DigitGrp]
forall a. a -> [a] -> [a]
: DigitGrp
grp2 DigitGrp -> [DigitGrp] -> [DigitGrp]
forall a. a -> [a] -> [a]
: [DigitGrp]
grps
fmap Right (withDecimalPt sep digitGroups)
<|> pure (withoutDecimalPt grp1 sep grp2 grps)
withDecimalPt :: Char -> [DigitGrp] -> TextParser m RawNumber
withDecimalPt :: forall (m :: * -> *). Char -> [DigitGrp] -> TextParser m RawNumber
withDecimalPt Char
digitSep [DigitGrp]
digitGroups = do
decPt <- (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy ((Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Token Text))
-> (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Token Text)
forall a b. (a -> b) -> a -> b
$ \Token Text
c -> Char -> Bool
isDecimalMark Char
Token Text
c Bool -> Bool -> Bool
&& Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
digitSep
decDigitGrp <- option mempty digitgroupp
pure $ WithSeparators digitSep digitGroups (Just (decPt, decDigitGrp))
withoutDecimalPt
:: DigitGrp
-> Char
-> DigitGrp
-> [DigitGrp]
-> Either AmbiguousNumber RawNumber
withoutDecimalPt :: DigitGrp
-> Char
-> DigitGrp
-> [DigitGrp]
-> Either AmbiguousNumber RawNumber
withoutDecimalPt DigitGrp
grp1 Char
sep DigitGrp
grp2 [DigitGrp]
grps
| [DigitGrp] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DigitGrp]
grps Bool -> Bool -> Bool
&& Char -> Bool
isDecimalMark Char
sep =
AmbiguousNumber -> Either AmbiguousNumber RawNumber
forall a b. a -> Either a b
Left (AmbiguousNumber -> Either AmbiguousNumber RawNumber)
-> AmbiguousNumber -> Either AmbiguousNumber RawNumber
forall a b. (a -> b) -> a -> b
$ DigitGrp -> Char -> DigitGrp -> AmbiguousNumber
AmbiguousNumber DigitGrp
grp1 Char
sep DigitGrp
grp2
| Bool
otherwise = RawNumber -> Either AmbiguousNumber RawNumber
forall a b. b -> Either a b
Right (RawNumber -> Either AmbiguousNumber RawNumber)
-> RawNumber -> Either AmbiguousNumber RawNumber
forall a b. (a -> b) -> a -> b
$ Char -> [DigitGrp] -> Maybe (Char, DigitGrp) -> RawNumber
WithSeparators Char
sep (DigitGrp
grp1DigitGrp -> [DigitGrp] -> [DigitGrp]
forall a. a -> [a] -> [a]
:DigitGrp
grp2DigitGrp -> [DigitGrp] -> [DigitGrp]
forall a. a -> [a] -> [a]
:[DigitGrp]
grps) Maybe (Char, DigitGrp)
forall a. Maybe a
Nothing
trailingDecimalPt :: DigitGrp -> TextParser m RawNumber
trailingDecimalPt :: forall (m :: * -> *). DigitGrp -> TextParser m RawNumber
trailingDecimalPt DigitGrp
grp1 = do
decPt <- (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
isDecimalMark
pure $ NoSeparators grp1 (Just (decPt, mempty))
isDigitSeparatorChar :: Char -> Bool
isDigitSeparatorChar :: Char -> Bool
isDigitSeparatorChar Char
c = Char -> Bool
isDecimalMark Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigitSeparatorSpaceChar Char
c
isDigitSeparatorSpaceChar :: Char -> Bool
isDigitSeparatorSpaceChar :: Char -> Bool
isDigitSeparatorSpaceChar Char
c =
Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' '
Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' '
Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' '
Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' '
Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' '
Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' '
Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' '
Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' '
data RawNumber
= NoSeparators DigitGrp (Maybe (Char, DigitGrp))
| WithSeparators Char [DigitGrp] (Maybe (Char, DigitGrp))
deriving (Int -> RawNumber -> ShowS
[RawNumber] -> ShowS
RawNumber -> [Char]
(Int -> RawNumber -> ShowS)
-> (RawNumber -> [Char])
-> ([RawNumber] -> ShowS)
-> Show RawNumber
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RawNumber -> ShowS
showsPrec :: Int -> RawNumber -> ShowS
$cshow :: RawNumber -> [Char]
show :: RawNumber -> [Char]
$cshowList :: [RawNumber] -> ShowS
showList :: [RawNumber] -> ShowS
Show, RawNumber -> RawNumber -> Bool
(RawNumber -> RawNumber -> Bool)
-> (RawNumber -> RawNumber -> Bool) -> Eq RawNumber
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RawNumber -> RawNumber -> Bool
== :: RawNumber -> RawNumber -> Bool
$c/= :: RawNumber -> RawNumber -> Bool
/= :: RawNumber -> RawNumber -> Bool
Eq)
data AmbiguousNumber = AmbiguousNumber DigitGrp Char DigitGrp
deriving (Int -> AmbiguousNumber -> ShowS
[AmbiguousNumber] -> ShowS
AmbiguousNumber -> [Char]
(Int -> AmbiguousNumber -> ShowS)
-> (AmbiguousNumber -> [Char])
-> ([AmbiguousNumber] -> ShowS)
-> Show AmbiguousNumber
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AmbiguousNumber -> ShowS
showsPrec :: Int -> AmbiguousNumber -> ShowS
$cshow :: AmbiguousNumber -> [Char]
show :: AmbiguousNumber -> [Char]
$cshowList :: [AmbiguousNumber] -> ShowS
showList :: [AmbiguousNumber] -> ShowS
Show, AmbiguousNumber -> AmbiguousNumber -> Bool
(AmbiguousNumber -> AmbiguousNumber -> Bool)
-> (AmbiguousNumber -> AmbiguousNumber -> Bool)
-> Eq AmbiguousNumber
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AmbiguousNumber -> AmbiguousNumber -> Bool
== :: AmbiguousNumber -> AmbiguousNumber -> Bool
$c/= :: AmbiguousNumber -> AmbiguousNumber -> Bool
/= :: AmbiguousNumber -> AmbiguousNumber -> Bool
Eq)
data DigitGrp = DigitGrp {
DigitGrp -> Word
digitGroupLength :: !Word,
DigitGrp -> Integer
digitGroupNumber :: !Integer
} deriving (DigitGrp -> DigitGrp -> Bool
(DigitGrp -> DigitGrp -> Bool)
-> (DigitGrp -> DigitGrp -> Bool) -> Eq DigitGrp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DigitGrp -> DigitGrp -> Bool
== :: DigitGrp -> DigitGrp -> Bool
$c/= :: DigitGrp -> DigitGrp -> Bool
/= :: DigitGrp -> DigitGrp -> Bool
Eq)
instance Show DigitGrp where
show :: DigitGrp -> [Char]
show (DigitGrp Word
len Integer
n) = [Char]
"\"" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
padding [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
numStr [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\""
where numStr :: [Char]
numStr = Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
n
padding :: [Char]
padding = Integer -> Char -> [Char]
forall i a. Integral i => i -> a -> [a]
genericReplicate (Word -> Integer
forall a. Integral a => a -> Integer
toInteger Word
len Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Int -> Integer
forall a. Integral a => a -> Integer
toInteger ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
numStr)) Char
'0'
instance Sem.Semigroup DigitGrp where
DigitGrp Word
l1 Integer
n1 <> :: DigitGrp -> DigitGrp -> DigitGrp
<> DigitGrp Word
l2 Integer
n2 = Word -> Integer -> DigitGrp
DigitGrp (Word
l1 Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
l2) (Integer
n1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
10Integer -> Word -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^Word
l2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
n2)
instance Monoid DigitGrp where
mempty :: DigitGrp
mempty = Word -> Integer -> DigitGrp
DigitGrp Word
0 Integer
0
mappend :: DigitGrp -> DigitGrp -> DigitGrp
mappend = DigitGrp -> DigitGrp -> DigitGrp
forall a. Semigroup a => a -> a -> a
(Sem.<>)
digitgroupp :: TextParser m DigitGrp
digitgroupp :: forall (m :: * -> *). TextParser m DigitGrp
digitgroupp = [Char]
-> ParsecT HledgerParseErrorData Text m DigitGrp
-> ParsecT HledgerParseErrorData Text m DigitGrp
forall a.
[Char]
-> ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label [Char]
"digits"
(ParsecT HledgerParseErrorData Text m DigitGrp
-> ParsecT HledgerParseErrorData Text m DigitGrp)
-> ParsecT HledgerParseErrorData Text m DigitGrp
-> ParsecT HledgerParseErrorData Text m DigitGrp
forall a b. (a -> b) -> a -> b
$ Text -> DigitGrp
makeGroup (Text -> DigitGrp)
-> ParsecT HledgerParseErrorData Text m Text
-> ParsecT HledgerParseErrorData Text m DigitGrp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Char]
-> (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"digit") Char -> Bool
Token Text -> Bool
isDigit
where
makeGroup :: Text -> DigitGrp
makeGroup = (Word -> Integer -> DigitGrp) -> (Word, Integer) -> DigitGrp
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Word -> Integer -> DigitGrp
DigitGrp ((Word, Integer) -> DigitGrp)
-> (Text -> (Word, Integer)) -> Text -> DigitGrp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Word, Integer) -> Char -> (Word, Integer))
-> (Word, Integer) -> Text -> (Word, Integer)
forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl' (Word, Integer) -> Char -> (Word, Integer)
forall {a} {b}. (Num a, Num b) => (a, b) -> Char -> (a, b)
step (Word
0, Integer
0)
step :: (a, b) -> Char -> (a, b)
step (!a
l, !b
a) Char
c = (a
la -> a -> a
forall a. Num a => a -> a -> a
+a
1, b
ab -> b -> b
forall a. Num a => a -> a -> a
*b
10 b -> b -> b
forall a. Num a => a -> a -> a
+ Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
digitToInt Char
c))
multilinecommentp :: TextParser m ()
= ParsecT HledgerParseErrorData Text m ()
startComment ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT HledgerParseErrorData Text m ()
anyLine ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m end
`skipManyTill` ParsecT HledgerParseErrorData Text m ()
endComment
where
startComment :: ParsecT HledgerParseErrorData Text m ()
startComment = Tokens Text -> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"comment" ParsecT HledgerParseErrorData Text m (Tokens Text)
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT HledgerParseErrorData Text m ()
forall (m :: * -> *). TextParser m ()
trailingSpaces
endComment :: ParsecT HledgerParseErrorData Text m ()
endComment = ParsecT HledgerParseErrorData Text m ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
forall a.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text -> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"end comment" ParsecT HledgerParseErrorData Text m (Tokens Text)
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT HledgerParseErrorData Text m ()
forall (m :: * -> *). TextParser m ()
trailingSpaces
trailingSpaces :: ParsecT HledgerParseErrorData Text m ()
trailingSpaces = ParsecT HledgerParseErrorData Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m ()
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT HledgerParseErrorData Text m Char
ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline
anyLine :: ParsecT HledgerParseErrorData Text m ()
anyLine = ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m ())
-> ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m ()
forall a b. (a -> b) -> a -> b
$ Maybe [Char]
-> (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe [Char]
forall a. Maybe a
Nothing (Token Text -> Token Text -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
Token Text
'\n') ParsecT HledgerParseErrorData Text m (Tokens Text)
-> ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m Char
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT HledgerParseErrorData Text m Char
ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline
{-# INLINABLE multilinecommentp #-}
emptyorcommentlinep :: TextParser m ()
= do
[Char] -> TextParser m ()
forall (m :: * -> *). [Char] -> TextParser m ()
dp [Char]
"emptyorcommentlinep"
TextParser m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces
TextParser m ()
forall (m :: * -> *). TextParser m ()
skiplinecommentp TextParser m () -> TextParser m () -> TextParser m ()
forall a.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT HledgerParseErrorData Text m Char -> TextParser m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT HledgerParseErrorData Text m Char
ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline
where
skiplinecommentp :: TextParser m ()
skiplinecommentp :: forall (m :: * -> *). TextParser m ()
skiplinecommentp = do
(Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
isLineCommentStart
ParsecT HledgerParseErrorData Text m (Tokens Text)
-> ParsecT HledgerParseErrorData Text m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT HledgerParseErrorData Text m (Tokens Text)
-> ParsecT HledgerParseErrorData Text m ())
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
-> ParsecT HledgerParseErrorData Text m ()
forall a b. (a -> b) -> a -> b
$ Maybe [Char]
-> (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe [Char]
forall a. Maybe a
Nothing (Token Text -> Token Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
Token Text
'\n')
ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT HledgerParseErrorData Text m Char
ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline
() -> ParsecT HledgerParseErrorData Text m ()
forall a. a -> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINABLE emptyorcommentlinep #-}
emptyorcommentlinep2 :: [Char] -> TextParser m ()
[Char]
cs =
[Char]
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
forall a.
[Char]
-> ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label ([Char]
"empty line or comment line beginning with "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
cs) (ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ())
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
forall a b. (a -> b) -> a -> b
$ do
[Char] -> ParsecT HledgerParseErrorData Text m ()
forall (m :: * -> *). [Char] -> TextParser m ()
dp [Char]
"emptyorcommentlinep2"
ParsecT HledgerParseErrorData Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces
ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT HledgerParseErrorData Text m Char
ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
forall a.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT HledgerParseErrorData Text m (Tokens Text)
-> ParsecT HledgerParseErrorData Text m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT HledgerParseErrorData Text m (Tokens Text)
commentp
where
commentp :: ParsecT HledgerParseErrorData Text m (Tokens Text)
commentp = do
[ParsecT HledgerParseErrorData Text m [Char]]
-> ParsecT HledgerParseErrorData Text m [Char]
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ((Char -> ParsecT HledgerParseErrorData Text m [Char])
-> [Char] -> [ParsecT HledgerParseErrorData Text m [Char]]
forall a b. (a -> b) -> [a] -> [b]
map (ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some(ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m [Char])
-> (Char -> ParsecT HledgerParseErrorData Text m Char)
-> Char
-> ParsecT HledgerParseErrorData Text m [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ParsecT HledgerParseErrorData Text m Char
Token Text -> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char) [Char]
cs)
Maybe [Char]
-> (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe [Char]
forall a. Maybe a
Nothing (Token Text -> Token Text -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
Token Text
'\n') ParsecT HledgerParseErrorData Text m (Tokens Text)
-> ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT HledgerParseErrorData Text m Char
ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline
isLineCommentStart :: Char -> Bool
Char
'#' = Bool
True
isLineCommentStart Char
'*' = Bool
True
isLineCommentStart Char
';' = Bool
True
isLineCommentStart Char
_ = Bool
False
isSameLineCommentStart :: Char -> Bool
Char
';' = Bool
True
isSameLineCommentStart Char
_ = Bool
False
followingcommentp :: TextParser m Text
=
(Text, ()) -> Text
forall a b. (a, b) -> a
fst ((Text, ()) -> Text)
-> ParsecT HledgerParseErrorData Text m (Text, ())
-> ParsecT HledgerParseErrorData Text m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextParser m () -> ParsecT HledgerParseErrorData Text m (Text, ())
forall a (m :: * -> *).
(Monoid a, Show a) =>
TextParser m a -> TextParser m (Text, a)
followingcommentpWith (ParsecT HledgerParseErrorData Text m (Tokens Text)
-> TextParser m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT HledgerParseErrorData Text m (Tokens Text)
-> TextParser m ())
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
-> TextParser m ()
forall a b. (a -> b) -> a -> b
$ Maybe [Char]
-> (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe [Char]
forall a. Maybe a
Nothing (Token Text -> Token Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
Token Text
'\n'))
{-# INLINABLE followingcommentp #-}
followingcommentpWith :: (Monoid a, Show a) => TextParser m a -> TextParser m (Text, a)
TextParser m a
contentp = do
ParsecT HledgerParseErrorData Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces
sameLine <- ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
forall a.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT HledgerParseErrorData Text m ()
forall (m :: * -> *). TextParser m ()
headerp ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m [(Text, a)]
-> ParsecT HledgerParseErrorData Text m [(Text, a)]
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (((Text, a) -> [(Text, a)] -> [(Text, a)]
forall a. a -> [a] -> [a]
:[]) ((Text, a) -> [(Text, a)])
-> ParsecT HledgerParseErrorData Text m (Text, a)
-> ParsecT HledgerParseErrorData Text m [(Text, a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextParser m a -> ParsecT HledgerParseErrorData Text m (Text, a)
forall (m :: * -> *) a. TextParser m a -> TextParser m (Text, a)
match' TextParser m a
contentp) ParsecT HledgerParseErrorData Text m [(Text, a)]
-> ParsecT HledgerParseErrorData Text m [(Text, a)]
-> ParsecT HledgerParseErrorData Text m [(Text, a)]
forall a.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [(Text, a)] -> ParsecT HledgerParseErrorData Text m [(Text, a)]
forall a. a -> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
_ <- eolof
nextLines <- many $
try (skipNonNewlineSpaces1 *> headerp) *> match' contentp <* eolof
let
sameLine' | [(Text, a)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Text, a)]
sameLine Bool -> Bool -> Bool
&& Bool -> Bool
not ([(Text, a)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Text, a)]
nextLines) = [(Text
"",a
forall a. Monoid a => a
mempty)]
| Bool
otherwise = [(Text, a)]
sameLine
(texts, contents) = unzip $ sameLine' ++ nextLines
strippedCommentText = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.strip [Text]
texts
commentContent = [a] -> a
forall a. Monoid a => [a] -> a
mconcat [a]
contents
pure (strippedCommentText, commentContent)
where
headerp :: ParsecT HledgerParseErrorData Text m ()
headerp = Token Text -> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
';' ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT HledgerParseErrorData Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces
{-# INLINABLE followingcommentpWith #-}
commentlinetagsp :: TextParser m [Tag]
= do
tagName <- ([Text] -> Text
forall a. HasCallStack => [a] -> a
last ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
T.split Char -> Bool
isSpace) (Text -> Text)
-> ParsecT HledgerParseErrorData Text m Text
-> ParsecT HledgerParseErrorData Text m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Char]
-> (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe [Char]
forall a. Maybe a
Nothing (\Token Text
c -> Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':' Bool -> Bool -> Bool
&& Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n')
atColon tagName <|> pure []
where
atColon :: Text -> TextParser m [Tag]
atColon :: forall (m :: * -> *). Text -> TextParser m [Tag]
atColon Text
name = Token Text -> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
':' ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m [Tag]
-> ParsecT HledgerParseErrorData Text m [Tag]
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> do
if Text -> Bool
T.null Text
name
then ParsecT HledgerParseErrorData Text m [Tag]
forall (m :: * -> *). TextParser m [Tag]
commentlinetagsp
else do
ParsecT HledgerParseErrorData Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces
val <- TextParser m Text
forall (m :: * -> *). TextParser m Text
tagValue
let tag = (Text
name, Text
val)
(tag:) <$> commentlinetagsp
tagValue :: TextParser m Text
tagValue :: forall (m :: * -> *). TextParser m Text
tagValue = do
val <- Text -> Text
T.strip (Text -> Text)
-> ParsecT HledgerParseErrorData Text m Text
-> ParsecT HledgerParseErrorData Text m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Char]
-> (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe [Char]
forall a. Maybe a
Nothing (\Token Text
c -> Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
',' Bool -> Bool -> Bool
&& Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n')
_ <- optional $ char ','
pure val
{-# INLINABLE commentlinetagsp #-}
transactioncommentp :: TextParser m (Text, [Tag])
= TextParser m [Tag] -> TextParser m (Text, [Tag])
forall a (m :: * -> *).
(Monoid a, Show a) =>
TextParser m a -> TextParser m (Text, a)
followingcommentpWith TextParser m [Tag]
forall (m :: * -> *). TextParser m [Tag]
commentlinetagsp
{-# INLINABLE transactioncommentp #-}
postingcommentp
:: Maybe Year -> TextParser m (Text, [Tag], Maybe Day, Maybe Day)
Maybe Integer
mYear = do
(commentText, (tags, dateTags)) <-
TextParser m ([Tag], [DateTag])
-> TextParser m (Text, ([Tag], [DateTag]))
forall a (m :: * -> *).
(Monoid a, Show a) =>
TextParser m a -> TextParser m (Text, a)
followingcommentpWith (Maybe Integer -> TextParser m ([Tag], [DateTag])
forall (m :: * -> *).
Maybe Integer -> TextParser m ([Tag], [DateTag])
commenttagsanddatesp Maybe Integer
mYear)
let mdate = DateTag -> Day
forall a b. (a, b) -> b
snd (DateTag -> Day) -> Maybe DateTag -> Maybe Day
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DateTag -> Bool) -> [DateTag] -> Maybe DateTag
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==Text
"date") (Text -> Bool) -> (DateTag -> Text) -> DateTag -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.DateTag -> Text
forall a b. (a, b) -> a
fst) [DateTag]
dateTags
mdate2 = DateTag -> Day
forall a b. (a, b) -> b
snd (DateTag -> Day) -> Maybe DateTag -> Maybe Day
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DateTag -> Bool) -> [DateTag] -> Maybe DateTag
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==Text
"date2")(Text -> Bool) -> (DateTag -> Text) -> DateTag -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.DateTag -> Text
forall a b. (a, b) -> a
fst) [DateTag]
dateTags
pure (commentText, tags, mdate, mdate2)
{-# INLINABLE postingcommentp #-}
commenttagsanddatesp
:: Maybe Year -> TextParser m ([Tag], [DateTag])
commenttagsanddatesp :: forall (m :: * -> *).
Maybe Integer -> TextParser m ([Tag], [DateTag])
commenttagsanddatesp Maybe Integer
mYear = do
(txt, dateTags) <- ParsecT HledgerParseErrorData Text m [DateTag]
-> ParsecT HledgerParseErrorData Text m (Tokens Text, [DateTag])
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> m (Tokens s, a)
match (ParsecT HledgerParseErrorData Text m [DateTag]
-> ParsecT HledgerParseErrorData Text m (Tokens Text, [DateTag]))
-> ParsecT HledgerParseErrorData Text m [DateTag]
-> ParsecT HledgerParseErrorData Text m (Tokens Text, [DateTag])
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT HledgerParseErrorData Text m [DateTag]
forall (m :: * -> *). Char -> TextParser m [DateTag]
readUpTo Char
':'
let tagName = [Text] -> Text
forall a. HasCallStack => [a] -> a
last ((Char -> Bool) -> Text -> [Text]
T.split Char -> Bool
isSpace Text
txt)
(fmap.second) (dateTags++) (atColon tagName) <|> pure ([], dateTags)
where
readUpTo :: Char -> TextParser m [DateTag]
readUpTo :: forall (m :: * -> *). Char -> TextParser m [DateTag]
readUpTo Char
end = do
ParsecT HledgerParseErrorData Text m (Tokens Text)
-> ParsecT HledgerParseErrorData Text m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT HledgerParseErrorData Text m (Tokens Text)
-> ParsecT HledgerParseErrorData Text m ())
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
-> ParsecT HledgerParseErrorData Text m ()
forall a b. (a -> b) -> a -> b
$ Maybe [Char]
-> (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe [Char]
forall a. Maybe a
Nothing (\Token Text
c -> Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
end Bool -> Bool -> Bool
&& Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n' Bool -> Bool -> Bool
&& Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'[')
TextParser m [DateTag] -> TextParser m [DateTag]
forall (m :: * -> *).
TextParser m [DateTag] -> TextParser m [DateTag]
atBracket (Char -> TextParser m [DateTag]
forall (m :: * -> *). Char -> TextParser m [DateTag]
readUpTo Char
end) TextParser m [DateTag]
-> TextParser m [DateTag] -> TextParser m [DateTag]
forall a.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [DateTag] -> TextParser m [DateTag]
forall a. a -> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
atBracket :: TextParser m [DateTag] -> TextParser m [DateTag]
atBracket :: forall (m :: * -> *).
TextParser m [DateTag] -> TextParser m [DateTag]
atBracket TextParser m [DateTag]
cont = do
dateTags <- [DateTag] -> TextParser m [DateTag] -> TextParser m [DateTag]
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option [] (TextParser m [DateTag] -> TextParser m [DateTag])
-> TextParser m [DateTag] -> TextParser m [DateTag]
forall a b. (a -> b) -> a -> b
$ TextParser m [DateTag] -> TextParser m [DateTag]
forall a.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (Maybe Integer -> TextParser m [DateTag]
forall (m :: * -> *). Maybe Integer -> TextParser m [DateTag]
bracketeddatetagsp Maybe Integer
mYear)
_ <- char '['
dateTags' <- cont
pure $ dateTags ++ dateTags'
atColon :: Text -> TextParser m ([Tag], [DateTag])
atColon :: forall (m :: * -> *). Text -> TextParser m ([Tag], [DateTag])
atColon Text
name = Token Text -> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
':' ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m ([Tag], [DateTag])
-> ParsecT HledgerParseErrorData Text m ([Tag], [DateTag])
forall a b.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
-> ParsecT HledgerParseErrorData Text m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> do
ParsecT HledgerParseErrorData Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces
(tags, dateTags) <- case Text
name of
Text
"" -> ([Tag], [DateTag])
-> ParsecT HledgerParseErrorData Text m ([Tag], [DateTag])
forall a. a -> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [])
Text
"date" -> Text -> ParsecT HledgerParseErrorData Text m ([Tag], [DateTag])
forall (m :: * -> *). Text -> TextParser m ([Tag], [DateTag])
dateValue Text
name
Text
"date2" -> Text -> ParsecT HledgerParseErrorData Text m ([Tag], [DateTag])
forall (m :: * -> *). Text -> TextParser m ([Tag], [DateTag])
dateValue Text
name
Text
_ -> Text -> ParsecT HledgerParseErrorData Text m ([Tag], [DateTag])
forall (m :: * -> *). Text -> TextParser m ([Tag], [DateTag])
tagValue Text
name
_ <- optional $ char ','
bimap (tags++) (dateTags++) <$> commenttagsanddatesp mYear
dateValue :: Text -> TextParser m ([Tag], [DateTag])
dateValue :: forall (m :: * -> *). Text -> TextParser m ([Tag], [DateTag])
dateValue Text
name = do
(txt, (date, dateTags)) <- TextParser m (Day, [DateTag])
-> TextParser m (Text, (Day, [DateTag]))
forall (m :: * -> *) a. TextParser m a -> TextParser m (Text, a)
match' (TextParser m (Day, [DateTag])
-> TextParser m (Text, (Day, [DateTag])))
-> TextParser m (Day, [DateTag])
-> TextParser m (Text, (Day, [DateTag]))
forall a b. (a -> b) -> a -> b
$ do
date <- Maybe Integer -> TextParser m Day
forall (m :: * -> *). Maybe Integer -> TextParser m Day
datep' Maybe Integer
mYear
dateTags <- readUpTo ','
pure (date, dateTags)
let val = Text -> Text
T.strip Text
txt
pure $ ( [(name, val)]
, (name, date) : dateTags )
tagValue :: Text -> TextParser m ([Tag], [DateTag])
tagValue :: forall (m :: * -> *). Text -> TextParser m ([Tag], [DateTag])
tagValue Text
name = do
(txt, dateTags) <- TextParser m [DateTag] -> TextParser m (Text, [DateTag])
forall (m :: * -> *) a. TextParser m a -> TextParser m (Text, a)
match' (TextParser m [DateTag] -> TextParser m (Text, [DateTag]))
-> TextParser m [DateTag] -> TextParser m (Text, [DateTag])
forall a b. (a -> b) -> a -> b
$ Char -> TextParser m [DateTag]
forall (m :: * -> *). Char -> TextParser m [DateTag]
readUpTo Char
','
let val = Text -> Text
T.strip Text
txt
pure $ ( [(name, val)]
, dateTags )
{-# INLINABLE commenttagsanddatesp #-}
bracketeddatetagsp
:: Maybe Year -> TextParser m [(TagName, Day)]
bracketeddatetagsp :: forall (m :: * -> *). Maybe Integer -> TextParser m [DateTag]
bracketeddatetagsp Maybe Integer
mYear1 = do
ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
forall a.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ())
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
forall a b. (a -> b) -> a -> b
$ do
s <- ParsecT HledgerParseErrorData Text m Text
-> ParsecT HledgerParseErrorData Text m Text
forall a.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead
(ParsecT HledgerParseErrorData Text m Text
-> ParsecT HledgerParseErrorData Text m Text)
-> ParsecT HledgerParseErrorData Text m Text
-> ParsecT HledgerParseErrorData Text m Text
forall a b. (a -> b) -> a -> b
$ ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m Text
-> ParsecT HledgerParseErrorData Text m Text
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Token Text -> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'[') (Token Text -> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
']')
(ParsecT HledgerParseErrorData Text m Text
-> ParsecT HledgerParseErrorData Text m Text)
-> ParsecT HledgerParseErrorData Text m Text
-> ParsecT HledgerParseErrorData Text m Text
forall a b. (a -> b) -> a -> b
$ Maybe [Char]
-> (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe [Char]
forall a. Maybe a
Nothing Char -> Bool
Token Text -> Bool
isBracketedDateChar
unless (T.any isDigit s && T.any isDateSepChar s) $
Fail.fail "not a bracketed date"
ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m [DateTag]
-> ParsecT HledgerParseErrorData Text m [DateTag]
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Token Text -> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'[') (Token Text -> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
']') (ParsecT HledgerParseErrorData Text m [DateTag]
-> ParsecT HledgerParseErrorData Text m [DateTag])
-> ParsecT HledgerParseErrorData Text m [DateTag]
-> ParsecT HledgerParseErrorData Text m [DateTag]
forall a b. (a -> b) -> a -> b
$ do
md1 <- ParsecT HledgerParseErrorData Text m Day
-> ParsecT HledgerParseErrorData Text m (Maybe Day)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT HledgerParseErrorData Text m Day
-> ParsecT HledgerParseErrorData Text m (Maybe Day))
-> ParsecT HledgerParseErrorData Text m Day
-> ParsecT HledgerParseErrorData Text m (Maybe Day)
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> ParsecT HledgerParseErrorData Text m Day
forall (m :: * -> *). Maybe Integer -> TextParser m Day
datep' Maybe Integer
mYear1
let mYear2 = (Day -> Integer) -> Maybe Day -> Maybe Integer
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Day -> Integer
readYear Maybe Day
md1 Maybe Integer -> Maybe Integer -> Maybe Integer
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Integer
mYear1
md2 <- optional $ char '=' *> datep' mYear2
pure $ catMaybes [("date",) <$> md1, ("date2",) <$> md2]
where
readYear :: Day -> Integer
readYear = (Integer, Int, Int) -> Integer
forall {a} {b} {c}. (a, b, c) -> a
first3 ((Integer, Int, Int) -> Integer)
-> (Day -> (Integer, Int, Int)) -> Day -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> (Integer, Int, Int)
toGregorian
isBracketedDateChar :: Char -> Bool
isBracketedDateChar Char
c = Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDateSepChar Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'='
{-# INLINABLE bracketeddatetagsp #-}
aliasesFromOpts :: InputOpts -> [AccountAlias]
aliasesFromOpts :: InputOpts -> [AccountAlias]
aliasesFromOpts = ([Char] -> AccountAlias) -> [[Char]] -> [AccountAlias]
forall a b. (a -> b) -> [a] -> [b]
map (\[Char]
a -> Either HledgerParseErrors AccountAlias -> AccountAlias
forall t e a.
(Show t, Show (Token t), Show e) =>
Either (ParseErrorBundle t e) a -> a
fromparse (Either HledgerParseErrors AccountAlias -> AccountAlias)
-> Either HledgerParseErrors AccountAlias -> AccountAlias
forall a b. (a -> b) -> a -> b
$ Parsec HledgerParseErrorData Text AccountAlias
-> [Char] -> Text -> Either HledgerParseErrors AccountAlias
forall e s a.
Parsec e s a -> [Char] -> s -> Either (ParseErrorBundle s e) a
runParser Parsec HledgerParseErrorData Text AccountAlias
forall (m :: * -> *). TextParser m AccountAlias
accountaliasp ([Char]
"--alias "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ShowS
quoteIfNeeded [Char]
a) (Text -> Either HledgerParseErrors AccountAlias)
-> Text -> Either HledgerParseErrors AccountAlias
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
a)
([[Char]] -> [AccountAlias])
-> (InputOpts -> [[Char]]) -> InputOpts -> [AccountAlias]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputOpts -> [[Char]]
aliases_
accountaliasp :: TextParser m AccountAlias
accountaliasp :: forall (m :: * -> *). TextParser m AccountAlias
accountaliasp = TextParser m AccountAlias
forall (m :: * -> *). TextParser m AccountAlias
regexaliasp TextParser m AccountAlias
-> TextParser m AccountAlias -> TextParser m AccountAlias
forall a.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TextParser m AccountAlias
forall (m :: * -> *). TextParser m AccountAlias
basicaliasp
basicaliasp :: TextParser m AccountAlias
basicaliasp :: forall (m :: * -> *). TextParser m AccountAlias
basicaliasp = do
old <- ShowS
rstrip ShowS
-> ParsecT HledgerParseErrorData Text m [Char]
-> ParsecT HledgerParseErrorData Text m [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m [Char])
-> ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m [Char]
forall a b. (a -> b) -> a -> b
$ [Token Text] -> ParsecT HledgerParseErrorData Text m (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
noneOf ([Char]
"=" :: [Char]))
char '='
skipNonNewlineSpaces
new <- rstrip <$> anySingle `manyTill` eolof
return $ BasicAlias (T.pack old) (T.pack new)
regexaliasp :: TextParser m AccountAlias
regexaliasp :: forall (m :: * -> *). TextParser m AccountAlias
regexaliasp = do
(off1, off2, re) <- ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m (Int, Int, Text)
-> ParsecT HledgerParseErrorData Text m (Int, Int, Text)
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Token Text -> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'/') (Token Text -> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'/') (ParsecT HledgerParseErrorData Text m (Int, Int, Text)
-> ParsecT HledgerParseErrorData Text m (Int, Int, Text))
-> ParsecT HledgerParseErrorData Text m (Int, Int, Text)
-> ParsecT HledgerParseErrorData Text m (Int, Int, Text)
forall a b. (a -> b) -> a -> b
$ do
off1 <- ParsecT HledgerParseErrorData Text m Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
re <- fmap T.concat . some $
(T.singleton <$> noneOf ("/\\\n\r" :: [Char]))
<|> string "\\/"
<|> (liftM2 T.cons (char '\\') (T.singleton <$> anySingle))
off2 <- getOffset
return (off1, off2, re)
skipNonNewlineSpaces
char '='
skipNonNewlineSpaces
repl <- anySingle `manyTill` eolof
case toRegexCI re of
Right Regexp
r -> AccountAlias -> ParsecT HledgerParseErrorData Text m AccountAlias
forall a. a -> ParsecT HledgerParseErrorData Text m a
forall (m :: * -> *) a. Monad m => a -> m a
return (AccountAlias -> ParsecT HledgerParseErrorData Text m AccountAlias)
-> AccountAlias
-> ParsecT HledgerParseErrorData Text m AccountAlias
forall a b. (a -> b) -> a -> b
$! Regexp -> [Char] -> AccountAlias
RegexAlias Regexp
r [Char]
repl
Left [Char]
e -> HledgerParseErrorData
-> ParsecT HledgerParseErrorData Text m AccountAlias
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (HledgerParseErrorData
-> ParsecT HledgerParseErrorData Text m AccountAlias)
-> HledgerParseErrorData
-> ParsecT HledgerParseErrorData Text m AccountAlias
forall a b. (a -> b) -> a -> b
$! Int -> Int -> [Char] -> HledgerParseErrorData
parseErrorAtRegion Int
off1 Int
off2 [Char]
e
tests_Common :: TestTree
tests_Common = [Char] -> [TestTree] -> TestTree
testGroup [Char]
"Common" [
[Char] -> [TestTree] -> TestTree
testGroup [Char]
"amountp" [
[Char] -> Assertion -> TestTree
testCase [Char]
"basic" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ StateT Journal (ParsecT HledgerParseErrorData Text IO) Amount
-> Text -> Amount -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> a -> Assertion
assertParseEq StateT Journal (ParsecT HledgerParseErrorData Text IO) Amount
forall (m :: * -> *). JournalParser m Amount
amountp Text
"$47.18" (Quantity -> Amount
usd Quantity
47.18)
,[Char] -> Assertion -> TestTree
testCase [Char]
"ends with decimal mark" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ StateT Journal (ParsecT HledgerParseErrorData Text IO) Amount
-> Text -> Amount -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> a -> Assertion
assertParseEq StateT Journal (ParsecT HledgerParseErrorData Text IO) Amount
forall (m :: * -> *). JournalParser m Amount
amountp Text
"$1." (Quantity -> Amount
usd Quantity
1 Amount -> AmountPrecision -> Amount
`withPrecision` Word8 -> AmountPrecision
Precision Word8
0)
,[Char] -> Assertion -> TestTree
testCase [Char]
"unit price" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ StateT Journal (ParsecT HledgerParseErrorData Text IO) Amount
-> Text -> Amount -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> a -> Assertion
assertParseEq StateT Journal (ParsecT HledgerParseErrorData Text IO) Amount
forall (m :: * -> *). JournalParser m Amount
amountp Text
"$10 @ €0.5"
Amount
nullamt{
acommodity="$"
,aquantity=10
,astyle=amountstyle{asprecision=Precision 0, asdecimalmark=Nothing}
,acost=Just $ UnitCost $
nullamt{
acommodity="€"
,aquantity=0.5
,astyle=amountstyle{asprecision=Precision 1, asdecimalmark=Just '.'}
}
}
,[Char] -> Assertion -> TestTree
testCase [Char]
"total price" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ StateT Journal (ParsecT HledgerParseErrorData Text IO) Amount
-> Text -> Amount -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> a -> Assertion
assertParseEq StateT Journal (ParsecT HledgerParseErrorData Text IO) Amount
forall (m :: * -> *). JournalParser m Amount
amountp Text
"$10 @@ €5"
Amount
nullamt{
acommodity="$"
,aquantity=10
,astyle=amountstyle{asprecision=Precision 0, asdecimalmark=Nothing}
,acost=Just $ TotalCost $
nullamt{
acommodity="€"
,aquantity=5
,astyle=amountstyle{asprecision=Precision 0, asdecimalmark=Nothing}
}
}
,[Char] -> Assertion -> TestTree
testCase [Char]
"unit price, parenthesised" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ StateT Journal (ParsecT HledgerParseErrorData Text IO) Amount
-> Text -> Assertion
forall st a.
(HasCallStack, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> Assertion
assertParse StateT Journal (ParsecT HledgerParseErrorData Text IO) Amount
forall (m :: * -> *). JournalParser m Amount
amountp Text
"$10 (@) €0.5"
,[Char] -> Assertion -> TestTree
testCase [Char]
"total price, parenthesised" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ StateT Journal (ParsecT HledgerParseErrorData Text IO) Amount
-> Text -> Assertion
forall st a.
(HasCallStack, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> Assertion
assertParse StateT Journal (ParsecT HledgerParseErrorData Text IO) Amount
forall (m :: * -> *). JournalParser m Amount
amountp Text
"$10 (@@) €0.5"
]
,let p :: JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
p = ParsecT
HledgerParseErrorData
Text
IO
(Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
forall (m :: * -> *) a. Monad m => m a -> StateT Journal m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Maybe AmountStyle
-> ParsecT
HledgerParseErrorData
Text
IO
(Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
forall (m :: * -> *).
Maybe AmountStyle
-> TextParser
m (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
numberp Maybe AmountStyle
forall a. Maybe a
Nothing) :: JournalParser IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle) in
[Char] -> Assertion -> TestTree
testCase [Char]
"numberp" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Text
-> (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> a -> Assertion
assertParseEq JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
p Text
"0" (Quantity
0, Word8
0, Maybe Char
forall a. Maybe a
Nothing, Maybe DigitGroupStyle
forall a. Maybe a
Nothing)
JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Text
-> (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> a -> Assertion
assertParseEq JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
p Text
"1" (Quantity
1, Word8
0, Maybe Char
forall a. Maybe a
Nothing, Maybe DigitGroupStyle
forall a. Maybe a
Nothing)
JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Text
-> (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> a -> Assertion
assertParseEq JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
p Text
"1.1" (Quantity
1.1, Word8
1, Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'.', Maybe DigitGroupStyle
forall a. Maybe a
Nothing)
JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Text
-> (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> a -> Assertion
assertParseEq JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
p Text
"1,000.1" (Quantity
1000.1, Word8
1, Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'.', DigitGroupStyle -> Maybe DigitGroupStyle
forall a. a -> Maybe a
Just (DigitGroupStyle -> Maybe DigitGroupStyle)
-> DigitGroupStyle -> Maybe DigitGroupStyle
forall a b. (a -> b) -> a -> b
$ Char -> [Word8] -> DigitGroupStyle
DigitGroups Char
',' [Word8
3])
JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Text
-> (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> a -> Assertion
assertParseEq JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
p Text
"1.00.000,1" (Quantity
100000.1, Word8
1, Char -> Maybe Char
forall a. a -> Maybe a
Just Char
',', DigitGroupStyle -> Maybe DigitGroupStyle
forall a. a -> Maybe a
Just (DigitGroupStyle -> Maybe DigitGroupStyle)
-> DigitGroupStyle -> Maybe DigitGroupStyle
forall a b. (a -> b) -> a -> b
$ Char -> [Word8] -> DigitGroupStyle
DigitGroups Char
'.' [Word8
3,Word8
2])
JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Text
-> (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> a -> Assertion
assertParseEq JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
p Text
"1,000,000" (Quantity
1000000, Word8
0, Maybe Char
forall a. Maybe a
Nothing, DigitGroupStyle -> Maybe DigitGroupStyle
forall a. a -> Maybe a
Just (DigitGroupStyle -> Maybe DigitGroupStyle)
-> DigitGroupStyle -> Maybe DigitGroupStyle
forall a b. (a -> b) -> a -> b
$ Char -> [Word8] -> DigitGroupStyle
DigitGroups Char
',' [Word8
3,Word8
3])
JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Text
-> (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> a -> Assertion
assertParseEq JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
p Text
"1." (Quantity
1, Word8
0, Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'.', Maybe DigitGroupStyle
forall a. Maybe a
Nothing)
JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Text
-> (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> a -> Assertion
assertParseEq JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
p Text
"1," (Quantity
1, Word8
0, Char -> Maybe Char
forall a. a -> Maybe a
Just Char
',', Maybe DigitGroupStyle
forall a. Maybe a
Nothing)
JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Text
-> (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> a -> Assertion
assertParseEq JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
p Text
".1" (Quantity
0.1, Word8
1, Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'.', Maybe DigitGroupStyle
forall a. Maybe a
Nothing)
JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Text
-> (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> a -> Assertion
assertParseEq JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
p Text
",1" (Quantity
0.1, Word8
1, Char -> Maybe Char
forall a. a -> Maybe a
Just Char
',', Maybe DigitGroupStyle
forall a. Maybe a
Nothing)
JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Text -> [Char] -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> [Char] -> Assertion
assertParseError JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
p Text
"" [Char]
""
JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Text -> [Char] -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> [Char] -> Assertion
assertParseError JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
p Text
"1,000.000,1" [Char]
""
JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Text -> [Char] -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> [Char] -> Assertion
assertParseError JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
p Text
"1.000,000.1" [Char]
""
JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Text -> [Char] -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> [Char] -> Assertion
assertParseError JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
p Text
"1,000.000.1" [Char]
""
JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Text -> [Char] -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> [Char] -> Assertion
assertParseError JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
p Text
"1,,1" [Char]
""
JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Text -> [Char] -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> [Char] -> Assertion
assertParseError JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
p Text
"1..1" [Char]
""
JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Text -> [Char] -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> [Char] -> Assertion
assertParseError JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
p Text
".1," [Char]
""
JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Text -> [Char] -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> [Char] -> Assertion
assertParseError JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
p Text
",1." [Char]
""
JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Text
-> (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> a -> Assertion
assertParseEq JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
p Text
"1.555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555" (Quantity
1.555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555, Word8
255, Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'.', Maybe DigitGroupStyle
forall a. Maybe a
Nothing)
JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> Text -> [Char] -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> [Char] -> Assertion
assertParseError JournalParser
IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
p Text
"1.5555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555" [Char]
""
,[Char] -> [TestTree] -> TestTree
testGroup [Char]
"spaceandamountormissingp" [
[Char] -> Assertion -> TestTree
testCase [Char]
"space and amount" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ StateT Journal (ParsecT HledgerParseErrorData Text IO) MixedAmount
-> Text -> MixedAmount -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> a -> Assertion
assertParseEq StateT Journal (ParsecT HledgerParseErrorData Text IO) MixedAmount
forall (m :: * -> *). JournalParser m MixedAmount
spaceandamountormissingp Text
" $47.18" (Amount -> MixedAmount
mixedAmount (Amount -> MixedAmount) -> Amount -> MixedAmount
forall a b. (a -> b) -> a -> b
$ Quantity -> Amount
usd Quantity
47.18)
,[Char] -> Assertion -> TestTree
testCase [Char]
"empty string" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ StateT Journal (ParsecT HledgerParseErrorData Text IO) MixedAmount
-> Text -> MixedAmount -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT HledgerParseErrorData Text IO) a
-> Text -> a -> Assertion
assertParseEq StateT Journal (ParsecT HledgerParseErrorData Text IO) MixedAmount
forall (m :: * -> *). JournalParser m MixedAmount
spaceandamountormissingp Text
"" MixedAmount
missingmixedamt
]
]