FIX actually the multi typo

FIX multi date pattern bug
FIX include missing type
2024-03-16 20:33:12 -04:00 · 2024-03-09 18:07:00 -05:00 · 2023-10-14 20:28:45 -04:00 · 2023-08-19 20:56:40 -04:00 · 2023-08-16 22:24:20 -04:00 · 2023-08-16 21:12:11 -04:00
12 changed files with 2919 additions and 1693 deletions
--- a/app/Main.hs
+++ b/app/Main.hs
@ -2,21 +2,21 @@

 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 Database.Persist.Monad
-import Dhall hiding (double, record)
-import Internal.Budget
+import qualified Database.Esqueleto.Experimental as E
+import qualified Dhall hiding (double, record)
 import Internal.Database
-import Internal.History
 import Internal.Types.Main
 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 ()
@ -30,14 +30,26 @@ main = parse =<< execParser o
            <> header "pwncash - your budget, your life"
        )

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

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

 configFile :: Parser FilePath
 configFile =
@ -55,7 +67,7 @@ options =
    <|> getConf dumpCurrencies
    <|> getConf dumpAccounts
    <|> getConf dumpAccountKeys
-    <|> getConf sync
+    <|> getConf sync_
  where
    getConf m = Options <$> configFile <*> m

@ -96,14 +108,43 @@ dumpAccountKeys =
        <> help "Dump all account keys/aliases"
    )

-sync :: Parser Mode
-sync =
+sync_ :: Parser Mode
+sync_ =
  flag'
    Sync
    ( long "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
@ -112,7 +153,8 @@ 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) = runSync c
+parse (Options c (Sync SyncOptions {syncBudgets, syncHistories, syncThreads})) =
+  runSync syncThreads c syncBudgets syncHistories

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

-runSync :: FilePath -> IO ()
-runSync c = do
+runSync :: Int -> FilePath -> [FilePath] -> [FilePath] -> IO ()
+runSync threads c bs hs = do
+  setNumCapabilities threads
  config <- readConfig c
-  let (hTs, hSs) = splitHistory $ statements config
+  (bs', hs') <-
+    fmap (bimap concat concat . partitionEithers) $
+      pooledMapConcurrentlyN threads (bimapM readDhall readDhall) $
+        (Left <$> bs) ++ (Right <$> hs)
  pool <- runNoLoggingT $ mkPool $ sqlConfig config
-  handle err $ do
-    -- _ <- askLoggerIO
-
-    -- get the current DB state
-    (state, updates) <- runSqlQueryT pool $ do
-      runMigration migrateAll
-      liftIOExceptT $ getDBState config
-
-    -- read desired statements from disk
-    bSs <-
-      flip runReaderT state $
-        catMaybes <$> mapErrorsIO (readHistStmt root) hSs
-
-    -- update the DB
-    runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
-      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
-        mapM_ (uncurry insertHistStmt) bSs
-        combineError hTransRes bgtRes $ \_ _ -> ()
-      rerunnableIO $ fromEither res
+  setNumCapabilities 1
+  handle err $ sync pool root config bs' hs'
  where
    root = takeDirectory c
-    err (InsertException es) = do
+    err (AppException es) = do
      liftIO $ mapM_ TI.putStrLn $ concatMap showError es
      exitFailure

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

-let TxOpts =
-    {- Additional metadata to use when parsing a statement -}
-      { Type =
+let TxAmount1_ =
+      \(re : Type) ->
+        { a1Column : Text
+        , a1Fmt :
+            {-
+            Format of the amount field. Must include three fields for the
+            sign, numerator, and denominator of the amount.
+            -}
+            re
+        }
+
+let TxAmount1 =
+      { Type = TxAmount1_ Text
+      , default = { a1Column = "Amount", a1Fmt = "([-+])?([0-9\\.]+)" }
+      }
+
+let TxAmount2_ =
+      \(re : Type) ->
+        { a2Positive : Text
+        , a2Negative : Text
+        , a2Fmt :
+            {-
+            Format of the amount field. Must include two fields for the
+            numerator and denominator of the amount.
+            -}
+            re
+        }
+
+let TxAmount2 =
+      { Type = TxAmount2_ Text
+      , default =
+        { a2Positive = "Deposit"
+        , a2Negative = "Withdraw"
+        , a2Fmt = "([0-9\\.]+)"
+        }
+      }
+
+let TxAmountSpec_ =
+      \(re : Type) ->
+        < AmountSingle : TxAmount1_ re | AmountDual : TxAmount2_ re >
+
+let TxOpts_ =
+    {-
+    Additional metadata to use when parsing a statement
+    -}
+      \(re : Type) ->
        { toDate :
            {-
            Column title for date
@ -290,7 +333,7 @@ let TxOpts =
            {-
            Column title for amount
            -}
-              Text
+            TxAmountSpec_ re
        , toDesc :
            {-
            Column title for description
@ -308,19 +351,51 @@ let TxOpts =
            Data.Time.Format.formattime Haskell function.
            -}
            Text
-          , toAmountFmt :
-              {- Format of the amount field. Must include three fields for the
-              sign, numerator, and denominator of the amount.
+        , toSkipBlankDate :
+            {-
+            Skip line if date field is a blank
            -}
-              Text
+            Bool
+        , toSkipBlankAmount :
+            {-
+            Skip line if amount field(s) is(are) a blank
+            -}
+            Bool
+        , toSkipBlankDescription :
+            {-
+            Skip line if description field is a blank
+            -}
+            Bool
+        , toSkipBlankOther :
+            {-
+            Skip line if any arbitrary fields are blank (these fields must also
+            be listed in 'toOther' to be considered)
+            -}
+            List Text
+        , toSkipMissingFields :
+            {-
+            Skip line if any fields are missing (this is different from blank;
+            'missing' means there is no field with name 'X', 'blank' means that
+            there is a field 'X' and its value is an empty string)
+            -}
+            Bool
        }
+
+let TxAmountSpec = TxAmountSpec_ Text
+
+let TxOpts =
+      { Type = TxOpts_ Text
      , default =
        { toDate = "Date"
-        , toAmount = "Amount"
+        , toAmount = TxAmountSpec.AmountSingle TxAmount1::{=}
        , toDesc = "Description"
        , toOther = [] : List Text
        , toDateFmt = "%0m/%0d/%Y"
-        , toAmountFmt = "([-+])?([0-9]+)\\.?([0-9]+)?"
+        , toSkipBlankDate = False
+        , toSkipBlankAmount = False
+        , toSkipBlankDescription = False
+        , toSkipBlankOther = [] : List Text
+        , toSkipMissingFields = False
        }
      }

@ -402,9 +477,45 @@ let EntryNumGetter =

    LookupN: lookup the value from a field
    ConstN: a constant value
-    AmountN: the value of the 'Amount' column
+    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
    -}
-      < LookupN : Text | ConstN : Double | AmountN : Double >
+      < 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 >

 let EntryTextGetter =
    {-
@ -443,7 +554,6 @@ let Entry =
    -}
      \(a : Type) ->
      \(v : Type) ->
-      \(c : Type) ->
      \(t : Type) ->
        { eAcnt :
            {-
@ -455,11 +565,6 @@ 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)
@ -474,35 +579,107 @@ let Entry =

 let EntryGetter =
    {-
-    Means for getting an entry from a given row in a statement
+    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
    -}
      { Type =
-          Entry EntryAcntGetter (Optional EntryNumGetter) EntryCurGetter TagID
-      , default = { eValue = None EntryNumGetter, eComment = "" }
+          { tsgValue : EntryNumGetter
+          , tsgCurrency : EntryCurGetter
+          , tsgFrom : (TxHalfGetter FromEntryGetter.Type).Type
+          , tsgTo : (TxHalfGetter ToEntryGetter.Type).Type
+          }
+      , default = { tsgFrom = TxHalfGetter, tsgTo = TxHalfGetter }
      }

 let TxGetter =
    {-
    A means for transforming one row in a statement to a transaction
-
-    Note that N-1 entries need to be specified to make a transaction, as the
-    Nth entry will be balanced with the others.
    -}
-      { tgEntries :
-          {-
-          A means of getting entries for this transaction (minimum 1)
-          -}
-          List EntryGetter.Type
-      , tgCurrency :
-          {-
-          Currency against which entries in this transaction will be balanced
-          -}
-          EntryCurGetter
-      , tgAcnt :
-          {-
-          Account in which entries in this transaction will be balanced
-          -}
-          EntryAcntGetter
+      { 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
+        }
      }

 let StatementParser_ =
@ -542,7 +719,7 @@ let StatementParser_ =
                a transaction. If none, don't make a transaction (eg 'skip'
                this row in the statement).
                -}
-                Optional TxGetter
+                Optional TxGetter.Type
            , spTimes :
                {-
                Match at most this many rows; if none there is no limit
@ -559,7 +736,7 @@ let StatementParser_ =
          , spVal = ValMatcher::{=}
          , spDesc = None Text
          , spOther = [] : List (FieldMatcher_ re)
-          , spTx = None TxGetter
+          , spTx = None TxGetter.Type
          , spTimes = None Natural
          , spPriority = +0
          }
@ -577,7 +754,29 @@ let Amount =
    -}
      \(w : Type) ->
      \(v : Type) ->
