ENH use decimals to round
This commit is contained in:
parent
c886c53f17
commit
46decdc4de
|
@ -75,7 +75,8 @@ library
|
|||
ViewPatterns
|
||||
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2
|
||||
build-depends:
|
||||
base >=4.12 && <10
|
||||
Decimal >=0.5.2
|
||||
, base >=4.12 && <10
|
||||
, cassava
|
||||
, conduit >=1.3.4.2
|
||||
, containers >=0.6.4.1
|
||||
|
@ -144,7 +145,8 @@ executable pwncash
|
|||
ViewPatterns
|
||||
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2 -threaded
|
||||
build-depends:
|
||||
base >=4.12 && <10
|
||||
Decimal >=0.5.2
|
||||
, base >=4.12 && <10
|
||||
, budget
|
||||
, cassava
|
||||
, conduit >=1.3.4.2
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
module Internal.Budget (readBudget) where
|
||||
|
||||
import Control.Monad.Except
|
||||
import Data.Decimal hiding (allocate)
|
||||
import Data.Foldable
|
||||
import Internal.Database
|
||||
import Internal.Types.Main
|
||||
|
@ -105,7 +106,7 @@ readIncome
|
|||
(combineError incRes nonIncRes (,))
|
||||
(combineError cpRes dayRes (,))
|
||||
$ \_ (cp, days) -> do
|
||||
let gross = roundPrecisionCur cp incGross
|
||||
let gross = realFracToDecimal (cpPrec cp) incGross
|
||||
foldDays (allocate cp gross) start days
|
||||
where
|
||||
incRes = isIncomeAcnt srcAcnt
|
||||
|
@ -156,7 +157,7 @@ readIncome
|
|||
let primary =
|
||||
EntrySet
|
||||
{ esTotalValue = gross
|
||||
, esCurrency = cp
|
||||
, esCurrency = cpID cp
|
||||
, esFrom = HalfEntrySet {hesPrimary = src, hesOther = []}
|
||||
, esTo = HalfEntrySet {hesPrimary = dest, hesOther = allos}
|
||||
}
|
||||
|
@ -178,18 +179,16 @@ periodScaler
|
|||
-> InsertExcept PeriodScaler
|
||||
periodScaler pt prev cur = return scale
|
||||
where
|
||||
n = fromIntegral $ workingDays wds prev cur
|
||||
n = workingDays wds prev cur
|
||||
wds = case pt of
|
||||
Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays
|
||||
Daily ds -> ds
|
||||
scale precision x = case pt of
|
||||
scale prec x = case pt of
|
||||
Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
|
||||
fromRational (rnd $ x / fromIntegral hpAnnualHours)
|
||||
realFracToDecimal prec (x / fromIntegral hpAnnualHours)
|
||||
* fromIntegral hpDailyHours
|
||||
* n
|
||||
Daily _ -> x * n / 365.25
|
||||
where
|
||||
rnd = roundPrecision precision
|
||||
* fromIntegral n
|
||||
Daily _ -> realFracToDecimal prec (x * fromIntegral n / 365.25)
|
||||
|
||||
-- ASSUME start < end
|
||||
workingDays :: [Weekday] -> Day -> Day -> Natural
|
||||
|
@ -267,49 +266,44 @@ selectAllos day Allocation {alloAmts, alloTo} =
|
|||
, faDesc = amtDesc
|
||||
}
|
||||
|
||||
allo2Trans :: FlatAllocation Rational -> Entry AcntID (LinkDeferred Rational) TagID
|
||||
allo2Trans :: FlatAllocation Decimal -> Entry AcntID LinkDeferred TagID
|
||||
allo2Trans FlatAllocation {faValue, faTo = TaggedAcnt {taAcnt, taTags}, faDesc} =
|
||||
Entry
|
||||
{ eValue = LinkDeferred (EntryValue TFixed faValue)
|
||||
{ eValue = LinkDeferred (EntryFixed faValue)
|
||||
, eComment = faDesc
|
||||
, eAcnt = taAcnt
|
||||
, eTags = taTags
|
||||
}
|
||||
|
||||
allocatePre
|
||||
:: Natural
|
||||
-> Rational
|
||||
:: Precision
|
||||
-> Decimal
|
||||
-> [FlatAllocation PretaxValue]
|
||||
-> (M.Map T.Text Rational, [FlatAllocation Rational])
|
||||
-> (M.Map T.Text Decimal, [FlatAllocation Decimal])
|
||||
allocatePre precision gross = L.mapAccumR go M.empty
|
||||
where
|
||||
go m f@FlatAllocation {faValue} =
|
||||
let c = preCategory faValue
|
||||
p = preValue faValue
|
||||
v =
|
||||
if prePercent faValue
|
||||
then (roundPrecision 3 p / 100) * gross
|
||||
else roundPrecision precision p
|
||||
in (mapAdd_ c v m, f {faValue = v})
|
||||
go m f@FlatAllocation {faValue = PretaxValue {preCategory, preValue, prePercent}} =
|
||||
let v =
|
||||
if prePercent
|
||||
then gross *. (preValue / 100)
|
||||
else realFracToDecimal precision preValue
|
||||
in (mapAdd_ preCategory v m, f {faValue = v})
|
||||
|
||||
allocateTax
|
||||
:: Natural
|
||||
-> Rational
|
||||
-> M.Map T.Text Rational
|
||||
:: Precision
|
||||
-> Decimal
|
||||
-> M.Map T.Text Decimal
|
||||
-> PeriodScaler
|
||||
-> [FlatAllocation TaxValue]
|
||||
-> [FlatAllocation Rational]
|
||||
-> [FlatAllocation Decimal]
|
||||
allocateTax precision gross preDeds f = fmap (fmap go)
|
||||
where
|
||||
go TaxValue {tvCategories, tvMethod} =
|
||||
let agi = gross - sum (mapMaybe (`M.lookup` preDeds) tvCategories)
|
||||
in case tvMethod of
|
||||
TMPercent p ->
|
||||
roundPrecision precision $
|
||||
fromRational $
|
||||
roundPrecision 3 p / 100 * agi
|
||||
TMPercent p -> agi *. p / 100
|
||||
TMBracket TaxProgression {tpDeductible, tpBrackets} ->
|
||||
let taxDed = roundPrecision precision $ f precision tpDeductible
|
||||
let taxDed = f precision tpDeductible
|
||||
in foldBracket f precision (agi - taxDed) tpBrackets
|
||||
|
||||
-- | Compute effective tax percentage of a bracket
|
||||
|
@ -323,26 +317,25 @@ allocateTax precision gross preDeds f = fmap (fmap go)
|
|||
--
|
||||
-- In reality, this can all be done with one loop, but it isn't clear these
|
||||
-- three steps are implemented from this alone.
|
||||
foldBracket :: PeriodScaler -> Natural -> Rational -> [TaxBracket] -> Rational
|
||||
foldBracket f precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
|
||||
foldBracket :: PeriodScaler -> Precision -> Decimal -> [TaxBracket] -> Decimal
|
||||
foldBracket f prec agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
|
||||
where
|
||||
go TaxBracket {tbLowerLimit, tbPercent} a@(acc, remain) =
|
||||
let l = roundPrecision precision $ f precision tbLowerLimit
|
||||
p = roundPrecision 3 tbPercent / 100
|
||||
in if remain >= l then (acc + p * (remain - l), l) else a
|
||||
let l = f prec tbLowerLimit
|
||||
in if remain >= l
|
||||
then (acc + (remain - l) *. (tbPercent / 100), l)
|
||||
else a
|
||||
|
||||
allocatePost
|
||||
:: Natural
|
||||
-> Rational
|
||||
:: Precision
|
||||
-> Decimal
|
||||
-> [FlatAllocation PosttaxValue]
|
||||
-> [FlatAllocation Rational]
|
||||
allocatePost precision aftertax = fmap (fmap go)
|
||||
-> [FlatAllocation Decimal]
|
||||
allocatePost prec aftertax = fmap (fmap go)
|
||||
where
|
||||
go PosttaxValue {postValue, postPercent} =
|
||||
let v = postValue
|
||||
in if postPercent
|
||||
then aftertax * roundPrecision 3 v / 100
|
||||
else roundPrecision precision v
|
||||
go PosttaxValue {postValue, postPercent}
|
||||
| postPercent = aftertax *. (postValue / 100)
|
||||
| otherwise = realFracToDecimal prec postValue
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- shadow transfers
|
||||
|
@ -365,8 +358,9 @@ fromShadow
|
|||
-> ShadowTransfer
|
||||
-> m (Maybe ShadowEntrySet)
|
||||
fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} = do
|
||||
cp <- lookupCurrency stCurrency
|
||||
res <- liftExcept $ shadowMatches stMatch tx
|
||||
es <- entryPair stFrom stTo stCurrency stDesc stRatio ()
|
||||
let es = entryPair stFrom stTo (cpID cp) stDesc stRatio ()
|
||||
return $ if not res then Nothing else Just es
|
||||
|
||||
shadowMatches :: TransferMatcher -> Tx CommitR -> InsertExcept Bool
|
||||
|
@ -374,7 +368,7 @@ shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} Tx {txPrimary, txDat
|
|||
-- NOTE this will only match against the primary entry set since those
|
||||
-- are what are guaranteed to exist from a transfer
|
||||
valRes <- case txPrimary of
|
||||
Left es -> valMatches tmVal $ esTotalValue es
|
||||
Left es -> valMatches tmVal $ toRational $ esTotalValue es
|
||||
Right _ -> return True
|
||||
return $
|
||||
memberMaybe fa tmFrom
|
||||
|
@ -404,7 +398,7 @@ type IntAllocations =
|
|||
|
||||
type DaySpanAllocation = Allocation DaySpan
|
||||
|
||||
type PeriodScaler = Natural -> Double -> Double
|
||||
type PeriodScaler = Precision -> Double -> Decimal
|
||||
|
||||
data FlatAllocation v = FlatAllocation
|
||||
{ faValue :: !v
|
||||
|
|
|
@ -22,6 +22,7 @@ where
|
|||
import Conduit
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Logger
|
||||
import Data.Decimal
|
||||
import Data.Hashable
|
||||
import Database.Esqueleto.Experimental ((:&) (..), (==.), (^.))
|
||||
import qualified Database.Esqueleto.Experimental as E
|
||||
|
@ -461,6 +462,7 @@ readUpdates hashes = do
|
|||
return (makeRE . snd <$> toRead, toUpdate')
|
||||
where
|
||||
makeUES ((_, day, name, pri, (curID, prec)), es) = do
|
||||
let prec' = fromIntegral $ E.unValue prec
|
||||
let res =
|
||||
bimap NE.nonEmpty NE.nonEmpty $
|
||||
NE.partition ((< 0) . entryRIndex . snd) $
|
||||
|
@ -469,22 +471,22 @@ readUpdates hashes = do
|
|||
case res of
|
||||
(Just froms, Just tos) -> do
|
||||
let tot = sum $ fmap (entryRValue . snd) froms
|
||||
(from0, fromRO, fromUnkVec) <- splitFrom $ NE.reverse froms
|
||||
(from0', fromUnk, to0, toRO, toUnk) <- splitTo from0 fromUnkVec tos
|
||||
(from0, fromRO, fromUnkVec) <- splitFrom prec' $ NE.reverse froms
|
||||
(from0', fromUnk, to0, toRO, toUnk) <- splitTo prec' from0 fromUnkVec tos
|
||||
-- TODO WAP (wet ass programming)
|
||||
return $ case from0' of
|
||||
Left x ->
|
||||
Left $
|
||||
UpdateEntrySet
|
||||
{ utDate = E.unValue day
|
||||
, utCurrency = (E.unValue curID, fromIntegral $ E.unValue prec)
|
||||
, utCurrency = E.unValue curID
|
||||
, utFrom0 = x
|
||||
, utTo0 = to0
|
||||
, utFromRO = fromRO
|
||||
, utToRO = toRO
|
||||
, utFromUnk = fromUnk
|
||||
, utToUnk = toUnk
|
||||
, utTotalValue = tot
|
||||
, utTotalValue = realFracToDecimal prec' tot
|
||||
, utBudget = E.unValue name
|
||||
, utPriority = E.unValue pri
|
||||
}
|
||||
|
@ -492,7 +494,7 @@ readUpdates hashes = do
|
|||
Right $
|
||||
UpdateEntrySet
|
||||
{ utDate = E.unValue day
|
||||
, utCurrency = (E.unValue curID, fromIntegral $ E.unValue prec)
|
||||
, utCurrency = E.unValue curID
|
||||
, utFrom0 = x
|
||||
, utTo0 = to0
|
||||
, utFromRO = fromRO
|
||||
|
@ -504,32 +506,34 @@ readUpdates hashes = do
|
|||
, utPriority = E.unValue pri
|
||||
}
|
||||
_ -> throwError undefined
|
||||
makeRE ((_, day, name, pri, (curID, _)), entry) =
|
||||
makeRE ((_, day, name, pri, (curID, prec)), entry) =
|
||||
let e = entityVal entry
|
||||
in ReadEntry
|
||||
{ reDate = E.unValue day
|
||||
, reCurrency = E.unValue curID
|
||||
, reAcnt = entryRAccount e
|
||||
, reValue = entryRValue e
|
||||
, reValue = realFracToDecimal (fromIntegral $ E.unValue prec) (entryRValue e)
|
||||
, reBudget = E.unValue name
|
||||
, rePriority = E.unValue pri
|
||||
}
|
||||
|
||||
splitFrom
|
||||
:: NonEmpty (EntryRId, EntryR)
|
||||
:: Precision
|
||||
-> NonEmpty (EntryRId, EntryR)
|
||||
-> InsertExcept (Either UEBlank (Either UE_RO UEUnk), [UE_RO], [UEUnk])
|
||||
splitFrom (f0 :| fs) = do
|
||||
splitFrom prec (f0 :| fs) = do
|
||||
-- ASSUME entries are sorted by index
|
||||
-- TODO combine errors here
|
||||
let f0Res = readDeferredValue f0
|
||||
let fsRes = mapErrors splitDeferredValue fs
|
||||
let f0Res = readDeferredValue prec f0
|
||||
let fsRes = mapErrors (splitDeferredValue prec) fs
|
||||
combineErrorM f0Res fsRes $ \f0' fs' -> do
|
||||
let (ro, unk) = partitionEithers fs'
|
||||
-- let idxVec = V.fromList $ fmap (either (const Nothing) Just) fs'
|
||||
return (f0', ro, unk)
|
||||
|
||||
splitTo
|
||||
:: Either UEBlank (Either UE_RO UEUnk)
|
||||
:: Precision
|
||||
-> Either UEBlank (Either UE_RO UEUnk)
|
||||
-> [UEUnk]
|
||||
-> NonEmpty (EntryRId, EntryR)
|
||||
-> InsertExcept
|
||||
|
@ -539,7 +543,7 @@ splitTo
|
|||
, [UE_RO]
|
||||
, [UEUnk]
|
||||
)
|
||||
splitTo from0 fromUnk (t0 :| ts) = do
|
||||
splitTo prec from0 fromUnk (t0 :| ts) = do
|
||||
-- How to split the credit side of the database transaction in 1024 easy
|
||||
-- steps:
|
||||
--
|
||||
|
@ -547,7 +551,7 @@ splitTo from0 fromUnk (t0 :| ts) = do
|
|||
let (unlinked, linked) = partitionEithers $ fmap splitLinked ts
|
||||
|
||||
-- 2. For unlinked entries, split into read-only and unknown entries
|
||||
let unlinkedRes = partitionEithers <$> mapErrors splitDeferredValue unlinked
|
||||
let unlinkedRes = partitionEithers <$> mapErrors (splitDeferredValue prec) unlinked
|
||||
|
||||
-- 3. For linked entries, split into those that link to the primary debit
|
||||
-- entry and not
|
||||
|
@ -557,7 +561,7 @@ splitTo from0 fromUnk (t0 :| ts) = do
|
|||
-- into those that link to an unknown debit entry or not. Those that
|
||||
-- are not will be read-only and those that are will be collected with
|
||||
-- their linked debit entry
|
||||
let linkedRes = zipPaired fromUnk linkedN
|
||||
let linkedRes = zipPaired prec fromUnk linkedN
|
||||
|
||||
-- 5. For entries linked to the primary debit entry, turn them into linked
|
||||
-- entries (lazily only used when needed later)
|
||||
|
@ -571,7 +575,7 @@ splitTo from0 fromUnk (t0 :| ts) = do
|
|||
\from0Links (fromUnk', toROLinkedN) (toROUnlinked, toUnk) -> do
|
||||
let (from0', toROLinked0) = case from0 of
|
||||
Left blnk -> (Left (blnk, from0Links), [])
|
||||
Right (Left ro) -> (Right $ Left ro, makeRoUE . snd . snd <$> linked0)
|
||||
Right (Left ro) -> (Right $ Left ro, makeRoUE prec . snd . snd <$> linked0)
|
||||
Right (Right unk) -> (Right $ Right (unk, from0Links), [])
|
||||
return (from0', fromUnk', primary, toROLinked0 ++ toROLinkedN ++ toROUnlinked, toUnk)
|
||||
where
|
||||
|
@ -583,10 +587,11 @@ splitTo from0 fromUnk (t0 :| ts) = do
|
|||
-- sorted according to index and 'fst' respectively. NOTE the output will NOT be
|
||||
-- sorted.
|
||||
zipPaired
|
||||
:: [UEUnk]
|
||||
:: Precision
|
||||
-> [UEUnk]
|
||||
-> [(Int, NonEmpty (EntryRId, EntryR))]
|
||||
-> InsertExcept ([(UEUnk, [UELink])], [UE_RO])
|
||||
zipPaired = go ([], [])
|
||||
zipPaired prec = go ([], [])
|
||||
where
|
||||
nolinks = ((,[]) <$>)
|
||||
go acc fs [] = return $ first (nolinks fs ++) acc
|
||||
|
@ -599,7 +604,7 @@ zipPaired = go ([], [])
|
|||
| otherwise -> (Nothing, rest)
|
||||
_ -> (Nothing, rest)
|
||||
let acc' = (nolinks lesser ++ facc, tacc)
|
||||
let ros = NE.toList $ makeRoUE . snd <$> tls
|
||||
let ros = NE.toList $ makeRoUE prec . snd <$> tls
|
||||
let f = maybe (second (++ ros)) (\u -> first (u :)) nextLink
|
||||
go (f acc') fs' ts
|
||||
|
||||
|
@ -619,30 +624,30 @@ makeLinkUnk (k, e) =
|
|||
maybe
|
||||
(throwError $ InsertException undefined)
|
||||
(return . makeUE k e . LinkScale)
|
||||
$ entryRCachedValue e
|
||||
$ fromRational <$> entryRCachedValue e
|
||||
|
||||
splitDeferredValue :: (EntryRId, EntryR) -> InsertExcept (Either UE_RO UEUnk)
|
||||
splitDeferredValue p = do
|
||||
res <- readDeferredValue p
|
||||
splitDeferredValue :: Precision -> (EntryRId, EntryR) -> InsertExcept (Either UE_RO UEUnk)
|
||||
splitDeferredValue prec p = do
|
||||
res <- readDeferredValue prec p
|
||||
case res of
|
||||
Left _ -> throwError $ InsertException undefined
|
||||
Right x -> return x
|
||||
|
||||
readDeferredValue :: (EntryRId, EntryR) -> InsertExcept (Either UEBlank (Either UE_RO UEUnk))
|
||||
readDeferredValue (k, e) = case (entryRCachedValue e, entryRCachedType e) of
|
||||
(Nothing, Just TFixed) -> return $ Right $ Left $ makeRoUE e
|
||||
(Just v, Just TBalance) -> go EVBalance v
|
||||
(Just v, Just TPercent) -> go EVPercent v
|
||||
readDeferredValue :: Precision -> (EntryRId, EntryR) -> InsertExcept (Either UEBlank (Either UE_RO UEUnk))
|
||||
readDeferredValue prec (k, e) = case (entryRCachedValue e, entryRCachedType e) of
|
||||
(Nothing, Just TFixed) -> return $ Right $ Left $ makeRoUE prec e
|
||||
(Just v, Just TBalance) -> go $ fmap EVBalance $ makeUE k e $ realFracToDecimal prec v
|
||||
(Just v, Just TPercent) -> go $ fmap EVPercent $ makeUE k e $ fromRational v
|
||||
(Nothing, Nothing) -> return $ Left $ makeUnkUE k e
|
||||
_ -> throwError $ InsertException undefined
|
||||
where
|
||||
go c = return . Right . Right . fmap c . makeUE k e
|
||||
go = return . Right . Right
|
||||
|
||||
makeUE :: i -> EntryR -> v -> UpdateEntry i v
|
||||
makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e)
|
||||
|
||||
makeRoUE :: EntryR -> UpdateEntry () StaticValue
|
||||
makeRoUE e = makeUE () e $ StaticValue (entryRValue e)
|
||||
makeRoUE :: Precision -> EntryR -> UpdateEntry () StaticValue
|
||||
makeRoUE prec e = makeUE () e $ StaticValue (realFracToDecimal prec $ entryRValue e)
|
||||
|
||||
makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
|
||||
makeUnkUE k e = makeUE k e ()
|
||||
|
@ -689,15 +694,17 @@ insertEntry
|
|||
, ieDeferred
|
||||
} =
|
||||
do
|
||||
ek <- insert $ EntryR k eAcnt eComment eValue i cval ctype deflink
|
||||
ek <- insert $ EntryR k eAcnt eComment (toRational eValue) i cval ctype deflink
|
||||
mapM_ (insert_ . TagRelationR ek) eTags
|
||||
return ek
|
||||
where
|
||||
(cval, ctype, deflink) = case ieDeferred of
|
||||
(Just (EntryLinked index scale)) -> (Just scale, Nothing, Just $ fromIntegral index)
|
||||
(Just (EntryBalance target)) -> (Just target, Just TBalance, Nothing)
|
||||
(Just (EntryPercent target)) -> (Just target, Just TPercent, Nothing)
|
||||
(Just (DBEntryLinked x s)) -> (Just (toRational s), Nothing, Just $ fromIntegral x)
|
||||
(Just (DBEntryBalance b)) -> (Just (toRational b), Just TBalance, Nothing)
|
||||
(Just (DBEntryPercent p)) -> (Just (toRational p), Just TPercent, Nothing)
|
||||
Nothing -> (Nothing, Just TFixed, Nothing)
|
||||
|
||||
updateTx :: MonadSqlQuery m => UEBalanced -> m ()
|
||||
updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue ueValue]
|
||||
updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. v]
|
||||
where
|
||||
v = toRational $ unStaticValue ueValue
|
||||
|
|
|
@ -7,6 +7,7 @@ where
|
|||
|
||||
import Control.Monad.Except
|
||||
import Data.Csv
|
||||
import Data.Decimal
|
||||
import Data.Foldable
|
||||
import GHC.Real
|
||||
import Internal.Database
|
||||
|
@ -93,7 +94,7 @@ parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFm
|
|||
if d == ""
|
||||
then return Nothing
|
||||
else do
|
||||
a <- parseRational toAmountFmt =<< r .: T.encodeUtf8 toAmount
|
||||
a <- parseDecimal toAmountFmt =<< r .: T.encodeUtf8 toAmount
|
||||
e <- r .: T.encodeUtf8 toDesc
|
||||
os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther
|
||||
d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
|
||||
|
@ -276,7 +277,7 @@ matches
|
|||
then maybe (return MatchSkip) convert spTx
|
||||
else return MatchFail
|
||||
where
|
||||
val = valMatches spVal trAmount
|
||||
val = valMatches spVal $ toRational 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
|
||||
|
@ -301,8 +302,8 @@ toTx
|
|||
, txPrimary =
|
||||
Left $
|
||||
EntrySet
|
||||
{ esTotalValue = roundPrecisionCur cur $ tgScale * fromRational trAmount
|
||||
, esCurrency = cur
|
||||
{ esTotalValue = roundTo (cpPrec cur) trAmount *. tgScale
|
||||
, esCurrency = cpID cur
|
||||
, esFrom = f
|
||||
, esTo = t
|
||||
}
|
||||
|
@ -314,8 +315,9 @@ toTx
|
|||
curRes = do
|
||||
m <- askDBState kmCurrency
|
||||
cur <- liftInner $ resolveCurrency m r tgCurrency
|
||||
let fromRes = liftInner $ resolveHalfEntry resolveFromValue cur r () tgFrom
|
||||
let toRes = liftInner $ resolveHalfEntry resolveToValue cur r () tgTo
|
||||
let prec = cpPrec cur
|
||||
let fromRes = liftInner $ resolveHalfEntry resolveFromValue prec r () tgFrom
|
||||
let toRes = liftInner $ resolveHalfEntry resolveToValue prec r () tgTo
|
||||
combineError fromRes toRes (cur,,)
|
||||
subRes = mapErrors (resolveSubGetter r) tgOtherEntries
|
||||
|
||||
|
@ -327,27 +329,27 @@ resolveSubGetter
|
|||
resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
|
||||
m <- askDBState kmCurrency
|
||||
cur <- liftInner $ resolveCurrency m r tsgCurrency
|
||||
let toRes = resolveHalfEntry resolveToValue cur r () tsgTo
|
||||
let valRes = liftInner $ fmap (roundPrecisionCur cur) <$> resolveValue r tsgValue
|
||||
let prec = cpPrec cur
|
||||
let toRes = resolveHalfEntry resolveToValue prec r () tsgTo
|
||||
let valRes = liftInner $ resolveValue prec r tsgValue
|
||||
liftInner $ combineErrorM toRes valRes $ \t v -> do
|
||||
f <- resolveHalfEntry resolveFromValue cur r v tsgFrom
|
||||
f <- resolveHalfEntry resolveFromValue prec r v tsgFrom
|
||||
return $
|
||||
EntrySet
|
||||
{ esTotalValue = ()
|
||||
, esCurrency = cur
|
||||
, esCurrency = cpID cur
|
||||
, esFrom = f
|
||||
, esTo = t
|
||||
}
|
||||
|
||||
resolveHalfEntry
|
||||
:: Traversable f
|
||||
=> (TxRecord -> n -> InsertExcept (f Double))
|
||||
-> CurrencyPrec
|
||||
:: (Precision -> TxRecord -> n -> InsertExcept v')
|
||||
-> Precision
|
||||
-> TxRecord
|
||||
-> v
|
||||
-> TxHalfGetter (EntryGetter n)
|
||||
-> InsertExcept (HalfEntrySet v (f Rational))
|
||||
resolveHalfEntry f cur r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
|
||||
-> InsertExcept (HalfEntrySet v v')
|
||||
resolveHalfEntry f prec r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
|
||||
combineError acntRes esRes $ \a es ->
|
||||
HalfEntrySet
|
||||
{ hesPrimary =
|
||||
|
@ -361,7 +363,7 @@ resolveHalfEntry f cur r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntrie
|
|||
}
|
||||
where
|
||||
acntRes = resolveAcnt r thgAcnt
|
||||
esRes = mapErrors (resolveEntry f cur r) thgEntries
|
||||
esRes = mapErrors (resolveEntry f prec r) thgEntries
|
||||
|
||||
otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> InsertExcept Bool
|
||||
otherMatches dict m = case m of
|
||||
|
@ -371,33 +373,33 @@ otherMatches dict m = case m of
|
|||
lookup_ t n = lookupErr (MatchField t) n dict
|
||||
|
||||
resolveEntry
|
||||
:: Traversable f
|
||||
=> (TxRecord -> n -> InsertExcept (f Double))
|
||||
-> CurrencyPrec
|
||||
:: (Precision -> TxRecord -> n -> InsertExcept v)
|
||||
-> Precision
|
||||
-> TxRecord
|
||||
-> EntryGetter n
|
||||
-> InsertExcept (Entry AcntID (f Rational) TagID)
|
||||
resolveEntry f cur r s@Entry {eAcnt, eValue} = do
|
||||
combineError acntRes valRes $ \a v ->
|
||||
s {eAcnt = a, eValue = roundPrecisionCur cur <$> v}
|
||||
-> InsertExcept (Entry AcntID v TagID)
|
||||
resolveEntry f prec r s@Entry {eAcnt, eValue} =
|
||||
combineError acntRes valRes $ \a v -> s {eAcnt = a, eValue = v}
|
||||
where
|
||||
acntRes = resolveAcnt r eAcnt
|
||||
valRes = f r eValue
|
||||
valRes = f prec r eValue
|
||||
|
||||
resolveFromValue :: TxRecord -> EntryNumGetter -> InsertExcept (EntryValue Double)
|
||||
resolveFromValue :: Precision -> TxRecord -> EntryNumGetter -> InsertExcept EntryValue
|
||||
resolveFromValue = resolveValue
|
||||
|
||||
resolveToValue :: TxRecord -> LinkedEntryNumGetter -> InsertExcept (LinkDeferred Double)
|
||||
resolveToValue _ (Linked l) = return $ LinkIndex l
|
||||
resolveToValue r (Getter g) = LinkDeferred <$> resolveValue r g
|
||||
resolveToValue :: Precision -> TxRecord -> LinkedEntryNumGetter -> InsertExcept LinkDeferred
|
||||
resolveToValue _ _ (Linked l) = return $ LinkIndex l
|
||||
resolveToValue prec r (Getter g) = LinkDeferred <$> resolveValue prec r g
|
||||
|
||||
resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (EntryValue Double)
|
||||
resolveValue TxRecord {trOther, trAmount} s = case s of
|
||||
(LookupN t) -> EntryValue TFixed <$> (readDouble =<< lookupErr EntryValField t trOther)
|
||||
(ConstN c) -> return $ EntryValue TFixed c
|
||||
AmountN m -> return $ EntryValue TFixed $ m * fromRational trAmount
|
||||
BalanceN x -> return $ EntryValue TBalance x
|
||||
PercentN x -> return $ EntryValue TPercent x
|
||||
resolveValue :: Precision -> TxRecord -> EntryNumGetter -> InsertExcept EntryValue
|
||||
resolveValue prec TxRecord {trOther, trAmount} s = case s of
|
||||
(LookupN t) -> EntryFixed . go <$> (readDouble =<< lookupErr EntryValField t trOther)
|
||||
(ConstN c) -> return $ EntryFixed $ go c
|
||||
AmountN m -> return $ EntryFixed $ trAmount *. m
|
||||
BalanceN x -> return $ EntryBalance $ go x
|
||||
PercentN x -> return $ EntryPercent x
|
||||
where
|
||||
go = realFracToDecimal prec
|
||||
|
||||
resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text
|
||||
resolveAcnt = resolveEntryField AcntField
|
||||
|
@ -479,14 +481,41 @@ matchGroupsMaybe q re = case regexec re q of
|
|||
-- this should never fail as regexec always returns Right
|
||||
Left _ -> []
|
||||
|
||||
parseRational :: MonadFail m => (T.Text, Regex) -> T.Text -> m Rational
|
||||
parseRational (pat, re) s = case matchGroupsMaybe s re of
|
||||
[sign, x, ""] -> uncurry (*) <$> readWhole sign x
|
||||
-- parseRational :: MonadFail m => (T.Text, Regex) -> T.Text -> m Rational
|
||||
-- parseRational (pat, re) s = case matchGroupsMaybe s re of
|
||||
-- [sign, x, ""] -> uncurry (*) <$> readWhole sign x
|
||||
-- [sign, x, y] -> do
|
||||
-- d <- readT "decimal" y
|
||||
-- let p = 10 ^ T.length y
|
||||
-- (k, w) <- readWhole sign x
|
||||
-- return $ k * (w + d % p)
|
||||
-- _ -> msg "malformed decimal"
|
||||
-- where
|
||||
-- readT what t = case readMaybe $ T.unpack t of
|
||||
-- Just d -> return $ fromInteger d
|
||||
-- _ -> msg $ T.unwords ["could not parse", what, singleQuote t]
|
||||
-- msg :: MonadFail m => T.Text -> m a
|
||||
-- msg m =
|
||||
-- fail $
|
||||
-- T.unpack $
|
||||
-- T.unwords [m, "-", keyVals [("pattern", pat), ("query", s)]]
|
||||
-- readSign x
|
||||
-- | x == "-" = return (-1)
|
||||
-- | x == "+" || x == "" = return 1
|
||||
-- | otherwise = msg $ T.append "invalid sign: " x
|
||||
-- readWhole sign x = do
|
||||
-- w <- readT "whole number" x
|
||||
-- k <- readSign sign
|
||||
-- return (k, w)
|
||||
|
||||
parseDecimal :: MonadFail m => (T.Text, Regex) -> T.Text -> m Decimal
|
||||
parseDecimal (pat, re) s = case matchGroupsMaybe s re of
|
||||
[sign, x, ""] -> Decimal 0 . uncurry (*) <$> readWhole sign x
|
||||
[sign, x, y] -> do
|
||||
d <- readT "decimal" y
|
||||
let p = 10 ^ T.length y
|
||||
let p = T.length y
|
||||
(k, w) <- readWhole sign x
|
||||
return $ k * (w + d % p)
|
||||
return $ Decimal (fromIntegral p) (k * (w * (10 ^ p) + d))
|
||||
_ -> msg "malformed decimal"
|
||||
where
|
||||
readT what t = case readMaybe $ T.unpack t of
|
||||
|
|
|
@ -12,6 +12,7 @@ module Internal.Types.Main
|
|||
where
|
||||
|
||||
import Control.Monad.Except
|
||||
import Data.Decimal
|
||||
import Database.Persist.Sql hiding (Desc, In, Statement)
|
||||
import Dhall hiding (embed, maybe)
|
||||
import Internal.Types.Database
|
||||
|
@ -36,7 +37,7 @@ data ConfigHashes = ConfigHashes
|
|||
|
||||
type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
|
||||
|
||||
data CurrencyPrec = CurrencyPrec {cpID :: !CurrencyRId, cpPrec :: !Natural}
|
||||
data CurrencyPrec = CurrencyPrec {cpID :: !CurrencyRId, cpPrec :: !Precision}
|
||||
deriving (Show)
|
||||
|
||||
type CurrencyMap = M.Map CurID CurrencyPrec
|
||||
|
@ -64,17 +65,15 @@ data DBUpdates = DBUpdates
|
|||
|
||||
type CurrencyM = Reader CurrencyMap
|
||||
|
||||
-- type DeferredKeyEntry = Entry AccountRId (Deferred Rational) CurrencyRId TagRId
|
||||
|
||||
data DBDeferred
|
||||
= EntryLinked Natural Rational
|
||||
| EntryBalance Rational
|
||||
| EntryPercent Rational
|
||||
= DBEntryLinked Natural Double
|
||||
| DBEntryBalance Decimal
|
||||
| DBEntryPercent Double
|
||||
|
||||
data ReadEntry = ReadEntry
|
||||
{ reCurrency :: !CurrencyRId
|
||||
, reAcnt :: !AccountRId
|
||||
, reValue :: !Rational
|
||||
, reValue :: !Decimal
|
||||
, reDate :: !Day
|
||||
, rePriority :: !Int
|
||||
, reBudget :: !T.Text
|
||||
|
@ -93,16 +92,15 @@ data CurrencyRound = CurrencyRound CurID Natural
|
|||
|
||||
deriving instance Functor (UpdateEntry i)
|
||||
|
||||
newtype LinkScale = LinkScale {unLinkScale :: Rational}
|
||||
type Precision = Word8
|
||||
|
||||
newtype LinkScale = LinkScale {unLinkScale :: Decimal}
|
||||
deriving newtype (Num, Show)
|
||||
|
||||
-- newtype BalanceTarget = BalanceTarget {unBalanceTarget :: Rational}
|
||||
-- deriving newtype (Num)
|
||||
|
||||
newtype StaticValue = StaticValue {unStaticValue :: Rational}
|
||||
newtype StaticValue = StaticValue {unStaticValue :: Decimal}
|
||||
deriving newtype (Num, Show)
|
||||
|
||||
data EntryValueUnk = EVBalance Rational | EVPercent Rational deriving (Show)
|
||||
data EntryValueUnk = EVBalance Decimal | EVPercent Double deriving (Show)
|
||||
|
||||
type UEUnk = UpdateEntry EntryRId EntryValueUnk
|
||||
|
||||
|
@ -121,7 +119,7 @@ data UpdateEntrySet f t = UpdateEntrySet
|
|||
, utToUnk :: ![UEUnk]
|
||||
, utFromRO :: ![UE_RO]
|
||||
, utToRO :: ![UE_RO]
|
||||
, utCurrency :: !(CurrencyRId, Natural)
|
||||
, utCurrency :: !CurrencyRId
|
||||
, utDate :: !Day
|
||||
, utTotalValue :: !t
|
||||
, utBudget :: !T.Text
|
||||
|
@ -129,7 +127,7 @@ data UpdateEntrySet f t = UpdateEntrySet
|
|||
}
|
||||
deriving (Show)
|
||||
|
||||
type TotalUpdateEntrySet = UpdateEntrySet (UEBlank, [UELink]) Rational
|
||||
type TotalUpdateEntrySet = UpdateEntrySet (UEBlank, [UELink]) Decimal
|
||||
|
||||
type FullUpdateEntrySet = UpdateEntrySet (Either UE_RO (UEUnk, [UELink])) ()
|
||||
|
||||
|
@ -171,7 +169,7 @@ data AcntPath = AcntPath
|
|||
|
||||
data TxRecord = TxRecord
|
||||
{ trDate :: !Day
|
||||
, trAmount :: !Rational
|
||||
, trAmount :: !Decimal
|
||||
, trDesc :: !T.Text
|
||||
, trOther :: !(M.Map T.Text T.Text)
|
||||
, trFile :: !FilePath
|
||||
|
@ -211,7 +209,7 @@ data HalfEntrySet v0 vN = HalfEntrySet
|
|||
|
||||
data EntrySet v0 vp0 vpN vtN = EntrySet
|
||||
{ esTotalValue :: !v0
|
||||
, esCurrency :: !CurrencyPrec
|
||||
, esCurrency :: !CurrencyRId
|
||||
, esFrom :: !(HalfEntrySet vp0 vpN)
|
||||
, esTo :: !(HalfEntrySet () vtN)
|
||||
}
|
||||
|
@ -221,25 +219,13 @@ type TotalEntrySet v0 vpN vtN = EntrySet v0 () vpN vtN
|
|||
|
||||
type FullEntrySet vp0 vpN vtN = EntrySet () vp0 vpN vtN
|
||||
|
||||
type PrimaryEntrySet =
|
||||
TotalEntrySet
|
||||
Rational
|
||||
(EntryValue Rational)
|
||||
(LinkDeferred Rational)
|
||||
type PrimaryEntrySet = TotalEntrySet Decimal EntryValue LinkDeferred
|
||||
|
||||
type SecondayEntrySet =
|
||||
FullEntrySet
|
||||
(EntryValue Rational)
|
||||
(EntryValue Rational)
|
||||
(LinkDeferred Rational)
|
||||
type SecondayEntrySet = FullEntrySet EntryValue EntryValue LinkDeferred
|
||||
|
||||
type TransferEntrySet = SecondayEntrySet
|
||||
|
||||
type ShadowEntrySet =
|
||||
TotalEntrySet
|
||||
Double
|
||||
(EntryValue Rational)
|
||||
(LinkDeferred Rational)
|
||||
type ShadowEntrySet = TotalEntrySet Double EntryValue LinkDeferred
|
||||
|
||||
data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text
|
||||
deriving (Eq, Ord, Show)
|
||||
|
@ -257,7 +243,7 @@ data Tx k = Tx
|
|||
|
||||
data InsertEntry = InsertEntry
|
||||
{ ieDeferred :: !(Maybe DBDeferred)
|
||||
, ieEntry :: !(Entry AccountRId Rational TagRId)
|
||||
, ieEntry :: !(Entry AccountRId Decimal TagRId)
|
||||
}
|
||||
|
||||
data InsertEntrySet = InsertEntrySet
|
||||
|
@ -279,17 +265,16 @@ data InsertTx = InsertTx
|
|||
data Deferred a = Deferred Bool a
|
||||
deriving (Show, Functor, Foldable, Traversable)
|
||||
|
||||
data EntryValue a = EntryValue TransferType a
|
||||
data EntryValue_ a = EntryValue_ TransferType a
|
||||
deriving (Show, Functor, Foldable, Traversable)
|
||||
|
||||
data LinkDeferred a
|
||||
= LinkDeferred (EntryValue a)
|
||||
data EntryValue = EntryFixed Decimal | EntryPercent Double | EntryBalance Decimal
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data LinkDeferred
|
||||
= LinkDeferred EntryValue
|
||||
| LinkIndex LinkedNumGetter
|
||||
deriving (Show, Functor, Traversable, Foldable)
|
||||
|
||||
-- type RawEntry = Entry AcntID (Deferred Rational) CurID TagID
|
||||
|
||||
-- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID
|
||||
deriving (Show)
|
||||
|
||||
data MatchRes a = MatchPass !a | MatchFail | MatchSkip
|
||||
|
||||
|
|
|
@ -39,8 +39,6 @@ module Internal.Utils
|
|||
, xGregToDay
|
||||
, dateMatches
|
||||
, valMatches
|
||||
, roundPrecision
|
||||
, roundPrecisionCur
|
||||
, lookupAccount
|
||||
, lookupAccountKey
|
||||
, lookupAccountSign
|
||||
|
@ -63,6 +61,7 @@ where
|
|||
|
||||
import Control.Monad.Error.Class
|
||||
import Control.Monad.Except
|
||||
import Data.Decimal
|
||||
import Data.Time.Format.ISO8601
|
||||
import GHC.Real
|
||||
import Internal.Types.Main
|
||||
|
@ -415,13 +414,13 @@ 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
|
||||
|
||||
roundPrecision :: Natural -> Double -> Rational
|
||||
roundPrecision n = (% p) . round . (* fromIntegral p) . toRational
|
||||
where
|
||||
p = 10 ^ n
|
||||
-- roundPrecision :: Natural -> Double -> Rational
|
||||
-- roundPrecision n = (% p) . round . (* fromIntegral p) . toRational
|
||||
-- where
|
||||
-- p = 10 ^ n
|
||||
|
||||
roundPrecisionCur :: CurrencyPrec -> Double -> Rational
|
||||
roundPrecisionCur (CurrencyPrec _ n) = roundPrecision n
|
||||
-- roundPrecisionCur :: CurrencyPrec -> Double -> Rational
|
||||
-- roundPrecisionCur (CurrencyPrec _ n) = roundPrecision n
|
||||
|
||||
acntPath2Text :: AcntPath -> T.Text
|
||||
acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
|
||||
|
@ -525,7 +524,7 @@ showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
|
|||
keyVals
|
||||
[ ("path", T.pack f)
|
||||
, ("date", T.pack $ iso8601Show d)
|
||||
, ("value", showT (fromRational v :: Float))
|
||||
, ("value", showT v)
|
||||
, ("description", doubleQuote e)
|
||||
]
|
||||
|
||||
|
@ -663,7 +662,7 @@ lookupCurrency = lookupFinance CurField kmCurrency
|
|||
lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId
|
||||
lookupCurrencyKey = fmap cpID . lookupCurrency
|
||||
|
||||
lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Natural
|
||||
lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Precision
|
||||
lookupCurrencyPrec = fmap cpPrec . lookupCurrency
|
||||
|
||||
lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId
|
||||
|
@ -695,7 +694,7 @@ balanceTxs ebs =
|
|||
go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate, txBudget, txPriority}) = do
|
||||
e <- either (balancePrimaryEntrySet txBudget) (balanceSecondaryEntrySet txBudget) txPrimary
|
||||
let tot = sum $ fmap (eValue . ieEntry) $ NE.toList $ iesFromEntries e
|
||||
es <- mapErrors (either (balanceSecondaryEntrySet txBudget) (balancePrimaryEntrySet txBudget . fromShadow tot)) txOther
|
||||
es <- mapErrors (goOther tot) txOther
|
||||
let tx =
|
||||
-- TODO this is lame
|
||||
InsertTx
|
||||
|
@ -707,7 +706,12 @@ balanceTxs ebs =
|
|||
, itxPriority = txPriority
|
||||
}
|
||||
return $ Just $ Right tx
|
||||
fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot * toRational esTotalValue}
|
||||
where
|
||||
goOther tot =
|
||||
either
|
||||
(balanceSecondaryEntrySet txBudget)
|
||||
(balancePrimaryEntrySet txBudget . fromShadow tot)
|
||||
fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot *. esTotalValue}
|
||||
|
||||
binDate :: EntryBin -> (Day, Int)
|
||||
binDate (ToRead ReadEntry {reDate, rePriority}) = (reDate, rePriority)
|
||||
|
@ -720,7 +724,7 @@ type BCKey = (CurrencyRId, Text)
|
|||
|
||||
type ABCKey = (AccountRId, BCKey)
|
||||
|
||||
type EntryBals = M.Map ABCKey Rational
|
||||
type EntryBals = M.Map ABCKey Decimal
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- rebalancing
|
||||
|
@ -735,19 +739,19 @@ rebalanceTotalEntrySet
|
|||
, utToUnk
|
||||
, utFromRO
|
||||
, utToRO
|
||||
, utCurrency = (curID, precision)
|
||||
, utCurrency
|
||||
, utTotalValue
|
||||
, utBudget
|
||||
} =
|
||||
do
|
||||
(fval, fs, tpairs) <- rebalanceDebit bc precision utFromRO utFromUnk
|
||||
(fval, fs, tpairs) <- rebalanceDebit bc utFromRO utFromUnk
|
||||
let f0val = utTotalValue - fval
|
||||
modify $ mapAdd_ (f0Acnt, bc) f0val
|
||||
let tsLinked = tpairs ++ (unlink f0val <$> f0links)
|
||||
ts <- rebalanceCredit bc precision utTotalValue utTo0 utToUnk utToRO tsLinked
|
||||
ts <- rebalanceCredit bc utTotalValue utTo0 utToUnk utToRO tsLinked
|
||||
return (f0 {ueValue = StaticValue f0val} : fs ++ ts)
|
||||
where
|
||||
bc = (curID, utBudget)
|
||||
bc = (utCurrency, utBudget)
|
||||
|
||||
rebalanceFullEntrySet :: FullUpdateEntrySet -> State EntryBals [UEBalanced]
|
||||
rebalanceFullEntrySet
|
||||
|
@ -758,26 +762,25 @@ rebalanceFullEntrySet
|
|||
, utToUnk
|
||||
, utFromRO
|
||||
, utToRO
|
||||
, utCurrency = (curID, precision)
|
||||
, utCurrency
|
||||
, utBudget
|
||||
} =
|
||||
do
|
||||
(ftot, fs, tpairs) <- rebalanceDebit bc precision rs ls
|
||||
ts <- rebalanceCredit bc precision ftot utTo0 utToUnk utToRO tpairs
|
||||
(ftot, fs, tpairs) <- rebalanceDebit bc rs ls
|
||||
ts <- rebalanceCredit bc ftot utTo0 utToUnk utToRO tpairs
|
||||
return (fs ++ ts)
|
||||
where
|
||||
(rs, ls) = case utFrom0 of
|
||||
Left x -> (x : utFromRO, utFromUnk)
|
||||
Right x -> (utFromRO, x : utFromUnk)
|
||||
bc = (curID, utBudget)
|
||||
bc = (utCurrency, utBudget)
|
||||
|
||||
rebalanceDebit
|
||||
:: BCKey
|
||||
-> Natural
|
||||
-> [UE_RO]
|
||||
-> [(UEUnk, [UELink])]
|
||||
-> State EntryBals (Rational, [UEBalanced], [UEBalanced])
|
||||
rebalanceDebit k precision ro linked = do
|
||||
-> State EntryBals (Decimal, [UEBalanced], [UEBalanced])
|
||||
rebalanceDebit k ro linked = do
|
||||
(tot, (tpairs, fs)) <-
|
||||
fmap (second (partitionEithers . concat)) $
|
||||
sumM goFrom $
|
||||
|
@ -788,24 +791,23 @@ rebalanceDebit k precision ro linked = do
|
|||
idx = either ueIndex (ueIndex . fst)
|
||||
goFrom (Left e) = (,[]) <$> updateFixed k e
|
||||
goFrom (Right (e0, es)) = do
|
||||
v <- updateUnknown precision k e0
|
||||
v <- updateUnknown k e0
|
||||
let e0' = Right $ e0 {ueValue = StaticValue v}
|
||||
let es' = Left . unlink v <$> es
|
||||
return (v, e0' : es')
|
||||
|
||||
unlink :: Rational -> UELink -> UEBalanced
|
||||
unlink :: Decimal -> UELink -> UEBalanced
|
||||
unlink v e = e {ueValue = StaticValue $ (-v) * unLinkScale (ueValue e)}
|
||||
|
||||
rebalanceCredit
|
||||
:: BCKey
|
||||
-> Natural
|
||||
-> Rational
|
||||
-> Decimal
|
||||
-> UEBlank
|
||||
-> [UEUnk]
|
||||
-> [UE_RO]
|
||||
-> [UEBalanced]
|
||||
-> State EntryBals [UEBalanced]
|
||||
rebalanceCredit k precision tot t0 us rs bs = do
|
||||
rebalanceCredit k tot t0 us rs bs = do
|
||||
(tval, ts) <-
|
||||
fmap (second catMaybes) $
|
||||
sumM goTo $
|
||||
|
@ -819,7 +821,7 @@ rebalanceCredit k precision tot t0 us rs bs = do
|
|||
goTo (UETReadOnly e) = (,Nothing) <$> updateFixed k e
|
||||
goTo (UETLinked e) = (,Just e) <$> updateFixed k e
|
||||
goTo (UETUnk e) = do
|
||||
v <- updateUnknown precision k e
|
||||
v <- updateUnknown k e
|
||||
return (v, Just $ e {ueValue = StaticValue v})
|
||||
|
||||
data UpdateEntryType a b
|
||||
|
@ -832,18 +834,18 @@ projectUET f _ _ (UETReadOnly e) = f e
|
|||
projectUET _ f _ (UETUnk e) = f e
|
||||
projectUET _ _ f (UETLinked p) = f p
|
||||
|
||||
updateFixed :: BCKey -> UpdateEntry i StaticValue -> State EntryBals Rational
|
||||
updateFixed :: BCKey -> UpdateEntry i StaticValue -> State EntryBals Decimal
|
||||
updateFixed k e = do
|
||||
let v = unStaticValue $ ueValue e
|
||||
modify $ mapAdd_ (ueAcnt e, k) v
|
||||
return v
|
||||
|
||||
updateUnknown :: Natural -> BCKey -> UpdateEntry i EntryValueUnk -> State EntryBals Rational
|
||||
updateUnknown precision k e = do
|
||||
updateUnknown :: BCKey -> UpdateEntry i EntryValueUnk -> State EntryBals Decimal
|
||||
updateUnknown k e = do
|
||||
let key = (ueAcnt e, k)
|
||||
curBal <- gets (M.findWithDefault 0 key)
|
||||
let v = roundPrecision precision $ fromRational $ case ueValue e of
|
||||
EVPercent p -> p * curBal
|
||||
let v = case ueValue e of
|
||||
EVPercent p -> curBal *. p
|
||||
EVBalance p -> p - curBal
|
||||
modify $ mapAdd_ key v
|
||||
return v
|
||||
|
@ -861,7 +863,7 @@ balancePrimaryEntrySet
|
|||
EntrySet
|
||||
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
|
||||
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
|
||||
, esCurrency = CurrencyPrec {cpID = curID, cpPrec = precision}
|
||||
, esCurrency
|
||||
, esTotalValue
|
||||
} =
|
||||
do
|
||||
|
@ -869,12 +871,12 @@ balancePrimaryEntrySet
|
|||
let t0res = resolveAcntAndTags t0
|
||||
let fsres = mapErrors resolveAcntAndTags fs
|
||||
let tsres = mapErrors resolveAcntAndTags ts
|
||||
let bc = (curID, budgetName)
|
||||
let bc = (esCurrency, budgetName)
|
||||
combineErrorM (combineError f0res fsres (,)) (combineError t0res tsres (,)) $
|
||||
\(f0', fs') (t0', ts') -> do
|
||||
let balFrom = fmap liftInnerS . balanceDeferred precision
|
||||
let balFrom = fmap liftInnerS . balanceDeferred
|
||||
fs'' <- doEntries balFrom bc esTotalValue f0' fs'
|
||||
balanceFinal bc (-esTotalValue) precision fs'' t0' ts'
|
||||
balanceFinal bc (-esTotalValue) fs'' t0' ts'
|
||||
|
||||
balanceSecondaryEntrySet
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
|
@ -886,7 +888,7 @@ balanceSecondaryEntrySet
|
|||
EntrySet
|
||||
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
|
||||
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
|
||||
, esCurrency = CurrencyPrec {cpID = curID, cpPrec = precision}
|
||||
, esCurrency
|
||||
} =
|
||||
do
|
||||
let fsRes = mapErrors resolveAcntAndTags (f0 :| fs)
|
||||
|
@ -895,24 +897,23 @@ balanceSecondaryEntrySet
|
|||
combineErrorM fsRes (combineError t0Res tsRes (,)) $ \fs' (t0', ts') -> do
|
||||
fs'' <- mapErrors balFrom fs'
|
||||
let tot = entrySum (NE.toList fs'')
|
||||
balanceFinal bc (-tot) precision fs'' t0' ts'
|
||||
balanceFinal bc (-tot) fs'' t0' ts'
|
||||
where
|
||||
entrySum = sum . fmap (eValue . ieEntry)
|
||||
balFrom = balanceEntry (fmap liftInnerS . balanceDeferred precision) bc
|
||||
bc = (curID, budgetName)
|
||||
balFrom = balanceEntry (fmap liftInnerS . balanceDeferred) bc
|
||||
bc = (esCurrency, budgetName)
|
||||
|
||||
balanceFinal
|
||||
:: (MonadInsertError m)
|
||||
=> BCKey
|
||||
-> Rational
|
||||
-> Natural
|
||||
-> Decimal
|
||||
-> NonEmpty InsertEntry
|
||||
-> Entry (AccountRId, AcntSign) () TagRId
|
||||
-> [Entry (AccountRId, AcntSign) (LinkDeferred Rational) TagRId]
|
||||
-> [Entry (AccountRId, AcntSign) LinkDeferred TagRId]
|
||||
-> StateT EntryBals m InsertEntrySet
|
||||
balanceFinal k@(curID, _) tot precision fs t0 ts = do
|
||||
balanceFinal k@(curID, _) tot fs t0 ts = do
|
||||
let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs
|
||||
let balTo = balanceLinked fv precision
|
||||
let balTo = balanceLinked fv
|
||||
ts' <- doEntries balTo k tot t0 ts
|
||||
return $
|
||||
InsertEntrySet
|
||||
|
@ -923,9 +924,9 @@ balanceFinal k@(curID, _) tot precision fs t0 ts = do
|
|||
|
||||
doEntries
|
||||
:: (MonadInsertError m)
|
||||
=> (ABCKey -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
|
||||
=> (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe DBDeferred))
|
||||
-> BCKey
|
||||
-> Rational
|
||||
-> Decimal
|
||||
-> Entry (AccountRId, AcntSign) () TagRId
|
||||
-> [Entry (AccountRId, AcntSign) v TagRId]
|
||||
-> StateT EntryBals m (NonEmpty InsertEntry)
|
||||
|
@ -949,39 +950,34 @@ liftInnerS = mapStateT (return . runIdentity)
|
|||
|
||||
balanceLinked
|
||||
:: MonadInsertError m
|
||||
=> Vector Rational
|
||||
-> Natural
|
||||
=> Vector Decimal
|
||||
-> ABCKey
|
||||
-> LinkDeferred Rational
|
||||
-> StateT EntryBals m (Rational, Maybe DBDeferred)
|
||||
balanceLinked from precision k lg = case lg of
|
||||
-> LinkDeferred
|
||||
-> StateT EntryBals m (Decimal, Maybe DBDeferred)
|
||||
balanceLinked from k lg = case lg of
|
||||
(LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do
|
||||
let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex
|
||||
case res of
|
||||
Just v -> return (v, Just $ EntryLinked lngIndex $ toRational lngScale)
|
||||
Just v -> return (v, Just $ DBEntryLinked lngIndex lngScale)
|
||||
-- TODO this error would be much more informative if I had access to the
|
||||
-- file from which it came
|
||||
Nothing -> throwError undefined
|
||||
(LinkDeferred d) -> liftInnerS $ balanceDeferred precision k d
|
||||
(LinkDeferred d) -> liftInnerS $ balanceDeferred k d
|
||||
where
|
||||
go s = negate . roundPrecision precision . (* s) . fromRational
|
||||
go s = negate . (*. s)
|
||||
|
||||
balanceDeferred
|
||||
:: Natural
|
||||
-> ABCKey
|
||||
-> EntryValue Rational
|
||||
-> State EntryBals (Rational, Maybe DBDeferred)
|
||||
balanceDeferred prec k (EntryValue t v) = do
|
||||
newval <- findBalance prec k t v
|
||||
let d = case t of
|
||||
TFixed -> Nothing
|
||||
TBalance -> Just $ EntryBalance v
|
||||
TPercent -> Just $ EntryPercent v
|
||||
balanceDeferred :: ABCKey -> EntryValue -> State EntryBals (Decimal, Maybe DBDeferred)
|
||||
balanceDeferred k e = do
|
||||
newval <- findBalance k e
|
||||
let d = case e of
|
||||
EntryFixed _ -> Nothing
|
||||
EntryBalance v -> Just $ DBEntryBalance v
|
||||
EntryPercent v -> Just $ DBEntryPercent v
|
||||
return (newval, d)
|
||||
|
||||
balanceEntry
|
||||
:: (MonadInsertError m)
|
||||
=> (ABCKey -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
|
||||
=> (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe DBDeferred))
|
||||
-> BCKey
|
||||
-> Entry (AccountRId, AcntSign) v TagRId
|
||||
-> StateT EntryBals m InsertEntry
|
||||
|
@ -1005,18 +1001,13 @@ resolveAcntAndTags e@Entry {eAcnt, eTags} = do
|
|||
combineError acntRes tagRes $
|
||||
\(acntID, sign, _) tags -> e {eAcnt = (acntID, sign), eTags = tags}
|
||||
|
||||
findBalance
|
||||
:: Natural
|
||||
-> ABCKey
|
||||
-> TransferType
|
||||
-> Rational
|
||||
-> State EntryBals Rational
|
||||
findBalance prec k t v = do
|
||||
findBalance :: ABCKey -> EntryValue -> State EntryBals Decimal
|
||||
findBalance k e = do
|
||||
curBal <- gets (M.findWithDefault 0 k)
|
||||
return $ roundPrecision prec $ fromRational $ case t of
|
||||
TBalance -> v - curBal
|
||||
TPercent -> v * curBal
|
||||
TFixed -> v
|
||||
return $ case e of
|
||||
EntryBalance b -> b - curBal
|
||||
EntryPercent p -> curBal *. p
|
||||
EntryFixed v -> v
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- transfers
|
||||
|
@ -1047,14 +1038,20 @@ expandTransfer tc name bounds Transfer {transAmounts, transTo, transCurrency, tr
|
|||
, amtValue = TransferValue {tvVal = v, tvType = t}
|
||||
, amtDesc = desc
|
||||
, amtPriority = pri
|
||||
} =
|
||||
withDates bounds pat $ \day -> do
|
||||
p <- entryPair transFrom transTo transCurrency desc () (EntryValue t (toRational (-v)))
|
||||
} = do
|
||||
cp <- lookupCurrency transCurrency
|
||||
let v' = (-v)
|
||||
let dec = realFracToDecimal (cpPrec cp) v'
|
||||
let v'' = case t of
|
||||
TFixed -> EntryFixed dec
|
||||
TPercent -> EntryPercent v'
|
||||
TBalance -> EntryBalance dec
|
||||
withDates bounds pat $ \day ->
|
||||
return
|
||||
Tx
|
||||
{ txCommit = tc
|
||||
, txDate = day
|
||||
, txPrimary = Right p
|
||||
, txPrimary = Right $ entryPair transFrom transTo (cpID cp) desc () v''
|
||||
, txOther = []
|
||||
, txDescr = desc
|
||||
, txBudget = name
|
||||
|
@ -1062,23 +1059,20 @@ expandTransfer tc name bounds Transfer {transAmounts, transTo, transCurrency, tr
|
|||
}
|
||||
|
||||
entryPair
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> TaggedAcnt
|
||||
:: TaggedAcnt
|
||||
-> TaggedAcnt
|
||||
-> CurID
|
||||
-> CurrencyRId
|
||||
-> T.Text
|
||||
-> v0
|
||||
-> v1
|
||||
-> m (EntrySet v0 v1 v2 v3)
|
||||
entryPair (TaggedAcnt fa fts) (TaggedAcnt ta tts) curid com totval val1 = do
|
||||
cp <- lookupCurrency curid
|
||||
return $
|
||||
EntrySet
|
||||
{ esCurrency = cp
|
||||
, esTotalValue = totval
|
||||
, esFrom = halfEntry fa fts val1
|
||||
, esTo = halfEntry ta tts ()
|
||||
}
|
||||
-> EntrySet v0 v1 v2 v3
|
||||
entryPair (TaggedAcnt fa fts) (TaggedAcnt ta tts) curid com totval val1 =
|
||||
EntrySet
|
||||
{ esCurrency = curid
|
||||
, esTotalValue = totval
|
||||
, esFrom = halfEntry fa fts val1
|
||||
, esTo = halfEntry ta tts ()
|
||||
}
|
||||
where
|
||||
halfEntry :: AcntID -> [TagID] -> v -> HalfEntrySet v v0
|
||||
halfEntry a ts v =
|
||||
|
|
|
@ -87,6 +87,7 @@ dependencies:
|
|||
- filepath
|
||||
- mtl
|
||||
- persistent-mtl >= 0.3.0.0
|
||||
- Decimal >= 0.5.2
|
||||
|
||||
library:
|
||||
source-dirs: lib/
|
||||
|
|
Loading…
Reference in New Issue