ndwarshuis
/
pwncash
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
dhall/Types.dhall
View File

@ -106,6 +106,11 @@ let Currency =
The full description of this currency (eg "Yugoslavian Twitcoin") The full description of this currency (eg "Yugoslavian Twitcoin")
-} -}
Text Text
, curPrecision :
{-
The number of decimal places for this currency
-}
Natural
} }
let TagID = let TagID =
@ -273,9 +278,6 @@ let DatePat =
-} -}
< Cron : CronPat.Type | Mod : ModPat.Type > < Cron : CronPat.Type | Mod : ModPat.Type >
let Decimal =
{ whole : Natural, decimal : Natural, precision : Natural, sign : Bool }
let TxOpts = let TxOpts =
{- Additional metadata to use when parsing a statement -} {- Additional metadata to use when parsing a statement -}
{ Type = { Type =
@ -402,7 +404,7 @@ let EntryNumGetter =
ConstN: a constant value ConstN: a constant value
AmountN: the value of the 'Amount' column AmountN: the value of the 'Amount' column
-} -}
< LookupN : Text | ConstN : Decimal | AmountN > < LookupN : Text | ConstN : Double | AmountN >
let EntryTextGetter = let EntryTextGetter =
{- {-
@ -595,7 +597,7 @@ let HistTransfer =
{- {-
A manually specified historical transfer A manually specified historical transfer
-} -}
Transfer AcntID CurID DatePat Decimal Transfer AcntID CurID DatePat Double
let Statement = let Statement =
{- {-
@ -655,7 +657,7 @@ let Exchange =
{- {-
The exchange rate between the currencies. The exchange rate between the currencies.
-} -}
Decimal Double
} }
let BudgetCurrency = let BudgetCurrency =
@ -692,7 +694,7 @@ let PretaxValue =
{- {-
The value to be deducted from gross income The value to be deducted from gross income
-} -}
Decimal Double
, prePercent : , prePercent :
{- {-
If true, value is interpreted as a percent of gross income instead of 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 A single tax bracket. Read as "every unit above limit is taxed at this
percentage". percentage".
-} -}
{ tbLowerLimit : Decimal, tbPercent : Decimal } { tbLowerLimit : Double, tbPercent : Double }
let TaxProgression = let TaxProgression =
{- {-
@ -724,7 +726,7 @@ let TaxProgression =
{- {-
Initial amount to subtract from after-pretax-deductions Initial amount to subtract from after-pretax-deductions
-} -}
Decimal Double
, tpBrackets : , tpBrackets :
{- {-
Tax brackets to apply after deductions (order does not matter, each 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) How to implement a given tax (either a progressive tax or a fixed percent)
-} -}
< TMBracket : TaxProgression | TMPercent : Decimal > < TMBracket : TaxProgression | TMPercent : Double >
let TaxValue = let TaxValue =
{- {-
@ -761,7 +763,7 @@ let PosttaxValue =
{- {-
The value to be deducted from income remaining after taxes. The value to be deducted from income remaining after taxes.
-} -}
Decimal Double
, postPercent : , postPercent :
{- {-
If true, subtract a percentage from the after-tax remainder instead If true, subtract a percentage from the after-tax remainder instead
@ -794,7 +796,7 @@ let Income =
{- {-
The value of the income stream. The value of the income stream.
-} -}
Decimal Double
, incCurrency : , incCurrency :
{- {-
The currency in which the income stream is denominated. 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. Fixed multipler to translate value of matched transfer to this one.
-} -}
Decimal Double
} }
let BudgetTransferValue = let BudgetTransferValue =
{- {-
Means to determine the value of a budget transfer. Means to determine the value of a budget transfer.
-} -}
{ btVal : Decimal, btType : BudgetTransferType } { btVal : Double, btType : BudgetTransferType }
let BudgetTransfer = let BudgetTransfer =
{- {-
@ -984,7 +986,6 @@ in { CurID
, WeekdayPat , WeekdayPat
, CronPat , CronPat
, DatePat , DatePat
, Decimal
, TxOpts , TxOpts
, StatementParser , StatementParser
, StatementParser_ , StatementParser_

19
dhall/common.dhall
View File

@ -4,19 +4,6 @@ let List/map =
let T = ./Types.dhall 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 = let nullSplit =
\(a : T.EntryAcntGetter) -> \(a : T.EntryAcntGetter) ->
\(c : T.EntryCurGetter) -> \(c : T.EntryCurGetter) ->
@ -99,7 +86,7 @@ let mRngYMD =
\(r : Natural) -> \(r : Natural) ->
T.DateMatcher.In { _1 = T.YMDMatcher.YMD (greg y m d), _2 = r } 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 = let partN =
\(c : T.EntryCurGetter) -> \(c : T.EntryCurGetter) ->
@ -184,9 +171,5 @@ in { nullSplit
, mvDenP , mvDenP
, mvDenN , mvDenN
, PartSplit , PartSplit
, d
, d_
, dec
, dec2
} }
/\ T /\ T

13
lib/Internal/Database/Ops.hs
View File

@ -194,11 +194,18 @@ updateCurrencies cs = do
return $ currencyMap curs return $ currencyMap curs
currency2Record :: Currency -> Entity CurrencyR currency2Record :: Currency -> Entity CurrencyR
currency2Record c@Currency {curSymbol, curFullname} = currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
Entity (toKey c) $ CurrencyR curSymbol curFullname Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision)
currencyMap :: [Entity CurrencyR] -> CurrencyMap 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 :: MonadUnliftIO m => [Tag] -> SqlPersistT m TagMap
updateTags cs = do updateTags cs = do

179
lib/Internal/Insert.hs
View File

@ -8,7 +8,7 @@ import Data.Hashable
import Database.Persist.Class import Database.Persist.Class
import Database.Persist.Sql hiding (Single, Statement) import Database.Persist.Sql hiding (Single, Statement)
import Internal.Statement import Internal.Statement
import Internal.Types hiding (sign) import Internal.Types hiding (CurrencyM, sign)
import Internal.Utils import Internal.Utils
import RIO hiding (to) import RIO hiding (to)
import qualified RIO.List as L import qualified RIO.List as L
@ -134,7 +134,8 @@ insertBudget
res2 <- expandTransfers key bgtLabel bgtTransfers res2 <- expandTransfers key bgtLabel bgtTransfers
unlessLefts (concatEithers2 (concat <$> concatEithersL res1) res2 (++)) $ unlessLefts (concatEithers2 (concat <$> concatEithersL res1) res2 (++)) $
\txs -> do \txs -> do
unlessLefts (addShadowTransfers bgtShadowTransfers txs) $ \shadow -> do m <- lift $ askDBState kmCurrency
unlessLefts (addShadowTransfers m bgtShadowTransfers txs) $ \shadow -> do
let bals = balanceTransfers $ txs ++ shadow let bals = balanceTransfers $ txs ++ shadow
concat <$> mapM insertBudgetTx bals concat <$> mapM insertBudgetTx bals
where 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? -- TODO this is going to be O(n*m), which might be a problem?
addShadowTransfers addShadowTransfers
:: [ShadowTransfer] :: CurrencyMap
-> [ShadowTransfer]
-> [UnbalancedTransfer] -> [UnbalancedTransfer]
-> EitherErrs [UnbalancedTransfer] -> EitherErrs [UnbalancedTransfer]
addShadowTransfers ms txs = addShadowTransfers cm ms txs =
fmap catMaybes $ fmap catMaybes $
concatEitherL $ concatEithersL $
fmap (uncurry fromShadow) $ fmap (uncurry (fromShadow cm)) $
[(t, m) | t <- txs, m <- ms] [(t, m) | t <- txs, m <- ms]
fromShadow fromShadow
:: UnbalancedTransfer :: CurrencyMap
-> UnbalancedTransfer
-> ShadowTransfer -> ShadowTransfer
-> EitherErr (Maybe UnbalancedTransfer) -> EitherErrs (Maybe UnbalancedTransfer)
fromShadow tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
res <- shadowMatches (stMatch t) tx res <- shadowMatches (stMatch t) tx
v <- roundPrecisionCur (initialCurrency stCurrency) cm stRatio
return $ return $
if not res if not res
then Nothing then Nothing
@ -196,11 +200,11 @@ fromShadow tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stTyp
, cbtCur = stCurrency , cbtCur = stCurrency
, cbtFrom = stFrom , cbtFrom = stFrom
, cbtTo = stTo , cbtTo = stTo
, cbtValue = UnbalancedValue stType $ dec2Rat stRatio * cvValue (cbtValue tx) , cbtValue = UnbalancedValue stType $ v * cvValue (cbtValue tx)
, cbtDesc = stDesc , cbtDesc = stDesc
} }
shadowMatches :: TransferMatcher -> UnbalancedTransfer -> EitherErr Bool shadowMatches :: TransferMatcher -> UnbalancedTransfer -> EitherErrs Bool
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
valRes <- valMatches tmVal $ cvValue $ cbtValue tx valRes <- valMatches tmVal $ cvValue $ cbtValue tx
return $ return $
@ -274,30 +278,32 @@ insertIncome
Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal, incGross} = do Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal, incGross} = do
-- TODO check that the other accounts are not income somewhere here -- TODO check that the other accounts are not income somewhere here
fromRes <- lift $ checkAcntType IncomeT $ taAcnt incFrom fromRes <- lift $ checkAcntType IncomeT $ taAcnt incFrom
case fromRes of precRes <- lift $ lookupCurrencyPrec incCurrency
Left e -> return $ Left [e] case concatEithers2 fromRes precRes (,) of
Left e -> return $ Left e
-- TODO this will scan the interval allocations fully each time -- TODO this will scan the interval allocations fully each time
-- iteration which is a total waste, but the fix requires turning this -- iteration which is a total waste, but the fix requires turning this
-- loop into a fold which I don't feel like doing now :( -- 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 where
meta = BudgetMeta key name meta = BudgetMeta key name
gross = dec2Rat incGross
flatPre = concatMap flattenAllo incPretax flatPre = concatMap flattenAllo incPretax
flatTax = concatMap flattenAllo incTaxes flatTax = concatMap flattenAllo incTaxes
flatPost = concatMap flattenAllo incPosttax flatPost = concatMap flattenAllo incPosttax
sumAllos = sum . fmap faValue sumAllos = sum . fmap faValue
-- TODO ensure these are all the "correct" accounts -- TODO ensure these are all the "correct" accounts
allocate day = allocate precision gross day =
let (preDeductions, pre) = let (preDeductions, pre) =
allocatePre gross $ allocatePre precision gross $
flatPre ++ concatMap (selectAllos day) intPre flatPre ++ concatMap (selectAllos day) intPre
tax = tax =
allocateTax gross preDeductions $ allocateTax precision gross preDeductions $
flatTax ++ concatMap (selectAllos day) intTax flatTax ++ concatMap (selectAllos day) intTax
aftertaxGross = sumAllos $ tax ++ pre aftertaxGross = sumAllos $ tax ++ pre
post = post =
allocatePost aftertaxGross $ allocatePost precision aftertaxGross $
flatPost ++ concatMap (selectAllos day) intPost flatPost ++ concatMap (selectAllos day) intPost
balance = aftertaxGross - sumAllos post balance = aftertaxGross - sumAllos post
bal = bal =
@ -315,15 +321,19 @@ insertIncome
else Right $ bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post) else Right $ bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post)
allocatePre allocatePre
:: Rational :: Natural
-> Rational
-> [FlatAllocation PretaxValue] -> [FlatAllocation PretaxValue]
-> (M.Map T.Text Rational, [FlatAllocation Rational]) -> (M.Map T.Text Rational, [FlatAllocation Rational])
allocatePre gross = L.mapAccumR go M.empty allocatePre precision gross = L.mapAccumR go M.empty
where where
go m f@FlatAllocation {faValue} = go m f@FlatAllocation {faValue} =
let c = preCategory faValue let c = preCategory faValue
p = dec2Rat $ preValue faValue p = preValue faValue
v = if prePercent faValue then p * gross else p v =
if prePercent faValue
then roundPrecision 3 p * gross
else roundPrecision precision p
in (mapAdd_ c v m, f {faValue = v}) in (mapAdd_ c v m, f {faValue = v})
allo2Trans allo2Trans
@ -344,34 +354,36 @@ allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} =
} }
allocateTax allocateTax
:: Rational :: Natural
-> Rational
-> M.Map T.Text Rational -> M.Map T.Text Rational
-> [FlatAllocation TaxValue] -> [FlatAllocation TaxValue]
-> [FlatAllocation Rational] -> [FlatAllocation Rational]
allocateTax gross deds = fmap (fmap go) allocateTax precision gross deds = fmap (fmap go)
where where
go TaxValue {tvCategories, tvMethod} = go TaxValue {tvCategories, tvMethod} =
let agi = gross - sum (mapMaybe (`M.lookup` deds) tvCategories) let agi = gross - sum (mapMaybe (`M.lookup` deds) tvCategories)
in case tvMethod of in case tvMethod of
TMPercent p -> dec2Rat p * agi TMPercent p -> roundPrecision 3 p * agi
TMBracket TaxProgression {tpDeductible, tpBrackets} -> TMBracket TaxProgression {tpDeductible, tpBrackets} ->
foldBracket (agi - dec2Rat tpDeductible) tpBrackets foldBracket precision (agi - roundPrecision precision tpDeductible) tpBrackets
allocatePost allocatePost
:: Rational :: Natural
-> Rational
-> [FlatAllocation PosttaxValue] -> [FlatAllocation PosttaxValue]
-> [FlatAllocation Rational] -> [FlatAllocation Rational]
allocatePost aftertax = fmap (fmap go) allocatePost precision aftertax = fmap (fmap go)
where where
go PosttaxValue {postValue, postPercent} = 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 :: Natural -> Rational -> [TaxBracket] -> Rational
foldBracket agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs foldBracket precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
where where
go TaxBracket {tbLowerLimit, tbPercent} (acc, remain) = go TaxBracket {tbLowerLimit, tbPercent} (acc, remain) =
let l = dec2Rat tbLowerLimit let l = roundPrecision precision tbLowerLimit
p = dec2Rat tbPercent p = roundPrecision 3 tbPercent
in if remain < l then (acc + p * (remain - l), l) else (acc, remain) in if remain < l then (acc + p * (remain - l), l) else (acc, remain)
data FlatAllocation v = FlatAllocation data FlatAllocation v = FlatAllocation
@ -418,39 +430,46 @@ expandTransfers key name ts = do
txs <- mapM (expandTransfer key name) ts txs <- mapM (expandTransfer key name) ts
return $ L.sortOn cbtWhen . concat <$> concatEithersL txs return $ L.sortOn cbtWhen . concat <$> concatEithersL txs
initialCurrency :: BudgetCurrency -> CurID
initialCurrency (NoX c) = c
initialCurrency (X Exchange {xFromCur = c}) = c
expandTransfer expandTransfer
:: MonadFinance m :: MonadFinance m
=> CommitRId => CommitRId
-> T.Text -> T.Text
-> BudgetTransfer -> BudgetTransfer
-> SqlPersistT m (EitherErrs [UnbalancedTransfer]) -> SqlPersistT m (EitherErrs [UnbalancedTransfer])
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do
-- whenHash CTExpense t (Right []) $ \key -> pRes <- lift $ lookupCurrencyPrec $ initialCurrency transCurrency
fmap (fmap concat . concatEithersL) $ case pRes of
forM transAmounts $ Left es -> return $ Left es
\Amount Right p ->
{ amtWhen = pat fmap (fmap concat . concatEithersL) $
, amtValue = BudgetTransferValue {btVal = v, btType = y} forM transAmounts $
, amtDesc = desc \Amount
} -> { amtWhen = pat
do , amtValue = BudgetTransferValue {btVal = v, btType = y}
withDates pat $ \day -> , amtDesc = desc
let meta = } ->
BudgetMeta do
{ bmCommit = key withDates pat $ \day ->
, bmName = name let meta =
} BudgetMeta
tx = { bmCommit = key
FlatTransfer , bmName = name
{ cbtMeta = meta }
, cbtWhen = day tx =
, cbtCur = transCurrency FlatTransfer
, cbtFrom = transFrom { cbtMeta = meta
, cbtTo = transTo , cbtWhen = day
, cbtValue = UnbalancedValue y $ dec2Rat v , cbtCur = transCurrency
, cbtDesc = desc , cbtFrom = transFrom
} , cbtTo = transTo
in return $ Right tx , cbtValue = UnbalancedValue y $ roundPrecision p v
, cbtDesc = desc
}
in return $ Right tx
insertBudgetTx :: MonadFinance m => BalancedTransfer -> SqlPersistT m [InsertError] insertBudgetTx :: MonadFinance m => BalancedTransfer -> SqlPersistT m [InsertError]
insertBudgetTx FlatTransfer {cbtFrom, cbtTo, cbtMeta, cbtCur, cbtValue, cbtDesc, cbtWhen} = do 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 X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do
let middle = TaggedAcnt xAcnt [] let middle = TaggedAcnt xAcnt []
res1 <- pair xFromCur from middle val 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) return $ concatEithers2 res1 res2 $ \a b -> (a, Just b)
where where
pair curid from_ to_ v = do pair curid from_ to_ v = do
@ -502,19 +521,19 @@ checkAcntType
:: MonadFinance m :: MonadFinance m
=> AcntType => AcntType
-> AcntID -> AcntID
-> m (EitherErr AcntID) -> m (EitherErrs AcntID)
checkAcntType t = checkAcntTypes (t :| []) checkAcntType t = checkAcntTypes (t :| [])
checkAcntTypes checkAcntTypes
:: MonadFinance m :: MonadFinance m
=> NE.NonEmpty AcntType => NE.NonEmpty AcntType
-> AcntID -> AcntID
-> m (EitherErr AcntID) -> m (EitherErrs AcntID)
checkAcntTypes ts i = (go =<<) <$> lookupAccountType i checkAcntTypes ts i = (go =<<) <$> lookupAccountType i
where where
go t go t
| t `L.elem` ts = Right i | t `L.elem` ts = Right i
| otherwise = Left $ AccountError i ts | otherwise = Left [AccountError i ts]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- statements -- statements
@ -536,12 +555,12 @@ insertManual
} = do } = do
whenHash CTManual m [] $ \c -> do whenHash CTManual m [] $ \c -> do
bounds <- lift $ askDBState kmStatementInterval bounds <- lift $ askDBState kmStatementInterval
-- let days = expandDatePat bounds dp precRes <- lift $ lookupCurrencyPrec u
es <- forM amts $ \Amount {amtWhen, amtValue, amtDesc} -> do es <- forM amts $ \Amount {amtWhen, amtValue, amtDesc} -> do
let v = dec2Rat amtValue
let dayRes = expandDatePat bounds amtWhen let dayRes = expandDatePat bounds amtWhen
unlessLefts dayRes $ \days -> do -- TODO rounding too often
let tx day = txPair day from to u v amtDesc unlessLefts (concatEithers2 dayRes precRes (,)) $ \(days, p) -> do
let tx day = txPair day from to u (roundPrecision p amtValue) amtDesc
txRes <- mapM (lift . tx) days txRes <- mapM (lift . tx) days
unlessLefts_ (concatEithersL txRes) $ mapM_ (insertTx c) unlessLefts_ (concatEithersL txRes) $ mapM_ (insertTx c)
return $ concat es return $ concat es
@ -601,13 +620,13 @@ resolveTx t@Tx {txSplits = ss} = do
resolveSplit :: MonadFinance m => BalSplit -> m (EitherErrs KeySplit) resolveSplit :: MonadFinance m => BalSplit -> m (EitherErrs KeySplit)
resolveSplit s@Entry {eAcnt, eCurrency, eValue, eTags} = do resolveSplit s@Entry {eAcnt, eCurrency, eValue, eTags} = do
aid <- lookupAccountKey eAcnt aid <- lookupAccountKey eAcnt
cid <- lookupCurrency eCurrency cid <- lookupCurrencyKey eCurrency
sign <- lookupAccountSign eAcnt sign <- lookupAccountSign eAcnt
tags <- mapM lookupTag eTags tags <- mapM lookupTag eTags
-- TODO correct sign here? -- TODO correct sign here?
-- TODO lenses would be nice here -- TODO lenses would be nice here
return $ return $
concatEithers2 (concatEither3 aid cid sign (,,)) (concatEitherL tags) $ concatEithers2 (concatEithers3 aid cid sign (,,)) (concatEithersL tags) $
\(aid_, cid_, sign_) tags_ -> \(aid_, cid_, sign_) tags_ ->
s s
{ eAcnt = aid_ { eAcnt = aid_
@ -627,22 +646,28 @@ insertSplit t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do
mapM_ (insert_ . TagRelationR k) eTags mapM_ (insert_ . TagRelationR k) eTags
return k 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 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 lookupAccountKey = fmap (fmap fstOf3) . lookupAccount
lookupAccountSign :: MonadFinance m => AcntID -> m (EitherErr AcntSign) lookupAccountSign :: MonadFinance m => AcntID -> m (EitherErrs AcntSign)
lookupAccountSign = fmap (fmap sndOf3) . lookupAccount lookupAccountSign = fmap (fmap sndOf3) . lookupAccount
lookupAccountType :: MonadFinance m => AcntID -> m (EitherErr AcntType) lookupAccountType :: MonadFinance m => AcntID -> m (EitherErrs AcntType)
lookupAccountType = fmap (fmap thdOf3) . lookupAccount 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 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 lookupTag c = lookupErr (DBKey TagField) c <$> askDBState kmTag
-- TODO this hashes twice (not that it really matters) -- TODO this hashes twice (not that it really matters)

132
lib/Internal/Statement.hs
View File

@ -23,11 +23,12 @@ readImport :: MonadFinance m => Statement -> m (EitherErrs [BalTx])
readImport Statement {..} = do readImport Statement {..} = do
let ores = plural $ compileOptions stmtTxOpts let ores = plural $ compileOptions stmtTxOpts
let cres = concatEithersL $ compileMatch <$> stmtParsers let cres = concatEithersL $ compileMatch <$> stmtParsers
m <- askDBState kmCurrency
case concatEithers2 ores cres (,) of case concatEithers2 ores cres (,) of
Right (compiledOptions, compiledMatches) -> do Right (compiledOptions, compiledMatches) -> do
ires <- mapM (readImport_ stmtSkipLines stmtDelim compiledOptions) stmtPaths ires <- mapM (readImport_ stmtSkipLines stmtDelim compiledOptions) stmtPaths
case concatEitherL ires of 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
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 d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
return $ Just $ TxRecord d' a e os p return $ Just $ TxRecord d' a e os p
matchRecords :: [MatchRe] -> [TxRecord] -> EitherErrs [BalTx] matchRecords :: [MatchRe] -> [TxRecord] -> CurrencyM (EitherErrs [BalTx])
matchRecords ms rs = do matchRecords ms rs = do
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs res <- matchAll (matchPriorities ms) rs
case (matched, unmatched, notfound) of case res of
(ms_, [], []) -> do Left es -> return $ Left es
-- TODO record number of times each match hits for debugging Right (matched, unmatched, notfound) -> do
matched_ <- first (: []) $ mapM balanceTx ms_ case (matched, unmatched, notfound) of
Right matched_ (ms_, [], []) -> do
(_, us, ns) -> Left [StatementError us ns] -- 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 :: [MatchRe] -> [MatchGroup]
matchPriorities = matchPriorities =
@ -124,28 +127,38 @@ zipperSlice f x = go
EQ -> goEq $ Unzipped bs (a : cs) as EQ -> goEq $ Unzipped bs (a : cs) as
LT -> z 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 zipperMatch (Unzipped bs cs as) x = go [] cs
where where
go _ [] = Right (Zipped bs $ cs ++ as, MatchFail) go _ [] = return $ Right (Zipped bs $ cs ++ as, MatchFail)
go prev (m : ms) = do go prev (m : ms) = do
res <- matches m x res <- matches m x
case res of case res of
MatchFail -> go (m : prev) ms Right MatchFail -> go (m : prev) ms
skipOrPass -> Right skipOrPass ->
let ps = reverse prev let ps = reverse prev
ms' = maybe ms (: ms) (matchDec m) 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 zipperMatch' z x = go z
where where
go (Zipped bs (a : as)) = do go (Zipped bs (a : as)) = do
res <- matches a x res <- matches a x
case res of case res of
MatchFail -> go (Zipped (a : bs) as) Right MatchFail -> go (Zipped (a : bs) as)
skipOrPass -> Right (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass) Right skipOrPass ->
go z' = Right (z', MatchFail) 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 :: MatchRe -> Maybe MatchRe
matchDec m = case spTimes m of matchDec m = case spTimes m of
@ -153,59 +166,76 @@ matchDec m = case spTimes m of
Just n -> Just $ m {spTimes = Just $ n - 1} Just n -> Just $ m {spTimes = Just $ n - 1}
Nothing -> Just m Nothing -> Just m
matchAll :: [MatchGroup] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe]) matchAll :: [MatchGroup] -> [TxRecord] -> CurrencyM (EitherErrs ([RawTx], [TxRecord], [MatchRe]))
matchAll = go ([], []) matchAll = go ([], [])
where where
go (matched, unused) gs rs = case (gs, rs) of go (matched, unused) gs rs = case (gs, rs) of
(_, []) -> return (matched, [], unused) (_, []) -> return $ Right (matched, [], unused)
([], _) -> return (matched, rs, unused) ([], _) -> return $ Right (matched, rs, unused)
(g : gs', _) -> do (g : gs', _) -> do
(ts, unmatched, us) <- matchGroup g rs res <- matchGroup g rs
go (ts ++ matched, us ++ unused) gs' unmatched 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 matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
(md, rest, ud) <- matchDates ds rs res <- matchDates ds rs
(mn, unmatched, un) <- matchNonDates ns rest case res of
return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un) 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) matchDates ms = go ([], [], initZipper ms)
where where
go (matched, unmatched, z) [] = go (matched, unmatched, z) [] =
Right return $
( catMaybes matched Right
, reverse unmatched ( catMaybes matched
, recoverZipper z , reverse unmatched
) , recoverZipper z
)
go (matched, unmatched, z) (r : rs) = go (matched, unmatched, z) (r : rs) =
case zipperSlice findDate r z of case zipperSlice findDate r z of
Left zipped -> go (matched, r : unmatched, zipped) rs Left zipped -> go (matched, r : unmatched, zipped) rs
Right unzipped -> do Right unzipped -> do
(z', res) <- zipperMatch unzipped r res <- zipperMatch unzipped r
let (m, u) = case res of case res of
MatchPass p -> (Just p : matched, unmatched) Right (z', res') -> do
MatchSkip -> (Nothing : matched, unmatched) let (m, u) = case res' of
MatchFail -> (matched, r : unmatched) (MatchPass p) -> (Just p : matched, unmatched)
go (m, u, z') rs 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 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) matchNonDates ms = go ([], [], initZipper ms)
where where
go (matched, unmatched, z) [] = go (matched, unmatched, z) [] =
Right return $
( catMaybes matched Right
, reverse unmatched ( catMaybes matched
, recoverZipper z , reverse unmatched
) , recoverZipper z
)
go (matched, unmatched, z) (r : rs) = do go (matched, unmatched, z) (r : rs) = do
(z', res) <- zipperMatch' z r res <- zipperMatch' z r
let (m, u) = case res of case res of
MatchPass p -> (Just p : matched, unmatched) Left es -> return $ Left es
MatchSkip -> (Nothing : matched, unmatched) Right (z', res') -> do
MatchFail -> (matched, r : unmatched) let (m, u) = case res' of
in go (m, u, resetZipper z') rs 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 :: RawTx -> EitherErr BalTx
balanceTx t@Tx {txSplits = ss} = do balanceTx t@Tx {txSplits = ss} = do

46
lib/Internal/Types.hs
View File

@ -5,6 +5,7 @@
module Internal.Types where module Internal.Types where
-- import Control.Monad.Except
import Data.Fix (Fix (..), foldFix) import Data.Fix (Fix (..), foldFix)
import Data.Functor.Foldable (embed) import Data.Functor.Foldable (embed)
import qualified Data.Functor.Foldable.TH as TH import qualified Data.Functor.Foldable.TH as TH
@ -49,7 +50,6 @@ makeHaskellTypesWith
, SingleConstructor "RepeatPat" "RepeatPat" "(./dhall/Types.dhall).RepeatPat" , SingleConstructor "RepeatPat" "RepeatPat" "(./dhall/Types.dhall).RepeatPat"
, SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type" , SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type"
, SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.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 "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type"
, SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount" , SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount"
, SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type" , SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
@ -96,7 +96,6 @@ deriveProduct
, "DateMatcher" , "DateMatcher"
, "ValMatcher" , "ValMatcher"
, "YMDMatcher" , "YMDMatcher"
, "Decimal"
, "BudgetCurrency" , "BudgetCurrency"
, "Exchange" , "Exchange"
, "EntryNumGetter" , "EntryNumGetter"
@ -180,6 +179,12 @@ deriving instance Hashable DatePat
type BudgetTransfer = type BudgetTransfer =
Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
deriving instance Hashable BudgetTransfer
deriving instance Generic BudgetTransfer
deriving instance FromDhall BudgetTransfer
data Budget = Budget data Budget = Budget
{ bgtLabel :: Text { bgtLabel :: Text
, bgtIncomes :: [Income] , bgtIncomes :: [Income]
@ -215,7 +220,7 @@ deriving instance Ord TaggedAcnt
type CurID = T.Text type CurID = T.Text
data Income = Income data Income = Income
{ incGross :: Decimal { incGross :: Double
, incCurrency :: CurID , incCurrency :: CurID
, incWhen :: DatePat , incWhen :: DatePat
, incPretax :: [SingleAllocation PretaxValue] , 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 (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) 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] , transAmounts :: [Amount w v]
, transCurrency :: c , transCurrency :: c
} }
deriving (Eq, Show, Generic, FromDhall) deriving (Eq, Show)
deriving instance
(Generic w, Generic v, Hashable a, Hashable c, Hashable w, Hashable v)
=> Hashable (Transfer a c w v)
deriving instance Hashable ShadowTransfer deriving instance Hashable ShadowTransfer
@ -298,10 +301,6 @@ deriving instance Hashable YMDMatcher
deriving instance Hashable DateMatcher deriving instance Hashable DateMatcher
deriving instance Ord Decimal
deriving instance Hashable Decimal
-- TODO this just looks silly...but not sure how to simplify it -- TODO this just looks silly...but not sure how to simplify it
instance Ord YMDMatcher where instance Ord YMDMatcher where
compare (Y y) (Y y') = compare y y' compare (Y y) (Y y') = compare y y'
@ -394,12 +393,18 @@ type AcntID = T.Text
type TagID = 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 data History
= HistTransfer !HistTransfer = HistTransfer !HistTransfer
| HistStatement !Statement | HistStatement !Statement
deriving (Eq, Hashable, Generic, FromDhall) deriving (Eq, Generic, Hashable, FromDhall)
type EntryGetter = Entry SplitAcnt (Maybe EntryNumGetter) SplitCur TagID type EntryGetter = Entry SplitAcnt (Maybe EntryNumGetter) SplitCur TagID
@ -517,6 +522,7 @@ CommitR sql=commits
CurrencyR sql=currencies CurrencyR sql=currencies
symbol T.Text symbol T.Text
fullname T.Text fullname T.Text
precision Int
deriving Show Eq deriving Show Eq
TagR sql=tags TagR sql=tags
symbol T.Text symbol T.Text
@ -579,7 +585,7 @@ instance PersistField ConfigType where
type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType) 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 type TagMap = M.Map TagID TagRId
@ -593,6 +599,8 @@ data DBState = DBState
, kmConfigDir :: !FilePath , kmConfigDir :: !FilePath
} }
type CurrencyM = Reader CurrencyMap
type MappingT m = ReaderT DBState (SqlPersistT m) type MappingT m = ReaderT DBState (SqlPersistT m)
type KeySplit = Entry AccountRId Rational CurrencyRId TagRId type KeySplit = Entry AccountRId Rational CurrencyRId TagRId
@ -746,6 +754,10 @@ type EitherErr = Either InsertError
type EitherErrs = Either [InsertError] type EitherErrs = Either [InsertError]
-- type InsertExceptT m = ExceptT [InsertError] m
-- type InsertExcept = InsertExceptT Identity
data XGregorian = XGregorian data XGregorian = XGregorian
{ xgYear :: !Int { xgYear :: !Int
, xgMonth :: !Int , xgMonth :: !Int

112
lib/Internal/Utils.hs
View File

@ -8,7 +8,6 @@ module Internal.Utils
, resolveBounds , resolveBounds
, resolveBounds_ , resolveBounds_
, leftToMaybe , leftToMaybe
, dec2Rat
, concatEithers2 , concatEithers2
, concatEithers3 , concatEithers3
, concatEither3 , concatEither3
@ -37,9 +36,12 @@ module Internal.Utils
, compileOptions , compileOptions
, dateMatches , dateMatches
, valMatches , valMatches
, roundPrecision
, roundPrecisionCur
) )
where where
import Control.Monad.Reader
import Data.Time.Format.ISO8601 import Data.Time.Format.ISO8601
import GHC.Real import GHC.Real
import Internal.Types import Internal.Types
@ -153,28 +155,34 @@ expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- matching -- matching
matches :: MatchRe -> TxRecord -> EitherErrs (MatchRes RawTx) matches :: MatchRe -> TxRecord -> CurrencyM (EitherErrs (MatchRes RawTx))
matches matches
StatementParser {spTx, spOther, spVal, spDate, spDesc} StatementParser {spTx, spOther, spVal, spDate, spDesc}
r@TxRecord {trDate, trAmount, trDesc, trOther} = do r@TxRecord {trDate, trAmount, trDesc, trOther} = do
res <- concatEither3 val other desc $ \x y z -> x && y && z let res = concatEithers3 val other desc $ \x y z -> x && y && z && date
if date && res case res of
then maybe (Right MatchSkip) (fmap MatchPass . convert) spTx Right test
else Right MatchFail | test -> maybe (return $ Right MatchSkip) convert spTx
| otherwise -> return $ Right MatchFail
Left es -> return $ Left es
where where
val = valMatches spVal trAmount val = valMatches spVal trAmount
date = maybe True (`dateMatches` trDate) spDate date = maybe True (`dateMatches` trDate) spDate
other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther
desc = maybe (return True) (matchMaybe trDesc . snd) spDesc 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 :: SplitCur -> SplitAcnt -> [EntryGetter] -> TxRecord -> CurrencyM (EitherErrs RawTx)
toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = do
concatEithers2 acRes ssRes $ \(a_, c_) ss_ -> m <- ask
let ssRes = concatEithersL $ fmap (resolveEntry m r) toSplits
return $ concatEithers2 acRes ssRes $ \(a, c) ss ->
let fromSplit = let fromSplit =
Entry Entry
{ eAcnt = a_ { eAcnt = a
, eCurrency = c_ , eCurrency = c
, eValue = Just trAmount , eValue = Just trAmount
, eComment = "" , eComment = ""
, eTags = [] -- TODO what goes here? , eTags = [] -- TODO what goes here?
@ -182,15 +190,14 @@ toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
in Tx in Tx
{ txDate = trDate { txDate = trDate
, txDescr = trDesc , txDescr = trDesc
, txSplits = fromSplit : ss_ , txSplits = fromSplit : ss
} }
where where
acRes = concatEithers2 (resolveAcnt r sa) (resolveCurrency r sc) (,) 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 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 = | otherwise =
Right $ Right $
checkMaybe (s ==) vmSign checkMaybe (s ==) vmSign
@ -205,26 +212,33 @@ valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
dateMatches :: DateMatcher -> Day -> Bool dateMatches :: DateMatcher -> Day -> Bool
dateMatches md = (EQ ==) . compareDate md 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 otherMatches dict m = case m of
Val (Field n mv) -> valMatches mv =<< (readRational =<< lookup_ MatchNumeric n) Val (Field n mv) -> valMatches mv =<< (readRational =<< lookup_ MatchNumeric n)
Desc (Field n (_, md)) -> (`matchMaybe` md) =<< lookup_ MatchText n Desc (Field n (_, md)) -> (`matchMaybe` md) =<< lookup_ MatchText n
where where
lookup_ t n = lookupErr (MatchField t) n dict lookup_ t n = lookupErr (MatchField t) n dict
resolveSplit :: TxRecord -> EntryGetter -> EitherErrs RawSplit resolveEntry :: CurrencyMap -> TxRecord -> EntryGetter -> EitherErrs RawSplit
resolveSplit r s@Entry {eAcnt, eValue, eCurrency} = resolveEntry m r s@Entry {eAcnt, eValue, eCurrency} = do
concatEithers2 acRes valRes $ (a, c, v) <- concatEithers2 acRes valRes $ \(a, c) v -> (a, c, v)
\(a_, c_) v_ -> (s {eAcnt = a_, eValue = v_, eCurrency = c_}) v' <- mapM (roundPrecisionCur c m) v
return $
s
{ eAcnt = a
, eValue = v'
, eCurrency = c
}
where where
acRes = concatEithers2 (resolveAcnt r eAcnt) (resolveCurrency r eCurrency) (,) 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 resolveValue r s = case s of
(LookupN t) -> readRational =<< lookupErr SplitValField t (trOther r) (LookupN t) -> readDouble =<< lookupErr SplitValField t (trOther r)
(ConstN c) -> Right $ dec2Rat c (ConstN c) -> Right c
AmountN -> Right $ trAmount r -- TODO don't coerce to rational in trAmount
AmountN -> Right $ fromRational $ trAmount r
resolveAcnt :: TxRecord -> SplitAcnt -> EitherErrs T.Text resolveAcnt :: TxRecord -> SplitAcnt -> EitherErrs T.Text
resolveAcnt = resolveSplitField AcntField resolveAcnt = resolveSplitField AcntField
@ -235,21 +249,21 @@ resolveCurrency = resolveSplitField CurField
resolveSplitField :: SplitIDType -> TxRecord -> SplitAcnt -> EitherErrs T.Text resolveSplitField :: SplitIDType -> TxRecord -> SplitAcnt -> EitherErrs T.Text
resolveSplitField t TxRecord {trOther = o} s = case s of resolveSplitField t TxRecord {trOther = o} s = case s of
ConstT p -> Right p ConstT p -> Right p
LookupT f -> plural $ lookup_ f o LookupT f -> lookup_ f o
MapT (Field f m) -> plural $ do MapT (Field f m) -> do
k <- lookup_ f o k <- lookup_ f o
lookup_ k m lookup_ k m
Map2T (Field (f1, f2) m) -> do Map2T (Field (f1, f2) m) -> do
(k1, k2) <- concatEither2 (lookup_ f1 o) (lookup_ f2 o) (,) (k1, k2) <- concatEithers2 (lookup_ f1 o) (lookup_ f2 o) (,)
plural $ lookup_ (k1, k2) m lookup_ (k1, k2) m
where 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) 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 lookupErr what k m = case M.lookup k m of
Just x -> Right x 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 :: MonadFail m => (T.Text, Regex) -> T.Text -> m Rational
parseRational (pat, re) s = case matchGroupsMaybe s re of 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 k <- readSign sign
return (k, w) 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 readRational s = case T.split (== '.') s of
[x] -> maybe err (return . fromInteger) $ readT x [x] -> maybe err (return . fromInteger) $ readT x
[x, y] -> case (readT x, readT y) of [x, y] -> case (readT x, readT y) of
@ -290,7 +309,7 @@ readRational s = case T.split (== '.') s of
_ -> err _ -> err
where where
readT = readMaybe . T.unpack readT = readMaybe . T.unpack
err = Left $ ConversionError s err = Left [ConversionError s]
-- TODO smells like a lens -- TODO smells like a lens
-- mapTxSplits :: (a -> b) -> Tx a -> Tx b -- 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 txt = T.pack . show
pad i c z = T.append (T.replicate (i - T.length z) c) z pad i c z = T.append (T.replicate (i - T.length z) c) z
dec2Rat :: Decimal -> Rational roundPrecision :: Natural -> Double -> Rational
dec2Rat D {sign, whole, decimal, precision} = roundPrecision n = (% p) . round . (* fromIntegral p) . toRational
k * (fromIntegral whole + (fromIntegral decimal % (10 ^ precision)))
where 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.Text
acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs) acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
@ -640,10 +670,10 @@ compileRegex groups pat = case res of
(blankExecOpt {captureGroups = groups}) (blankExecOpt {captureGroups = groups})
pat pat
matchMaybe :: T.Text -> Regex -> EitherErr Bool matchMaybe :: T.Text -> Regex -> EitherErrs Bool
matchMaybe q re = case execute re q of matchMaybe q re = case execute re q of
Right res -> Right $ isJust res 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 :: T.Text -> Regex -> [T.Text]
matchGroupsMaybe q re = case regexec re q of matchGroupsMaybe q re = case regexec re q of