-        { amtWhen : w, amtValue : v, amtDesc : Text }
+        { 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
+      }

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

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

 let Statement =
    {-
@ -634,44 +843,6 @@ 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
@ -679,12 +850,7 @@ let Allocation =
    -}
      \(w : Type) ->
      \(v : Type) ->
-        { alloTo : TaggedAcnt
-        , alloAmts : List (Amount w v)
-        , alloCur :
-            {-TODO allow exchanges here-}
-            CurID
-        }
+        { alloTo : TaggedAcnt.Type, alloAmts : List (Amount w v).Type }

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

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

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

-let AcntSet =
+let AcntMatcher_ =
    {-
-    A list of account IDs represented as a set.
+    Regex pattern by which matching account ids will be identified
    -}
-      { Type =
-          { asList : List AcntID
-          , asInclude :
-              {-
-              If true, tests for account membership in this set will return
-              true if the account is in the set. Invert this behavior otherwise.
-              -}
-              Bool
-          }
-      , default = { asList = [] : List AcntID, asInclude = False }
-      }
+      \(re : Type) ->
+        { Type = { amPat : re, amInvert : Bool }, default.amInvert = False }

-let TransferMatcher =
+let AcntMatcher = AcntMatcher_ Text
+
+let TransferMatcher_ =
    {-
    Means to match a transfer (which will be used to "clone" it in some
    fashion)
    -}
