From c2c30caf6993f04c26147761cc8c28fa758847f6 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Mon, 17 Apr 2023 00:34:09 -0400
Subject: [PATCH 01/15] ENH use mostly dhall types

---
 budget.cabal           |   1 +
 dhall/Types.dhall      |  46 ++++---
 lib/Internal/Insert.hs |   4 +-
 lib/Internal/TH.hs     |  12 ++
 lib/Internal/Types.hs  | 271 +++++++++++++++--------------------------
 5 files changed, 139 insertions(+), 195 deletions(-)
 create mode 100644 lib/Internal/TH.hs

diff --git a/budget.cabal b/budget.cabal
index 3516b37..6c1cdb4 100644
--- a/budget.cabal
+++ b/budget.cabal
@@ -29,6 +29,7 @@ library
       Internal.Database.Ops
       Internal.Insert
       Internal.Statement
+      Internal.TH
       Internal.Types
       Internal.Utils
   other-modules:
diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index 3bf6b48..0425e75 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -112,7 +112,10 @@ let MatchYMD = < Y : Natural | YM : GregorianM | YMD : Gregorian >
 
 let MatchDate = < On : MatchYMD | In : { _1 : MatchYMD, _2 : Natural } >
 
-let MatchOther = < Desc : Field Text Text | Val : Field Text MatchVal.Type >
+let MatchOther_ =
+      \(re : Type) -> < Desc : Field Text re | Val : Field Text MatchVal.Type >
+
+let MatchOther = MatchOther_ Text
 
 let SplitNum = < LookupN : Text | ConstN : Decimal | AmountN >
 
@@ -151,26 +154,29 @@ let ToTx =
       , ttSplit : List ExpSplit.Type
       }
 
