WIP use doubles in config

dhall/Types.dhall

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

dhall/common.dhall

@@ -4,19 +4,6 @@ let List/map =
 
 let T = ./Types.dhall
 
-let dec =
-      \(s : Bool) ->
-      \(w : Natural) ->
-      \(d : Natural) ->
-      \(p : Natural) ->
-        { whole = w, decimal = d, precision = p, sign = s } : T.Decimal
-
-let dec2 = \(s : Bool) -> \(w : Natural) -> \(d : Natural) -> dec s w d 2
-
-let d = dec2 True
-
-let d_ = dec2 False
-
 let nullSplit =
       \(a : T.EntryAcntGetter) ->
       \(c : T.EntryCurGetter) ->
@@ -99,7 +86,7 @@ let mRngYMD =
       \(r : Natural) ->
         T.DateMatcher.In { _1 = T.YMDMatcher.YMD (greg y m d), _2 = r }
 
-let PartSplit = { _1 : T.AcntID, _2 : T.Decimal, _3 : Text }
+let PartSplit = { _1 : T.AcntID, _2 : Double, _3 : Text }
 
 let partN =
       \(c : T.EntryCurGetter) ->
@@ -184,9 +171,5 @@ in      { nullSplit
         , mvDenP
         , mvDenN
         , PartSplit
-        , d
-        , d_
-        , dec
-        , dec2
         }
     /\  T

lib/Internal/Database/Ops.hs

@@ -194,11 +194,18 @@ updateCurrencies cs = do
   return $ currencyMap curs
 
 currency2Record :: Currency -> Entity CurrencyR
-currency2Record c@Currency {curSymbol, curFullname} =
+currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
-  Entity (toKey c) $ CurrencyR curSymbol curFullname
+  Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision)
 
 currencyMap :: [Entity CurrencyR] -> CurrencyMap
-currencyMap = M.fromList . fmap (\e -> (currencyRSymbol $ entityVal e, entityKey e))
+currencyMap =
+  M.fromList
+    . fmap
+      ( \e ->
+          ( currencyRSymbol $ entityVal e
+          , (entityKey e, fromIntegral $ currencyRPrecision $ entityVal e)
+          )
+      )
 
 updateTags :: MonadUnliftIO m => [Tag] -> SqlPersistT m TagMap
 updateTags cs = do

lib/Internal/Insert.hs

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

lib/Internal/Statement.hs

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

lib/Internal/Types.hs

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

lib/Internal/Utils.hs

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