-      { Type =
-          { tmFrom :
-              {-
-              List of accounts (which may be empty) to match with the
-              starting account in a transfer.
-              -}
-              AcntSet.Type
-          , tmTo :
-              {-
-              List of accounts (which may be empty) to match with the
-              ending account in a transfer.
-              -}
-              AcntSet.Type
+      \(re : Type) ->
+        { tmFrom : Optional (AcntMatcher_ re).Type
+        , tmTo : Optional (AcntMatcher_ re).Type
        , tmDate :
            {-
            If given, means to match the date of a transfer.
@ -929,25 +1084,17 @@ let TransferMatcher =
            -}
            ValMatcher.Type
        }
+
+let TransferMatcher =
+      { Type = TransferMatcher_ Text
      , default =
-        { tmFrom = AcntSet.default
-        , tmTo = AcntSet.default
+        { tmFrom = None AcntMatcher.Type
+        , tmTo = None AcntMatcher.Type
        , tmDate = None DateMatcher
        , tmVal = ValMatcher.default
        }
      }

-let BudgetTransferType =
-    {-
-    The type of a budget transfer.
-
-    BTFixed: Tranfer a fixed amount
-    BTPercent: Transfer a percent of the source account to destination
-    BTTarget: Transfer an amount such that the destination has a given target
-              value
-    -}
-      < BTPercent | BTTarget | BTFixed >
-
 let ShadowTransfer =
    {-
    A transaction analogous to another transfer with given properties.
@ -956,17 +1103,17 @@ let ShadowTransfer =
          {-
          Source of this transfer
          -}
-          TaggedAcnt
+          TaggedAcnt.Type
      , stTo :
          {-
          Destination of this transfer.
          -}
-          TaggedAcnt
+          TaggedAcnt.Type
      , stCurrency :
          {-
          Currency of this transfer.
          -}
-          BudgetCurrency
+          CurID
      , stDesc :
          {-
          Description of this transfer.
@ -980,7 +1127,6 @@ let ShadowTransfer =
          specified in other fields of this type.
          -}
          TransferMatcher.Type
-      , stType : BudgetTransferType
      , stRatio :
          {-
          Fixed multipler to translate value of matched transfer to this one.
@ -988,17 +1134,11 @@ 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
    -}
-      Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
+      HistTransfer

 let Budget =
    {-
@ -1040,6 +1180,7 @@ in  { CurID
    , CronPat
    , DatePat
    , TxOpts
+    , TxOpts_
    , StatementParser
    , StatementParser_
    , ValMatcher
@ -1048,10 +1189,13 @@ in  { CurID
    , FieldMatcher
    , FieldMatcher_
    , EntryNumGetter
+    , LinkedEntryNumGetter
+    , LinkedNumGetter
    , Field
    , FieldMap
    , Entry
-    , EntryGetter
+    , FromEntryGetter
+    , ToEntryGetter
    , EntryTextGetter
    , EntryCurGetter
    , EntryAcntGetter
@ -1062,12 +1206,11 @@ in  { CurID
    , Budget
    , Allocation
    , Amount
+    , TransferMatcher_
    , TransferMatcher
    , ShadowTransfer
-    , AcntSet
-    , BudgetCurrency
-    , Exchange
    , TaggedAcnt
+    , AccountTree
    , Account
    , Placeholder
    , PretaxValue
@ -1076,13 +1219,29 @@ in  { CurID
    , TaxProgression
    , TaxMethod
    , TaxValue
-    , BudgetTransferValue
-    , BudgetTransferType
+    , TransferValue
+    , TransferType
    , TxGetter
+    , TxSubGetter
+    , TxHalfGetter
+    , FromTxHalfGetter
+    , ToTxHalfGetter
    , HistTransfer
    , SingleAllocation
    , MultiAllocation
    , HourlyPeriod
    , Period
    , PeriodType
+    , TransferAmount
+    , MultiAlloAmount
+    , SingleAlloAmount
+    , AcntMatcher_
+    , AcntMatcher
+    , TxAmountSpec
+    , TxAmountSpec_
+    , TxAmount1_
+    , TxAmount2_
+    , TxAmount1
+    , TxAmount2
+    , BudgetTransfer
    }
--- a/dhall/common.dhall
+++ b/dhall/common.dhall
@ -4,18 +4,10 @@ let List/map =

 let T = ./Types.dhall

-let nullSplit =
+let nullEntry =
      \(a : T.EntryAcntGetter) ->
-      \(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::{=}
+      \(v : T.EntryNumGetter) ->
+        T.FromEntryGetter::{ eAcnt = a, eValue = v }

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

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

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

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

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

 let match1_ = matchN_ 1

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

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

-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)
+let partNFrom =
+      \(ss : List PartEntry) ->
+        let toEntry =
+              \(x : PartEntry) ->
+                T.FromEntryGetter::{
+                , eAcnt = T.EntryAcntGetter.ConstT x._1
+                , eValue = T.EntryNumGetter.ConstN x._2
                , eComment = x._3
                }

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

-let part1 =
-      \(c : T.EntryCurGetter) ->
-      \(a : T.EntryAcntGetter) ->
-      \(comment : Text) ->
-        partN c a comment ([] : List PartSplit)
+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) ->
-        partN c a "" ([] : List PartSplit)
+        in  List/map PartEntry T.ToEntryGetter.Type toEntry ss

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

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

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

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

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

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

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

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

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

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

-- 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
+readBudgetCRUD :: (MonadAppError m, MonadFinance m) => PreBudgetCRUD -> m FinalBudgetCRUD
+readBudgetCRUD o@CRUDOps {coCreate} = do
+  bs <- mapM readBudget coCreate
+  return $ o {coCreate = bs}

-insertBudget
-  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
-  => Budget
-  -> m ()
-insertBudget
+readBudget :: (MonadAppError m, MonadFinance m) => Budget -> m (BudgetName, [Tx CommitR])
+readBudget
  b@Budget
    { bgtLabel
    , bgtIncomes
@ -39,15 +30,18 @@ insertBudget
    , bgtPosttax
    , bgtInterval
    } =
-    whenHash CTBudget b () $ \key -> do
+    do
+      spanRes <- getSpan
+      (bgtLabel,) <$> case spanRes of
+        Nothing -> return []
+        Just budgetSpan -> do
          (intAllos, _) <- combineError intAlloRes acntRes (,)
-      let res1 = mapErrors (insertIncome key bgtLabel intAllos bgtInterval) bgtIncomes
-      let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers
-      txs <- combineError (concat <$> res1) res2 (++)
-      m <- askDBState kmCurrency
-      shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs
-      void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow
+          let res1 = mapErrors (readIncome c intAllos budgetSpan) bgtIncomes
+          let res2 = expandTransfers c budgetSpan bgtTransfers
+          combineErrorM (concat <$> res1) res2 $ \is ts ->
+            addShadowTransfers bgtShadowTransfers (is ++ ts)
    where
+      c = CommitR (CommitHash $ hash b) CTBudget
      acntRes = mapErrors isNotIncomeAcnt alloAcnts
      intAlloRes = combineError3 pre_ tax_ post_ (,,)
      pre_ = sortAllos bgtPretax
@ -58,73 +52,15 @@ insertBudget
        (alloAcnt <$> bgtPretax)
          ++ (alloAcnt <$> bgtTax)
          ++ (alloAcnt <$> bgtPosttax)
+      getSpan = do
+        globalSpan <- asks (unBSpan . tsBudgetScope)
+        case bgtInterval of
+          Nothing -> return $ Just globalSpan
+          Just bi -> do
+            localSpan <- liftExcept $ resolveDaySpan bi
+            return $ intersectDaySpan globalSpan localSpan

-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 :: MultiAllocation v -> AppExcept (DaySpanAllocation v)
 sortAllo a@Allocation {alloAmts = as} = do
  bs <- foldSpan [] $ L.sortOn amtWhen as
  return $ a {alloAmts = reverse bs}
@ -143,100 +79,101 @@ 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 :(
-insertIncome
-  :: (MonadInsertError m, MonadFinance m)
-  => CommitRId
-  -> T.Text
+readIncome
+  :: (MonadAppError m, MonadFinance m)
+  => CommitR
  -> IntAllocations
-  -> Maybe Interval
+  -> DaySpan
  -> Income
-  -> m [UnbalancedTransfer]
-insertIncome
+  -> m [Tx CommitR]
+readIncome
  key
-  name
  (intPre, intTax, intPost)
-  localInterval
+  ds
  Income
    { incWhen
    , incCurrency
-    , incFrom
+    , incFrom = TaggedAcnt {taAcnt = srcAcnt, taTags = srcTags}
    , incPretax
    , incPosttax
    , incTaxes
-    , incToBal
+    , incToBal = TaggedAcnt {taAcnt = destAcnt, taTags = destTags}
    , incGross
    , incPayPeriod
+    , incPriority
    } =
    combineErrorM
      (combineError incRes nonIncRes (,))
-      (combineError precRes dayRes (,))
-      $ \_ (precision, days) -> do
-        let gross = roundPrecision precision incGross
-        concat <$> foldDays (allocate precision gross) start days
+      (combineError cpRes dayRes (,))
+      $ \_ (cp, days) -> do
+        let gross = realFracToDecimalP (cpPrec cp) incGross
+        foldDays (allocate cp gross) start days
    where
-      incRes = isIncomeAcnt $ taAcnt incFrom
+      srcAcnt' = AcntID srcAcnt
+      destAcnt' = AcntID destAcnt
+      incRes = isIncomeAcnt srcAcnt'
      nonIncRes =
        mapErrors isNotIncomeAcnt $
-          taAcnt incToBal
+          destAcnt'
            : (alloAcnt <$> incPretax)
            ++ (alloAcnt <$> incTaxes)
            ++ (alloAcnt <$> incPosttax)
-      precRes = lookupCurrencyPrec incCurrency
-      dayRes = askDays incWhen localInterval
+      cpRes = lookupCurrency incCurrency
+      dayRes = liftExcept $ expandDatePat ds incWhen
      start = fromGregorian' $ pStart incPayPeriod
      pType' = pType incPayPeriod
-      meta = BudgetMeta key name
      flatPre = concatMap flattenAllo incPretax
      flatTax = concatMap flattenAllo incTaxes
      flatPost = concatMap flattenAllo incPosttax
      sumAllos = sum . fmap faValue
-      -- TODO ensure these are all the "correct" accounts
-      allocate precision gross prevDay day = do
+      entry0 a c ts = Entry {eAcnt = a, eValue = (), eComment = c, eTags = ts}
+      allocate cp 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
-            tax =
+        let tax =
              allocateTax precision gross preDeductions scaler $
                flatTax ++ concatMap (selectAllos day) intTax
            aftertaxGross = gross - sumAllos (tax ++ pre)
-            post =
+        let post =
              allocatePost precision aftertaxGross $
                flatPost ++ concatMap (selectAllos day) intPost
-            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"
+        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
+            { txMeta = TxMeta day incPriority (TxDesc "") key
+            , txPrimary = Left primary
+            , txOther = []
            }
-         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
-  -> InsertExcept PeriodScaler
+  -> AppExcept PeriodScaler
 periodScaler pt prev cur = return scale
  where
-    n = fromIntegral $ workingDays wds prev cur
+    n = workingDays wds prev cur
    wds = case pt of
      Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays
      Daily ds -> ds
-    scale precision x = case pt of
+    scale prec x = case pt of
      Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
-        fromRational (rnd $ x / fromIntegral hpAnnualHours)
+        realFracToDecimalP prec (x / fromIntegral hpAnnualHours)
          * fromIntegral hpDailyHours
-          * n
-      Daily _ -> x * n / 365.25
-      where
-        rnd = roundPrecision precision
+          * fromIntegral n
+      Daily _ -> realFracToDecimalP prec (x * fromIntegral n / 365.25)

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

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

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

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

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

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

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

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

-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
+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
    }

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

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

 -- | Compute effective tax percentage of a bracket
@ -380,174 +304,102 @@ allocateTax precision gross preDeds f = fmap (fmap go)
 --
 -- In reality, this can all be done with one loop, but it isn't clear these
 -- three steps are implemented from this alone.
-foldBracket :: PeriodScaler -> Natural -> Rational -> [TaxBracket] -> Rational
-foldBracket f precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
+foldBracket :: PeriodScaler -> Precision -> Decimal -> [TaxBracket] -> Decimal
+foldBracket f prec agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
  where
    go TaxBracket {tbLowerLimit, tbPercent} a@(acc, remain) =
-      let l = roundPrecision precision $ f precision tbLowerLimit
-          p = roundPrecision 3 tbPercent / 100
-       in if remain >= l then (acc + p * (remain - l), l) else a
+      let l = f prec tbLowerLimit
+       in if remain >= l
+            then (acc + (remain - l) *. (tbPercent / 100), l)
+            else a

 allocatePost
-  :: Natural
-  -> Rational
+  :: Precision
+  -> Decimal
  -> [FlatAllocation PosttaxValue]
-  -> [FlatAllocation Rational]
-allocatePost precision aftertax = fmap (fmap go)
+  -> [FlatAllocation Decimal]
+allocatePost prec aftertax = fmap (fmap go)
  where
-    go PosttaxValue {postValue, postPercent} =
-      let v = postValue
-       in if postPercent
-            then aftertax * roundPrecision 3 v / 100
-            else roundPrecision precision v
-
--------------------------------------------------------------------------------
-- 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
+    go PosttaxValue {postValue, postPercent}
+      | postPercent = aftertax *. (postValue / 100)
+      | otherwise = realFracToDecimalP prec postValue

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

 -- TODO this is going to be O(n*m), which might be a problem?
 addShadowTransfers
-  :: CurrencyMap
-  -> [ShadowTransfer]
-  -> [UnbalancedTransfer]
-  -> InsertExcept [UnbalancedTransfer]
-addShadowTransfers cm ms txs =
-  fmap catMaybes $
-    combineErrors $
-      fmap (uncurry (fromShadow cm)) $
-        [(t, m) | t <- txs, m <- ms]
+  :: (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}

 fromShadow
-  :: CurrencyMap
-  -> UnbalancedTransfer
+  :: (MonadAppError m, MonadFinance m)
+  => Tx CommitR
  -> ShadowTransfer
-  -> 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 $
-    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
-            }
+  -> m (Maybe ShadowEntrySet)
+fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} =
+  combineErrorM curRes mRes $ \cur compiled -> do
+    res <- liftExcept $ shadowMatches compiled tx
+    let es = entryPair stFrom stTo cur stDesc stRatio ()
+    return $ if not res then Nothing else Just es
+  where
+    curRes = lookupCurrencyKey stCurrency
+    mRes = liftExcept $ compileMatch stMatch

-shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool
-shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
-  valRes <- valMatches tmVal $ cvValue $ ftValue tx
+shadowMatches :: TransferMatcherRe -> Tx CommitR -> AppExcept Bool
+shadowMatches
+  TransferMatcher_ {tmFrom, tmTo, tmDate, tmVal}
+  Tx {txPrimary, txMeta = TxMeta {txmDate}} =
+    do
+      -- ASSUME these will never fail and thus I don't need to worry about
+      -- stacking the errors
+      fromRes <- acntMatches fa tmFrom
+      toRes <- acntMatches ta tmTo
+      -- 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
      return $
-    memberMaybe (taAcnt $ ftFrom tx) tmFrom
-      && memberMaybe (taAcnt $ ftTo tx) tmTo
-      && maybe True (`dateMatches` ftWhen tx) tmDate
+        fromRes
+          && toRes
+          && maybe True (`dateMatches` txmDate) tmDate
          && valRes
    where
-    memberMaybe x AcntSet {asList, asInclude} =
-      (if asInclude then id else not) $ x `elem` asList
+      fa = either getAcntFrom getAcntFrom txPrimary
+      ta = either getAcntTo getAcntTo txPrimary
+      getAcntFrom = getAcnt esFrom
+      getAcntTo = getAcnt esTo
+      getAcnt f = eAcnt . hesPrimary . f
+      acntMatches (AcntID a) = maybe (return True) (match' a)
+      match' a AcntMatcher_ {amPat, amInvert} =
+        (if amInvert then not else id) <$> matchMaybe a amPat
+
+compileMatch :: TransferMatcher_ T.Text -> AppExcept TransferMatcherRe
+compileMatch m@TransferMatcher_ {tmTo, tmFrom} =
+  combineError tres fres $ \t f -> m {tmTo = t, tmFrom = f}
+  where
+    go a@AcntMatcher_ {amPat} = do
+      (_, p) <- compileRegex False amPat
+      return $ a {amPat = p}
+    tres = mapM go tmTo
+    fres = mapM go tmFrom
+
+-- memberMaybe x AcntSet {asList, asInclude} =
+--   (if asInclude then id else not) $ x `elem` (AcntID <$> asList)

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

-initialCurrency :: BudgetCurrency -> CurID
-initialCurrency (NoX c) = c
-initialCurrency (X Exchange {xFromCur = c}) = c
-
 alloAcnt :: Allocation w v -> AcntID
-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)
+alloAcnt = AcntID . taAcnt . alloTo

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

 type DaySpanAllocation = Allocation DaySpan

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

 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
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@ -1,15 +1,17 @@
 module Internal.History
-  ( splitHistory
-  , insertHistTransfer
-  , readHistStmt
-  , insertHistStmt
+  ( readHistStmt
+  , readHistTransfer
+  , splitHistory
+  , readHistoryCRUD
  )
 where

 import Control.Monad.Except
 import Data.Csv
-import Database.Persist.Monad
-import Internal.Database
+import Data.Decimal
+import Data.Foldable
+import Data.Hashable
+import GHC.Real
 import Internal.Types.Main
 import Internal.Utils
 import RIO hiding (to)
@ -20,107 +22,73 @@ 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)

-splitHistory :: [History] -> ([HistTransfer], [Statement])
+readHistoryCRUD
+  :: (MonadUnliftIO m, MonadFinance m)
+  => FilePath
+  -> PreHistoryCRUD
+  -> m FinalHistoryCRUD
+readHistoryCRUD root o@CRUDOps {coCreate = (ts, ss)} = do
+  -- TODO multithread this for some extra fun :)
+
+  ss' <- mapErrorsIO (readHistStmt root) ss
+  fromEitherM $ runExceptT $ do
+    let sRes = mapErrors (ExceptT . return) ss'
+    let tRes = mapErrors readHistTransfer ts
+    combineError sRes tRes $ \ss'' ts' -> o {coCreate = concat ss'' ++ concat ts'}
+
+-- 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 = partitionEithers . fmap go
  where
    go (HistTransfer x) = Left x
    go (HistStatement x) = Right x

-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
+--------------------------------------------------------------------------------
+-- Transfers
+
+readHistTransfer
+  :: (MonadAppError m, MonadFinance m)
+  => PairedTransfer
+  -> m [Tx CommitR]
+readHistTransfer ht = do
+  bounds <- asks (unHSpan . tsHistoryScope)
+  expandTransfer c bounds ht
+  where
+    c = CommitR (CommitHash $ hash ht) CTHistoryTransfer
+
+--------------------------------------------------------------------------------
+-- Statements

 readHistStmt
  :: (MonadUnliftIO m, MonadFinance m)
  => FilePath
  -> Statement
-  -> m (Maybe (CommitR, [KeyTx]))
-readHistStmt root i = whenHash_ CTImport i $ do
+  -> m (Either AppException [Tx CommitR])
+readHistStmt root i = do
+  bounds <- asks (unHSpan . tsHistoryScope)
  bs <- readImport root i
-  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
+  return $ filter (inDaySpan bounds . txmDate . txMeta) . fmap go <$> bs
  where
-    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
+    go t@Tx {txMeta = m} =
+      t {txMeta = m {txmCommit = CommitR (CommitHash $ hash i) CTHistoryStatement}}

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

@ -133,9 +101,9 @@ readImport_
  -> m [TxRecord]
 readImport_ n delim tns p = do
  res <- tryIO $ BL.readFile p
-  bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res
+  bs <- fromEither $ first (AppException . (: []) . StatementIOError . tshow) res
  case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
-    Left m -> throwIO $ InsertException [ParseError $ T.pack m]
+    Left m -> throwIO $ AppException [ParseError $ T.pack m]
    Right (_, v) -> return $ catMaybes $ V.toList v
  where
    opts = defaultDecodeOptions {decDelimiter = fromIntegral delim}
@ -144,39 +112,93 @@ readImport_ n delim tns p = do
 -- TODO handle this better, this maybe thing is a hack to skip lines with
 -- blank dates but will likely want to make this more flexible
 parseTxRecord :: FilePath -> TxOptsRe -> NamedRecord -> Parser (Maybe TxRecord)
-parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFmt} r = do
-  d <- r .: T.encodeUtf8 toDate
-  if d == ""
+parseTxRecord
+  p
+  TxOpts
+    { toDate
+    , toDesc
+    , toAmount
+    , toOther
+    , toDateFmt
+    , toSkipBlankDate
+    , toSkipBlankAmount
+    , toSkipBlankDescription
+    , toSkipBlankOther
+    , toSkipMissingFields
+    }
+  r =
+    do
+      -- TODO this is confusing as hell
+      --
+      -- try and parse all fields; if a parse fails, either trip an error
+      -- or return a Nothing if we want to deliberately skip missing fields
+      d <- getField toDate
+      e <- getField toDesc
+      os <-
+        fmap M.fromList . sequence
+          <$> mapM (\n -> fmap (n,) <$> getField n) toOther
+      (af, ax) <- case toAmount of
+        -- the amount column is extra confusing because it can either be one
+        -- or two columns, so keep track of this with a maybe
+        AmountSingle TxAmount1 {a1Column, a1Fmt} -> do
+          f <- getField a1Column
+          return (a1Fmt, Right <$> f)
+        AmountDual TxAmount2 {a2Positive, a2Negative, a2Fmt} -> do
+          f1 <- getField a2Positive
+          f2 <- getField a2Negative
+          return $ (a2Fmt,) $ case (f1, f2) of
+            (Just a, Just b) -> Just $ Left (a, b)
+            _ -> Nothing
+      case (d, e, os, ax) of
+        -- If all lookups were successful, check that none of the fields are
+        -- blank, and if they are return nothing to skip this line
+        (Just d', Just e', Just os', Just ax') ->
+          if (toSkipBlankDate && d' == "")
+            || (toSkipBlankDescription && e' == "")
+            || (toSkipBlankAmount && (ax' == Right "" || ax' == Left ("", "")))
+            || elem "" (mapMaybe (`M.lookup` os') toSkipBlankOther)
            then return Nothing
-    else do
-      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
+            else -- if we are skipping nothing, proceed to parse the date and amount
+            -- columns
+            do
+              a <- case ax' of
+                Right a -> parseDecimal True af a
+                Left ("", a) -> ((-1) *) <$> parseDecimal False af a
+                Left (a, _) -> parseDecimal False af a
+              d'' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d'
+              return $ Just $ TxRecord d'' a e' os' p
+        -- if no lookups succeeded, return nothing to skip this line. Note that
+        -- a parse fail will trigger a failure error further up, so that case
+        -- is already dealt with implicitly
+        _ -> return Nothing
+    where
+      getField :: FromField a => T.Text -> Parser (Maybe a)
+      getField f = case runParser $ r .: T.encodeUtf8 f of
+        Left err -> if toSkipMissingFields then return Nothing else fail err
+        Right x -> return $ Just x

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

-matchPriorities :: [MatchRe] -> [MatchGroup]
+matchPriorities :: [StatementParserRe] -> [MatchGroup]
 matchPriorities =
  fmap matchToGroup
    . L.groupBy (\a b -> spPriority a == spPriority b)
    . L.sortOn (Down . spPriority)

-matchToGroup :: [MatchRe] -> MatchGroup
+matchToGroup :: [StatementParserRe] -> MatchGroup
 matchToGroup ms =
  uncurry MatchGroup $
    first (L.sortOn spDate) $
      L.partition (isJust . spDate) ms

 data MatchGroup = MatchGroup
-  { mgDate :: ![MatchRe]
-  , mgNoDate :: ![MatchRe]
+  { mgDate :: ![StatementParserRe]
+  , mgNoDate :: ![StatementParserRe]
  }
  deriving (Show)

@ -214,9 +236,10 @@ zipperSlice f x = go
        LT -> z

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

 zipperMatch'
-  :: Zipped MatchRe
+  :: MonadFinance m
+  => Zipped StatementParserRe
  -> TxRecord
-  -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
+  -> AppExceptT m (Zipped StatementParserRe, MatchRes (Tx ()))
 zipperMatch' z x = go z
  where
    go (Zipped bs (a : as)) = do
@ -243,13 +267,17 @@ zipperMatch' z x = go z
          return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
    go z' = return (z', MatchFail)

-matchDec :: MatchRe -> Maybe MatchRe
+matchDec :: StatementParserRe -> Maybe StatementParserRe
 matchDec m = case spTimes m of
  Just 1 -> Nothing
  Just n -> Just $ m {spTimes = Just $ n - 1}
  Nothing -> Just m

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

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

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

-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
+matches
+  :: MonadFinance m
+  => StatementParserRe
+  -> 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
    where
-    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]
+      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

-groupByKey :: Ord k => [(k, v)] -> [(k, [v])]
-groupByKey = M.toList . M.fromListWith (++) . fmap (second (: []))
+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
+        { txMeta = TxMeta trDate priority trDesc ()
+        , txPrimary =
+            Left $
+              EntrySet
+                { esTotalValue = roundToP (cpPrec cur) trAmount *. tgScale
+                , esCurrency = cpID cur
+                , esFrom = f
+                , esTo = t
+                }
+        , txOther = Left <$> ss
+        }
+    where
+      curRes = do
+        m <- asks tsCurrencyMap
+        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 tsCurrencyMap
+  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 = mapM (compileRegex True)
+
+-- compileOptions o@TxOpts {toAmount = pat} = case pat of
+--   AmountSingle (TxAmount1 {a1Fmt}) -> do
+--     re <- compileRegex True a1Fmt
+--     return $ o {toAmountFmt = re}
+--   AmountDual (TxAmount2 {a2Fmt}) -> do
+--     re <- compileRegex True a2Fmt
+--     return $ o {toAmountFmt = re}
+
+compileMatch :: StatementParser T.Text -> AppExcept StatementParserRe
+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
+
+parseDecimal :: MonadFail m => Bool -> (T.Text, Regex) -> T.Text -> m Decimal
+parseDecimal wantSign (pat, re) s = case (wantSign, matchGroupsMaybe s re) of
+  (True, [sign, num]) -> do
+    k <- readSign sign
+    x <- readNum num
+    return $ k * x
+  (False, [num]) -> readNum num
+  _ -> msg "malformed decimal"
+  where
+    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
+    readNum x =
+      maybe
+        (msg $ T.unwords ["could not parse", singleQuote x])
+        return
+        $ readMaybe
+        $ T.unpack
+        $ T.filter (/= ',') x
--- a/lib/Internal/Types/Database.hs
+++ b/lib/Internal/Types/Database.hs
@ -7,9 +7,12 @@
 -- | 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

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

-data ConfigType = CTBudget | CTManual | CTImport
-  deriving (Eq, Show, Read, Enum)
+newtype TxIndex = TxIndex {unTxIndex :: Int}
+  deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)
+
+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, IsString)
+
+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)

 instance PersistFieldSql ConfigType where
  sqlType _ = SqlString
@ -69,7 +127,61 @@ 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 "wrong type"
+  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"
--- 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,13 +33,14 @@ makeHaskellTypesWith
  , MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
  , MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
  , MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
-  , MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
-  , MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
+  , MultipleConstructors "LinkedEntryNumGetter" "(./dhall/Types.dhall).LinkedEntryNumGetter"
+  , MultipleConstructors "TransferType" "(./dhall/Types.dhall).TransferType"
  , 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"
+  , SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt.Type"
  , SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
  , SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
  , SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
@ -48,12 +49,16 @@ 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" "(./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 "TxAmount1" "TxAmount1" "(./dhall/Types.dhall).TxAmount1_"
+  , SingleConstructor "TxAmount2" "TxAmount2" "(./dhall/Types.dhall).TxAmount2_"
+  , SingleConstructor
+      "Amount"
+      "Amount"
+      "\\(w : Type) -> \\(v : Type) -> ((./dhall/Types.dhall).Amount w v).Type"
+  , SingleConstructor
+      "AcntMatcher_"
+      "AcntMatcher_"
+      "\\(re : Type) -> ((./dhall/Types.dhall).AcntMatcher_ re).Type"
  , SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
  , SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry"
  , SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue"
@ -61,14 +66,9 @@ makeHaskellTypesWith
  , SingleConstructor "TaxProgression" "TaxProgression" "(./dhall/Types.dhall).TaxProgression"
  , SingleConstructor "TaxValue" "TaxValue" "(./dhall/Types.dhall).TaxValue"
  , SingleConstructor "PosttaxValue" "PosttaxValue" "(./dhall/Types.dhall).PosttaxValue"
-  , SingleConstructor "BudgetTransferValue" "BudgetTransferValue" "(./dhall/Types.dhall).BudgetTransferValue"
+  , SingleConstructor "TransferValue" "TransferValue" "(./dhall/Types.dhall).TransferValue.Type"
  , 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
@ -87,17 +87,13 @@ deriveProduct
  , "CronPat"
  , "DatePat"
  , "TaggedAcnt"
-  , "Budget"
  , "Income"
-  , "ShadowTransfer"
-  , "TransferMatcher"
-  , "AcntSet"
  , "DateMatcher"
  , "ValMatcher"
  , "YMDMatcher"
-  , "BudgetCurrency"
-  , "Exchange"
  , "EntryNumGetter"
+  , "LinkedNumGetter"
+  , "LinkedEntryNumGetter"
  , "TemporalScope"
  , "SqlConfig"
  , "PretaxValue"
@ -106,8 +102,8 @@ deriveProduct
  , "TaxProgression"
  , "TaxMethod"
  , "PosttaxValue"
-  , "BudgetTransferValue"
-  , "BudgetTransferType"
+  , "TransferValue"
+  , "TransferType"
  , "Period"
  , "PeriodType"
  , "HourlyPeriod"
@ -178,25 +174,45 @@ deriving instance Ord DatePat

 deriving instance Hashable DatePat

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

-deriving instance Hashable BudgetTransfer
+deriving instance Hashable PairedTransfer

-deriving instance Generic BudgetTransfer
+deriving instance Generic PairedTransfer

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

 data Budget = Budget
-  { bgtLabel :: Text
-  , bgtIncomes :: [Income]
-  , bgtPretax :: [MultiAllocation PretaxValue]
-  , bgtTax :: [MultiAllocation TaxValue]
-  , bgtPosttax :: [MultiAllocation PosttaxValue]
-  , bgtTransfers :: [BudgetTransfer]
-  , bgtShadowTransfers :: [ShadowTransfer]
+  { bgtLabel :: !BudgetName
+  , bgtIncomes :: ![Income]
+  , bgtPretax :: ![MultiAllocation PretaxValue]
+  , bgtTax :: ![MultiAllocation TaxValue]
+  , bgtPosttax :: ![MultiAllocation PosttaxValue]
+  , bgtTransfers :: ![PairedTransfer]
+  , bgtShadowTransfers :: ![ShadowTransfer]
  , bgtInterval :: !(Maybe Interval)
  }
+  deriving (Generic, Hashable, FromDhall)
+
+data ShadowTransfer = ShadowTransfer
+  { stFrom :: !TaggedAcnt
+  , stTo :: !TaggedAcnt
+  , stCurrency :: !CurID
+  , stDesc :: !Text
+  , stMatch :: !(TransferMatcher_ Text)
+  , stRatio :: !Double
+  }
+  deriving (Generic, Hashable, FromDhall)
+
+data TransferMatcher_ re = TransferMatcher_
+  { tmFrom :: !(Maybe (AcntMatcher_ re))
+  , tmTo :: !(Maybe (AcntMatcher_ re))
+  , tmDate :: !(Maybe DateMatcher)
+  , tmVal :: !ValMatcher
+  }

 deriving instance Hashable PretaxValue

@ -210,17 +226,28 @@ deriving instance Hashable TaxValue

 deriving instance Hashable PosttaxValue

-deriving instance Hashable Budget
+deriving instance Hashable TransferValue

-deriving instance Hashable BudgetTransferValue
+deriving instance Hashable TransferType

-deriving instance Hashable BudgetTransferType
+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 TaggedAcnt

 deriving instance Ord TaggedAcnt

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

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

 deriving instance Hashable HourlyPeriod
@ -250,20 +278,13 @@ 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)

@ -304,11 +325,17 @@ data Transfer a c w v = Transfer
  }
  deriving (Eq, Show)

-deriving instance Hashable ShadowTransfer
+deriving instance Generic (TransferMatcher_ Text)

-deriving instance Hashable AcntSet
+deriving instance Hashable (TransferMatcher_ Text)

-deriving instance Hashable TransferMatcher
+deriving instance FromDhall (TransferMatcher_ Text)
+
+deriving instance Generic (AcntMatcher_ Text)
+
+deriving instance Hashable (AcntMatcher_ Text)
+
+deriving instance FromDhall (AcntMatcher_ Text)

 deriving instance Hashable ValMatcher

@ -340,6 +367,10 @@ 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
@ -362,7 +393,7 @@ data AccountRoot_ a = AccountRoot_
  , arIncome :: ![a]
  , arLiabilities :: ![a]
  }
-  deriving (Generic)
+  deriving (Generic, Hashable)

 type AccountRootF = AccountRoot_ (Fix AccountTreeF)

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

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

 -- TODO newtypes for these?
-type AcntID = T.Text
+newtype AcntID = AcntID {unAcntID :: 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
+newtype TagID = TagID {unTagID :: T.Text}
+  deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)

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

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

-instance FromDhall EntryGetter
+type FromEntryGetter = EntryGetter EntryNumGetter

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

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

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

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

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

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

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

-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)
+deriving instance Eq a => Eq (TxOpts a)
+
+deriving instance Generic (TxOpts a)
+
+deriving instance Hashable (TxOpts T.Text)
+
+deriving instance FromDhall (TxOpts T.Text)
+
+deriving instance Show a => Show (TxOpts a)
+
+deriving instance Eq re => Eq (TxAmount1 re)
+
+deriving instance Eq re => Eq (TxAmount2 re)
+
+deriving instance Show re => Show (TxAmount1 re)
+
+deriving instance Show re => Show (TxAmount2 re)
+
+deriving instance Generic (TxAmount1 T.Text)
+
+deriving instance Generic (TxAmount2 T.Text)
+
+deriving instance Hashable (TxAmount1 T.Text)
+
+deriving instance Hashable (TxAmount2 T.Text)
+
+deriving instance FromDhall (TxAmount1 T.Text)
+
+deriving instance FromDhall (TxAmount2 T.Text)
+
+deriving instance Functor TxAmount1
+
+deriving instance Functor TxAmount2
+
+deriving instance Foldable TxAmount1
+
+deriving instance Foldable TxAmount2
+
+deriving instance Traversable TxAmount1
+
+deriving instance Traversable TxAmount2

 data Statement = Statement
  { stmtPaths :: ![FilePath]
@ -461,7 +511,30 @@ data Statement = Statement
  , stmtTxOpts :: !(TxOpts T.Text)
  , stmtSkipLines :: !Natural
  }
