ENH use decimals to round

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

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
+          * fromIntegral n
-      Daily _ -> x * n / 365.25
+      Daily _ -> realFracToDecimal prec (x * fromIntegral n / 365.25)
-      where
-        rnd = roundPrecision precision
 
 -- 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
+  :: Precision
-  -> Rational
+  -> 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} =
+    go m f@FlatAllocation {faValue = PretaxValue {preCategory, preValue, prePercent}} =
-      let c = preCategory faValue
+      let v =
-          p = preValue faValue
+            if prePercent
-          v =
+              then gross *. (preValue / 100)
-            if prePercent faValue
+              else realFracToDecimal precision preValue
-              then (roundPrecision 3 p / 100) * gross
+       in (mapAdd_ preCategory v m, f {faValue = v})
-              else roundPrecision precision p
-       in (mapAdd_ c v m, f {faValue = v})
 
 allocateTax
-  :: Natural
+  :: Precision
-  -> Rational
+  -> Decimal
-  -> M.Map T.Text Rational
+  -> 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 ->
+            TMPercent p -> agi *. p / 100
-              roundPrecision precision $
-                fromRational $
-                  roundPrecision 3 p / 100 * agi
             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 :: PeriodScaler -> Precision -> Decimal -> [TaxBracket] -> Decimal
-foldBracket f precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
+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
+      let l = f prec tbLowerLimit
-          p = roundPrecision 3 tbPercent / 100
+       in if remain >= l
-       in if remain >= l then (acc + p * (remain - l), l) else a
+            then (acc + (remain - l) *. (tbPercent / 100), l)
+            else a
 
 allocatePost
-  :: Natural
+  :: Precision
-  -> Rational
+  -> Decimal
   -> [FlatAllocation PosttaxValue]
-  -> [FlatAllocation Rational]
+  -> [FlatAllocation Decimal]
-allocatePost precision aftertax = fmap (fmap go)
+allocatePost prec aftertax = fmap (fmap go)
   where