-let Match =
-      { Type =
-          { mDate : Optional MatchDate
-          , mVal : MatchVal.Type
-          , mDesc : Optional Text
-          , mOther : List MatchOther
-          , mTx : Optional ToTx
-          , mTimes : Optional Natural
-          , mPriority : Integer
+let Match_ =
+      \(re : Type) ->
+        { Type =
+            { mDate : Optional MatchDate
+            , mVal : MatchVal.Type
+            , mDesc : Optional re
+            , mOther : List (MatchOther_ re)
+            , mTx : Optional ToTx
+            , mTimes : Optional Natural
+            , mPriority : Integer
+            }
+        , default =
+          { mDate = None MatchDate
+          , mVal = MatchVal::{=}
+          , mDesc = None Text
+          , mOther = [] : List (MatchOther_ re)
+          , mTx = None ToTx
+          , mTimes = None Natural
+          , mPriority = +0
           }
-      , default =
-        { mDate = None MatchDate
-        , mVal = MatchVal::{=}
-        , mDesc = None Text
-        , mOther = [] : List MatchOther
-        , mTx = None ToTx
-        , mTimes = None Natural
-        , mPriority = +0
         }
-      }
+
+let Match = Match_ Text
 
 let Manual =
       { manualDate : DatePat
@@ -303,10 +309,12 @@ in  { CurID
     , Decimal
     , TxOpts
     , Match
+    , Match_
     , MatchVal
     , MatchYMD
     , MatchDate
     , MatchOther
+    , MatchOther_
     , SplitNum
     , Field
     , FieldMap
diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs
index c07b276..3d50823 100644
--- a/lib/Internal/Insert.hs
+++ b/lib/Internal/Insert.hs
@@ -326,7 +326,7 @@ fromAllo day meta from Allocation_ {alloTo, alloAmts} = do
   -- res <- expandTarget alloPath
   return $ fmap toBT alloAmts
   where
-    toBT (Amount desc v) =
+    toBT (Amount {amtDesc = desc, amtValue = v}) =
       BudgetTxType
         { bttTx =
             BudgetTx
@@ -400,7 +400,7 @@ expandTransfer :: MonadFinance m => CommitRId -> T.Text -> Transfer -> SqlPersis
 expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} =
   -- whenHash CTExpense t (Right []) $ \key ->
   fmap (fmap concat . concatEithersL) $
-    forM transAmounts $ \(TimeAmount pat (Amount desc v) atype) -> do
+    forM transAmounts $ \(TimeAmount {taWhen = pat, taAmt = (Amount {amtDesc = desc, amtValue = v}), taAmtType = atype}) -> do
       withDates pat $ \day ->
         let meta =
               BudgetMeta
diff --git a/lib/Internal/TH.hs b/lib/Internal/TH.hs
new file mode 100644
index 0000000..51c0ce1
--- /dev/null
+++ b/lib/Internal/TH.hs
@@ -0,0 +1,12 @@
+module Internal.TH where
+
+import Language.Haskell.TH.Syntax (Dec (..), Q (..), Type (..), mkName)
+import RIO
+
+deriveProduct :: [String] -> [String] -> Q [Dec]
+deriveProduct cs ss =
+  return $
+    [ StandaloneDerivD Nothing [] (AppT x y)
+    | x <- ConT . mkName <$> cs
+    , y <- ConT . mkName <$> ss
+    ]
diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs
index 3730fe0..c2a58ff 100644
--- a/lib/Internal/Types.hs
+++ b/lib/Internal/Types.hs
@@ -12,6 +12,7 @@ import Database.Persist.Sql hiding (Desc, In, Statement)
 import Database.Persist.TH
 import Dhall hiding (embed, maybe)
 import Dhall.TH
+import Internal.TH (deriveProduct)
 import Language.Haskell.TH.Syntax (Lift)
 import RIO
 import qualified RIO.Map as M
@@ -25,7 +26,7 @@ import Text.Regex.TDFA
 -------------------------------------------------------------------------------
 
 makeHaskellTypesWith
-  (defaultGenerateOptions {generateToDhallInstance = False})
+  (defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False})
   [ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
   , MultipleConstructors "TimeUnit" "(./dhall/Types.dhall).TimeUnit"
   , MultipleConstructors "Weekday" "(./dhall/Types.dhall).Weekday"
@@ -50,84 +51,93 @@ makeHaskellTypesWith
   , SingleConstructor "MatchVal" "MatchVal" "(./dhall/Types.dhall).MatchVal.Type"
   , SingleConstructor "Manual" "Manual" "(./dhall/Types.dhall).Manual"
   , SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount"
-  , -- , SingleConstructor "TimeAmount" "TimeAmount" "(./dhall/Types.dhall).TimeAmount"
-    -- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income"
-    -- , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
-    -- , SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
-    SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
+  , SingleConstructor "TimeAmount" "TimeAmount" "(./dhall/Types.dhall).TimeAmount"
   , SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
   , SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
   , SingleConstructor "ShadowMatch" "ShadowMatch" "(./dhall/Types.dhall).ShadowMatch.Type"
   , SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
+  , -- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income.Type"
+    SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
+  , SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
+  , SingleConstructor "Split" "Split" "(./dhall/Types.dhall).Split"
+  -- , SingleConstructor "ToTx" "ToTx" "(./dhall/Types.dhall).ToTx"
+  -- , SingleConstructor "MatchOther" "MatchOther" "(./dhall/Types.dhall).MatchOther_"
+  -- , SingleConstructor "Match" "Match" "(./dhall/Types.dhall).Match_"
+  -- , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
+  -- SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
+  ]
+
+deriveProduct
+  ["Eq", "Show", "Generic", "FromDhall"]
+  [ "Currency"
+  , "Tag"
+  , "TimeUnit"
+  , "Weekday"
+  , "WeekdayPat"
+  , "RepeatPat"
+  , "MDYPat"
+  , "Gregorian"
+  , "GregorianM"
+  , "Interval"
+  , "ModPat"
+  , "CronPat"
+  , "DatePat"
+  , "TaggedAcnt"
+  , "Budget"
+  , "Income"
+  , "ShadowTransfer"
+  , "ShadowMatch"
+  , "AcntSet"
+  , "MatchDate"
+  , "MatchVal"
+  , "MatchYMD"
+  , "Decimal"
+  , "Transfer"
+  , "BudgetCurrency"
+  , "Manual"
+  , "Exchange"
+  , "Amount"
+  , "AmountType"
+  , "SplitNum"
+  , "Global"
+  , "SqlConfig"
   ]
 
 -------------------------------------------------------------------------------
 -- lots of instances for dhall types
 
-deriving instance Eq Currency
-
 deriving instance Lift Currency
 
 deriving instance Hashable Currency
 
-deriving instance Eq Tag
-
 deriving instance Lift Tag
 
 deriving instance Hashable Tag
 
-deriving instance Eq TimeUnit
-
 deriving instance Ord TimeUnit
 
-deriving instance Show TimeUnit
-
 deriving instance Hashable TimeUnit
 
-deriving instance Eq Weekday
-
 deriving instance Ord Weekday
 
-deriving instance Show Weekday
-
 deriving instance Hashable Weekday
 
 deriving instance Enum Weekday
 
-deriving instance Eq WeekdayPat
-
 deriving instance Ord WeekdayPat
 
-deriving instance Show WeekdayPat
-
 deriving instance Hashable WeekdayPat
 
-deriving instance Show RepeatPat
-
-deriving instance Eq RepeatPat
-
 deriving instance Ord RepeatPat
 
 deriving instance Hashable RepeatPat
 
-deriving instance Show MDYPat
-
-deriving instance Eq MDYPat
-
 deriving instance Ord MDYPat
 
 deriving instance Hashable MDYPat
 
-deriving instance Eq Gregorian
-
-deriving instance Show Gregorian
-
 deriving instance Hashable Gregorian
 
-deriving instance Eq GregorianM
-
-deriving instance Show GregorianM
-
 deriving instance Hashable GregorianM
 
 -- Dhall.TH rearranges my fields :(
@@ -144,34 +154,18 @@ instance Ord GregorianM where
     GregorianM {gmYear = y, gmMonth = m}
     GregorianM {gmYear = y', gmMonth = m'} = compare y y' <> compare m m'
 
-deriving instance Eq Interval
-
-deriving instance Ord Interval
-
 deriving instance Hashable Interval
 
-deriving instance Eq ModPat
-
 deriving instance Ord ModPat
 
-deriving instance Show ModPat
-
 deriving instance Hashable ModPat
 
-deriving instance Eq CronPat
-
 deriving instance Ord CronPat
 
-deriving instance Show CronPat
-
 deriving instance Hashable CronPat
 
-deriving instance Eq DatePat
-
 deriving instance Ord DatePat
 
-deriving instance Show DatePat
-
 deriving instance Hashable DatePat
 
 data Budget = Budget
@@ -184,18 +178,8 @@ data Budget = Budget
   , shadowTransfers :: [ShadowTransfer]
   }
 
-deriving instance Eq Budget
-
-deriving instance Generic Budget
-
 deriving instance Hashable Budget
 
-deriving instance FromDhall Budget
-
-deriving instance Show TaggedAcnt
-
-deriving instance Eq TaggedAcnt
-
 deriving instance Hashable TaggedAcnt
 
 deriving instance Ord TaggedAcnt
@@ -213,32 +197,14 @@ data Income = Income
   , incToBal :: TaggedAcnt
   }
 
-deriving instance Eq Income
-
-deriving instance Generic Income
-
 deriving instance Hashable Income
 
-deriving instance FromDhall Income
-
-deriving instance Show Amount
-
-deriving instance Eq Amount
-
 deriving instance Ord Amount
 
 deriving instance Hashable Amount
 
-deriving instance Show Exchange
-
-deriving instance Eq Exchange
-
 deriving instance Hashable Exchange
 
-deriving instance Show BudgetCurrency
-
-deriving instance Eq BudgetCurrency
-
 deriving instance Hashable BudgetCurrency
 
 data Allocation_ a = Allocation_
@@ -246,28 +212,14 @@ data Allocation_ a = Allocation_
   , alloAmts :: [a]
   , alloCur :: BudgetCurrency
   }
-  deriving (Show)
+  deriving (Eq, Show, Generic, Hashable)
+
+deriving instance FromDhall a => FromDhall (Allocation_ a)
 
 type Allocation = Allocation_ Amount
 
-deriving instance Eq Allocation
-
-deriving instance Generic Allocation
-
-deriving instance Hashable Allocation
-
-deriving instance FromDhall Allocation
-
 type IntervalAllocation = Allocation_ IntervalAmount
 
-deriving instance Eq IntervalAllocation
-
-deriving instance Generic IntervalAllocation
-
-deriving instance Hashable IntervalAllocation
-
-deriving instance FromDhall IntervalAllocation
-
 toPersistText :: Show a => a -> PersistValue
 toPersistText = PersistText . T.pack . show
 
@@ -278,42 +230,40 @@ fromPersistText what (PersistText t) = case readMaybe $ T.unpack t of
 fromPersistText what x =
   Left $ T.unwords ["error when deserializing", what, "; got", T.pack (show x)]
 
-deriving instance Show AmountType
-
-deriving instance Eq AmountType
-
 deriving instance Ord AmountType
 
 deriving instance Hashable AmountType
 
-data TimeAmount a = TimeAmount
-  { taWhen :: a
-  , taAmt :: Amount
-  , taAmtType :: AmountType
-  }
-  deriving (Show, Eq, Ord, Functor, Generic, FromDhall, Hashable, Foldable, Traversable)
+-- data TimeAmount a = TimeAmount
+--   { taWhen :: a
+--   , taAmt :: Amount
+--   , taAmtType :: AmountType
+--   }
+--   deriving (Show, Eq, Ord, Functor, Generic, FromDhall, Hashable, Foldable, Traversable)
+
+deriving instance Show a => Show (TimeAmount a)
+
+deriving instance Eq a => Eq (TimeAmount a)
+
+deriving instance Ord a => Ord (TimeAmount a)
+
+deriving instance Functor TimeAmount
+
+deriving instance Foldable TimeAmount
+
+deriving instance Traversable TimeAmount
+
+deriving instance Generic (TimeAmount a)
+
+deriving instance Hashable a => Hashable (TimeAmount a)
+
+deriving instance FromDhall a => FromDhall (TimeAmount a)
 
 type DateAmount = TimeAmount DatePat
 
--- deriving instance Eq DateAmount
-
--- deriving instance Generic DateAmount
-
--- deriving instance Hashable DateAmount
-
--- deriving instance FromDhall DateAmount
-
 type IntervalAmount = TimeAmount Interval
 
--- deriving instance Eq IntervalAmount
-
--- deriving instance Ord IntervalAmount
-
--- deriving instance Generic IntervalAmount
-
--- deriving instance Hashable IntervalAmount
-
--- deriving instance FromDhall IntervalAmount
+deriving instance Ord Interval
 
 data Transfer = Transfer
   { transFrom :: TaggedAcnt
@@ -322,52 +272,24 @@ data Transfer = Transfer
   , transCurrency :: BudgetCurrency
   }
 
-deriving instance Eq Transfer
-
-deriving instance Generic Transfer
-
 deriving instance Hashable Transfer
 
-deriving instance FromDhall Transfer
-
-deriving instance Eq ShadowTransfer
-
 deriving instance Hashable ShadowTransfer
 
-deriving instance Eq AcntSet
-
 deriving instance Hashable AcntSet
 
-deriving instance Eq ShadowMatch
-
 deriving instance Hashable ShadowMatch
 
-deriving instance Eq MatchVal
-
 deriving instance Hashable MatchVal
 
-deriving instance Show MatchVal
-
-deriving instance Eq MatchYMD
-
 deriving instance Hashable MatchYMD
 
-deriving instance Show MatchYMD
-
-deriving instance Eq MatchDate
-
 deriving instance Hashable MatchDate
 
-deriving instance Show MatchDate
-
-deriving instance Eq Decimal
-
 deriving instance Ord Decimal
 
 deriving instance Hashable Decimal
 
-deriving instance Show Decimal
-
 -- TODO this just looks silly...but not sure how to simplify it
 instance Ord MatchYMD where
   compare (Y y) (Y y') = compare y y'
@@ -390,14 +312,8 @@ instance Ord MatchDate where
   compare (On d) (In d' _) = compare d d' <> LT
   compare (In d _) (On d') = compare d d' <> GT
 
-deriving instance Eq SplitNum
-
 deriving instance Hashable SplitNum
 
-deriving instance Show SplitNum
-
-deriving instance Eq Manual
-
 deriving instance Hashable Manual
 
 -------------------------------------------------------------------------------
@@ -473,19 +389,18 @@ data Statement
   | StmtImport !Import
   deriving (Eq, Hashable, Generic, FromDhall)
 
-data Split a v c t = Split
-  { sAcnt :: !a
-  , sValue :: !v
-  , sCurrency :: !c
-  , sComment :: !T.Text
-  , sTags :: ![t]
-  }
-  deriving (Eq, Generic, Hashable, Show)
-
 type ExpSplit = Split SplitAcnt (Maybe SplitNum) SplitCur TagID
 
 instance FromDhall ExpSplit
 
+deriving instance (Show a, Show c, Show v, Show t) => Show (Split a v c t)
+
+deriving instance Generic (Split a v c t)
+
+deriving instance (Hashable a, Hashable v, Hashable c, Hashable t) => Hashable (Split a v c t)
+
+deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Split a v c t)
+
 data Tx s = Tx
   { txDescr :: !T.Text
   , txDate :: !Day
@@ -530,11 +445,19 @@ type SplitCur = SplitText CurID
 
 type SplitAcnt = SplitText AcntID
 
-data Field k v = Field
-  { fKey :: !k
-  , fVal :: !v
-  }
-  deriving (Show, Eq, Hashable, Generic, FromDhall, Foldable, Traversable)
+deriving instance (Show k, Show v) => Show (Field k v)
+
+deriving instance (Eq k, Eq v) => Eq (Field k v)
+
+deriving instance Generic (Field k v)
+
+deriving instance (Hashable k, Hashable v) => Hashable (Field k v)
+
+deriving instance Foldable (Field k)
+
+deriving instance Traversable (Field k)
+
+deriving instance (FromDhall k, FromDhall v) => FromDhall (Field k v)
 
 instance Functor (Field f) where
   fmap f (Field k v) = Field k $ f v

From 4098e720603735c05c9762889d71482f385c6eb9 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sun, 30 Apr 2023 00:16:06 -0400
Subject: [PATCH 02/15] ENH update types and use deferred allocation math

---
 dhall/Types.dhall         | 997 ++++++++++++++++++++++++++++++++------
 lib/Internal/Insert.hs    | 527 ++++++++++----------
 lib/Internal/Statement.hs |   6 +-
 lib/Internal/Types.hs     | 216 +++++----
 lib/Internal/Utils.hs     |  62 +--
 5 files changed, 1270 insertions(+), 538 deletions(-)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index 0425e75..fde6cfe 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -2,34 +2,200 @@ let Map =
       https://prelude.dhall-lang.org/v21.1.0/Map/Type
         sha256:210c7a9eba71efbb0f7a66b3dcf8b9d3976ffc2bc0e907aadfb6aa29c333e8ed
 
-let CurID = Text
+let List/map =
+      https://prelude.dhall-lang.org/v21.1.0/List/map
+        sha256:dd845ffb4568d40327f2a817eb42d1c6138b929ca758d50bc33112ef3c885680
 
-let AcntID = Text
+let AccountTree
+    : Type
+    =
+      {-
+      Recursive type representing a tree of accounts.
 
-let TagID = Text
+      A node in the tree can either be an account (leaf) which has a name
+      and description, or a placeholder (branch) which has name, description,
+      and a non-empty list of accounts or other placeholders.
+      -}
+      forall (a : Type) ->
+      forall  ( Fix
+              : < AccountF : { _1 : Text, _2 : Text }
+                | PlaceholderF :
+                    { _1 : Text
+                    , _2 : Text
+                    , _3 :
+                        {- TODO nonempty? -}
+                        List a
+                    }
+                > ->
+                  a
+              ) ->
+        a
 
-let SqlConfig {- TODO pgsql -} = < Sqlite : Text | Postgres >
+let AccountTreeF =
+    {-
+    Fixed type abstraction for an account tree.
+    -}
+      \(a : Type) ->
+        < AccountF : { _1 : Text, _2 : Text }
+        | PlaceholderF : { _1 : Text, _2 : Text, _3 : List a }
+        >
 
-let Currency = { curSymbol : CurID, curFullname : Text }
+let Account
+    : Text -> Text -> AccountTree
+    =
+      {-
+      Smart constructor to build an account node in an account tree.
+      -}
+      \(desc : Text) ->
+      \(name : Text) ->
+      \(a : Type) ->
+        let f = AccountTreeF a
 
-let Tag = { tagID : TagID, tagDesc : Text }
+        in  \(Fix : f -> a) -> Fix (f.AccountF { _1 = desc, _2 = name })
 
-let Gregorian = { gYear : Natural, gMonth : Natural, gDay : Natural }
+let Placeholder
+    : Text -> Text -> List AccountTree -> AccountTree
+    =
+      {-
+      Smart constructor to build a placeholder node in an account tree.
+      -}
+      \(desc : Text) ->
+      \(name : Text) ->
+      \(children : List AccountTree) ->
+      \(a : Type) ->
+        let f = AccountTreeF a
 
-let GregorianM = { gmYear : Natural, gmMonth : Natural }
+        in  \(Fix : f -> a) ->
+              let apply = \(x : AccountTree) -> x a Fix
 
-let Interval = { intStart : Gregorian, intEnd : Optional Gregorian }
+              in  Fix
+                    ( f.PlaceholderF
+                        { _1 = desc
+                        , _2 = name
+                        , _3 = List/map AccountTree a apply children
+                        }
+                    )
 
-let Global = { budgetInterval : Interval, statementInterval : Interval }
+let AcntID =
+    {-
+    A unique ID for an account; the exact ID associated with each account
+    depends on the path in which each account exists in a tree. If the leaf
+    node of an account's path is totally unique, this ID will be that leaf node.
+    If not, then branch nodes will be appended to the front (delimited by
+    underscores) until the ID is unique.
+
+    This ID will be used throughout the config to refer to a specific account.
+    -}
+      Text
+
+let CurID =
+    {-
+    A unique, short (usually three uppercase characters) ID for a currency;
+    this symbol will be used throughout the configuration to signify a
+    particular currency
+    -}
+      Text
+
+let Currency =
+    {-
+    A unit of exchange.
+    -}
+      { curSymbol : CurID
+      , curFullname :
+          {-
+          The full description of this currency (eg "Yugoslavian Twitcoin")
+          -}
+          Text
+      }
+
+let TagID =
+    {-
+    A unique ID for a tag. This ID will be used throughout the configuration
+    to refer to a specific tag.
+    -}
+      Text
+
+let Tag =
+    {-
+    A short metadata identifier associated with an account or entry.
+    -}
+      { tagID : TagID
+      , tagDesc :
+          {-
+          A description to convey the meaning of this tag.
+          -}
+          Text
+      }
+
+let SqlConfig {- TODO pgsql -} =
+    {-
+    How to connect to a SQL database. Only SQLite is supported, in which case
+    the only parameter is the output path of the db file.
+    -}
+      < Sqlite : Text | Postgres >
+
+let Gregorian =
+    {-
+    A full date like 1976-04-01
+    -}
+      { gYear : Natural, gMonth : Natural, gDay : Natural }
+
+let GregorianM =
+    {-
+    Like a Gregorian but without the month
+    -}
+      { gmYear : Natural, gmMonth : Natural }
+
+let Interval =
+    {-
+    An interval in time. If end is None, the interval ends at 'forever'
+    -}
+      { intStart : Gregorian, intEnd : Optional Gregorian }
+
+let TemporalScope =
+    {-
+    The range of times that will be considered when computing transactions.
+    -}
+      { budgetInterval : Interval, statementInterval : Interval }
 
 let TimeUnit = < Day | Week | Month | Year >
 
 let Weekday = < Mon | Tue | Wed | Thu | Fri | Sat | Sun >
 
 let RepeatPat =
-      { rpStart : Natural, rpBy : Natural, rpRepeats : Optional Natural }
+    {-
+    Means to match a repeated set of numeric values.
+    -}
+      { rpStart :
+          {-
+          Initial value to match
+          -}
+          Natural
+      , rpBy :
+          {-
+          Distance between each repeated value
+          -}
+          Natural
+      , rpRepeats :
+          {-
+          Number of repeats after initial value to match. If not given, this
+          number continues until an upper bound determined from context.
+          -}
+          Optional Natural
+      }
 
 let MDYPat =
+    {-
+    Means to match either a year, month, or day in a date (the matched component
+    is determined by context)
+
+    Single: match a single number
+    Multi: match several numbers
+    Repeat: match a repeated pattern
+    After: match any number greater than a given value
+    Before: match any number less than a given value
+    Between: match any number between two values
+    -}
       < Single : Natural
       | Multi : List Natural
       | Repeat : RepeatPat
@@ -39,18 +205,51 @@ let MDYPat =
       >
 
 let ModPat =
+    {-
+    Means to match a date using modular arithmetic.
+    -}
       { Type =
-          { mpStart : Optional Gregorian
-          , mpBy : Natural
-          , mpUnit : TimeUnit
-          , mpRepeats : Optional Natural
+          { mpStart :
+              {-
+              The starting date to begin matching. If not given, start at the
+              beginning of whatever global time window is active.
+              -}
+              Optional Gregorian
+          , mpBy :
+              {-
+              Numeric number of temporal units to repeat before next match.
+              -}
+              Natural
+          , mpUnit :
+              {-
+              Unit of each interval
+              -}
+              TimeUnit
+          , mpRepeats :
+              {-
+              Number of repeats to match. If not given, match all repeats until
+              the end of the active global interval
+              -}
+              Optional Natural
           }
       , default = { mpStart = None Gregorian, mpRepeats = None Natural }
       }
 
-let WeekdayPat = < OnDay : Weekday | OnDays : List Weekday >
+let WeekdayPat =
+    {-
+    Means to match a given day of week
+
+    OnDay: Match a single weekday
+    OnDays: Match multiple weekdays
+    -}
+      < OnDay : Weekday | OnDays : List Weekday >
 
 let CronPat =
+    {-
+    Means of matching dates according to their component parts.
+
+    This is similar to 'cron' patterns in unix-like systems.
+    -}
       { Type =
           { cronWeekly : Optional WeekdayPat
           , cronYear : Optional MDYPat
@@ -65,19 +264,53 @@ let CronPat =
         }
       }
 
-let DatePat = < Cron : CronPat.Type | Mod : ModPat.Type >
+let DatePat =
+    {-
+    Means of matching dates
+
+    Cron: use cron-like date matching
+    Mod: use modular temporal arithmetic matching
+    -}
+      < 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 =
-          { toDate : Text
-          , toAmount : Text
-          , toDesc : Text
-          , toOther : List Text
-          , toDateFmt : Text
-          , toAmountFmt : Text
+          { toDate :
+              {-
+              Column title for date
+              -}
+              Text
+          , toAmount :
+              {-
+              Column title for amount
+              -}
+              Text
+          , toDesc :
+              {-
+              Column title for description
+              -}
+              Text
+          , toOther :
+              {-
+              Titles of other columns to include; these will be available in
+              a map for use in downstream processing (see 'Field')
+              -}
+              List Text
+          , toDateFmt :
+              {-
+              Format of the date field as specified in the
+              Data.Time.Format.formattime Haskell function.
+              -}
+              Text
+          , toAmountFmt :
+              {- Format of the amount field. Must include three fields for the
+              sign, numerator, and denominator of the amount.
+              -}
+              Text
           }
       , default =
         { toDate = "Date"
@@ -89,16 +322,48 @@ let TxOpts =
         }
       }
 
-let Field = \(k : Type) -> \(v : Type) -> { fKey : k, fVal : v }
+let Field =
+    {-
+    General key-value type
+    -}
+      \(k : Type) -> \(v : Type) -> { fKey : k, fVal : v }
 
-let FieldMap = \(k : Type) -> \(v : Type) -> Field k (Map k v)
+let FieldMap =
+    {-
+    Key-value type where key maps to a Map with key of the same type
+    -}
+      \(k : Type) -> \(v : Type) -> Field k (Map k v)
 
-let MatchVal =
+let ValMatcher =
+    {-
+    Means to match a decimal value.
+    -}
       { Type =
-          { mvSign : Optional Bool
-          , mvNum : Optional Natural
-          , mvDen : Optional Natural
-          , mvPrec : Natural
+          { mvSign :
+              {-
+              Sign of value.
+              True -> positive,
+              False -> negative,
+              None -> do not consider.
+              -}
+              Optional Bool
+          , mvNum :
+              {-
+              Value of numerator to match. Do not consider numerator if none
+              -}
+              Optional Natural
+          , mvDen :
+              {-
+              Value of denominator to match. Do not consider numerator if none
+              -}
+              Optional Natural
+          , mvPrec :
+              {-
+              Precision of decimal to use when matching. This only affects the
+              denominator, such that a query of '10.1' with a precision of 2
+              will have a denominator of '10'
+              -}
+              Natural
           }
       , default =
         { mvSign = None Bool
@@ -108,18 +373,46 @@ let MatchVal =
         }
       }
 
-let MatchYMD = < Y : Natural | YM : GregorianM | YMD : Gregorian >
+let YMDMatcher =
+    {-
+    Means to match a given date with varying precision
+    -}
+      < Y : Natural | YM : GregorianM | YMD : Gregorian >
 
-let MatchDate = < On : MatchYMD | In : { _1 : MatchYMD, _2 : Natural } >
+let DateMatcher =
+    {-
+    Means to match either one discrete date or a range of dates
+    -}
+      < On : YMDMatcher | In : { _1 : YMDMatcher, _2 : Natural } >
 
-let MatchOther_ =
-      \(re : Type) -> < Desc : Field Text re | Val : Field Text MatchVal.Type >
+let FieldMatcher_ =
+    {-
+    Means to match a given field (either textual or numeric)
+    -}
+      \(re : Type) ->
+        < Desc : Field Text re | Val : Field Text ValMatcher.Type >
 
-let MatchOther = MatchOther_ Text
+let FieldMatcher = FieldMatcher_ Text
 
-let SplitNum = < LookupN : Text | ConstN : Decimal | AmountN >
+let EntryNumGetter =
+    {-
+    Means to get a numeric value from a statement row.
 
-let SplitText =
+    LookupN: lookup the value from a field
+    ConstN: a constant value
+    AmountN: the value of the 'Amount' column
+    -}
+      < LookupN : Text | ConstN : Decimal | AmountN >
+
+let EntryTextGetter =
+    {-
+    Means to get a textual value from a statement row.
+
+    ConstT: a constant value
+    LookupT: lookup the value of a field
+    MapT: use the value of a column as the key for a map
+    Map2T: use the paired value of 2 columns as the key for a map
+    -}
       \(t : Type) ->
         < ConstT : t
         | LookupT : Text
@@ -127,164 +420,549 @@ let SplitText =
         | Map2T : FieldMap { _1 : Text, _2 : Text } t
         >
 
-let SplitCur = SplitText CurID
+let EntryCurGetter =
+    {-
+    Means to get a currency ID from a statement row.
+    -}
+      EntryTextGetter CurID
 
-let SplitAcnt = SplitText AcntID
+let EntryAcntGetter =
+    {-
+    Means to get an account ID from a statement row.
+    -}
+      EntryTextGetter AcntID
 
-let Split =
+let Entry =
+    {-
+    General type describing a single line item in an account.
+
+    The polymorphism of this type allows representation of an actual line
+    item itself as well as the means to get a line item from other data.
+    -}
       \(a : Type) ->
       \(v : Type) ->
       \(c : Type) ->
       \(t : Type) ->
-        { sAcnt : a
-        , sValue : v
-        , sCurrency : c
-        , sComment : Text
-        , sTags : List t
+        { sAcnt :
+            {-
+            Pertains to account for this entry.
+            -}
+            a
+        , sValue :
+            {-
+            Pertains to value for this entry.
+            -}
+            v
+        , sCurrency :
+            {-
+            Pertains to value for this entry.
+            -}
+            c
+        , sComment :
+            {-
+            A short description of this entry (if none, use a blank string)
+            -}
+            Text
+        , sTags :
+            {-
+            Pertains to the tags to describe this entry.
+            -}
+            List t
         }
 
-let ExpSplit =
-      { Type = Split SplitAcnt (Optional SplitNum) SplitCur TagID
-      , default = { sValue = None SplitNum, sComment = "" }
+let EntryGetter =
+    {-
+    Means for getting an entry from a given row in a statement
+    -}
+      { Type =
+          Entry EntryAcntGetter (Optional EntryNumGetter) EntryCurGetter TagID
+      , default = { sValue = None EntryNumGetter, sComment = "" }
       }
 
-let ToTx =
-      { ttCurrency : SplitCur
-      , ttPath : SplitAcnt
-      , ttSplit : List ExpSplit.Type
+let TxGetter =
+    {-
+    A means for transforming one row in a statement to a transaction
+
+    Note that N-1 entries need to be specified to make a transaction, as the
+    Nth entry will be balanced with the others.
+    -}
+      { tgEntries :
+          {-
+          A means of getting entries for this transaction (minimum 1)
+          -}
+          List EntryGetter.Type
+      , tgCurrency :
+          {-
+          Currency against which entries in this transaction will be balanced
+          -}
+          EntryCurGetter
+      , tgAcnt :
+          {-
+          Account in which entries in this transaction will be balanced
+          -}
+          EntryAcntGetter
       }
 
-let Match_ =
+let StatementParser_ =
+    {-
+    A recipe to match and transform a given entry in a statement to a
+    transaction between 2 or more accounts.
+
+    Polymorphism allows regular expressions to be computed and cached within
+    the type during parsing.
+    -}
       \(re : Type) ->
         { Type =
-            { mDate : Optional MatchDate
-            , mVal : MatchVal.Type
-            , mDesc : Optional re
-            , mOther : List (MatchOther_ re)
-            , mTx : Optional ToTx
-            , mTimes : Optional Natural
-            , mPriority : Integer
+            { mDate :
+                {-
+                How to match the date column; if none match any date
+                -}
+                Optional DateMatcher
+            , mVal :
+                {-
+                How to match the value column; if none match any value
+                -}
+                ValMatcher.Type
+            , mDesc :
+                {-
+                Regular expression to match the description;
+                if none match anythingS
+                -}
+                Optional re
+            , mOther :
+                {-
+                How to match additional columns if present
+                -}
+                List (FieldMatcher_ re)
+            , mTx :
+                {-
+                How to translate the matched statement row into entries for
+                a transaction. If none, don't make a transaction (eg 'skip'
+                this row in the statement).
+                -}
+                Optional TxGetter
+            , mTimes :
+                {-
+                Match at most this many rows; if none there is no limit
+                -}
+                Optional Natural
+            , mPriority :
+                {-
+                In case of multiple matches, higher priority gets precedence.
+                -}
+                Integer
             }
         , default =
-          { mDate = None MatchDate
-          , mVal = MatchVal::{=}
+          { mDate = None DateMatcher
+          , mVal = ValMatcher::{=}
           , mDesc = None Text
-          , mOther = [] : List (MatchOther_ re)
-          , mTx = None ToTx
+          , mOther = [] : List (FieldMatcher_ re)
+          , mTx = None EntryGetter.Type
           , mTimes = None Natural
           , mPriority = +0
           }
         }
 
-let Match = Match_ Text
+let StatementParser =
+    {-
+    A statement parser specialized to raw regular expressions.
+    -}
+      StatementParser_ Text
 
-let Manual =
-      { manualDate : DatePat
-      , manualFrom : AcntID
-      , manualTo : AcntID
-      , manualValue : Decimal
-      , manualDesc : Text
-      , manualCurrency : CurID
+let Amount =
+    {-
+    A quantify of currency at a given time.
+    -}
+      \(w : Type) ->
+      \(v : Type) ->
+        { amtWhen : w, amtValue : v, amtDesc : Text }
+
+let Transfer =
+    {-
+    1-1 transaction(s) between two accounts.
+    -}
+      \(a : Type) ->
+      \(c : Type) ->
+      \(w : Type) ->
+      \(v : Type) ->
+        { transFrom : a
+        , transTo : a
+        , transCurrency : c
+        , transAmounts : List (Amount w v)
+        }
+
+let HistTransfer =
+    {-
+    A manually specified historical transfer
+    -}
+      Transfer AcntID CurID DatePat Decimal
+
+let Statement =
+    {-
+    How to import a statement from local file(s). Statements are assumed to be
+    tabular with one statement per row.
+    -}
+      { stmtPaths
+        {-
+        paths to statement files
+        -}
+        : List Text
+      , stmtParsers
+        {-
+        parsers to match statements
+        -}
+        : List StatementParser.Type
+      , stmtDelim
+        {-
+        file delimiter as a numeric char, usually either tab (9) or comma (44)
+        -}
+        : Natural
+      , stmtTxOpts : TxOpts.Type
+      , stmtSkipLines
+        {-
+        how many lines to skip before parsing statement
+        -}
+        : Natural
       }
 
-let Import =
-      { impPaths : List Text
-      , impMatches : List Match.Type
-      , impDelim : Natural
-      , impTxOpts : TxOpts.Type
-      , impSkipLines : Natural
-      }
-
-let Statement = < StmtManual : Manual | StmtImport : Import >
-
-let Amount = { amtValue : Decimal, amtDesc : Text }
-
-let AmountType = < FixedAmt | Percent | Target >
-
-let TimeAmount =
-      \(t : Type) -> { taWhen : t, taAmt : Amount, taAmtType : AmountType }
-
-let DateAmount = TimeAmount DatePat
+let History =
+    {-
+    How to generate historical transactions; either specified as manual
+    transfers or via statements in files on local disk
+    -}
+      < HistTransfer : HistTransfer | HistStatement : Statement >
 
 let Exchange =
-      { xFromCur : CurID, xToCur : CurID, xAcnt : AcntID, xRate : Decimal }
+    {-
+    A currency exchange.
+    -}
+      { xFromCur :
+          {-
+          Starting currency of the exchange.
+          -}
+          CurID
+      , xToCur :
+          {-
+          Ending currency of the exchange.
+          -}
+          CurID
+      , xAcnt :
+          {-
+          account in which the exchange will be documented.
+          -}
+          AcntID
+      , xRate :
+          {-
+          The exchange rate between the currencies.
+          -}
+          Decimal
+      }
 
-let BudgetCurrency = < NoX : CurID | X : Exchange >
+let BudgetCurrency =
+    {-
+    A 'currency' in the budget; either a fixed currency or an exchange
+    -}
+      < NoX : CurID | X : Exchange >
 
-let TaggedAcnt = { taAcnt : AcntID, taTags : List TagID }
+let TaggedAcnt =
+    {-
+    An account with a tag
+    -}
+      { taAcnt : AcntID, taTags : List TagID }
 
-let Allocation_ =
-      \(t : Type) ->
-        { alloTo : TaggedAcnt, alloAmts : List t, alloCur : BudgetCurrency }
+let Allocation =
+    {-
+    How to allocate a given budget stream. This can be thought of as a Transfer
+    without an incoming account specified.
+    -}
+      \(w : Type) ->
+      \(v : Type) ->
+        { alloTo : TaggedAcnt
+        , alloAmts : List (Amount w v)
+        , alloCur :
+            {-TODO allow exchanges here-}
+            CurID
+        }
 
-let Allocation = Allocation_ Amount
+let PretaxValue =
+    {-
+    How to determine value of a pretax allocation.
+    -}
+      { preValue :
+          {-
+          The value to be deducted from gross income
+          -}
+          Decimal
+      , prePercent :
+          {-
+          If true, value is interpreted as a percent of gross income instead of
+          a fixed amount.
+          -}
+          Bool
+      , preCategory :
+          {-
+          A category for this allocation. This is used when calculating taxes,
+          which match against this to determine how much to deduct from the
+          gross income stream.
+          -}
+          Text
+      }
 
-let IntervalAllocation = Allocation_ (TimeAmount Interval)
+let TaxBracket =
+    {-
+    A single tax bracket. Read as "every unit above limit is taxed at this
+    percentage".
+    -}
+      { tbLowerLimit : Decimal, tbPercent : Decimal }
+
+let TaxProgression =
+    {-
+    A tax progression using a deductible and a series of tax brackets.
+    This will cover simple cases of the US income tax as of 2017 and similar.
+    -}
+      { tbsDeductible :
+          {-
+          Initial amount to subtract from after-pretax-deductions
+          -}
+          Decimal
+      , tbsBrackets :
+          {-
+          Tax brackets to apply after deductions (order does not matter, each
+          entry will be sorted by limit)
+          -}
+          List TaxBracket
+      }
+
+let TaxMethod =
+    {-
+    How to implement a given tax (either a progressive tax or a fixed percent)
+    -}
+      < TMBracket : TaxProgression | TMPercent : Decimal >
+
+let TaxValue =
+    {-
+    Means to determine value of an income tax allocation.
+    -}
+      { tvCategories :
+          {-
+          A list of categories corresponding to pretax allocations. Taxable
+          income (from the perspective of this type) will be determined by
+          subtracting matching allocations from gross income.
+          -}
+          List Text
+      , tvMethod : TaxMethod
+      }
+
+let PosttaxValue =
+    {-
+    Means to determine value of a post tax allocation.
+    -}
+      { postValue :
+          {-
+          The value to be deducted from income remaining after taxes.
+          -}
+          Decimal
+      , postPercent :
+          {-
+          If true, subtract a percentage from the after-tax remainder instead
+          of a fixed value.
+          -}
+          Bool
+      }
+
+let SingleAllocation =
+    {-
+    An allocation specialized to an income stream (which means the timing is
+    dictated by the income stream)
+    -}
+      Allocation {}
+
+let MultiAllocation =
+    {-
+    An allocation specialized to capturing multiple income streams within a given
+    time period (useful for instances where an allocation might change independent
+    of a change in income)
+    -}
+      Allocation Interval
 
 let Income =
+    {-
+    Means to compute an income stream and how to allocate it
+    -}
       { Type =
-          { incGross : Decimal
-          , incCurrency : CurID
-          , incWhen : DatePat
-          , incPretax : List Allocation
-          , incTaxes : List Allocation
-          , incPosttax : List Allocation
+          { incGross :
+              {-
+              The value of the income stream.
+              -}
+              Decimal
+          , incCurrency :
+              {-
+              The currency in which the income stream is denominated.
+              -}
+              CurID
+          , incWhen :
+              {-
+              The dates on which the income stream is distributed.
+              -}
+              DatePat
+          , incPretax : List (SingleAllocation PretaxValue)
+          , incTaxes : List (SingleAllocation TaxValue)
+          , incPosttax : List (SingleAllocation PosttaxValue)
           , incFrom :
-              {- this must be an income AcntID, and is the only place income
-              accounts may be specified in the entire budget -}
+              {-
+              The account in which the income is recorded.
+
+              This must be an income AcntID, and is the only place income
+              accounts may be specified in the entire budget.
+              -}
+              TaggedAcnt
+          , incToBal :
+              {-
+              The account to which to send the remainder of the income stream
+              (if any) after all allocations have been applied.
+              -}
               TaggedAcnt
-          , incToBal : TaggedAcnt
           }
       , default =
-        { incPretax = [] : List Allocation
-        , incTaxes = [] : List Allocation
-        , incPosttaxx = [] : List Allocation
+        { incPretax = [] : List (SingleAllocation PretaxValue)
+        , incTaxes = [] : List (SingleAllocation TaxValue)
+        , incPosttaxx = [] : List (SingleAllocation PosttaxValue)
         }
       }
 
-let Transfer =
-      { transFrom : TaggedAcnt
-      , transTo : TaggedAcnt
-      , transAmounts : List DateAmount
-      , transCurrency : BudgetCurrency
-      }
-
 let AcntSet =
-      { Type = { asList : List AcntID, asInclude : Bool }
+    {-
+    A list of account IDs represented as a set.
+    -}
+      { Type =
+          { asList : List AcntID
+          , asInclude :
+              {-
+              If true, tests for account membership in this set will return
+              true if the account is in the set. Invert this behavior otherwise.
+              -}
+              Bool
+          }
       , default = { asList = [] : List AcntID, asInclude = False }
       }
 
-let ShadowMatch =
+let TransferMatcher =
+    {-
+    Means to match a transfer (which will be used to "clone" it in some
+    fashion)
+    -}
       { Type =
-          { smFrom : AcntSet.Type
-          , smTo : AcntSet.Type
-          , smDate : Optional MatchDate
-          , smVal : MatchVal.Type
+          { smFrom :
+              {-
+              List of accounts (which may be empty) to match with the
+              starting account in a transfer.
+              -}
+              AcntSet.Type
+          , smTo :
+              {-
+              List of accounts (which may be empty) to match with the
+              ending account in a transfer.
+              -}
+              AcntSet.Type
+          , smDate :
+              {-
+              If given, means to match the date of a transfer.
+              -}
+              Optional DateMatcher
+          , smVal :
+              {-
+              If given, means to match the value of a transfer.
+              -}
+              ValMatcher.Type
           }
       , default =
         { smFrom = AcntSet.default
         , smTo = AcntSet.default
-        , smDate = None MatchDate
-        , smVal = MatchVal.default
+        , smDate = None DateMatcher
+        , smVal = ValMatcher.default
         }
       }
 
+let BudgetTransferType =
+    {-
+    The type of a budget transfer.
+
+    BTFixed: Tranfer a fixed amount
+    BTPercent: Transfer a percent of the source account to destination
+    BTTarget: Transfer an amount such that the destination has a given target
+              value
+    -}
+      < BTPercent | BTTarget | BTFixed >
+
 let ShadowTransfer =
-      { stFrom : TaggedAcnt
-      , stTo : TaggedAcnt
-      , stCurrency : CurID
-      , stDesc : Text
-      , stMatch : ShadowMatch.Type
-      , stRatio : Decimal
+    {-
+    A transaction analogous to another transfer with given properties.
+    -}
+      { stFrom :
+          {-
+          Source of this transfer
+          -}
+          TaggedAcnt
+      , stTo :
+          {-
+          Destination of this transfer.
+          -}
+          TaggedAcnt
+      , stCurrency :
+          {-
+          Currency of this transfer.
+          -}
+          BudgetCurrency
+      , stDesc :
+          {-
+          Description of this transfer.
+          -}
+          Text
+      , stMatch :
+          {-
+          Means to match other transfers which will be used as the basis to
+          compute this transfer. The date is taken as-is, the value is
+          multiplied by a constant (see 'stRatio') and everything else is
+          specified in other fields of this type.
+          -}
+          TransferMatcher.Type
+      , stType : BudgetTransferType
+      , stRatio :
+          {-
+          Fixed multipler to translate value of matched transfer to this one.
+          -}
+          Decimal
       }
 
+let BudgetTransferValue =
+    {-
+    Means to determine the value of a budget transfer.
+    -}
+      { btVal : Decimal, btType : BudgetTransferType }
+
+let BudgetTransfer =
+    {-
+    A manually specified transaction for a budget
+    -}
+      Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
+
 let Budget =
-      { budgetLabel : Text
+    {-
+    A hypothetical set of transactions (eg a "budget") to be generated
+    and inserted into the database.
+    -}
+      { budgetLabel :
+          {-
+          A unique label for this budget.
+
+          Can be useful to compare multiple potential futures.
+          -}
+          Text
       , incomes : List Income.Type
-      , pretax : List IntervalAllocation
-      , tax : List IntervalAllocation
-      , posttax : List IntervalAllocation
-      , transfers : List Transfer
+      , pretax : List (MultiAllocation PretaxValue)
+      , tax : List (MultiAllocation TaxValue)
+      , posttax : List (MultiAllocation PosttaxValue)
+      , transfers : List BudgetTransfer
       , shadowTransfers : List ShadowTransfer
       }
 
@@ -295,7 +973,7 @@ in  { CurID
     , Tag
     , TagID
     , Interval
-    , Global
+    , TemporalScope
     , Gregorian
     , GregorianM
     , TimeUnit
@@ -308,37 +986,42 @@ in  { CurID
     , DatePat
     , Decimal
     , TxOpts
-    , Match
-    , Match_
-    , MatchVal
-    , MatchYMD
-    , MatchDate
-    , MatchOther
-    , MatchOther_
-    , SplitNum
+    , StatementParser
+    , StatementParser_
+    , ValMatcher
+    , YMDMatcher
+    , DateMatcher
+    , FieldMatcher
+    , FieldMatcher_
+    , EntryNumGetter
     , Field
     , FieldMap
-    , Split
-    , ExpSplit
-    , SplitText
-    , SplitCur
-    , SplitAcnt
-    , ToTx
-    , Import
-    , Manual
+    , Entry
+    , EntryGetter
+    , EntryTextGetter
+    , EntryCurGetter
+    , EntryAcntGetter
     , Statement
+    , History
     , Transfer
     , Income
     , Budget
     , Allocation
-    , IntervalAllocation
     , Amount
-    , TimeAmount
-    , AmountType
-    , ShadowMatch
+    , TransferMatcher
     , ShadowTransfer
     , AcntSet
     , BudgetCurrency
     , Exchange
     , TaggedAcnt
+    , Account
+    , Placeholder
+    , PretaxValue
+    , PosttaxValue
+    , TaxBracket
+    , TaxProgression
+    , TaxMethod
+    , TaxValue
+    , BudgetTransferValue
+    , BudgetTransferType
     }
diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs
index 3d50823..ed7b945 100644
--- a/lib/Internal/Insert.hs
+++ b/lib/Internal/Insert.hs
@@ -119,21 +119,20 @@ withDates dp f = do
 
 insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError]
 insertBudget
-  b@( Budget
-        { budgetLabel
-        , incomes
-        , transfers
-        , shadowTransfers
-        , pretax
-        , tax
-        , posttax
-        }
-      ) =
+  b@Budget
+    { budgetLabel
+    , incomes
+    , transfers
+    , shadowTransfers
+    , pretax
+    , tax
+    , posttax
+    } =
     whenHash CTBudget b [] $ \key -> do
       unlessLefts intAllos $ \intAllos_ -> do
         res1 <- mapM (insertIncome key budgetLabel intAllos_) incomes
         res2 <- expandTransfers key budgetLabel transfers
-        unlessLefts (concatEithers2 (fmap concat $ concatEithersL res1) res2 (++)) $
+        unlessLefts (concatEithers2 (concat <$> concatEithersL res1) res2 (++)) $
           \txs -> do
             unlessLefts (addShadowTransfers shadowTransfers txs) $ \shadow -> do
               let bals = balanceTransfers $ txs ++ shadow
@@ -146,117 +145,120 @@ insertBudget
          in concatEithers3 pre_ tax_ post_ (,,)
       sortAllos = concatEithersL . fmap sortAllo
 
-type BoundAllocation = Allocation_ (TimeAmount (Day, Day))
+type BoundAllocation = Allocation (Day, Day)
 
-type IntAllocations = ([BoundAllocation], [BoundAllocation], [BoundAllocation])
+type IntAllocations =
+  ( [BoundAllocation PretaxValue]
+  , [BoundAllocation TaxValue]
+  , [BoundAllocation PosttaxValue]
+  )
 
--- TODO this should actually error if there is no ultimate end date
-sortAllo :: IntervalAllocation -> EitherErrs BoundAllocation
-sortAllo a@Allocation_ {alloAmts = as} = do
-  bs <- fmap reverse <$> foldBounds (Right []) $ L.sortOn taWhen as
-  return $ a {alloAmts = L.sort bs}
+-- TODO this should actually error if there is no ultimate end date?
+sortAllo :: MultiAllocation v -> EitherErrs (BoundAllocation v)
+sortAllo a@Allocation {alloAmts = as} = do
+  bs <- foldBounds (Right []) $ L.sortOn amtWhen as
+  return $ a {alloAmts = reverse bs}
   where
     foldBounds acc [] = acc
     foldBounds acc (x : xs) =
-      let res = fmap (fmap expandBounds) $ case xs of
-            [] -> mapM resolveBounds x
-            (y : _) ->
-              let end = intStart $ taWhen y
-               in mapM (resolveBounds_ end) x
-       in foldBounds (concatEithers2 (plural res) acc (:)) xs
+      let res = case xs of
+            [] -> resolveBounds $ amtWhen x
+            (y : _) -> resolveBounds_ (intStart $ amtWhen y) $ amtWhen x
+          concatRes bs acc' = x {amtWhen = expandBounds bs} : acc'
+       in foldBounds (concatEithers2 (plural res) acc concatRes) xs
 
 -- TODO this is going to be O(n*m), which might be a problem?
-addShadowTransfers :: [ShadowTransfer] -> [BudgetTxType] -> EitherErrs [BudgetTxType]
+addShadowTransfers
+  :: [ShadowTransfer]
+  -> [UnbalancedTransfer]
+  -> EitherErrs [UnbalancedTransfer]
 addShadowTransfers ms txs =
   fmap catMaybes $
     concatEitherL $
       fmap (uncurry fromShadow) $
         [(t, m) | t <- txs, m <- ms]
 
-fromShadow :: BudgetTxType -> ShadowTransfer -> EitherErr (Maybe BudgetTxType)
-fromShadow tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio} = do
+fromShadow
+  :: UnbalancedTransfer
+  -> ShadowTransfer
+  -> EitherErr (Maybe UnbalancedTransfer)
+fromShadow tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
   res <- shadowMatches (stMatch t) tx
   return $
     if not res
       then Nothing
       else
         Just $
-          BudgetTxType
-            { bttTx =
-                -- TODO does this actually share the same metadata as the "parent" tx?
-                BudgetTx
-                  { btMeta = btMeta $ bttTx tx
-                  , btWhen = btWhen $ bttTx tx
-                  , btFrom = stFrom
-                  , btTo = stTo
-                  , btValue = dec2Rat stRatio * (btValue $ bttTx tx)
-                  , btDesc = stDesc
-                  }
-            , bttType = FixedAmt
+          -- TODO does this actually share the same metadata as the "parent" tx?
+          FlatTransfer
+            { cbtMeta = cbtMeta tx
+            , cbtWhen = cbtWhen tx
+            , cbtCur = stCurrency
+            , cbtFrom = stFrom
+            , cbtTo = stTo
+            , cbtValue = UnbalancedValue stType $ dec2Rat stRatio * cvValue (cbtValue tx)
+            , cbtDesc = stDesc
             }
 
-shadowMatches :: ShadowMatch -> BudgetTxType -> EitherErr Bool
-shadowMatches ShadowMatch {smFrom, smTo, smDate, smVal} tx = do
-  -- TODO what does the amount do for each of the different types?
-  valRes <- valMatches smVal (btValue tx_)
+shadowMatches :: TransferMatcher -> UnbalancedTransfer -> EitherErr Bool
+shadowMatches TransferMatcher {smFrom, smTo, smDate, smVal} tx = do
+  valRes <- valMatches smVal $ cvValue $ cbtValue tx
   return $
-    memberMaybe (taAcnt $ btFrom tx_) smFrom
-      && memberMaybe (taAcnt $ btTo tx_) smTo
-      && maybe True (`dateMatches` (btWhen tx_)) smDate
+    memberMaybe (taAcnt $ cbtFrom tx) smFrom
+      && memberMaybe (taAcnt $ cbtTo tx) smTo
+      && maybe True (`dateMatches` cbtWhen tx) smDate
       && valRes
   where
-    tx_ = bttTx tx
     memberMaybe x AcntSet {asList, asInclude} =
       (if asInclude then id else not) $ x `elem` asList
 
-balanceTransfers :: [BudgetTxType] -> [BudgetTx]
+balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
 balanceTransfers ts =
-  snd $ L.mapAccumR go initBals $ reverse $ L.sortOn (btWhen . bttTx) ts
+  snd $ L.mapAccumR go M.empty $ reverse $ L.sortOn cbtWhen ts
   where
-    initBals =
-      M.fromList $
-        fmap (,0) $
-          L.nub $
-            fmap (btTo . bttTx) ts
-              ++ fmap (btFrom . bttTx) ts
-    updateBal x = M.update (Just . (+ x))
-    lookupBal = M.findWithDefault (error "this should not happen")
-    go bals btt =
-      let tx = bttTx btt
-          from = btFrom tx
-          to = btTo tx
-          bal = lookupBal to bals
-          x = amtToMove bal (bttType btt) (btValue tx)
-       in (updateBal x to $ updateBal (-x) from bals, tx {btValue = x})
+    go bals f@FlatTransfer {cbtFrom, cbtTo, cbtValue = UnbalancedValue {cvValue, cvType}} =
+      let (bals', v) = mapAdd cbtTo x $ mapAdd_ cbtFrom (-x) bals
+          x = amtToMove v cvType cvValue
+       in (bals', f {cbtValue = x})
     -- TODO might need to query signs to make this intuitive; as it is this will
     -- probably work, but for credit accounts I might need to supply a negative
     -- target value
-    amtToMove _ FixedAmt x = x
-    amtToMove bal Percent x = -(x / 100 * bal)
-    amtToMove bal Target x = x - bal
+    amtToMove _ BTFixed x = x
+    amtToMove bal BTPercent x = -(x / 100 * bal)
+    amtToMove bal BTTarget x = x - bal
+
+mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
+mapAdd_ k v m = fst $ mapAdd k v m
+
+mapAdd :: (Ord k, Num v) => k -> v -> M.Map k v -> (M.Map k v, v)
+mapAdd k v m = (new, M.findWithDefault (error "this should not happen") k new)
+  where
+    new = M.alter (maybe (Just v) (Just . (+ v))) k m
 
 data BudgetMeta = BudgetMeta
   { bmCommit :: !CommitRId
-  , bmCur :: !BudgetCurrency
   , bmName :: !T.Text
   }
   deriving (Show)
 
-data BudgetTx = BudgetTx
-  { btMeta :: !BudgetMeta
-  , btWhen :: !Day
-  , btFrom :: !TaggedAcnt
-  , btTo :: !TaggedAcnt
-  , btValue :: !Rational
-  , btDesc :: !T.Text
+data FlatTransfer v = FlatTransfer
+  { cbtFrom :: !TaggedAcnt
+  , cbtTo :: !TaggedAcnt
+  , cbtValue :: !v
+  , cbtWhen :: !Day
+  , cbtDesc :: !T.Text
+  , cbtMeta :: !BudgetMeta
+  , cbtCur :: !BudgetCurrency
   }
-  deriving (Show)
 
-data BudgetTxType = BudgetTxType
-  { bttType :: !AmountType
-  , bttTx :: !BudgetTx
+data UnbalancedValue = UnbalancedValue
+  { cvType :: !BudgetTransferType
+  , cvValue :: !Rational
   }
-  deriving (Show)
+
+type UnbalancedTransfer = FlatTransfer UnbalancedValue
+
+type BalancedTransfer = FlatTransfer Rational
 
 insertIncome
   :: MonadFinance m
@@ -264,179 +266,206 @@ insertIncome
   -> T.Text
   -> IntAllocations
   -> Income
-  -> SqlPersistT m (EitherErrs [BudgetTxType])
+  -> SqlPersistT m (EitherErrs [UnbalancedTransfer])
 insertIncome
   key
   name
   (intPre, intTax, intPost)
-  i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} = do
-    let meta = BudgetMeta key (NoX incCurrency) name
-    let balRes = balanceIncome i
+  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 concatEither2 balRes fromRes (,) of
-      Left es -> return $ Left es
-      -- TODO this hole seems sloppy...
-      Right (balance, _) ->
-        fmap (fmap (concat . concat)) $
-          -- 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 :(
-          withDates incWhen $ \day -> do
-            let fromAllos = fmap concat . mapM (lift . fromAllo day meta incFrom)
-            pre <- fromAllos $ incPretax ++ mapMaybe (selectAllos day) intPre
-            -- TODO ensure these are all expense accounts
-            tax <- fromAllos $ incTaxes ++ mapMaybe (selectAllos day) intTax
-            post <- fromAllos $ incPosttax ++ mapMaybe (selectAllos day) intPost
-            let bal =
-                  BudgetTxType
-                    { bttTx =
-                        BudgetTx
-                          { btMeta = meta
-                          , btWhen = day
-                          , btFrom = incFrom
-                          , btTo = incToBal
-                          , btValue = balance
-                          , btDesc = "balance after deductions"
-                          }
-                    , bttType = FixedAmt
-                    }
-            return $ concatEithersL [Right [bal], Right tax, Right pre, Right post]
+    case fromRes 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)
+    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 =
+        let (preDeductions, pre) =
+              allocatePre gross $
+                flatPre ++ concatMap (selectAllos day) intPre
+            tax =
+              allocateTax gross preDeductions $
+                flatTax ++ concatMap (selectAllos day) intTax
+            aftertaxGross = sumAllos $ tax ++ pre
+            post =
+              allocatePost aftertaxGross $
+                flatPost ++ concatMap (selectAllos day) intPost
+            balance = aftertaxGross - sumAllos post
+            bal =
+              FlatTransfer
+                { cbtMeta = meta
+                , cbtWhen = day
+                , cbtFrom = incFrom
+                , cbtCur = NoX incCurrency
+                , cbtTo = incToBal
+                , cbtValue = UnbalancedValue BTFixed balance
+                , cbtDesc = "balance after deductions"
+                }
+         in if balance < 0
+              then Left [IncomeError day name balance]
+              else Right $ bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post)
 
--- ASSUME allocations are sorted
-selectAllos :: Day -> BoundAllocation -> Maybe Allocation
-selectAllos day a@Allocation_ {alloAmts = as} = case select [] as of
-  [] -> Nothing
-  xs -> Just $ a {alloAmts = xs}
+allocatePre
+  :: Rational
+  -> [FlatAllocation PretaxValue]
+  -> (M.Map T.Text Rational, [FlatAllocation Rational])
+allocatePre gross = L.mapAccumR go M.empty
   where
-    select acc [] = acc
-    select acc (x : xs)
-      | day < fst (taWhen x) = select acc xs
-      | inBounds (taWhen x) day = select (taAmt x : acc) xs
-      | otherwise = acc
+    go m f@FlatAllocation {faValue} =
+      let c = preCategory faValue
+          p = dec2Rat $ preValue faValue
+          v = if prePercent faValue then p * gross else p
+       in (mapAdd_ c v m, f {faValue = v})
 
-fromAllo
-  :: MonadFinance m
-  => Day
-  -> BudgetMeta
+allo2Trans
+  :: BudgetMeta
+  -> Day
   -> TaggedAcnt
-  -> Allocation
-  -> m [BudgetTxType]
-fromAllo day meta from Allocation_ {alloTo, alloAmts} = do
-  -- TODO this is going to be repeated a zillion times (might matter)
-  -- res <- expandTarget alloPath
-  return $ fmap toBT alloAmts
+  -> FlatAllocation Rational
+  -> UnbalancedTransfer
+allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} =
+  FlatTransfer
+    { cbtMeta = meta
+    , cbtWhen = day
+    , cbtFrom = from
+    , cbtCur = faCur
+    , cbtTo = faTo
+    , cbtValue = UnbalancedValue BTFixed faValue
+    , cbtDesc = faDesc
+    }
+
+allocateTax
+  :: Rational
+  -> M.Map T.Text Rational
+  -> [FlatAllocation TaxValue]
+  -> [FlatAllocation Rational]
+allocateTax gross deds = fmap (fmap go)
   where
-    toBT (Amount {amtDesc = desc, amtValue = v}) =
-      BudgetTxType
-        { bttTx =
-            BudgetTx
-              { btFrom = from
-              , btWhen = day
-              , btTo = alloTo
-              , btValue = dec2Rat v
-              , btDesc = desc
-              , btMeta = meta
-              }
-        , bttType = FixedAmt
+    go TaxValue {tvCategories, tvMethod} =
+      let agi = gross - sum (mapMaybe (`M.lookup` deds) tvCategories)
+       in case tvMethod of
+            TMPercent p -> dec2Rat p * agi
+            TMBracket TaxProgression {tbsDeductible, tbsBrackets} ->
+              foldBracket (agi - dec2Rat tbsDeductible) tbsBrackets
+
+allocatePost
+  :: Rational
+  -> [FlatAllocation PosttaxValue]
+  -> [FlatAllocation Rational]
+allocatePost aftertax = fmap (fmap go)
+  where
+    go PosttaxValue {postValue, postPercent} =
+      let v = dec2Rat postValue in if postPercent then aftertax * v else v
+
+foldBracket :: Rational -> [TaxBracket] -> Rational
+foldBracket agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
+  where
+    go TaxBracket {tbLowerLimit, tbPercent} (acc, remain) =
+      let l = dec2Rat tbLowerLimit
+          p = dec2Rat tbPercent
+       in if remain < l then (acc + p * (remain - l), l) else (acc, remain)
+
+data FlatAllocation v = FlatAllocation
+  { faValue :: !v
+  , faDesc :: !T.Text
+  , faTo :: !TaggedAcnt
+  , faCur :: !BudgetCurrency
+  }
+  deriving (Functor)
+
+flattenAllo :: SingleAllocation v -> [FlatAllocation v]
+flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
+  where
+    go Amount {amtValue, amtDesc} =
+      FlatAllocation
+        { faCur = NoX alloCur
+        , faTo = alloTo
+        , faValue = amtValue
+        , faDesc = amtDesc
         }
 
--- -- TODO maybe allow tags here?
--- fromTax
---   :: MonadFinance m
---   => Day
---   -> BudgetMeta
---   -> AcntID
---   -> Tax
---   -> m (EitherErr BudgetTxType)
--- fromTax day meta from Tax {taxAcnt = to, taxValue = v} = do
---   res <- checkAcntType ExpenseT to
---   return $ fmap go res
---   where
---     go to_ =
---       BudgetTxType
---         { bttTx =
---             BudgetTx
---               { btFrom = TaggedAcnt from []
---               , btWhen = day
---               , btTo = TaggedAcnt to_ []
---               , btValue = dec2Rat v
---               , btDesc = ""
---               , btMeta = meta
---               }
---         , bttType = FixedAmt
---         }
-
-balanceIncome :: Income -> EitherErr Rational
-balanceIncome
-  Income
-    { incGross = g
-    , incWhen = dp
-    , incPretax = pre
-    , incTaxes = tax
-    , incPosttax = post
-    }
-    | bal < 0 = Left $ IncomeError dp
-    | otherwise = Right bal
-    where
-      bal = dec2Rat g - sum (sumAllocation <$> pre ++ tax ++ post)
-
-sumAllocation :: Allocation -> Rational
-sumAllocation = sum . fmap (dec2Rat . amtValue) . alloAmts
-
--- sumTaxes :: [Tax] -> Rational
--- sumTaxes = sum . fmap (dec2Rat . taxValue)
+-- ASSUME allocations are sorted
+selectAllos :: Day -> BoundAllocation v -> [FlatAllocation v]
+selectAllos day Allocation {alloAmts, alloCur, alloTo} =
+  fmap go $
+    takeWhile ((`inBounds` day) . amtWhen) $
+      dropWhile ((day <) . fst . amtWhen) alloAmts
+  where
+    go Amount {amtValue, amtDesc} =
+      FlatAllocation
+        { faCur = NoX alloCur
+        , faTo = alloTo
+        , faValue = amtValue
+        , faDesc = amtDesc
+        }
 
 expandTransfers
   :: MonadFinance m
   => CommitRId
   -> T.Text
-  -> [Transfer]
-  -> SqlPersistT m (EitherErrs [BudgetTxType])
+  -> [BudgetTransfer]
+  -> SqlPersistT m (EitherErrs [UnbalancedTransfer])
 expandTransfers key name ts = do
   txs <- mapM (expandTransfer key name) ts
-  return $ L.sortOn (btWhen . bttTx) . concat <$> concatEithersL txs
+  return $ L.sortOn cbtWhen . concat <$> concatEithersL txs
 
-expandTransfer :: MonadFinance m => CommitRId -> T.Text -> Transfer -> SqlPersistT m (EitherErrs [BudgetTxType])
+expandTransfer
+  :: MonadFinance m
+  => CommitRId
+  -> T.Text
+  -> BudgetTransfer
+  -> SqlPersistT m (EitherErrs [UnbalancedTransfer])
 expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} =
   -- whenHash CTExpense t (Right []) $ \key ->
   fmap (fmap concat . concatEithersL) $
-    forM transAmounts $ \(TimeAmount {taWhen = pat, taAmt = (Amount {amtDesc = desc, amtValue = v}), taAmtType = atype}) -> do
-      withDates pat $ \day ->
-        let meta =
-              BudgetMeta
-                { bmCur = transCurrency
-                , bmCommit = key
-                , bmName = name
-                }
-            tx =
-              BudgetTxType
-                { bttTx =
-                    BudgetTx
-                      { btMeta = meta
-                      , btWhen = day
-                      , btFrom = transFrom
-                      , btTo = transTo
-                      , btValue = dec2Rat v
-                      , btDesc = desc
+    forM transAmounts $
+      \Amount
+        { amtWhen = pat
+        , amtValue = BudgetTransferValue {btVal = v, btType = y}
+        , amtDesc = desc
+        } ->
+          do
+            withDates pat $ \day ->
+              let meta =
+                    BudgetMeta
+                      { bmCommit = key
+                      , bmName = name
                       }
-                , bttType = atype
-                }
-         in return $ Right tx
+                  tx =
+                    FlatTransfer
+                      { cbtMeta = meta
+                      , cbtWhen = day
+                      , cbtCur = transCurrency
+                      , cbtFrom = transFrom
+                      , cbtTo = transTo
+                      , cbtValue = UnbalancedValue y $ dec2Rat v
+                      , cbtDesc = desc
+                      }
+               in return $ Right tx
 
-insertBudgetTx :: MonadFinance m => BudgetTx -> SqlPersistT m [InsertError]
-insertBudgetTx BudgetTx {btFrom, btTo, btMeta, btValue, btDesc, btWhen} = do
-  res <- lift $ splitPair btFrom btTo (bmCur btMeta) btValue
+insertBudgetTx :: MonadFinance m => BalancedTransfer -> SqlPersistT m [InsertError]
+insertBudgetTx FlatTransfer {cbtFrom, cbtTo, cbtMeta, cbtCur, cbtValue, cbtDesc, cbtWhen} = do
+  res <- lift $ splitPair cbtFrom cbtTo cbtCur cbtValue
   unlessLefts_ res $ \((sFrom, sTo), exchange) -> do
     insertPair sFrom sTo
-    forM_ exchange $ \(xFrom, xTo) -> insertPair xFrom xTo
+    forM_ exchange $ uncurry insertPair
   where
     insertPair from to = do
-      k <- insert $ TransactionR (bmCommit btMeta) btWhen btDesc
+      k <- insert $ TransactionR (bmCommit cbtMeta) cbtWhen cbtDesc
       insertBudgetLabel k from
       insertBudgetLabel k to
     insertBudgetLabel k split = do
       sk <- insertSplit k split
-      insert_ $ BudgetLabelR sk $ bmName btMeta
+      insert_ $ BudgetLabelR sk $ bmName cbtMeta
 
 type SplitPair = (KeySplit, KeySplit)
 
@@ -448,8 +477,8 @@ splitPair
   -> Rational
   -> m (EitherErrs (SplitPair, Maybe SplitPair))
 splitPair from to cur val = case cur of
-  NoX curid -> fmap (fmap (,Nothing)) $ pair curid from to val
-  X (Exchange {xFromCur, xToCur, xAcnt, xRate}) -> do
+  NoX curid -> fmap (,Nothing) <$> pair curid from to val
+  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)
@@ -461,7 +490,7 @@ splitPair from to cur val = case cur of
       return $ concatEithers2 s1 s2 (,)
     split c TaggedAcnt {taAcnt, taTags} v =
       resolveSplit $
-        Split
+        Entry
           { sAcnt = taAcnt
           , sValue = v
           , sComment = ""
@@ -493,31 +522,31 @@ checkAcntTypes ts i = (go =<<) <$> lookupAccountType i
 insertStatements :: MonadFinance m => Config -> SqlPersistT m [InsertError]
 insertStatements conf = concat <$> mapM insertStatement (statements conf)
 
-insertStatement :: MonadFinance m => Statement -> SqlPersistT m [InsertError]
-insertStatement (StmtManual m) = insertManual m
-insertStatement (StmtImport i) = insertImport i
+insertStatement :: MonadFinance m => History -> SqlPersistT m [InsertError]
+insertStatement (HistTransfer m) = insertManual m
+insertStatement (HistStatement i) = insertImport i
 
-insertManual :: MonadFinance m => Manual -> SqlPersistT m [InsertError]
+insertManual :: MonadFinance m => HistTransfer -> SqlPersistT m [InsertError]
 insertManual
-  m@Manual
-    { manualDate = dp
-    , manualFrom = from
-    , manualTo = to
-    , manualValue = v
-    , manualCurrency = u
-    , manualDesc = e
+  m@Transfer
+    { transFrom = from
+    , transTo = to
+    , transCurrency = u
+    , transAmounts = amts
     } = do
     whenHash CTManual m [] $ \c -> do
       bounds <- lift $ askDBState kmStatementInterval
       -- let days = expandDatePat bounds dp
-      let dayRes = expandDatePat bounds dp
-      unlessLefts dayRes $ \days -> do
-        txRes <- mapM (lift . tx) days
-        unlessLefts_ (concatEithersL txRes) $ mapM_ (insertTx c)
-    where
-      tx day = txPair day from to u (dec2Rat v) e
+      es <- forM amts $ \Amount {amtWhen, amtValue, amtDesc} -> do
+        let v = dec2Rat amtValue
+        let dayRes = expandDatePat bounds amtWhen
+        unlessLefts dayRes $ \days -> do
+          let tx day = txPair day from to u v amtDesc
+          txRes <- mapM (lift . tx) days
+          unlessLefts_ (concatEithersL txRes) $ mapM_ (insertTx c)
+      return $ concat es
 
-insertImport :: MonadFinance m => Import -> SqlPersistT m [InsertError]
+insertImport :: MonadFinance m => Statement -> SqlPersistT m [InsertError]
 insertImport i = whenHash CTImport i [] $ \c -> do
   -- TODO this isn't efficient, the whole file will be read and maybe no
   -- transactions will be desired
@@ -549,7 +578,7 @@ txPair
   -> m (EitherErrs KeyTx)
 txPair day from to cur val desc = resolveTx tx
   where
-    split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur, sTags = []}
+    split a v = Entry {sAcnt = a, sValue = v, sComment = "", sCurrency = cur, sTags = []}
     tx =
       Tx
         { txDescr = desc
@@ -563,7 +592,7 @@ resolveTx t@Tx {txSplits = ss} = do
   return $ fmap (\kss -> t {txSplits = kss}) res
 
 resolveSplit :: MonadFinance m => BalSplit -> m (EitherErrs KeySplit)
-resolveSplit s@Split {sAcnt, sCurrency, sValue, sTags} = do
+resolveSplit s@Entry {sAcnt, sCurrency, sValue, sTags} = do
   aid <- lookupAccountKey sAcnt
   cid <- lookupCurrency sCurrency
   sign <- lookupAccountSign sAcnt
@@ -571,7 +600,7 @@ resolveSplit s@Split {sAcnt, sCurrency, sValue, sTags} = do
   -- TODO correct sign here?
   -- TODO lenses would be nice here
   return $
-    (concatEithers2 (concatEither3 aid cid sign (,,)) $ concatEitherL tags) $
+    concatEithers2 (concatEither3 aid cid sign (,,)) (concatEitherL tags) $
       \(aid_, cid_, sign_) tags_ ->
         s
           { sAcnt = aid_
@@ -586,16 +615,16 @@ insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do
   mapM_ (insertSplit k) ss
 
 insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m (Key SplitR)
-insertSplit t Split {sAcnt, sCurrency, sValue, sComment, sTags} = do
+insertSplit t Entry {sAcnt, sCurrency, sValue, sComment, sTags} = do
   k <- insert $ SplitR t sCurrency sAcnt sComment sValue
   mapM_ (insert_ . TagRelationR k) sTags
   return k
 
 lookupAccount :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR, AcntSign, AcntType))
-lookupAccount p = lookupErr (DBKey AcntField) p <$> (askDBState kmAccount)
+lookupAccount p = lookupErr (DBKey AcntField) p <$> askDBState kmAccount
 
 lookupAccountKey :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR))
-lookupAccountKey = (fmap (fmap fstOf3)) . lookupAccount
+lookupAccountKey = fmap (fmap fstOf3) . lookupAccount
 
 lookupAccountSign :: MonadFinance m => AcntID -> m (EitherErr AcntSign)
 lookupAccountSign = fmap (fmap sndOf3) . lookupAccount
@@ -604,10 +633,10 @@ lookupAccountType :: MonadFinance m => AcntID -> m (EitherErr AcntType)
 lookupAccountType = fmap (fmap thdOf3) . lookupAccount
 
 lookupCurrency :: MonadFinance m => T.Text -> m (EitherErr (Key CurrencyR))
-lookupCurrency c = lookupErr (DBKey CurField) c <$> (askDBState kmCurrency)
+lookupCurrency c = lookupErr (DBKey CurField) c <$> askDBState kmCurrency
 
 lookupTag :: MonadFinance m => TagID -> m (EitherErr (Key TagR))
-lookupTag c = lookupErr (DBKey TagField) c <$> (askDBState kmTag)
+lookupTag c = lookupErr (DBKey TagField) c <$> askDBState kmTag
 
 -- TODO this hashes twice (not that it really matters)
 whenHash
diff --git a/lib/Internal/Statement.hs b/lib/Internal/Statement.hs
index dffc499..cd9180e 100644
--- a/lib/Internal/Statement.hs
+++ b/lib/Internal/Statement.hs
@@ -19,8 +19,8 @@ import qualified RIO.Vector as V
 
 -- TODO this probably won't scale well (pipes?)
 
-readImport :: MonadFinance m => Import -> m (EitherErrs [BalTx])
-readImport Import {..} = do
+readImport :: MonadFinance m => Statement -> m (EitherErrs [BalTx])
+readImport Statement {..} = do
   let ores = plural $ compileOptions impTxOpts
   let cres = concatEithersL $ compileMatch <$> impMatches
   case concatEithers2 ores cres (,) of
@@ -219,7 +219,7 @@ balanceSplits ss =
     $ groupByKey
     $ fmap (\s -> (sCurrency s, s)) ss
   where
-    hasValue s@(Split {sValue = Just v}) = Right s {sValue = v}
+    hasValue s@Entry {sValue = Just v} = Right s {sValue = v}
     hasValue s = Left s
     bal cur rss
       | length rss < 2 = Left $ BalanceError TooFewSplits cur rss
diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs
index c2a58ff..6526cb7 100644
--- a/lib/Internal/Types.hs
+++ b/lib/Internal/Types.hs
@@ -33,33 +33,38 @@ makeHaskellTypesWith
   , MultipleConstructors "WeekdayPat" "(./dhall/Types.dhall).WeekdayPat"
   , MultipleConstructors "MDYPat" "(./dhall/Types.dhall).MDYPat"
   , MultipleConstructors "DatePat" "(./dhall/Types.dhall).DatePat"
-  , MultipleConstructors "MatchYMD" "(./dhall/Types.dhall).MatchYMD"
-  , MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate"
-  , MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum"
-  , MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType"
+  , MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
+  , MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
+  , MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
   , MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
+  , MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
+  , MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
   , SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
   , SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag"
+  , SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
   , SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
   , SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
   , SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
-  , SingleConstructor "Global" "Global" "(./dhall/Types.dhall).Global"
+  , SingleConstructor "TemporalScope" "TemporalScope" "(./dhall/Types.dhall).TemporalScope"
   , 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 "MatchVal" "MatchVal" "(./dhall/Types.dhall).MatchVal.Type"
-  , SingleConstructor "Manual" "Manual" "(./dhall/Types.dhall).Manual"
+  , SingleConstructor "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type"
   , SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount"
-  , SingleConstructor "TimeAmount" "TimeAmount" "(./dhall/Types.dhall).TimeAmount"
-  , SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
   , SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
-  , SingleConstructor "ShadowMatch" "ShadowMatch" "(./dhall/Types.dhall).ShadowMatch.Type"
+  , SingleConstructor "TransferMatcher" "TransferMatcher" "(./dhall/Types.dhall).TransferMatcher.Type"
   , SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
   , -- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income.Type"
     SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
   , SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
-  , SingleConstructor "Split" "Split" "(./dhall/Types.dhall).Split"
+  , SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry"
+  , SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue"
+  , SingleConstructor "TaxBracket" "TaxBracket" "(./dhall/Types.dhall).TaxBracket"
+  , SingleConstructor "TaxProgression" "TaxProgression" "(./dhall/Types.dhall).TaxProgression"
+  , SingleConstructor "TaxValue" "TaxValue" "(./dhall/Types.dhall).TaxValue"
+  , SingleConstructor "PosttaxValue" "PosttaxValue" "(./dhall/Types.dhall).PosttaxValue"
+  , SingleConstructor "BudgetTransferValue" "BudgetTransferValue" "(./dhall/Types.dhall).BudgetTransferValue"
   -- , SingleConstructor "ToTx" "ToTx" "(./dhall/Types.dhall).ToTx"
   -- , SingleConstructor "MatchOther" "MatchOther" "(./dhall/Types.dhall).MatchOther_"
   -- , SingleConstructor "Match" "Match" "(./dhall/Types.dhall).Match_"
@@ -86,21 +91,25 @@ deriveProduct
   , "Budget"
   , "Income"
   , "ShadowTransfer"
-  , "ShadowMatch"
+  , "TransferMatcher"
   , "AcntSet"
-  , "MatchDate"
-  , "MatchVal"
-  , "MatchYMD"
+  , "DateMatcher"
+  , "ValMatcher"
+  , "YMDMatcher"
   , "Decimal"
-  , "Transfer"
   , "BudgetCurrency"
-  , "Manual"
   , "Exchange"
-  , "Amount"
-  , "AmountType"
-  , "SplitNum"
-  , "Global"
+  , "EntryNumGetter"
+  , "TemporalScope"
   , "SqlConfig"
+  , "PretaxValue"
+  , "TaxValue"
+  , "TaxBracket"
+  , "TaxProgression"
+  , "TaxMethod"
+  , "PosttaxValue"
+  , "BudgetTransferValue"
+  , "BudgetTransferType"
   ]
 
 -------------------------------------------------------------------------------
@@ -168,18 +177,37 @@ deriving instance Ord DatePat
 
 deriving instance Hashable DatePat
 
+type BudgetTransfer =
+  Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
+
 data Budget = Budget
   { budgetLabel :: Text
   , incomes :: [Income]
-  , pretax :: [IntervalAllocation]
-  , tax :: [IntervalAllocation]
-  , posttax :: [IntervalAllocation]
-  , transfers :: [Transfer]
+  , pretax :: [MultiAllocation PretaxValue]
+  , tax :: [MultiAllocation TaxValue]
+  , posttax :: [MultiAllocation PosttaxValue]
+  , transfers :: [BudgetTransfer]
   , shadowTransfers :: [ShadowTransfer]
   }
 
+deriving instance Hashable PretaxValue
+
+deriving instance Hashable TaxBracket
+
+deriving instance Hashable TaxProgression
+
+deriving instance Hashable TaxMethod
+
+deriving instance Hashable TaxValue
+
+deriving instance Hashable PosttaxValue
+
 deriving instance Hashable Budget
 
+deriving instance Hashable BudgetTransferValue
+
+deriving instance Hashable BudgetTransferType
+
 deriving instance Hashable TaggedAcnt
 
 deriving instance Ord TaggedAcnt
@@ -190,35 +218,49 @@ data Income = Income
   { incGross :: Decimal
   , incCurrency :: CurID
   , incWhen :: DatePat
-  , incPretax :: [Allocation]
-  , incTaxes :: [Allocation]
-  , incPosttax :: [Allocation]
+  , incPretax :: [SingleAllocation PretaxValue]
+  , incTaxes :: [SingleAllocation TaxValue]
+  , incPosttax :: [SingleAllocation PosttaxValue]
   , incFrom :: TaggedAcnt
   , incToBal :: TaggedAcnt
   }
 
 deriving instance Hashable Income
 
-deriving instance Ord Amount
+deriving instance (Ord w, Ord v) => Ord (Amount w v)
 
-deriving instance Hashable Amount
+deriving instance Generic (Amount w v)
+
+deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Amount w v)
+
+deriving instance (Generic w, Generic v, Hashable w, Hashable v) => Hashable (Amount w v)
+
+deriving instance (Show w, Show v) => Show (Amount w v)
+
+deriving instance (Eq w, Eq v) => Eq (Amount w v)
 
 deriving instance Hashable Exchange
 
 deriving instance Hashable BudgetCurrency
 
-data Allocation_ a = Allocation_
+data Allocation w v = Allocation
   { alloTo :: TaggedAcnt
-  , alloAmts :: [a]
-  , alloCur :: BudgetCurrency
+  , alloAmts :: [Amount w v]
+  , alloCur :: CurID
   }
   deriving (Eq, Show, Generic, Hashable)
 
-deriving instance FromDhall a => FromDhall (Allocation_ a)
+instance Bifunctor Amount where
+  bimap f g a@Amount {amtWhen, amtValue} = a {amtWhen = f amtWhen, amtValue = g amtValue}
 
-type Allocation = Allocation_ Amount
+instance Bifunctor Allocation where
+  bimap f g a@Allocation {alloAmts} = a {alloAmts = fmap (bimap f g) alloAmts}
 
-type IntervalAllocation = Allocation_ IntervalAmount
+deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Allocation w v)
+
+type MultiAllocation = Allocation Interval
+
+type SingleAllocation = Allocation ()
 
 toPersistText :: Show a => a -> PersistValue
 toPersistText = PersistText . T.pack . show
@@ -230,68 +272,38 @@ fromPersistText what (PersistText t) = case readMaybe $ T.unpack t of
 fromPersistText what x =
   Left $ T.unwords ["error when deserializing", what, "; got", T.pack (show x)]
 
-deriving instance Ord AmountType
-
-deriving instance Hashable AmountType
-
--- data TimeAmount a = TimeAmount
---   { taWhen :: a
---   , taAmt :: Amount
---   , taAmtType :: AmountType
---   }
---   deriving (Show, Eq, Ord, Functor, Generic, FromDhall, Hashable, Foldable, Traversable)
-
-deriving instance Show a => Show (TimeAmount a)
-
-deriving instance Eq a => Eq (TimeAmount a)
-
-deriving instance Ord a => Ord (TimeAmount a)
-
-deriving instance Functor TimeAmount
-
-deriving instance Foldable TimeAmount
-
-deriving instance Traversable TimeAmount
-
-deriving instance Generic (TimeAmount a)
-
-deriving instance Hashable a => Hashable (TimeAmount a)
-
-deriving instance FromDhall a => FromDhall (TimeAmount a)
-
-type DateAmount = TimeAmount DatePat
-
-type IntervalAmount = TimeAmount Interval
-
 deriving instance Ord Interval
 
-data Transfer = Transfer
-  { transFrom :: TaggedAcnt
-  , transTo :: TaggedAcnt
-  , transAmounts :: [DateAmount]
-  , transCurrency :: BudgetCurrency
+data Transfer a c w v = Transfer
+  { transFrom :: a
+  , transTo :: a
+  , transAmounts :: [Amount w v]
+  , transCurrency :: c
   }
+  deriving (Eq, Show, Generic, FromDhall)
 
-deriving instance Hashable Transfer
+deriving instance
+  (Generic w, Generic v, Hashable a, Hashable c, Hashable w, Hashable v)
+  => Hashable (Transfer a c w v)
 
 deriving instance Hashable ShadowTransfer
 
 deriving instance Hashable AcntSet
 
-deriving instance Hashable ShadowMatch
+deriving instance Hashable TransferMatcher
 
-deriving instance Hashable MatchVal
+deriving instance Hashable ValMatcher
 
-deriving instance Hashable MatchYMD
+deriving instance Hashable YMDMatcher
 
-deriving instance Hashable MatchDate
+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 MatchYMD where
+instance Ord YMDMatcher where
   compare (Y y) (Y y') = compare y y'
   compare (YM g) (YM g') = compare g g'
   compare (YMD g) (YMD g') = compare g g'
@@ -306,15 +318,13 @@ gregM :: Gregorian -> GregorianM
 gregM Gregorian {gYear = y, gMonth = m} =
   GregorianM {gmYear = y, gmMonth = m}
 
-instance Ord MatchDate where
+instance Ord DateMatcher where
   compare (On d) (On d') = compare d d'
   compare (In d r) (In d' r') = compare d d' <> compare r r'
   compare (On d) (In d' _) = compare d d' <> LT
   compare (In d _) (On d') = compare d d' <> GT
 
-deriving instance Hashable SplitNum
-
-deriving instance Hashable Manual
+deriving instance Hashable EntryNumGetter
 
 -------------------------------------------------------------------------------
 -- top level type with fixed account tree to unroll the recursion in the dhall
@@ -347,10 +357,10 @@ deriving instance FromDhall AccountRootF
 type AccountRoot = AccountRoot_ AccountTree
 
 data Config_ a = Config_
-  { global :: !Global
+  { global :: !TemporalScope
   , budget :: ![Budget]
   , currencies :: ![Currency]
-  , statements :: ![Statement]
+  , statements :: ![History]
   , accounts :: !a
   , tags :: ![Tag]
   , sqlConfig :: !SqlConfig
@@ -384,22 +394,24 @@ type AcntID = T.Text
 
 type TagID = T.Text
 
-data Statement
-  = StmtManual !Manual
-  | StmtImport !Import
+type HistTransfer = Transfer AcntID CurID DatePat Decimal
+
+data History
+  = HistTransfer !HistTransfer
+  | HistStatement !Statement
   deriving (Eq, Hashable, Generic, FromDhall)
 
-type ExpSplit = Split SplitAcnt (Maybe SplitNum) SplitCur TagID
+type ExpSplit = Entry SplitAcnt (Maybe EntryNumGetter) SplitCur TagID
 
 instance FromDhall ExpSplit
 
-deriving instance (Show a, Show c, Show v, Show t) => Show (Split a v c t)
+deriving instance (Show a, Show c, Show v, Show t) => Show (Entry a v c t)
 
-deriving instance Generic (Split a v c t)
+deriving instance Generic (Entry a v c t)
 
-deriving instance (Hashable a, Hashable v, Hashable c, Hashable t) => Hashable (Split a v c t)
+deriving instance (Hashable a, Hashable v, Hashable c, Hashable t) => Hashable (Entry a v c t)
 
-deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Split a v c t)
+deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Entry a v c t)
 
 data Tx s = Tx
   { txDescr :: !T.Text
@@ -422,7 +434,7 @@ data TxOpts re = TxOpts
   }
   deriving (Eq, Generic, Hashable, Show, FromDhall)
 
-data Import = Import
+data Statement = Statement
   { impPaths :: ![FilePath]
   , impMatches :: ![Match T.Text]
   , impDelim :: !Word
@@ -466,7 +478,7 @@ type FieldMap k v = Field k (M.Map k v)
 
 data MatchOther re
   = Desc !(Field T.Text re)
-  | Val !(Field T.Text MatchVal)
+  | Val !(Field T.Text ValMatcher)
   deriving (Eq, Hashable, Generic, FromDhall, Functor, Foldable, Traversable)
 
 deriving instance Show (MatchOther T.Text)
@@ -479,8 +491,8 @@ data ToTx = ToTx
   deriving (Eq, Generic, Hashable, Show, FromDhall)
 
 data Match re = Match
-  { mDate :: !(Maybe MatchDate)
-  , mVal :: !MatchVal
+  { mDate :: !(Maybe DateMatcher)
+  , mVal :: !ValMatcher
   , mDesc :: !(Maybe re)
   , mOther :: ![MatchOther re]
   , mTx :: !(Maybe ToTx)
@@ -583,7 +595,7 @@ data DBState = DBState
 
 type MappingT m = ReaderT DBState (SqlPersistT m)
 
-type KeySplit = Split AccountRId Rational CurrencyRId TagRId
+type KeySplit = Entry AccountRId Rational CurrencyRId TagRId
 
 type KeyTx = Tx KeySplit
 
@@ -676,9 +688,9 @@ accountSign IncomeT = Credit
 accountSign LiabilityT = Credit
 accountSign EquityT = Credit
 
-type RawSplit = Split AcntID (Maybe Rational) CurID TagID
+type RawSplit = Entry AcntID (Maybe Rational) CurID TagID
 
-type BalSplit = Split AcntID Rational CurID TagID
+type BalSplit = Entry AcntID Rational CurID TagID
 
 type RawTx = Tx RawSplit
 
@@ -720,7 +732,7 @@ data InsertError
   | ConversionError !T.Text
   | LookupError !LookupSuberr !T.Text
   | BalanceError !BalanceType !CurID ![RawSplit]
-  | IncomeError !DatePat
+  | IncomeError !Day !T.Text !Rational
   | PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
   | BoundsError !Gregorian !(Maybe Gregorian)
   | StatementError ![TxRecord] ![MatchRe]
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index b9992fa..873f5f1 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -97,22 +97,22 @@ gregMTup GregorianM {gmYear, gmMonth} =
 
 data YMD_ = Y_ !Integer | YM_ !Integer !Int | YMD_ !Integer !Int !Int
 
-fromMatchYMD :: MatchYMD -> YMD_
-fromMatchYMD m = case m of
+fromYMDMatcher :: YMDMatcher -> YMD_
+fromYMDMatcher m = case m of
   Y y -> Y_ $ fromIntegral y
   YM g -> uncurry YM_ $ gregMTup g
   YMD g -> uncurry3 YMD_ $ gregTup g
 
-compareDate :: MatchDate -> Day -> Ordering
+compareDate :: DateMatcher -> Day -> Ordering
 compareDate (On md) x =
-  case fromMatchYMD md of
+  case fromYMDMatcher md of
     Y_ y' -> compare y y'
     YM_ y' m' -> compare (y, m) (y', m')
     YMD_ y' m' d' -> compare (y, m, d) (y', m', d')
   where
     (y, m, d) = toGregorian x
 compareDate (In md offset) x = do
-  case fromMatchYMD md of
+  case fromYMDMatcher md of
     Y_ y' -> compareRange y' y
     YM_ y' m' -> compareRange (toMonth y' m') $ toMonth y m
     YMD_ y' m' d' ->
@@ -172,7 +172,7 @@ toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErrs RawTx
 toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
   concatEithers2 acRes ssRes $ \(a_, c_) ss_ ->
     let fromSplit =
-          Split
+          Entry
             { sAcnt = a_
             , sCurrency = c_
             , sValue = Just trAmount
@@ -188,8 +188,8 @@ toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
     acRes = concatEithers2 (resolveAcnt r sa) (resolveCurrency r sc) (,)
     ssRes = concatEithersL $ fmap (resolveSplit r) toSplits
 
-valMatches :: MatchVal -> Rational -> EitherErr Bool
-valMatches MatchVal {mvDen, mvSign, mvNum, mvPrec} x
+valMatches :: ValMatcher -> Rational -> EitherErr Bool
+valMatches ValMatcher {mvDen, mvSign, mvNum, mvPrec} x
   | Just d_ <- mvDen, d_ >= p = Left $ MatchValPrecisionError d_ p
   | otherwise =
       Right $
@@ -202,7 +202,7 @@ valMatches MatchVal {mvDen, mvSign, mvNum, mvPrec} x
     s = signum x >= 0
     checkMaybe = maybe True
 
-dateMatches :: MatchDate -> Day -> Bool
+dateMatches :: DateMatcher -> Day -> Bool
 dateMatches md = (EQ ==) . compareDate md
 
 otherMatches :: M.Map T.Text T.Text -> MatchOtherRe -> EitherErr Bool
@@ -213,14 +213,14 @@ otherMatches dict m = case m of
     lookup_ t n = lookupErr (MatchField t) n dict
 
 resolveSplit :: TxRecord -> ExpSplit -> EitherErrs RawSplit
-resolveSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} =
+resolveSplit r s@Entry {sAcnt = a, sValue = v, sCurrency = c} =
   concatEithers2 acRes valRes $
     \(a_, c_) v_ -> (s {sAcnt = a_, sValue = v_, sCurrency = c_})
   where
     acRes = concatEithers2 (resolveAcnt r a) (resolveCurrency r c) (,)
     valRes = plural $ mapM (resolveValue r) v
 
-resolveValue :: TxRecord -> SplitNum -> EitherErr Rational
+resolveValue :: TxRecord -> EntryNumGetter -> EitherErr Rational
 resolveValue r s = case s of
   (LookupN t) -> readRational =<< lookupErr SplitValField t (trOther r)
   (ConstN c) -> Right $ dec2Rat c
@@ -371,8 +371,16 @@ showError other = case other of
       idName TagField = "tag"
       matchName MatchNumeric = "numeric"
       matchName MatchText = "text"
-  (IncomeError dp) ->
-    [T.append "Income allocations exceed total: datepattern=" $ showT dp]
+  (IncomeError day name balance) ->
+    [ T.unwords
+        [ "Income allocations for budget"
+        , singleQuote name
+        , "exceed total on day"
+        , showT day
+        , "where balance is"
+        , showT balance
+        ]
+    ]
   (BalanceError t cur rss) ->
     [ T.unwords
         [ msg
@@ -406,8 +414,8 @@ showMatch Match {mDate = d, mVal = v, mDesc = e, mOther = o, mTimes = n, mPriori
   T.append "Unused match: " $ keyVals [(x, y) | (x, Just y) <- kvs]
   where
     kvs =
-      [ ("date", showMatchDate <$> d)
-      , ("val", showMatchVal v)
+      [ ("date", showDateMatcher <$> d)
+      , ("val", showValMatcher v)
       , ("desc", fst <$> e)
       , ("other", others)
       , ("counter", Just $ maybe "Inf" showT n)
@@ -420,14 +428,14 @@ showMatch Match {mDate = d, mVal = v, mDesc = e, mOther = o, mTimes = n, mPriori
 -- | Convert match date to text
 -- Single date matches will just show the single date, and ranged matches will
 -- show an interval like [YY-MM-DD, YY-MM-DD)
-showMatchDate :: MatchDate -> T.Text
-showMatchDate md = case md of
-  (On x) -> showMatchYMD x
-  (In start n) -> T.concat ["[", showMatchYMD start, " ", showYMD_ end, ")"]
+showDateMatcher :: DateMatcher -> T.Text
+showDateMatcher md = case md of
+  (On x) -> showYMDMatcher x
+  (In start n) -> T.concat ["[", showYMDMatcher start, " ", showYMD_ end, ")"]
     where
       -- TODO not DRY (this shifting thing happens during the comparison
       -- function (kinda)
-      end = case fromMatchYMD start of
+      end = case fromYMDMatcher start of
         Y_ y -> Y_ $ y + fromIntegral n
         YM_ y m ->
           let (y_, m_) = divMod (m + fromIntegral n - 1) 12
@@ -439,8 +447,8 @@ showMatchDate md = case md of
                 fromGregorian y m d
 
 -- | convert YMD match to text
-showMatchYMD :: MatchYMD -> T.Text
-showMatchYMD = showYMD_ . fromMatchYMD
+showYMDMatcher :: YMDMatcher -> T.Text
+showYMDMatcher = showYMD_ . fromYMDMatcher
 
 showYMD_ :: YMD_ -> T.Text
 showYMD_ md =
@@ -451,9 +459,9 @@ showYMD_ md =
       YM_ y m -> [fromIntegral y, m]
       YMD_ y m d -> [fromIntegral y, m, d]
 
-showMatchVal :: MatchVal -> Maybe T.Text
-showMatchVal MatchVal {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing
-showMatchVal MatchVal {mvNum, mvDen, mvSign, mvPrec} =
+showValMatcher :: ValMatcher -> Maybe T.Text
+showValMatcher ValMatcher {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing
+showValMatcher ValMatcher {mvNum, mvDen, mvSign, mvPrec} =
   Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs]
   where
     kvs =
@@ -471,11 +479,11 @@ showMatchOther (Val (Field f mv)) =
     [ "val field"
     , singleQuote f
     , "with match value"
-    , singleQuote $ fromMaybe "*" $ showMatchVal mv
+    , singleQuote $ fromMaybe "*" $ showValMatcher mv
     ]
 
 showSplit :: RawSplit -> T.Text
-showSplit Split {sAcnt = a, sValue = v, sComment = c} =
+showSplit Entry {sAcnt = a, sValue = v, sComment = c} =
   keyVals
     [ ("account", a)
     , ("value", T.pack $ show ((fromRational <$> v) :: Maybe Float))

From d7c61ac29352fca63d50d70cda15d587a0472701 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sun, 30 Apr 2023 11:52:30 -0400
Subject: [PATCH 03/15] ENH update common

---
 dhall/Types.dhall  |  3 ++-
 dhall/common.dhall | 46 ++++++++++++++++++++++++----------------------
 2 files changed, 26 insertions(+), 23 deletions(-)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index fde6cfe..2cbd2f2 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -557,7 +557,7 @@ let StatementParser_ =
           , mVal = ValMatcher::{=}
           , mDesc = None Text
           , mOther = [] : List (FieldMatcher_ re)
-          , mTx = None EntryGetter.Type
+          , mTx = None TxGetter
           , mTimes = None Natural
           , mPriority = +0
           }
@@ -1024,4 +1024,5 @@ in  { CurID
     , TaxValue
     , BudgetTransferValue
     , BudgetTransferType
+    , TxGetter
     }
diff --git a/dhall/common.dhall b/dhall/common.dhall
index de043d2..85678c4 100644
--- a/dhall/common.dhall
+++ b/dhall/common.dhall
@@ -18,15 +18,15 @@ let d = dec2 True
 let d_ = dec2 False
 
 let nullSplit =
-      \(a : T.SplitAcnt) ->
-      \(c : T.SplitCur) ->
-        T.ExpSplit::{ sAcnt = a, sCurrency = c, sTags = [] : List T.TagID }
+      \(a : T.EntryAcntGetter) ->
+      \(c : T.EntryCurGetter) ->
+        T.EntryGetter::{ sAcnt = a, sCurrency = c, sTags = [] : List T.TagID }
 
 let nullOpts = T.TxOpts::{=}
 
-let nullVal = T.MatchVal::{=}
+let nullVal = T.ValMatcher::{=}
 
-let nullMatch = T.Match::{=}
+let nullMatch = T.StatementParser::{=}
 
 let nullCron = T.CronPat::{=}
 
@@ -49,12 +49,12 @@ let cron1 =
 
 let matchInf_ = nullMatch
 
-let matchInf = \(x : T.ToTx) -> nullMatch // { mTx = Some x }
+let matchInf = \(x : T.TxGetter) -> nullMatch // { mTx = Some x }
 
 let matchN_ = \(n : Natural) -> nullMatch // { mTimes = Some n }
 
 let matchN =
-      \(n : Natural) -> \(x : T.ToTx) -> matchInf x // { mTimes = Some n }
+      \(n : Natural) -> \(x : T.TxGetter) -> matchInf x // { mTimes = Some n }
 
 let match1_ = matchN_ 1
 
@@ -68,61 +68,63 @@ let greg =
       \(d : Natural) ->
         { gYear = y, gMonth = m, gDay = d }
 
-let mY = \(y : Natural) -> T.MatchDate.On (T.MatchYMD.Y y)
+let mY = \(y : Natural) -> T.DateMatcher.On (T.YMDMatcher.Y y)
 
 let mYM =
       \(y : Natural) ->
       \(m : Natural) ->
-        T.MatchDate.On (T.MatchYMD.YM (gregM y m))
+        T.DateMatcher.On (T.YMDMatcher.YM (gregM y m))
 
 let mYMD =
       \(y : Natural) ->
       \(m : Natural) ->
       \(d : Natural) ->
-        T.MatchDate.On (T.MatchYMD.YMD (greg y m d))
+        T.DateMatcher.On (T.YMDMatcher.YMD (greg y m d))
 
 let mRngY =
       \(y : Natural) ->
       \(r : Natural) ->
-        T.MatchDate.In { _1 = T.MatchYMD.Y y, _2 = r }
+        T.DateMatcher.In { _1 = T.YMDMatcher.Y y, _2 = r }
 
 let mRngYM =
       \(y : Natural) ->
       \(m : Natural) ->
       \(r : Natural) ->
-        T.MatchDate.In { _1 = T.MatchYMD.YM (gregM y m), _2 = r }
+        T.DateMatcher.In { _1 = T.YMDMatcher.YM (gregM y m), _2 = r }
 
 let mRngYMD =
       \(y : Natural) ->
       \(m : Natural) ->
       \(d : Natural) ->
       \(r : Natural) ->
-        T.MatchDate.In { _1 = T.MatchYMD.YMD (greg y m d), _2 = r }
+        T.DateMatcher.In { _1 = T.YMDMatcher.YMD (greg y m d), _2 = r }
 
 let PartSplit = { _1 : T.AcntID, _2 : T.Decimal, _3 : Text }
 
 let partN =
-      \(c : T.SplitCur) ->
-      \(a : T.SplitAcnt) ->
+      \(c : T.EntryCurGetter) ->
+      \(a : T.EntryAcntGetter) ->
       \(comment : Text) ->
       \(ss : List PartSplit) ->
         let toSplit =
               \(x : PartSplit) ->
-                    nullSplit (T.SplitAcnt.ConstT x._1) c
-                //  { sValue = Some (T.SplitNum.ConstN x._2), sComment = x._3 }
+                    nullSplit (T.EntryAcntGetter.ConstT x._1) c
+                //  { sValue = Some (T.EntryNumGetter.ConstN x._2)
+                    , sComment = x._3
+                    }
 
         in    [ nullSplit a c // { sComment = comment } ]
-            # List/map PartSplit T.ExpSplit.Type toSplit ss
+            # List/map PartSplit T.EntryGetter.Type toSplit ss
 
 let part1 =
-      \(c : T.SplitCur) ->
-      \(a : T.SplitAcnt) ->
+      \(c : T.EntryCurGetter) ->
+      \(a : T.EntryAcntGetter) ->
       \(comment : Text) ->
         partN c a comment ([] : List PartSplit)
 
 let part1_ =
-      \(c : T.SplitCur) ->
-      \(a : T.SplitAcnt) ->
+      \(c : T.EntryCurGetter) ->
+      \(a : T.EntryAcntGetter) ->
         partN c a "" ([] : List PartSplit)
 
 let addDay =

From 37af813c73468e86961279f3e69568a3fcd5f24c Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sun, 30 Apr 2023 12:00:35 -0400
Subject: [PATCH 04/15] FIX missing export

---
 dhall/Types.dhall | 1 +
 1 file changed, 1 insertion(+)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index 2cbd2f2..fc24604 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -1025,4 +1025,5 @@ in  { CurID
     , BudgetTransferValue
     , BudgetTransferType
     , TxGetter
+    , HistTransfer
     }

From 0650ce194887bf9cb9949b9b74ebc3ec0930d748 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sun, 30 Apr 2023 15:23:29 -0400
Subject: [PATCH 05/15] FIX more exports

---
 dhall/Types.dhall | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index fc24604..dee064a 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -1026,4 +1026,6 @@ in  { CurID
     , BudgetTransferType
     , TxGetter
     , HistTransfer
+    , SingleAllocation
+    , MultiAllocation
     }

From ca7fef7a56d8ec06f6f0c025836d8c628732fbe4 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sun, 30 Apr 2023 22:54:20 -0400
Subject: [PATCH 06/15] ENH update types

---
 dhall/Types.dhall  | 106 ++++++++++++++++++++++-----------------------
 dhall/common.dhall |  14 +++---
 2 files changed, 60 insertions(+), 60 deletions(-)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index dee064a..a4e8704 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -251,16 +251,16 @@ let CronPat =
     This is similar to 'cron' patterns in unix-like systems.
     -}
       { Type =
-          { cronWeekly : Optional WeekdayPat
-          , cronYear : Optional MDYPat
-          , cronMonth : Optional MDYPat
-          , cronDay : Optional MDYPat
+          { cpWeekly : Optional WeekdayPat
+          , cpYear : Optional MDYPat
+          , cpMonth : Optional MDYPat
+          , cpDay : Optional MDYPat
           }
       , default =
-        { cronWeekly = None WeekdayPat
-        , cronYear = None MDYPat
-        , cronMonth = None MDYPat
-        , cronDay = None MDYPat
+        { cpWeekly = None WeekdayPat
+        , cpYear = None MDYPat
+        , cpMonth = None MDYPat
+        , cpDay = None MDYPat
         }
       }
 
@@ -339,7 +339,7 @@ let ValMatcher =
     Means to match a decimal value.
     -}
       { Type =
-          { mvSign :
+          { vmSign :
               {-
               Sign of value.
               True -> positive,
@@ -347,17 +347,17 @@ let ValMatcher =
               None -> do not consider.
               -}
               Optional Bool
-          , mvNum :
+          , vmNum :
               {-
               Value of numerator to match. Do not consider numerator if none
               -}
               Optional Natural
-          , mvDen :
+          , vmDen :
               {-
               Value of denominator to match. Do not consider numerator if none
               -}
               Optional Natural
-          , mvPrec :
+          , vmPrec :
               {-
               Precision of decimal to use when matching. This only affects the
               denominator, such that a query of '10.1' with a precision of 2
@@ -366,10 +366,10 @@ let ValMatcher =
               Natural
           }
       , default =
-        { mvSign = None Bool
-        , mvNum = None Natural
-        , mvDen = None Natural
-        , mvPrec = 2
+        { vmSign = None Bool
+        , vmNum = None Natural
+        , vmDen = None Natural
+        , vmPrec = 2
         }
       }
 
@@ -443,27 +443,27 @@ let Entry =
       \(v : Type) ->
       \(c : Type) ->
       \(t : Type) ->
-        { sAcnt :
+        { eAcnt :
             {-
             Pertains to account for this entry.
             -}
             a
-        , sValue :
+        , eValue :
             {-
             Pertains to value for this entry.
             -}
             v
-        , sCurrency :
+        , eCurrency :
             {-
             Pertains to value for this entry.
             -}
             c
-        , sComment :
+        , eComment :
             {-
             A short description of this entry (if none, use a blank string)
             -}
             Text
-        , sTags :
+        , eTags :
             {-
             Pertains to the tags to describe this entry.
             -}
@@ -476,7 +476,7 @@ let EntryGetter =
     -}
       { Type =
           Entry EntryAcntGetter (Optional EntryNumGetter) EntryCurGetter TagID
-      , default = { sValue = None EntryNumGetter, sComment = "" }
+      , default = { eValue = None EntryNumGetter, eComment = "" }
       }
 
 let TxGetter =
@@ -513,53 +513,53 @@ let StatementParser_ =
     -}
       \(re : Type) ->
         { Type =
-            { mDate :
+            { spDate :
                 {-
                 How to match the date column; if none match any date
                 -}
                 Optional DateMatcher
-            , mVal :
+            , spVal :
                 {-
                 How to match the value column; if none match any value
                 -}
                 ValMatcher.Type
-            , mDesc :
+            , spDesc :
                 {-
                 Regular expression to match the description;
                 if none match anythingS
                 -}
                 Optional re
-            , mOther :
+            , spOther :
                 {-
                 How to match additional columns if present
                 -}
                 List (FieldMatcher_ re)
-            , mTx :
+            , spTx :
                 {-
                 How to translate the matched statement row into entries for
                 a transaction. If none, don't make a transaction (eg 'skip'
                 this row in the statement).
                 -}
                 Optional TxGetter
-            , mTimes :
+            , spTimes :
                 {-
                 Match at most this many rows; if none there is no limit
                 -}
                 Optional Natural
-            , mPriority :
+            , spPriority :
                 {-
                 In case of multiple matches, higher priority gets precedence.
                 -}
                 Integer
             }
         , default =
-          { mDate = None DateMatcher
-          , mVal = ValMatcher::{=}
-          , mDesc = None Text
-          , mOther = [] : List (FieldMatcher_ re)
-          , mTx = None TxGetter
-          , mTimes = None Natural
-          , mPriority = +0
+          { spDate = None DateMatcher
+          , spVal = ValMatcher::{=}
+          , spDesc = None Text
+          , spOther = [] : List (FieldMatcher_ re)
+          , spTx = None TxGetter
+          , spTimes = None Natural
+          , spPriority = +0
           }
         }
 
@@ -720,12 +720,12 @@ let TaxProgression =
     A tax progression using a deductible and a series of tax brackets.
     This will cover simple cases of the US income tax as of 2017 and similar.
     -}
-      { tbsDeductible :
+      { tpDeductible :
           {-
           Initial amount to subtract from after-pretax-deductions
           -}
           Decimal
-      , tbsBrackets :
+      , tpBrackets :
           {-
           Tax brackets to apply after deductions (order does not matter, each
           entry will be sorted by limit)
@@ -852,34 +852,34 @@ let TransferMatcher =
     fashion)
     -}
       { Type =
-          { smFrom :
+          { tmFrom :
               {-
               List of accounts (which may be empty) to match with the
               starting account in a transfer.
               -}
               AcntSet.Type
-          , smTo :
+          , tmTo :
               {-
               List of accounts (which may be empty) to match with the
               ending account in a transfer.
               -}
               AcntSet.Type
-          , smDate :
+          , tmDate :
               {-
               If given, means to match the date of a transfer.
               -}
               Optional DateMatcher
-          , smVal :
+          , tmVal :
               {-
               If given, means to match the value of a transfer.
               -}
               ValMatcher.Type
           }
       , default =
-        { smFrom = AcntSet.default
-        , smTo = AcntSet.default
-        , smDate = None DateMatcher
-        , smVal = ValMatcher.default
+        { tmFrom = AcntSet.default
+        , tmTo = AcntSet.default
+        , tmDate = None DateMatcher
+        , tmVal = ValMatcher.default
         }
       }
 
@@ -951,19 +951,19 @@ let Budget =
     A hypothetical set of transactions (eg a "budget") to be generated
     and inserted into the database.
     -}
-      { budgetLabel :
+      { bgtLabel :
           {-
           A unique label for this budget.
 
           Can be useful to compare multiple potential futures.
           -}
           Text
-      , incomes : List Income.Type
-      , pretax : List (MultiAllocation PretaxValue)
-      , tax : List (MultiAllocation TaxValue)
-      , posttax : List (MultiAllocation PosttaxValue)
-      , transfers : List BudgetTransfer
-      , shadowTransfers : List ShadowTransfer
+      , bgtIncomes : List Income.Type
+      , bgtPretax : List (MultiAllocation PretaxValue)
+      , bgtTax : List (MultiAllocation TaxValue)
+      , bgtPosttax : List (MultiAllocation PosttaxValue)
+      , bgtTransfers : List BudgetTransfer
+      , bgtShadowTransfers : List ShadowTransfer
       }
 
 in  { CurID
diff --git a/dhall/common.dhall b/dhall/common.dhall
index 85678c4..493664d 100644
--- a/dhall/common.dhall
+++ b/dhall/common.dhall
@@ -20,7 +20,7 @@ let d_ = dec2 False
 let nullSplit =
       \(a : T.EntryAcntGetter) ->
       \(c : T.EntryCurGetter) ->
-        T.EntryGetter::{ sAcnt = a, sCurrency = c, sTags = [] : List T.TagID }
+        T.EntryGetter::{ eAcnt = a, eCurrency = c, eTags = [] : List T.TagID }
 
 let nullOpts = T.TxOpts::{=}
 
@@ -41,9 +41,9 @@ let cron1 =
       \(d : Natural) ->
         T.DatePat.Cron
           (     nullCron
-            //  { cronYear = Some (T.MDYPat.Single y)
-                , cronMonth = Some (T.MDYPat.Single m)
-                , cronDay = Some (T.MDYPat.Single d)
+            //  { cpYear = Some (T.MDYPat.Single y)
+                , cpMonth = Some (T.MDYPat.Single m)
+                , cpDay = Some (T.MDYPat.Single d)
                 }
           )
 
@@ -109,11 +109,11 @@ let partN =
         let toSplit =
               \(x : PartSplit) ->
                     nullSplit (T.EntryAcntGetter.ConstT x._1) c
-                //  { sValue = Some (T.EntryNumGetter.ConstN x._2)
-                    , sComment = x._3
+                //  { eValue = Some (T.EntryNumGetter.ConstN x._2)
+                    , eComment = x._3
                     }
 
-        in    [ nullSplit a c // { sComment = comment } ]
+        in    [ nullSplit a c // { eComment = comment } ]
             # List/map PartSplit T.EntryGetter.Type toSplit ss
 
 let part1 =

From 0dbe1590b510944e1cf32985f8b5182b4475e0ab Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sun, 30 Apr 2023 22:56:40 -0400
Subject: [PATCH 07/15] ENH update types again

---
 dhall/common.dhall | 16 ++++++++--------
 1 file changed, 8 insertions(+), 8 deletions(-)

diff --git a/dhall/common.dhall b/dhall/common.dhall
index 493664d..b0dd789 100644
--- a/dhall/common.dhall
+++ b/dhall/common.dhall
@@ -132,21 +132,21 @@ let addDay =
       \(d : Natural) ->
         { gYear = x.gmYear, gMonth = x.gmMonth, gDay = d }
 
-let mvP = nullVal // { mvSign = Some True }
+let mvP = nullVal // { vmSign = Some True }
 
-let mvN = nullVal // { mvSign = Some False }
+let mvN = nullVal // { vmSign = Some False }
 
-let mvNum = \(x : Natural) -> nullVal // { mvNum = Some x }
+let mvNum = \(x : Natural) -> nullVal // { vmNum = Some x }
 
-let mvDen = \(x : Natural) -> nullVal // { mvDen = Some x }
+let mvDen = \(x : Natural) -> nullVal // { vmDen = Some x }
 
-let mvNumP = \(x : Natural) -> mvP // { mvNum = Some x }
+let mvNumP = \(x : Natural) -> mvP // { vmNum = Some x }
 
-let mvNumN = \(x : Natural) -> mvN // { mvNum = Some x }
+let mvNumN = \(x : Natural) -> mvN // { vmNum = Some x }
 
-let mvDenP = \(x : Natural) -> mvP // { mvDen = Some x }
+let mvDenP = \(x : Natural) -> mvP // { vmDen = Some x }
 
-let mvDenN = \(x : Natural) -> mvN // { mvDen = Some x }
+let mvDenN = \(x : Natural) -> mvN // { vmDen = Some x }
 
 in      { nullSplit
         , nullMatch

From 65a280c3d74ee05f211c2f163f1c95b5ffdc5013 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sun, 30 Apr 2023 23:00:26 -0400
Subject: [PATCH 08/15] ENH update types (and again)

---
 dhall/common.dhall | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/dhall/common.dhall b/dhall/common.dhall
index b0dd789..e9a7d34 100644
--- a/dhall/common.dhall
+++ b/dhall/common.dhall
@@ -49,12 +49,12 @@ let cron1 =
 
 let matchInf_ = nullMatch
 
-let matchInf = \(x : T.TxGetter) -> nullMatch // { mTx = Some x }
+let matchInf = \(x : T.TxGetter) -> nullMatch // { spTx = Some x }
 
-let matchN_ = \(n : Natural) -> nullMatch // { mTimes = Some n }
+let matchN_ = \(n : Natural) -> nullMatch // { spTimes = Some n }
 
 let matchN =
-      \(n : Natural) -> \(x : T.TxGetter) -> matchInf x // { mTimes = Some n }
+      \(n : Natural) -> \(x : T.TxGetter) -> matchInf x // { spTimes = Some n }
 
 let match1_ = matchN_ 1
 

From 2119eb61c8c11aa319c11beea14972961ed383c8 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sun, 30 Apr 2023 23:28:16 -0400
Subject: [PATCH 09/15] ENH update haskell types

---
 dhall/Accounts.dhall         | 50 -------------------
 lib/Internal/Database/Ops.hs |  6 +--
 lib/Internal/Insert.hs       | 93 ++++++++++++++++++----------------
 lib/Internal/Statement.hs    | 32 ++++++------
 lib/Internal/Types.hs        | 74 +++++++++++++--------------
 lib/Internal/Utils.hs        | 96 ++++++++++++++++++------------------
 6 files changed, 154 insertions(+), 197 deletions(-)
 delete mode 100644 dhall/Accounts.dhall

diff --git a/dhall/Accounts.dhall b/dhall/Accounts.dhall
deleted file mode 100644
index 7b42b72..0000000
--- a/dhall/Accounts.dhall
+++ /dev/null
@@ -1,50 +0,0 @@
-let List/map =
-      https://prelude.dhall-lang.org/v21.1.0/List/map
-        sha256:dd845ffb4568d40327f2a817eb42d1c6138b929ca758d50bc33112ef3c885680
-
-let AccountTree
-    : Type
-    = forall (a : Type) ->
-      forall  ( Fix
-              : < AccountF : { _1 : Text, _2 : Text }
-                | PlaceholderF : { _1 : Text, _2 : Text, _3 : List a }
-                > ->
-                  a
-              ) ->
-        a
-
-let AccountTreeF =
-      \(a : Type) ->
-        < AccountF : { _1 : Text, _2 : Text }
-        | PlaceholderF : { _1 : Text, _2 : Text, _3 : List a }
-        >
-
-let Account
-    : Text -> Text -> AccountTree
-    = \(desc : Text) ->
-      \(name : Text) ->
-      \(a : Type) ->
-        let f = AccountTreeF a
-
-        in  \(Fix : f -> a) -> Fix (f.AccountF { _1 = desc, _2 = name })
-
-let Placeholder
-    : Text -> Text -> List AccountTree -> AccountTree
-    = \(desc : Text) ->
-      \(name : Text) ->
-      \(children : List AccountTree) ->
-      \(a : Type) ->
-        let f = AccountTreeF a
-
-        in  \(Fix : f -> a) ->
-              let apply = \(x : AccountTree) -> x a Fix
-
-              in  Fix
-                    ( f.PlaceholderF
-                        { _1 = desc
-                        , _2 = name
-                        , _3 = List/map AccountTree a apply children
-                        }
-                    )
-
-in  { Account, Placeholder }
diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs
index 54aeac0..11bb000 100644
--- a/lib/Internal/Database/Ops.hs
+++ b/lib/Internal/Database/Ops.hs
@@ -98,8 +98,8 @@ hashConfig
     } = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
     where
       (ms, ps) = partitionEithers $ fmap go ss
-      go (StmtManual x) = Left x
-      go (StmtImport x) = Right x
+      go (HistTransfer x) = Left x
+      go (HistStatement x) = Right x
 
 setDiff :: Eq a => [a] -> [a] -> ([a], [a])
 -- setDiff = setDiff' (==)
@@ -209,7 +209,7 @@ updateTags cs = do
   mapM_ insertFull toIns
   return $ tagMap tags
   where
-    toRecord t@(Tag {tagID, tagDesc}) = Entity (toKey t) $ TagR tagID tagDesc
+    toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc
     tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
 
 toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs
index ed7b945..13a9cf9 100644
--- a/lib/Internal/Insert.hs
+++ b/lib/Internal/Insert.hs
@@ -40,7 +40,7 @@ expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs =
       Year -> addGregorianYearsClip
 
 expandCronPat :: Bounds -> CronPat -> EitherErrs [Day]
-expandCronPat b CronPat {cronYear, cronMonth, cronDay, cronWeekly} =
+expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} =
   concatEither3 yRes mRes dRes $ \ys ms ds ->
     filter validWeekday $
       mapMaybe (uncurry3 toDay) $
@@ -48,13 +48,13 @@ expandCronPat b CronPat {cronYear, cronMonth, cronDay, cronWeekly} =
           dropWhile (\((y, _), m, d) -> (y, m, d) < (yb0, mb0, db0)) $
             [(y, m, d) | y <- (\y -> (y, isLeapYear y)) <$> ys, m <- ms, d <- ds]
   where
-    yRes = case cronYear of
+    yRes = case cpYear of
       Nothing -> return [yb0 .. yb1]
       Just pat -> do
         ys <- expandMDYPat (fromIntegral yb0) (fromIntegral yb1) pat
         return $ dropWhile (< yb0) $ fromIntegral <$> ys
-    mRes = expandMD 12 cronMonth
-    dRes = expandMD 31 cronDay
+    mRes = expandMD 12 cpMonth
+    dRes = expandMD 31 cpDay
     (s, e) = expandBounds b
     (yb0, mb0, db0) = toGregorian s
     (yb1, mb1, db1) = toGregorian $ addDays (-1) e
@@ -63,7 +63,7 @@ expandCronPat b CronPat {cronYear, cronMonth, cronDay, cronWeekly} =
         . maybe (return [1 .. lim]) (expandMDYPat 1 lim)
     expandW (OnDay x) = [fromEnum x]
     expandW (OnDays xs) = fromEnum <$> xs
-    ws = maybe [] expandW cronWeekly
+    ws = maybe [] expandW cpWeekly
     validWeekday = if null ws then const True else \day -> dayToWeekday day `elem` ws
     toDay (y, leap) m d
       | m == 2 && (not leap && d > 28 || leap && d > 29) = Nothing
@@ -120,28 +120,28 @@ withDates dp f = do
 insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError]
 insertBudget
   b@Budget
-    { budgetLabel
-    , incomes
-    , transfers
-    , shadowTransfers
-    , pretax
-    , tax
-    , posttax
+    { bgtLabel
+    , bgtIncomes
+    , bgtTransfers
+    , bgtShadowTransfers
+    , bgtPretax
+    , bgtTax
+    , bgtPosttax
     } =
     whenHash CTBudget b [] $ \key -> do
       unlessLefts intAllos $ \intAllos_ -> do
-        res1 <- mapM (insertIncome key budgetLabel intAllos_) incomes
-        res2 <- expandTransfers key budgetLabel transfers
+        res1 <- mapM (insertIncome key bgtLabel intAllos_) bgtIncomes
+        res2 <- expandTransfers key bgtLabel bgtTransfers
         unlessLefts (concatEithers2 (concat <$> concatEithersL res1) res2 (++)) $
           \txs -> do
-            unlessLefts (addShadowTransfers shadowTransfers txs) $ \shadow -> do
+            unlessLefts (addShadowTransfers bgtShadowTransfers txs) $ \shadow -> do
               let bals = balanceTransfers $ txs ++ shadow
               concat <$> mapM insertBudgetTx bals
     where
       intAllos =
-        let pre_ = sortAllos pretax
-            tax_ = sortAllos tax
-            post_ = sortAllos posttax
+        let pre_ = sortAllos bgtPretax
+            tax_ = sortAllos bgtTax
+            post_ = sortAllos bgtPosttax
          in concatEithers3 pre_ tax_ post_ (,,)
       sortAllos = concatEithersL . fmap sortAllo
 
@@ -201,12 +201,12 @@ fromShadow tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stTyp
             }
 
 shadowMatches :: TransferMatcher -> UnbalancedTransfer -> EitherErr Bool
-shadowMatches TransferMatcher {smFrom, smTo, smDate, smVal} tx = do
-  valRes <- valMatches smVal $ cvValue $ cbtValue tx
+shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
+  valRes <- valMatches tmVal $ cvValue $ cbtValue tx
   return $
-    memberMaybe (taAcnt $ cbtFrom tx) smFrom
-      && memberMaybe (taAcnt $ cbtTo tx) smTo
-      && maybe True (`dateMatches` cbtWhen tx) smDate
+    memberMaybe (taAcnt $ cbtFrom tx) tmFrom
+      && memberMaybe (taAcnt $ cbtTo tx) tmTo
+      && maybe True (`dateMatches` cbtWhen tx) tmDate
       && valRes
   where
     memberMaybe x AcntSet {asList, asInclude} =
@@ -354,8 +354,8 @@ allocateTax gross deds = fmap (fmap go)
       let agi = gross - sum (mapMaybe (`M.lookup` deds) tvCategories)
        in case tvMethod of
             TMPercent p -> dec2Rat p * agi
-            TMBracket TaxProgression {tbsDeductible, tbsBrackets} ->
-              foldBracket (agi - dec2Rat tbsDeductible) tbsBrackets
+            TMBracket TaxProgression {tpDeductible, tpBrackets} ->
+              foldBracket (agi - dec2Rat tpDeductible) tpBrackets
 
 allocatePost
   :: Rational
@@ -491,11 +491,11 @@ splitPair from to cur val = case cur of
     split c TaggedAcnt {taAcnt, taTags} v =
       resolveSplit $
         Entry
-          { sAcnt = taAcnt
-          , sValue = v
-          , sComment = ""
-          , sCurrency = c
-          , sTags = taTags
+          { eAcnt = taAcnt
+          , eValue = v
+          , eComment = ""
+          , eCurrency = c
+          , eTags = taTags
           }
 
 checkAcntType
@@ -578,7 +578,14 @@ txPair
   -> m (EitherErrs KeyTx)
 txPair day from to cur val desc = resolveTx tx
   where
-    split a v = Entry {sAcnt = a, sValue = v, sComment = "", sCurrency = cur, sTags = []}
+    split a v =
+      Entry
+        { eAcnt = a
+        , eValue = v
+        , eComment = ""
+        , eCurrency = cur
+        , eTags = []
+        }
     tx =
       Tx
         { txDescr = desc
@@ -592,21 +599,21 @@ resolveTx t@Tx {txSplits = ss} = do
   return $ fmap (\kss -> t {txSplits = kss}) res
 
 resolveSplit :: MonadFinance m => BalSplit -> m (EitherErrs KeySplit)
-resolveSplit s@Entry {sAcnt, sCurrency, sValue, sTags} = do
-  aid <- lookupAccountKey sAcnt
-  cid <- lookupCurrency sCurrency
-  sign <- lookupAccountSign sAcnt
-  tags <- mapM lookupTag sTags
+resolveSplit s@Entry {eAcnt, eCurrency, eValue, eTags} = do
+  aid <- lookupAccountKey eAcnt
+  cid <- lookupCurrency 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) $
       \(aid_, cid_, sign_) tags_ ->
         s
-          { sAcnt = aid_
-          , sCurrency = cid_
-          , sValue = sValue * fromIntegral (sign2Int sign_)
-          , sTags = tags_
+          { eAcnt = aid_
+          , eCurrency = cid_
+          , eValue = eValue * fromIntegral (sign2Int sign_)
+          , eTags = tags_
           }
 
 insertTx :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
@@ -615,9 +622,9 @@ insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do
   mapM_ (insertSplit k) ss
 
 insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m (Key SplitR)
-insertSplit t Entry {sAcnt, sCurrency, sValue, sComment, sTags} = do
-  k <- insert $ SplitR t sCurrency sAcnt sComment sValue
-  mapM_ (insert_ . TagRelationR k) sTags
+insertSplit t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do
+  k <- insert $ SplitR t eCurrency eAcnt eComment eValue
+  mapM_ (insert_ . TagRelationR k) eTags
   return k
 
 lookupAccount :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR, AcntSign, AcntType))
diff --git a/lib/Internal/Statement.hs b/lib/Internal/Statement.hs
index cd9180e..aeaf133 100644
--- a/lib/Internal/Statement.hs
+++ b/lib/Internal/Statement.hs
@@ -21,11 +21,11 @@ import qualified RIO.Vector as V
 
 readImport :: MonadFinance m => Statement -> m (EitherErrs [BalTx])
 readImport Statement {..} = do
-  let ores = plural $ compileOptions impTxOpts
-  let cres = concatEithersL $ compileMatch <$> impMatches
+  let ores = plural $ compileOptions stmtTxOpts
+  let cres = concatEithersL $ compileMatch <$> stmtParsers
   case concatEithers2 ores cres (,) of
     Right (compiledOptions, compiledMatches) -> do
-      ires <- mapM (readImport_ impSkipLines impDelim compiledOptions) impPaths
+      ires <- mapM (readImport_ stmtSkipLines stmtDelim compiledOptions) stmtPaths
       case concatEitherL ires of
         Right records -> return $ matchRecords compiledMatches $ L.sort $ concat records
         Left es -> return $ Left es
@@ -75,14 +75,14 @@ matchRecords ms rs = do
 matchPriorities :: [MatchRe] -> [MatchGroup]
 matchPriorities =
   fmap matchToGroup
-    . L.groupBy (\a b -> mPriority a == mPriority b)
-    . L.sortOn (Down . mPriority)
+    . L.groupBy (\a b -> spPriority a == spPriority b)
+    . L.sortOn (Down . spPriority)
 
 matchToGroup :: [MatchRe] -> MatchGroup
 matchToGroup ms =
   uncurry MatchGroup $
-    first (L.sortOn mDate) $
-      L.partition (isJust . mDate) ms
+    first (L.sortOn spDate) $
+      L.partition (isJust . spDate) ms
 
 -- TDOO could use a better struct to flatten the maybe date subtype
 data MatchGroup = MatchGroup
@@ -148,9 +148,9 @@ zipperMatch' z x = go z
     go z' = Right (z', MatchFail)
 
 matchDec :: MatchRe -> Maybe MatchRe
-matchDec m = case mTimes m of
+matchDec m = case spTimes m of
   Just 1 -> Nothing
-  Just n -> Just $ m {mTimes = Just $ n - 1}
+  Just n -> Just $ m {spTimes = Just $ n - 1}
   Nothing -> Just m
 
 matchAll :: [MatchGroup] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
@@ -167,7 +167,7 @@ matchGroup :: MatchGroup -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [Matc
 matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
   (md, rest, ud) <- matchDates ds rs
   (mn, unmatched, un) <- matchNonDates ns rest
-  return (md ++ mn, unmatched, filter ((/= Nothing) . mTimes) $ ud ++ un)
+  return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un)
 
 matchDates :: [MatchRe] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
 matchDates ms = go ([], [], initZipper ms)
@@ -188,7 +188,7 @@ matchDates ms = go ([], [], initZipper ms)
                 MatchSkip -> (Nothing : matched, unmatched)
                 MatchFail -> (matched, r : unmatched)
           go (m, u, z') rs
-    findDate m r = maybe EQ (`compareDate` trDate r) $ mDate m
+    findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
 
 matchNonDates :: [MatchRe] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe])
 matchNonDates ms = go ([], [], initZipper ms)
@@ -217,14 +217,14 @@ balanceSplits ss =
   fmap concat
     <$> mapM (uncurry bal)
     $ groupByKey
-    $ fmap (\s -> (sCurrency s, s)) ss
+    $ fmap (\s -> (eCurrency s, s)) ss
   where
-    hasValue s@Entry {sValue = Just v} = Right s {sValue = v}
-    hasValue s = Left s
+    haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
+    haeValue s = Left s
     bal cur rss
       | length rss < 2 = Left $ BalanceError TooFewSplits cur rss
-      | otherwise = case partitionEithers $ fmap hasValue rss of
-          ([noVal], val) -> Right $ noVal {sValue = foldr (\s x -> x - sValue s) 0 val} : val
+      | otherwise = case partitionEithers $ fmap haeValue rss of
+          ([noVal], val) -> Right $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
           ([], val) -> Right val
           _ -> Left $ BalanceError NotOneBlank cur rss
 
diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs
index 6526cb7..d76f539 100644
--- a/lib/Internal/Types.hs
+++ b/lib/Internal/Types.hs
@@ -66,7 +66,7 @@ makeHaskellTypesWith
   , SingleConstructor "PosttaxValue" "PosttaxValue" "(./dhall/Types.dhall).PosttaxValue"
   , SingleConstructor "BudgetTransferValue" "BudgetTransferValue" "(./dhall/Types.dhall).BudgetTransferValue"
   -- , SingleConstructor "ToTx" "ToTx" "(./dhall/Types.dhall).ToTx"
-  -- , SingleConstructor "MatchOther" "MatchOther" "(./dhall/Types.dhall).MatchOther_"
+  -- , SingleConstructor "FieldMatcher" "FieldMatcher" "(./dhall/Types.dhall).FieldMatcher_"
   -- , SingleConstructor "Match" "Match" "(./dhall/Types.dhall).Match_"
   -- , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
   -- SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
@@ -181,13 +181,13 @@ type BudgetTransfer =
   Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
 
 data Budget = Budget
-  { budgetLabel :: Text
-  , incomes :: [Income]
-  , pretax :: [MultiAllocation PretaxValue]
-  , tax :: [MultiAllocation TaxValue]
-  , posttax :: [MultiAllocation PosttaxValue]
-  , transfers :: [BudgetTransfer]
-  , shadowTransfers :: [ShadowTransfer]
+  { bgtLabel :: Text
+  , bgtIncomes :: [Income]
+  , bgtPretax :: [MultiAllocation PretaxValue]
+  , bgtTax :: [MultiAllocation TaxValue]
+  , bgtPosttax :: [MultiAllocation PosttaxValue]
+  , bgtTransfers :: [BudgetTransfer]
+  , bgtShadowTransfers :: [ShadowTransfer]
   }
 
 deriving instance Hashable PretaxValue
@@ -401,9 +401,9 @@ data History
   | HistStatement !Statement
   deriving (Eq, Hashable, Generic, FromDhall)
 
-type ExpSplit = Entry SplitAcnt (Maybe EntryNumGetter) SplitCur TagID
+type EntryGetter = Entry SplitAcnt (Maybe EntryNumGetter) SplitCur TagID
 
-instance FromDhall ExpSplit
+instance FromDhall EntryGetter
 
 deriving instance (Show a, Show c, Show v, Show t) => Show (Entry a v c t)
 
@@ -420,7 +420,7 @@ data Tx s = Tx
   }
   deriving (Generic)
 
-type ExpTx = Tx ExpSplit
+type ExpTx = Tx EntryGetter
 
 instance FromDhall ExpTx
 
@@ -435,27 +435,27 @@ data TxOpts re = TxOpts
   deriving (Eq, Generic, Hashable, Show, FromDhall)
 
 data Statement = Statement
-  { impPaths :: ![FilePath]
-  , impMatches :: ![Match T.Text]
-  , impDelim :: !Word
-  , impTxOpts :: !(TxOpts T.Text)
-  , impSkipLines :: !Natural
+  { stmtPaths :: ![FilePath]
+  , stmtParsers :: ![StatementParser T.Text]
+  , stmtDelim :: !Word
+  , stmtTxOpts :: !(TxOpts T.Text)
+  , stmtSkipLines :: !Natural
   }
   deriving (Eq, Hashable, Generic, FromDhall)
 
 -- | the value of a field in split (text version)
 -- can either be a raw (constant) value, a lookup from the record, or a map
 -- between the lookup and some other value
-data SplitText t
+data EntryTextGetter t
   = ConstT !t
   | LookupT !T.Text
   | MapT !(FieldMap T.Text t)
   | Map2T !(FieldMap (T.Text, T.Text) t)
   deriving (Eq, Generic, Hashable, Show, FromDhall)
 
-type SplitCur = SplitText CurID
+type SplitCur = EntryTextGetter CurID
 
-type SplitAcnt = SplitText AcntID
+type SplitAcnt = EntryTextGetter AcntID
 
 deriving instance (Show k, Show v) => Show (Field k v)
 
@@ -476,32 +476,32 @@ instance Functor (Field f) where
 
 type FieldMap k v = Field k (M.Map k v)
 
-data MatchOther re
+data FieldMatcher re
   = Desc !(Field T.Text re)
   | Val !(Field T.Text ValMatcher)
   deriving (Eq, Hashable, Generic, FromDhall, Functor, Foldable, Traversable)
 
-deriving instance Show (MatchOther T.Text)
+deriving instance Show (FieldMatcher T.Text)
 
-data ToTx = ToTx
-  { ttCurrency :: !SplitCur
-  , ttPath :: !SplitAcnt
-  , ttSplit :: ![ExpSplit]
+data TxGetter = TxGetter
+  { tgCurrency :: !SplitCur
+  , tgAcnt :: !SplitAcnt
+  , tgEntries :: ![EntryGetter]
   }
   deriving (Eq, Generic, Hashable, Show, FromDhall)
 
-data Match re = Match
-  { mDate :: !(Maybe DateMatcher)
-  , mVal :: !ValMatcher
-  , mDesc :: !(Maybe re)
-  , mOther :: ![MatchOther re]
-  , mTx :: !(Maybe ToTx)
-  , mTimes :: !(Maybe Natural)
-  , mPriority :: !Integer
+data StatementParser re = StatementParser
+  { spDate :: !(Maybe DateMatcher)
+  , spVal :: !ValMatcher
+  , spDesc :: !(Maybe re)
+  , spOther :: ![FieldMatcher re]
+  , spTx :: !(Maybe TxGetter)
+  , spTimes :: !(Maybe Natural)
+  , spPriority :: !Integer
   }
   deriving (Eq, Generic, Hashable, FromDhall, Functor)
 
-deriving instance Show (Match T.Text)
+deriving instance Show (StatementParser T.Text)
 
 --------------------------------------------------------------------------------
 -- DATABASE MODEL
@@ -753,11 +753,11 @@ data XGregorian = XGregorian
   , xgDayOfWeek :: !Int
   }
 
-type MatchRe = Match (T.Text, Regex)
+type MatchRe = StatementParser (T.Text, Regex)
 
 type TxOptsRe = TxOpts (T.Text, Regex)
 
-type MatchOtherRe = MatchOther (T.Text, Regex)
+type FieldMatcherRe = FieldMatcher (T.Text, Regex)
 
-instance Show (Match (T.Text, Regex)) where
+instance Show (StatementParser (T.Text, Regex)) where
   show = show . fmap fst
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index 873f5f1..ddfb701 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -155,29 +155,29 @@ expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d)
 
 matches :: MatchRe -> TxRecord -> EitherErrs (MatchRes RawTx)
 matches
-  Match {mTx, mOther, mVal, mDate, mDesc}
+  StatementParser {spTx, spOther, spVal, spDate, spDesc}
   r@TxRecord {trDate, trAmount, trDesc, trOther} = do
     res <- concatEither3 val other desc $ \x y z -> x && y && z
     if date && res
-      then maybe (Right MatchSkip) (fmap MatchPass . convert) mTx
+      then maybe (Right MatchSkip) (fmap MatchPass . convert) spTx
       else Right MatchFail
     where
-      val = valMatches mVal trAmount
-      date = maybe True (`dateMatches` trDate) mDate
-      other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True mOther
-      desc = maybe (return True) (matchMaybe trDesc . snd) mDesc
-      convert (ToTx cur a ss) = toTx cur a ss r
+      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
 
-toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErrs RawTx
+toTx :: SplitCur -> SplitAcnt -> [EntryGetter] -> TxRecord -> EitherErrs RawTx
 toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
   concatEithers2 acRes ssRes $ \(a_, c_) ss_ ->
     let fromSplit =
           Entry
-            { sAcnt = a_
-            , sCurrency = c_
-            , sValue = Just trAmount
-            , sComment = ""
-            , sTags = [] -- TODO what goes here?
+            { eAcnt = a_
+            , eCurrency = c_
+            , eValue = Just trAmount
+            , eComment = ""
+            , eTags = [] -- TODO what goes here?
             }
      in Tx
           { txDate = trDate
@@ -189,36 +189,36 @@ toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
     ssRes = concatEithersL $ fmap (resolveSplit r) toSplits
 
 valMatches :: ValMatcher -> Rational -> EitherErr Bool
-valMatches ValMatcher {mvDen, mvSign, mvNum, mvPrec} x
-  | Just d_ <- mvDen, d_ >= p = Left $ MatchValPrecisionError d_ p
+valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
+  | Just d_ <- vmDen, d_ >= p = Left $ MatchValPrecisionError d_ p
   | otherwise =
       Right $
-        checkMaybe (s ==) mvSign
-          && checkMaybe (n ==) mvNum
-          && checkMaybe ((d * fromIntegral p ==) . fromIntegral) mvDen
+        checkMaybe (s ==) vmSign
+          && checkMaybe (n ==) vmNum
+          && checkMaybe ((d * fromIntegral p ==) . fromIntegral) vmDen
   where
     (n, d) = properFraction $ abs x
-    p = 10 ^ mvPrec
+    p = 10 ^ vmPrec
     s = signum x >= 0
     checkMaybe = maybe True
 
 dateMatches :: DateMatcher -> Day -> Bool
 dateMatches md = (EQ ==) . compareDate md
 
-otherMatches :: M.Map T.Text T.Text -> MatchOtherRe -> EitherErr Bool
+otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> EitherErr 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 -> ExpSplit -> EitherErrs RawSplit
-resolveSplit r s@Entry {sAcnt = a, sValue = v, sCurrency = c} =
+resolveSplit :: TxRecord -> EntryGetter -> EitherErrs RawSplit
+resolveSplit r s@Entry {eAcnt, eValue, eCurrency} =
   concatEithers2 acRes valRes $
-    \(a_, c_) v_ -> (s {sAcnt = a_, sValue = v_, sCurrency = c_})
+    \(a_, c_) v_ -> (s {eAcnt = a_, eValue = v_, eCurrency = c_})
   where
-    acRes = concatEithers2 (resolveAcnt r a) (resolveCurrency r c) (,)
-    valRes = plural $ mapM (resolveValue r) v
+    acRes = concatEithers2 (resolveAcnt r eAcnt) (resolveCurrency r eCurrency) (,)
+    valRes = plural $ mapM (resolveValue r) eValue
 
 resolveValue :: TxRecord -> EntryNumGetter -> EitherErr Rational
 resolveValue r s = case s of
@@ -410,18 +410,18 @@ showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
       ]
 
 showMatch :: MatchRe -> T.Text
-showMatch Match {mDate = d, mVal = v, mDesc = e, mOther = o, mTimes = n, mPriority = p} =
+showMatch StatementParser {spDate, spVal, spDesc, spOther, spTimes, spPriority} =
   T.append "Unused match: " $ keyVals [(x, y) | (x, Just y) <- kvs]
   where
     kvs =
-      [ ("date", showDateMatcher <$> d)
-      , ("val", showValMatcher v)
-      , ("desc", fst <$> e)
+      [ ("date", showDateMatcher <$> spDate)
+      , ("val", showValMatcher spVal)
+      , ("desc", fst <$> spDesc)
       , ("other", others)
-      , ("counter", Just $ maybe "Inf" showT n)
-      , ("priority", Just $ showT p)
+      , ("counter", Just $ maybe "Inf" showT spTimes)
+      , ("priority", Just $ showT spPriority)
       ]
-    others = case o of
+    others = case spOther of
       [] -> Nothing
       xs -> Just $ singleQuote $ T.concat $ showMatchOther <$> xs
 
@@ -460,18 +460,18 @@ showYMD_ md =
       YMD_ y m d -> [fromIntegral y, m, d]
 
 showValMatcher :: ValMatcher -> Maybe T.Text
-showValMatcher ValMatcher {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing
-showValMatcher ValMatcher {mvNum, mvDen, mvSign, mvPrec} =
+showValMatcher ValMatcher {vmSign = Nothing, vmNum = Nothing, vmDen = Nothing} = Nothing
+showValMatcher ValMatcher {vmNum, vmDen, vmSign, vmPrec} =
   Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs]
   where
     kvs =
-      [ ("sign", (\s -> if s then "+" else "-") <$> mvSign)
-      , ("numerator", showT <$> mvNum)
-      , ("denominator", showT <$> mvDen)
-      , ("precision", Just $ showT mvPrec)
+      [ ("sign", (\s -> if s then "+" else "-") <$> vmSign)
+      , ("numerator", showT <$> vmNum)
+      , ("denominator", showT <$> vmDen)
+      , ("precision", Just $ showT vmPrec)
       ]
 
-showMatchOther :: MatchOtherRe -> T.Text
+showMatchOther :: FieldMatcherRe -> T.Text
 showMatchOther (Desc (Field f (re, _))) =
   T.unwords ["desc field", singleQuote f, "with re", singleQuote re]
 showMatchOther (Val (Field f mv)) =
@@ -483,11 +483,11 @@ showMatchOther (Val (Field f mv)) =
     ]
 
 showSplit :: RawSplit -> T.Text
-showSplit Entry {sAcnt = a, sValue = v, sComment = c} =
+showSplit Entry {eAcnt, eValue, eComment} =
   keyVals
-    [ ("account", a)
-    , ("value", T.pack $ show ((fromRational <$> v) :: Maybe Float))
-    , ("comment", doubleQuote c)
+    [ ("account", eAcnt)
+    , ("value", T.pack $ show ((fromRational <$> eValue) :: Maybe Float))
+    , ("comment", doubleQuote eComment)
     ]
 
 singleQuote :: T.Text -> T.Text
@@ -621,11 +621,11 @@ compileOptions o@TxOpts {toAmountFmt = pat} = do
   re <- compileRegex True pat
   return $ o {toAmountFmt = re}
 
-compileMatch :: Match T.Text -> EitherErrs MatchRe
-compileMatch m@Match {mDesc = d, mOther = os} = do
-  let dres = plural $ mapM go d
-  let ores = concatEitherL $ fmap (mapM go) os
-  concatEithers2 dres ores $ \d_ os_ -> m {mDesc = d_, mOther = os_}
+compileMatch :: StatementParser T.Text -> EitherErrs MatchRe
+compileMatch m@StatementParser {spDesc, spOther} = do
+  let dres = plural $ mapM go spDesc
+  let ores = concatEitherL $ fmap (mapM go) spOther
+  concatEithers2 dres ores $ \d_ os_ -> m {spDesc = d_, spOther = os_}
   where
     go = compileRegex False
 

From 38710b1f568fce2d96cacc7e7d1d2e4fc2bb1536 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Thu, 4 May 2023 21:48:21 -0400
Subject: [PATCH 10/15] WIP use doubles in config

---
 dhall/Types.dhall            |  31 +++---
 dhall/common.dhall           |  19 +---
 lib/Internal/Database/Ops.hs |  13 ++-
 lib/Internal/Insert.hs       | 179 ++++++++++++++++++++---------------
 lib/Internal/Statement.hs    | 132 ++++++++++++++++----------
 lib/Internal/Types.hs        |  46 +++++----
 lib/Internal/Utils.hs        | 112 ++++++++++++++--------
 7 files changed, 310 insertions(+), 222 deletions(-)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index a4e8704..dbbde81 100644
--- a/dhall/Types.dhall
+++ b/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_
diff --git a/dhall/common.dhall b/dhall/common.dhall
index e9a7d34..b8c96d0 100644
--- a/dhall/common.dhall
+++ b/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
diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs
index 11bb000..dda0baf 100644
--- a/lib/Internal/Database/Ops.hs
+++ b/lib/Internal/Database/Ops.hs
@@ -194,11 +194,18 @@ updateCurrencies cs = do
   return $ currencyMap curs
 
 currency2Record :: Currency -> Entity CurrencyR
-currency2Record c@Currency {curSymbol, curFullname} =
-  Entity (toKey c) $ CurrencyR curSymbol curFullname
+currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
+  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
diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs
index 13a9cf9..5d7a866 100644
--- a/lib/Internal/Insert.hs
+++ b/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 $
-      fmap (uncurry fromShadow) $
+    concatEithersL $
+      fmap (uncurry (fromShadow cm)) $
         [(t, m) | t <- txs, m <- ms]
 
 fromShadow
-  :: UnbalancedTransfer
+  :: CurrencyMap
+  -> UnbalancedTransfer
   -> ShadowTransfer
-  -> EitherErr (Maybe UnbalancedTransfer)
-fromShadow tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
+  -> EitherErrs (Maybe UnbalancedTransfer)
+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
-      Left e -> return $ Left [e]
+    precRes <- lift $ lookupCurrencyPrec incCurrency
+    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
-          v = if prePercent faValue then p * gross else p
+          p = preValue faValue
+          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 agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
+foldBracket :: Natural -> Rational -> [TaxBracket] -> Rational
+foldBracket precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
   where
     go TaxBracket {tbLowerLimit, tbPercent} (acc, remain) =
-      let l = dec2Rat tbLowerLimit
-          p = dec2Rat tbPercent
+      let l = roundPrecision precision tbLowerLimit
+          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} =
-  -- whenHash CTExpense t (Right []) $ \key ->
-  fmap (fmap concat . concatEithersL) $
-    forM transAmounts $
-      \Amount
-        { amtWhen = pat
-        , amtValue = BudgetTransferValue {btVal = v, btType = y}
-        , amtDesc = desc
-        } ->
-          do
-            withDates pat $ \day ->
-              let meta =
-                    BudgetMeta
-                      { bmCommit = key
-                      , bmName = name
-                      }
-                  tx =
-                    FlatTransfer
-                      { cbtMeta = meta
-                      , cbtWhen = day
-                      , cbtCur = transCurrency
-                      , cbtFrom = transFrom
-                      , cbtTo = transTo
-                      , cbtValue = UnbalancedValue y $ dec2Rat v
-                      , cbtDesc = desc
-                      }
-               in return $ Right tx
+expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do
+  pRes <- lift $ lookupCurrencyPrec $ initialCurrency transCurrency
+  case pRes of
+    Left es -> return $ Left es
+    Right p ->
+      fmap (fmap concat . concatEithersL) $
+        forM transAmounts $
+          \Amount
+            { amtWhen = pat
+            , amtValue = BudgetTransferValue {btVal = v, btType = y}
+            , amtDesc = desc
+            } ->
+              do
+                withDates pat $ \day ->
+                  let meta =
+                        BudgetMeta
+                          { bmCommit = key
+                          , bmName = name
+                          }
+                      tx =
+                        FlatTransfer
+                          { cbtMeta = meta
+                          , cbtWhen = day
+                          , cbtCur = transCurrency
+                          , cbtFrom = transFrom
+                          , cbtTo = transTo
+                          , 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
-          let tx day = txPair day from to u v amtDesc
+        -- TODO rounding too often
+        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)
diff --git a/lib/Internal/Statement.hs b/lib/Internal/Statement.hs
index aeaf133..c6496bb 100644
--- a/lib/Internal/Statement.hs
+++ b/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
-  case (matched, unmatched, notfound) of
-    (ms_, [], []) -> do
-      -- TODO record number of times each match hits for debugging
-      matched_ <- first (: []) $ mapM balanceTx ms_
-      Right matched_
-    (_, us, ns) -> Left [StatementError us ns]
+  res <- matchAll (matchPriorities ms) rs
+  case res of
+    Left es -> return $ Left es
+    Right (matched, unmatched, notfound) -> do
+      case (matched, unmatched, notfound) of
+        (ms_, [], []) -> do
+          -- 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
-        skipOrPass ->
+        Right MatchFail -> go (m : prev) ms
+        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)
-        skipOrPass -> Right (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
-    go z' = Right (z', MatchFail)
+        Right MatchFail -> go (Zipped (a : bs) as)
+        Right skipOrPass ->
+          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 (matched, rs, unused)
+      (_, []) -> return $ Right (matched, [], unused)
+      ([], _) -> return $ Right (matched, rs, unused)
       (g : gs', _) -> do
-        (ts, unmatched, us) <- matchGroup g rs
-        go (ts ++ matched, us ++ unused) gs' unmatched
+        res <- matchGroup g rs
+        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
-  (mn, unmatched, un) <- matchNonDates ns rest
-  return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un)
+  res <- matchDates ds rs
+  case res of
+    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
-        ( catMaybes matched
-        , reverse unmatched
-        , recoverZipper z
-        )
+      return $
+        Right
+          ( catMaybes matched
+          , 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
-          let (m, u) = case res of
-                MatchPass p -> (Just p : matched, unmatched)
-                MatchSkip -> (Nothing : matched, unmatched)
-                MatchFail -> (matched, r : unmatched)
-          go (m, u, z') rs
+          res <- zipperMatch unzipped r
+          case res of
+            Right (z', res') -> do
+              let (m, u) = case res' of
+                    (MatchPass p) -> (Just p : matched, unmatched)
+                    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
-        ( catMaybes matched
-        , reverse unmatched
-        , recoverZipper z
-        )
+      return $
+        Right
+          ( catMaybes matched
+          , reverse unmatched
+          , recoverZipper z
+          )
     go (matched, unmatched, z) (r : rs) = do
-      (z', res) <- zipperMatch' z r
-      let (m, u) = case res of
-            MatchPass p -> (Just p : matched, unmatched)
-            MatchSkip -> (Nothing : matched, unmatched)
-            MatchFail -> (matched, r : unmatched)
-       in go (m, u, resetZipper z') rs
+      res <- zipperMatch' z r
+      case res of
+        Left es -> return $ Left es
+        Right (z', res') -> do
+          let (m, u) = case res' of
+                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
diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs
index d76f539..d8f05c1 100644
--- a/lib/Internal/Types.hs
+++ b/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 instance
-  (Generic w, Generic v, Hashable a, Hashable c, Hashable w, Hashable v)
-  => Hashable (Transfer a c w v)
+  deriving (Eq, Show)
 
 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
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index ddfb701..9f25089 100644
--- a/lib/Internal/Utils.hs
+++ b/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
-    if date && res
-      then maybe (Right MatchSkip) (fmap MatchPass . convert) spTx
-      else Right MatchFail
+    let res = concatEithers3 val other desc $ \x y z -> x && y && z && date
+    case res of
+      Right test
+        | 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 sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
-  concatEithers2 acRes ssRes $ \(a_, c_) ss_ ->
+toTx :: SplitCur -> SplitAcnt -> [EntryGetter] -> TxRecord -> CurrencyM (EitherErrs RawTx)
+toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = do
+  m <- ask
+  let ssRes = concatEithersL $ fmap (resolveEntry m r) toSplits
+  return $ concatEithers2 acRes ssRes $ \(a, c) ss ->
     let fromSplit =
           Entry
-            { eAcnt = a_
-            , eCurrency = c_
+            { eAcnt = a
+            , 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
-resolveSplit r s@Entry {eAcnt, eValue, eCurrency} =
-  concatEithers2 acRes valRes $
-    \(a_, c_) v_ -> (s {eAcnt = a_, eValue = v_, eCurrency = c_})
+resolveEntry :: CurrencyMap -> TxRecord -> EntryGetter -> EitherErrs RawSplit
+resolveEntry m r s@Entry {eAcnt, eValue, eCurrency} = do
+  (a, c, v) <- concatEithers2 acRes valRes $ \(a, c) v -> (a, c, v)
+  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)
-  (ConstN c) -> Right $ dec2Rat c
-  AmountN -> Right $ trAmount r
+  (LookupN t) -> readDouble =<< lookupErr SplitValField t (trOther r)
+  (ConstN c) -> Right c
+  -- 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
-  MapT (Field f m) -> plural $ do
+  LookupT f -> lookup_ f o
+  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) (,)
-    plural $ lookup_ (k1, k2) m
+    (k1, k2) <- concatEithers2 (lookup_ f1 o) (lookup_ f2 o) (,)
+    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
-dec2Rat D {sign, whole, decimal, precision} =
-  k * (fromIntegral whole + (fromIntegral decimal % (10 ^ precision)))
+roundPrecision :: Natural -> Double -> Rational
+roundPrecision n = (% p) . round . (* fromIntegral p) . toRational
   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

From 9a1dd1ac3e0c6d01c0f38bcc86b4d4219c58c779 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sun, 7 May 2023 20:29:33 -0400
Subject: [PATCH 11/15] ENH use doubles and get clean compile

---
 app/Main.hs                  |  19 +-
 budget.cabal                 |   2 +
 lib/Internal/Database/Ops.hs | 123 +++++------
 lib/Internal/Insert.hs       | 381 +++++++++++++++++------------------
 lib/Internal/Statement.hs    | 167 +++++++--------
 lib/Internal/Types.hs        |  25 +--
 lib/Internal/Utils.hs        | 338 ++++++++++++++++++++-----------
 package.yaml                 |   1 +
 stack.yaml                   |   1 +
 9 files changed, 562 insertions(+), 495 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index f479df0..a0f39d7 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -103,7 +103,7 @@ sync =
 parse :: Options -> IO ()
 parse (Options c Reset) = do
   config <- readConfig c
-  migrate_ (sqlConfig config) nukeTables
+  runDB (sqlConfig config) nukeTables
 parse (Options c DumpAccounts) = runDumpAccounts c
 parse (Options c DumpAccountKeys) = runDumpAccountKeys c
 parse (Options c DumpCurrencies) = runDumpCurrencies c
@@ -155,19 +155,14 @@ runDumpAccountKeys c = do
     t3 (_, _, x) = x
     double x = (x, x)
 
-runSync :: MonadUnliftIO m => FilePath -> m ()
+runSync :: FilePath -> IO ()
 runSync c = do
   config <- readConfig c
-  handle err $ migrate_ (sqlConfig config) $ do
-    res <- getDBState config
-    case res of
-      Left es -> throwIO $ InsertException es
-      Right s -> do
-        let run = mapReaderT $ flip runReaderT (s $ takeDirectory c)
-        es1 <- concat <$> mapM (run . insertBudget) (budget config)
-        es2 <- run $ insertStatements config
-        let es = es1 ++ es2
-        unless (null es) $ throwIO $ InsertException es
+  handle err $ runDB (sqlConfig config) $ do
+    let bgtRes = liftIOExceptT $ mapErrors insertBudget $ budget config
+    let histRes = mapErrorsIO insertStatement $ statements config
+    s <- fmap (\f -> f $ takeDirectory c) $ liftIOExceptT $ getDBState config
+    flip runReaderT s $ combineErrorIO2 bgtRes histRes $ \_ _ -> ()
   where
     err (InsertException es) = do
       liftIO $ mapM_ TI.putStrLn $ concatMap showError es
diff --git a/budget.cabal b/budget.cabal
index 6c1cdb4..c3ae77e 100644
--- a/budget.cabal
+++ b/budget.cabal
@@ -89,6 +89,7 @@ library
     , mtl
     , optparse-applicative
     , persistent >=2.13.3.1
+    , persistent-mtl >=0.3.0.0
     , persistent-sqlite
     , recursion-schemes
     , regex-tdfa
@@ -158,6 +159,7 @@ executable pwncash
     , mtl
     , optparse-applicative
     , persistent >=2.13.3.1
+    , persistent-mtl >=0.3.0.0
     , persistent-sqlite
     , recursion-schemes
     , regex-tdfa
diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs
index dda0baf..8a09223 100644
--- a/lib/Internal/Database/Ops.hs
+++ b/lib/Internal/Database/Ops.hs
@@ -1,5 +1,5 @@
 module Internal.Database.Ops
-  ( migrate_
+  ( runDB
   , nukeTables
   , updateHashes
   , getDBState
@@ -10,12 +10,15 @@ module Internal.Database.Ops
 where
 
 import Conduit
+import Control.Monad.Except
 import Control.Monad.Logger
 import Data.Hashable
-import Database.Esqueleto.Experimental
-import Database.Persist.Sql hiding (delete, (==.), (||.))
-import Database.Persist.Sqlite hiding (delete, (==.), (||.))
-import Database.Sqlite hiding (Config)
+import Database.Esqueleto.Experimental ((==.), (^.))
+import qualified Database.Esqueleto.Experimental as E
+import Database.Esqueleto.Internal.Internal (SqlSelect)
+import Database.Persist.Monad
+-- import Database.Persist.Sql hiding (delete, runMigration, (==.), (||.))
+import Database.Persist.Sqlite hiding (delete, deleteWhere, insert, insertKey, runMigration, (==.), (||.))
 import GHC.Err
 import Internal.Types
 import Internal.Utils
@@ -26,31 +29,27 @@ import qualified RIO.Map as M
 import qualified RIO.NonEmpty as N
 import qualified RIO.Text as T
 
-migrate_
+runDB
   :: MonadUnliftIO m
   => SqlConfig
-  -> SqlPersistT (ResourceT (NoLoggingT m)) ()
-  -> m ()
-migrate_ c more =
-  runNoLoggingT $
-    runResourceT $
-      withSqlConn
-        (openConnection c)
-        ( \backend ->
-            flip runSqlConn backend $ do
-              _ <- askLoggerIO
-              runMigration migrateAll
-              more
-        )
+  -> SqlQueryT (NoLoggingT m) a
+  -> m a
+runDB c more =
+  runNoLoggingT $ do
+    pool <- mkPool c
+    runSqlQueryT pool $ do
+      _ <- lift askLoggerIO
+      runMigration migrateAll
+      more
 
-openConnection :: MonadUnliftIO m => SqlConfig -> LogFunc -> m SqlBackend
-openConnection c logfn = case c of
-  Sqlite p -> liftIO $ do
-    conn <- open p
-    wrapConnection conn logfn
+mkPool :: (MonadLoggerIO m, MonadUnliftIO m) => SqlConfig -> m ConnectionPool
+mkPool c = case c of
+  Sqlite p -> createSqlitePool p 10
+  -- conn <- open p
+  -- wrapConnection conn logfn
   Postgres -> error "postgres not implemented"
 
-nukeTables :: MonadUnliftIO m => SqlPersistT m ()
+nukeTables :: MonadSqlQuery m => m ()
 nukeTables = do
   deleteWhere ([] :: [Filter CommitR])
   deleteWhere ([] :: [Filter CurrencyR])
@@ -118,54 +117,54 @@ setDiff as bs = (as \\ bs, bs \\ as)
 --       | f a b = Just bs
 --       | otherwise = inB a bs
 
-getDBHashes :: MonadUnliftIO m => SqlPersistT m [Int]
+getDBHashes :: MonadSqlQuery m => m [Int]
 getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
 
-nukeDBHash :: MonadUnliftIO m => Int -> SqlPersistT m ()
-nukeDBHash h = delete $ do
-  c <- from table
-  where_ (c ^. CommitRHash ==. val h)
+nukeDBHash :: MonadSqlQuery m => Int -> m ()
+nukeDBHash h = deleteE $ do
+  c <- E.from E.table
+  E.where_ (c ^. CommitRHash ==. E.val h)
 
-nukeDBHashes :: MonadUnliftIO m => [Int] -> SqlPersistT m ()
+nukeDBHashes :: MonadSqlQuery m => [Int] -> m ()
 nukeDBHashes = mapM_ nukeDBHash
 
-getConfigHashes :: MonadUnliftIO m => Config -> SqlPersistT m ([Int], [Int])
+getConfigHashes :: MonadSqlQuery m => Config -> m ([Int], [Int])
 getConfigHashes c = do
   let ch = hashConfig c
   dh <- getDBHashes
   return $ setDiff dh ch
 
-updateHashes :: MonadUnliftIO m => Config -> SqlPersistT m [Int]
+updateHashes :: MonadSqlQuery m => Config -> m [Int]
 updateHashes c = do
   (del, new) <- getConfigHashes c
   nukeDBHashes del
   return new
 
-dumpTbl :: (PersistEntity r, MonadUnliftIO m) => SqlPersistT m [Entity r]
-dumpTbl = select $ from table
+dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r]
+dumpTbl = selectE $ E.from E.table
 
-deleteAccount :: MonadUnliftIO m => Entity AccountR -> SqlPersistT m ()
-deleteAccount e = delete $ do
-  c <- from $ table @AccountR
-  where_ (c ^. AccountRId ==. val k)
+deleteAccount :: MonadSqlQuery m => Entity AccountR -> m ()
+deleteAccount e = deleteE $ do
+  c <- E.from $ E.table @AccountR
+  E.where_ (c ^. AccountRId ==. E.val k)
   where
     k = entityKey e
 
-deleteCurrency :: MonadUnliftIO m => Entity CurrencyR -> SqlPersistT m ()
-deleteCurrency e = delete $ do
-  c <- from $ table @CurrencyR
-  where_ (c ^. CurrencyRId ==. val k)
+deleteCurrency :: MonadSqlQuery m => Entity CurrencyR -> m ()
+deleteCurrency e = deleteE $ do
+  c <- E.from $ E.table @CurrencyR
+  E.where_ (c ^. CurrencyRId ==. E.val k)
   where
     k = entityKey e
 
-deleteTag :: MonadUnliftIO m => Entity TagR -> SqlPersistT m ()
-deleteTag e = delete $ do
-  c <- from $ table @TagR
-  where_ (c ^. TagRId ==. val k)
+deleteTag :: MonadSqlQuery m => Entity TagR -> m ()
+deleteTag e = deleteE $ do
+  c <- E.from $ E.table @TagR
+  E.where_ (c ^. TagRId ==. E.val k)
   where
     k = entityKey e
 
-updateAccounts :: MonadUnliftIO m => AccountRoot -> SqlPersistT m AccountMap
+updateAccounts :: MonadSqlQuery m => AccountRoot -> m AccountMap
 updateAccounts ar = do
   let (acnts, paths, acntMap) = indexAcntRoot ar
   acnts' <- dumpTbl
@@ -179,15 +178,15 @@ updateAccounts ar = do
 
 -- TODO slip-n-slide code...
 insertFull
-  :: (MonadUnliftIO m, PersistStoreWrite b, PersistRecordBackend r b)
+  :: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m)
   => Entity r
-  -> ReaderT b m ()
+  -> m ()
 insertFull (Entity k v) = insertKey k v
 
-updateCurrencies :: MonadUnliftIO m => [Currency] -> SqlPersistT m CurrencyMap
+updateCurrencies :: MonadSqlQuery m => [Currency] -> m CurrencyMap
 updateCurrencies cs = do
   let curs = fmap currency2Record cs
-  curs' <- select $ from $ table @CurrencyR
+  curs' <- selectE $ E.from $ E.table @CurrencyR
   let (toIns, toDel) = setDiff curs curs'
   mapM_ deleteCurrency toDel
   mapM_ insertFull toIns
@@ -207,10 +206,10 @@ currencyMap =
           )
       )
 
-updateTags :: MonadUnliftIO m => [Tag] -> SqlPersistT m TagMap
+updateTags :: MonadSqlQuery m => [Tag] -> m TagMap
 updateTags cs = do
   let tags = fmap toRecord cs
-  tags' <- select $ from $ table @TagR
+  tags' <- selectE $ E.from $ E.table @TagR
   let (toIns, toDel) = setDiff tags tags'
   mapM_ deleteTag toDel
   mapM_ insertFull toIns
@@ -324,9 +323,9 @@ indexAcntRoot r =
     (ars, aprs, ms) = L.unzip3 $ uncurry tree2Records <$> flattenAcntRoot r
 
 getDBState
-  :: MonadUnliftIO m
+  :: (MonadInsertError m, MonadSqlQuery m)
   => Config
-  -> SqlPersistT m (EitherErrs (FilePath -> DBState))
+  -> m (FilePath -> DBState)
 getDBState c = do
   am <- updateAccounts $ accounts c
   cm <- updateCurrencies $ currencies c
@@ -334,7 +333,7 @@ getDBState c = do
   hs <- updateHashes c
   -- TODO not sure how I feel about this, probably will change this struct alot
   -- in the future so whatever...for now
-  return $ concatEither2 bi si $ \b s f ->
+  combineError bi si $ \b s f ->
     DBState
       { kmCurrency = cm
       , kmAccount = am
@@ -345,5 +344,11 @@ getDBState c = do
       , kmTag = ts
       }
   where
-    bi = resolveBounds $ budgetInterval $ global c
-    si = resolveBounds $ statementInterval $ global c
+    bi = liftExcept $ resolveBounds $ budgetInterval $ global c
+    si = liftExcept $ resolveBounds $ statementInterval $ global c
+
+deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m ()
+deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)
+
+selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r]
+selectE q = unsafeLiftSql "esqueleto-select" (E.select q)
diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs
index 5d7a866..443ac5e 100644
--- a/lib/Internal/Insert.hs
+++ b/lib/Internal/Insert.hs
@@ -1,14 +1,14 @@
 module Internal.Insert
-  ( insertStatements
+  ( insertStatement
   , insertBudget
   )
 where
 
+import Control.Monad.Except
 import Data.Hashable
-import Database.Persist.Class
-import Database.Persist.Sql hiding (Single, Statement)
+import Database.Persist.Monad
 import Internal.Statement
-import Internal.Types hiding (CurrencyM, sign)
+import Internal.Types
 import Internal.Utils
 import RIO hiding (to)
 import qualified RIO.List as L
@@ -20,9 +20,9 @@ import RIO.Time
 --------------------------------------------------------------------------------
 -- intervals
 
-expandDatePat :: Bounds -> DatePat -> EitherErrs [Day]
+expandDatePat :: Bounds -> DatePat -> InsertExcept [Day]
 expandDatePat b (Cron cp) = expandCronPat b cp
-expandDatePat i (Mod mp) = Right $ expandModPat mp i
+expandDatePat i (Mod mp) = return $ expandModPat mp i
 
 expandModPat :: ModPat -> Bounds -> [Day]
 expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs =
@@ -39,9 +39,9 @@ expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs =
       Month -> addGregorianMonthsClip
       Year -> addGregorianYearsClip
 
-expandCronPat :: Bounds -> CronPat -> EitherErrs [Day]
+expandCronPat :: Bounds -> CronPat -> InsertExcept [Day]
 expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} =
-  concatEither3 yRes mRes dRes $ \ys ms ds ->
+  combineError3 yRes mRes dRes $ \ys ms ds ->
     filter validWeekday $
       mapMaybe (uncurry3 toDay) $
         takeWhile (\((y, _), m, d) -> (y, m, d) <= (yb1, mb1, db1)) $
@@ -70,38 +70,37 @@ expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} =
       | m `elem` [4, 6, 9, 11] && d > 30 = Nothing
       | otherwise = Just $ fromGregorian y m d
 
-expandMDYPat :: Natural -> Natural -> MDYPat -> EitherErr [Natural]
-expandMDYPat lower upper (Single x) = Right [x | lower <= x && x <= upper]
-expandMDYPat lower upper (Multi xs) = Right $ dropWhile (<= lower) $ takeWhile (<= upper) xs
-expandMDYPat lower upper (After x) = Right [max lower x .. upper]
-expandMDYPat lower upper (Before x) = Right [lower .. min upper x]
-expandMDYPat lower upper (Between x y) = Right [max lower x .. min upper y]
+expandMDYPat :: Natural -> Natural -> MDYPat -> InsertExcept [Natural]
+expandMDYPat lower upper (Single x) = return [x | lower <= x && x <= upper]
+expandMDYPat lower upper (Multi xs) = return $ dropWhile (<= lower) $ takeWhile (<= upper) xs
+expandMDYPat lower upper (After x) = return [max lower x .. upper]
+expandMDYPat lower upper (Before x) = return [lower .. min upper x]
+expandMDYPat lower upper (Between x y) = return [max lower x .. min upper y]
 expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r})
-  | b < 1 = Left $ PatternError s b r ZeroLength
+  | b < 1 = throwError $ InsertException [PatternError s b r ZeroLength]
   | otherwise = do
       k <- limit r
       return $ dropWhile (<= lower) $ takeWhile (<= k) [s + i * b | i <- [0 ..]]
   where
-    limit Nothing = Right upper
+    limit Nothing = return upper
     limit (Just n)
       -- this guard not only produces the error for the user but also protects
       -- from an underflow below it
-      | n < 1 = Left $ PatternError s b r ZeroRepeats
-      | otherwise = Right $ min (s + b * (n - 1)) upper
+      | n < 1 = throwError $ InsertException [PatternError s b r ZeroRepeats]
+      | otherwise = return $ min (s + b * (n - 1)) upper
 
 dayToWeekday :: Day -> Int
 dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7
 
 withDates
-  :: MonadFinance m
+  :: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
   => DatePat
-  -> (Day -> SqlPersistT m (EitherErrs a))
-  -> SqlPersistT m (EitherErrs [a])
+  -> (Day -> m a)
+  -> m [a]
 withDates dp f = do
-  bounds <- lift $ askDBState kmBudgetInterval
-  case expandDatePat bounds dp of
-    Left es -> return $ Left es
-    Right days -> concatEithersL <$> mapM f days
+  bounds <- askDBState kmBudgetInterval
+  days <- liftExcept $ expandDatePat bounds dp
+  combineErrors $ fmap f days
 
 --------------------------------------------------------------------------------
 -- budget
@@ -117,7 +116,7 @@ withDates dp f = do
 -- 4. assign shadow transactions (TODO)
 -- 5. insert all transactions
 
-insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError]
+insertBudget :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => Budget -> m ()
 insertBudget
   b@Budget
     { bgtLabel
@@ -128,23 +127,21 @@ insertBudget
     , bgtTax
     , bgtPosttax
     } =
-    whenHash CTBudget b [] $ \key -> do
-      unlessLefts intAllos $ \intAllos_ -> do
-        res1 <- mapM (insertIncome key bgtLabel intAllos_) bgtIncomes
-        res2 <- expandTransfers key bgtLabel bgtTransfers
-        unlessLefts (concatEithers2 (concat <$> concatEithersL res1) res2 (++)) $
-          \txs -> do
-            m <- lift $ askDBState kmCurrency
-            unlessLefts (addShadowTransfers m bgtShadowTransfers txs) $ \shadow -> do
-              let bals = balanceTransfers $ txs ++ shadow
-              concat <$> mapM insertBudgetTx bals
+    whenHash CTBudget b () $ \key -> do
+      intAllos <- combineError3 pre_ tax_ post_ (,,)
+      let res1 = combineErrors $ fmap (insertIncome key bgtLabel intAllos) bgtIncomes
+      let res2 = expandTransfers key bgtLabel bgtTransfers
+      txs <- combineError (concat <$> res1) res2 (++)
+      m <- askDBState kmCurrency
+      shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs
+      let bals = balanceTransfers $ txs ++ shadow
+      _ <- combineErrors $ fmap insertBudgetTx bals
+      return ()
     where
-      intAllos =
-        let pre_ = sortAllos bgtPretax
-            tax_ = sortAllos bgtTax
-            post_ = sortAllos bgtPosttax
-         in concatEithers3 pre_ tax_ post_ (,,)
-      sortAllos = concatEithersL . fmap sortAllo
+      pre_ = sortAllos bgtPretax
+      tax_ = sortAllos bgtTax
+      post_ = sortAllos bgtPosttax
+      sortAllos = liftExcept . combineErrors . fmap sortAllo
 
 type BoundAllocation = Allocation (Day, Day)
 
@@ -155,9 +152,9 @@ type IntAllocations =
   )
 
 -- TODO this should actually error if there is no ultimate end date?
-sortAllo :: MultiAllocation v -> EitherErrs (BoundAllocation v)
+sortAllo :: MultiAllocation v -> InsertExcept (BoundAllocation v)
 sortAllo a@Allocation {alloAmts = as} = do
-  bs <- foldBounds (Right []) $ L.sortOn amtWhen as
+  bs <- foldBounds (return []) $ L.sortOn amtWhen as
   return $ a {alloAmts = reverse bs}
   where
     foldBounds acc [] = acc
@@ -166,17 +163,17 @@ sortAllo a@Allocation {alloAmts = as} = do
             [] -> resolveBounds $ amtWhen x
             (y : _) -> resolveBounds_ (intStart $ amtWhen y) $ amtWhen x
           concatRes bs acc' = x {amtWhen = expandBounds bs} : acc'
-       in foldBounds (concatEithers2 (plural res) acc concatRes) xs
+       in foldBounds (combineError res acc concatRes) xs
 
 -- TODO this is going to be O(n*m), which might be a problem?
 addShadowTransfers
   :: CurrencyMap
   -> [ShadowTransfer]
   -> [UnbalancedTransfer]
-  -> EitherErrs [UnbalancedTransfer]
+  -> InsertExcept [UnbalancedTransfer]
 addShadowTransfers cm ms txs =
   fmap catMaybes $
-    concatEithersL $
+    combineErrors $
       fmap (uncurry (fromShadow cm)) $
         [(t, m) | t <- txs, m <- ms]
 
@@ -184,7 +181,7 @@ fromShadow
   :: CurrencyMap
   -> UnbalancedTransfer
   -> ShadowTransfer
-  -> EitherErrs (Maybe UnbalancedTransfer)
+  -> InsertExcept (Maybe UnbalancedTransfer)
 fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
   res <- shadowMatches (stMatch t) tx
   v <- roundPrecisionCur (initialCurrency stCurrency) cm stRatio
@@ -204,7 +201,7 @@ fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, st
             , cbtDesc = stDesc
             }
 
-shadowMatches :: TransferMatcher -> UnbalancedTransfer -> EitherErrs Bool
+shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool
 shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
   valRes <- valMatches tmVal $ cvValue $ cbtValue tx
   return $
@@ -265,28 +262,26 @@ type UnbalancedTransfer = FlatTransfer UnbalancedValue
 type BalancedTransfer = FlatTransfer Rational
 
 insertIncome
-  :: MonadFinance m
+  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
   => CommitRId
   -> T.Text
   -> IntAllocations
   -> Income
-  -> SqlPersistT m (EitherErrs [UnbalancedTransfer])
+  -> m [UnbalancedTransfer]
 insertIncome
   key
   name
   (intPre, intTax, intPost)
   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
-    precRes <- lift $ lookupCurrencyPrec incCurrency
-    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 (_, p) ->
-        let gross = roundPrecision p incGross
-         in fmap concat <$> withDates incWhen (return . allocate p gross)
+    _ <- checkAcntType IncomeT $ taAcnt incFrom
+    precision <- lookupCurrencyPrec incCurrency
+    -- 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 :(
+    let gross = roundPrecision precision incGross
+    res <- withDates incWhen (allocate precision gross)
+    return $ concat res
     where
       meta = BudgetMeta key name
       flatPre = concatMap flattenAllo incPretax
@@ -317,8 +312,8 @@ insertIncome
                 , cbtDesc = "balance after deductions"
                 }
          in if balance < 0
-              then Left [IncomeError day name balance]
-              else Right $ bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post)
+              then throwError $ InsertException [IncomeError day name balance]
+              else return (bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post))
 
 allocatePre
   :: Natural
@@ -421,62 +416,55 @@ selectAllos day Allocation {alloAmts, alloCur, alloTo} =
         }
 
 expandTransfers
-  :: MonadFinance m
+  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
   => CommitRId
   -> T.Text
   -> [BudgetTransfer]
-  -> SqlPersistT m (EitherErrs [UnbalancedTransfer])
-expandTransfers key name ts = do
-  txs <- mapM (expandTransfer key name) ts
-  return $ L.sortOn cbtWhen . concat <$> concatEithersL txs
+  -> m [UnbalancedTransfer]
+expandTransfers key name ts =
+  fmap (L.sortOn cbtWhen . concat) $
+    combineErrors $
+      fmap (expandTransfer key name) ts
 
 initialCurrency :: BudgetCurrency -> CurID
 initialCurrency (NoX c) = c
 initialCurrency (X Exchange {xFromCur = c}) = c
 
 expandTransfer
-  :: MonadFinance m
+  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
   => CommitRId
   -> T.Text
   -> BudgetTransfer
-  -> SqlPersistT m (EitherErrs [UnbalancedTransfer])
+  -> m [UnbalancedTransfer]
 expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do
-  pRes <- lift $ lookupCurrencyPrec $ initialCurrency transCurrency
-  case pRes of
-    Left es -> return $ Left es
-    Right p ->
-      fmap (fmap concat . concatEithersL) $
-        forM transAmounts $
-          \Amount
-            { amtWhen = pat
-            , amtValue = BudgetTransferValue {btVal = v, btType = y}
-            , amtDesc = desc
-            } ->
-              do
-                withDates pat $ \day ->
-                  let meta =
-                        BudgetMeta
-                          { bmCommit = key
-                          , bmName = name
-                          }
-                      tx =
-                        FlatTransfer
-                          { cbtMeta = meta
-                          , cbtWhen = day
-                          , cbtCur = transCurrency
-                          , cbtFrom = transFrom
-                          , cbtTo = transTo
-                          , cbtValue = UnbalancedValue y $ roundPrecision p v
-                          , cbtDesc = desc
-                          }
-                   in return $ Right tx
+  precision <- lookupCurrencyPrec $ initialCurrency transCurrency
+  fmap concat $ combineErrors $ fmap (go precision) transAmounts
+  where
+    go
+      precision
+      Amount
+        { amtWhen = pat
+        , amtValue = BudgetTransferValue {btVal = v, btType = y}
+        , amtDesc = desc
+        } =
+        withDates pat $ \day -> do
+          let meta = BudgetMeta {bmCommit = key, bmName = name}
+          return
+            FlatTransfer
+              { cbtMeta = meta
+              , cbtWhen = day
+              , cbtCur = transCurrency
+              , cbtFrom = transFrom
+              , cbtTo = transTo
+              , cbtValue = UnbalancedValue y $ roundPrecision precision v
+              , cbtDesc = desc
+              }
 
-insertBudgetTx :: MonadFinance m => BalancedTransfer -> SqlPersistT m [InsertError]
+insertBudgetTx :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => BalancedTransfer -> m ()
 insertBudgetTx FlatTransfer {cbtFrom, cbtTo, cbtMeta, cbtCur, cbtValue, cbtDesc, cbtWhen} = do
-  res <- lift $ splitPair cbtFrom cbtTo cbtCur cbtValue
-  unlessLefts_ res $ \((sFrom, sTo), exchange) -> do
-    insertPair sFrom sTo
-    forM_ exchange $ uncurry insertPair
+  ((sFrom, sTo), exchange) <- splitPair cbtFrom cbtTo cbtCur cbtValue
+  insertPair sFrom sTo
+  forM_ exchange $ uncurry insertPair
   where
     insertPair from to = do
       k <- insert $ TransactionR (bmCommit cbtMeta) cbtWhen cbtDesc
@@ -489,24 +477,24 @@ insertBudgetTx FlatTransfer {cbtFrom, cbtTo, cbtMeta, cbtCur, cbtValue, cbtDesc,
 type SplitPair = (KeySplit, KeySplit)
 
 splitPair
-  :: MonadFinance m
+  :: (MonadInsertError m, MonadFinance m)
   => TaggedAcnt
   -> TaggedAcnt
   -> BudgetCurrency
   -> Rational
-  -> m (EitherErrs (SplitPair, Maybe SplitPair))
+  -> m (SplitPair, Maybe SplitPair)
 splitPair from to cur val = case cur of
-  NoX curid -> fmap (,Nothing) <$> pair curid from to val
+  NoX curid -> (,Nothing) <$> pair curid from to val
   X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do
     let middle = TaggedAcnt xAcnt []
-    res1 <- pair xFromCur from middle val
-    res2 <- pair xToCur middle to (val * roundPrecision 3 xRate)
-    return $ concatEithers2 res1 res2 $ \a b -> (a, Just b)
+    let res1 = pair xFromCur from middle val
+    let res2 = pair xToCur middle to (val * roundPrecision 3 xRate)
+    combineError res1 res2 $ \a b -> (a, Just b)
   where
     pair curid from_ to_ v = do
-      s1 <- split curid from_ (-v)
-      s2 <- split curid to_ v
-      return $ concatEithers2 s1 s2 (,)
+      let s1 = split curid from_ (-v)
+      let s2 = split curid to_ v
+      combineError s1 s2 (,)
     split c TaggedAcnt {taAcnt, taTags} v =
       resolveSplit $
         Entry
@@ -518,34 +506,37 @@ splitPair from to cur val = case cur of
           }
 
 checkAcntType
-  :: MonadFinance m
+  :: (MonadInsertError m, MonadFinance m)
   => AcntType
   -> AcntID
-  -> m (EitherErrs AcntID)
+  -> m AcntID
 checkAcntType t = checkAcntTypes (t :| [])
 
 checkAcntTypes
-  :: MonadFinance m
+  :: (MonadInsertError m, MonadFinance m)
   => NE.NonEmpty AcntType
   -> AcntID
-  -> m (EitherErrs AcntID)
-checkAcntTypes ts i = (go =<<) <$> lookupAccountType i
+  -> m AcntID
+checkAcntTypes ts i = go =<< lookupAccountType i
   where
     go t
-      | t `L.elem` ts = Right i
-      | otherwise = Left [AccountError i ts]
+      | t `L.elem` ts = return i
+      | otherwise = throwError $ InsertException [AccountError i ts]
 
 --------------------------------------------------------------------------------
 -- statements
 
-insertStatements :: MonadFinance m => Config -> SqlPersistT m [InsertError]
-insertStatements conf = concat <$> mapM insertStatement (statements conf)
-
-insertStatement :: MonadFinance m => History -> SqlPersistT m [InsertError]
-insertStatement (HistTransfer m) = insertManual m
+insertStatement
+  :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m)
+  => History
+  -> m ()
+insertStatement (HistTransfer m) = liftIOExceptT $ insertManual m
 insertStatement (HistStatement i) = insertImport i
 
-insertManual :: MonadFinance m => HistTransfer -> SqlPersistT m [InsertError]
+insertManual
+  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
+  => HistTransfer
+  -> m ()
 insertManual
   m@Transfer
     { transFrom = from
@@ -553,48 +544,42 @@ insertManual
     , transCurrency = u
     , transAmounts = amts
     } = do
-    whenHash CTManual m [] $ \c -> do
-      bounds <- lift $ askDBState kmStatementInterval
-      precRes <- lift $ lookupCurrencyPrec u
-      es <- forM amts $ \Amount {amtWhen, amtValue, amtDesc} -> do
-        let dayRes = expandDatePat bounds amtWhen
-        -- TODO rounding too often
-        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
+    whenHash CTManual m () $ \c -> do
+      bounds <- askDBState kmStatementInterval
+      let precRes = lookupCurrencyPrec u
+      let go Amount {amtWhen, amtValue, amtDesc} = do
+            let dayRes = liftExcept $ expandDatePat bounds amtWhen
+            (days, precision) <- combineError dayRes precRes (,)
+            let tx day = txPair day from to u (roundPrecision precision amtValue) amtDesc
+            keys <- combineErrors $ fmap tx days
+            mapM_ (insertTx c) keys
+      void $ combineErrors $ fmap go amts
 
-insertImport :: MonadFinance m => Statement -> SqlPersistT m [InsertError]
-insertImport i = whenHash CTImport i [] $ \c -> do
+insertImport
+  :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m)
+  => Statement
+  -> m ()
+insertImport i = whenHash CTImport i () $ \c -> do
   -- TODO this isn't efficient, the whole file will be read and maybe no
   -- transactions will be desired
-  recoverIO (lift $ readImport i) $ \r -> unlessLefts r $ \bs -> do
-    bounds <- expandBounds <$> lift (askDBState kmStatementInterval)
-    res <- mapM (lift . resolveTx) $ filter (inBounds bounds . txDate) bs
-    unlessLefts_ (concatEithersL res) $ mapM_ (insertTx c)
-  where
-    recoverIO x rest = do
-      res <- tryIO x
-      case res of
-        Right r -> rest r
-        -- If file is not found (or something else happens) then collect the
-        -- error try the remaining imports
-        Left e -> return [InsertIOError $ showT e]
+  bs <- readImport i
+  bounds <- expandBounds <$> askDBState kmStatementInterval
+  keys <- liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs
+  mapM_ (insertTx c) keys
 
 --------------------------------------------------------------------------------
 -- low-level transaction stuff
 
 -- TODO tags here?
 txPair
-  :: MonadFinance m
+  :: (MonadInsertError m, MonadFinance m)
   => Day
   -> AcntID
   -> AcntID
   -> CurID
   -> Rational
   -> T.Text
-  -> m (EitherErrs KeyTx)
+  -> m KeyTx
 txPair day from to cur val desc = resolveTx tx
   where
     split a v =
@@ -612,73 +597,83 @@ txPair day from to cur val desc = resolveTx tx
         , txSplits = [split from (-val), split to val]
         }
 
-resolveTx :: MonadFinance m => BalTx -> m (EitherErrs KeyTx)
-resolveTx t@Tx {txSplits = ss} = do
-  res <- concatEithersL <$> mapM resolveSplit ss
-  return $ fmap (\kss -> t {txSplits = kss}) res
+resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
+resolveTx t@Tx {txSplits = ss} =
+  fmap (\kss -> t {txSplits = kss}) $
+    combineErrors $
+      fmap resolveSplit ss
 
-resolveSplit :: MonadFinance m => BalSplit -> m (EitherErrs KeySplit)
+resolveSplit :: (MonadInsertError m, MonadFinance m) => BalSplit -> m KeySplit
 resolveSplit s@Entry {eAcnt, eCurrency, eValue, eTags} = do
-  aid <- lookupAccountKey eAcnt
-  cid <- lookupCurrencyKey eCurrency
-  sign <- lookupAccountSign eAcnt
-  tags <- mapM lookupTag eTags
+  let aRes = lookupAccountKey eAcnt
+  let cRes = lookupCurrencyKey eCurrency
+  let sRes = lookupAccountSign eAcnt
+  let tagRes = combineErrors $ fmap lookupTag eTags
   -- TODO correct sign here?
   -- TODO lenses would be nice here
-  return $
-    concatEithers2 (concatEithers3 aid cid sign (,,)) (concatEithersL tags) $
-      \(aid_, cid_, sign_) tags_ ->
-        s
-          { eAcnt = aid_
-          , eCurrency = cid_
-          , eValue = eValue * fromIntegral (sign2Int sign_)
-          , eTags = tags_
-          }
+  combineError (combineError3 aRes cRes sRes (,,)) tagRes $
+    \(aid, cid, sign) tags ->
+      s
+        { eAcnt = aid
+        , eCurrency = cid
+        , eValue = eValue * fromIntegral (sign2Int sign)
+        , eTags = tags
+        }
 
-insertTx :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
+insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
 insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do
   k <- insert $ TransactionR c d e
   mapM_ (insertSplit k) ss
 
-insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m (Key SplitR)
+insertSplit :: MonadSqlQuery m => TransactionRId -> KeySplit -> m SplitRId
 insertSplit t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do
   k <- insert $ SplitR t eCurrency eAcnt eComment eValue
   mapM_ (insert_ . TagRelationR k) eTags
   return k
 
-lookupAccount :: MonadFinance m => AcntID -> m (EitherErrs (Key AccountR, AcntSign, AcntType))
-lookupAccount p = lookupErr (DBKey AcntField) p <$> askDBState kmAccount
+lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntSign, AcntType)
+lookupAccount = lookupFinance AcntField kmAccount
 
-lookupAccountKey :: MonadFinance m => AcntID -> m (EitherErrs (Key AccountR))
-lookupAccountKey = fmap (fmap fstOf3) . lookupAccount
+lookupAccountKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m AccountRId
+lookupAccountKey = fmap fstOf3 . lookupAccount
 
-lookupAccountSign :: MonadFinance m => AcntID -> m (EitherErrs AcntSign)
-lookupAccountSign = fmap (fmap sndOf3) . lookupAccount
+lookupAccountSign :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntSign
+lookupAccountSign = fmap sndOf3 . lookupAccount
 
-lookupAccountType :: MonadFinance m => AcntID -> m (EitherErrs AcntType)
-lookupAccountType = fmap (fmap thdOf3) . lookupAccount
+lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType
+lookupAccountType = fmap thdOf3 . lookupAccount
 
-lookupCurrency :: MonadFinance m => T.Text -> m (EitherErrs (Key CurrencyR, Natural))
-lookupCurrency c = lookupErr (DBKey CurField) c <$> askDBState kmCurrency
+lookupCurrency :: (MonadInsertError m, MonadFinance m) => T.Text -> m (CurrencyRId, Natural)
+lookupCurrency = lookupFinance CurField kmCurrency
 
-lookupCurrencyKey :: MonadFinance m => AcntID -> m (EitherErrs (Key CurrencyR))
-lookupCurrencyKey = fmap (fmap fst) . lookupCurrency
+lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId
+lookupCurrencyKey = fmap fst . lookupCurrency
 
-lookupCurrencyPrec :: MonadFinance m => AcntID -> m (EitherErrs Natural)
-lookupCurrencyPrec = fmap (fmap snd) . lookupCurrency
+lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Natural
+lookupCurrencyPrec = fmap snd . lookupCurrency
 
-lookupTag :: MonadFinance m => TagID -> m (EitherErrs (Key TagR))
-lookupTag c = lookupErr (DBKey TagField) c <$> askDBState kmTag
+lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId
+lookupTag = lookupFinance TagField kmTag
+
+lookupFinance
+  :: (MonadInsertError m, MonadFinance m)
+  => SplitIDType
+  -> (DBState -> M.Map T.Text a)
+  -> T.Text
+  -> m a
+lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f
 
 -- TODO this hashes twice (not that it really matters)
+-- TODO generalize this (persistent mtl)
+
 whenHash
-  :: (Hashable a, MonadFinance m)
+  :: (Hashable a, MonadFinance m, MonadSqlQuery m)
   => ConfigType
   -> a
   -> b
-  -> (Key CommitR -> SqlPersistT m b)
-  -> SqlPersistT m b
+  -> (CommitRId -> m b)
+  -> m b
 whenHash t o def f = do
   let h = hash o
-  hs <- lift $ askDBState kmNewCommits
+  hs <- askDBState kmNewCommits
   if h `elem` hs then f =<< insert (CommitR h t) else return def
diff --git a/lib/Internal/Statement.hs b/lib/Internal/Statement.hs
index c6496bb..e7a325e 100644
--- a/lib/Internal/Statement.hs
+++ b/lib/Internal/Statement.hs
@@ -5,6 +5,8 @@ module Internal.Statement
   )
 where
 
+import Control.Monad.Error.Class
+import Control.Monad.Except
 import Data.Csv
 import Internal.Types
 import Internal.Utils
@@ -18,33 +20,33 @@ import RIO.Time
 import qualified RIO.Vector as V
 
 -- TODO this probably won't scale well (pipes?)
-
-readImport :: MonadFinance m => Statement -> m (EitherErrs [BalTx])
+readImport :: (MonadUnliftIO m, MonadFinance m) => Statement -> m [BalTx]
 readImport Statement {..} = do
-  let ores = plural $ compileOptions stmtTxOpts
-  let cres = concatEithersL $ compileMatch <$> stmtParsers
+  let ores = compileOptions stmtTxOpts
+  let cres = combineErrors $ compileMatch <$> stmtParsers
+  (compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
+  let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
+  records <- L.sort . concat <$> mapErrorsIO readStmt stmtPaths
   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 $ runReader (matchRecords compiledMatches $ L.sort $ concat records) m
-        Left es -> return $ Left es
-    Left es -> return $ Left es
+  fromEither $
+    flip runReader m $
+      runExceptT $
+        matchRecords compiledMatches records
 
 readImport_
-  :: MonadFinance m
+  :: (MonadUnliftIO m, MonadFinance m)
   => Natural
   -> Word
   -> TxOptsRe
   -> FilePath
-  -> m (EitherErr [TxRecord])
+  -> m [TxRecord]
 readImport_ n delim tns p = do
   dir <- askDBState kmConfigDir
-  bs <- liftIO $ BL.readFile $ dir </> p
+  res <- tryIO $ BL.readFile $ dir </> p
+  bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res
   case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
-    Left m -> return $ Left $ ParseError $ T.pack m
-    Right (_, v) -> return $ Right $ catMaybes $ V.toList v
+    Left m -> throwIO $ InsertException [ParseError $ T.pack m]
+    Right (_, v) -> return $ catMaybes $ V.toList v
   where
     opts = defaultDecodeOptions {decDelimiter = fromIntegral delim}
     skip = BL.intercalate "\n" . L.drop (fromIntegral n) . BL.split 10
@@ -63,17 +65,13 @@ parseTxRecord p TxOpts {..} r = do
       d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
       return $ Just $ TxRecord d' a e os p
 
-matchRecords :: [MatchRe] -> [TxRecord] -> CurrencyM (EitherErrs [BalTx])
+matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [BalTx]
 matchRecords ms rs = do
-  res <- matchAll (matchPriorities ms) rs
-  case res of
-    Left es -> return $ Left es
-    Right (matched, unmatched, notfound) -> do
-      case (matched, unmatched, notfound) of
-        (ms_, [], []) -> do
-          -- TODO record number of times each match hits for debugging
-          return $ first (: []) $ mapM balanceTx ms_
-        (_, us, ns) -> return $ Left [StatementError us ns]
+  (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
+  case (matched, unmatched, notfound) of
+    -- TODO record number of times each match hits for debugging
+    (ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_
+    (_, us, ns) -> throwError $ InsertException [StatementError us ns]
 
 matchPriorities :: [MatchRe] -> [MatchGroup]
 matchPriorities =
@@ -130,35 +128,33 @@ zipperSlice f x = go
 zipperMatch
   :: Unzipped MatchRe
   -> TxRecord
-  -> CurrencyM (EitherErrs (Zipped MatchRe, MatchRes RawTx))
+  -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
 zipperMatch (Unzipped bs cs as) x = go [] cs
   where
-    go _ [] = return $ Right (Zipped bs $ cs ++ as, MatchFail)
+    go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
     go prev (m : ms) = do
       res <- matches m x
       case res of
-        Right MatchFail -> go (m : prev) ms
-        Right skipOrPass ->
+        MatchFail -> go (m : prev) ms
+        skipOrPass ->
           let ps = reverse prev
               ms' = maybe ms (: ms) (matchDec m)
-           in return $ Right (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
-        Left es -> return $ Left es
+           in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
 
 -- TODO all this unpacking left/error crap is annoying
 zipperMatch'
   :: Zipped MatchRe
   -> TxRecord
-  -> CurrencyM (EitherErrs (Zipped MatchRe, MatchRes RawTx))
+  -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
 zipperMatch' z x = go z
   where
     go (Zipped bs (a : as)) = do
       res <- matches a x
       case res of
-        Right MatchFail -> go (Zipped (a : bs) as)
-        Right skipOrPass ->
-          return $ Right (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
-        Left es -> return $ Left es
-    go z' = return $ Right (z', MatchFail)
+        MatchFail -> go (Zipped (a : bs) as)
+        skipOrPass ->
+          return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
+    go z' = return (z', MatchFail)
 
 matchDec :: MatchRe -> Maybe MatchRe
 matchDec m = case spTimes m of
@@ -166,83 +162,66 @@ matchDec m = case spTimes m of
   Just n -> Just $ m {spTimes = Just $ n - 1}
   Nothing -> Just m
 
-matchAll :: [MatchGroup] -> [TxRecord] -> CurrencyM (EitherErrs ([RawTx], [TxRecord], [MatchRe]))
+matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
 matchAll = go ([], [])
   where
     go (matched, unused) gs rs = case (gs, rs) of
-      (_, []) -> return $ Right (matched, [], unused)
-      ([], _) -> return $ Right (matched, rs, unused)
+      (_, []) -> return (matched, [], unused)
+      ([], _) -> return (matched, rs, unused)
       (g : gs', _) -> do
-        res <- matchGroup g rs
-        case res of
-          Right (ts, unmatched, us) ->
-            go (ts ++ matched, us ++ unused) gs' unmatched
-          Left es -> return $ Left es
+        (ts, unmatched, us) <- matchGroup g rs
+        go (ts ++ matched, us ++ unused) gs' unmatched
 
-matchGroup :: MatchGroup -> [TxRecord] -> CurrencyM (EitherErrs ([RawTx], [TxRecord], [MatchRe]))
+matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
 matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
-  res <- matchDates ds rs
-  case res of
-    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
+  (md, rest, ud) <- matchDates ds rs
+  (mn, unmatched, un) <- matchNonDates ns rest
+  return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un)
 
-matchDates :: [MatchRe] -> [TxRecord] -> CurrencyM (EitherErrs ([RawTx], [TxRecord], [MatchRe]))
+matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
 matchDates ms = go ([], [], initZipper ms)
   where
     go (matched, unmatched, z) [] =
-      return $
-        Right
-          ( catMaybes matched
-          , reverse unmatched
-          , recoverZipper z
-          )
+      return
+        ( catMaybes matched
+        , 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
-          res <- zipperMatch unzipped r
-          case res of
-            Right (z', res') -> do
-              let (m, u) = case res' of
-                    (MatchPass p) -> (Just p : matched, unmatched)
-                    MatchSkip -> (Nothing : matched, unmatched)
-                    MatchFail -> (matched, r : unmatched)
-              go (m, u, z') rs
-            Left es -> return $ Left es
+          (z', res) <- zipperMatch unzipped r
+          let (m, u) = case res of
+                (MatchPass p) -> (Just p : matched, unmatched)
+                MatchSkip -> (Nothing : matched, unmatched)
+                MatchFail -> (matched, r : unmatched)
+          go (m, u, z') rs
     findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
 
-matchNonDates :: [MatchRe] -> [TxRecord] -> CurrencyM (EitherErrs ([RawTx], [TxRecord], [MatchRe]))
+matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
 matchNonDates ms = go ([], [], initZipper ms)
   where
     go (matched, unmatched, z) [] =
-      return $
-        Right
-          ( catMaybes matched
-          , reverse unmatched
-          , recoverZipper z
-          )
+      return
+        ( catMaybes matched
+        , reverse unmatched
+        , recoverZipper z
+        )
     go (matched, unmatched, z) (r : rs) = do
-      res <- zipperMatch' z r
-      case res of
-        Left es -> return $ Left es
-        Right (z', res') -> do
-          let (m, u) = case res' of
-                MatchPass p -> (Just p : matched, unmatched)
-                MatchSkip -> (Nothing : matched, unmatched)
-                MatchFail -> (matched, r : unmatched)
-           in go (m, u, resetZipper z') rs
+      (z', res) <- zipperMatch' z r
+      let (m, u) = case res of
+            MatchPass p -> (Just p : matched, unmatched)
+            MatchSkip -> (Nothing : matched, unmatched)
+            MatchFail -> (matched, r : unmatched)
+       in go (m, u, resetZipper z') rs
 
-balanceTx :: RawTx -> EitherErr BalTx
+balanceTx :: RawTx -> InsertExcept BalTx
 balanceTx t@Tx {txSplits = ss} = do
   bs <- balanceSplits ss
   return $ t {txSplits = bs}
 
-balanceSplits :: [RawSplit] -> EitherErr [BalSplit]
+balanceSplits :: [RawSplit] -> InsertExcept [BalSplit]
 balanceSplits ss =
   fmap concat
     <$> mapM (uncurry bal)
@@ -252,11 +231,11 @@ balanceSplits ss =
     haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
     haeValue s = Left s
     bal cur rss
-      | length rss < 2 = Left $ BalanceError TooFewSplits cur rss
+      | length rss < 2 = throwError $ InsertException [BalanceError TooFewSplits cur rss]
       | otherwise = case partitionEithers $ fmap haeValue rss of
-          ([noVal], val) -> Right $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
-          ([], val) -> Right val
-          _ -> Left $ BalanceError NotOneBlank cur rss
+          ([noVal], val) -> return $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
+          ([], val) -> return val
+          _ -> throwError $ InsertException [BalanceError NotOneBlank cur rss]
 
 groupByKey :: Ord k => [(k, v)] -> [(k, [v])]
 groupByKey = M.toList . M.fromListWith (++) . fmap (second (: []))
diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs
index d8f05c1..d42dac9 100644
--- a/lib/Internal/Types.hs
+++ b/lib/Internal/Types.hs
@@ -1,11 +1,12 @@
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module Internal.Types where
 
--- import Control.Monad.Except
+import Control.Monad.Except
 import Data.Fix (Fix (..), foldFix)
 import Data.Functor.Foldable (embed)
 import qualified Data.Functor.Foldable.TH as TH
@@ -601,8 +602,6 @@ data DBState = DBState
 
 type CurrencyM = Reader CurrencyMap
 
-type MappingT m = ReaderT DBState (SqlPersistT m)
-
 type KeySplit = Entry AccountRId Rational CurrencyRId TagRId
 
 type KeyTx = Tx KeySplit
@@ -611,13 +610,12 @@ type TreeR = Tree ([T.Text], AccountRId)
 
 type Balances = M.Map AccountRId Rational
 
-type BalanceM m = ReaderT (MVar Balances) m
+type BalanceM = ReaderT (MVar Balances)
 
-class MonadUnliftIO m => MonadFinance m where
-  askDBState :: (DBState -> a) -> m a
+type MonadFinance = MonadReader DBState
 
-instance MonadUnliftIO m => MonadFinance (ReaderT DBState m) where
-  askDBState = asks
+askDBState :: MonadFinance m => (DBState -> a) -> m a
+askDBState = asks
 
 class MonadUnliftIO m => MonadBalance m where
   askBalances :: m (MVar Balances)
@@ -746,17 +744,16 @@ data InsertError
   | StatementError ![TxRecord] ![MatchRe]
   deriving (Show)
 
-newtype InsertException = InsertException [InsertError] deriving (Show)
+newtype InsertException = InsertException [InsertError]
+  deriving (Show, Semigroup) via [InsertError]
 
 instance Exception InsertException
 
-type EitherErr = Either InsertError
+type MonadInsertError = MonadError InsertException
 
-type EitherErrs = Either [InsertError]
+type InsertExceptT = ExceptT InsertException
 
--- type InsertExceptT m = ExceptT [InsertError] m
-
--- type InsertExcept = InsertExceptT Identity
+type InsertExcept = InsertExceptT Identity
 
 data XGregorian = XGregorian
   { xgYear :: !Int
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index 9f25089..f1dee17 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -7,15 +7,33 @@ module Internal.Utils
   , fromGregorian'
   , resolveBounds
   , resolveBounds_
-  , leftToMaybe
-  , concatEithers2
-  , concatEithers3
-  , concatEither3
-  , concatEither2
-  , concatEitherL
-  , concatEithersL
-  , concatEither2M
-  , concatEithers2M
+  , liftInner
+  , liftExceptT
+  , liftExcept
+  , liftIOExcept
+  , liftIOExceptT
+  , combineError
+  , combineError_
+  , combineError3
+  , combineErrors
+  , mapErrors
+  , combineErrorM
+  , combineErrorM3
+  , combineErrorIO2
+  , combineErrorIO3
+  , combineErrorIOM2
+  , combineErrorIOM3
+  , collectErrorsIO
+  , mapErrorsIO
+  -- , leftToMaybe
+  -- , concatEithers2
+  -- , concatEithers3
+  -- , concatEither3
+  -- , concatEither2
+  -- , concatEitherL
+  -- , concatEithersL
+  -- , concatEither2M
+  -- , concatEithers2M
   , parseRational
   , showError
   , unlessLeft_
@@ -31,7 +49,7 @@ module Internal.Utils
   , sndOf3
   , thdOf3
   , xGregToDay
-  , plural
+  -- , plural
   , compileMatch
   , compileOptions
   , dateMatches
@@ -41,6 +59,8 @@ module Internal.Utils
   )
 where
 
+import Control.Monad.Error.Class
+import Control.Monad.Except
 import Control.Monad.Reader
 import Data.Time.Format.ISO8601
 import GHC.Real
@@ -134,17 +154,17 @@ fromGregorian' = uncurry3 fromGregorian . gregTup
 inBounds :: (Day, Day) -> Day -> Bool
 inBounds (d0, d1) x = d0 <= x && x < d1
 
-resolveBounds :: Interval -> EitherErr Bounds
+resolveBounds :: Interval -> InsertExcept Bounds
 resolveBounds i@Interval {intStart = s} =
   resolveBounds_ (s {gYear = gYear s + 50}) i
 
-resolveBounds_ :: Gregorian -> Interval -> EitherErr Bounds
+resolveBounds_ :: Gregorian -> Interval -> InsertExcept Bounds
 resolveBounds_ def Interval {intStart = s, intEnd = e} =
   case fromGregorian' <$> e of
-    Nothing -> Right $ toBounds $ fromGregorian' def
+    Nothing -> return $ toBounds $ fromGregorian' def
     Just e_
-      | s_ < e_ -> Right $ toBounds e_
-      | otherwise -> Left $ BoundsError s e
+      | s_ < e_ -> return $ toBounds e_
+      | otherwise -> throwError $ InsertException [BoundsError s e]
   where
     s_ = fromGregorian' s
     toBounds end = (s_, fromIntegral $ diffDays end s_ - 1)
@@ -155,30 +175,26 @@ expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d)
 --------------------------------------------------------------------------------
 -- matching
 
-matches :: MatchRe -> TxRecord -> CurrencyM (EitherErrs (MatchRes RawTx))
+matches :: MatchRe -> TxRecord -> InsertExceptT CurrencyM (MatchRes RawTx)
 matches
   StatementParser {spTx, spOther, spVal, spDate, spDesc}
   r@TxRecord {trDate, trAmount, trDesc, trOther} = do
-    let res = concatEithers3 val other desc $ \x y z -> x && y && z && date
-    case res of
-      Right test
-        | test -> maybe (return $ Right MatchSkip) convert spTx
-        | otherwise -> return $ Right MatchFail
-      Left es -> return $ Left es
+    res <- liftInner $
+      combineError3 val other desc $
+        \x y z -> x && y && z && date
+    if res
+      then maybe (return MatchSkip) convert spTx
+      else return MatchFail
     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) = do
-        res <- toTx cur a ss r
-        return $ fmap MatchPass res
+      convert (TxGetter cur a ss) = MatchPass <$> toTx cur a ss r
 
-toTx :: SplitCur -> SplitAcnt -> [EntryGetter] -> TxRecord -> CurrencyM (EitherErrs RawTx)
+toTx :: SplitCur -> SplitAcnt -> [EntryGetter] -> TxRecord -> InsertExceptT CurrencyM RawTx
 toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = do
-  m <- ask
-  let ssRes = concatEithersL $ fmap (resolveEntry m r) toSplits
-  return $ concatEithers2 acRes ssRes $ \(a, c) ss ->
+  combineError3 acntRes curRes ssRes $ \a c ss ->
     let fromSplit =
           Entry
             { eAcnt = a
@@ -193,13 +209,15 @@ toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = do
           , txSplits = fromSplit : ss
           }
   where
-    acRes = concatEithers2 (resolveAcnt r sa) (resolveCurrency r sc) (,)
+    acntRes = liftInner $ resolveAcnt r sa
+    curRes = liftInner $ resolveCurrency r sc
+    ssRes = combineErrors $ fmap (resolveEntry r) toSplits
 
-valMatches :: ValMatcher -> Rational -> EitherErrs Bool
+valMatches :: ValMatcher -> Rational -> InsertExcept Bool
 valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
-  | Just d_ <- vmDen, d_ >= p = Left [MatchValPrecisionError d_ p]
+  | Just d_ <- vmDen, d_ >= p = throwError $ InsertException [MatchValPrecisionError d_ p]
   | otherwise =
-      Right $
+      return $
         checkMaybe (s ==) vmSign
           && checkMaybe (n ==) vmNum
           && checkMaybe ((d * fromIntegral p ==) . fromIntegral) vmDen
@@ -212,58 +230,138 @@ valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
 dateMatches :: DateMatcher -> Day -> Bool
 dateMatches md = (EQ ==) . compareDate md
 
-otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> EitherErrs Bool
+otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> InsertExcept 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
 
-resolveEntry :: CurrencyMap -> TxRecord -> EntryGetter -> EitherErrs RawSplit
-resolveEntry m r s@Entry {eAcnt, eValue, eCurrency} = do
-  (a, c, v) <- concatEithers2 acRes valRes $ \(a, c) v -> (a, c, v)
-  v' <- mapM (roundPrecisionCur c m) v
-  return $
-    s
-      { eAcnt = a
-      , eValue = v'
-      , eCurrency = c
-      }
+resolveEntry :: TxRecord -> EntryGetter -> InsertExceptT CurrencyM RawSplit
+resolveEntry r s@Entry {eAcnt, eValue, eCurrency} = do
+  m <- ask
+  liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
+    v' <- mapM (roundPrecisionCur c m) v
+    return $ s {eAcnt = a, eValue = v', eCurrency = c}
   where
-    acRes = concatEithers2 (resolveAcnt r eAcnt) (resolveCurrency r eCurrency) (,)
+    acntRes = resolveAcnt r eAcnt
+    curRes = resolveCurrency r eCurrency
     valRes = mapM (resolveValue r) eValue
 
-resolveValue :: TxRecord -> EntryNumGetter -> EitherErrs Double
+liftInner :: Monad m => ExceptT e Identity a -> ExceptT e m a
+liftInner = mapExceptT (return . runIdentity)
+
+liftExceptT :: MonadError e m => ExceptT e m a -> m a
+liftExceptT x = runExceptT x >>= either throwError return
+
+liftExcept :: MonadError e m => Except e a -> m a
+liftExcept = either throwError return . runExcept
+
+-- tryError :: MonadError e m => m a -> m (Either e a)
+-- tryError action = (Right <$> action) `catchError` (pure . Left)
+
+liftIOExceptT :: MonadIO m => InsertExceptT m a -> m a
+liftIOExceptT = fromEither <=< runExceptT
+
+liftIOExcept :: MonadIO m => InsertExcept a -> m a
+liftIOExcept = fromEither . runExcept
+
+combineError :: MonadError InsertException m => m a -> m b -> (a -> b -> c) -> m c
+combineError a b f = combineErrorM a b (\x y -> pure $ f x y)
+
+combineError_ :: MonadError InsertException m => m a -> m b -> m ()
+combineError_ a b = do
+  _ <- catchError a $ \e ->
+    throwError =<< catchError (e <$ b) (return . (e <>))
+  _ <- b
+  return ()
+
+combineErrorM :: MonadError InsertException m => m a -> m b -> (a -> b -> m c) -> m c
+combineErrorM a b f = do
+  a' <- catchError a $ \e ->
+    throwError =<< catchError (e <$ b) (return . (e <>))
+  f a' =<< b
+
+combineError3 :: MonadError InsertException m => m a -> m b -> m c -> (a -> b -> c -> d) -> m d
+combineError3 a b c f =
+  combineError (combineError a b (,)) c $ \(x, y) z -> f x y z
+
+combineErrorM3 :: MonadError InsertException m => m a -> m b -> m c -> (a -> b -> c -> m d) -> m d
+combineErrorM3 a b c f = do
+  combineErrorM (combineErrorM a b (curry return)) c $ \(x, y) z -> f x y z
+
+combineErrors :: MonadError InsertException m => [m a] -> m [a]
+combineErrors = mapErrors id
+
+mapErrors :: MonadError InsertException m => (a -> m b) -> [a] -> m [b]
+mapErrors f xs = do
+  ys <- mapM (go . f) xs
+  case partitionEithers ys of
+    ([], zs) -> return zs
+    (e : es, _) -> throwError $ foldr (<>) e es
+  where
+    go x = catchError (Right <$> x) (pure . Left)
+
+combineErrorIO2 :: MonadUnliftIO m => m a -> m b -> (a -> b -> c) -> m c
+combineErrorIO2 a b f = combineErrorIOM2 a b (\x y -> pure $ f x y)
+
+combineErrorIO3 :: MonadUnliftIO m => m a -> m b -> m c -> (a -> b -> c -> d) -> m d
+combineErrorIO3 a b c f = combineErrorIOM3 a b c (\x y z -> pure $ f x y z)
+
+combineErrorIOM2 :: MonadUnliftIO m => m a -> m b -> (a -> b -> m c) -> m c
+combineErrorIOM2 a b f = do
+  a' <- catch a $ \(InsertException es) ->
+    (throwIO . InsertException)
+      =<< catch (es <$ b) (\(InsertException es') -> return (es' ++ es))
+  f a' =<< b
+
+combineErrorIOM3 :: MonadUnliftIO m => m a -> m b -> m c -> (a -> b -> c -> m d) -> m d
+combineErrorIOM3 a b c f =
+  combineErrorIOM2 (combineErrorIOM2 a b (curry return)) c $ \(x, y) z -> f x y z
+
+mapErrorsIO :: MonadUnliftIO m => (a -> m b) -> [a] -> m [b]
+mapErrorsIO f xs = do
+  ys <- mapM (go . f) xs
+  case partitionEithers ys of
+    ([], zs) -> return zs
+    (es, _) -> throwIO $ InsertException $ concat es
+  where
+    go x = catch (Right <$> x) $ \(InsertException es) -> pure $ Left es
+
+collectErrorsIO :: MonadUnliftIO m => [m a] -> m [a]
+collectErrorsIO = mapErrorsIO id
+
+resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept Double
 resolveValue r s = case s of
   (LookupN t) -> readDouble =<< lookupErr SplitValField t (trOther r)
-  (ConstN c) -> Right c
+  (ConstN c) -> return c
   -- TODO don't coerce to rational in trAmount
-  AmountN -> Right $ fromRational $ trAmount r
+  AmountN -> return $ fromRational $ trAmount r
 
-resolveAcnt :: TxRecord -> SplitAcnt -> EitherErrs T.Text
+resolveAcnt :: TxRecord -> SplitAcnt -> InsertExcept T.Text
 resolveAcnt = resolveSplitField AcntField
 
-resolveCurrency :: TxRecord -> SplitCur -> EitherErrs T.Text
+resolveCurrency :: TxRecord -> SplitCur -> InsertExcept T.Text
 resolveCurrency = resolveSplitField CurField
 
-resolveSplitField :: SplitIDType -> TxRecord -> SplitAcnt -> EitherErrs T.Text
+resolveSplitField :: SplitIDType -> TxRecord -> SplitAcnt -> InsertExcept T.Text
 resolveSplitField t TxRecord {trOther = o} s = case s of
-  ConstT p -> Right p
+  ConstT p -> return p
   LookupT f -> lookup_ f o
   MapT (Field f m) -> do
     k <- lookup_ f o
     lookup_ k m
   Map2T (Field (f1, f2) m) -> do
-    (k1, k2) <- concatEithers2 (lookup_ f1 o) (lookup_ f2 o) (,)
+    (k1, k2) <- combineError (lookup_ f1 o) (lookup_ f2 o) (,)
     lookup_ (k1, k2) m
   where
-    lookup_ :: (Ord k, Show k) => k -> M.Map k v -> EitherErrs v
+    lookup_ :: (Ord k, Show k) => k -> M.Map k v -> InsertExcept v
     lookup_ = lookupErr (SplitIDField t)
 
-lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> EitherErrs v
+lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> InsertExcept v
 lookupErr what k m = case M.lookup k m of
-  Just x -> Right x
-  _ -> Left [LookupError what $ showT k]
+  Just x -> return x
+  _ -> throwError $ InsertException [LookupError what $ showT k]
 
 parseRational :: MonadFail m => (T.Text, Regex) -> T.Text -> m Rational
 parseRational (pat, re) s = case matchGroupsMaybe s re of
@@ -292,12 +390,12 @@ parseRational (pat, re) s = case matchGroupsMaybe s re of
       k <- readSign sign
       return (k, w)
 
-readDouble :: T.Text -> EitherErrs Double
+readDouble :: T.Text -> InsertExcept Double
 readDouble s = case readMaybe $ T.unpack s of
-  Just x -> Right x
-  Nothing -> Left [ConversionError s]
+  Just x -> return x
+  Nothing -> throwError $ InsertException [ConversionError s]
 
-readRational :: T.Text -> EitherErrs Rational
+readRational :: T.Text -> InsertExcept Rational
 readRational s = case T.split (== '.') s of
   [x] -> maybe err (return . fromInteger) $ readT x
   [x, y] -> case (readT x, readT y) of
@@ -309,7 +407,7 @@ readRational s = case T.split (== '.') s of
   _ -> err
   where
     readT = readMaybe . T.unpack
-    err = Left [ConversionError s]
+    err = throwError $ InsertException [ConversionError s]
 
 -- TODO smells like a lens
 -- mapTxSplits :: (a -> b) -> Tx a -> Tx b
@@ -331,17 +429,11 @@ roundPrecision n = (% p) . round . (* fromIntegral p) . toRational
   where
     p = 10 ^ n
 
-roundPrecisionCur :: CurID -> CurrencyMap -> Double -> EitherErrs Rational
+roundPrecisionCur :: CurID -> CurrencyMap -> Double -> InsertExcept 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
+    Just (_, n) -> return $ roundPrecision n x
+    Nothing -> throwError $ InsertException [undefined]
 
 acntPath2Text :: AcntPath -> T.Text
 acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
@@ -538,51 +630,51 @@ showT = T.pack . show
 --------------------------------------------------------------------------------
 -- pure error processing
 
-concatEither2 :: Either x a -> Either x b -> (a -> b -> c) -> Either [x] c
-concatEither2 a b fun = case (a, b) of
-  (Right a_, Right b_) -> Right $ fun a_ b_
-  _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b]
+-- concatEither2 :: Either x a -> Either x b -> (a -> b -> c) -> Either [x] c
+-- concatEither2 a b fun = case (a, b) of
+--   (Right a_, Right b_) -> Right $ fun a_ b_
+--   _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b]
 
-concatEither2M :: Monad m => Either x a -> Either x b -> (a -> b -> m c) -> m (Either [x] c)
-concatEither2M a b fun = case (a, b) of
-  (Right a_, Right b_) -> Right <$> fun a_ b_
-  _ -> return $ Left $ catMaybes [leftToMaybe a, leftToMaybe b]
+-- concatEither2M :: Monad m => Either x a -> Either x b -> (a -> b -> m c) -> m (Either [x] c)
+-- concatEither2M a b fun = case (a, b) of
+--   (Right a_, Right b_) -> Right <$> fun a_ b_
+--   _ -> return $ Left $ catMaybes [leftToMaybe a, leftToMaybe b]
 
-concatEither3 :: Either x a -> Either x b -> Either x c -> (a -> b -> c -> d) -> Either [x] d
-concatEither3 a b c fun = case (a, b, c) of
-  (Right a_, Right b_, Right c_) -> Right $ fun a_ b_ c_
-  _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b, leftToMaybe c]
+-- concatEither3 :: Either x a -> Either x b -> Either x c -> (a -> b -> c -> d) -> Either [x] d
+-- concatEither3 a b c fun = case (a, b, c) of
+--   (Right a_, Right b_, Right c_) -> Right $ fun a_ b_ c_
+--   _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b, leftToMaybe c]
 
-concatEithers2 :: Either [x] a -> Either [x] b -> (a -> b -> c) -> Either [x] c
-concatEithers2 a b = merge . concatEither2 a b
+-- concatEithers2 :: Either [x] a -> Either [x] b -> (a -> b -> c) -> Either [x] c
+-- concatEithers2 a b = merge . concatEither2 a b
 
-concatEithers2M
-  :: Monad m
-  => Either [x] a
-  -> Either [x] b
-  -> (a -> b -> m c)
-  -> m (Either [x] c)
-concatEithers2M a b = fmap merge . concatEither2M a b
+-- concatEithers2M
+--   :: Monad m
+--   => Either [x] a
+--   -> Either [x] b
+--   -> (a -> b -> m c)
+--   -> m (Either [x] c)
+-- concatEithers2M a b = fmap merge . concatEither2M a b
 
-concatEithers3
-  :: Either [x] a
-  -> Either [x] b
-  -> Either [x] c
-  -> (a -> b -> c -> d)
-  -> Either [x] d
-concatEithers3 a b c = merge . concatEither3 a b c
+-- concatEithers3
+--   :: Either [x] a
+--   -> Either [x] b
+--   -> Either [x] c
+--   -> (a -> b -> c -> d)
+--   -> Either [x] d
+-- concatEithers3 a b c = merge . concatEither3 a b c
 
-concatEitherL :: [Either x a] -> Either [x] [a]
-concatEitherL as = case partitionEithers as of
-  ([], bs) -> Right bs
-  (es, _) -> Left es
+-- concatEitherL :: [Either x a] -> Either [x] [a]
+-- concatEitherL as = case partitionEithers as of
+--   ([], bs) -> Right bs
+--   (es, _) -> Left es
 
-concatEithersL :: [Either [x] a] -> Either [x] [a]
-concatEithersL = merge . concatEitherL
+-- concatEithersL :: [Either [x] a] -> Either [x] [a]
+-- concatEithersL = merge . concatEitherL
 
-leftToMaybe :: Either a b -> Maybe a
-leftToMaybe (Left a) = Just a
-leftToMaybe _ = Nothing
+-- leftToMaybe :: Either a b -> Maybe a
+-- leftToMaybe (Left a) = Just a
+-- leftToMaybe _ = Nothing
 
 unlessLeft :: (Monad m, MonadPlus n) => Either a b -> (b -> m (n a)) -> m (n a)
 unlessLeft (Left es) _ = return (return es)
@@ -598,11 +690,11 @@ unlessLeft_ e f = unlessLeft e (\x -> void (f x) >> return mzero)
 unlessLefts_ :: (Monad m, MonadPlus n) => Either (n a) b -> (b -> m ()) -> m (n a)
 unlessLefts_ e f = unlessLefts e (\x -> void (f x) >> return mzero)
 
-plural :: Either a b -> Either [a] b
-plural = first (: [])
+-- plural :: Either a b -> Either [a] b
+-- plural = first (: [])
 
-merge :: Either [[a]] b -> Either [a] b
-merge = first concat
+-- merge :: Either [[a]] b -> Either [a] b
+-- merge = first concat
 
 --------------------------------------------------------------------------------
 -- random functions
@@ -646,23 +738,23 @@ thdOf3 (_, _, c) = c
 --     -- these options barely do anything in terms of performance
 --     compres = compile (blankCompOpt {newSyntax = True}) (blankExecOpt {captureGroups = False}) pat
 
-compileOptions :: TxOpts T.Text -> EitherErr TxOptsRe
+compileOptions :: TxOpts T.Text -> InsertExcept TxOptsRe
 compileOptions o@TxOpts {toAmountFmt = pat} = do
   re <- compileRegex True pat
   return $ o {toAmountFmt = re}
 
-compileMatch :: StatementParser T.Text -> EitherErrs MatchRe
+compileMatch :: StatementParser T.Text -> InsertExcept MatchRe
 compileMatch m@StatementParser {spDesc, spOther} = do
-  let dres = plural $ mapM go spDesc
-  let ores = concatEitherL $ fmap (mapM go) spOther
-  concatEithers2 dres ores $ \d_ os_ -> m {spDesc = d_, spOther = os_}
+  combineError dres ores $ \d os -> m {spDesc = d, spOther = os}
   where
     go = compileRegex False
+    dres = mapM go spDesc
+    ores = combineErrors $ fmap (mapM go) spOther
 
-compileRegex :: Bool -> T.Text -> EitherErr (Text, Regex)
+compileRegex :: Bool -> T.Text -> InsertExcept (Text, Regex)
 compileRegex groups pat = case res of
-  Right re -> Right (pat, re)
-  Left _ -> Left $ RegexError pat
+  Right re -> return (pat, re)
+  Left _ -> throwError $ InsertException [RegexError pat]
   where
     res =
       compile
@@ -670,10 +762,10 @@ compileRegex groups pat = case res of
         (blankExecOpt {captureGroups = groups})
         pat
 
-matchMaybe :: T.Text -> Regex -> EitherErrs Bool
+matchMaybe :: T.Text -> Regex -> InsertExcept Bool
 matchMaybe q re = case execute re q of
-  Right res -> Right $ isJust res
-  Left _ -> Left [RegexError "this should not happen"]
+  Right res -> return $ isJust res
+  Left _ -> throwError $ InsertException [RegexError "this should not happen"]
 
 matchGroupsMaybe :: T.Text -> Regex -> [T.Text]
 matchGroupsMaybe q re = case regexec re q of
diff --git a/package.yaml b/package.yaml
index 5c09970..93b2fc3 100644
--- a/package.yaml
+++ b/package.yaml
@@ -86,6 +86,7 @@ dependencies:
 - data-fix
 - filepath
 - mtl
+- persistent-mtl >= 0.3.0.0
 
 library:
   source-dirs: lib/
diff --git a/stack.yaml b/stack.yaml
index 120e4e4..9ed44a6 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -46,6 +46,7 @@ extra-deps:
   commit: ffd1ba94ef39b875aba8adc1c498f28aa02e36e4
   subdirs: [dhall]
 - hashable-1.3.5.0
+- persistent-mtl-0.3.0.0
 #
 # extra-deps: []
 

From b3276132e360efea7f11fcfe378b85cba720a949 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Mon, 8 May 2023 00:12:01 -0400
Subject: [PATCH 12/15] ENH actually use percents

---
 lib/Internal/Insert.hs | 11 +++++++----
 1 file changed, 7 insertions(+), 4 deletions(-)

diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs
index 443ac5e..531edc1 100644
--- a/lib/Internal/Insert.hs
+++ b/lib/Internal/Insert.hs
@@ -327,7 +327,7 @@ allocatePre precision gross = L.mapAccumR go M.empty
           p = preValue faValue
           v =
             if prePercent faValue
-              then roundPrecision 3 p * gross
+              then (roundPrecision 3 p / 100) * gross
               else roundPrecision precision p
        in (mapAdd_ c v m, f {faValue = v})
 
@@ -359,7 +359,7 @@ allocateTax precision gross deds = fmap (fmap go)
     go TaxValue {tvCategories, tvMethod} =
       let agi = gross - sum (mapMaybe (`M.lookup` deds) tvCategories)
        in case tvMethod of
-            TMPercent p -> roundPrecision 3 p * agi
+            TMPercent p -> roundPrecision 3 p / 100 * agi
             TMBracket TaxProgression {tpDeductible, tpBrackets} ->
               foldBracket precision (agi - roundPrecision precision tpDeductible) tpBrackets
 
@@ -371,14 +371,17 @@ allocatePost
 allocatePost precision aftertax = fmap (fmap go)
   where
     go PosttaxValue {postValue, postPercent} =
-      let v = postValue in if postPercent then aftertax * roundPrecision 3 v else roundPrecision precision v
+      let v = postValue
+       in if postPercent
+            then aftertax * roundPrecision 3 v / 100
+            else roundPrecision precision v
 
 foldBracket :: Natural -> Rational -> [TaxBracket] -> Rational
 foldBracket precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
   where
     go TaxBracket {tbLowerLimit, tbPercent} (acc, remain) =
       let l = roundPrecision precision tbLowerLimit
-          p = roundPrecision 3 tbPercent
+          p = roundPrecision 3 tbPercent / 100
        in if remain < l then (acc + p * (remain - l), l) else (acc, remain)
 
 data FlatAllocation v = FlatAllocation

From 397a78ddfb76b81903b54ec2741cb98c82454fb3 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sat, 13 May 2023 13:53:43 -0400
Subject: [PATCH 13/15] WIP split IO actions into stages

---
 app/Main.hs                  |  31 +++++++++--
 lib/Internal/Database/Ops.hs | 104 +++++++++++++++++++----------------
 lib/Internal/Insert.hs       |  87 ++++++++++++++++++++---------
 lib/Internal/Types.hs        |   5 ++
 4 files changed, 150 insertions(+), 77 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index a0f39d7..715f85c 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -2,8 +2,12 @@
 
 module Main (main) where
 
+import Control.Monad.Except
+import Control.Monad.IO.Rerunnable
+import Control.Monad.Logger
 import Control.Monad.Reader
 import qualified Data.Text.IO as TI
+import Database.Persist.Monad
 import Internal.Config
 import Internal.Database.Ops
 import Internal.Insert
@@ -158,11 +162,28 @@ runDumpAccountKeys c = do
 runSync :: FilePath -> IO ()
 runSync c = do
   config <- readConfig c
-  handle err $ runDB (sqlConfig config) $ do
-    let bgtRes = liftIOExceptT $ mapErrors insertBudget $ budget config
-    let histRes = mapErrorsIO insertStatement $ statements config
-    s <- fmap (\f -> f $ takeDirectory c) $ liftIOExceptT $ getDBState config
-    flip runReaderT s $ combineErrorIO2 bgtRes histRes $ \_ _ -> ()
+  let (hTs, hSs) = splitHistory $ statements config
+  pool <- runNoLoggingT $ mkPool $ sqlConfig config
+  handle err $ do
+    -- _ <- askLoggerIO
+
+    -- get the current DB state
+    s <- runSqlQueryT pool $ do
+      runMigration migrateAll
+      fmap (\f -> f $ takeDirectory c) $ liftIOExceptT $ getDBState config
+
+    -- read desired statements from disk
+    bSs <- flip runReaderT s $ catMaybes <$> mapM readHistStmt hSs
+
+    -- update the DB
+    runSqlQueryT pool $ withTransaction $ flip runReaderT s $ do
+      let hTransRes = mapErrors insertHistTransfer hTs
+      let bgtRes = mapErrors insertBudget $ budget config
+      updateDBState -- TODO this will only work if foreign keys are deferred
+      res <- runExceptT $ do
+        mapM_ (uncurry insertHistStmt) bSs
+        combineError hTransRes bgtRes $ \_ _ -> ()
+      rerunnableIO $ fromEither res
   where
     err (InsertException es) = do
       liftIO $ mapM_ TI.putStrLn $ concatMap showError es
diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs
index 8a09223..f7c95a3 100644
--- a/lib/Internal/Database/Ops.hs
+++ b/lib/Internal/Database/Ops.hs
@@ -2,10 +2,12 @@ module Internal.Database.Ops
   ( runDB
   , nukeTables
   , updateHashes
+  , updateDBState
   , getDBState
   , tree2Records
   , flattenAcntRoot
   , paths2IDs
+  , mkPool
   )
 where
 
@@ -134,12 +136,6 @@ getConfigHashes c = do
   dh <- getDBHashes
   return $ setDiff dh ch
 
-updateHashes :: MonadSqlQuery m => Config -> m [Int]
-updateHashes c = do
-  (del, new) <- getConfigHashes c
-  nukeDBHashes del
-  return new
-
 dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r]
 dumpTbl = selectE $ E.from E.table
 
@@ -164,18 +160,6 @@ deleteTag e = deleteE $ do
   where
     k = entityKey e
 
-updateAccounts :: MonadSqlQuery m => AccountRoot -> m AccountMap
-updateAccounts ar = do
-  let (acnts, paths, acntMap) = indexAcntRoot ar
-  acnts' <- dumpTbl
-  let (toIns, toDel) = setDiff acnts acnts'
-  deleteWhere ([] :: [Filter AccountPathR])
-  mapM_ deleteAccount toDel
-  -- liftIO $ mapM_ print toDel
-  mapM_ insertFull toIns
-  mapM_ insert paths
-  return acntMap
-
 -- TODO slip-n-slide code...
 insertFull
   :: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m)
@@ -183,15 +167,6 @@ insertFull
   -> m ()
 insertFull (Entity k v) = insertKey k v
 
-updateCurrencies :: MonadSqlQuery m => [Currency] -> m CurrencyMap
-updateCurrencies cs = do
-  let curs = fmap currency2Record cs
-  curs' <- selectE $ E.from $ E.table @CurrencyR
-  let (toIns, toDel) = setDiff curs curs'
-  mapM_ deleteCurrency toDel
-  mapM_ insertFull toIns
-  return $ currencyMap curs
-
 currency2Record :: Currency -> Entity CurrencyR
 currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
   Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision)
@@ -206,18 +181,6 @@ currencyMap =
           )
       )
 
-updateTags :: MonadSqlQuery m => [Tag] -> m TagMap
-updateTags cs = do
-  let tags = fmap toRecord cs
-  tags' <- selectE $ E.from $ E.table @TagR
-  let (toIns, toDel) = setDiff tags tags'
-  mapM_ deleteTag toDel
-  mapM_ insertFull toIns
-  return $ tagMap tags
-  where
-    toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc
-    tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
-
 toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
 toKey = toSqlKey . fromIntegral . hash
 
@@ -327,25 +290,74 @@ getDBState
   => Config
   -> m (FilePath -> DBState)
 getDBState c = do
-  am <- updateAccounts $ accounts c
-  cm <- updateCurrencies $ currencies c
-  ts <- updateTags $ tags c
-  hs <- updateHashes c
+  (del, new) <- getConfigHashes c
   -- TODO not sure how I feel about this, probably will change this struct alot
   -- in the future so whatever...for now
   combineError bi si $ \b s f ->
+    -- TODO this can be cleaned up, half of it is meant to be queried when
+    -- determining how to insert budgets/history and the rest is just
+    -- holdover data to delete upon successful insertion
     DBState
-      { kmCurrency = cm
+      { kmCurrency = currencyMap cs
       , kmAccount = am
       , kmBudgetInterval = b
       , kmStatementInterval = s
-      , kmNewCommits = hs
+      , kmNewCommits = new
+      , kmOldCommits = del
       , kmConfigDir = f
-      , kmTag = ts
+      , kmTag = tagMap ts
+      , kmTagAll = ts
+      , kmAcntPaths = paths
+      , kmAcntsOld = acnts
+      , kmCurrenciesOld = cs
       }
   where
     bi = liftExcept $ resolveBounds $ budgetInterval $ global c
     si = liftExcept $ resolveBounds $ statementInterval $ global c
+    (acnts, paths, am) = indexAcntRoot $ accounts c
+    cs = currency2Record <$> currencies c
+    ts = toRecord <$> tags c
+    toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc
+    tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
+
+updateHashes :: (MonadFinance m, MonadSqlQuery m) => m ()
+updateHashes = do
+  old <- askDBState kmOldCommits
+  nukeDBHashes old
+
+updateTags :: (MonadFinance m, MonadSqlQuery m) => m ()
+updateTags = do
+  tags <- askDBState kmTagAll
+  tags' <- selectE $ E.from $ E.table @TagR
+  let (toIns, toDel) = setDiff tags tags'
+  mapM_ deleteTag toDel
+  mapM_ insertFull toIns
+
+updateAccounts :: (MonadFinance m, MonadSqlQuery m) => m ()
+updateAccounts = do
+  acnts <- askDBState kmAcntsOld
+  paths <- askDBState kmAcntPaths
+  acnts' <- dumpTbl
+  let (toIns, toDel) = setDiff acnts acnts'
+  deleteWhere ([] :: [Filter AccountPathR])
+  mapM_ deleteAccount toDel
+  mapM_ insertFull toIns
+  mapM_ insert paths
+
+updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => m ()
+updateCurrencies = do
+  curs <- askDBState kmCurrenciesOld
+  curs' <- selectE $ E.from $ E.table @CurrencyR
+  let (toIns, toDel) = setDiff curs curs'
+  mapM_ deleteCurrency toDel
+  mapM_ insertFull toIns
+
+updateDBState :: (MonadFinance m, MonadSqlQuery m) => m ()
+updateDBState = do
+  updateHashes
+  updateTags
+  updateAccounts
+  updateCurrencies
 
 deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m ()
 deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)
diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs
index 531edc1..d9b2bfd 100644
--- a/lib/Internal/Insert.hs
+++ b/lib/Internal/Insert.hs
@@ -1,6 +1,9 @@
 module Internal.Insert
-  ( insertStatement
-  , insertBudget
+  ( insertBudget
+  , splitHistory
+  , insertHistTransfer
+  , readHistStmt
+  , insertHistStmt
   )
 where
 
@@ -116,7 +119,10 @@ withDates dp f = do
 -- 4. assign shadow transactions (TODO)
 -- 5. insert all transactions
 
-insertBudget :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => Budget -> m ()
+insertBudget
+  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
+  => Budget
+  -> m [UnbalancedTransfer]
 insertBudget
   b@Budget
     { bgtLabel
@@ -127,16 +133,15 @@ insertBudget
     , bgtTax
     , bgtPosttax
     } =
-    whenHash CTBudget b () $ \key -> do
+    whenHash CTBudget b [] $ \key -> do
       intAllos <- combineError3 pre_ tax_ post_ (,,)
-      let res1 = combineErrors $ fmap (insertIncome key bgtLabel intAllos) bgtIncomes
+      let res1 = mapErrors (insertIncome key bgtLabel intAllos) bgtIncomes
       let res2 = expandTransfers key bgtLabel bgtTransfers
       txs <- combineError (concat <$> res1) res2 (++)
       m <- askDBState kmCurrency
       shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs
-      let bals = balanceTransfers $ txs ++ shadow
-      _ <- combineErrors $ fmap insertBudgetTx bals
-      return ()
+      void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow
+      return $ shadow ++ txs
     where
       pre_ = sortAllos bgtPretax
       tax_ = sortAllos bgtTax
@@ -251,11 +256,13 @@ data FlatTransfer v = FlatTransfer
   , cbtMeta :: !BudgetMeta
   , cbtCur :: !BudgetCurrency
   }
+  deriving (Show)
 
 data UnbalancedValue = UnbalancedValue
   { cvType :: !BudgetTransferType
   , cvValue :: !Rational
   }
+  deriving (Show)
 
 type UnbalancedTransfer = FlatTransfer UnbalancedValue
 
@@ -529,18 +536,24 @@ checkAcntTypes ts i = go =<< lookupAccountType i
 --------------------------------------------------------------------------------
 -- statements
 
-insertStatement
-  :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m)
-  => History
-  -> m ()
-insertStatement (HistTransfer m) = liftIOExceptT $ insertManual m
-insertStatement (HistStatement i) = insertImport i
+splitHistory :: [History] -> ([HistTransfer], [Statement])
+splitHistory = partitionEithers . fmap go
+  where
+    go (HistTransfer x) = Left x
+    go (HistStatement x) = Right x
 
-insertManual
+-- insertStatement
+--   :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m)
+--   => History
+--   -> m ()
+-- insertStatement (HistTransfer m) = liftIOExceptT $ insertManual m
+-- insertStatement (HistStatement i) = insertImport i
+
+insertHistTransfer
   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
   => HistTransfer
   -> m ()
-insertManual
+insertHistTransfer
   m@Transfer
     { transFrom = from
     , transTo = to
@@ -558,17 +571,28 @@ insertManual
             mapM_ (insertTx c) keys
       void $ combineErrors $ fmap go amts
 
-insertImport
-  :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m)
-  => Statement
-  -> m ()
-insertImport i = whenHash CTImport i () $ \c -> do
-  -- TODO this isn't efficient, the whole file will be read and maybe no
-  -- transactions will be desired
+readHistStmt :: (MonadUnliftIO m, MonadFinance m) => Statement -> m (Maybe (CommitR, [KeyTx]))
+readHistStmt i = whenHash_ CTImport i $ do
   bs <- readImport i
   bounds <- expandBounds <$> askDBState kmStatementInterval
-  keys <- liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs
-  mapM_ (insertTx c) keys
+  liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs
+
+insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m ()
+insertHistStmt c ks = do
+  ck <- insert c
+  mapM_ (insertTx ck) ks
+
+-- insertImport
+--   :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m)
+--   => Statement
+--   -> m ()
+-- insertImport i = whenHash CTImport i () $ \c -> do
+--   -- TODO this isn't efficient, the whole file will be read and maybe no
+--   -- transactions will be desired
+--   bs <- readImport i
+--   bounds <- expandBounds <$> askDBState kmStatementInterval
+--   keys <- liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs
+--   mapM_ (insertTx c) keys
 
 --------------------------------------------------------------------------------
 -- low-level transaction stuff
@@ -667,7 +691,6 @@ lookupFinance
 lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f
 
 -- TODO this hashes twice (not that it really matters)
--- TODO generalize this (persistent mtl)
 
 whenHash
   :: (Hashable a, MonadFinance m, MonadSqlQuery m)
@@ -680,3 +703,15 @@ whenHash t o def f = do
   let h = hash o
   hs <- askDBState kmNewCommits
   if h `elem` hs then f =<< insert (CommitR h t) else return def
+
+whenHash_
+  :: (Hashable a, MonadFinance m)
+  => ConfigType
+  -> a
+  -> m b
+  -> m (Maybe (CommitR, b))
+whenHash_ t o f = do
+  let h = hash o
+  let c = CommitR h t
+  hs <- askDBState kmNewCommits
+  if h `elem` hs then Just . (c,) <$> f else return Nothing
diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs
index d42dac9..f5e7be5 100644
--- a/lib/Internal/Types.hs
+++ b/lib/Internal/Types.hs
@@ -597,7 +597,12 @@ data DBState = DBState
   , kmBudgetInterval :: !Bounds
   , kmStatementInterval :: !Bounds
   , kmNewCommits :: ![Int]
+  , kmOldCommits :: ![Int]
   , kmConfigDir :: !FilePath
+  , kmTagAll :: ![Entity TagR]
+  , kmAcntPaths :: ![AccountPathR]
+  , kmAcntsOld :: ![Entity AccountR]
+  , kmCurrenciesOld :: ![Entity CurrencyR]
   }
 
 type CurrencyM = Reader CurrencyMap

From 5e2e8d8acf978b69d8d20ae58dd9f67d3febd504 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sun, 14 May 2023 19:20:10 -0400
Subject: [PATCH 14/15] ENH scale taxes by pay period length

---
 dhall/Types.dhall      | 55 +++++++++++++++++++++++++++
 lib/Internal/Insert.hs | 85 ++++++++++++++++++++++++++++++++++++------
 lib/Internal/Types.hs  | 14 +++++++
 lib/Internal/Utils.hs  | 21 ++++++++++-
 4 files changed, 163 insertions(+), 12 deletions(-)

diff --git a/dhall/Types.dhall b/dhall/Types.dhall
index dbbde81..063c7c2 100644
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@@ -787,6 +787,52 @@ let MultiAllocation =
     -}
       Allocation Interval
 
+let HourlyPeriod =
+    {-
+    Definition for a pay period denominated in hours
+    -}
+      { hpAnnualHours :
+          {-
+          Number of hours in one year
+          -}
+          Natural
+      , hpDailyHours :
+          {-
+          Number of hours in one working day
+          -}
+          Natural
+      , hpWorkingDays :
+          {-
+          Days which count as working days
+          -}
+          List Weekday
+      }
+
+let PeriodType =
+    {-
+    Type of pay period.
+
+    Hourly: pay period is denominated in hours
+    Daily: pay period is denominated in working days (specified in a list)
+    -}
+      < Hourly : HourlyPeriod | Daily : List Weekday >
+
+let Period =
+    {-
+    Definition of a pay period
+    -}   { pType :
+             {-
+             Type of pay period
+             -}
+             PeriodType
+         , pStart :
+             {-
+             Start date of the pay period. Must occur before first payment
+             in this income stream is dispersed.
+             -}
+             Gregorian
+         }
+
 let Income =
     {-
     Means to compute an income stream and how to allocate it
@@ -807,6 +853,12 @@ let Income =
               The dates on which the income stream is distributed.
               -}
               DatePat
+          , incPayPeriod :
+              {-
+              Defines the period of time over which this income was earned
+              (mostly used for taxes)
+              -}
+              Period
           , incPretax : List (SingleAllocation PretaxValue)
           , incTaxes : List (SingleAllocation TaxValue)
           , incPosttax : List (SingleAllocation PosttaxValue)
@@ -1029,4 +1081,7 @@ in  { CurID
     , HistTransfer
     , SingleAllocation
     , MultiAllocation
+    , HourlyPeriod
+    , Period
+    , PeriodType
     }
diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs
index d9b2bfd..b5524e3 100644
--- a/lib/Internal/Insert.hs
+++ b/lib/Internal/Insert.hs
@@ -105,6 +105,19 @@ withDates dp f = do
   days <- liftExcept $ expandDatePat bounds dp
   combineErrors $ fmap f days
 
+foldDates
+  :: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
+  => DatePat
+  -> Day
+  -> (Day -> Day -> m a)
+  -> m [a]
+foldDates dp start f = do
+  bounds <- askDBState kmBudgetInterval
+  days <- liftExcept $ expandDatePat bounds dp
+  combineErrors $
+    snd $
+      L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days
+
 --------------------------------------------------------------------------------
 -- budget
 
@@ -279,29 +292,42 @@ insertIncome
   key
   name
   (intPre, intTax, intPost)
-  Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal, incGross} = do
+  Income
+    { incWhen
+    , incCurrency
+    , incFrom
+    , incPretax
+    , incPosttax
+    , incTaxes
+    , incToBal
+    , incGross
+    , incPayPeriod
+    } = do
     -- TODO check that the other accounts are not income somewhere here
     _ <- checkAcntType IncomeT $ taAcnt incFrom
     precision <- lookupCurrencyPrec incCurrency
+    let gross = roundPrecision precision incGross
     -- 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 :(
-    let gross = roundPrecision precision incGross
-    res <- withDates incWhen (allocate precision gross)
+    res <- foldDates incWhen start (allocate precision gross)
     return $ concat res
     where
+      start = fromGregorian' $ pStart incPayPeriod
+      pType' = pType incPayPeriod
       meta = BudgetMeta key name
       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 precision gross day =
+      allocate precision gross prevDay day = do
+        scaler <- liftExcept $ periodScaler pType' prevDay day
         let (preDeductions, pre) =
               allocatePre precision gross $
                 flatPre ++ concatMap (selectAllos day) intPre
             tax =
-              allocateTax precision gross preDeductions $
+              allocateTax precision gross preDeductions scaler $
                 flatTax ++ concatMap (selectAllos day) intTax
             aftertaxGross = sumAllos $ tax ++ pre
             post =
@@ -322,6 +348,41 @@ insertIncome
               then throwError $ InsertException [IncomeError day name balance]
               else return (bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post))
 
+type PeriodScaler = Natural -> Double -> Double
+
+-- TODO we probably don't need to check for 1/0 each time
+periodScaler
+  :: PeriodType
+  -> Day
+  -> Day
+  -> InsertExcept PeriodScaler
+periodScaler pt prev cur
+  | interval > 0 = return scale
+  -- TODO fix error here
+  | otherwise = throwError $ InsertException undefined
+  where
+    interval = diffDays cur prev
+    startDay = dayOfWeek prev
+    days = L.sort $
+      fmap (diff startDay . fromWeekday) $
+        L.nub $ case pt of
+          Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays
+          Daily ds -> ds
+    diff a b = fromIntegral $ mod (fromEnum a - fromEnum b) 7
+    n =
+      let (nFull, nPart) = divMod interval 7
+          daysFull = fromIntegral (length days) * nFull
+          daysTail = fromIntegral $ length $ takeWhile (< nPart) days
+       in fromIntegral $ daysFull + daysTail
+    scale precision x = case pt of
+      Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
+        fromRational (rnd $ x / fromIntegral hpAnnualHours)
+          * fromIntegral hpDailyHours
+          * n
+      Daily _ -> x * n / 365.25
+      where
+        rnd = roundPrecision precision
+
 allocatePre
   :: Natural
   -> Rational
@@ -359,16 +420,18 @@ allocateTax
   :: Natural
   -> Rational
   -> M.Map T.Text Rational
+  -> PeriodScaler
   -> [FlatAllocation TaxValue]
   -> [FlatAllocation Rational]
-allocateTax precision gross deds = fmap (fmap go)
+allocateTax precision gross preDeds f = fmap (fmap go)
   where
     go TaxValue {tvCategories, tvMethod} =
-      let agi = gross - sum (mapMaybe (`M.lookup` deds) tvCategories)
+      let agi = gross - sum (mapMaybe (`M.lookup` preDeds) tvCategories)
        in case tvMethod of
             TMPercent p -> roundPrecision 3 p / 100 * agi
             TMBracket TaxProgression {tpDeductible, tpBrackets} ->
-              foldBracket precision (agi - roundPrecision precision tpDeductible) tpBrackets
+              let taxDed = roundPrecision precision $ f precision tpDeductible
+               in foldBracket f precision (agi - taxDed) tpBrackets
 
 allocatePost
   :: Natural
@@ -383,11 +446,11 @@ allocatePost precision aftertax = fmap (fmap go)
             then aftertax * roundPrecision 3 v / 100
             else roundPrecision precision v
 
-foldBracket :: Natural -> Rational -> [TaxBracket] -> Rational
-foldBracket precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
+foldBracket :: PeriodScaler -> Natural -> Rational -> [TaxBracket] -> Rational
+foldBracket f precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
   where
     go TaxBracket {tbLowerLimit, tbPercent} (acc, remain) =
-      let l = roundPrecision precision tbLowerLimit
+      let l = roundPrecision precision $ f precision tbLowerLimit
           p = roundPrecision 3 tbPercent / 100
        in if remain < l then (acc + p * (remain - l), l) else (acc, remain)
 
diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs
index f5e7be5..6058653 100644
--- a/lib/Internal/Types.hs
+++ b/lib/Internal/Types.hs
@@ -41,6 +41,7 @@ makeHaskellTypesWith
   , MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
   , MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
   , MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
+  , MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType"
   , SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
   , SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag"
   , SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
@@ -66,6 +67,8 @@ makeHaskellTypesWith
   , SingleConstructor "TaxValue" "TaxValue" "(./dhall/Types.dhall).TaxValue"
   , SingleConstructor "PosttaxValue" "PosttaxValue" "(./dhall/Types.dhall).PosttaxValue"
   , SingleConstructor "BudgetTransferValue" "BudgetTransferValue" "(./dhall/Types.dhall).BudgetTransferValue"
+  , SingleConstructor "Period" "Period" "(./dhall/Types.dhall).Period"
+  , SingleConstructor "HourlyPeriod" "HourlyPeriod" "(./dhall/Types.dhall).HourlyPeriod"
   -- , SingleConstructor "ToTx" "ToTx" "(./dhall/Types.dhall).ToTx"
   -- , SingleConstructor "FieldMatcher" "FieldMatcher" "(./dhall/Types.dhall).FieldMatcher_"
   -- , SingleConstructor "Match" "Match" "(./dhall/Types.dhall).Match_"
@@ -110,6 +113,9 @@ deriveProduct
   , "PosttaxValue"
   , "BudgetTransferValue"
   , "BudgetTransferType"
+  , "Period"
+  , "PeriodType"
+  , "HourlyPeriod"
   ]
 
 -------------------------------------------------------------------------------
@@ -229,8 +235,15 @@ data Income = Income
   , incPosttax :: [SingleAllocation PosttaxValue]
   , incFrom :: TaggedAcnt
   , incToBal :: TaggedAcnt
+  , incPayPeriod :: !Period
   }
 
+deriving instance Hashable HourlyPeriod
+
+deriving instance Hashable PeriodType
+
+deriving instance Hashable Period
+
 deriving instance Hashable Income
 
 deriving instance (Ord w, Ord v) => Ord (Amount w v)
@@ -747,6 +760,7 @@ data InsertError
   | PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
   | BoundsError !Gregorian !(Maybe Gregorian)
   | StatementError ![TxRecord] ![MatchRe]
+  | PeriodError !Day !Day
   deriving (Show)
 
 newtype InsertException = InsertException [InsertError]
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index f1dee17..76db251 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -1,5 +1,6 @@
 module Internal.Utils
   ( compareDate
+  , fromWeekday
   , inBounds
   , expandBounds
   , fmtRational
@@ -77,6 +78,16 @@ import Text.Regex.TDFA.Text
 --------------------------------------------------------------------------------
 -- dates
 
+-- | Lame weekday converter since day of weeks aren't in dhall (yet)
+fromWeekday :: Weekday -> DayOfWeek
+fromWeekday Mon = Monday
+fromWeekday Tue = Tuesday
+fromWeekday Wed = Wednesday
+fromWeekday Thu = Thursday
+fromWeekday Fri = Friday
+fromWeekday Sat = Saturday
+fromWeekday Sun = Sunday
+
 -- | find the next date
 -- this is meant to go in a very tight loop and be very fast (hence no
 -- complex date functions, most of which heavily use 'mod' and friends)
@@ -500,7 +511,15 @@ showError other = case other of
         , "exceed total on day"
         , showT day
         , "where balance is"
-        , showT balance
+        , showT (fromRational balance :: Double)
+        ]
+    ]
+  (PeriodError start next) ->
+    [ T.unwords
+        [ "First pay period on "
+        , singleQuote $ showT start
+        , "must start before first income payment on "
+        , singleQuote $ showT next
         ]
     ]
   (BalanceError t cur rss) ->

From b2fdc8d74ce2d93bf6cc708824aac1816848eb60 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Tue, 16 May 2023 23:12:29 -0400
Subject: [PATCH 15/15] FIX tax miscalculations

---
 lib/Internal/Insert.hs | 101 ++++++++++++++++++++++-------------------
 lib/Internal/Types.hs  |   7 ++-
 2 files changed, 61 insertions(+), 47 deletions(-)

diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs
index b5524e3..740d11b 100644
--- a/lib/Internal/Insert.hs
+++ b/lib/Internal/Insert.hs
@@ -135,7 +135,7 @@ foldDates dp start f = do
 insertBudget
   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
   => Budget
-  -> m [UnbalancedTransfer]
+  -> m ()
 insertBudget
   b@Budget
     { bgtLabel
@@ -146,7 +146,7 @@ insertBudget
     , bgtTax
     , bgtPosttax
     } =
-    whenHash CTBudget b [] $ \key -> do
+    whenHash CTBudget b () $ \key -> do
       intAllos <- combineError3 pre_ tax_ post_ (,,)
       let res1 = mapErrors (insertIncome key bgtLabel intAllos) bgtIncomes
       let res2 = expandTransfers key bgtLabel bgtTransfers
@@ -154,7 +154,6 @@ insertBudget
       m <- askDBState kmCurrency
       shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs
       void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow
-      return $ shadow ++ txs
     where
       pre_ = sortAllos bgtPretax
       tax_ = sortAllos bgtTax
@@ -172,16 +171,16 @@ type IntAllocations =
 -- TODO this should actually error if there is no ultimate end date?
 sortAllo :: MultiAllocation v -> InsertExcept (BoundAllocation v)
 sortAllo a@Allocation {alloAmts = as} = do
-  bs <- foldBounds (return []) $ L.sortOn amtWhen as
+  bs <- foldBounds [] $ L.sortOn amtWhen as
   return $ a {alloAmts = reverse bs}
   where
-    foldBounds acc [] = acc
-    foldBounds acc (x : xs) =
-      let res = case xs of
-            [] -> resolveBounds $ amtWhen x
-            (y : _) -> resolveBounds_ (intStart $ amtWhen y) $ amtWhen x
-          concatRes bs acc' = x {amtWhen = expandBounds bs} : acc'
-       in foldBounds (combineError res acc concatRes) xs
+    foldBounds acc [] = return acc
+    foldBounds acc (x : xs) = do
+      let start = amtWhen x
+      res <- case xs of
+        [] -> resolveBounds start
+        (y : _) -> resolveBounds_ (intStart $ amtWhen y) start
+      foldBounds (x {amtWhen = expandBounds res} : acc) xs
 
 -- TODO this is going to be O(n*m), which might be a problem?
 addShadowTransfers
@@ -232,12 +231,12 @@ shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
       (if asInclude then id else not) $ x `elem` asList
 
 balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
-balanceTransfers ts =
-  snd $ L.mapAccumR go M.empty $ reverse $ L.sortOn cbtWhen ts
+balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn cbtWhen
   where
     go bals f@FlatTransfer {cbtFrom, cbtTo, cbtValue = UnbalancedValue {cvValue, cvType}} =
-      let (bals', v) = mapAdd cbtTo x $ mapAdd_ cbtFrom (-x) bals
-          x = amtToMove v cvType cvValue
+      let balTo = M.findWithDefault 0 cbtTo bals
+          x = amtToMove balTo cvType cvValue
+          bals' = mapAdd_ cbtTo x $ mapAdd_ cbtFrom (-x) bals
        in (bals', f {cbtValue = x})
     -- TODO might need to query signs to make this intuitive; as it is this will
     -- probably work, but for credit accounts I might need to supply a negative
@@ -247,12 +246,7 @@ balanceTransfers ts =
     amtToMove bal BTTarget x = x - bal
 
 mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
-mapAdd_ k v m = fst $ mapAdd k v m
-
-mapAdd :: (Ord k, Num v) => k -> v -> M.Map k v -> (M.Map k v, v)
-mapAdd k v m = (new, M.findWithDefault (error "this should not happen") k new)
-  where
-    new = M.alter (maybe (Just v) (Just . (+ v))) k m
+mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k
 
 data BudgetMeta = BudgetMeta
   { bmCommit :: !CommitRId
@@ -356,25 +350,14 @@ periodScaler
   -> Day
   -> Day
   -> InsertExcept PeriodScaler
-periodScaler pt prev cur
-  | interval > 0 = return scale
-  -- TODO fix error here
-  | otherwise = throwError $ InsertException undefined
+periodScaler pt prev cur = do
+  n <- workingDays wds prev cur
+  return $ scale (fromIntegral n)
   where
-    interval = diffDays cur prev
-    startDay = dayOfWeek prev
-    days = L.sort $
-      fmap (diff startDay . fromWeekday) $
-        L.nub $ case pt of
-          Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays
-          Daily ds -> ds
-    diff a b = fromIntegral $ mod (fromEnum a - fromEnum b) 7
-    n =
-      let (nFull, nPart) = divMod interval 7
-          daysFull = fromIntegral (length days) * nFull
-          daysTail = fromIntegral $ length $ takeWhile (< nPart) days
-       in fromIntegral $ daysFull + daysTail
-    scale precision x = case pt of
+    wds = case pt of
+      Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays
+      Daily ds -> ds
+    scale n precision x = case pt of
       Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
         fromRational (rnd $ x / fromIntegral hpAnnualHours)
           * fromIntegral hpDailyHours
@@ -383,6 +366,20 @@ periodScaler pt prev cur
       where
         rnd = roundPrecision precision
 
+workingDays :: [Weekday] -> Day -> Day -> InsertExcept Natural
+workingDays wds start end
+  | interval > 0 =
+      let (nFull, nPart) = divMod interval 7
+          daysFull = fromIntegral (length wds') * nFull
+          daysTail = fromIntegral $ length $ takeWhile (< nPart) wds'
+       in return $ fromIntegral $ daysFull + daysTail
+  | otherwise = throwError $ InsertException undefined
+  where
+    interval = diffDays end start
+    startDay = dayOfWeek start
+    wds' = L.sort $ (\x -> diff (fromWeekday x) startDay) <$> L.nub wds
+    diff a b = fromIntegral $ mod (fromEnum a - fromEnum b) 7
+
 allocatePre
   :: Natural
   -> Rational
@@ -428,7 +425,10 @@ allocateTax precision gross preDeds f = fmap (fmap go)
     go TaxValue {tvCategories, tvMethod} =
       let agi = gross - sum (mapMaybe (`M.lookup` preDeds) tvCategories)
        in case tvMethod of
-            TMPercent p -> roundPrecision 3 p / 100 * agi
+            TMPercent p ->
+              roundPrecision precision $
+                fromRational $
+                  roundPrecision 3 p / 100 * agi
             TMBracket TaxProgression {tpDeductible, tpBrackets} ->
               let taxDed = roundPrecision precision $ f precision tpDeductible
                in foldBracket f precision (agi - taxDed) tpBrackets
@@ -446,13 +446,24 @@ allocatePost precision aftertax = fmap (fmap go)
             then aftertax * roundPrecision 3 v / 100
             else roundPrecision precision v
 
+-- | Compute effective tax percentage of a bracket
+-- The algorithm can be thought of in three phases:
+-- 1. Find the highest tax bracket by looping backward until the AGI is less
+--    than the bracket limit
+-- 2. Computing the tax in the top bracket by subtracting the AGI from the
+--    bracket limit and multiplying by the tax percentage.
+-- 3. Adding all lower brackets, which are just the limit of the bracket less
+--    the amount of the lower bracket times the percentage.
+--
+-- 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
   where
-    go TaxBracket {tbLowerLimit, tbPercent} (acc, remain) =
+    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 (acc, remain)
+       in if remain >= l then (acc + p * (remain - l), l) else a
 
 data FlatAllocation v = FlatAllocation
   { faValue :: !v
@@ -460,7 +471,7 @@ data FlatAllocation v = FlatAllocation
   , faTo :: !TaggedAcnt
   , faCur :: !BudgetCurrency
   }
-  deriving (Functor)
+  deriving (Functor, Show)
 
 flattenAllo :: SingleAllocation v -> [FlatAllocation v]
 flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
@@ -476,9 +487,7 @@ flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
 -- ASSUME allocations are sorted
 selectAllos :: Day -> BoundAllocation v -> [FlatAllocation v]
 selectAllos day Allocation {alloAmts, alloCur, alloTo} =
-  fmap go $
-    takeWhile ((`inBounds` day) . amtWhen) $
-      dropWhile ((day <) . fst . amtWhen) alloAmts
+  go <$> filter ((`inBounds` day) . amtWhen) alloAmts
   where
     go Amount {amtValue, amtDesc} =
       FlatAllocation
diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs
index 6058653..6b7fc77 100644
--- a/lib/Internal/Types.hs
+++ b/lib/Internal/Types.hs
@@ -293,7 +293,12 @@ fromPersistText what (PersistText t) = case readMaybe $ T.unpack t of
 fromPersistText what x =
   Left $ T.unwords ["error when deserializing", what, "; got", T.pack (show x)]
 
-deriving instance Ord Interval
+-- this is necessary since dhall will reverse the order when importing
+instance Ord Interval where
+  compare
+    Interval {intStart = s0, intEnd = e0}
+    Interval {intStart = s1, intEnd = e1} =
+      compare (s0, e0) (s1, e1)
 
 data Transfer a c w v = Transfer
   { transFrom :: a