WIP use doubles in config

This commit is contained in:
Nathan Dwarshuis 2023-05-04 21:48:21 -04:00
parent 2119eb61c8
commit 38710b1f56
7 changed files with 310 additions and 222 deletions

View File

@ -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_

View File

@ -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

View File

@ -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

View File

@ -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)

View File

@ -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

View File

@ -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

View File

@ -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