-    go PosttaxValue {postValue, postPercent} =
+    go PosttaxValue {postValue, postPercent}
-      let v = postValue
+      | postPercent = aftertax *. (postValue / 100)
-       in if postPercent
+      | otherwise = realFracToDecimal prec postValue
-            then aftertax * roundPrecision 3 v / 100
-            else roundPrecision precision v
 
 --------------------------------------------------------------------------------
 -- 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

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, fromRO, fromUnkVec) <- splitFrom prec' $ NE.reverse froms
-          (from0', fromUnk, to0, toRO, toUnk) <- splitTo from0 fromUnkVec tos
+          (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 f0Res = readDeferredValue prec f0
-  let fsRes = mapErrors splitDeferredValue fs
+  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 :: Precision -> (EntryRId, EntryR) -> InsertExcept (Either UE_RO UEUnk)
-splitDeferredValue p = do
+splitDeferredValue prec p = do
-  res <- readDeferredValue p
+  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 :: Precision -> (EntryRId, EntryR) -> InsertExcept (Either UEBlank (Either UE_RO UEUnk))
-readDeferredValue (k, e) = case (entryRCachedValue e, entryRCachedType e) of
+readDeferredValue prec (k, e) = case (entryRCachedValue e, entryRCachedType e) of
-  (Nothing, Just TFixed) -> return $ Right $ Left $ makeRoUE e
+  (Nothing, Just TFixed) -> return $ Right $ Left $ makeRoUE prec e
-  (Just v, Just TBalance) -> go EVBalance v
+  (Just v, Just TBalance) -> go $ fmap EVBalance $ makeUE k e $ realFracToDecimal prec v
-  (Just v, Just TPercent) -> go EVPercent 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 :: Precision -> EntryR -> UpdateEntry () StaticValue
-makeRoUE e = makeUE () e $ StaticValue (entryRValue e)
+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 (DBEntryLinked x s)) -> (Just (toRational s), Nothing, Just $ fromIntegral x)
-        (Just (EntryBalance target)) -> (Just target, Just TBalance, Nothing)
+        (Just (DBEntryBalance b)) -> (Just (toRational b), Just TBalance, Nothing)
-        (Just (EntryPercent target)) -> (Just target, Just TPercent, 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

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
+                { esTotalValue = roundTo (cpPrec cur) trAmount *. tgScale
-                , esCurrency = cur
+                , 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 prec = cpPrec cur
-        let toRes = liftInner $ resolveHalfEntry resolveToValue cur r () tgTo
+        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 prec = cpPrec cur
-  let valRes = liftInner $ fmap (roundPrecisionCur cur) <$> resolveValue r tsgValue
+  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
+  :: (Precision -> TxRecord -> n -> InsertExcept v')
-  => (TxRecord -> n -> InsertExcept (f Double))
+  -> Precision
-  -> CurrencyPrec
   -> TxRecord
   -> v
   -> TxHalfGetter (EntryGetter n)
-  -> InsertExcept (HalfEntrySet v (f Rational))
+  -> InsertExcept (HalfEntrySet v v')
-resolveHalfEntry f cur r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
+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
+  :: (Precision -> TxRecord -> n -> InsertExcept v)
-  => (TxRecord -> n -> InsertExcept (f Double))
+  -> Precision
-  -> CurrencyPrec
   -> TxRecord
   -> EntryGetter n
-  -> InsertExcept (Entry AcntID (f Rational) TagID)
+  -> InsertExcept (Entry AcntID v TagID)
-resolveEntry f cur r s@Entry {eAcnt, eValue} = do
+resolveEntry f prec r s@Entry {eAcnt, eValue} =
-  combineError acntRes valRes $ \a v ->
+  combineError acntRes valRes $ \a v -> s {eAcnt = a, eValue = v}
-    s {eAcnt = a, eValue = roundPrecisionCur cur <$> 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 :: Precision -> TxRecord -> LinkedEntryNumGetter -> InsertExcept LinkDeferred
-resolveToValue _ (Linked l) = return $ LinkIndex l
+resolveToValue _ _ (Linked l) = return $ LinkIndex l
-resolveToValue r (Getter g) = LinkDeferred <$> resolveValue r g
+resolveToValue prec r (Getter g) = LinkDeferred <$> resolveValue prec r g
 
-resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (EntryValue Double)
+resolveValue :: Precision -> TxRecord -> EntryNumGetter -> InsertExcept EntryValue
-resolveValue TxRecord {trOther, trAmount} s = case s of
+resolveValue prec TxRecord {trOther, trAmount} s = case s of
-  (LookupN t) -> EntryValue TFixed <$> (readDouble =<< lookupErr EntryValField t trOther)
+  (LookupN t) -> EntryFixed . go <$> (readDouble =<< lookupErr EntryValField t trOther)
-  (ConstN c) -> return $ EntryValue TFixed c
+  (ConstN c) -> return $ EntryFixed $ go c
-  AmountN m -> return $ EntryValue TFixed $ m * fromRational trAmount
+  AmountN m -> return $ EntryFixed $ trAmount *. m
-  BalanceN x -> return $ EntryValue TBalance x
+  BalanceN x -> return $ EntryBalance $ go x
-  PercentN x -> return $ EntryValue TPercent 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 :: 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
-  [sign, x, ""] -> uncurry (*) <$> readWhole sign x
+--   [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

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
+  = DBEntryLinked Natural Double
-  | EntryBalance Rational
+  | DBEntryBalance Decimal
-  | EntryPercent Rational
+  | 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}
+newtype StaticValue = StaticValue {unStaticValue :: Decimal}
---   deriving newtype (Num)
-
-newtype StaticValue = StaticValue {unStaticValue :: Rational}
   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 =
+type PrimaryEntrySet = TotalEntrySet Decimal EntryValue LinkDeferred
-  TotalEntrySet
-    Rational
-    (EntryValue Rational)
-    (LinkDeferred Rational)
 
-type SecondayEntrySet =
+type SecondayEntrySet = FullEntrySet EntryValue EntryValue LinkDeferred
-  FullEntrySet
-    (EntryValue Rational)
-    (EntryValue Rational)
-    (LinkDeferred Rational)
 
 type TransferEntrySet = SecondayEntrySet
 
-type ShadowEntrySet =
+type ShadowEntrySet = TotalEntrySet Double EntryValue LinkDeferred
-  TotalEntrySet
-    Double
-    (EntryValue Rational)
-    (LinkDeferred Rational)
 
 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
+data EntryValue = EntryFixed Decimal | EntryPercent Double | EntryBalance Decimal
-  = LinkDeferred (EntryValue a)
+  deriving (Show, Eq, Ord)
+
+data LinkDeferred
+  = LinkDeferred EntryValue
   | LinkIndex LinkedNumGetter
-  deriving (Show, Functor, Traversable, Foldable)
+  deriving (Show)
-
--- type RawEntry = Entry AcntID (Deferred Rational) CurID TagID
-
--- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID
 
 data MatchRes a = MatchPass !a | MatchFail | MatchSkip
 

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 :: Natural -> Double -> Rational
-roundPrecision n = (% p) . round . (* fromIntegral p) . toRational
+-- roundPrecision n = (% p) . round . (* fromIntegral p) . toRational
-  where
+--   where
-    p = 10 ^ n
+--     p = 10 ^ n
 
-roundPrecisionCur :: CurrencyPrec -> Double -> Rational
+-- roundPrecisionCur :: CurrencyPrec -> Double -> Rational
-roundPrecisionCur (CurrencyPrec _ n) = roundPrecision n
+-- 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
+      (ftot, fs, tpairs) <- rebalanceDebit bc rs ls
-      ts <- rebalanceCredit bc precision ftot utTo0 utToUnk utToRO tpairs
+      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])
+  -> State EntryBals (Decimal, [UEBalanced], [UEBalanced])
-rebalanceDebit k precision ro linked = do
+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
+  -> Decimal
-  -> Rational
   -> 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 :: BCKey -> UpdateEntry i EntryValueUnk -> State EntryBals Decimal
-updateUnknown precision k e = do
+updateUnknown k e = do
   let key = (ueAcnt e, k)
   curBal <- gets (M.findWithDefault 0 key)
-  let v = roundPrecision precision $ fromRational $ case ueValue e of
+  let v = case ueValue e of
-        EVPercent p -> p * curBal
+        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
+      balFrom = balanceEntry (fmap liftInnerS . balanceDeferred) bc
-      bc = (curID, budgetName)
+      bc = (esCurrency, budgetName)
 
 balanceFinal
   :: (MonadInsertError m)
   => BCKey
-  -> Rational
+  -> Decimal
-  -> Natural
   -> 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
+  => Vector Decimal
-  -> Natural
   -> ABCKey
-  -> LinkDeferred Rational
+  -> LinkDeferred
-  -> StateT EntryBals m (Rational, Maybe DBDeferred)
+  -> StateT EntryBals m (Decimal, Maybe DBDeferred)
-balanceLinked from precision k lg = case lg of
+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
+balanceDeferred :: ABCKey -> EntryValue -> State EntryBals (Decimal, Maybe DBDeferred)
-  :: Natural
+balanceDeferred k e = do
-  -> ABCKey
+  newval <- findBalance k e
-  -> EntryValue Rational
+  let d = case e of
-  -> State EntryBals (Rational, Maybe DBDeferred)
+        EntryFixed _ -> Nothing
-balanceDeferred prec k (EntryValue t v) = do
+        EntryBalance v -> Just $ DBEntryBalance v
-  newval <- findBalance prec k t v
+        EntryPercent v -> Just $ DBEntryPercent v
-  let d = case t of
-        TFixed -> Nothing
-        TBalance -> Just $ EntryBalance v
-        TPercent -> Just $ EntryPercent 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
+findBalance :: ABCKey -> EntryValue -> State EntryBals Decimal
-  :: Natural
+findBalance k e = do
-  -> ABCKey
-  -> TransferType
-  -> Rational
-  -> State EntryBals Rational
-findBalance prec k t v = do
   curBal <- gets (M.findWithDefault 0 k)
-  return $ roundPrecision prec $ fromRational $ case t of
+  return $ case e of
-    TBalance -> v - curBal
+    EntryBalance b -> b - curBal
-    TPercent -> v * curBal
+    EntryPercent p -> curBal *. p
-    TFixed -> v
+    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
-        } =
+        } = do
-        withDates bounds pat $ \day -> do
+        cp <- lookupCurrency transCurrency
-          p <- entryPair transFrom transTo transCurrency desc () (EntryValue t (toRational (-v)))
+        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)
+  -> EntrySet v0 v1 v2 v3
-entryPair (TaggedAcnt fa fts) (TaggedAcnt ta tts) curid com totval val1 = do
+entryPair (TaggedAcnt fa fts) (TaggedAcnt ta tts) curid com totval val1 =
-  cp <- lookupCurrency curid
+  EntrySet
-  return $
+    { esCurrency = curid
-    EntrySet
+    , esTotalValue = totval
-      { esCurrency = cp
+    , esFrom = halfEntry fa fts val1
-      , esTotalValue = totval
+    , esTo = halfEntry ta tts ()
-      , esFrom = halfEntry fa fts val1
+    }
-      , esTo = halfEntry ta tts ()
-      }
   where
     halfEntry :: AcntID -> [TagID] -> v -> HalfEntrySet v v0
     halfEntry a ts v =

package.yaml

@@ -87,6 +87,7 @@ dependencies:
 - filepath
 - mtl
 - persistent-mtl >= 0.3.0.0
+- Decimal >= 0.5.2
 
 library:
   source-dirs: lib/