-  deriving (Eq, Hashable, Generic, FromDhall)
+  deriving (Eq, Hashable, Generic, FromDhall, Show)
+
+data TxAmountSpec re = AmountSingle (TxAmount1 re) | AmountDual (TxAmount2 re)
+  deriving (Eq, Show, Functor, Foldable, Traversable)
+
+deriving instance Generic (TxAmountSpec T.Text)
+
+deriving instance FromDhall (TxAmountSpec T.Text)
+
+deriving instance Hashable (TxAmountSpec T.Text)
+
+data TxOpts re = TxOpts
+  { toDate :: !T.Text
+  , toAmount :: !(TxAmountSpec re)
+  , toDesc :: !T.Text
+  , toOther :: ![T.Text]
+  , toDateFmt :: !T.Text
+  , toSkipBlankDate :: !Bool
+  , toSkipBlankAmount :: !Bool
+  , toSkipBlankDescription :: !Bool
+  , toSkipBlankOther :: ![Text]
+  , toSkipMissingFields :: !Bool
+  }
+  deriving (Functor, Foldable, Traversable)

 -- | the value of a field in entry (text version)
 -- can either be a raw (constant) value, a lookup from the record, or a map
@ -471,7 +544,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)
+  deriving (Eq, Generic, Hashable, Show, FromDhall, Functor)

 type EntryCur = EntryTextGetter CurID

