12 changed files with 1617 additions and 2456 deletions
--- a/app/Main.hs
+++ b/app/Main.hs
@ -2,17 +2,13 @@

 module Main (main) where

-import Control.Concurrent
 import Control.Monad.Except
 import Control.Monad.IO.Rerunnable
 import Control.Monad.Logger
 import Control.Monad.Reader
-import Data.Bitraversable
-- import Data.Hashable
 import qualified Data.Text.IO as TI
-import qualified Database.Esqueleto.Experimental as E
 import Database.Persist.Monad
-import qualified Dhall hiding (double, record)
+import Dhall hiding (double, record)
 import Internal.Budget
 import Internal.Database
 import Internal.History
@ -21,7 +17,6 @@ import Internal.Utils
 import Options.Applicative
 import RIO
 import RIO.FilePath
-- import qualified RIO.Map as M
 import qualified RIO.Text as T

 main :: IO ()
@ -35,26 +30,14 @@ main = parse =<< execParser o
            <> header "pwncash - your budget, your life"
        )

-type ConfigPath = FilePath
-
-type BudgetPath = FilePath
-
-type HistoryPath = FilePath
-
-data Options = Options !ConfigPath !Mode
+data Options = Options FilePath Mode

 data Mode
  = Reset
  | DumpCurrencies
  | DumpAccounts
  | DumpAccountKeys
-  | Sync !SyncOptions
-
-data SyncOptions = SyncOptions
-  { syncBudgets :: ![BudgetPath]
-  , syncHistories :: ![HistoryPath]
-  , syncThreads :: !Int
-  }
+  | Sync

 configFile :: Parser FilePath
 configFile =
@ -121,35 +104,6 @@ sync =
        <> short 'S'
        <> help "Sync config to database"
    )
-    <*> syncOptions
-
-syncOptions :: Parser SyncOptions
-syncOptions =
-  SyncOptions
-    <$> many
-      ( strOption
-          ( long "budget"
-              <> short 'b'
-              <> metavar "BUDGET"
-              <> help "path to a budget config"
-          )
-      )
-    <*> many
-      ( strOption
-          ( long "history"
-              <> short 'H'
-              <> metavar "HISTORY"
-              <> help "path to a history config"
-          )
-      )
-    <*> option
-      auto
-      ( long "threads"
-          <> short 't'
-          <> metavar "THREADS"
-          <> value 1
-          <> help "number of threads for syncing"
-      )

 parse :: Options -> IO ()
 parse (Options c Reset) = do
@ -158,8 +112,7 @@ parse (Options c Reset) = do
 parse (Options c DumpAccounts) = runDumpAccounts c
 parse (Options c DumpAccountKeys) = runDumpAccountKeys c
 parse (Options c DumpCurrencies) = runDumpCurrencies c
-parse (Options c (Sync SyncOptions {syncBudgets, syncHistories, syncThreads})) =
-  runSync syncThreads c syncBudgets syncHistories
+parse (Options c Sync) = runSync c

 runDumpCurrencies :: MonadUnliftIO m => FilePath -> m ()
 runDumpCurrencies c = do
@ -197,70 +150,50 @@ runDumpAccountKeys c = do
  ar <- accounts <$> readConfig c
  let ks =
        paths2IDs $
-          fmap (double . accountRFullpath . E.entityVal) $
-            fst $
-              indexAcntRoot ar
+          fmap (double . fst) $
+            concatMap (t3 . uncurry tree2Records) $
+              flattenAcntRoot ar
  mapM_ (uncurry printPair) ks
  where
    printPair i p = do
-      liftIO $ putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", unAcntID i]
+      liftIO $ putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", i]
+    t3 (_, _, x) = x
    double x = (x, x)

-runSync :: Int -> FilePath -> [FilePath] -> [FilePath] -> IO ()
-runSync threads c bs hs = do
-  setNumCapabilities threads
-  -- putStrLn "reading config"
+runSync :: FilePath -> IO ()
+runSync c = do
  config <- readConfig c
-  -- putStrLn "reading statements"
-  (bs', hs') <-
-    fmap (bimap concat concat . partitionEithers) $
-      pooledMapConcurrentlyN threads (bimapM readDhall readDhall) $
-        (Left <$> bs) ++ (Right <$> hs)
+  let (hTs, hSs) = splitHistory $ statements config
  pool <- runNoLoggingT $ mkPool $ sqlConfig config
-  putStrLn "doing other stuff"
-  setNumCapabilities 1
  handle err $ do
    -- _ <- askLoggerIO

-    -- Get the current DB state.
-    state <- runSqlQueryT pool $ do
+    -- get the current DB state
+    (state, updates) <- runSqlQueryT pool $ do
      runMigration migrateAll
-      liftIOExceptT $ readConfigState config bs' hs'
+      liftIOExceptT $ getDBState config

-    -- Read raw transactions according to state. If a transaction is already in
-    -- the database, don't read it but record the commit so we can update it.
-    toIns <-
-      flip runReaderT state $ do
-        (CRUDOps hSs _ _ _) <- asks csHistStmts
-        hSs' <- mapErrorsIO (readHistStmt root) hSs
-        (CRUDOps hTs _ _ _) <- asks csHistTrans
-        hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
-        (CRUDOps bTs _ _ _) <- asks csBudgets
-        bTs' <- liftIOExceptT $ mapErrors readBudget bTs
-        return $ concat $ hSs' ++ hTs' ++ bTs'
+    -- read desired statements from disk
+    bSs <-
+      flip runReaderT state $
+        catMaybes <$> mapErrorsIO (readHistStmt root) hSs

-    -- Update the DB.
+    -- update the DB
    runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
-      -- NOTE this must come first (unless we defer foreign keys)
-      updateDBState
+      let hTransRes = mapErrors insertHistTransfer hTs
+      let bgtRes = mapErrors insertBudget $ budget config
+      updateDBState updates -- TODO this will only work if foreign keys are deferred
      res <- runExceptT $ do
-        (CRUDOps _ bRs bUs _) <- asks csBudgets
-        (CRUDOps _ tRs tUs _) <- asks csHistTrans
-        (CRUDOps _ sRs sUs _) <- asks csHistStmts
-        let ebs = fmap ToUpdate (bUs ++ tUs ++ sUs) ++ fmap ToRead (bRs ++ tRs ++ sRs) ++ fmap ToInsert toIns
-        insertAll ebs
-      -- NOTE this rerunnable thing is a bit misleading; fromEither will throw
-      -- whatever error is encountered above in an IO context, but the first
-      -- thrown error should be caught despite possibly needing to be rerun
+        mapM_ (uncurry insertHistStmt) bSs
+        combineError hTransRes bgtRes $ \_ _ -> ()
      rerunnableIO $ fromEither res
  where
    root = takeDirectory c
-    err (AppException es) = do
+    err (InsertException es) = do
      liftIO $ mapM_ TI.putStrLn $ concatMap showError es
      exitFailure

-readConfig :: MonadUnliftIO m => FilePath -> m Config
-readConfig = fmap unfix . readDhall
+-- showBalances

-readDhall :: Dhall.FromDhall a => MonadUnliftIO m => FilePath -> m a
-readDhall confpath = liftIO $ Dhall.inputFile Dhall.auto confpath
+readConfig :: MonadUnliftIO m => FilePath -> m Config
+readConfig confpath = liftIO $ unfix <$> Dhall.inputFile Dhall.auto confpath
--- a/budget.cabal
+++ b/budget.cabal
@ -75,8 +75,7 @@ library
      ViewPatterns
  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2
  build-depends:
-      Decimal >=0.5.2
-    , base >=4.12 && <10
+      base >=4.12 && <10
    , cassava
    , conduit >=1.3.4.2
    , containers >=0.6.4.1
@ -145,8 +144,7 @@ executable pwncash
      ViewPatterns
  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2 -threaded
  build-depends:
-      Decimal >=0.5.2
-    , base >=4.12 && <10
+      base >=4.12 && <10
    , budget
    , cassava
    , conduit >=1.3.4.2
--- a/dhall/Types.dhall
+++ b/dhall/Types.dhall
@ -278,9 +278,8 @@ let DatePat =
    -}
      < Cron : CronPat.Type | Mod : ModPat.Type >

-let TxOpts_ =
+let TxOpts =
    {- Additional metadata to use when parsing a statement -}
-      \(re : Type) ->
      { Type =
          { toDate :
              {-
@ -313,7 +312,7 @@ let TxOpts_ =
              {- Format of the amount field. Must include three fields for the
              sign, numerator, and denominator of the amount.
              -}
-                re
+              Text
          }
      , default =
        { toDate = "Date"
@ -325,8 +324,6 @@ let TxOpts_ =
        }
      }

-let TxOpts = TxOpts_ Text
-
 let Field =
    {-
    General key-value type
@ -405,45 +402,9 @@ let EntryNumGetter =

    LookupN: lookup the value from a field
    ConstN: a constant value
-    AmountN: the value of the 'Amount' column times a scaling factor
-    BalanceN: the amount required to make the target account reach a balance
-    PercentN: the amount required to make an account reach a given percentage
+    AmountN: the value of the 'Amount' column
    -}
-      < LookupN : Text
-      | ConstN : Double
-      | AmountN : Double
-      | BalanceN : Double
-      | PercentN : Double
-      >
-
-let LinkedNumGetter =
-    {-
-    Means to get a numeric value from another entry
-    -}
-      { Type =
-          { lngIndex :
-              {-
-              Index of the entry to link.
-              -}
-              Natural
-          , lngScale :
-              {-
-              Factor by which to multiply the value of the linked entry.
-              -}
-              Double
-          }
-      , default = { lngScale = 1.0, lngIndex = 0 }
-      }
-
-let LinkedEntryNumGetter =
-    {-
-    Means to get a numeric value from a statement row or another entry getter.
-
-    Linked: a number referring to the entry on the 'from' side of the
-    transaction (with 0 being the primary entry)
-    Getter: a normal getter
-    -}
-      < Linked : LinkedNumGetter.Type | Getter : EntryNumGetter >
+      < LookupN : Text | ConstN : Double | AmountN : Double >

 let EntryTextGetter =
    {-
@ -482,6 +443,7 @@ let Entry =
    -}
      \(a : Type) ->
      \(v : Type) ->
+      \(c : Type) ->
      \(t : Type) ->
        { eAcnt :
            {-
@ -493,6 +455,11 @@ let Entry =
            Pertains to value for this entry.
            -}
            v
+        , eCurrency :
+            {-
+            Pertains to value for this entry.
+            -}
+            c
        , eComment :
            {-
            A short description of this entry (if none, use a blank string)
@ -507,107 +474,35 @@ let Entry =

 let EntryGetter =
    {-
-    Means for getting an entry from a given row in a statement (debit side)
-    -}
-      \(n : Type) ->
-        { Type = Entry EntryAcntGetter n TagID
-        , default = { eComment = "", eTags = [] : List TagID }
-        }
-
-let FromEntryGetter =
-    {-
-    Means for getting an entry from a given row in a statement (debit side)
-    -}
-      EntryGetter EntryNumGetter
-
-let ToEntryGetter =
-    {-
-    Means for getting an entry from a given row in a statement (credit side)
-    -}
-      EntryGetter LinkedEntryNumGetter
-
-let TxHalfGetter =
-    {-
-    Means of transforming one row in a statement to either the credit or debit
-    half of a transaction
-    -}
-      \(e : Type) ->
-        { Type =
-            { thgAcnt :
-                {-
-                Account from which this transaction will be balanced. The value
-                of the transaction will be assigned to this account unless
-                other entries are specified (see below).
-
-                This account (and its associated entry) will be denoted
-                'primary'.
-                -}
-                EntryAcntGetter
-            , thgEntries :
-                {-
-                Means of getting additional entries from which this transaction
-                will be balanced. If this list is empty, the total value of the
-                transaction will be assigned to the value defined by 'tsgAcnt'.
-                Otherwise, the entries specified here will be added to this side
-                of this transaction, and their sum value will be subtracted from
-                the total value of the transaction and assigned to 'tsgAcnt'.
-
-                This is useful for situations where a particular transaction
-                denotes values that come from multiple subaccounts.
-                -}
-                List e
-            , thgComment :
-                {-
-                Comment for the primary entry
-                -}
-                Text
-            , thgTags :
-                {-
-                Tags for the primary entry
-                -}
-                List TagID
-            }
-        , default =
-          { thgTags = [] : List TagID
-          , thgComment = ""
-          , thgEntries = [] : List e
-          }
-        }
-
-let FromTxHalfGetter = TxHalfGetter FromEntryGetter.Type
-
-let ToTxHalfGetter = TxHalfGetter ToEntryGetter.Type
-
-let TxSubGetter =
-    {-
-    A means for transforming one row in a statement to a transaction
+    Means for getting an entry from a given row in a statement
    -}
      { Type =
-          { tsgValue : EntryNumGetter
-          , tsgCurrency : EntryCurGetter
-          , tsgFrom : (TxHalfGetter FromEntryGetter.Type).Type
-          , tsgTo : (TxHalfGetter ToEntryGetter.Type).Type
-          }
-      , default = { tsgFrom = TxHalfGetter, tsgTo = TxHalfGetter }
+          Entry EntryAcntGetter (Optional EntryNumGetter) EntryCurGetter TagID
+      , default = { eValue = None EntryNumGetter, eComment = "" }
      }

 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.
    -}
-      { Type =
-          { tgFrom : (TxHalfGetter FromEntryGetter.Type).Type
-          , tgTo : (TxHalfGetter ToEntryGetter.Type).Type
-          , tgScale : Double
-          , tgCurrency : EntryCurGetter
-          , tgOtherEntries : List TxSubGetter.Type
-          }
-      , default =
-        { tgOtherEntries = [] : List TxSubGetter.Type
-        , tgFrom = TxHalfGetter
-        , tgTo = TxHalfGetter
-        , tgScale = 1.0
-        }
+      { 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 StatementParser_ =
@ -647,7 +542,7 @@ let StatementParser_ =
                a transaction. If none, don't make a transaction (eg 'skip'
                this row in the statement).
                -}
-                Optional TxGetter.Type
+                Optional TxGetter
            , spTimes :
                {-
                Match at most this many rows; if none there is no limit
@ -664,7 +559,7 @@ let StatementParser_ =
          , spVal = ValMatcher::{=}
          , spDesc = None Text
          , spOther = [] : List (FieldMatcher_ re)
-          , spTx = None TxGetter.Type
+          , spTx = None TxGetter
          , spTimes = None Natural
          , spPriority = +0
          }
@ -682,29 +577,7 @@ let Amount =
    -}
      \(w : Type) ->
      \(v : Type) ->
-        { Type =
-            { amtWhen : w, amtValue : v, amtDesc : Text, amtPriority : Integer }
-        , default.amtPriority = +0
-        }
-
-let TransferType =
-    {-
-    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
-    -}
-      < TPercent | TBalance | TFixed >
-
-let TransferValue =
-    {-
-    Means to determine the value of a budget transfer.
-    -}
-      { Type = { tvVal : Double, tvType : TransferType }
-      , default.tvType = TransferType.TFixed
-      }
+        { amtWhen : w, amtValue : v, amtDesc : Text }

 let Transfer =
    {-
@ -717,24 +590,14 @@ let Transfer =
        { transFrom : a
        , transTo : a
        , transCurrency : c
-        , transAmounts : List (Amount w v).Type
-        }
-
-let TaggedAcnt =
-    {-
-    An account with a tag
-    -}
-      { Type = { taAcnt : AcntID, taTags : List TagID }
-      , default.taTags = [] : List TagID
+        , transAmounts : List (Amount w v)
        }

 let HistTransfer =
    {-
    A manually specified historical transfer
    -}
-      Transfer TaggedAcnt.Type CurID DatePat TransferValue.Type
-
-let TransferAmount = Amount DatePat TransferValue.Type
+      Transfer AcntID CurID DatePat Double

 let Statement =
    {-
@ -771,6 +634,44 @@ let History =
    -}
      < HistTransfer : HistTransfer | HistStatement : Statement >

+let Exchange =
+    {-
+    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.
+          -}
+          Double
+      }
+
+let BudgetCurrency =
+    {-
+    A 'currency' in the budget; either a fixed currency or an exchange
+    -}
+      < NoX : CurID | X : Exchange >
+
+let TaggedAcnt =
+    {-
+    An account with a tag
+    -}
+      { taAcnt : AcntID, taTags : List TagID }
+
 let Allocation =
    {-
    How to allocate a given budget stream. This can be thought of as a Transfer
@ -778,7 +679,12 @@ let Allocation =
    -}
      \(w : Type) ->
      \(v : Type) ->
-        { alloTo : TaggedAcnt.Type, alloAmts : List (Amount w v).Type }
+        { alloTo : TaggedAcnt
+        , alloAmts : List (Amount w v)
+        , alloCur :
+            {-TODO allow exchanges here-}
+            CurID
+        }

 let PretaxValue =
    {-
@ -873,8 +779,6 @@ let SingleAllocation =
    -}
      Allocation {}

-let SingleAlloAmount = \(v : Type) -> Amount {} v
-
 let MultiAllocation =
    {-
    An allocation specialized to capturing multiple income streams within a given
@ -883,8 +787,6 @@ let MultiAllocation =
    -}
      Allocation Interval

-let MultiAlloAmount = \(v : Type) -> Amount Interval v
-
 let HourlyPeriod =
    {-
    Definition for a pay period denominated in hours
@ -967,20 +869,18 @@ let Income =
              This must be an income AcntID, and is the only place income
              accounts may be specified in the entire budget.
              -}
-              TaggedAcnt.Type
+              TaggedAcnt
          , incToBal :
              {-
              The account to which to send the remainder of the income stream
              (if any) after all allocations have been applied.
              -}
-              TaggedAcnt.Type
-          , incPriority : Integer
+              TaggedAcnt
          }
      , default =
        { incPretax = [] : List (SingleAllocation PretaxValue)
        , incTaxes = [] : List (SingleAllocation TaxValue)
        , incPosttaxx = [] : List (SingleAllocation PosttaxValue)
-        , incPriority = +0
        }
      }

