WIP use doubles in config
This commit is contained in:
parent
2119eb61c8
commit
38710b1f56
|
|
@ -106,6 +106,11 @@ let Currency =
|
|||
The full description of this currency (eg "Yugoslavian Twitcoin")
|
||||
-}
|
||||
Text
|
||||
, curPrecision :
|
||||
{-
|
||||
The number of decimal places for this currency
|
||||
-}
|
||||
Natural
|
||||
}
|
||||
|
||||
let TagID =
|
||||
|
|
@ -273,9 +278,6 @@ let DatePat =
|
|||
-}
|
||||
< Cron : CronPat.Type | Mod : ModPat.Type >
|
||||
|
||||
let Decimal =
|
||||
{ whole : Natural, decimal : Natural, precision : Natural, sign : Bool }
|
||||
|
||||
let TxOpts =
|
||||
{- Additional metadata to use when parsing a statement -}
|
||||
{ Type =
|
||||
|
|
@ -402,7 +404,7 @@ let EntryNumGetter =
|
|||
ConstN: a constant value
|
||||
AmountN: the value of the 'Amount' column
|
||||
-}
|
||||
< LookupN : Text | ConstN : Decimal | AmountN >
|
||||
< LookupN : Text | ConstN : Double | AmountN >
|
||||
|
||||
let EntryTextGetter =
|
||||
{-
|
||||
|
|
@ -595,7 +597,7 @@ let HistTransfer =
|
|||
{-
|
||||
A manually specified historical transfer
|
||||
-}
|
||||
Transfer AcntID CurID DatePat Decimal
|
||||
Transfer AcntID CurID DatePat Double
|
||||
|
||||
let Statement =
|
||||
{-
|
||||
|
|
@ -655,7 +657,7 @@ let Exchange =
|
|||
{-
|
||||
The exchange rate between the currencies.
|
||||
-}
|
||||
Decimal
|
||||
Double
|
||||
}
|
||||
|
||||
let BudgetCurrency =
|
||||
|
|
@ -692,7 +694,7 @@ let PretaxValue =
|
|||
{-
|
||||
The value to be deducted from gross income
|
||||
-}
|
||||
Decimal
|
||||
Double
|
||||
, prePercent :
|
||||
{-
|
||||
If true, value is interpreted as a percent of gross income instead of
|
||||
|
|
@ -713,7 +715,7 @@ let TaxBracket =
|
|||
A single tax bracket. Read as "every unit above limit is taxed at this
|
||||
percentage".
|
||||
-}
|
||||
{ tbLowerLimit : Decimal, tbPercent : Decimal }
|
||||
{ tbLowerLimit : Double, tbPercent : Double }
|
||||
|
||||
let TaxProgression =
|
||||
{-
|
||||
|
|
@ -724,7 +726,7 @@ let TaxProgression =
|
|||
{-
|
||||
Initial amount to subtract from after-pretax-deductions
|
||||
-}
|
||||
Decimal
|
||||
Double
|
||||
, tpBrackets :
|
||||
{-
|
||||
Tax brackets to apply after deductions (order does not matter, each
|
||||
|
|
@ -737,7 +739,7 @@ let TaxMethod =
|
|||
{-
|
||||
How to implement a given tax (either a progressive tax or a fixed percent)
|
||||
-}
|
||||
< TMBracket : TaxProgression | TMPercent : Decimal >
|
||||
< TMBracket : TaxProgression | TMPercent : Double >
|
||||
|
||||
let TaxValue =
|
||||
{-
|
||||
|
|
@ -761,7 +763,7 @@ let PosttaxValue =
|
|||
{-
|
||||
The value to be deducted from income remaining after taxes.
|
||||
-}
|
||||
Decimal
|
||||
Double
|
||||
, postPercent :
|
||||
{-
|
||||
If true, subtract a percentage from the after-tax remainder instead
|
||||
|
|
@ -794,7 +796,7 @@ let Income =
|
|||
{-
|
||||
The value of the income stream.
|
||||
-}
|
||||
Decimal
|
||||
Double
|
||||
, incCurrency :
|
||||
{-
|
||||
The currency in which the income stream is denominated.
|
||||
|
|
@ -931,14 +933,14 @@ let ShadowTransfer =
|
|||
{-
|
||||
Fixed multipler to translate value of matched transfer to this one.
|
||||
-}
|
||||
Decimal
|
||||
Double
|
||||
}
|
||||
|
||||
let BudgetTransferValue =
|
||||
{-
|
||||
Means to determine the value of a budget transfer.
|
||||
-}
|
||||
{ btVal : Decimal, btType : BudgetTransferType }
|
||||
{ btVal : Double, btType : BudgetTransferType }
|
||||
|
||||
let BudgetTransfer =
|
||||
{-
|
||||
|
|
@ -984,7 +986,6 @@ in { CurID
|
|||
, WeekdayPat
|
||||
, CronPat
|
||||
, DatePat
|
||||
, Decimal
|
||||
, TxOpts
|
||||
, StatementParser
|
||||
, StatementParser_
|
||||
|
|
|
|||
|
|
@ -4,19 +4,6 @@ let List/map =
|
|||
|
||||
let T = ./Types.dhall
|
||||
|
||||
let dec =
|
||||
\(s : Bool) ->
|
||||
\(w : Natural) ->
|
||||
\(d : Natural) ->
|
||||
\(p : Natural) ->
|
||||
{ whole = w, decimal = d, precision = p, sign = s } : T.Decimal
|
||||
|
||||
let dec2 = \(s : Bool) -> \(w : Natural) -> \(d : Natural) -> dec s w d 2
|
||||
|
||||
let d = dec2 True
|
||||
|
||||
let d_ = dec2 False
|
||||
|
||||
let nullSplit =
|
||||
\(a : T.EntryAcntGetter) ->
|
||||
\(c : T.EntryCurGetter) ->
|
||||
|
|
@ -99,7 +86,7 @@ let mRngYMD =
|
|||
\(r : Natural) ->
|
||||
T.DateMatcher.In { _1 = T.YMDMatcher.YMD (greg y m d), _2 = r }
|
||||
|
||||
let PartSplit = { _1 : T.AcntID, _2 : T.Decimal, _3 : Text }
|
||||
let PartSplit = { _1 : T.AcntID, _2 : Double, _3 : Text }
|
||||
|
||||
let partN =
|
||||
\(c : T.EntryCurGetter) ->
|
||||
|
|
@ -184,9 +171,5 @@ in { nullSplit
|
|||
, mvDenP
|
||||
, mvDenN
|
||||
, PartSplit
|
||||
, d
|
||||
, d_
|
||||
, dec
|
||||
, dec2
|
||||
}
|
||||
/\ T
|
||||
|
|
|
|||
|
|
@ -194,11 +194,18 @@ updateCurrencies cs = do
|
|||
return $ currencyMap curs
|
||||
|
||||
currency2Record :: Currency -> Entity CurrencyR
|
||||
currency2Record c@Currency {curSymbol, curFullname} =
|
||||
Entity (toKey c) $ CurrencyR curSymbol curFullname
|
||||
currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
|
||||
Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision)
|
||||
|
||||
currencyMap :: [Entity CurrencyR] -> CurrencyMap
|
||||
currencyMap = M.fromList . fmap (\e -> (currencyRSymbol $ entityVal e, entityKey e))
|
||||
currencyMap =
|
||||
M.fromList
|
||||
. fmap
|
||||
( \e ->
|
||||
( currencyRSymbol $ entityVal e
|
||||
, (entityKey e, fromIntegral $ currencyRPrecision $ entityVal e)
|
||||
)
|
||||
)
|
||||
|
||||
updateTags :: MonadUnliftIO m => [Tag] -> SqlPersistT m TagMap
|
||||
updateTags cs = do
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ import Data.Hashable
|
|||
import Database.Persist.Class
|
||||
import Database.Persist.Sql hiding (Single, Statement)
|
||||
import Internal.Statement
|
||||
import Internal.Types hiding (sign)
|
||||
import Internal.Types hiding (CurrencyM, sign)
|
||||
import Internal.Utils
|
||||
import RIO hiding (to)
|
||||
import qualified RIO.List as L
|
||||
|
|
@ -134,7 +134,8 @@ insertBudget
|
|||
res2 <- expandTransfers key bgtLabel bgtTransfers
|
||||
unlessLefts (concatEithers2 (concat <$> concatEithersL res1) res2 (++)) $
|
||||
\txs -> do
|
||||
unlessLefts (addShadowTransfers bgtShadowTransfers txs) $ \shadow -> do
|
||||
m <- lift $ askDBState kmCurrency
|
||||
unlessLefts (addShadowTransfers m bgtShadowTransfers txs) $ \shadow -> do
|
||||
let bals = balanceTransfers $ txs ++ shadow
|
||||
concat <$> mapM insertBudgetTx bals
|
||||
where
|
||||
|
|
@ -169,21 +170,24 @@ sortAllo a@Allocation {alloAmts = as} = do
|
|||
|
||||
-- TODO this is going to be O(n*m), which might be a problem?
|
||||
addShadowTransfers
|
||||
:: [ShadowTransfer]
|
||||
:: CurrencyMap
|
||||
-> [ShadowTransfer]
|
||||
-> [UnbalancedTransfer]
|
||||
-> EitherErrs [UnbalancedTransfer]
|
||||
addShadowTransfers ms txs =
|
||||
addShadowTransfers cm ms txs =
|
||||
fmap catMaybes $
|
||||
concatEitherL $
|
||||
fmap (uncurry fromShadow) $
|
||||
concatEithersL $
|
||||
fmap (uncurry (fromShadow cm)) $
|
||||
[(t, m) | t <- txs, m <- ms]
|
||||
|
||||
fromShadow
|
||||
:: UnbalancedTransfer
|
||||
:: CurrencyMap
|
||||
-> UnbalancedTransfer
|
||||
-> ShadowTransfer
|
||||
-> EitherErr (Maybe UnbalancedTransfer)
|
||||
fromShadow tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
|
||||
-> EitherErrs (Maybe UnbalancedTransfer)
|
||||
fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
|
||||
res <- shadowMatches (stMatch t) tx
|
||||
v <- roundPrecisionCur (initialCurrency stCurrency) cm stRatio
|
||||
return $
|
||||
if not res
|
||||
then Nothing
|
||||
|
|
@ -196,11 +200,11 @@ fromShadow tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stTyp
|
|||
, cbtCur = stCurrency
|
||||
, cbtFrom = stFrom
|
||||
, cbtTo = stTo
|
||||
, cbtValue = UnbalancedValue stType $ dec2Rat stRatio * cvValue (cbtValue tx)
|
||||
, cbtValue = UnbalancedValue stType $ v * cvValue (cbtValue tx)
|
||||
, cbtDesc = stDesc
|
||||
}
|
||||
|
||||
shadowMatches :: TransferMatcher -> UnbalancedTransfer -> EitherErr Bool
|
||||
shadowMatches :: TransferMatcher -> UnbalancedTransfer -> EitherErrs Bool
|
||||
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
|
||||
valRes <- valMatches tmVal $ cvValue $ cbtValue tx
|
||||
return $
|
||||
|
|
@ -274,30 +278,32 @@ insertIncome
|
|||
Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal, incGross} = do
|
||||
-- TODO check that the other accounts are not income somewhere here
|
||||
fromRes <- lift $ checkAcntType IncomeT $ taAcnt incFrom
|
||||
case fromRes of
|
||||
Left e -> return $ Left [e]
|
||||
precRes <- lift $ lookupCurrencyPrec incCurrency
|
||||
case concatEithers2 fromRes precRes (,) of
|
||||
Left e -> return $ Left e
|
||||
-- TODO this will scan the interval allocations fully each time
|
||||
-- iteration which is a total waste, but the fix requires turning this
|
||||
-- loop into a fold which I don't feel like doing now :(
|
||||
Right _ -> fmap concat <$> withDates incWhen (return . allocate)
|
||||
Right (_, p) ->
|
||||
let gross = roundPrecision p incGross
|
||||
in fmap concat <$> withDates incWhen (return . allocate p gross)
|
||||
where
|
||||
meta = BudgetMeta key name
|
||||
gross = dec2Rat incGross
|
||||
flatPre = concatMap flattenAllo incPretax
|
||||
flatTax = concatMap flattenAllo incTaxes
|
||||
flatPost = concatMap flattenAllo incPosttax
|
||||
sumAllos = sum . fmap faValue
|
||||
-- TODO ensure these are all the "correct" accounts
|
||||
allocate day =
|
||||
allocate precision gross day =
|
||||
let (preDeductions, pre) =
|
||||
allocatePre gross $
|
||||
allocatePre precision gross $
|
||||
flatPre ++ concatMap (selectAllos day) intPre
|
||||
tax =
|
||||
allocateTax gross preDeductions $
|
||||
allocateTax precision gross preDeductions $
|
||||
flatTax ++ concatMap (selectAllos day) intTax
|
||||
aftertaxGross = sumAllos $ tax ++ pre
|
||||
post =
|
||||
allocatePost aftertaxGross $
|
||||
allocatePost precision aftertaxGross $
|
||||
flatPost ++ concatMap (selectAllos day) intPost
|
||||
balance = aftertaxGross - sumAllos post
|
||||
bal =
|
||||
|
|
@ -315,15 +321,19 @@ insertIncome
|
|||
else Right $ bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post)
|
||||
|
||||
allocatePre
|
||||
:: Rational
|
||||
:: Natural
|
||||
-> Rational
|
||||
-> [FlatAllocation PretaxValue]
|
||||
-> (M.Map T.Text Rational, [FlatAllocation Rational])
|
||||
allocatePre gross = L.mapAccumR go M.empty
|
||||
allocatePre precision gross = L.mapAccumR go M.empty
|
||||
where
|
||||
go m f@FlatAllocation {faValue} =
|
||||
let c = preCategory faValue
|
||||
p = dec2Rat $ preValue faValue
|
||||
v = if prePercent faValue then p * gross else p
|
||||
p = preValue faValue
|
||||
v =
|
||||
if prePercent faValue
|
||||
then roundPrecision 3 p * gross
|
||||
else roundPrecision precision p
|
||||
in (mapAdd_ c v m, f {faValue = v})
|
||||
|
||||
allo2Trans
|
||||
|
|
@ -344,34 +354,36 @@ allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} =
|
|||
}
|
||||
|
||||
allocateTax
|
||||
:: Rational
|
||||
:: Natural
|
||||
-> Rational
|
||||
-> M.Map T.Text Rational
|
||||
-> [FlatAllocation TaxValue]
|
||||
-> [FlatAllocation Rational]
|
||||
allocateTax gross deds = fmap (fmap go)
|
||||
allocateTax precision gross deds = fmap (fmap go)
|
||||
where
|
||||
go TaxValue {tvCategories, tvMethod} =
|
||||
let agi = gross - sum (mapMaybe (`M.lookup` deds) tvCategories)
|
||||
in case tvMethod of
|
||||
TMPercent p -> dec2Rat p * agi
|
||||
TMPercent p -> roundPrecision 3 p * agi
|
||||
TMBracket TaxProgression {tpDeductible, tpBrackets} ->
|
||||
foldBracket (agi - dec2Rat tpDeductible) tpBrackets
|
||||
foldBracket precision (agi - roundPrecision precision tpDeductible) tpBrackets
|
||||
|
||||
allocatePost
|
||||
:: Rational
|
||||
:: Natural
|
||||
-> Rational
|
||||
-> [FlatAllocation PosttaxValue]
|
||||
-> [FlatAllocation Rational]
|
||||
allocatePost aftertax = fmap (fmap go)
|
||||
allocatePost precision aftertax = fmap (fmap go)
|
||||
where
|
||||
go PosttaxValue {postValue, postPercent} =
|
||||
let v = dec2Rat postValue in if postPercent then aftertax * v else v
|
||||
let v = postValue in if postPercent then aftertax * roundPrecision 3 v else roundPrecision precision v
|
||||
|
||||
foldBracket :: Rational -> [TaxBracket] -> Rational
|
||||
foldBracket agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
|
||||
foldBracket :: Natural -> Rational -> [TaxBracket] -> Rational
|
||||
foldBracket precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
|
||||
where
|
||||
go TaxBracket {tbLowerLimit, tbPercent} (acc, remain) =
|
||||
let l = dec2Rat tbLowerLimit
|
||||
p = dec2Rat tbPercent
|
||||
let l = roundPrecision precision tbLowerLimit
|
||||
p = roundPrecision 3 tbPercent
|
||||
in if remain < l then (acc + p * (remain - l), l) else (acc, remain)
|
||||
|
||||
data FlatAllocation v = FlatAllocation
|
||||
|
|
@ -418,39 +430,46 @@ expandTransfers key name ts = do
|
|||
txs <- mapM (expandTransfer key name) ts
|
||||
return $ L.sortOn cbtWhen . concat <$> concatEithersL txs
|
||||
|
||||
initialCurrency :: BudgetCurrency -> CurID
|
||||
initialCurrency (NoX c) = c
|
||||
initialCurrency (X Exchange {xFromCur = c}) = c
|
||||
|
||||
expandTransfer
|
||||
:: MonadFinance m
|
||||
=> CommitRId
|
||||
-> T.Text
|
||||
-> BudgetTransfer
|
||||
-> SqlPersistT m (EitherErrs [UnbalancedTransfer])
|
||||
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} =
|
||||
-- whenHash CTExpense t (Right []) $ \key ->
|
||||
fmap (fmap concat . concatEithersL) $
|
||||
forM transAmounts $
|
||||
\Amount
|
||||
{ amtWhen = pat
|
||||
, amtValue = BudgetTransferValue {btVal = v, btType = y}
|
||||
, amtDesc = desc
|
||||
} ->
|
||||
do
|
||||
withDates pat $ \day ->
|
||||
let meta =
|
||||
BudgetMeta
|
||||
{ bmCommit = key
|
||||
, bmName = name
|
||||
}
|
||||
tx =
|
||||
FlatTransfer
|
||||
{ cbtMeta = meta
|
||||
, cbtWhen = day
|
||||
, cbtCur = transCurrency
|
||||
, cbtFrom = transFrom
|
||||
, cbtTo = transTo
|
||||
, cbtValue = UnbalancedValue y $ dec2Rat v
|
||||
, cbtDesc = desc
|
||||
}
|
||||
in return $ Right tx
|
||||
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do
|
||||
pRes <- lift $ lookupCurrencyPrec $ initialCurrency transCurrency
|
||||
case pRes of
|
||||
Left es -> return $ Left es
|
||||
Right p ->
|
||||
fmap (fmap concat . concatEithersL) $
|
||||
forM transAmounts $
|
||||
\Amount
|
||||
{ amtWhen = pat
|
||||
, amtValue = BudgetTransferValue {btVal = v, btType = y}
|
||||
, amtDesc = desc
|
||||
} ->
|
||||
do
|
||||
withDates pat $ \day ->
|
||||
let meta =
|
||||
BudgetMeta
|
||||
{ bmCommit = key
|
||||
, bmName = name
|
||||
}
|
||||
tx =
|
||||
FlatTransfer
|
||||
{ cbtMeta = meta
|
||||
, cbtWhen = day
|
||||
, cbtCur = transCurrency
|
||||
, cbtFrom = transFrom
|
||||
, cbtTo = transTo
|
||||
, cbtValue = UnbalancedValue y $ roundPrecision p v
|
||||
, cbtDesc = desc
|
||||
}
|
||||
in return $ Right tx
|
||||
|
||||
insertBudgetTx :: MonadFinance m => BalancedTransfer -> SqlPersistT m [InsertError]
|
||||
insertBudgetTx FlatTransfer {cbtFrom, cbtTo, cbtMeta, cbtCur, cbtValue, cbtDesc, cbtWhen} = do
|
||||
|
|
@ -481,7 +500,7 @@ splitPair from to cur val = case cur of
|
|||
X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do
|
||||
let middle = TaggedAcnt xAcnt []
|
||||
res1 <- pair xFromCur from middle val
|
||||
res2 <- pair xToCur middle to (val * dec2Rat xRate)
|
||||
res2 <- pair xToCur middle to (val * roundPrecision 3 xRate)
|
||||
return $ concatEithers2 res1 res2 $ \a b -> (a, Just b)
|
||||
where
|
||||
pair curid from_ to_ v = do
|
||||
|
|
@ -502,19 +521,19 @@ checkAcntType
|
|||
:: MonadFinance m
|
||||
=> AcntType
|
||||
-> AcntID
|
||||
-> m (EitherErr AcntID)
|
||||
-> m (EitherErrs AcntID)
|
||||
checkAcntType t = checkAcntTypes (t :| [])
|
||||
|
||||
checkAcntTypes
|
||||
:: MonadFinance m
|
||||
=> NE.NonEmpty AcntType
|
||||
-> AcntID
|
||||
-> m (EitherErr AcntID)
|
||||
-> m (EitherErrs AcntID)
|
||||
checkAcntTypes ts i = (go =<<) <$> lookupAccountType i
|
||||
where
|
||||
go t
|
||||
| t `L.elem` ts = Right i
|
||||
| otherwise = Left $ AccountError i ts
|
||||
| otherwise = Left [AccountError i ts]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- statements
|
||||
|
|
@ -536,12 +555,12 @@ insertManual
|
|||
} = do
|
||||
whenHash CTManual m [] $ \c -> do
|
||||
bounds <- lift $ askDBState kmStatementInterval
|
||||
-- let days = expandDatePat bounds dp
|
||||
precRes <- lift $ lookupCurrencyPrec u
|
||||
es <- forM amts $ \Amount {amtWhen, amtValue, amtDesc} -> do
|
||||
let v = dec2Rat amtValue
|
||||
let dayRes = expandDatePat bounds amtWhen
|
||||
unlessLefts dayRes $ \days -> do
|
||||
let tx day = txPair day from to u v amtDesc
|
||||
-- TODO rounding too often
|
||||
unlessLefts (concatEithers2 dayRes precRes (,)) $ \(days, p) -> do
|
||||
let tx day = txPair day from to u (roundPrecision p amtValue) amtDesc
|
||||
txRes <- mapM (lift . tx) days
|
||||
unlessLefts_ (concatEithersL txRes) $ mapM_ (insertTx c)
|
||||
return $ concat es
|
||||
|
|
@ -601,13 +620,13 @@ resolveTx t@Tx {txSplits = ss} = do
|
|||
resolveSplit :: MonadFinance m => BalSplit -> m (EitherErrs KeySplit)
|
||||
resolveSplit s@Entry {eAcnt, eCurrency, eValue, eTags} = do
|
||||
aid <- lookupAccountKey eAcnt
|
||||
cid <- lookupCurrency eCurrency
|
||||
cid <- lookupCurrencyKey eCurrency
|
||||
sign <- lookupAccountSign eAcnt
|
||||
tags <- mapM lookupTag eTags
|
||||
-- TODO correct sign here?
|
||||
-- TODO lenses would be nice here
|
||||
return $
|
||||
concatEithers2 (concatEither3 aid cid sign (,,)) (concatEitherL tags) $
|
||||
concatEithers2 (concatEithers3 aid cid sign (,,)) (concatEithersL tags) $
|
||||
\(aid_, cid_, sign_) tags_ ->
|
||||
s
|
||||
{ eAcnt = aid_
|
||||
|
|
@ -627,22 +646,28 @@ insertSplit t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do
|
|||
mapM_ (insert_ . TagRelationR k) eTags
|
||||
return k
|
||||
|
||||
lookupAccount :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR, AcntSign, AcntType))
|
||||
lookupAccount :: MonadFinance m => AcntID -> m (EitherErrs (Key AccountR, AcntSign, AcntType))
|
||||
lookupAccount p = lookupErr (DBKey AcntField) p <$> askDBState kmAccount
|
||||
|
||||
lookupAccountKey :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR))
|
||||
lookupAccountKey :: MonadFinance m => AcntID -> m (EitherErrs (Key AccountR))
|
||||
lookupAccountKey = fmap (fmap fstOf3) . lookupAccount
|
||||
|
||||
lookupAccountSign :: MonadFinance m => AcntID -> m (EitherErr AcntSign)
|
||||
lookupAccountSign :: MonadFinance m => AcntID -> m (EitherErrs AcntSign)
|
||||
lookupAccountSign = fmap (fmap sndOf3) . lookupAccount
|
||||
|
||||
lookupAccountType :: MonadFinance m => AcntID -> m (EitherErr AcntType)
|
||||
lookupAccountType :: MonadFinance m => AcntID -> m (EitherErrs AcntType)
|
||||
lookupAccountType = fmap (fmap thdOf3) . lookupAccount
|
||||
|
||||
lookupCurrency :: MonadFinance m => T.Text -> m (EitherErr (Key CurrencyR))
|
||||
lookupCurrency :: MonadFinance m => T.Text -> m (EitherErrs (Key CurrencyR, Natural))
|
||||
lookupCurrency c = lookupErr (DBKey CurField) c <$> askDBState kmCurrency
|
||||
|
||||
lookupTag :: MonadFinance m => TagID -> m (EitherErr (Key TagR))
|
||||
lookupCurrencyKey :: MonadFinance m => AcntID -> m (EitherErrs (Key CurrencyR))
|
||||
lookupCurrencyKey = fmap (fmap fst) . lookupCurrency
|
||||
|
||||
lookupCurrencyPrec :: MonadFinance m => AcntID -> m (EitherErrs Natural)
|
||||
lookupCurrencyPrec = fmap (fmap snd) . lookupCurrency
|
||||
|
||||
lookupTag :: MonadFinance m => TagID -> m (EitherErrs (Key TagR))
|
||||
lookupTag c = lookupErr (DBKey TagField) c <$> askDBState kmTag
|
||||
|
||||
-- TODO this hashes twice (not that it really matters)
|
||||
|
|
|
|||
|
|
@ -23,11 +23,12 @@ readImport :: MonadFinance m => Statement -> m (EitherErrs [BalTx])
|
|||
readImport Statement {..} = do
|
||||
let ores = plural $ compileOptions stmtTxOpts
|
||||
let cres = concatEithersL $ compileMatch <$> stmtParsers
|
||||
m <- askDBState kmCurrency
|
||||
case concatEithers2 ores cres (,) of
|
||||
Right (compiledOptions, compiledMatches) -> do
|
||||
ires <- mapM (readImport_ stmtSkipLines stmtDelim compiledOptions) stmtPaths
|
||||
case concatEitherL ires of
|
||||
Right records -> return $ matchRecords compiledMatches $ L.sort $ concat records
|
||||
Right records -> return $ runReader (matchRecords compiledMatches $ L.sort $ concat records) m
|
||||
Left es -> return $ Left es
|
||||
Left es -> return $ Left es
|
||||
|
||||
|
|
@ -62,15 +63,17 @@ parseTxRecord p TxOpts {..} r = do
|
|||
d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
|
||||
return $ Just $ TxRecord d' a e os p
|
||||
|
||||
matchRecords :: [MatchRe] -> [TxRecord] -> EitherErrs [BalTx]
|
||||
matchRecords :: [MatchRe] -> [TxRecord] -> CurrencyM (EitherErrs [BalTx])
|
||||
matchRecords ms rs = do
|
||||
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
|
||||
case (matched, unmatched, notfound) of
|
||||
(ms_, [], []) -> do
|
||||
-- TODO record number of times each match hits for debugging
|
||||
matched_ <- first (: []) $ mapM balanceTx ms_
|
||||
Right matched_
|
||||
(_, us, ns) -> Left [StatementError us ns]
|
||||
res <- matchAll (matchPriorities ms) rs
|
||||
case res of
|
||||
Left es -> return $ Left es
|
||||
Right (matched, unmatched, notfound) -> do
|
||||
case (matched, unmatched, notfound) of
|
||||
(ms_, [], []) -> do
|
||||
-- TODO record number of times each match hits for debugging
|
||||
return $ first (: []) $ mapM balanceTx ms_
|
||||
(_, us, ns) -> return $ Left [StatementError us ns]
|
||||
|
||||
matchPriorities :: [MatchRe] -> [MatchGroup]
|
||||
matchPriorities =
|
||||
|
|
@ -124,28 +127,38 @@ zipperSlice f x = go
|
|||
EQ -> goEq $ Unzipped bs (a : cs) as
|
||||
LT -> z
|
||||
|
||||
zipperMatch :: Unzipped MatchRe -> TxRecord -> EitherErrs (Zipped MatchRe, MatchRes RawTx)
|
||||
zipperMatch
|
||||
:: Unzipped MatchRe
|
||||
-> TxRecord
|
||||
-> CurrencyM (EitherErrs (Zipped MatchRe, MatchRes RawTx))
|
||||
zipperMatch (Unzipped bs cs as) x = go [] cs
|
||||
where
|
||||
go _ [] = Right (Zipped bs $ cs ++ as, MatchFail)
|
||||
go _ [] = return $ Right (Zipped bs $ cs ++ as, MatchFail)
|
||||
go prev (m : ms) = do
|
||||
res <- matches m x
|
||||
case res of
|
||||
MatchFail -> go (m : prev) ms
|
||||
skipOrPass ->
|
||||
Right MatchFail -> go (m : prev) ms
|
||||
Right skipOrPass ->
|
||||
let ps = reverse prev
|
||||
ms' = maybe ms (: ms) (matchDec m)
|
||||
in Right (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
|
||||
in return $ Right (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
|
||||
Left es -> return $ Left es
|
||||
|
||||
zipperMatch' :: Zipped MatchRe -> TxRecord -> EitherErrs (Zipped MatchRe, MatchRes RawTx)
|
||||
-- TODO all this unpacking left/error crap is annoying
|
||||
zipperMatch'
|
||||
:: Zipped MatchRe
|
||||
-> TxRecord
|
||||
-> CurrencyM (EitherErrs (Zipped MatchRe, MatchRes RawTx))
|
||||
zipperMatch' z x = go z
|
||||
where
|
||||
go (Zipped bs (a : as)) = do
|
||||
res <- matches a x
|
||||
case res of
|
||||
MatchFail -> go (Zipped (a : bs) as)
|
||||
skipOrPass -> Right (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
|
||||
go z' = Right (z', MatchFail)
|
||||
Right MatchFail -> go (Zipped (a : bs) as)
|
||||
Right skipOrPass ->
|
||||
return $ Right (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
|
||||
Left es -> return $ Left es
|
||||
go z' = return $ Right (z', MatchFail)
|
||||
|
||||
matchDec :: MatchRe -> Maybe MatchRe
|
||||
matchDec m = case spTimes m of
|
||||
|
|
@ -153,59 +166,76 @@ matchDec m = case spTimes m of
|
|||
Just n -> Just $ m {spTimes = Just $ n - 1}
|
||||
Nothing -> Just m
|
||||
|
||||
matchAll :: [MatchGroup] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
|
||||
matchAll :: [MatchGroup] -> [TxRecord] -> CurrencyM (EitherErrs ([RawTx], [TxRecord], [MatchRe]))
|
||||
matchAll = go ([], [])
|
||||
where
|
||||
go (matched, unused) gs rs = case (gs, rs) of
|
||||
(_, []) -> return (matched, [], unused)
|
||||
([], _) -> return (matched, rs, unused)
|
||||
(_, []) -> return $ Right (matched, [], unused)
|
||||
([], _) -> return $ Right (matched, rs, unused)
|
||||
(g : gs', _) -> do
|
||||
(ts, unmatched, us) <- matchGroup g rs
|
||||
go (ts ++ matched, us ++ unused) gs' unmatched
|
||||
res <- matchGroup g rs
|
||||
case res of
|
||||
Right (ts, unmatched, us) ->
|
||||
go (ts ++ matched, us ++ unused) gs' unmatched
|
||||
Left es -> return $ Left es
|
||||
|
||||
matchGroup :: MatchGroup -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
|
||||
matchGroup :: MatchGroup -> [TxRecord] -> CurrencyM (EitherErrs ([RawTx], [TxRecord], [MatchRe]))
|
||||
matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
|
||||
(md, rest, ud) <- matchDates ds rs
|
||||
(mn, unmatched, un) <- matchNonDates ns rest
|
||||
return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un)
|
||||
res <- matchDates ds rs
|
||||
case res of
|
||||
Left es -> return $ Left es
|
||||
Right (md, rest, ud) -> do
|
||||
res' <- matchNonDates ns rest
|
||||
case res' of
|
||||
Right (mn, unmatched, un) -> do
|
||||
return $ Right $ (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un)
|
||||
Left es -> return $ Left es
|
||||
|
||||
matchDates :: [MatchRe] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
|
||||
matchDates :: [MatchRe] -> [TxRecord] -> CurrencyM (EitherErrs ([RawTx], [TxRecord], [MatchRe]))
|
||||
matchDates ms = go ([], [], initZipper ms)
|
||||
where
|
||||
go (matched, unmatched, z) [] =
|
||||
Right
|
||||
( catMaybes matched
|
||||
, reverse unmatched
|
||||
, recoverZipper z
|
||||
)
|
||||
return $
|
||||
Right
|
||||
( catMaybes matched
|
||||
, reverse unmatched
|
||||
, recoverZipper z
|
||||
)
|
||||
go (matched, unmatched, z) (r : rs) =
|
||||
case zipperSlice findDate r z of
|
||||
Left zipped -> go (matched, r : unmatched, zipped) rs
|
||||
Right unzipped -> do
|
||||
(z', res) <- zipperMatch unzipped r
|
||||
let (m, u) = case res of
|
||||
MatchPass p -> (Just p : matched, unmatched)
|
||||
MatchSkip -> (Nothing : matched, unmatched)
|
||||
MatchFail -> (matched, r : unmatched)
|
||||
go (m, u, z') rs
|
||||
res <- zipperMatch unzipped r
|
||||
case res of
|
||||
Right (z', res') -> do
|
||||
let (m, u) = case res' of
|
||||
(MatchPass p) -> (Just p : matched, unmatched)
|
||||
MatchSkip -> (Nothing : matched, unmatched)
|
||||
MatchFail -> (matched, r : unmatched)
|
||||
go (m, u, z') rs
|
||||
Left es -> return $ Left es
|
||||
findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
|
||||
|
||||
matchNonDates :: [MatchRe] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
|
||||
matchNonDates :: [MatchRe] -> [TxRecord] -> CurrencyM (EitherErrs ([RawTx], [TxRecord], [MatchRe]))
|
||||
matchNonDates ms = go ([], [], initZipper ms)
|
||||
where
|
||||
go (matched, unmatched, z) [] =
|
||||
Right
|
||||
( catMaybes matched
|
||||
, reverse unmatched
|
||||
, recoverZipper z
|
||||
)
|
||||
return $
|
||||
Right
|
||||
( catMaybes matched
|
||||
, reverse unmatched
|
||||
, recoverZipper z
|
||||
)
|
||||
go (matched, unmatched, z) (r : rs) = do
|
||||
(z', res) <- zipperMatch' z r
|
||||
let (m, u) = case res of
|
||||
MatchPass p -> (Just p : matched, unmatched)
|
||||
MatchSkip -> (Nothing : matched, unmatched)
|
||||
MatchFail -> (matched, r : unmatched)
|
||||
in go (m, u, resetZipper z') rs
|
||||
res <- zipperMatch' z r
|
||||
case res of
|
||||
Left es -> return $ Left es
|
||||
Right (z', res') -> do
|
||||
let (m, u) = case res' of
|
||||
MatchPass p -> (Just p : matched, unmatched)
|
||||
MatchSkip -> (Nothing : matched, unmatched)
|
||||
MatchFail -> (matched, r : unmatched)
|
||||
in go (m, u, resetZipper z') rs
|
||||
|
||||
balanceTx :: RawTx -> EitherErr BalTx
|
||||
balanceTx t@Tx {txSplits = ss} = do
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@
|
|||
|
||||
module Internal.Types where
|
||||
|
||||
-- import Control.Monad.Except
|
||||
import Data.Fix (Fix (..), foldFix)
|
||||
import Data.Functor.Foldable (embed)
|
||||
import qualified Data.Functor.Foldable.TH as TH
|
||||
|
|
@ -49,7 +50,6 @@ makeHaskellTypesWith
|
|||
, SingleConstructor "RepeatPat" "RepeatPat" "(./dhall/Types.dhall).RepeatPat"
|
||||
, SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type"
|
||||
, SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type"
|
||||
, SingleConstructor "Decimal" "D" "(./dhall/Types.dhall).Decimal"
|
||||
, SingleConstructor "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type"
|
||||
, SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount"
|
||||
, SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
|
||||
|
|
@ -96,7 +96,6 @@ deriveProduct
|
|||
, "DateMatcher"
|
||||
, "ValMatcher"
|
||||
, "YMDMatcher"
|
||||
, "Decimal"
|
||||
, "BudgetCurrency"
|
||||
, "Exchange"
|
||||
, "EntryNumGetter"
|
||||
|
|
@ -180,6 +179,12 @@ deriving instance Hashable DatePat
|
|||
type BudgetTransfer =
|
||||
Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
|
||||
|
||||
deriving instance Hashable BudgetTransfer
|
||||
|
||||
deriving instance Generic BudgetTransfer
|
||||
|
||||
deriving instance FromDhall BudgetTransfer
|
||||
|
||||
data Budget = Budget
|
||||
{ bgtLabel :: Text
|
||||
, bgtIncomes :: [Income]
|
||||
|
|
@ -215,7 +220,7 @@ deriving instance Ord TaggedAcnt
|
|||
type CurID = T.Text
|
||||
|
||||
data Income = Income
|
||||
{ incGross :: Decimal
|
||||
{ incGross :: Double
|
||||
, incCurrency :: CurID
|
||||
, incWhen :: DatePat
|
||||
, incPretax :: [SingleAllocation PretaxValue]
|
||||
|
|
@ -231,9 +236,11 @@ deriving instance (Ord w, Ord v) => Ord (Amount w v)
|
|||
|
||||
deriving instance Generic (Amount w v)
|
||||
|
||||
deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Amount w v)
|
||||
deriving instance (FromDhall v, FromDhall w) => FromDhall (Amount w v)
|
||||
|
||||
deriving instance (Generic w, Generic v, Hashable w, Hashable v) => Hashable (Amount w v)
|
||||
deriving instance (Hashable v, Hashable w) => Hashable (Amount w v)
|
||||
|
||||
-- deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Amount w v)
|
||||
|
||||
deriving instance (Show w, Show v) => Show (Amount w v)
|
||||
|
||||
|
|
@ -280,11 +287,7 @@ data Transfer a c w v = Transfer
|
|||
, transAmounts :: [Amount w v]
|
||||
, transCurrency :: c
|
||||
}
|
||||
deriving (Eq, Show, Generic, FromDhall)
|
||||
|
||||
deriving instance
|
||||
(Generic w, Generic v, Hashable a, Hashable c, Hashable w, Hashable v)
|
||||
=> Hashable (Transfer a c w v)
|
||||
deriving (Eq, Show)
|
||||
|
||||
deriving instance Hashable ShadowTransfer
|
||||
|
||||
|
|
@ -298,10 +301,6 @@ deriving instance Hashable YMDMatcher
|
|||
|
||||
deriving instance Hashable DateMatcher
|
||||
|
||||
deriving instance Ord Decimal
|
||||
|
||||
deriving instance Hashable Decimal
|
||||
|
||||
-- TODO this just looks silly...but not sure how to simplify it
|
||||
instance Ord YMDMatcher where
|
||||
compare (Y y) (Y y') = compare y y'
|
||||
|
|
@ -394,12 +393,18 @@ type AcntID = T.Text
|
|||
|
||||
type TagID = T.Text
|
||||
|
||||
type HistTransfer = Transfer AcntID CurID DatePat Decimal
|
||||
type HistTransfer = Transfer AcntID CurID DatePat Double
|
||||
|
||||
deriving instance Generic HistTransfer
|
||||
|
||||
deriving instance Hashable HistTransfer
|
||||
|
||||
deriving instance FromDhall HistTransfer
|
||||
|
||||
data History
|
||||
= HistTransfer !HistTransfer
|
||||
| HistStatement !Statement
|
||||
deriving (Eq, Hashable, Generic, FromDhall)
|
||||
deriving (Eq, Generic, Hashable, FromDhall)
|
||||
|
||||
type EntryGetter = Entry SplitAcnt (Maybe EntryNumGetter) SplitCur TagID
|
||||
|
||||
|
|
@ -517,6 +522,7 @@ CommitR sql=commits
|
|||
CurrencyR sql=currencies
|
||||
symbol T.Text
|
||||
fullname T.Text
|
||||
precision Int
|
||||
deriving Show Eq
|
||||
TagR sql=tags
|
||||
symbol T.Text
|
||||
|
|
@ -579,7 +585,7 @@ instance PersistField ConfigType where
|
|||
|
||||
type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
|
||||
|
||||
type CurrencyMap = M.Map CurID CurrencyRId
|
||||
type CurrencyMap = M.Map CurID (CurrencyRId, Natural)
|
||||
|
||||
type TagMap = M.Map TagID TagRId
|
||||
|
||||
|
|
@ -593,6 +599,8 @@ data DBState = DBState
|
|||
, kmConfigDir :: !FilePath
|
||||
}
|
||||
|
||||
type CurrencyM = Reader CurrencyMap
|
||||
|
||||
type MappingT m = ReaderT DBState (SqlPersistT m)
|
||||
|
||||
type KeySplit = Entry AccountRId Rational CurrencyRId TagRId
|
||||
|
|
@ -746,6 +754,10 @@ type EitherErr = Either InsertError
|
|||
|
||||
type EitherErrs = Either [InsertError]
|
||||
|
||||
-- type InsertExceptT m = ExceptT [InsertError] m
|
||||
|
||||
-- type InsertExcept = InsertExceptT Identity
|
||||
|
||||
data XGregorian = XGregorian
|
||||
{ xgYear :: !Int
|
||||
, xgMonth :: !Int
|
||||
|
|
|
|||
|
|
@ -8,7 +8,6 @@ module Internal.Utils
|
|||
, resolveBounds
|
||||
, resolveBounds_
|
||||
, leftToMaybe
|
||||
, dec2Rat
|
||||
, concatEithers2
|
||||
, concatEithers3
|
||||
, concatEither3
|
||||
|
|
@ -37,9 +36,12 @@ module Internal.Utils
|
|||
, compileOptions
|
||||
, dateMatches
|
||||
, valMatches
|
||||
, roundPrecision
|
||||
, roundPrecisionCur
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.Reader
|
||||
import Data.Time.Format.ISO8601
|
||||
import GHC.Real
|
||||
import Internal.Types
|
||||
|
|
@ -153,28 +155,34 @@ expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d)
|
|||
--------------------------------------------------------------------------------
|
||||
-- matching
|
||||
|
||||
matches :: MatchRe -> TxRecord -> EitherErrs (MatchRes RawTx)
|
||||
matches :: MatchRe -> TxRecord -> CurrencyM (EitherErrs (MatchRes RawTx))
|
||||
matches
|
||||
StatementParser {spTx, spOther, spVal, spDate, spDesc}
|
||||
r@TxRecord {trDate, trAmount, trDesc, trOther} = do
|
||||
res <- concatEither3 val other desc $ \x y z -> x && y && z
|
||||
if date && res
|
||||
then maybe (Right MatchSkip) (fmap MatchPass . convert) spTx
|
||||
else Right MatchFail
|
||||
let res = concatEithers3 val other desc $ \x y z -> x && y && z && date
|
||||
case res of
|
||||
Right test
|
||||
| test -> maybe (return $ Right MatchSkip) convert spTx
|
||||
| otherwise -> return $ Right MatchFail
|
||||
Left es -> return $ Left es
|
||||
where
|
||||
val = valMatches spVal trAmount
|
||||
date = maybe True (`dateMatches` trDate) spDate
|
||||
other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther
|
||||
desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
|
||||
convert (TxGetter cur a ss) = toTx cur a ss r
|
||||
convert (TxGetter cur a ss) = do
|
||||
res <- toTx cur a ss r
|
||||
return $ fmap MatchPass res
|
||||
|
||||
toTx :: SplitCur -> SplitAcnt -> [EntryGetter] -> TxRecord -> EitherErrs RawTx
|
||||
toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
|
||||
concatEithers2 acRes ssRes $ \(a_, c_) ss_ ->
|
||||
toTx :: SplitCur -> SplitAcnt -> [EntryGetter] -> TxRecord -> CurrencyM (EitherErrs RawTx)
|
||||
toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = do
|
||||
m <- ask
|
||||
let ssRes = concatEithersL $ fmap (resolveEntry m r) toSplits
|
||||
return $ concatEithers2 acRes ssRes $ \(a, c) ss ->
|
||||
let fromSplit =
|
||||
Entry
|
||||
{ eAcnt = a_
|
||||
, eCurrency = c_
|
||||
{ eAcnt = a
|
||||
, eCurrency = c
|
||||
, eValue = Just trAmount
|
||||
, eComment = ""
|
||||
, eTags = [] -- TODO what goes here?
|
||||
|
|
@ -182,15 +190,14 @@ toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
|
|||
in Tx
|
||||
{ txDate = trDate
|
||||
, txDescr = trDesc
|
||||
, txSplits = fromSplit : ss_
|
||||
, txSplits = fromSplit : ss
|
||||
}
|
||||
where
|
||||
acRes = concatEithers2 (resolveAcnt r sa) (resolveCurrency r sc) (,)
|
||||
ssRes = concatEithersL $ fmap (resolveSplit r) toSplits
|
||||
|
||||
valMatches :: ValMatcher -> Rational -> EitherErr Bool
|
||||
valMatches :: ValMatcher -> Rational -> EitherErrs Bool
|
||||
valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
|
||||
| Just d_ <- vmDen, d_ >= p = Left $ MatchValPrecisionError d_ p
|
||||
| Just d_ <- vmDen, d_ >= p = Left [MatchValPrecisionError d_ p]
|
||||
| otherwise =
|
||||
Right $
|
||||
checkMaybe (s ==) vmSign
|
||||
|
|
@ -205,26 +212,33 @@ valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
|
|||
dateMatches :: DateMatcher -> Day -> Bool
|
||||
dateMatches md = (EQ ==) . compareDate md
|
||||
|
||||
otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> EitherErr Bool
|
||||
otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> EitherErrs Bool
|
||||
otherMatches dict m = case m of
|
||||
Val (Field n mv) -> valMatches mv =<< (readRational =<< lookup_ MatchNumeric n)
|
||||
Desc (Field n (_, md)) -> (`matchMaybe` md) =<< lookup_ MatchText n
|
||||
where
|
||||
lookup_ t n = lookupErr (MatchField t) n dict
|
||||
|
||||
resolveSplit :: TxRecord -> EntryGetter -> EitherErrs RawSplit
|
||||
resolveSplit r s@Entry {eAcnt, eValue, eCurrency} =
|
||||
concatEithers2 acRes valRes $
|
||||
\(a_, c_) v_ -> (s {eAcnt = a_, eValue = v_, eCurrency = c_})
|
||||
resolveEntry :: CurrencyMap -> TxRecord -> EntryGetter -> EitherErrs RawSplit
|
||||
resolveEntry m r s@Entry {eAcnt, eValue, eCurrency} = do
|
||||
(a, c, v) <- concatEithers2 acRes valRes $ \(a, c) v -> (a, c, v)
|
||||
v' <- mapM (roundPrecisionCur c m) v
|
||||
return $
|
||||
s
|
||||
{ eAcnt = a
|
||||
, eValue = v'
|
||||
, eCurrency = c
|
||||
}
|
||||
where
|
||||
acRes = concatEithers2 (resolveAcnt r eAcnt) (resolveCurrency r eCurrency) (,)
|
||||
valRes = plural $ mapM (resolveValue r) eValue
|
||||
valRes = mapM (resolveValue r) eValue
|
||||
|
||||
resolveValue :: TxRecord -> EntryNumGetter -> EitherErr Rational
|
||||
resolveValue :: TxRecord -> EntryNumGetter -> EitherErrs Double
|
||||
resolveValue r s = case s of
|
||||
(LookupN t) -> readRational =<< lookupErr SplitValField t (trOther r)
|
||||
(ConstN c) -> Right $ dec2Rat c
|
||||
AmountN -> Right $ trAmount r
|
||||
(LookupN t) -> readDouble =<< lookupErr SplitValField t (trOther r)
|
||||
(ConstN c) -> Right c
|
||||
-- TODO don't coerce to rational in trAmount
|
||||
AmountN -> Right $ fromRational $ trAmount r
|
||||
|
||||
resolveAcnt :: TxRecord -> SplitAcnt -> EitherErrs T.Text
|
||||
resolveAcnt = resolveSplitField AcntField
|
||||
|
|
@ -235,21 +249,21 @@ resolveCurrency = resolveSplitField CurField
|
|||
resolveSplitField :: SplitIDType -> TxRecord -> SplitAcnt -> EitherErrs T.Text
|
||||
resolveSplitField t TxRecord {trOther = o} s = case s of
|
||||
ConstT p -> Right p
|
||||
LookupT f -> plural $ lookup_ f o
|
||||
MapT (Field f m) -> plural $ do
|
||||
LookupT f -> lookup_ f o
|
||||
MapT (Field f m) -> do
|
||||
k <- lookup_ f o
|
||||
lookup_ k m
|
||||
Map2T (Field (f1, f2) m) -> do
|
||||
(k1, k2) <- concatEither2 (lookup_ f1 o) (lookup_ f2 o) (,)
|
||||
plural $ lookup_ (k1, k2) m
|
||||
(k1, k2) <- concatEithers2 (lookup_ f1 o) (lookup_ f2 o) (,)
|
||||
lookup_ (k1, k2) m
|
||||
where
|
||||
lookup_ :: (Ord k, Show k) => k -> M.Map k v -> EitherErr v
|
||||
lookup_ :: (Ord k, Show k) => k -> M.Map k v -> EitherErrs v
|
||||
lookup_ = lookupErr (SplitIDField t)
|
||||
|
||||
lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> EitherErr v
|
||||
lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> EitherErrs v
|
||||
lookupErr what k m = case M.lookup k m of
|
||||
Just x -> Right x
|
||||
_ -> Left $ LookupError what $ showT k
|
||||
_ -> Left [LookupError what $ showT k]
|
||||
|
||||
parseRational :: MonadFail m => (T.Text, Regex) -> T.Text -> m Rational
|
||||
parseRational (pat, re) s = case matchGroupsMaybe s re of
|
||||
|
|
@ -278,7 +292,12 @@ parseRational (pat, re) s = case matchGroupsMaybe s re of
|
|||
k <- readSign sign
|
||||
return (k, w)
|
||||
|
||||
readRational :: T.Text -> EitherErr Rational
|
||||
readDouble :: T.Text -> EitherErrs Double
|
||||
readDouble s = case readMaybe $ T.unpack s of
|
||||
Just x -> Right x
|
||||
Nothing -> Left [ConversionError s]
|
||||
|
||||
readRational :: T.Text -> EitherErrs Rational
|
||||
readRational s = case T.split (== '.') s of
|
||||
[x] -> maybe err (return . fromInteger) $ readT x
|
||||
[x, y] -> case (readT x, readT y) of
|
||||
|
|
@ -290,7 +309,7 @@ readRational s = case T.split (== '.') s of
|
|||
_ -> err
|
||||
where
|
||||
readT = readMaybe . T.unpack
|
||||
err = Left $ ConversionError s
|
||||
err = Left [ConversionError s]
|
||||
|
||||
-- TODO smells like a lens
|
||||
-- mapTxSplits :: (a -> b) -> Tx a -> Tx b
|
||||
|
|
@ -307,11 +326,22 @@ fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d']
|
|||
txt = T.pack . show
|
||||
pad i c z = T.append (T.replicate (i - T.length z) c) z
|
||||
|
||||
dec2Rat :: Decimal -> Rational
|
||||
dec2Rat D {sign, whole, decimal, precision} =
|
||||
k * (fromIntegral whole + (fromIntegral decimal % (10 ^ precision)))
|
||||
roundPrecision :: Natural -> Double -> Rational
|
||||
roundPrecision n = (% p) . round . (* fromIntegral p) . toRational
|
||||
where
|
||||
k = if sign then 1 else -1
|
||||
p = 10 ^ n
|
||||
|
||||
roundPrecisionCur :: CurID -> CurrencyMap -> Double -> EitherErrs Rational
|
||||
roundPrecisionCur c m x =
|
||||
case M.lookup c m of
|
||||
Just (_, n) -> Right $ roundPrecision n x
|
||||
Nothing -> Left undefined
|
||||
|
||||
-- dec2Rat :: Decimal -> Rational
|
||||
-- dec2Rat D {sign, whole, decimal, precision} =
|
||||
-- k * (fromIntegral whole + (fromIntegral decimal % (10 ^ precision)))
|
||||
-- where
|
||||
-- k = if sign then 1 else -1
|
||||
|
||||
acntPath2Text :: AcntPath -> T.Text
|
||||
acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
|
||||
|
|
@ -640,10 +670,10 @@ compileRegex groups pat = case res of
|
|||
(blankExecOpt {captureGroups = groups})
|
||||
pat
|
||||
|
||||
matchMaybe :: T.Text -> Regex -> EitherErr Bool
|
||||
matchMaybe :: T.Text -> Regex -> EitherErrs Bool
|
||||
matchMaybe q re = case execute re q of
|
||||
Right res -> Right $ isJust res
|
||||
Left _ -> Left $ RegexError "this should not happen"
|
||||
Left _ -> Left [RegexError "this should not happen"]
|
||||
|
||||
matchGroupsMaybe :: T.Text -> Regex -> [T.Text]
|
||||
matchGroupsMaybe q re = case regexec re q of
|
||||
|
|
|
|||
Loading…
Reference in New Issue