@ -503,10 +576,32 @@ 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
-  { tgCurrency :: !EntryCur
-  , tgAcnt :: !EntryAcnt
-  , tgEntries :: ![EntryGetter]
+  { tgFrom :: !(TxHalfGetter FromEntryGetter)
+  , tgTo :: !(TxHalfGetter ToEntryGetter)
+  , tgCurrency :: !EntryCur
+  , tgOtherEntries :: ![TxSubGetter]
+  , tgScale :: !Double
  }
  deriving (Eq, Generic, Hashable, Show, FromDhall)

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

@ -12,11 +11,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
@ -27,99 +26,166 @@ import Text.Regex.TDFA
 --------------------------------------------------------------------------------
 -- database cache types

-data ConfigHashes = ConfigHashes
-  { chIncome :: ![Int]
-  , chExpense :: ![Int]
-  , chManual :: ![Int]
-  , chImport :: ![Int]
+type MonadFinance = MonadReader TxState
+
+data DeleteTxs = DeleteTxs
+  { dtCommits :: ![CommitRId]
+  , dtTxs :: ![TransactionRId]
+  , dtEntrySets :: ![EntrySetRId]
+  , dtEntries :: ![EntryRId]
+  , dtTagRelations :: ![TagRelationRId]
+  }
+  deriving (Show)
+
+type EntityCRUDOps r = CRUDOps [Entity r] () () [Key r]
+
+data MetaCRUD = MetaCRUD
+  { mcCurrencies :: !(EntityCRUDOps CurrencyR)
+  , mcAccounts :: !(EntityCRUDOps AccountR)
+  , mcPaths :: !(EntityCRUDOps AccountPathR)
+  , mcTags :: !(EntityCRUDOps TagR)
+  , mcBudgetScope :: !BudgetSpan
+  , mcHistoryScope :: !HistorySpan
  }

-type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
+type BudgetCRUDOps b = CRUDOps [b] () () DeleteTxs

-type CurrencyMap = M.Map CurID (CurrencyRId, Natural)
+type PreBudgetCRUD = BudgetCRUDOps Budget
+
+type FinalBudgetCRUD = BudgetCRUDOps (BudgetName, [Tx CommitR])
+
+type HistoryCRUDOps h =
+  CRUDOps
+    h
+    [ReadEntry]
+    [Either TotalUpdateEntrySet FullUpdateEntrySet]
+    DeleteTxs
+
+type PreHistoryCRUD = HistoryCRUDOps ([PairedTransfer], [Statement])
+
+type FinalHistoryCRUD = HistoryCRUDOps [Tx CommitR]
+
+data TxState = TxState
+  { tsAccountMap :: !AccountMap
+  , tsCurrencyMap :: !CurrencyMap
+  , tsTagMap :: !TagMap
+  , tsBudgetScope :: !BudgetSpan
+  , tsHistoryScope :: !HistorySpan
+  }
+  deriving (Show)
+
+data ExistingConfig = ExistingConfig
+  { ecAccounts :: !(Set AccountRId)
+  , ecTags :: !(Set TagRId)
+  , ecCurrencies :: !(Set CurrencyRId)
+  }
+
+type AccountMap = M.Map AcntID (AccountRId, AcntType)
+
+data CurrencyPrec = CurrencyPrec {cpID :: !CurrencyRId, cpPrec :: !Precision}
+  deriving (Show)
+
+type CurrencyMap = M.Map CurID CurrencyPrec

 type TagMap = M.Map TagID TagRId

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

-data DBUpdates = DBUpdates
-  { duOldCommits :: ![Int]
-  , duNewTagIds :: ![Entity TagR]
-  , duNewAcntPaths :: ![AccountPathR]
-  , duNewAcntIds :: ![Entity AccountR]
-  , duNewCurrencyIds :: ![Entity CurrencyR]
+data CachedEntry
+  = CachedLink EntryIndex LinkScale
+  | CachedBalance Decimal
+  | CachedPercent Double
+
+data TxSortKey = TxSortKey
+  { tskDate :: !Day
+  , tskPriority :: !Int
+  , tskDesc :: !TxDesc
  }
+  deriving (Show, Eq, Ord)

-type CurrencyM = Reader CurrencyMap
+-- TODO this should actually be a ReadTx since it will be compared with other
+-- Tx's to get the insert/update order correct
+data ReadEntry = ReadEntry
+  { reCurrency :: !CurrencyRId
+  , reAcnt :: !AccountRId
+  , reValue :: !Decimal
+  , reIndex :: !EntryIndex
+  , reESIndex :: !EntrySetIndex
+  , reSortKey :: !TxSortKey
+  }
+  deriving (Show)

-type KeyEntry = Entry AccountRId Rational CurrencyRId TagRId
+data UpdateEntry i v = UpdateEntry
+  { ueID :: !i
+  , ueAcnt :: !AccountRId
+  , ueValue :: !v
+  , ueIndex :: !EntryIndex
+  }
+  deriving (Show)

-type KeyTx = Tx KeyEntry
+deriving instance Functor (UpdateEntry i)

-type TreeR = Tree ([T.Text], AccountRId)
+newtype LinkScale = LinkScale {unLinkScale :: Double}
+  deriving newtype (Num, Show, Eq, Ord, Real, Fractional)

-type MonadFinance = MonadReader DBState
+newtype StaticValue = StaticValue {unStaticValue :: Decimal}
+  deriving newtype (Num, Show)

-askDBState :: MonadFinance m => (DBState -> a) -> m a
-askDBState = asks
+data EntryValueUnk = EVBalance Decimal | EVPercent Double deriving (Show)
+
+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
+  , utTotalValue :: !t
+  , utIndex :: !EntrySetIndex
+  , utSortKey :: !TxSortKey
+  }
+  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)

 -------------------------------------------------------------------------------
 -- 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 :: !Rational
-  , trDesc :: !T.Text
+  , trAmount :: !Decimal
+  , trDesc :: !TxDesc
  , 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
@ -127,21 +193,81 @@ accountSign IncomeT = Credit
 accountSign LiabilityT = Credit
 accountSign EquityT = Credit

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

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

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

-type BalTx = Tx BalEntry
+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 TxMeta k = TxMeta
+  { txmDate :: !Day
+  , txmPriority :: !Int
+  , txmDesc :: !TxDesc
+  , txmCommit :: !k
+  }
+  deriving (Show, Eq, Ord)
+
+data Tx k = Tx
+  { txMeta :: !(TxMeta k)
+  , txPrimary :: !(Either PrimaryEntrySet TransferEntrySet)
+  , txOther :: ![Either SecondayEntrySet ShadowEntrySet]
+  }
+  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
+  { itxMeta :: !(TxMeta CommitR)
+  , itxEntrySets :: !(NonEmpty InsertEntrySet)
+  }
+  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)

 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)
