From 46decdc4de18597d8ac1d462d47f3ca0e05fc7ad Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sat, 8 Jul 2023 00:52:40 -0400 Subject: [PATCH] ENH use decimals to round --- budget.cabal | 6 +- lib/Internal/Budget.hs | 90 ++++++++---------- lib/Internal/Database.hs | 79 ++++++++------- lib/Internal/History.hs | 109 +++++++++++++-------- lib/Internal/Types/Main.hs | 67 +++++-------- lib/Internal/Utils.hs | 190 ++++++++++++++++++------------------- package.yaml | 1 + 7 files changed, 277 insertions(+), 265 deletions(-) diff --git a/budget.cabal b/budget.cabal index aa0f2b3..428696b 100644 --- a/budget.cabal +++ b/budget.cabal @@ -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 diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs index 035a49e..ad685f9 100644 --- a/lib/Internal/Budget.hs +++ b/lib/Internal/Budget.hs @@ -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 diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs index c050ba5..0209355 100644 --- a/lib/Internal/Database.hs +++ b/lib/Internal/Database.hs @@ -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 diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs index 8727424..5cef870 100644 --- a/lib/Internal/History.hs +++ b/lib/Internal/History.hs @@ -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 diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs index bc8b4e9..7ac50db 100644 --- a/lib/Internal/Types/Main.hs +++ b/lib/Internal/Types/Main.hs @@ -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 diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index e7e4b69..bf6168f 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -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 = diff --git a/package.yaml b/package.yaml index 93b2fc3..2801a9a 100644 --- a/package.yaml +++ b/package.yaml @@ -87,6 +87,7 @@ dependencies: - filepath - mtl - persistent-mtl >= 0.3.0.0 +- Decimal >= 0.5.2 library: source-dirs: lib/