@ -1037,6 +937,17 @@ let TransferMatcher =
        }
      }

+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 =
    {-
    A transaction analogous to another transfer with given properties.
@ -1045,17 +956,17 @@ let ShadowTransfer =
          {-
          Source of this transfer
          -}
-          TaggedAcnt.Type
+          TaggedAcnt
      , stTo :
          {-
          Destination of this transfer.
          -}
-          TaggedAcnt.Type
+          TaggedAcnt
      , stCurrency :
          {-
          Currency of this transfer.
          -}
-          CurID
+          BudgetCurrency
      , stDesc :
          {-
          Description of this transfer.
@ -1069,7 +980,7 @@ let ShadowTransfer =
          specified in other fields of this type.
          -}
          TransferMatcher.Type
-      , stType : TransferType
+      , stType : BudgetTransferType
      , stRatio :
          {-
          Fixed multipler to translate value of matched transfer to this one.
@ -1077,11 +988,17 @@ let ShadowTransfer =
          Double
      }

+let BudgetTransferValue =
+    {-
+    Means to determine the value of a budget transfer.
+    -}
+      { btVal : Double, btType : BudgetTransferType }
+
 let BudgetTransfer =
    {-
    A manually specified transaction for a budget
    -}
-      HistTransfer
+      Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue

 let Budget =
    {-
@ -1123,7 +1040,6 @@ in  { CurID
    , CronPat
    , DatePat
    , TxOpts
-    , TxOpts_
    , StatementParser
    , StatementParser_
    , ValMatcher
@ -1132,13 +1048,10 @@ in  { CurID
    , FieldMatcher
    , FieldMatcher_
    , EntryNumGetter
-    , LinkedEntryNumGetter
-    , LinkedNumGetter
    , Field
    , FieldMap
    , Entry
-    , FromEntryGetter
-    , ToEntryGetter
+    , EntryGetter
    , EntryTextGetter
    , EntryCurGetter
    , EntryAcntGetter
@ -1152,8 +1065,9 @@ in  { CurID
    , TransferMatcher
    , ShadowTransfer
    , AcntSet
+    , BudgetCurrency
+    , Exchange
    , TaggedAcnt
-    , AccountTree
    , Account
    , Placeholder
    , PretaxValue
@ -1162,20 +1076,13 @@ in  { CurID
    , TaxProgression
    , TaxMethod
    , TaxValue
-    , TransferValue
-    , TransferType
+    , BudgetTransferValue
+    , BudgetTransferType
    , TxGetter
-    , TxSubGetter
-    , TxHalfGetter
-    , FromTxHalfGetter
-    , ToTxHalfGetter
    , HistTransfer
    , SingleAllocation
    , MultiAllocation
    , HourlyPeriod
    , Period
    , PeriodType
-    , TransferAmount
-    , MultiAlloAmount
-    , SingleAlloAmount
    }
--- a/dhall/common.dhall
+++ b/dhall/common.dhall
@ -4,10 +4,18 @@ let List/map =

 let T = ./Types.dhall

-let nullEntry =
+let nullSplit =
      \(a : T.EntryAcntGetter) ->
-      \(v : T.EntryNumGetter) ->
-        T.FromEntryGetter::{ eAcnt = a, eValue = v }
+      \(c : T.EntryCurGetter) ->
+        T.EntryGetter::{ eAcnt = a, eCurrency = c, eTags = [] : List T.TagID }
+
+let nullOpts = T.TxOpts::{=}
+
+let nullVal = T.ValMatcher::{=}
+
+let nullMatch = T.StatementParser::{=}
+
+let nullCron = T.CronPat::{=}

 let nullMod =
      \(by : Natural) ->
@ -19,22 +27,21 @@ let cron1 =
      \(m : Natural) ->
      \(d : Natural) ->
        T.DatePat.Cron
-          T.CronPat::{
-          , cpYear = Some (T.MDYPat.Single y)
+          (     nullCron
+            //  { cpYear = Some (T.MDYPat.Single y)
                , cpMonth = Some (T.MDYPat.Single m)
                , cpDay = Some (T.MDYPat.Single d)
                }
+          )

-let matchInf_ = T.StatementParser::{=}
+let matchInf_ = nullMatch

-let matchInf = \(x : T.TxGetter.Type) -> T.StatementParser::{ spTx = Some x }
+let matchInf = \(x : T.TxGetter) -> nullMatch // { spTx = Some x }

-let matchN_ = \(n : Natural) -> T.StatementParser::{ spTimes = Some n }
+let matchN_ = \(n : Natural) -> nullMatch // { spTimes = Some n }

 let matchN =
-      \(n : Natural) ->
-      \(x : T.TxGetter.Type) ->
-        matchInf x // { spTimes = Some n }
+      \(n : Natural) -> \(x : T.TxGetter) -> matchInf x // { spTimes = Some n }

 let match1_ = matchN_ 1

@ -79,45 +86,46 @@ let mRngYMD =
      \(r : Natural) ->
        T.DateMatcher.In { _1 = T.YMDMatcher.YMD (greg y m d), _2 = r }

-let PartEntry = { _1 : T.AcntID, _2 : Double, _3 : Text }
+let PartSplit = { _1 : T.AcntID, _2 : Double, _3 : Text }

-let partNFrom =
-      \(ss : List PartEntry) ->
-        let toEntry =
-              \(x : PartEntry) ->
-                T.FromEntryGetter::{
-                , eAcnt = T.EntryAcntGetter.ConstT x._1
-                , eValue = T.EntryNumGetter.ConstN x._2
+let partN =
+      \(c : T.EntryCurGetter) ->
+      \(a : T.EntryAcntGetter) ->
+      \(comment : Text) ->
+      \(ss : List PartSplit) ->
+        let toSplit =
+              \(x : PartSplit) ->
+                    nullSplit (T.EntryAcntGetter.ConstT x._1) c
+                //  { eValue = Some (T.EntryNumGetter.ConstN x._2)
                    , eComment = x._3
                    }

-        in  List/map PartEntry T.FromEntryGetter.Type toEntry ss
+        in    [ nullSplit a c // { eComment = comment } ]
+            # List/map PartSplit T.EntryGetter.Type toSplit ss

-let partNTo =
-      \(ss : List PartEntry) ->
-        let toEntry =
-              \(x : PartEntry) ->
-                T.ToEntryGetter::{
-                , eAcnt = T.EntryAcntGetter.ConstT x._1
-                , eValue =
-                    T.LinkedEntryNumGetter.Getter (T.EntryNumGetter.ConstN x._2)
-                , eComment = x._3
-                }
+let part1 =
+      \(c : T.EntryCurGetter) ->
+      \(a : T.EntryAcntGetter) ->
+      \(comment : Text) ->
+        partN c a comment ([] : List PartSplit)

-        in  List/map PartEntry T.ToEntryGetter.Type toEntry ss
+let part1_ =
+      \(c : T.EntryCurGetter) ->
+      \(a : T.EntryAcntGetter) ->
+        partN c a "" ([] : List PartSplit)

 let addDay =
      \(x : T.GregorianM) ->
      \(d : Natural) ->
        { gYear = x.gmYear, gMonth = x.gmMonth, gDay = d }

-let mvP = T.ValMatcher::{ vmSign = Some True }
+let mvP = nullVal // { vmSign = Some True }

-let mvN = T.ValMatcher::{ vmSign = Some False }
+let mvN = nullVal // { vmSign = Some False }

-let mvNum = \(x : Natural) -> T.ValMatcher::{ vmNum = Some x }
+let mvNum = \(x : Natural) -> nullVal // { vmNum = Some x }

-let mvDen = \(x : Natural) -> T.ValMatcher::{ vmDen = Some x }
+let mvDen = \(x : Natural) -> nullVal // { vmDen = Some x }

 let mvNumP = \(x : Natural) -> mvP // { vmNum = Some x }

@ -127,7 +135,13 @@ let mvDenP = \(x : Natural) -> mvP // { vmDen = Some x }

 let mvDenN = \(x : Natural) -> mvN // { vmDen = Some x }

-in      { cron1
+in      { nullSplit
+        , nullMatch
+        , nullVal
+        , nullOpts
+        , nullCron
+        , nullMod
+        , cron1
        , mY
        , mYM
        , mYMD
@ -142,8 +156,9 @@ in      { cron1
        , match1
        , greg
        , gregM
-        , partNFrom
-        , partNTo
+        , partN
+        , part1
+        , part1_
        , addDay
        , comma = 44
        , tab = 9
@ -155,8 +170,6 @@ in      { cron1
        , mvDen
        , mvDenP
        , mvDenN
-        , PartEntry
-        , nullEntry
-        , nullMod
+        , PartSplit
        }
    /\  T
--- a/lib/Internal/Budget.hs
+++ b/lib/Internal/Budget.hs
@ -1,9 +1,9 @@
-module Internal.Budget (readBudget) where
+module Internal.Budget (insertBudget) where

 import Control.Monad.Except
-import Data.Decimal hiding (allocate)
 import Data.Foldable
-import Data.Hashable
+import Database.Persist.Monad
+import Internal.Database
 import Internal.Types.Main
 import Internal.Utils
 import RIO hiding (to)
@ -13,8 +13,22 @@ import qualified RIO.NonEmpty as NE
 import qualified RIO.Text as T
 import RIO.Time

-readBudget :: (MonadAppError m, MonadFinance m) => Budget -> m [Tx CommitR]
-readBudget
+-- each budget (designated at the top level by a 'name') is processed in the
+-- following steps
+-- 1. expand all transactions given the desired date range and date patterns for
+--    each directive in the budget
+-- 2. sort all transactions by date
+-- 3. propagate all balances forward, and while doing so assign values to each
+--    transaction (some of which depend on the 'current' balance of the
+--    target account)
+-- 4. assign shadow transactions
+-- 5. insert all transactions
+
+insertBudget
+  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
+  => Budget
+  -> m ()
+insertBudget
  b@Budget
    { bgtLabel
    , bgtIncomes
@ -25,19 +39,15 @@ readBudget
    , bgtPosttax
    , bgtInterval
    } =
-    do
-      spanRes <- getSpan
-      case spanRes of
-        Nothing -> return []
-        Just budgetSpan -> do
+    whenHash CTBudget b () $ \key -> do
      (intAllos, _) <- combineError intAlloRes acntRes (,)
-          let res1 = mapErrors (readIncome c bgtLabel intAllos budgetSpan) bgtIncomes
-          let res2 = expandTransfers c bgtLabel budgetSpan bgtTransfers
+      let res1 = mapErrors (insertIncome key bgtLabel intAllos bgtInterval) bgtIncomes
+      let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers
      txs <- combineError (concat <$> res1) res2 (++)
-          shadow <- addShadowTransfers bgtShadowTransfers txs
-          return $ txs ++ shadow
+      m <- askDBState kmCurrency
+      shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs
+      void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow
    where
-      c = CommitR (CommitHash $ hash b) CTBudget
      acntRes = mapErrors isNotIncomeAcnt alloAcnts
      intAlloRes = combineError3 pre_ tax_ post_ (,,)
      pre_ = sortAllos bgtPretax
@ -48,15 +58,73 @@ readBudget
        (alloAcnt <$> bgtPretax)
          ++ (alloAcnt <$> bgtTax)
          ++ (alloAcnt <$> bgtPosttax)
-      getSpan = do
-        globalSpan <- asks (unBSpan . csBudgetScope)
-        case bgtInterval of
-          Nothing -> return $ Just globalSpan
-          Just bi -> do
-            localSpan <- liftExcept $ resolveDaySpan bi
-            return $ intersectDaySpan globalSpan localSpan

-sortAllo :: MultiAllocation v -> AppExcept (DaySpanAllocation v)
+balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
+balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
+  where
+    go bals f@FlatTransfer {ftFrom, ftTo, ftValue = UnbalancedValue {cvValue, cvType}} =
+      let balTo = M.findWithDefault 0 ftTo bals
+          x = amtToMove balTo cvType cvValue
+          bals' = mapAdd_ ftTo x $ mapAdd_ ftFrom (-x) bals
+       in (bals', f {ftValue = 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 _ BTFixed x = x
+    amtToMove bal BTPercent x = -(x / 100 * bal)
+    amtToMove bal BTTarget x = x - bal
+
+-- TODO this seems too general for this module
+mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
+mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k
+
+insertBudgetTx
+  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
+  => BalancedTransfer
+  -> m ()
+insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do
+  ((sFrom, sTo), exchange) <- entryPair ftFrom ftTo ftCur ftValue
+  insertPair sFrom sTo
+  forM_ exchange $ uncurry insertPair
+  where
+    insertPair from to = do
+      k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc
+      insertBudgetLabel k from
+      insertBudgetLabel k to
+    insertBudgetLabel k entry = do
+      sk <- insertEntry k entry
+      insert_ $ BudgetLabelR sk $ bmName ftMeta
+
+entryPair
+  :: (MonadInsertError m, MonadFinance m)
+  => TaggedAcnt
+  -> TaggedAcnt
+  -> BudgetCurrency
+  -> Rational
+  -> m (EntryPair, Maybe EntryPair)
+entryPair from to cur val = case cur of
+  NoX curid -> (,Nothing) <$> pair curid from to val
+  X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do
+    let middle = TaggedAcnt xAcnt []
+    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
+      let s1 = entry curid from_ (-v)
+      let s2 = entry curid to_ v
+      combineError s1 s2 (,)
+    entry c TaggedAcnt {taAcnt, taTags} v =
+      resolveEntry $
+        Entry
+          { eAcnt = taAcnt
+          , eValue = v
+          , eComment = ""
+          , eCurrency = c
+          , eTags = taTags
+          }
+
+sortAllo :: MultiAllocation v -> InsertExcept (DaySpanAllocation v)
 sortAllo a@Allocation {alloAmts = as} = do
  bs <- foldSpan [] $ L.sortOn amtWhen as
  return $ a {alloAmts = reverse bs}
@ -75,107 +143,100 @@ sortAllo a@Allocation {alloAmts = as} = do
 -- 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 :(
-readIncome
-  :: (MonadAppError m, MonadFinance m)
-  => CommitR
-  -> BudgetName
+insertIncome
+  :: (MonadInsertError m, MonadFinance m)
+  => CommitRId
+  -> T.Text
  -> IntAllocations
-  -> DaySpan
+  -> Maybe Interval
  -> Income
-  -> m [Tx CommitR]
-readIncome
+  -> m [UnbalancedTransfer]
+insertIncome
  key
  name
  (intPre, intTax, intPost)
-  ds
+  localInterval
  Income
    { incWhen
    , incCurrency
-    , incFrom = TaggedAcnt {taAcnt = srcAcnt, taTags = srcTags}
+    , incFrom
    , incPretax
    , incPosttax
    , incTaxes
-    , incToBal = TaggedAcnt {taAcnt = destAcnt, taTags = destTags}
+    , incToBal
    , incGross
    , incPayPeriod
-    , incPriority
    } =
    combineErrorM
      (combineError incRes nonIncRes (,))
-      (combineError cpRes dayRes (,))
-      $ \_ (cp, days) -> do
-        let gross = realFracToDecimalP (cpPrec cp) incGross
-        foldDays (allocate cp gross) start days
+      (combineError precRes dayRes (,))
+      $ \_ (precision, days) -> do
+        let gross = roundPrecision precision incGross
+        concat <$> foldDays (allocate precision gross) start days
    where
-      srcAcnt' = AcntID srcAcnt
-      destAcnt' = AcntID destAcnt
-      incRes = isIncomeAcnt srcAcnt'
+      incRes = isIncomeAcnt $ taAcnt incFrom
      nonIncRes =
        mapErrors isNotIncomeAcnt $
-          destAcnt'
+          taAcnt incToBal
            : (alloAcnt <$> incPretax)
            ++ (alloAcnt <$> incTaxes)
            ++ (alloAcnt <$> incPosttax)
-      cpRes = lookupCurrency incCurrency
-      dayRes = liftExcept $ expandDatePat ds incWhen
+      precRes = lookupCurrencyPrec incCurrency
+      dayRes = askDays incWhen localInterval
      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
-      entry0 a c ts = Entry {eAcnt = a, eValue = (), eComment = c, eTags = ts}
-      allocate cp gross prevDay day = do
+      -- TODO ensure these are all the "correct" accounts
+      allocate precision gross prevDay day = do
        scaler <- liftExcept $ periodScaler pType' prevDay day
-        let precision = cpPrec cp
        let (preDeductions, pre) =
              allocatePre precision gross $
                flatPre ++ concatMap (selectAllos day) intPre
-        let tax =
+            tax =
              allocateTax precision gross preDeductions scaler $
                flatTax ++ concatMap (selectAllos day) intTax
            aftertaxGross = gross - sumAllos (tax ++ pre)
-        let post =
+            post =
              allocatePost precision aftertaxGross $
                flatPost ++ concatMap (selectAllos day) intPost
-        let src = entry0 srcAcnt' "gross income" (TagID <$> srcTags)
-        let dest = entry0 destAcnt' "balance after deductions" (TagID <$> destTags)
-        let allos = allo2Trans <$> (pre ++ tax ++ post)
-        let primary =
-              EntrySet
-                { esTotalValue = gross
-                , esCurrency = cpID cp
-                , esFrom = HalfEntrySet {hesPrimary = src, hesOther = []}
-                , esTo = HalfEntrySet {hesPrimary = dest, hesOther = allos}
-                }
-        return $
-          Tx
-            { txCommit = key
-            , txDate = day
-            , txPrimary = Left primary
-            , txOther = []
-            , txDescr = TxDesc ""
-            , txBudget = name
-            , txPriority = incPriority
+            balance = aftertaxGross - sumAllos post
+            bal =
+              FlatTransfer
+                { ftMeta = meta
+                , ftWhen = day
+                , ftFrom = incFrom
+                , ftCur = NoX incCurrency
+                , ftTo = incToBal
+                , ftValue = UnbalancedValue BTFixed balance
+                , ftDesc = "balance after deductions"
                }
+         in if balance < 0
+              then throwError $ InsertException [IncomeError day name balance]
+              else return (bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post))

 periodScaler
  :: PeriodType
  -> Day
  -> Day
-  -> AppExcept PeriodScaler
+  -> InsertExcept PeriodScaler
 periodScaler pt prev cur = return scale
  where
-    n = workingDays wds prev cur
+    n = fromIntegral $ workingDays wds prev cur
    wds = case pt of
      Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays
      Daily ds -> ds
-    scale prec x = case pt of
+    scale precision x = case pt of
      Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
-        realFracToDecimalP prec (x / fromIntegral hpAnnualHours)
+        fromRational (rnd $ x / fromIntegral hpAnnualHours)
          * fromIntegral hpDailyHours
-          * fromIntegral n
-      Daily _ -> realFracToDecimalP prec (x * fromIntegral n / 365.25)
+          * n
+      Daily _ -> x * n / 365.25
+      where
+        rnd = roundPrecision precision

 -- ASSUME start < end
 workingDays :: [Weekday] -> Day -> Day -> Natural
@ -191,7 +252,7 @@ workingDays wds start end = fromIntegral $ daysFull + daysTail

 -- ASSUME days is a sorted list
 foldDays
-  :: MonadAppError m
+  :: MonadInsertError m
  => (Day -> Day -> m a)
  -> Day
  -> [Day]
@ -201,27 +262,27 @@ foldDays f start days = case NE.nonEmpty days of
  Just ds
    | any (start >) ds ->
        throwError $
-          AppException [PeriodError start $ minimum ds]
+          InsertException [PeriodError start $ minimum ds]
    | otherwise ->
        combineErrors $
          snd $
            L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days

-isIncomeAcnt :: (MonadAppError m, MonadFinance m) => AcntID -> m ()
+isIncomeAcnt :: (MonadInsertError m, MonadFinance m) => AcntID -> m ()
 isIncomeAcnt = checkAcntType IncomeT

-isNotIncomeAcnt :: (MonadAppError m, MonadFinance m) => AcntID -> m ()
+isNotIncomeAcnt :: (MonadInsertError m, MonadFinance m) => AcntID -> m ()
 isNotIncomeAcnt = checkAcntTypes (AssetT :| [EquityT, ExpenseT, LiabilityT])

 checkAcntType
-  :: (MonadAppError m, MonadFinance m)
+  :: (MonadInsertError m, MonadFinance m)
  => AcntType
  -> AcntID
  -> m ()
 checkAcntType t = checkAcntTypes (t :| [])

 checkAcntTypes
-  :: (MonadAppError m, MonadFinance m)
+  :: (MonadInsertError m, MonadFinance m)
  => NE.NonEmpty AcntType
  -> AcntID
  -> m ()
@ -229,70 +290,83 @@ checkAcntTypes ts i = void $ go =<< lookupAccountType i
  where
    go t
      | t `L.elem` ts = return i
-      | otherwise = throwError $ AppException [AccountTypeError i ts]
+      | otherwise = throwError $ InsertException [AccountError i ts]

 flattenAllo :: SingleAllocation v -> [FlatAllocation v]
-flattenAllo Allocation {alloAmts, alloTo} = fmap go alloAmts
+flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
  where
    go Amount {amtValue, amtDesc} =
      FlatAllocation
-        { faTo = alloTo
+        { faCur = NoX alloCur
+        , faTo = alloTo
        , faValue = amtValue
        , faDesc = amtDesc
        }

 -- ASSUME allocations are sorted
 selectAllos :: Day -> DaySpanAllocation v -> [FlatAllocation v]
-selectAllos day Allocation {alloAmts, alloTo} =
+selectAllos day Allocation {alloAmts, alloCur, alloTo} =
  go <$> filter ((`inDaySpan` day) . amtWhen) alloAmts
  where
    go Amount {amtValue, amtDesc} =
      FlatAllocation
-        { faTo = alloTo
+        { faCur = NoX alloCur
+        , faTo = alloTo
        , faValue = amtValue
        , faDesc = amtDesc
        }

-allo2Trans :: FlatAllocation Decimal -> Entry AcntID EntryLink TagID
-allo2Trans FlatAllocation {faValue, faTo = TaggedAcnt {taAcnt, taTags}, faDesc} =
-  Entry
-    { eValue = LinkValue (EntryFixed faValue)
-    , eComment = faDesc
-    , eAcnt = AcntID taAcnt
-    , eTags = TagID <$> taTags
+allo2Trans
+  :: BudgetMeta
+  -> Day
+  -> TaggedAcnt
+  -> FlatAllocation Rational
+  -> UnbalancedTransfer
+allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} =
+  FlatTransfer
+    { ftMeta = meta
+    , ftWhen = day
+    , ftFrom = from
+    , ftCur = faCur
+    , ftTo = faTo
+    , ftValue = UnbalancedValue BTFixed faValue
+    , ftDesc = faDesc
    }

-type PreDeductions = M.Map T.Text Decimal
-
 allocatePre
-  :: Precision
-  -> Decimal
+  :: Natural
+  -> Rational
  -> [FlatAllocation PretaxValue]
-  -> (PreDeductions, [FlatAllocation Decimal])
+  -> (M.Map T.Text Rational, [FlatAllocation Rational])
 allocatePre precision gross = L.mapAccumR go M.empty
  where
-    go m f@FlatAllocation {faValue = PretaxValue {preCategory, preValue, prePercent}} =
-      let v =
-            if prePercent
-              then gross *. (preValue / 100)
-              else realFracToDecimalP precision preValue
-       in (mapAdd_ preCategory v m, f {faValue = v})
+    go m f@FlatAllocation {faValue} =
+      let c = preCategory faValue
+          p = preValue faValue
+          v =
+            if prePercent faValue
+              then (roundPrecision 3 p / 100) * gross
+              else roundPrecision precision p
+       in (mapAdd_ c v m, f {faValue = v})

 allocateTax
-  :: Precision
-  -> Decimal
-  -> PreDeductions
+  :: Natural
+  -> Rational
+  -> M.Map T.Text Rational
  -> PeriodScaler
  -> [FlatAllocation TaxValue]
-  -> [FlatAllocation Decimal]
+  -> [FlatAllocation Rational]
 allocateTax precision gross preDeds f = fmap (fmap go)
  where
    go TaxValue {tvCategories, tvMethod} =
      let agi = gross - sum (mapMaybe (`M.lookup` preDeds) tvCategories)
       in case tvMethod of
-            TMPercent p -> agi *. p / 100
+            TMPercent p ->
+              roundPrecision precision $
+                fromRational $
+                  roundPrecision 3 p / 100 * agi
            TMBracket TaxProgression {tpDeductible, tpBrackets} ->
-              let taxDed = f precision tpDeductible
+              let taxDed = roundPrecision precision $ f precision tpDeductible
               in foldBracket f precision (agi - taxDed) tpBrackets

 -- | Compute effective tax percentage of a bracket
@ -306,80 +380,174 @@ allocateTax precision gross preDeds f = fmap (fmap go)
 --
 -- In reality, this can all be done with one loop, but it isn't clear these
 -- three steps are implemented from this alone.
-foldBracket :: PeriodScaler -> Precision -> Decimal -> [TaxBracket] -> Decimal
-foldBracket f prec 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} a@(acc, remain) =
-      let l = f prec tbLowerLimit
-       in if remain >= l
-            then (acc + (remain - l) *. (tbPercent / 100), l)
-            else a
+      let l = roundPrecision precision $ f precision tbLowerLimit
+          p = roundPrecision 3 tbPercent / 100
+       in if remain >= l then (acc + p * (remain - l), l) else a

 allocatePost
-  :: Precision
-  -> Decimal
+  :: Natural
+  -> Rational
  -> [FlatAllocation PosttaxValue]
-  -> [FlatAllocation Decimal]
-allocatePost prec aftertax = fmap (fmap go)
+  -> [FlatAllocation Rational]
+allocatePost precision aftertax = fmap (fmap go)
  where
-    go PosttaxValue {postValue, postPercent}
-      | postPercent = aftertax *. (postValue / 100)
-      | otherwise = realFracToDecimalP prec postValue
+    go PosttaxValue {postValue, postPercent} =
+      let v = postValue
+       in if postPercent
+            then aftertax * roundPrecision 3 v / 100
+            else roundPrecision precision v
+
+--------------------------------------------------------------------------------
+-- Standalone Transfer
+
+expandTransfers
+  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
+  => CommitRId
+  -> T.Text
+  -> Maybe Interval
+  -> [BudgetTransfer]
+  -> m [UnbalancedTransfer]
+expandTransfers key name localInterval ts = do
+  txs <-
+    fmap (L.sortOn ftWhen . concat) $
+      combineErrors $
+        fmap (expandTransfer key name) ts
+  case localInterval of
+    Nothing -> return txs
+    Just i -> do
+      bounds <- liftExcept $ resolveDaySpan i
+      return $ filter (inDaySpan bounds . ftWhen) txs
+
+expandTransfer
+  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
+  => CommitRId
+  -> T.Text
+  -> BudgetTransfer
+  -> m [UnbalancedTransfer]
+expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do
+  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
+              { ftMeta = meta
+              , ftWhen = day
+              , ftCur = transCurrency
+              , ftFrom = transFrom
+              , ftTo = transTo
+              , ftValue = UnbalancedValue y $ roundPrecision precision v
+              , ftDesc = desc
+              }
+
+withDates
+  :: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
+  => DatePat
+  -> (Day -> m a)
+  -> m [a]
+withDates dp f = do
+  bounds <- askDBState kmBudgetInterval
+  days <- liftExcept $ expandDatePat bounds dp
+  combineErrors $ fmap f days

 --------------------------------------------------------------------------------
 -- shadow transfers

 -- TODO this is going to be O(n*m), which might be a problem?
 addShadowTransfers
-  :: (MonadAppError m, MonadFinance m)
-  => [ShadowTransfer]
-  -> [Tx CommitR]
-  -> m [Tx CommitR]
-addShadowTransfers ms = mapErrors go
-  where
-    go tx = do
-      es <- catMaybes <$> mapErrors (fromShadow tx) ms
-      return $ tx {txOther = Right <$> es}
+  :: CurrencyMap
+  -> [ShadowTransfer]
+  -> [UnbalancedTransfer]
+  -> InsertExcept [UnbalancedTransfer]
+addShadowTransfers cm ms txs =
+  fmap catMaybes $
+    combineErrors $
+      fmap (uncurry (fromShadow cm)) $
+        [(t, m) | t <- txs, m <- ms]

 fromShadow
-  :: (MonadAppError m, MonadFinance m)
-  => Tx CommitR
+  :: CurrencyMap
+  -> UnbalancedTransfer
  -> ShadowTransfer
-  -> m (Maybe ShadowEntrySet)
-fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} =
-  combineErrorM curRes shaRes $ \cur sha -> do
-    let es = entryPair stFrom stTo cur stDesc stRatio ()
-    return $ if not sha then Nothing else Just es
-  where
-    curRes = lookupCurrencyKey (CurID stCurrency)
-    shaRes = liftExcept $ shadowMatches stMatch tx
-
-shadowMatches :: TransferMatcher -> Tx CommitR -> AppExcept Bool
-shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} Tx {txPrimary, txDate} = do
-  -- NOTE this will only match against the primary entry set since those
-  -- are what are guaranteed to exist from a transfer
-  valRes <- case txPrimary of
-    Left es -> valMatches tmVal $ toRational $ esTotalValue es
-    Right _ -> return True
+  -> 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
  return $
-    memberMaybe fa tmFrom
-      && memberMaybe ta tmTo
-      && maybe True (`dateMatches` txDate) tmDate
+    if not res
+      then Nothing
+      else
+        Just $
+          FlatTransfer
+            { ftMeta = ftMeta tx
+            , ftWhen = ftWhen tx
+            , ftCur = stCurrency
+            , ftFrom = stFrom
+            , ftTo = stTo
+            , ftValue = UnbalancedValue stType $ v * cvValue (ftValue tx)
+            , ftDesc = stDesc
+            }
+
+shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool
+shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
+  valRes <- valMatches tmVal $ cvValue $ ftValue tx
+  return $
+    memberMaybe (taAcnt $ ftFrom tx) tmFrom
+      && memberMaybe (taAcnt $ ftTo tx) tmTo
+      && maybe True (`dateMatches` ftWhen tx) tmDate
      && valRes
  where
-    fa = either getAcntFrom getAcntFrom txPrimary
-    ta = either getAcntTo getAcntTo txPrimary
-    getAcntFrom = getAcnt esFrom
-    getAcntTo = getAcnt esTo
-    getAcnt f = eAcnt . hesPrimary . f
    memberMaybe x AcntSet {asList, asInclude} =
-      (if asInclude then id else not) $ x `elem` (AcntID <$> asList)
+      (if asInclude then id else not) $ x `elem` asList

 --------------------------------------------------------------------------------
 -- random

+initialCurrency :: BudgetCurrency -> CurID
+initialCurrency (NoX c) = c
+initialCurrency (X Exchange {xFromCur = c}) = c
+
 alloAcnt :: Allocation w v -> AcntID
-alloAcnt = AcntID . taAcnt . alloTo
+alloAcnt = taAcnt . alloTo
+
+data UnbalancedValue = UnbalancedValue
+  { cvType :: !BudgetTransferType
+  , cvValue :: !Rational
+  }
+  deriving (Show)
+
+type UnbalancedTransfer = FlatTransfer UnbalancedValue
+
+type BalancedTransfer = FlatTransfer Rational
+
+data FlatTransfer v = FlatTransfer
+  { ftFrom :: !TaggedAcnt
+  , ftTo :: !TaggedAcnt
+  , ftValue :: !v
+  , ftWhen :: !Day
+  , ftDesc :: !T.Text
+  , ftMeta :: !BudgetMeta
+  , ftCur :: !BudgetCurrency
+  }
+  deriving (Show)
+
+data BudgetMeta = BudgetMeta
+  { bmCommit :: !CommitRId
+  , bmName :: !T.Text
+  }
+  deriving (Show)

 type IntAllocations =
  ( [DaySpanAllocation PretaxValue]
@ -389,11 +557,14 @@ type IntAllocations =

 type DaySpanAllocation = Allocation DaySpan

-type PeriodScaler = Precision -> Double -> Decimal
+type EntryPair = (KeyEntry, KeyEntry)
+
+type PeriodScaler = Natural -> Double -> Double

 data FlatAllocation v = FlatAllocation
  { faValue :: !v
  , faDesc :: !T.Text
  , faTo :: !TaggedAcnt
+  , faCur :: !BudgetCurrency
  }
  deriving (Functor, Show)
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@ -1,38 +1,35 @@
 module Internal.Database
  ( runDB
-  , readConfigState
  , nukeTables
+  , updateHashes
  , updateDBState
+  , getDBState
  , tree2Records
  , flattenAcntRoot
-  , indexAcntRoot
  , paths2IDs
  , mkPool
+  , whenHash
+  , whenHash_
  , insertEntry
-  , readUpdates
-  , insertAll
-  , updateTx
+  , resolveEntry
  )
 where

 import Conduit
 import Control.Monad.Except
 import Control.Monad.Logger
-import Data.Decimal
 import Data.Hashable
-import Database.Esqueleto.Experimental ((:&) (..), (==.), (?.), (^.))
+import Database.Esqueleto.Experimental ((==.), (^.))
 import qualified Database.Esqueleto.Experimental as E
 import Database.Esqueleto.Internal.Internal (SqlSelect)
 import Database.Persist.Monad
 import Database.Persist.Sqlite hiding
-  ( Statement
-  , delete
+  ( delete
  , deleteWhere
  , insert
  , insertKey
  , insert_
  , runMigration
-  , update
  , (==.)
  , (||.)
  )
@ -40,10 +37,10 @@ import GHC.Err
 import Internal.Types.Main
 import Internal.Utils
 import RIO hiding (LogFunc, isNothing, on, (^.))
+import RIO.List ((\\))
 import qualified RIO.List as L
 import qualified RIO.Map as M
-import qualified RIO.NonEmpty as NE
-import qualified RIO.Set as S
+import qualified RIO.NonEmpty as N
 import qualified RIO.Text as T

 runDB
@ -106,236 +103,132 @@ nukeTables = do
 --     toFullPath path name = T.unwords [unValue @T.Text path, "/", unValue @T.Text name]
 --     toBal = maybe "???" (fmtRational 2) . unValue

-readConfigState
-  :: (MonadAppError m, MonadSqlQuery m)
-  => Config
-  -> [Budget]
-  -> [History]
-  -> m ConfigState
-readConfigState c bs hs = do
-  (acnts2Ins, acntsRem, acnts2Del) <- diff newAcnts
-  (pathsIns, _, pathsDel) <- diff newPaths
-  (curs2Ins, cursRem, curs2Del) <- diff newCurs
-  (tags2Ins, tagsRem, tags2Del) <- diff newTags
-  let amap = makeAcntMap $ acnts2Ins ++ (fst <$> acntsRem)
-  let cmap = currencyMap $ curs2Ins ++ (fst <$> cursRem)
-  let tmap = makeTagMap $ tags2Ins ++ (fst <$> tagsRem)
-  let fromMap f = S.fromList . fmap f . M.elems
-  let existing =
-        ExistingConfig (fromMap fst amap) (fromMap id tmap) (fromMap cpID cmap)
-
-  (curBgts, curHistTrs, curHistSts) <- readCurrentCommits
-  -- TODO refine this test to include the whole db (with data already mixed
-  -- in this algorithm)
-  let bsRes = BudgetSpan <$> resolveScope budgetInterval
-  let hsRes = HistorySpan <$> resolveScope statementInterval
-  combineErrorM bsRes hsRes $ \bscope hscope -> do
-    let dbempty = null $ curBgts ++ curHistTrs ++ curHistSts
-    (bChanged, hChanged) <- readScopeChanged dbempty bscope hscope
-    bgt <- makeTxCRUD existing bs curBgts bChanged
-    hTrans <- makeTxCRUD existing ts curHistTrs hChanged
-    hStmt <- makeTxCRUD existing ss curHistSts hChanged
-
-    return $
-      ConfigState
-        { csCurrencies = CRUDOps curs2Ins () () curs2Del
-        , csTags = CRUDOps tags2Ins () () tags2Del
-        , csAccounts = CRUDOps acnts2Ins () () acnts2Del
-        , csPaths = CRUDOps pathsIns () () pathsDel
-        , csBudgets = bgt
-        , csHistTrans = hTrans
-        , csHistStmts = hStmt
-        , csAccountMap = amap
-        , csCurrencyMap = cmap
-        , csTagMap = tmap
-        , csBudgetScope = bscope
-        , csHistoryScope = hscope
-        }
-  where
-    (ts, ss) = splitHistory hs
-    diff new = setDiffWith (\a b -> E.entityKey a == b) new <$> readCurrentIds
-    (newAcnts, newPaths) = indexAcntRoot $ accounts c
-    newTags = tag2Record <$> tags c
-    newCurs = currency2Record <$> currencies c
-    resolveScope f = liftExcept $ resolveDaySpan $ f $ scope c
-
-readScopeChanged
-  :: (MonadAppError m, MonadSqlQuery m)
-  => Bool
-  -> BudgetSpan
-  -> HistorySpan
-  -> m (Bool, Bool)
-readScopeChanged dbempty bscope hscope = do
-  rs <- dumpTbl
-  -- TODO these errors should only fire when someone messed with the DB
-  case rs of
-    [] -> if dbempty then return (True, True) else throwAppError $ DBError DBShouldBeEmpty
-    [r] -> do
-      let (ConfigStateR h b) = E.entityVal r
-      return (bscope /= b, hscope /= h)
-    _ -> throwAppError $ DBError DBMultiScope
-
-makeTxCRUD
-  :: (MonadAppError m, MonadSqlQuery m, Hashable a)
-  => ExistingConfig
-  -> [a]
-  -> [CommitHash]
-  -> Bool
-  -> m
-      ( CRUDOps
-          [a]
-          [ReadEntry]
-          [Either TotalUpdateEntrySet FullUpdateEntrySet]
-          DeleteTxs
-      )
-makeTxCRUD existing newThings curThings scopeChanged = do
-  let (toDelHashes, overlap, toIns) =
-        setDiffWith (\a b -> hash b == unCommitHash a) curThings newThings
-  -- Check the overlap for rows with accounts/tags/currencies that
-  -- won't exist on the next update. Those with invalid IDs will be set aside
-  -- to delete and reinsert (which may also fail) later
-  (noRetry, toInsRetry) <- readInvalidIds existing overlap
-  let (toDelAllHashes, toInsAll) = bimap (toDelHashes ++) (toIns ++) $ L.unzip toInsRetry
-  -- If we are inserting or deleting something or the scope changed, pull out
-  -- the remainder of the entries to update/read as we are (re)inserting other
-  -- stuff (this is necessary because a given transaction may depend on the
-  -- value of previous transactions, even if they are already in the DB).
-  (toRead, toUpdate) <- case (toInsAll, toDelAllHashes, scopeChanged) of
-    ([], [], False) -> return ([], [])
-    _ -> readUpdates noRetry
-  toDelAll <- readTxIds toDelAllHashes
-  return $ CRUDOps toInsAll toRead toUpdate toDelAll
-
-readTxIds :: MonadSqlQuery m => [CommitHash] -> m DeleteTxs
-readTxIds cs = do
-  xs <- selectE $ do
-    (commits :& txs :& ess :& es :& ts) <-
-      E.from
-        $ E.table
-          `E.innerJoin` E.table
-        `E.on` (\(c :& t) -> c ^. CommitRId ==. t ^. TransactionRCommit)
-          `E.innerJoin` E.table
-        `E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
-          `E.innerJoin` E.table
-        `E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
-          `E.innerJoin` E.table
-        `E.on` (\(_ :& _ :& _ :& e :& t) -> e ^. EntryRId ==. t ^. TagRelationREntry)
-    E.where_ $ commits ^. CommitRHash `E.in_` E.valList cs
-    return
-      ( txs ^. TransactionRId
-      , ess ^. EntrySetRId
-      , es ^. EntryRId
-      , ts ^. TagRelationRId
-      )
-  let (txs, ss, es, ts) = L.unzip4 xs
-  return $
-    DeleteTxs
-      { dtTxs = go txs
-      , dtEntrySets = go ss
-      , dtEntries = go es
-      , dtTagRelations = E.unValue <$> ts
-      }
-  where
-    go :: Eq a => [E.Value a] -> [a]
-    go = fmap (E.unValue . NE.head) . NE.group
-
-splitHistory :: [History] -> ([PairedTransfer], [Statement])
-splitHistory = partitionEithers . fmap go
+hashConfig :: Config -> [Int]
+hashConfig
+  Config_
+    { budget = bs
+    , statements = ss
+    } = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
    where
+      (ms, ps) = partitionEithers $ fmap go ss
      go (HistTransfer x) = Left x
      go (HistStatement x) = Right x

-makeTagMap :: [Entity TagR] -> TagMap
-makeTagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
+setDiff :: Eq a => [a] -> [a] -> ([a], [a])
+-- setDiff = setDiff' (==)
+setDiff as bs = (as \\ bs, bs \\ as)

-tag2Record :: Tag -> Entity TagR
-tag2Record t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR (TagID tagID) tagDesc
+-- setDiff' :: Eq a => (a -> b -> Bool) -> [a] -> [b] -> ([a], [b])
+-- setDiff' f = go []
+--   where
+--     go inA [] bs     = (inA, bs)
+--     go inA as []     = (as ++ inA, [])
+--     go inA (a:as) bs = case inB a bs of
+--       Just bs' -> go inA as bs'
+--       Nothing  -> go (a:inA) as bs
+--     inB _ [] = Nothing
+--     inB a (b:bs)
+--       | f a b = Just bs
+--       | otherwise = inB a bs

-currency2Record :: Currency -> Entity CurrencyR
-currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
-  Entity (toKey c) $ CurrencyR (CurID curSymbol) curFullname (fromIntegral curPrecision)
+getDBHashes :: MonadSqlQuery m => m [Int]
+getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl

-readCurrentIds :: PersistEntity a => MonadSqlQuery m => m [Key a]
-readCurrentIds = fmap (E.unValue <$>) $ selectE $ do
-  rs <- E.from E.table
-  return (rs ^. E.persistIdField)
+nukeDBHash :: MonadSqlQuery m => Int -> m ()
+nukeDBHash h = deleteE $ do
+  c <- E.from E.table
+  E.where_ (c ^. CommitRHash ==. E.val h)

-readCurrentCommits :: MonadSqlQuery m => m ([CommitHash], [CommitHash], [CommitHash])
-readCurrentCommits = do
-  xs <- selectE $ do
-    rs <- E.from E.table
-    return (rs ^. CommitRHash, rs ^. CommitRType)
-  return $ foldr go ([], [], []) xs
-  where
-    go (x, t) (bs, ts, hs) =
-      let y = E.unValue x
-       in case E.unValue t of
-            CTBudget -> (y : bs, ts, hs)
-            CTHistoryTransfer -> (bs, y : ts, hs)
-            CTHistoryStatement -> (bs, ts, y : hs)
+nukeDBHashes :: MonadSqlQuery m => [Int] -> m ()
+nukeDBHashes = mapM_ nukeDBHash

-setDiffWith :: (a -> b -> Bool) -> [a] -> [b] -> ([a], [(a, b)], [b])
-setDiffWith f = go [] []
-  where
-    go inA inBoth [] bs = (inA, inBoth, bs)
-    go inA inBoth as [] = (as ++ inA, inBoth, [])
-    go inA inBoth (a : as) bs =
-      let (res, bs') = findDelete (f a) bs
-       in case res of
-            Nothing -> go (a : inA) inBoth as bs
-            Just b -> go inA ((a, b) : inBoth) as bs'
-
-findDelete :: (a -> Bool) -> [a] -> (Maybe a, [a])
-findDelete f xs = case break f xs of
-  (ys, []) -> (Nothing, ys)
-  (ys, z : zs) -> (Just z, ys ++ zs)
+getConfigHashes :: MonadSqlQuery m => Config -> m ([Int], [Int])
+getConfigHashes c = do
+  let ch = hashConfig c
+  dh <- getDBHashes
+  return $ setDiff dh ch

 dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r]
 dumpTbl = selectE $ E.from E.table

+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 :: 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 :: 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
+
+-- TODO slip-n-slide code...
+insertFull
+  :: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m)
+  => Entity r
+  -> m ()
+insertFull (Entity k v) = insertKey k v
+
+currency2Record :: Currency -> Entity CurrencyR
+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
-          , CurrencyPrec (entityKey e) $ currencyRPrecision $ entityVal e
+          , (entityKey e, fromIntegral $ currencyRPrecision $ entityVal e)
          )
      )

 toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
 toKey = toSqlKey . fromIntegral . hash

-makeAccountEntity :: AccountR -> Entity AccountR
-makeAccountEntity a = Entity (toKey $ accountRFullpath a) a
-
-makeAccountR :: AcntType -> T.Text -> [T.Text] -> T.Text -> Bool -> AccountR
-makeAccountR atype name parents des = AccountR name path des (accountSign atype)
+tree2Entity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR
+tree2Entity t parents name des =
+  Entity (toSqlKey $ fromIntegral h) $
+    AccountR name (toPath parents) des
  where
-    path = AcntPath atype (reverse $ name : parents)
+    p = AcntPath t (reverse (name : parents))
+    h = hash p
+    toPath = T.intercalate "/" . (atName t :) . reverse

-tree2Records :: AcntType -> AccountTree -> ([Entity AccountR], [Entity AccountPathR])
+tree2Records
+  :: AcntType
+  -> AccountTree
+  -> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntSign, AcntType))])
 tree2Records t = go []
  where
    go ps (Placeholder d n cs) =
-      let (parentKeys, parentNames) = L.unzip ps
-          a = acnt n parentNames d False
-          k = entityKey a
-          thesePaths = expand k parentKeys
-       in bimap ((a :) . concat) ((thesePaths ++) . concat) $
-            L.unzip $
-              go ((k, n) : ps) <$> cs
+      let e = tree2Entity t (fmap snd ps) n d
+          k = entityKey e
+          (as, aps, ms) = L.unzip3 $ fmap (go ((k, n) : ps)) cs
+          a0 = acnt k n (fmap snd ps) d
+          paths = expand k $ fmap fst ps
+       in (a0 : concat as, paths ++ concat aps, concat ms)
    go ps (Account d n) =
-      let (parentKeys, parentNames) = L.unzip ps
-          a = acnt n parentNames d True
-          k = entityKey a
-       in ([a], expand k parentKeys)
-    expand h0 hs = (\(h, d) -> accountPathRecord h h0 d) <$> zip (h0 : hs) [0 ..]
-    acnt n ps d = makeAccountEntity . makeAccountR t n ps d
-
-accountPathRecord :: Key AccountR -> Key AccountR -> Int -> Entity AccountPathR
-accountPathRecord p c d =
-  Entity (toKey (fromSqlKey p, fromSqlKey c)) $ AccountPathR p c d
+      let e = tree2Entity t (fmap snd ps) n d
+          k = entityKey e
+       in ( [acnt k n (fmap snd ps) d]
+          , expand k $ fmap fst ps
+          , [(AcntPath t $ reverse $ n : fmap snd ps, (k, sign, t))]
+          )
+    toPath = T.intercalate "/" . (atName t :) . reverse
+    acnt k n ps = Entity k . AccountR n (toPath ps)
+    expand h0 hs = (\(h, d) -> AccountPathR h h0 d) <$> zip (h0 : hs) [0 ..]
+    sign = accountSign t

 paths2IDs :: [(AcntPath, a)] -> [(AcntID, a)]
 paths2IDs =
@ -343,25 +236,49 @@ paths2IDs =
    . first trimNames
    . L.unzip
    . L.sortOn fst
-    . fmap (first (NE.reverse . acntPath2NonEmpty))
+    . fmap (first pathList)
+  where
+    pathList (AcntPath t []) = atName t :| []
+    pathList (AcntPath t ns) = N.reverse $ atName t :| ns

 -- none of these errors should fire assuming that input is sorted and unique
-trimNames :: [NonEmpty T.Text] -> [AcntID]
-trimNames = fmap (AcntID . T.intercalate "_") . go []
+trimNames :: [N.NonEmpty T.Text] -> [AcntID]
+trimNames = fmap (T.intercalate "_" . reverse) . trimAll 0
  where
-    go :: [T.Text] -> [NonEmpty T.Text] -> [[T.Text]]
-    go prev = concatMap (go' prev) . groupNonEmpty
-    go' prev (key, rest) = case rest of
-      (_ :| []) -> [key : prev]
-      ([] :| xs) ->
-        let next = key : prev
-            other = go next $ fmap (fromMaybe err . NE.nonEmpty) xs
-         in next : other
-      (x :| xs) -> go (key : prev) $ fmap (fromMaybe err . NE.nonEmpty) (x : xs)
-    err = error "account path list either not sorted or contains duplicates"
+    trimAll _ [] = []
+    trimAll i (y : ys) = case L.foldl' (matchPre i) (y, [], []) ys of
+      (a, [], bs) -> reverse $ trim i a : bs
+      (a, as, bs) -> reverse bs ++ trimAll (i + 1) (reverse $ a : as)
+    matchPre i (y, ys, old) new = case (y !? i, new !? i) of
+      (Nothing, Just _) ->
+        case ys of
+          [] -> (new, [], trim i y : old)
+          _ -> err "unsorted input"
+      (Just _, Nothing) -> err "unsorted input"
+      (Nothing, Nothing) -> err "duplicated inputs"
+      (Just a, Just b)
+        | a == b -> (new, y : ys, old)
+        | otherwise ->
+            let next = case ys of
+                  [] -> [trim i y]
+                  _ -> trimAll (i + 1) (reverse $ y : ys)
+             in (new, [], reverse next ++ old)
+    trim i = N.take (i + 1)
+    err msg = errorWithoutStackTrace $ "Import.Database.Ops.hs: " ++ msg

-groupNonEmpty :: Ord a => [NonEmpty a] -> [(a, NonEmpty [a])]
-groupNonEmpty = fmap (second (NE.tail <$>)) . groupWith NE.head
+(!?) :: N.NonEmpty a -> Int -> Maybe a
+xs !? n
+  | n < 0 = Nothing
+  -- Definition adapted from GHC.List
+  | otherwise =
+      foldr
+        ( \x r k -> case k of
+            0 -> Just x
+            _ -> r (k - 1)
+        )
+        (const Nothing)
+        xs
+        n

 flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)]
 flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arEquity} =
@ -371,372 +288,129 @@ flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arE
    ++ ((AssetT,) <$> arAssets)
    ++ ((EquityT,) <$> arEquity)

-makeAcntMap :: [Entity AccountR] -> AccountMap
-makeAcntMap =
-  M.fromList
-    . paths2IDs
-    . fmap go
-    . filter (accountRLeaf . snd)
-    . fmap (\e -> (E.entityKey e, E.entityVal e))
+indexAcntRoot :: AccountRoot -> ([Entity AccountR], [AccountPathR], AccountMap)
+indexAcntRoot r =
+  ( concat ars
+  , concat aprs
+  , M.fromList $ paths2IDs $ concat ms
+  )
  where
-    go (k, v) = let p = accountRFullpath v in (p, (k, apType p))
+    (ars, aprs, ms) = L.unzip3 $ uncurry tree2Records <$> flattenAcntRoot r

-indexAcntRoot :: AccountRoot -> ([Entity AccountR], [Entity AccountPathR])
-indexAcntRoot = bimap concat concat . L.unzip . fmap (uncurry tree2Records) . flattenAcntRoot
-
-updateCD
-  :: ( MonadSqlQuery m
-     , PersistRecordBackend a SqlBackend
-     , PersistRecordBackend b SqlBackend
-     )
-  => CDOps (Entity a) (Key b)
-  -> m ()
-updateCD (CRUDOps cs () () ds) = do
-  mapM_ deleteKeyE ds
-  insertEntityManyE cs
-
-deleteTxs :: MonadSqlQuery m => DeleteTxs -> m ()
-deleteTxs DeleteTxs {dtTxs, dtEntrySets, dtEntries, dtTagRelations} = do
-  mapM_ deleteKeyE dtTxs
-  mapM_ deleteKeyE dtEntrySets
-  mapM_ deleteKeyE dtEntries
-  mapM_ deleteKeyE dtTagRelations
-
-updateDBState :: (MonadFinance m, MonadSqlQuery m) => m ()
-updateDBState = do
-  updateCD =<< asks csCurrencies
-  updateCD =<< asks csAccounts
-  updateCD =<< asks csPaths
-  updateCD =<< asks csTags
-  deleteTxs =<< asks (coDelete . csBudgets)
-  deleteTxs =<< asks (coDelete . csHistTrans)
-  deleteTxs =<< asks (coDelete . csHistStmts)
-  b <- asks csBudgetScope
-  h <- asks csHistoryScope
-  repsertE (E.toSqlKey 1) $ ConfigStateR h b
-
-readInvalidIds
-  :: MonadSqlQuery m
-  => ExistingConfig
-  -> [(CommitHash, a)]
-  -> m ([CommitHash], [(CommitHash, a)])
-readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
-  rs <- selectE $ do
-    (commits :& _ :& entrysets :& entries :& tags) <-
-      E.from
-        $ E.table
-          `E.innerJoin` E.table
-        `E.on` (\(c :& t) -> c ^. CommitRId ==. t ^. TransactionRCommit)
-          `E.innerJoin` E.table
-        `E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
-          `E.innerJoin` E.table
-        `E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
-          `E.leftJoin` E.table
-        `E.on` (\(_ :& _ :& _ :& e :& r) -> E.just (e ^. EntryRId) ==. r ?. TagRelationREntry)
-    E.where_ $ commits ^. CommitRHash `E.in_` E.valList (fmap fst xs)
-    return
-      ( commits ^. CommitRHash
-      , entrysets ^. EntrySetRCurrency
-      , entries ^. EntryRAccount
-      , tags ?. TagRelationRTag
-      )
-  -- TODO there are faster ways to do this; may/may not matter
-  let cs = go ecCurrencies $ fmap (\(i, E.Value c, _, _) -> (i, c)) rs
-  let as = go ecAccounts $ fmap (\(i, _, E.Value a, _) -> (i, a)) rs
-  let ts = go ecTags [(i, t) | (i, _, _, E.Value (Just t)) <- rs]
-  let valid = (cs `S.intersection` as) `S.intersection` ts
-  let (a0, _) = first (fst <$>) $ L.partition ((`S.member` valid) . fst) xs
-  return (a0, [])
-  where
-    go existing =
-      S.fromList
-        . fmap (E.unValue . fst)
-        . L.filter (all (`S.member` existing) . snd)
-        . groupKey id
-
-readUpdates
-  :: (MonadAppError m, MonadSqlQuery m)
-  => [CommitHash]
-  -> m ([ReadEntry], [Either TotalUpdateEntrySet FullUpdateEntrySet])
-readUpdates hashes = do
-  xs <- selectE $ do
-    (commits :& txs :& entrysets :& entries :& currencies) <-
-      E.from
-        $ E.table @CommitR
-          `E.innerJoin` E.table @TransactionR
-        `E.on` (\(c :& t) -> c ^. CommitRId ==. t ^. TransactionRCommit)
-          `E.innerJoin` E.table @EntrySetR
-        `E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
-          `E.innerJoin` E.table @EntryR
-        `E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
-          `E.innerJoin` E.table @CurrencyR
-        `E.on` (\(_ :& _ :& es :& _ :& cur) -> es ^. EntrySetRCurrency ==. cur ^. CurrencyRId)
-    E.where_ $ commits ^. CommitRHash `E.in_` E.valList hashes
-    return
-      ( entrysets ^. EntrySetRRebalance
-      ,
-        (
-          ( entrysets ^. EntrySetRId
-          , txs ^. TransactionRDate
-          , txs ^. TransactionRBudgetName
-          , txs ^. TransactionRPriority
-          ,
-            ( entrysets ^. EntrySetRCurrency
-            , currencies ^. CurrencyRPrecision
-            )
-          )
-        , entries
-        )
-      )
-  let (toUpdate, toRead) = L.partition (E.unValue . fst) xs
-  toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _, _, _) -> i) (snd <$> toUpdate)
-  let toRead' = fmap (makeRE . snd) toRead
-  return (toRead', toUpdate')
-  where
-    makeUES ((_, day, name, pri, (curID, prec)), es) = do
-      let prec' = fromIntegral $ E.unValue prec
-      let cur = E.unValue curID
-      let res =
-            bimap NE.nonEmpty NE.nonEmpty $
-              NE.partition ((< 0) . entryRIndex . snd) $
-                NE.sortWith (entryRIndex . snd) $
-                  fmap (\e -> (entityKey e, entityVal e)) es
-      case res of
-        (Just froms, Just tos) -> do
-          let tot = sum $ fmap (entryRValue . snd) froms
-          (from0, fromRO, fromUnkVec) <- splitFrom prec' $ NE.reverse froms
-          (from0', fromUnk, to0, toRO, toUnk) <- splitTo prec' from0 fromUnkVec tos
-          -- TODO WAP (wet ass programming)
-          return $ case from0' of
-            Left x ->
-              Left $
-                UpdateEntrySet
-                  { utDate = E.unValue day
-                  , utCurrency = cur
-                  , utFrom0 = x
-                  , utTo0 = to0
-                  , utFromRO = fromRO
-                  , utToRO = toRO
-                  , utFromUnk = fromUnk
-                  , utToUnk = toUnk
-                  , utTotalValue = realFracToDecimalP prec' tot
-                  , utBudget = E.unValue name
-                  , utPriority = E.unValue pri
+getDBState
+  :: (MonadInsertError m, MonadSqlQuery m)
+  => Config
+  -> m (DBState, DBUpdates)
+getDBState c = do
+  (del, new) <- getConfigHashes c
+  combineError bi si $ \b s ->
+    ( DBState
+        { kmCurrency = currencyMap cs
+        , kmAccount = am
+        , kmBudgetInterval = b
+        , kmStatementInterval = s
+        , kmTag = tagMap ts
+        , kmNewCommits = new
        }
-            Right x ->
-              Right $
-                UpdateEntrySet
-                  { utDate = E.unValue day
-                  , utCurrency = cur
-                  , utFrom0 = x
-                  , utTo0 = to0
-                  , utFromRO = fromRO
-                  , utToRO = toRO
-                  , utFromUnk = fromUnk
-                  , utToUnk = toUnk
-                  , utTotalValue = ()
-                  , utBudget = E.unValue name
-                  , utPriority = E.unValue pri
+    , DBUpdates
+        { duOldCommits = del
+        , duNewTagIds = ts
+        , duNewAcntPaths = paths
+        , duNewAcntIds = acnts
+        , duNewCurrencyIds = cs
        }
-        -- TODO this error is lame
-        _ -> throwAppError $ DBError $ DBUpdateUnbalanced
-    makeRE ((_, day, name, pri, (curID, prec)), entry) = do
-      let e = entityVal entry
-       in ReadEntry
-            { reDate = E.unValue day
-            , reCurrency = E.unValue curID
-            , reAcnt = entryRAccount e
-            , reValue = realFracToDecimal (fromIntegral $ E.unValue prec) (entryRValue e)
-            , reBudget = E.unValue name
-            , rePriority = E.unValue pri
-            }
-
-splitFrom
-  :: Precision
-  -> NonEmpty (EntryRId, EntryR)
-  -> AppExcept (Either UEBlank (Either UE_RO UEUnk), [UE_RO], [UEUnk])
-splitFrom prec (f0 :| fs) = do
-  -- ASSUME entries are sorted by index
-  -- TODO combine errors here
-  let f0Res = readDeferredValue prec f0
-  let fsRes = mapErrors (splitDeferredValue prec) fs
-  combineErrorM f0Res fsRes $ \f0' fs' -> do
-    let (ro, unk) = partitionEithers fs'
-    -- let idxVec = V.fromList $ fmap (either (const Nothing) Just) fs'
-    return (f0', ro, unk)
-
-splitTo
-  :: Precision
-  -> Either UEBlank (Either UE_RO UEUnk)
-  -> [UEUnk]
-  -> NonEmpty (EntryRId, EntryR)
-  -> AppExcept
-      ( Either (UEBlank, [UELink]) (Either UE_RO (UEUnk, [UELink]))
-      , [(UEUnk, [UELink])]
-      , UEBlank
-      , [UE_RO]
-      , [UEUnk]
    )
-splitTo prec from0 fromUnk (t0 :| ts) = do
-  -- How to split the credit side of the database transaction in 1024 easy
-  -- steps:
-  --
-  -- 1. Split incoming entries (except primary) into those with links and not
-  let (unlinked, linked) = partitionEithers $ fmap splitLinked ts
-
-  -- 2. For unlinked entries, split into read-only and unknown entries
-  let unlinkedRes = partitionEithers <$> mapErrors (splitDeferredValue prec) unlinked
-
-  -- 3. For linked entries, split into those that link to the primary debit
-  --    entry and not
-  let (linked0, linkedN) = second (groupKey id) $ L.partition ((== 0) . fst) linked
-
-  -- 4. For linked entries that don't link to the primary debit entry, split
-  --    into those that link to an unknown debit entry or not. Those that
-  --    are not will be read-only and those that are will be collected with
-  --    their linked debit entry
-  let linkedRes = zipPaired prec fromUnk linkedN
-
-  -- 5. For entries linked to the primary debit entry, turn them into linked
-  --    entries (lazily only used when needed later)
-  let from0Res = mapErrors (makeLinkUnk . snd) linked0
-
-  combineErrorM3 from0Res linkedRes unlinkedRes $
-    -- 6. Depending on the type of primary debit entry we have, add linked
-    --    entries if it is either an unknown or a blank (to be solved) entry,
-    --    or turn the remaining linked entries to read-only and add to the other
-    --    read-only entries
-    \from0Links (fromUnk', toROLinkedN) (toROUnlinked, toUnk) -> do
-      let (from0', toROLinked0) = case from0 of
-            Left blnk -> (Left (blnk, from0Links), [])
-            Right (Left ro) -> (Right $ Left ro, makeRoUE prec . snd . snd <$> linked0)
-            Right (Right unk) -> (Right $ Right (unk, from0Links), [])
-      return (from0', fromUnk', primary, toROLinked0 ++ toROLinkedN ++ toROUnlinked, toUnk)
  where
-    primary = uncurry makeUnkUE t0
-    splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRCachedLink e
+    bi = liftExcept $ resolveDaySpan $ budgetInterval $ global c
+    si = liftExcept $ resolveDaySpan $ 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))

-- | Match linked credit entries with unknown entries, returning a list of
-- matches and non-matching (read-only) credit entries. ASSUME both lists are
-- sorted according to index and 'fst' respectively. NOTE the output will NOT be
-- sorted.
-zipPaired
-  :: Precision
-  -> [UEUnk]
-  -> [(EntryIndex, NonEmpty (EntryRId, EntryR))]
-  -> AppExcept ([(UEUnk, [UELink])], [UE_RO])
-zipPaired prec = go ([], [])
-  where
-    nolinks = ((,[]) <$>)
-    go acc fs [] = return $ first (nolinks fs ++) acc
-    go (facc, tacc) fs ((ti, tls) : ts) = do
-      let (lesser, rest) = L.span ((< ti) . ueIndex) fs
-      links <- NE.toList <$> mapErrors makeLinkUnk tls
-      let (nextLink, fs') = case rest of
-            (r0 : rs)
-              | ueIndex r0 == ti -> (Just (r0, links), rs)
-              | otherwise -> (Nothing, rest)
-            _ -> (Nothing, rest)
-      let acc' = (nolinks lesser ++ facc, tacc)
-      let ros = NE.toList $ makeRoUE prec . snd <$> tls
-      let f = maybe (second (++ ros)) (\u -> first (u :)) nextLink
-      go (f acc') fs' ts
+updateHashes :: (MonadSqlQuery m) => DBUpdates -> m ()
+updateHashes DBUpdates {duOldCommits} = nukeDBHashes duOldCommits

-makeLinkUnk :: (EntryRId, EntryR) -> AppExcept UELink
-makeLinkUnk (k, e) =
-  -- TODO error should state that scale must be present for a link in the db
-  maybe
-    (throwAppError $ DBError $ DBLinkError k DBLinkNoScale)
-    (return . makeUE k e . LinkScale)
-    $ fromRational <$> entryRCachedValue e
+updateTags :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
+updateTags DBUpdates {duNewTagIds} = do
+  tags' <- selectE $ E.from $ E.table @TagR
+  let (toIns, toDel) = setDiff duNewTagIds tags'
+  mapM_ deleteTag toDel
+  mapM_ insertFull toIns

-splitDeferredValue :: Precision -> (EntryRId, EntryR) -> AppExcept (Either UE_RO UEUnk)
-splitDeferredValue prec p@(k, _) = do
-  res <- readDeferredValue prec p
-  case res of
-    Left _ -> throwAppError $ DBError $ DBLinkError k DBLinkNoValue
-    Right x -> return x
+updateAccounts :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
+updateAccounts DBUpdates {duNewAcntIds, duNewAcntPaths} = do
+  acnts' <- dumpTbl
+  let (toIns, toDel) = setDiff duNewAcntIds acnts'
+  deleteWhere ([] :: [Filter AccountPathR])
+  mapM_ deleteAccount toDel
+  mapM_ insertFull toIns
+  mapM_ insert duNewAcntPaths

-readDeferredValue :: Precision -> (EntryRId, EntryR) -> AppExcept (Either UEBlank (Either UE_RO UEUnk))
-readDeferredValue prec (k, e) = case (entryRCachedValue e, entryRCachedType e) of
-  (Nothing, Just TFixed) -> return $ Right $ Left $ makeRoUE prec e
-  (Just v, Just TBalance) -> go $ fmap EVBalance $ makeUE k e $ realFracToDecimalP prec v
-  (Just v, Just TPercent) -> go $ fmap EVPercent $ makeUE k e $ fromRational v
-  (Nothing, Nothing) -> return $ Left $ makeUnkUE k e
-  (Just v, Nothing) -> err $ DBLinkInvalidValue v False
-  (Just v, Just TFixed) -> err $ DBLinkInvalidValue v True
-  (Nothing, Just TBalance) -> err $ DBLinkInvalidBalance
-  (Nothing, Just TPercent) -> err $ DBLinkInvalidPercent
-  where
-    go = return . Right . Right
-    err = throwAppError . DBError . DBLinkError k
+updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
+updateCurrencies DBUpdates {duNewCurrencyIds} = do
+  curs' <- selectE $ E.from $ E.table @CurrencyR
+  let (toIns, toDel) = setDiff duNewCurrencyIds curs'
+  mapM_ deleteCurrency toDel
+  mapM_ insertFull toIns

-makeUE :: i -> EntryR -> v -> UpdateEntry i v
-makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e)
+updateDBState :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
+updateDBState u = do
+  updateHashes u
+  updateTags u
+  updateAccounts u
+  updateCurrencies u

-makeRoUE :: Precision -> EntryR -> UpdateEntry () StaticValue
-makeRoUE prec e = makeUE () e $ StaticValue (realFracToDecimalP prec $ entryRValue e)
-
-makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
-makeUnkUE k e = makeUE k e ()
-
-insertAll
-  :: (MonadAppError m, MonadSqlQuery m, MonadFinance m)
-  => [EntryCRU]
-  -> m ()
-insertAll ebs = do
-  (toUpdate, toInsert) <- balanceTxs ebs
-  mapM_ updateTx toUpdate
-  forM_ (groupWith itxCommit toInsert) $
-    \(c, ts) -> do
-      ck <- insert c
-      mapM_ (insertTx ck) ts
-
-insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
-insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget, itxPriority} = do
-  k <- insert $ TransactionR c itxDate itxDescr itxBudget itxPriority
-  mapM_ (uncurry (insertEntrySet k)) $ zip [0 ..] (NE.toList itxEntrySets)
-  where
-    insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do
-      let fs = NE.toList iesFromEntries
-      let ts = NE.toList iesToEntries
-      let rebalance = any (isJust . ieCached) (fs ++ ts)
-      esk <- insert $ EntrySetR tk iesCurrency i rebalance
-      mapM_ (uncurry (go esk)) $ zip [0 ..] ts ++ zip (negate <$> [1 ..]) fs
-    go k i e = void $ insertEntry k i e
-
-insertEntry :: MonadSqlQuery m => EntrySetRId -> EntryIndex -> InsertEntry -> m EntryRId
-insertEntry
-  k
-  i
-  InsertEntry
-    { ieEntry = Entry {eValue, eTags, eAcnt, eComment}
-    , ieCached
-    } =
-    do
-      ek <- insert $ EntryR k eAcnt eComment (toRational eValue) i cval ctype deflink
-      mapM_ (insert_ . TagRelationR ek) eTags
-      return ek
-    where
-      (cval, ctype, deflink) = case ieCached of
-        (Just (CachedLink x s)) -> (Just (toRational s), Nothing, Just x)
-        (Just (CachedBalance b)) -> (Just (toRational b), Just TBalance, Nothing)
-        (Just (CachedPercent p)) -> (Just (toRational p), Just TPercent, Nothing)
-        Nothing -> (Nothing, Just TFixed, Nothing)
-
-updateTx :: MonadSqlQuery m => UEBalanced -> m ()
-updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. v]
-  where
-    v = toRational $ unStaticValue ueValue
-
-repsertE :: (MonadSqlQuery m, PersistRecordBackend r SqlBackend) => Key r -> r -> m ()
-repsertE k r = unsafeLiftSql "esqueleto-repsert" (E.repsert k r)
+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)

-deleteKeyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => Key a -> m ()
-deleteKeyE q = unsafeLiftSql "esqueleto-deleteKey" (E.deleteKey q)
+whenHash
+  :: (Hashable a, MonadFinance m, MonadSqlQuery m)
+  => ConfigType
+  -> a
+  -> b
+  -> (CommitRId -> m b)
+  -> m b
+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

-insertEntityManyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => [Entity a] -> m ()
-insertEntityManyE q = unsafeLiftSql "esqueleto-insertEntityMany" (E.insertEntityMany q)
+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
+
+insertEntry :: MonadSqlQuery m => TransactionRId -> KeyEntry -> m EntryRId
+insertEntry t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do
+  k <- insert $ EntryR t eCurrency eAcnt eComment eValue
+  mapM_ (insert_ . TagRelationR k) eTags
+  return k
+
+resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry
+resolveEntry s@Entry {eAcnt, eCurrency, eValue, eTags} = do
+  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
+  combineError (combineError3 aRes cRes sRes (,,)) tagRes $
+    \(aid, cid, sign) tags ->
+      s
+        { eAcnt = aid
+        , eCurrency = cid
+        , eValue = eValue * fromIntegral (sign2Int sign)
+        , eTags = tags
+        }
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@ -1,16 +1,15 @@
 module Internal.History
-  ( readHistStmt
-  , readHistTransfer
-  , splitHistory
+  ( splitHistory
+  , insertHistTransfer
+  , readHistStmt
+  , insertHistStmt
  )
 where

 import Control.Monad.Except
 import Data.Csv
-import Data.Decimal
-import Data.Foldable
-import Data.Hashable
-import GHC.Real
+import Database.Persist.Monad
+import Internal.Database
 import Internal.Types.Main
 import Internal.Utils
 import RIO hiding (to)
@ -21,55 +20,107 @@ import qualified RIO.Map as M
 import qualified RIO.Text as T
 import RIO.Time
 import qualified RIO.Vector as V
-import Text.Regex.TDFA hiding (matchAll)
-import Text.Regex.TDFA.Text

-- NOTE keep statement and transfer readers separate because the former needs
-- the IO monad, and thus will throw IO errors rather than using the ExceptT
-- thingy
-splitHistory :: [History] -> ([PairedTransfer], [Statement])
+splitHistory :: [History] -> ([HistTransfer], [Statement])
 splitHistory = partitionEithers . fmap go
  where
    go (HistTransfer x) = Left x
    go (HistStatement x) = Right x

--------------------------------------------------------------------------------
-- Transfers
-
-readHistTransfer
-  :: (MonadAppError m, MonadFinance m)
-  => PairedTransfer
-  -> m [Tx CommitR]
-readHistTransfer ht = do
-  bounds <- asks (unHSpan . csHistoryScope)
-  expandTransfer c historyName bounds ht
-  where
-    c = CommitR (CommitHash $ hash ht) CTHistoryTransfer
-
--------------------------------------------------------------------------------
-- Statements
+insertHistTransfer
+  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
+  => HistTransfer
+  -> m ()
+insertHistTransfer
+  m@Transfer
+    { transFrom = from
+    , transTo = to
+    , transCurrency = u
+    , transAmounts = amts
+    } = do
+    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

 readHistStmt
  :: (MonadUnliftIO m, MonadFinance m)
  => FilePath
  -> Statement
-  -> m [Tx CommitR]
-readHistStmt root i = do
+  -> m (Maybe (CommitR, [KeyTx]))
+readHistStmt root i = whenHash_ CTImport i $ do
  bs <- readImport root i
-  bounds <- asks (unHSpan . csHistoryScope)
-  return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
+  bounds <- askDBState kmStatementInterval
+  liftIOExceptT $ mapErrors resolveTx $ filter (inDaySpan bounds . txDate) bs
+
+insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m ()
+insertHistStmt c ks = do
+  ck <- insert c
+  mapM_ (insertTx ck) ks
+
+--------------------------------------------------------------------------------
+-- low-level transaction stuff
+
+-- TODO tags here?
+txPair
+  :: (MonadInsertError m, MonadFinance m)
+  => Day
+  -> AcntID
+  -> AcntID
+  -> CurID
+  -> Rational
+  -> T.Text
+  -> m KeyTx
+txPair day from to cur val desc = resolveTx tx
  where
-    c = CommitR (CommitHash $ hash i) CTHistoryStatement
+    split a v =
+      Entry
+        { eAcnt = a
+        , eValue = v
+        , eComment = ""
+        , eCurrency = cur
+        , eTags = []
+        }
+    tx =
+      Tx
+        { txDescr = desc
+        , txDate = day
+        , txEntries = [split from (-val), split to val]
+        }
+
+resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
+resolveTx t@Tx {txEntries = ss} =
+  fmap (\kss -> t {txEntries = kss}) $
+    combineErrors $
+      fmap resolveEntry ss
+
+insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
+insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
+  k <- insert $ TransactionR c d e
+  mapM_ (insertEntry k) ss
+
+--------------------------------------------------------------------------------
+-- Statements

 -- TODO this probably won't scale well (pipes?)
-readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]
+readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [BalTx]
 readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
  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 paths
-  fromEither =<< runExceptT (matchRecords compiledMatches records)
+  m <- askDBState kmCurrency
+  fromEither $
+    flip runReader m $
+      runExceptT $
+        matchRecords compiledMatches records
  where
    paths = (root </>) <$> stmtPaths

@ -82,9 +133,9 @@ readImport_
  -> m [TxRecord]
 readImport_ n delim tns p = do
  res <- tryIO $ BL.readFile p
-  bs <- fromEither $ first (AppException . (: []) . StatementIOError . tshow) res
+  bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res
  case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
-    Left m -> throwIO $ AppException [ParseError $ T.pack m]
+    Left m -> throwIO $ InsertException [ParseError $ T.pack m]
    Right (_, v) -> return $ catMaybes $ V.toList v
  where
    opts = defaultDecodeOptions {decDelimiter = fromIntegral delim}
@ -98,18 +149,18 @@ parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFm
  if d == ""
    then return Nothing
    else do
-      a <- parseDecimal toAmountFmt =<< r .: T.encodeUtf8 toAmount
+      a <- parseRational toAmountFmt =<< r .: T.encodeUtf8 toAmount
      e <- r .: T.encodeUtf8 toDesc
      os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther
      d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
      return $ Just $ TxRecord d' a e os p

-matchRecords :: MonadFinance m => [MatchRe] -> [TxRecord] -> AppExceptT m [Tx ()]
+matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [BalTx]
 matchRecords ms rs = do
  (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
  case (matched, unmatched, notfound) of
-    (ms_, [], []) -> return ms_
-    (_, us, ns) -> throwError $ AppException [StatementError us ns]
+    (ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_
+    (_, us, ns) -> throwError $ InsertException [StatementError us ns]

 matchPriorities :: [MatchRe] -> [MatchGroup]
 matchPriorities =
@ -163,10 +214,9 @@ zipperSlice f x = go
        LT -> z

 zipperMatch
-  :: MonadFinance m
-  => Unzipped MatchRe
+  :: Unzipped MatchRe
  -> TxRecord
-  -> AppExceptT m (Zipped MatchRe, MatchRes (Tx ()))
+  -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
 zipperMatch (Unzipped bs cs as) x = go [] cs
  where
    go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
@ -180,10 +230,9 @@ zipperMatch (Unzipped bs cs as) x = go [] cs
           in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)

 zipperMatch'
-  :: MonadFinance m
-  => Zipped MatchRe
+  :: Zipped MatchRe
  -> TxRecord
-  -> AppExceptT m (Zipped MatchRe, MatchRes (Tx ()))
+  -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
 zipperMatch' z x = go z
  where
    go (Zipped bs (a : as)) = do
@ -200,11 +249,7 @@ matchDec m = case spTimes m of
  Just n -> Just $ m {spTimes = Just $ n - 1}
  Nothing -> Just m

-matchAll
-  :: MonadFinance m
-  => [MatchGroup]
-  -> [TxRecord]
-  -> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
+matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
 matchAll = go ([], [])
  where
    go (matched, unused) gs rs = case (gs, rs) of
@ -214,21 +259,13 @@ matchAll = go ([], [])
        (ts, unmatched, us) <- matchGroup g rs
        go (ts ++ matched, us ++ unused) gs' unmatched

-matchGroup
-  :: MonadFinance m
-  => MatchGroup
-  -> [TxRecord]
-  -> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
+matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([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)

-matchDates
-  :: MonadFinance m
-  => [MatchRe]
-  -> [TxRecord]
-  -> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
+matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
 matchDates ms = go ([], [], initZipper ms)
  where
    go (matched, unmatched, z) [] =
@ -249,11 +286,7 @@ matchDates ms = go ([], [], initZipper ms)
          go (m, u, z') rs
    findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m

-matchNonDates
-  :: MonadFinance m
-  => [MatchRe]
-  -> [TxRecord]
-  -> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
+matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
 matchNonDates ms = go ([], [], initZipper ms)
  where
    go (matched, unmatched, z) [] =
@ -270,246 +303,26 @@ matchNonDates ms = go ([], [], initZipper ms)
            MatchFail -> (matched, r : unmatched)
       in go (m, u, resetZipper z') rs

-matches :: MonadFinance m => MatchRe -> TxRecord -> AppExceptT m (MatchRes (Tx ()))
-matches
-  StatementParser {spTx, spOther, spVal, spDate, spDesc, spPriority}
-  r@TxRecord {trDate, trAmount, trDesc, trOther} = do
-    res <- liftInner $
-      combineError3 val other desc $
-        \x y z -> x && y && z && date
-    if res
-      then maybe (return MatchSkip) convert spTx
-      else return MatchFail
+balanceTx :: RawTx -> InsertExcept BalTx
+balanceTx t@Tx {txEntries = ss} = do
+  bs <- balanceEntries ss
+  return $ t {txEntries = bs}
+
+balanceEntries :: [RawEntry] -> InsertExcept [BalEntry]
+balanceEntries ss =
+  fmap concat
+    <$> mapM (uncurry bal)
+    $ groupByKey
+    $ fmap (\s -> (eCurrency s, s)) ss
  where
-      val = valMatches spVal $ toRational trAmount
-      date = maybe True (`dateMatches` trDate) spDate
-      other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther
-      desc = maybe (return True) (matchMaybe (unTxDesc trDesc) . snd) spDesc
-      convert tg = MatchPass <$> toTx (fromIntegral spPriority) tg r
+    haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
+    haeValue s = Left s
+    bal cur rss
+      | length rss < 2 = throwError $ InsertException [BalanceError TooFewEntries cur rss]
+      | otherwise = case partitionEithers $ fmap haeValue rss of
+          ([noVal], val) -> return $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
+          ([], val) -> return val
+          _ -> throwError $ InsertException [BalanceError NotOneBlank cur rss]

-toTx :: MonadFinance m => Int -> TxGetter -> TxRecord -> AppExceptT m (Tx ())
-toTx
-  priority
-  TxGetter
-    { tgFrom
-    , tgTo
-    , tgCurrency
-    , tgOtherEntries
-    , tgScale
-    }
-  r@TxRecord {trAmount, trDate, trDesc} = do
-    combineError curRes subRes $ \(cur, f, t) ss ->
-      Tx
-        { txDate = trDate
-        , txDescr = trDesc
-        , txCommit = ()
-        , txPrimary =
-            Left $
-              EntrySet
-                { esTotalValue = roundToP (cpPrec cur) trAmount *. tgScale
-                , esCurrency = cpID cur
-                , esFrom = f
-                , esTo = t
-                }
-        , txOther = Left <$> ss
-        , txBudget = historyName
-        , txPriority = priority
-        }
-    where
-      curRes = do
-        m <- asks csCurrencyMap
-        cur <- liftInner $ resolveCurrency m r tgCurrency
-        let prec = cpPrec cur
-        let fromRes = liftInner $ resolveHalfEntry resolveFromValue prec r () tgFrom
-        let toRes = liftInner $ resolveHalfEntry resolveToValue prec r () tgTo
-        combineError fromRes toRes (cur,,)
-      subRes = mapErrors (resolveSubGetter r) tgOtherEntries
-
-resolveSubGetter
-  :: MonadFinance m
-  => TxRecord
-  -> TxSubGetter
-  -> AppExceptT m SecondayEntrySet
-resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
-  m <- asks csCurrencyMap
-  cur <- liftInner $ resolveCurrency m r tsgCurrency
-  let prec = cpPrec cur
-  let toRes = resolveHalfEntry resolveToValue prec r () tsgTo
-  let valRes = liftInner $ resolveValue prec r tsgValue
-  liftInner $ combineErrorM toRes valRes $ \t v -> do
-    f <- resolveHalfEntry resolveFromValue prec r v tsgFrom
-    return $
-      EntrySet
-        { esTotalValue = ()
-        , esCurrency = cpID cur
-        , esFrom = f
-        , esTo = t
-        }
-
-resolveHalfEntry
-  :: (Precision -> TxRecord -> n -> AppExcept v')
-  -> Precision
-  -> TxRecord
-  -> v
-  -> TxHalfGetter (EntryGetter n)
-  -> AppExcept (HalfEntrySet v v')
-resolveHalfEntry f prec r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
-  combineError acntRes esRes $ \a es ->
-    HalfEntrySet
-      { hesPrimary =
-          Entry
-            { eAcnt = a
-            , eValue = v
-            , eComment = thgComment
-            , eTags = thgTags
-            }
-      , hesOther = es
-      }
-  where
-    acntRes = resolveAcnt r thgAcnt
-    esRes = mapErrors (resolveEntry f prec r) thgEntries
-
-otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> AppExcept 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
-  :: (Precision -> TxRecord -> n -> AppExcept v)
-  -> Precision
-  -> TxRecord
-  -> EntryGetter n
-  -> AppExcept (Entry AcntID v TagID)
-resolveEntry f prec r s@Entry {eAcnt, eValue} =
-  combineError acntRes valRes $ \a v -> s {eAcnt = a, eValue = v}
-  where
-    acntRes = resolveAcnt r eAcnt
-    valRes = f prec r eValue
-
-resolveFromValue :: Precision -> TxRecord -> EntryNumGetter -> AppExcept EntryValue
-resolveFromValue = resolveValue
-
-resolveToValue :: Precision -> TxRecord -> LinkedEntryNumGetter -> AppExcept EntryLink
-resolveToValue _ _ (Linked l) = return $ LinkIndex l
-resolveToValue prec r (Getter g) = LinkValue <$> resolveValue prec r g
-
-resolveValue :: Precision -> TxRecord -> EntryNumGetter -> AppExcept EntryValue
-resolveValue prec TxRecord {trOther, trAmount} s = case s of
-  (LookupN t) -> EntryFixed . go <$> (readDouble =<< lookupErr EntryValField t trOther)
-  (ConstN c) -> return $ EntryFixed $ go c
-  AmountN m -> return $ EntryFixed $ trAmount *. m
-  BalanceN x -> return $ EntryBalance $ go x
-  PercentN x -> return $ EntryPercent x
-  where
-    go = realFracToDecimalP prec
-
-resolveAcnt :: TxRecord -> EntryAcnt -> AppExcept AcntID
-resolveAcnt r e = AcntID <$> resolveEntryField AcntField r (unAcntID <$> e)
-
-resolveCurrency :: CurrencyMap -> TxRecord -> EntryCur -> AppExcept CurrencyPrec
-resolveCurrency m r c = do
-  i <- resolveEntryField CurField r (unCurID <$> c)
-  case M.lookup (CurID i) m of
-    Just k -> return k
-    Nothing -> throwError $ AppException [LookupError (DBKey CurField) i]
-
-resolveEntryField :: EntryIDType -> TxRecord -> EntryTextGetter T.Text -> AppExcept T.Text
-resolveEntryField t TxRecord {trOther = o} s = case s of
-  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) <- combineError (lookup_ f1 o) (lookup_ f2 o) (,)
-    lookup_ (k1, k2) m
-  where
-    lookup_ :: (Ord k, Show k) => k -> M.Map k v -> AppExcept v
-    lookup_ = lookupErr (EntryIDField t)
-
-readDouble :: T.Text -> AppExcept Double
-readDouble s = case readMaybe $ T.unpack s of
-  Just x -> return x
-  Nothing -> throwError $ AppException [ConversionError s True]
-
-readRational :: T.Text -> AppExcept Rational
-readRational s = case T.split (== '.') s of
-  [x] -> maybe err (return . fromInteger) $ readT x
-  [x, y] -> case (readT x, readT y) of
-    (Just x', Just y') ->
-      let p = 10 ^ T.length y
-          k = if x' >= 0 then 1 else -1
-       in return $ fromInteger x' + k * y' % p
-    _ -> err
-  _ -> err
-  where
-    readT = readMaybe . T.unpack
-    err = throwError $ AppException [ConversionError s False]
-
-compileOptions :: TxOpts T.Text -> AppExcept TxOptsRe
-compileOptions o@TxOpts {toAmountFmt = pat} = do
-  re <- compileRegex True pat
-  return $ o {toAmountFmt = re}
-
-compileMatch :: StatementParser T.Text -> AppExcept MatchRe
-compileMatch m@StatementParser {spDesc, spOther} = do
-  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 -> AppExcept (Text, Regex)
-compileRegex groups pat = case res of
-  Right re -> return (pat, re)
-  Left _ -> throwError $ AppException [RegexError pat]
-  where
-    res =
-      compile
-        (blankCompOpt {newSyntax = True})
-        (blankExecOpt {captureGroups = groups})
-        pat
-
-matchMaybe :: T.Text -> Regex -> AppExcept Bool
-matchMaybe q re = case execute re q of
-  Right res -> return $ isJust res
-  Left _ -> throwError $ AppException [RegexError "this should not happen"]
-
-matchGroupsMaybe :: T.Text -> Regex -> [T.Text]
-matchGroupsMaybe q re = case regexec re q of
-  Right Nothing -> []
-  Right (Just (_, _, _, xs)) -> xs
-  -- this should never fail as regexec always returns Right
-  Left _ -> []
-
-parseDecimal :: MonadFail m => (T.Text, Regex) -> T.Text -> m Decimal
-parseDecimal (pat, re) s = case matchGroupsMaybe s re of
-  [sign, x, ""] -> Decimal 0 . uncurry (*) <$> readWhole sign x
-  [sign, x, y] -> do
-    d <- readT "decimal" y
-    let p = T.length y
-    (k, w) <- readWhole sign x
-    return $ Decimal (fromIntegral p) (k * (w * (10 ^ p) + d))
-  _ -> msg "malformed decimal"
-  where
-    readT what t = case readMaybe $ T.unpack t of
-      Just d -> return $ fromInteger d
-      _ -> msg $ T.unwords ["could not parse", what, singleQuote t]
-    msg :: MonadFail m => T.Text -> m a
-    msg m =
-      fail $
-        T.unpack $
-          T.unwords [m, "-", keyVals [("pattern", pat), ("query", s)]]
-    readSign x
-      | x == "-" = return (-1)
-      | x == "+" || x == "" = return 1
-      | otherwise = msg $ T.append "invalid sign: " x
-    readWhole sign x = do
-      w <- readT "whole number" x
-      k <- readSign sign
-      return (k, w)
-
-historyName :: BudgetName
-historyName = BudgetName "history"
+groupByKey :: Ord k => [(k, v)] -> [(k, [v])]
+groupByKey = M.toList . M.fromListWith (++) . fmap (second (: []))
--- a/lib/Internal/Types/Database.hs
+++ b/lib/Internal/Types/Database.hs
@ -7,12 +7,9 @@
 -- | Types corresponding to the database model
 module Internal.Types.Database where

-import Data.Csv (FromField)
 import Database.Persist.Sql hiding (Desc, In, Statement)
 import Database.Persist.TH
-import Internal.Types.Dhall
 import RIO
-import qualified RIO.NonEmpty as NE
 import qualified RIO.Text as T
 import RIO.Time

@ -20,94 +17,51 @@ share
  [mkPersist sqlSettings, mkMigrate "migrateAll"]
  [persistLowerCase|
 CommitR sql=commits
-    hash CommitHash
+    hash Int
    type ConfigType
-    UniqueCommitHash hash
-    deriving Show Eq Ord
-ConfigStateR sql=config_state
-    historySpan HistorySpan
-    budgetSpan BudgetSpan
-    deriving Show
+    deriving Show Eq
 CurrencyR sql=currencies
-    symbol CurID
+    symbol T.Text
    fullname T.Text
-    precision Precision
-    UniqueCurrencySymbol symbol
-    UniqueCurrencyFullname fullname
-    deriving Show Eq Ord
+    precision Int
+    deriving Show Eq
 TagR sql=tags
-    symbol TagID
+    symbol T.Text
    fullname T.Text
-    UniqueTagSymbol symbol
-    UniqueTagFullname fullname
-    deriving Show Eq Ord
+    deriving Show Eq
 AccountR sql=accounts
    name T.Text
-    fullpath AcntPath
+    fullpath T.Text
    desc T.Text
-    sign AcntSign
-    leaf Bool
-    UniqueAccountFullpath fullpath
-    deriving Show Eq Ord
-AccountPathR sql=account_paths
-    parent AccountRId 
-    child AccountRId 
-    depth Int
-    deriving Show Eq Ord
-TransactionR sql=transactions
-    commit CommitRId 
-    date Day
-    description TxDesc
-    budgetName BudgetName
-    priority Int
    deriving Show Eq
-EntrySetR sql=entry_sets
-    transaction TransactionRId 
-    currency CurrencyRId 
-    index EntrySetIndex
-    rebalance Bool
+AccountPathR sql=account_paths
+    parent AccountRId OnDeleteCascade
+    child AccountRId OnDeleteCascade
+    depth Int
+    deriving Show Eq
+TransactionR sql=transactions
+    commit CommitRId OnDeleteCascade
+    date Day
+    description T.Text
    deriving Show Eq
 EntryR sql=entries
-    entryset EntrySetRId  
-    account AccountRId 
+    transaction TransactionRId OnDeleteCascade
+    currency CurrencyRId OnDeleteCascade
+    account AccountRId OnDeleteCascade
    memo T.Text
    value Rational
-    index EntryIndex
-    cachedValue (Maybe Rational)
-    cachedType (Maybe TransferType)
-    cachedLink (Maybe EntryIndex)
    deriving Show Eq
 TagRelationR sql=tag_relations
-    entry EntryRId 
-    tag TagRId
+    entry EntryRId OnDeleteCascade
+    tag TagRId OnDeleteCascade
+BudgetLabelR sql=budget_labels
+    entry EntryRId OnDeleteCascade
+    budgetName T.Text
    deriving Show Eq
 |]

-newtype EntrySetIndex = EntrySetIndex {unEntrySetIndex :: Int}
-  deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)
-
-newtype EntryIndex = EntryIndex {unEntryIndex :: Int}
-  deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)
-
-newtype TxDesc = TxDesc {unTxDesc :: T.Text}
-  deriving newtype (Show, Eq, Ord, PersistField, PersistFieldSql, FromField)
-
-newtype Precision = Precision {unPrecision :: Word8}
-  deriving newtype (Eq, Ord, Num, Show, Real, Enum, Integral, PersistField, PersistFieldSql)
-
-type DaySpan = (Day, Int)
-
-newtype CommitHash = CommitHash {unCommitHash :: Int}
-  deriving newtype (Show, Eq, Num, Ord, PersistField, PersistFieldSql)
-
-newtype BudgetSpan = BudgetSpan {unBSpan :: DaySpan}
-  deriving newtype (Show, Eq, PersistField, PersistFieldSql)
-
-newtype HistorySpan = HistorySpan {unHSpan :: DaySpan}
-  deriving newtype (Show, Eq, PersistField, PersistFieldSql)
-
-data ConfigType = CTBudget | CTHistoryTransfer | CTHistoryStatement
-  deriving (Eq, Show, Read, Enum, Ord)
+data ConfigType = CTBudget | CTManual | CTImport
+  deriving (Eq, Show, Read, Enum)

 instance PersistFieldSql ConfigType where
  sqlType _ = SqlString
@ -115,61 +69,7 @@ instance PersistFieldSql ConfigType where
 instance PersistField ConfigType where
  toPersistValue = PersistText . T.pack . show

+  -- TODO these error messages *might* be good enough?
  fromPersistValue (PersistText v) =
    maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
-  fromPersistValue _ = Left "not a string"
-
-data AcntSign = Credit | Debit
-  deriving (Show, Eq, Ord)
-
-instance PersistFieldSql AcntSign where
-  sqlType _ = SqlInt64
-
-instance PersistField AcntSign where
-  toPersistValue Debit = PersistInt64 1
-  toPersistValue Credit = PersistInt64 (-1)
-
-  fromPersistValue (PersistInt64 1) = Right Debit
-  fromPersistValue (PersistInt64 (-1)) = Right Credit
-  fromPersistValue (PersistInt64 v) = Left $ "could not convert to account sign: " <> tshow v
-  fromPersistValue _ = Left "not an Int64"
-
-data AcntType
-  = AssetT
-  | EquityT
-  | ExpenseT
-  | IncomeT
-  | LiabilityT
-  deriving (Show, Eq, Ord, Hashable, Generic, Read)
-
-atName :: AcntType -> T.Text
-atName AssetT = "asset"
-atName EquityT = "equity"
-atName ExpenseT = "expense"
-atName IncomeT = "income"
-atName LiabilityT = "liability"
-
-data AcntPath = AcntPath
-  { apType :: !AcntType
-  , apChildren :: ![T.Text]
-  }
-  deriving (Eq, Ord, Show, Hashable, Generic, Read)
-
-acntPath2Text :: AcntPath -> T.Text
-acntPath2Text = T.intercalate "/" . NE.toList . acntPath2NonEmpty
-
-acntPath2NonEmpty :: AcntPath -> NonEmpty T.Text
-acntPath2NonEmpty (AcntPath t cs) = atName t :| cs
-
-instance PersistFieldSql AcntPath where
-  sqlType _ = SqlString
-
-instance PersistField AcntPath where
-  toPersistValue = PersistText . acntPath2Text
-
-  fromPersistValue (PersistText v) = case T.split (== '/') v of
-    [] -> Left "path is empty"
-    (x : xs) -> case readMaybe $ T.unpack x of
-      Just t -> Right $ AcntPath t xs
-      _ -> Left "could not get account type"
-  fromPersistValue _ = Left "not a string"
+  fromPersistValue _ = Left "wrong type"
--- a/lib/Internal/Types/Dhall.hs
+++ b/lib/Internal/Types/Dhall.hs
@ -19,9 +19,9 @@ import Language.Haskell.TH.Syntax (Lift)
 import RIO
 import qualified RIO.Map as M
 import qualified RIO.Text as T
+import RIO.Time
 import Text.Regex.TDFA

-- TODO find a way to conventiently make TaggedAcnt use my newtypes
 makeHaskellTypesWith
  (defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False})
  [ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
@ -33,14 +33,13 @@ makeHaskellTypesWith
  , MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
  , MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
  , MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
-  , MultipleConstructors "LinkedEntryNumGetter" "(./dhall/Types.dhall).LinkedEntryNumGetter"
-  , MultipleConstructors "TransferType" "(./dhall/Types.dhall).TransferType"
+  , 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 "LinkedNumGetter" "LinkedNumGetter" "(./dhall/Types.dhall).LinkedNumGetter.Type"
  , SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
  , SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag"
-  , SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt.Type"
+  , 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"
@ -49,17 +48,12 @@ makeHaskellTypesWith
  , SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type"
  , SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type"
  , SingleConstructor "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type"
-  , SingleConstructor
-      "Amount"
-      "Amount"
-      "\\(w : Type) -> \\(v : Type) -> ((./dhall/Types.dhall).Amount w v).Type"
-  , SingleConstructor
-      "TxOpts"
-      "TxOpts"
-      "\\(re : Type) -> ((./dhall/Types.dhall).TxOpts_ re).Type"
+  , SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount"
  , SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.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 "Entry" "Entry" "(./dhall/Types.dhall).Entry"
  , SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue"
@ -67,9 +61,14 @@ makeHaskellTypesWith
  , SingleConstructor "TaxProgression" "TaxProgression" "(./dhall/Types.dhall).TaxProgression"
  , SingleConstructor "TaxValue" "TaxValue" "(./dhall/Types.dhall).TaxValue"
  , SingleConstructor "PosttaxValue" "PosttaxValue" "(./dhall/Types.dhall).PosttaxValue"
-  , SingleConstructor "TransferValue" "TransferValue" "(./dhall/Types.dhall).TransferValue.Type"
+  , 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_"
+  -- , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
+  -- SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
  ]

 deriveProduct
@ -96,9 +95,9 @@ deriveProduct
  , "DateMatcher"
  , "ValMatcher"
  , "YMDMatcher"
+  , "BudgetCurrency"
+  , "Exchange"
  , "EntryNumGetter"
-  , "LinkedNumGetter"
-  , "LinkedEntryNumGetter"
  , "TemporalScope"
  , "SqlConfig"
  , "PretaxValue"
@ -107,8 +106,8 @@ deriveProduct
  , "TaxProgression"
  , "TaxMethod"
  , "PosttaxValue"
-  , "TransferValue"
-  , "TransferType"
+  , "BudgetTransferValue"
+  , "BudgetTransferType"
  , "Period"
  , "PeriodType"
  , "HourlyPeriod"
@ -179,24 +178,22 @@ deriving instance Ord DatePat

 deriving instance Hashable DatePat

-type PairedTransfer = Transfer TaggedAcnt CurID DatePat TransferValue
+type BudgetTransfer =
+  Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue

-deriving instance Hashable PairedTransfer
+deriving instance Hashable BudgetTransfer

-deriving instance Generic PairedTransfer
+deriving instance Generic BudgetTransfer

-deriving instance FromDhall PairedTransfer
-
-newtype BudgetName = BudgetName {unBudgetName :: T.Text}
-  deriving newtype (Show, Eq, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
+deriving instance FromDhall BudgetTransfer

 data Budget = Budget
-  { bgtLabel :: BudgetName
+  { bgtLabel :: Text
  , bgtIncomes :: [Income]
  , bgtPretax :: [MultiAllocation PretaxValue]
  , bgtTax :: [MultiAllocation TaxValue]
  , bgtPosttax :: [MultiAllocation PosttaxValue]
-  , bgtTransfers :: [PairedTransfer]
+  , bgtTransfers :: [BudgetTransfer]
  , bgtShadowTransfers :: [ShadowTransfer]
  , bgtInterval :: !(Maybe Interval)
  }
@ -215,28 +212,15 @@ deriving instance Hashable PosttaxValue

 deriving instance Hashable Budget

-deriving instance Hashable TransferValue
+deriving instance Hashable BudgetTransferValue

-deriving instance Hashable TransferType
-
-deriving instance Read TransferType
-
-instance PersistFieldSql TransferType where
-  sqlType _ = SqlString
-
-instance PersistField TransferType where
-  toPersistValue = PersistText . T.pack . show
-
-  fromPersistValue (PersistText v) =
-    maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
-  fromPersistValue _ = Left "wrong type"
+deriving instance Hashable BudgetTransferType

 deriving instance Hashable TaggedAcnt

 deriving instance Ord TaggedAcnt

-newtype CurID = CurID {unCurID :: T.Text}
-  deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
+type CurID = T.Text

 data Income = Income
  { incGross :: Double
@ -248,7 +232,6 @@ data Income = Income
  , incFrom :: TaggedAcnt
  , incToBal :: TaggedAcnt
  , incPayPeriod :: !Period
-  , incPriority :: !Int
  }

 deriving instance Hashable HourlyPeriod
@ -267,13 +250,20 @@ deriving instance (FromDhall v, FromDhall w) => FromDhall (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)

 deriving instance (Eq w, Eq v) => Eq (Amount w v)

+deriving instance Hashable Exchange
+
+deriving instance Hashable BudgetCurrency
+
 data Allocation w v = Allocation
  { alloTo :: TaggedAcnt
  , alloAmts :: [Amount w v]
+  , alloCur :: CurID
  }
  deriving (Eq, Show, Generic, Hashable)

@ -350,10 +340,6 @@ instance Ord DateMatcher where

 deriving instance Hashable EntryNumGetter

-deriving instance Hashable LinkedNumGetter
-
-deriving instance Hashable LinkedEntryNumGetter
-
 -------------------------------------------------------------------------------
 -- top level type with fixed account tree to unroll the recursion in the dhall
 -- account tree type
@ -376,7 +362,7 @@ data AccountRoot_ a = AccountRoot_
  , arIncome :: ![a]
  , arLiabilities :: ![a]
  }
-  deriving (Generic, Hashable)
+  deriving (Generic)

 type AccountRootF = AccountRoot_ (Fix AccountTreeF)

@ -385,8 +371,10 @@ deriving instance FromDhall AccountRootF
 type AccountRoot = AccountRoot_ AccountTree

 data Config_ a = Config_
-  { scope :: !TemporalScope
+  { global :: !TemporalScope
+  , budget :: ![Budget]
  , currencies :: ![Currency]
+  , statements :: ![History]
  , accounts :: !a
  , tags :: ![Tag]
  , sqlConfig :: !SqlConfig
@ -416,44 +404,55 @@ instance FromDhall a => FromDhall (Config_ a)
 -- dhall type overrides (since dhall can't import types with parameters...yet)

 -- TODO newtypes for these?
-newtype AcntID = AcntID {unAcntID :: T.Text}
-  deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
+type AcntID = T.Text

-newtype TagID = TagID {unTagID :: T.Text}
-  deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
+type TagID = T.Text
+
+type HistTransfer = Transfer AcntID CurID DatePat Double
+
+deriving instance Generic HistTransfer
+
+deriving instance Hashable HistTransfer
+
+deriving instance FromDhall HistTransfer

 data History
-  = HistTransfer !PairedTransfer
+  = HistTransfer !HistTransfer
  | HistStatement !Statement
  deriving (Eq, Generic, Hashable, FromDhall)

-type EntryGetter n = Entry EntryAcnt n TagID
+type EntryGetter = Entry EntryAcnt (Maybe EntryNumGetter) EntryCur TagID

-type FromEntryGetter = EntryGetter EntryNumGetter
+instance FromDhall EntryGetter

-type ToEntryGetter = EntryGetter LinkedEntryNumGetter
+deriving instance (Show a, Show c, Show v, Show t) => Show (Entry a v c t)

-instance FromDhall FromEntryGetter
+deriving instance Generic (Entry a v c t)

-instance FromDhall ToEntryGetter
+deriving instance (Hashable a, Hashable v, Hashable c, Hashable t) => Hashable (Entry a v c t)

-deriving instance (Show a, Show v, Show t) => Show (Entry a v t)
+deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Entry a v c t)

-deriving instance Generic (Entry a v t)
+data Tx s = Tx
+  { txDescr :: !T.Text
+  , txDate :: !Day
+  , txEntries :: ![s]
+  }
+  deriving (Generic)

-deriving instance (Hashable a, Hashable v, Hashable t) => Hashable (Entry a v t)
+type ExpTx = Tx EntryGetter

-deriving instance (Eq a, Eq v, Eq t) => Eq (Entry a v t)
+instance FromDhall ExpTx

-deriving instance Eq a => Eq (TxOpts a)
-
-deriving instance Generic (TxOpts a)
-
-deriving instance Hashable a => Hashable (TxOpts a)
-
-deriving instance FromDhall a => FromDhall (TxOpts a)
-
-deriving instance Show a => Show (TxOpts a)
+data TxOpts re = TxOpts
+  { toDate :: !T.Text
+  , toAmount :: !T.Text
+  , toDesc :: !T.Text
+  , toOther :: ![T.Text]
+  , toDateFmt :: !T.Text
+  , toAmountFmt :: !re
+  }
+  deriving (Eq, Generic, Hashable, Show, FromDhall)

 data Statement = Statement
  { stmtPaths :: ![FilePath]
@ -462,7 +461,7 @@ data Statement = Statement
  , stmtTxOpts :: !(TxOpts T.Text)
  , stmtSkipLines :: !Natural
  }
-  deriving (Eq, Hashable, Generic, FromDhall, Show)
+  deriving (Eq, Hashable, Generic, FromDhall)

 -- | the value of a field in entry (text version)
 -- can either be a raw (constant) value, a lookup from the record, or a map
@ -472,7 +471,7 @@ data EntryTextGetter t
  | LookupT !T.Text
  | MapT !(FieldMap T.Text t)
  | Map2T !(FieldMap (T.Text, T.Text) t)
-  deriving (Eq, Generic, Hashable, Show, FromDhall, Functor)
+  deriving (Eq, Generic, Hashable, Show, FromDhall)

 type EntryCur = EntryTextGetter CurID

@ -504,32 +503,10 @@ data FieldMatcher re

 deriving instance Show (FieldMatcher T.Text)

-data TxHalfGetter e = TxHalfGetter
-  { thgAcnt :: !EntryAcnt
-  , thgComment :: !T.Text
-  , thgTags :: ![TagID]
-  , thgEntries :: ![e]
-  }
-  deriving (Eq, Generic, Hashable, Show)
-
-deriving instance FromDhall (TxHalfGetter FromEntryGetter)
-
-deriving instance FromDhall (TxHalfGetter ToEntryGetter)
-
-data TxSubGetter = TxSubGetter
-  { tsgFrom :: !(TxHalfGetter FromEntryGetter)
-  , tsgTo :: !(TxHalfGetter ToEntryGetter)
-  , tsgValue :: !EntryNumGetter
-  , tsgCurrency :: !EntryCur
-  }
-  deriving (Eq, Generic, Hashable, Show, FromDhall)
-
 data TxGetter = TxGetter
-  { tgFrom :: !(TxHalfGetter FromEntryGetter)
-  , tgTo :: !(TxHalfGetter ToEntryGetter)
-  , tgCurrency :: !EntryCur
-  , tgOtherEntries :: ![TxSubGetter]
-  , tgScale :: !Double
+  { tgCurrency :: !EntryCur
+  , tgAcnt :: !EntryAcnt
+  , tgEntries :: ![EntryGetter]
  }
  deriving (Eq, Generic, Hashable, Show, FromDhall)

--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE UndecidableInstances #-}

@ -11,11 +12,11 @@ module Internal.Types.Main
 where

 import Control.Monad.Except
-import Data.Decimal
 import Database.Persist.Sql hiding (Desc, In, Statement)
 import Dhall hiding (embed, maybe)
 import Internal.Types.Database
 import Internal.Types.Dhall
+import Language.Haskell.TH.Syntax (Lift)
 import RIO
 import qualified RIO.Map as M
 import qualified RIO.NonEmpty as NE
@ -26,139 +27,99 @@ import Text.Regex.TDFA
 --------------------------------------------------------------------------------
 -- database cache types

-type MonadFinance = MonadReader ConfigState
-
-data DeleteTxs = DeleteTxs
-  { dtTxs :: ![TransactionRId]
-  , dtEntrySets :: ![EntrySetRId]
-  , dtEntries :: ![EntryRId]
-  , dtTagRelations :: ![TagRelationRId]
-  }
-  deriving (Show)
-
-type CDOps c d = CRUDOps [c] () () [d]
-
-- TODO split the entry stuff from the account metadata stuff
-data ConfigState = ConfigState
-  { csCurrencies :: !(CDOps (Entity CurrencyR) CurrencyRId)
-  , csAccounts :: !(CDOps (Entity AccountR) AccountRId)
-  , csPaths :: !(CDOps (Entity AccountPathR) AccountPathRId)
-  , csTags :: !(CDOps (Entity TagR) TagRId)
-  , csBudgets :: !(CRUDOps [Budget] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs)
-  , csHistTrans :: !(CRUDOps [PairedTransfer] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs)
-  , csHistStmts :: !(CRUDOps [Statement] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs)
-  , csAccountMap :: !AccountMap
-  , csCurrencyMap :: !CurrencyMap
-  , csTagMap :: !TagMap
-  , csBudgetScope :: !BudgetSpan
-  , csHistoryScope :: !HistorySpan
-  }
-  deriving (Show)
-
-data ExistingConfig = ExistingConfig
-  { ecAccounts :: !(Set AccountRId)
-  , ecTags :: !(Set TagRId)
-  , ecCurrencies :: !(Set CurrencyRId)
+data ConfigHashes = ConfigHashes
+  { chIncome :: ![Int]
+  , chExpense :: ![Int]
+  , chManual :: ![Int]
+  , chImport :: ![Int]
  }

-type AccountMap = M.Map AcntID (AccountRId, AcntType)
+type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)

-data CurrencyPrec = CurrencyPrec {cpID :: !CurrencyRId, cpPrec :: !Precision}
-  deriving (Show)
-
-type CurrencyMap = M.Map CurID CurrencyPrec
+type CurrencyMap = M.Map CurID (CurrencyRId, Natural)

 type TagMap = M.Map TagID TagRId

-data CRUDOps c r u d = CRUDOps
-  { coCreate :: !c
-  , coRead :: !r
-  , coUpdate :: !u
-  , coDelete :: !d
+data DBState = DBState
+  { kmCurrency :: !CurrencyMap
+  , kmAccount :: !AccountMap
+  , kmTag :: !TagMap
+  , kmBudgetInterval :: !DaySpan
+  , kmStatementInterval :: !DaySpan
+  , kmNewCommits :: ![Int]
  }
-  deriving (Show)

-data CachedEntry
-  = CachedLink EntryIndex LinkScale
-  | CachedBalance Decimal
-  | CachedPercent Double
-
-data ReadEntry = ReadEntry
-  { reCurrency :: !CurrencyRId
-  , reAcnt :: !AccountRId
-  , reValue :: !Decimal
-  , reDate :: !Day
-  , rePriority :: !Int
-  , reBudget :: !BudgetName
+data DBUpdates = DBUpdates
+  { duOldCommits :: ![Int]
+  , duNewTagIds :: ![Entity TagR]
+  , duNewAcntPaths :: ![AccountPathR]
+  , duNewAcntIds :: ![Entity AccountR]
+  , duNewCurrencyIds :: ![Entity CurrencyR]
  }
-  deriving (Show)

-data UpdateEntry i v = UpdateEntry
-  { ueID :: !i
-  , ueAcnt :: !AccountRId
-  , ueValue :: !v
-  , ueIndex :: !EntryIndex
-  }
-  deriving (Show)
+type CurrencyM = Reader CurrencyMap

-deriving instance Functor (UpdateEntry i)
+type KeyEntry = Entry AccountRId Rational CurrencyRId TagRId

-newtype LinkScale = LinkScale {unLinkScale :: Double}
-  deriving newtype (Num, Show, Eq, Ord, Real, Fractional)
+type KeyTx = Tx KeyEntry

-newtype StaticValue = StaticValue {unStaticValue :: Decimal}
-  deriving newtype (Num, Show)
+type TreeR = Tree ([T.Text], AccountRId)

-data EntryValueUnk = EVBalance Decimal | EVPercent Double deriving (Show)
+type MonadFinance = MonadReader DBState

-type UEUnk = UpdateEntry EntryRId EntryValueUnk
-
-type UELink = UpdateEntry EntryRId LinkScale
-
-type UEBlank = UpdateEntry EntryRId ()
-
-type UE_RO = UpdateEntry () StaticValue
-
-type UEBalanced = UpdateEntry EntryRId StaticValue
-
-data UpdateEntrySet f t = UpdateEntrySet
-  { utFrom0 :: !f
-  , utTo0 :: !UEBlank
-  , utFromUnk :: ![(UEUnk, [UELink])]
-  , utToUnk :: ![UEUnk]
-  , utFromRO :: ![UE_RO]
-  , utToRO :: ![UE_RO]
-  , utCurrency :: !CurrencyRId
-  , utDate :: !Day
-  , utTotalValue :: !t
-  , utBudget :: !BudgetName
-  , utPriority :: !Int
-  }
-  deriving (Show)
-
-type TotalUpdateEntrySet = UpdateEntrySet (UEBlank, [UELink]) Decimal
-
-type FullUpdateEntrySet = UpdateEntrySet (Either UE_RO (UEUnk, [UELink])) ()
-
-data EntryCRU
-  = ToUpdate (Either TotalUpdateEntrySet FullUpdateEntrySet)
-  | ToRead ReadEntry
-  | ToInsert (Tx CommitR)
+askDBState :: MonadFinance m => (DBState -> a) -> m a
+askDBState = asks

 -------------------------------------------------------------------------------
 -- misc

+data AcntType
+  = AssetT
+  | EquityT
+  | ExpenseT
+  | IncomeT
+  | LiabilityT
+  deriving (Show, Eq, Ord, Lift, Hashable, Generic, Read, FromDhall)
+
+atName :: AcntType -> T.Text
+atName AssetT = "asset"
+atName EquityT = "equity"
+atName ExpenseT = "expense"
+atName IncomeT = "income"
+atName LiabilityT = "liability"
+
+data AcntPath = AcntPath
+  { apType :: !AcntType
+  , apChildren :: ![T.Text]
+  }
+  deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall)
+
 data TxRecord = TxRecord
  { trDate :: !Day
-  , trAmount :: !Decimal
-  , trDesc :: !TxDesc
+  , trAmount :: !Rational
+  , trDesc :: !T.Text
  , trOther :: !(M.Map T.Text T.Text)
  , trFile :: !FilePath
  }
  deriving (Show, Eq, Ord)

+type DaySpan = (Day, Natural)
+
+data Keyed a = Keyed
+  { kKey :: !Int64
+  , kVal :: !a
+  }
+  deriving (Eq, Show, Functor)
+
 data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show)

+data AcntSign = Credit | Debit
+  deriving (Show)
+
+sign2Int :: AcntSign -> Int
+sign2Int Debit = 1
+sign2Int Credit = 1
+
 accountSign :: AcntType -> AcntSign
 accountSign AssetT = Debit
 accountSign ExpenseT = Debit
@ -166,81 +127,21 @@ accountSign IncomeT = Credit
 accountSign LiabilityT = Credit
 accountSign EquityT = Credit

-data HalfEntrySet v0 vN = HalfEntrySet
-  { hesPrimary :: !(Entry AcntID v0 TagID)
-  , hesOther :: ![Entry AcntID vN TagID]
-  }
-  deriving (Show)
+type RawEntry = Entry AcntID (Maybe Rational) CurID TagID

-data EntrySet v0 vp0 vpN vtN = EntrySet
-  { esTotalValue :: !v0
-  , esCurrency :: !CurrencyRId
-  , esFrom :: !(HalfEntrySet vp0 vpN)
-  , esTo :: !(HalfEntrySet () vtN)
-  }
-  deriving (Show)
+type BalEntry = Entry AcntID Rational CurID TagID

-type TotalEntrySet v0 vpN vtN = EntrySet v0 () vpN vtN
+type RawTx = Tx RawEntry

-type FullEntrySet vp0 vpN vtN = EntrySet () vp0 vpN vtN
-
-type PrimaryEntrySet = TotalEntrySet Decimal EntryValue EntryLink
-
-type SecondayEntrySet = FullEntrySet EntryValue EntryValue EntryLink
-
-type TransferEntrySet = SecondayEntrySet
-
-type ShadowEntrySet = TotalEntrySet Double EntryValue EntryLink
-
-data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text
-  deriving (Eq, Ord, Show)
-
-data Tx k = Tx
-  { txDescr :: !TxDesc
-  , txDate :: !Day
-  , txPriority :: !Int
-  , txPrimary :: !(Either PrimaryEntrySet TransferEntrySet)
-  , txOther :: ![Either SecondayEntrySet ShadowEntrySet]
-  , txCommit :: !k
-  , txBudget :: !BudgetName
-  }
-  deriving (Generic, Show)
-
-data InsertEntry = InsertEntry
-  { ieCached :: !(Maybe CachedEntry)
-  , ieEntry :: !(Entry AccountRId Decimal TagRId)
-  }
-
-data InsertEntrySet = InsertEntrySet
-  { iesCurrency :: !CurrencyRId
-  , iesFromEntries :: !(NonEmpty InsertEntry)
-  , iesToEntries :: !(NonEmpty InsertEntry)
-  }
-
-data InsertTx = InsertTx
-  { itxDescr :: !TxDesc
-  , itxDate :: !Day
-  , itxPriority :: !Int
-  , itxEntrySets :: !(NonEmpty InsertEntrySet)
-  , itxCommit :: !CommitR
-  , itxBudget :: !BudgetName
-  }
-  deriving (Generic)
-
-data EntryValue_ a = EntryValue_ TransferType a
-  deriving (Show, Functor, Foldable, Traversable)
-
-data EntryValue = EntryFixed Decimal | EntryPercent Double | EntryBalance Decimal
-  deriving (Show, Eq, Ord)
-
-data EntryLink = LinkValue EntryValue | LinkIndex LinkedNumGetter
-  deriving (Show)
+type BalTx = Tx BalEntry

 data MatchRes a = MatchPass !a | MatchFail | MatchSkip

 --------------------------------------------------------------------------------
 -- exception types

+data BalanceType = TooFewEntries | NotOneBlank deriving (Show)
+
 data MatchType = MatchNumeric | MatchText deriving (Show)

 data EntryIDType = AcntField | CurField | TagField deriving (Show)
@ -252,49 +153,48 @@ data LookupSuberr
  | DBKey !EntryIDType
  deriving (Show)

+data AllocationSuberr
+  = NoAllocations
+  | ExceededTotal
+  | MissingBlank
+  | TooManyBlanks
+  deriving (Show)
+
 data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show)

-data DBLinkSubError
-  = DBLinkNoScale
-  | DBLinkNoValue
-  | DBLinkInvalidValue !Rational !Bool
-  | DBLinkInvalidBalance
-  | DBLinkInvalidPercent
-  deriving (Show)
-
-data DBSubError
-  = DBShouldBeEmpty
-  | DBMultiScope
-  | DBUpdateUnbalanced
-  | DBLinkError !EntryRId !DBLinkSubError
-  deriving (Show)
-
-data AppError
+data InsertError
  = RegexError !T.Text
  | MatchValPrecisionError !Natural !Natural
-  | AccountTypeError !AcntID !(NE.NonEmpty AcntType)
-  | StatementIOError !T.Text
+  | AccountError !AcntID !(NE.NonEmpty AcntType)
+  | InsertIOError !T.Text
  | ParseError !T.Text
-  | ConversionError !T.Text !Bool
+  | ConversionError !T.Text
  | LookupError !LookupSuberr !T.Text
-  | DatePatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
+  | BalanceError !BalanceType !CurID ![RawEntry]
+  | IncomeError !Day !T.Text !Rational
+  | PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
  | DaySpanError !Gregorian !(Maybe Gregorian)
  | StatementError ![TxRecord] ![MatchRe]
  | PeriodError !Day !Day
-  | LinkError !EntryIndex !EntryIndex
-  | DBError !DBSubError
  deriving (Show)

-newtype AppException = AppException [AppError]
-  deriving (Show, Semigroup) via [AppError]
+newtype InsertException = InsertException [InsertError]
+  deriving (Show, Semigroup) via [InsertError]

-instance Exception AppException
+instance Exception InsertException

-type MonadAppError = MonadError AppException
+type MonadInsertError = MonadError InsertException

-type AppExceptT = ExceptT AppException
+type InsertExceptT = ExceptT InsertException

-type AppExcept = AppExceptT Identity
+type InsertExcept = InsertExceptT Identity
+
+data XGregorian = XGregorian
+  { xgYear :: !Int
+  , xgMonth :: !Int
+  , xgDay :: !Int
+  , xgDayOfWeek :: !Int
+  }

 type MatchRe = StatementParser (T.Text, Regex)

--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
--- a/package.yaml
+++ b/package.yaml
@ -87,7 +87,6 @@ dependencies:
 - filepath
 - mtl
 - persistent-mtl >= 0.3.0.0
- Decimal >= 0.5.2

 library:
  source-dirs: lib/