@ -153,50 +279,53 @@ data LookupSuberr
  | DBKey !EntryIDType
  deriving (Show)

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

-data InsertError
-  = RegexError !T.Text
-  | MatchValPrecisionError !Natural !Natural
-  | AccountError !AcntID !(NE.NonEmpty AcntType)
-  | InsertIOError !T.Text
-  | ParseError !T.Text
-  | ConversionError !T.Text
-  | LookupError !LookupSuberr !T.Text
-  | 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
+data DBLinkSubError
+  = DBLinkNoScale
+  | DBLinkNoValue
+  | DBLinkInvalidValue !Rational !Bool
+  | DBLinkInvalidBalance
+  | DBLinkInvalidPercent
  deriving (Show)

-newtype InsertException = InsertException [InsertError]
-  deriving (Show, Semigroup) via [InsertError]
+data DBSubError
+  = DBShouldBeEmpty
+  | DBMultiScope
+  | DBUpdateUnbalanced
+  | DBLinkError !EntryRId !DBLinkSubError
+  deriving (Show)

-instance Exception InsertException
+data AppError
+  = RegexError !T.Text
+  | MatchValPrecisionError !Natural !Natural
+  | AccountTypeError !AcntID !(NE.NonEmpty AcntType)
+  | StatementIOError !T.Text
+  | ParseError !T.Text
+  | ConversionError !T.Text !Bool
+  | LookupError !LookupSuberr !T.Text
+  | DatePatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
+  | DaySpanError !Gregorian !(Maybe Gregorian)
+  | StatementError ![TxRecord] ![StatementParserRe]
+  | PeriodError !Day !Day
+  | LinkError !EntryIndex !EntryIndex
+  | DBError !DBSubError
+  deriving (Show)

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

-type InsertExceptT = ExceptT InsertException
+instance Exception AppException

-type InsertExcept = InsertExceptT Identity
+type MonadAppError = MonadError AppException

-data XGregorian = XGregorian
-  { xgYear :: !Int
-  , xgMonth :: !Int
-  , xgDay :: !Int
-  , xgDayOfWeek :: !Int
-  }
+type AppExceptT = ExceptT AppException

-type MatchRe = StatementParser (T.Text, Regex)
+type AppExcept = AppExceptT Identity
+
+type StatementParserRe = StatementParser (T.Text, Regex)
+
+type TransferMatcherRe = TransferMatcher_ Regex

 type TxOptsRe = TxOpts (T.Text, Regex)

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

 library:
  source-dirs: lib/
Author	SHA1	Message	Date
Nathan Dwarshuis	09761dabdf	FIX actually the multi typo	2024-03-16 20:33:12 -04:00
Nathan Dwarshuis	432aa4f90f	FIX multi date pattern bug	2024-03-09 18:07:00 -05:00
Nathan Dwarshuis	26be9212f1	FIX include missing type	2023-10-14 20:28:45 -04:00
Nathan Dwarshuis	e8a5088d35	ENH clean up build plan printout	2023-08-19 20:56:40 -04:00
Nathan Dwarshuis	8e2019ac5b	ENH skip lines without all fields	2023-08-16 22:24:20 -04:00
Nathan Dwarshuis	4835ab15ca	ADD missing defaults	2023-08-16 21:12:11 -04:00
Nathan Dwarshuis	d4044dede3	FIX special case type	2023-08-16 21:04:16 -04:00
Nathan Dwarshuis	001ca0ff37	ADD better parsing for statements	2023-08-16 21:01:06 -04:00
Nathan Dwarshuis	2ebfe7a125	FIX sign on income	2023-08-14 20:46:28 -04:00
Nathan Dwarshuis	fa41ead348	ENH add inverter to shadow acnt matcher	2023-08-13 23:29:22 -04:00
Nathan Dwarshuis	4fef3714a2	ENH use pattern for shadow matcher accounts	2023-08-13 13:29:38 -04:00
Nathan Dwarshuis	3bf6df3b49	FIX duplicated txs	2023-08-13 12:11:33 -04:00
Nathan Dwarshuis	7609171ab4	FIX failure to track last entry when updating full entrysets	2023-07-27 00:17:53 -04:00
Nathan Dwarshuis	0c5401cd0b	Merge branch 'fix_cache'	2023-07-21 23:46:09 -04:00
Nathan Dwarshuis	472b137b9a	ENH remove useless field	2023-07-21 23:45:53 -04:00
Nathan Dwarshuis	e9772e6516	ENH ensure tx sort order is (kinda) stable	2023-07-21 19:57:54 -04:00
Nathan Dwarshuis	bd94afd30f	FIX history updates	2023-07-20 00:25:33 -04:00
Nathan Dwarshuis	e6f97651e5	Merge branch 'use_subaccount'	2023-07-16 19:57:00 -04:00
Nathan Dwarshuis	2e0b591312	ADD errors for everything that needs them (ish)	2023-07-16 19:55:33 -04:00
Nathan Dwarshuis	cafc066881	REF clean up useless types	2023-07-16 12:51:39 -04:00
Nathan Dwarshuis	ad5e4a0748	REF use newtype for indices	2023-07-16 12:15:39 -04:00
Nathan Dwarshuis	901882b79f	REF use newtypes for budget and tx desc	2023-07-16 00:39:03 -04:00
Nathan Dwarshuis	642ebb4727	REF use newtype for precision	2023-07-16 00:20:01 -04:00
Nathan Dwarshuis	81f09d1280	REF use newtypes for ids and commits	2023-07-16 00:10:49 -04:00
Nathan Dwarshuis	cd89597b1f	REF delete lots of dead code	2023-07-15 23:28:21 -04:00
Nathan Dwarshuis	8901fd6a64	FIX update bugs	2023-07-15 23:25:28 -04:00
Nathan Dwarshuis	223be34145	FIX mixed up account paths/keys	2023-07-15 14:14:23 -04:00
Nathan Dwarshuis	0e74ae41db	FIX reversed account path	2023-07-13 23:43:10 -04:00
Nathan Dwarshuis	4c46f035f5	WIP use more robust update strategy	2023-07-13 23:31:27 -04:00
Nathan Dwarshuis	c8f7689c7a	ENH store account sign in db itself	2023-07-09 11:13:35 -04:00
Nathan Dwarshuis	9c93ad25af	ENH break up input files to thread them	2023-07-09 00:16:57 -04:00
Nathan Dwarshuis	bf1434542f	ENH remove useless field	2023-07-08 19:05:34 -04:00
Nathan Dwarshuis	46decdc4de	ENH use decimals to round	2023-07-08 00:52:40 -04:00
Nathan Dwarshuis	c886c53f17	FIX readd export	2023-07-07 20:50:55 -04:00
Nathan Dwarshuis	90b88945c5	ENH clean up types again	2023-07-07 20:42:41 -04:00
Nathan Dwarshuis	00346ff8ee	ENH clean up types a bit	2023-07-07 20:20:09 -04:00
Nathan Dwarshuis	2946a8f9e2	ADD priority flag to keep tx's sorted always	2023-07-07 00:20:18 -04:00
Nathan Dwarshuis	24bc9a239b	FIX rounding errors	2023-07-06 00:05:16 -04:00
Nathan Dwarshuis	dce3ff4166	ENH clean up (and hopefully fix) lots of balancing stuff	2023-07-05 22:30:24 -04:00
Nathan Dwarshuis	d9709f565f	FIX separate running totals by budget label	2023-07-04 10:35:11 -04:00
Nathan Dwarshuis	8c9dc1e970	REF rearrange stuff	2023-07-04 00:11:25 -04:00
Nathan Dwarshuis	bae847d9f3	WIP balance transactions in two different ways	2023-07-03 20:27:52 -04:00
Nathan Dwarshuis	d5761c75ed	REF move commont stuff to common modules	2023-07-01 18:58:15 -04:00
Nathan Dwarshuis	ebef4e0f6b	WIP mostly unify history and budget transfer pipelines	2023-07-01 18:32:20 -04:00
Nathan Dwarshuis	5c1d2bce9d	WIP unify budget and history pipelines	2023-07-01 13:12:50 -04:00
Nathan Dwarshuis	1ae670187a	WIP unify history and budget pipelines	2023-06-30 23:54:39 -04:00
Nathan Dwarshuis	cc0699eb4e	WIP make budget and statement paths use same machinery	2023-06-29 21:32:14 -04:00
Nathan Dwarshuis	d617fa52cc	REF clean code	2023-06-26 19:04:37 -04:00
Nathan Dwarshuis	f8669e5a15	WIP add code to actually insert updates in the db	2023-06-26 00:10:40 -04:00
Nathan Dwarshuis	7a44aeb5db	WIP use newtypes to keep update balancer sane	2023-06-25 21:16:47 -04:00
Nathan Dwarshuis	fc4da967be	WIP read updates from database	2023-06-25 14:26:35 -04:00
Nathan Dwarshuis	05928087b2	WIP add logic for updating entries and summing read only entries	2023-06-24 17:32:43 -04:00
Nathan Dwarshuis	5697a071ab	WIP add lots of stuff to cache deferred calculations	2023-06-22 23:27:14 -04:00
Nathan Dwarshuis	09e03ff675	ADD means to scale/flip the value of a transaction	2023-06-20 22:52:52 -04:00
Nathan Dwarshuis	4c88151610	ENH split partn	2023-06-19 13:21:20 -04:00
Nathan Dwarshuis	33678e3908	FIX yet another typo	2023-06-19 13:00:23 -04:00
Nathan Dwarshuis	352cc88eed	FIX more typos	2023-06-19 12:44:14 -04:00
Nathan Dwarshuis	845899d073	FIX typo	2023-06-19 12:43:16 -04:00
Nathan Dwarshuis	ec74e735d0	FIX more exports	2023-06-19 12:41:57 -04:00
Nathan Dwarshuis	024a57179d	FIX half getter expiort	2023-06-19 12:39:56 -04:00
Nathan Dwarshuis	f3d2c1655e	FIX undefined error paths	2023-06-19 12:33:50 -04:00
Nathan Dwarshuis	03e75ce549	ADD linked credit entries	2023-06-19 12:14:18 -04:00
Nathan Dwarshuis	c2525fb77c	FIX balancing stuff	2023-06-18 00:14:06 -04:00
Nathan Dwarshuis	87e6dcff8f	FIX typos	2023-06-17 20:57:24 -04:00
Nathan Dwarshuis	8d45614571	ADD defaults	2023-06-17 20:06:14 -04:00
Nathan Dwarshuis	c18750d600	ADD comment and tags to txgetter	2023-06-17 00:16:01 -04:00
Nathan Dwarshuis	5858e2f8ce	FIX typo	2023-06-16 23:46:09 -04:00
Nathan Dwarshuis	a144b9fa3c	ENH update dhall interface	2023-06-16 23:41:01 -04:00
Nathan Dwarshuis	4c0b192b9c	FIX typo (clean compile)	2023-06-16 22:06:48 -04:00
Nathan Dwarshuis	ad0975aba7	ENH use sane types to simplify tx balancing	2023-06-16 22:05:28 -04:00
Nathan Dwarshuis	6926003c46	ENH assault user's face with all errors at once	2023-06-13 20:32:12 -04:00
Nathan Dwarshuis	efffda378a	ADD calculations for running balances in statements	2023-06-13 20:12:29 -04:00
Nathan Dwarshuis	592c1550c0	FIX typo	2023-06-13 20:12:23 -04:00
Nathan Dwarshuis	b2e4ee05e8	WIP allow running balances to be used in history	2023-06-12 00:27:34 -04:00
Nathan Dwarshuis	45df1af534	ENH export account tree type	2023-06-11 12:27:57 -04:00
Nathan Dwarshuis	dcd260f6fd	FIX update types	2023-06-10 21:38:13 -04:00
Nathan Dwarshuis	776a10ba11	ENH allow multiple entries on credit side of transaction statement getter	2023-06-10 21:30:30 -04:00
Nathan Dwarshuis	53d77326f5	Merge branch 'add_budget_limits'	2023-06-10 20:59:45 -04:00