Merge branch 'use_subaccount'
This commit is contained in:
commit
e6f97651e5
125
app/Main.hs
125
app/Main.hs
|
@ -2,13 +2,17 @@
|
||||||
|
|
||||||
module Main (main) where
|
module Main (main) where
|
||||||
|
|
||||||
|
import Control.Concurrent
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
import Control.Monad.IO.Rerunnable
|
import Control.Monad.IO.Rerunnable
|
||||||
import Control.Monad.Logger
|
import Control.Monad.Logger
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
|
import Data.Bitraversable
|
||||||
|
-- import Data.Hashable
|
||||||
import qualified Data.Text.IO as TI
|
import qualified Data.Text.IO as TI
|
||||||
|
import qualified Database.Esqueleto.Experimental as E
|
||||||
import Database.Persist.Monad
|
import Database.Persist.Monad
|
||||||
import Dhall hiding (double, record)
|
import qualified Dhall hiding (double, record)
|
||||||
import Internal.Budget
|
import Internal.Budget
|
||||||
import Internal.Database
|
import Internal.Database
|
||||||
import Internal.History
|
import Internal.History
|
||||||
|
@ -17,6 +21,7 @@ import Internal.Utils
|
||||||
import Options.Applicative
|
import Options.Applicative
|
||||||
import RIO
|
import RIO
|
||||||
import RIO.FilePath
|
import RIO.FilePath
|
||||||
|
-- import qualified RIO.Map as M
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
|
@ -30,14 +35,26 @@ main = parse =<< execParser o
|
||||||
<> header "pwncash - your budget, your life"
|
<> 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
|
data Mode
|
||||||
= Reset
|
= Reset
|
||||||
| DumpCurrencies
|
| DumpCurrencies
|
||||||
| DumpAccounts
|
| DumpAccounts
|
||||||
| DumpAccountKeys
|
| DumpAccountKeys
|
||||||
| Sync
|
| Sync !SyncOptions
|
||||||
|
|
||||||
|
data SyncOptions = SyncOptions
|
||||||
|
{ syncBudgets :: ![BudgetPath]
|
||||||
|
, syncHistories :: ![HistoryPath]
|
||||||
|
, syncThreads :: !Int
|
||||||
|
}
|
||||||
|
|
||||||
configFile :: Parser FilePath
|
configFile :: Parser FilePath
|
||||||
configFile =
|
configFile =
|
||||||
|
@ -104,6 +121,35 @@ sync =
|
||||||
<> short 'S'
|
<> short 'S'
|
||||||
<> help "Sync config to database"
|
<> 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 -> IO ()
|
||||||
parse (Options c Reset) = do
|
parse (Options c Reset) = do
|
||||||
|
@ -112,7 +158,8 @@ parse (Options c Reset) = do
|
||||||
parse (Options c DumpAccounts) = runDumpAccounts c
|
parse (Options c DumpAccounts) = runDumpAccounts c
|
||||||
parse (Options c DumpAccountKeys) = runDumpAccountKeys c
|
parse (Options c DumpAccountKeys) = runDumpAccountKeys c
|
||||||
parse (Options c DumpCurrencies) = runDumpCurrencies 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 :: MonadUnliftIO m => FilePath -> m ()
|
||||||
runDumpCurrencies c = do
|
runDumpCurrencies c = do
|
||||||
|
@ -150,50 +197,70 @@ runDumpAccountKeys c = do
|
||||||
ar <- accounts <$> readConfig c
|
ar <- accounts <$> readConfig c
|
||||||
let ks =
|
let ks =
|
||||||
paths2IDs $
|
paths2IDs $
|
||||||
fmap (double . fst) $
|
fmap (double . accountRFullpath . E.entityVal) $
|
||||||
concatMap (t3 . uncurry tree2Records) $
|
fst $
|
||||||
flattenAcntRoot ar
|
indexAcntRoot ar
|
||||||
mapM_ (uncurry printPair) ks
|
mapM_ (uncurry printPair) ks
|
||||||
where
|
where
|
||||||
printPair i p = do
|
printPair i p = do
|
||||||
liftIO $ putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", i]
|
liftIO $ putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", unAcntID i]
|
||||||
t3 (_, _, x) = x
|
|
||||||
double x = (x, x)
|
double x = (x, x)
|
||||||
|
|
||||||
runSync :: FilePath -> IO ()
|
runSync :: Int -> FilePath -> [FilePath] -> [FilePath] -> IO ()
|
||||||
runSync c = do
|
runSync threads c bs hs = do
|
||||||
|
setNumCapabilities threads
|
||||||
|
-- putStrLn "reading config"
|
||||||
config <- readConfig c
|
config <- readConfig c
|
||||||
let (hTs, hSs) = splitHistory $ statements config
|
-- putStrLn "reading statements"
|
||||||
|
(bs', hs') <-
|
||||||
|
fmap (bimap concat concat . partitionEithers) $
|
||||||
|
pooledMapConcurrentlyN threads (bimapM readDhall readDhall) $
|
||||||
|
(Left <$> bs) ++ (Right <$> hs)
|
||||||
pool <- runNoLoggingT $ mkPool $ sqlConfig config
|
pool <- runNoLoggingT $ mkPool $ sqlConfig config
|
||||||
|
putStrLn "doing other stuff"
|
||||||
|
setNumCapabilities 1
|
||||||
handle err $ do
|
handle err $ do
|
||||||
-- _ <- askLoggerIO
|
-- _ <- askLoggerIO
|
||||||
|
|
||||||
-- get the current DB state
|
-- Get the current DB state.
|
||||||
(state, updates) <- runSqlQueryT pool $ do
|
state <- runSqlQueryT pool $ do
|
||||||
runMigration migrateAll
|
runMigration migrateAll
|
||||||
liftIOExceptT $ getDBState config
|
liftIOExceptT $ readConfigState config bs' hs'
|
||||||
|
|
||||||
-- read desired statements from disk
|
-- Read raw transactions according to state. If a transaction is already in
|
||||||
bSs <-
|
-- the database, don't read it but record the commit so we can update it.
|
||||||
flip runReaderT state $
|
toIns <-
|
||||||
catMaybes <$> mapErrorsIO (readHistStmt root) hSs
|
flip runReaderT state $ do
|
||||||
|
(CRUDOps hSs _ _ _) <- asks csHistStmts
|
||||||
|
hSs' <- mapErrorsIO (readHistStmt root) hSs
|
||||||
|
(CRUDOps hTs _ _ _) <- asks csHistTrans
|
||||||
|
hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
|
||||||
|
(CRUDOps bTs _ _ _) <- asks csBudgets
|
||||||
|
bTs' <- liftIOExceptT $ mapErrors readBudget bTs
|
||||||
|
return $ concat $ hSs' ++ hTs' ++ bTs'
|
||||||
|
|
||||||
-- update the DB
|
-- Update the DB.
|
||||||
runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
|
runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
|
||||||
let hTransRes = mapErrors insertHistTransfer hTs
|
-- NOTE this must come first (unless we defer foreign keys)
|
||||||
let bgtRes = mapErrors insertBudget $ budget config
|
updateDBState
|
||||||
updateDBState updates -- TODO this will only work if foreign keys are deferred
|
|
||||||
res <- runExceptT $ do
|
res <- runExceptT $ do
|
||||||
mapM_ (uncurry insertHistStmt) bSs
|
(CRUDOps _ bRs bUs _) <- asks csBudgets
|
||||||
combineError hTransRes bgtRes $ \_ _ -> ()
|
(CRUDOps _ tRs tUs _) <- asks csHistTrans
|
||||||
|
(CRUDOps _ sRs sUs _) <- asks csHistStmts
|
||||||
|
let ebs = fmap ToUpdate (bUs ++ tUs ++ sUs) ++ fmap ToRead (bRs ++ tRs ++ sRs) ++ fmap ToInsert toIns
|
||||||
|
insertAll ebs
|
||||||
|
-- NOTE this rerunnable thing is a bit misleading; fromEither will throw
|
||||||
|
-- whatever error is encountered above in an IO context, but the first
|
||||||
|
-- thrown error should be caught despite possibly needing to be rerun
|
||||||
rerunnableIO $ fromEither res
|
rerunnableIO $ fromEither res
|
||||||
where
|
where
|
||||||
root = takeDirectory c
|
root = takeDirectory c
|
||||||
err (InsertException es) = do
|
err (AppException es) = do
|
||||||
liftIO $ mapM_ TI.putStrLn $ concatMap showError es
|
liftIO $ mapM_ TI.putStrLn $ concatMap showError es
|
||||||
exitFailure
|
exitFailure
|
||||||
|
|
||||||
-- showBalances
|
|
||||||
|
|
||||||
readConfig :: MonadUnliftIO m => FilePath -> m Config
|
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
|
||||||
|
|
|
@ -75,7 +75,8 @@ library
|
||||||
ViewPatterns
|
ViewPatterns
|
||||||
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2
|
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2
|
||||||
build-depends:
|
build-depends:
|
||||||
base >=4.12 && <10
|
Decimal >=0.5.2
|
||||||
|
, base >=4.12 && <10
|
||||||
, cassava
|
, cassava
|
||||||
, conduit >=1.3.4.2
|
, conduit >=1.3.4.2
|
||||||
, containers >=0.6.4.1
|
, containers >=0.6.4.1
|
||||||
|
@ -144,7 +145,8 @@ executable pwncash
|
||||||
ViewPatterns
|
ViewPatterns
|
||||||
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2 -threaded
|
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2 -threaded
|
||||||
build-depends:
|
build-depends:
|
||||||
base >=4.12 && <10
|
Decimal >=0.5.2
|
||||||
|
, base >=4.12 && <10
|
||||||
, budget
|
, budget
|
||||||
, cassava
|
, cassava
|
||||||
, conduit >=1.3.4.2
|
, conduit >=1.3.4.2
|
||||||
|
|
|
@ -278,8 +278,9 @@ let DatePat =
|
||||||
-}
|
-}
|
||||||
< Cron : CronPat.Type | Mod : ModPat.Type >
|
< Cron : CronPat.Type | Mod : ModPat.Type >
|
||||||
|
|
||||||
let TxOpts =
|
let TxOpts_ =
|
||||||
{- Additional metadata to use when parsing a statement -}
|
{- Additional metadata to use when parsing a statement -}
|
||||||
|
\(re : Type) ->
|
||||||
{ Type =
|
{ Type =
|
||||||
{ toDate :
|
{ toDate :
|
||||||
{-
|
{-
|
||||||
|
@ -312,7 +313,7 @@ let TxOpts =
|
||||||
{- Format of the amount field. Must include three fields for the
|
{- Format of the amount field. Must include three fields for the
|
||||||
sign, numerator, and denominator of the amount.
|
sign, numerator, and denominator of the amount.
|
||||||
-}
|
-}
|
||||||
Text
|
re
|
||||||
}
|
}
|
||||||
, default =
|
, default =
|
||||||
{ toDate = "Date"
|
{ toDate = "Date"
|
||||||
|
@ -324,6 +325,8 @@ let TxOpts =
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
let TxOpts = TxOpts_ Text
|
||||||
|
|
||||||
let Field =
|
let Field =
|
||||||
{-
|
{-
|
||||||
General key-value type
|
General key-value type
|
||||||
|
@ -402,9 +405,45 @@ let EntryNumGetter =
|
||||||
|
|
||||||
LookupN: lookup the value from a field
|
LookupN: lookup the value from a field
|
||||||
ConstN: a constant value
|
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 =
|
let EntryTextGetter =
|
||||||
{-
|
{-
|
||||||
|
@ -443,7 +482,6 @@ let Entry =
|
||||||
-}
|
-}
|
||||||
\(a : Type) ->
|
\(a : Type) ->
|
||||||
\(v : Type) ->
|
\(v : Type) ->
|
||||||
\(c : Type) ->
|
|
||||||
\(t : Type) ->
|
\(t : Type) ->
|
||||||
{ eAcnt :
|
{ eAcnt :
|
||||||
{-
|
{-
|
||||||
|
@ -455,11 +493,6 @@ let Entry =
|
||||||
Pertains to value for this entry.
|
Pertains to value for this entry.
|
||||||
-}
|
-}
|
||||||
v
|
v
|
||||||
, eCurrency :
|
|
||||||
{-
|
|
||||||
Pertains to value for this entry.
|
|
||||||
-}
|
|
||||||
c
|
|
||||||
, eComment :
|
, eComment :
|
||||||
{-
|
{-
|
||||||
A short description of this entry (if none, use a blank string)
|
A short description of this entry (if none, use a blank string)
|
||||||
|
@ -474,35 +507,107 @@ let Entry =
|
||||||
|
|
||||||
let EntryGetter =
|
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 =
|
{ Type =
|
||||||
Entry EntryAcntGetter (Optional EntryNumGetter) EntryCurGetter TagID
|
{ tsgValue : EntryNumGetter
|
||||||
, default = { eValue = None EntryNumGetter, eComment = "" }
|
, tsgCurrency : EntryCurGetter
|
||||||
|
, tsgFrom : (TxHalfGetter FromEntryGetter.Type).Type
|
||||||
|
, tsgTo : (TxHalfGetter ToEntryGetter.Type).Type
|
||||||
|
}
|
||||||
|
, default = { tsgFrom = TxHalfGetter, tsgTo = TxHalfGetter }
|
||||||
}
|
}
|
||||||
|
|
||||||
let TxGetter =
|
let TxGetter =
|
||||||
{-
|
{-
|
||||||
A means for transforming one row in a statement to a transaction
|
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 :
|
{ Type =
|
||||||
{-
|
{ tgFrom : (TxHalfGetter FromEntryGetter.Type).Type
|
||||||
A means of getting entries for this transaction (minimum 1)
|
, tgTo : (TxHalfGetter ToEntryGetter.Type).Type
|
||||||
-}
|
, tgScale : Double
|
||||||
List EntryGetter.Type
|
, tgCurrency : EntryCurGetter
|
||||||
, tgCurrency :
|
, tgOtherEntries : List TxSubGetter.Type
|
||||||
{-
|
}
|
||||||
Currency against which entries in this transaction will be balanced
|
, default =
|
||||||
-}
|
{ tgOtherEntries = [] : List TxSubGetter.Type
|
||||||
EntryCurGetter
|
, tgFrom = TxHalfGetter
|
||||||
, tgAcnt :
|
, tgTo = TxHalfGetter
|
||||||
{-
|
, tgScale = 1.0
|
||||||
Account in which entries in this transaction will be balanced
|
}
|
||||||
-}
|
|
||||||
EntryAcntGetter
|
|
||||||
}
|
}
|
||||||
|
|
||||||
let StatementParser_ =
|
let StatementParser_ =
|
||||||
|
@ -542,7 +647,7 @@ let StatementParser_ =
|
||||||
a transaction. If none, don't make a transaction (eg 'skip'
|
a transaction. If none, don't make a transaction (eg 'skip'
|
||||||
this row in the statement).
|
this row in the statement).
|
||||||
-}
|
-}
|
||||||
Optional TxGetter
|
Optional TxGetter.Type
|
||||||
, spTimes :
|
, spTimes :
|
||||||
{-
|
{-
|
||||||
Match at most this many rows; if none there is no limit
|
Match at most this many rows; if none there is no limit
|
||||||
|
@ -559,7 +664,7 @@ let StatementParser_ =
|
||||||
, spVal = ValMatcher::{=}
|
, spVal = ValMatcher::{=}
|
||||||
, spDesc = None Text
|
, spDesc = None Text
|
||||||
, spOther = [] : List (FieldMatcher_ re)
|
, spOther = [] : List (FieldMatcher_ re)
|
||||||
, spTx = None TxGetter
|
, spTx = None TxGetter.Type
|
||||||
, spTimes = None Natural
|
, spTimes = None Natural
|
||||||
, spPriority = +0
|
, spPriority = +0
|
||||||
}
|
}
|
||||||
|
@ -577,7 +682,29 @@ let Amount =
|
||||||
-}
|
-}
|
||||||
\(w : Type) ->
|
\(w : Type) ->
|
||||||
\(v : 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 =
|
let Transfer =
|
||||||
{-
|
{-
|
||||||
|
@ -590,14 +717,24 @@ let Transfer =
|
||||||
{ transFrom : a
|
{ transFrom : a
|
||||||
, transTo : a
|
, transTo : a
|
||||||
, transCurrency : c
|
, 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 =
|
let HistTransfer =
|
||||||
{-
|
{-
|
||||||
A manually specified historical transfer
|
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 =
|
let Statement =
|
||||||
{-
|
{-
|
||||||
|
@ -634,44 +771,6 @@ let History =
|
||||||
-}
|
-}
|
||||||
< HistTransfer : HistTransfer | HistStatement : Statement >
|
< 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 =
|
let Allocation =
|
||||||
{-
|
{-
|
||||||
How to allocate a given budget stream. This can be thought of as a Transfer
|
How to allocate a given budget stream. This can be thought of as a Transfer
|
||||||
|
@ -679,12 +778,7 @@ let Allocation =
|
||||||
-}
|
-}
|
||||||
\(w : Type) ->
|
\(w : Type) ->
|
||||||
\(v : Type) ->
|
\(v : Type) ->
|
||||||
{ alloTo : TaggedAcnt
|
{ alloTo : TaggedAcnt.Type, alloAmts : List (Amount w v).Type }
|
||||||
, alloAmts : List (Amount w v)
|
|
||||||
, alloCur :
|
|
||||||
{-TODO allow exchanges here-}
|
|
||||||
CurID
|
|
||||||
}
|
|
||||||
|
|
||||||
let PretaxValue =
|
let PretaxValue =
|
||||||
{-
|
{-
|
||||||
|
@ -779,6 +873,8 @@ let SingleAllocation =
|
||||||
-}
|
-}
|
||||||
Allocation {}
|
Allocation {}
|
||||||
|
|
||||||
|
let SingleAlloAmount = \(v : Type) -> Amount {} v
|
||||||
|
|
||||||
let MultiAllocation =
|
let MultiAllocation =
|
||||||
{-
|
{-
|
||||||
An allocation specialized to capturing multiple income streams within a given
|
An allocation specialized to capturing multiple income streams within a given
|
||||||
|
@ -787,6 +883,8 @@ let MultiAllocation =
|
||||||
-}
|
-}
|
||||||
Allocation Interval
|
Allocation Interval
|
||||||
|
|
||||||
|
let MultiAlloAmount = \(v : Type) -> Amount Interval v
|
||||||
|
|
||||||
let HourlyPeriod =
|
let HourlyPeriod =
|
||||||
{-
|
{-
|
||||||
Definition for a pay period denominated in hours
|
Definition for a pay period denominated in hours
|
||||||
|
@ -869,18 +967,20 @@ let Income =
|
||||||
This must be an income AcntID, and is the only place income
|
This must be an income AcntID, and is the only place income
|
||||||
accounts may be specified in the entire budget.
|
accounts may be specified in the entire budget.
|
||||||
-}
|
-}
|
||||||
TaggedAcnt
|
TaggedAcnt.Type
|
||||||
, incToBal :
|
, incToBal :
|
||||||
{-
|
{-
|
||||||
The account to which to send the remainder of the income stream
|
The account to which to send the remainder of the income stream
|
||||||
(if any) after all allocations have been applied.
|
(if any) after all allocations have been applied.
|
||||||
-}
|
-}
|
||||||
TaggedAcnt
|
TaggedAcnt.Type
|
||||||
|
, incPriority : Integer
|
||||||
}
|
}
|
||||||
, default =
|
, default =
|
||||||
{ incPretax = [] : List (SingleAllocation PretaxValue)
|
{ incPretax = [] : List (SingleAllocation PretaxValue)
|
||||||
, incTaxes = [] : List (SingleAllocation TaxValue)
|
, incTaxes = [] : List (SingleAllocation TaxValue)
|
||||||
, incPosttaxx = [] : List (SingleAllocation PosttaxValue)
|
, incPosttaxx = [] : List (SingleAllocation PosttaxValue)
|
||||||
|
, incPriority = +0
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -937,17 +1037,6 @@ let TransferMatcher =
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
let BudgetTransferType =
|
|
||||||
{-
|
|
||||||
The type of a budget transfer.
|
|
||||||
|
|
||||||
BTFixed: Tranfer a fixed amount
|
|
||||||
BTPercent: Transfer a percent of the source account to destination
|
|
||||||
BTTarget: Transfer an amount such that the destination has a given target
|
|
||||||
value
|
|
||||||
-}
|
|
||||||
< BTPercent | BTTarget | BTFixed >
|
|
||||||
|
|
||||||
let ShadowTransfer =
|
let ShadowTransfer =
|
||||||
{-
|
{-
|
||||||
A transaction analogous to another transfer with given properties.
|
A transaction analogous to another transfer with given properties.
|
||||||
|
@ -956,17 +1045,17 @@ let ShadowTransfer =
|
||||||
{-
|
{-
|
||||||
Source of this transfer
|
Source of this transfer
|
||||||
-}
|
-}
|
||||||
TaggedAcnt
|
TaggedAcnt.Type
|
||||||
, stTo :
|
, stTo :
|
||||||
{-
|
{-
|
||||||
Destination of this transfer.
|
Destination of this transfer.
|
||||||
-}
|
-}
|
||||||
TaggedAcnt
|
TaggedAcnt.Type
|
||||||
, stCurrency :
|
, stCurrency :
|
||||||
{-
|
{-
|
||||||
Currency of this transfer.
|
Currency of this transfer.
|
||||||
-}
|
-}
|
||||||
BudgetCurrency
|
CurID
|
||||||
, stDesc :
|
, stDesc :
|
||||||
{-
|
{-
|
||||||
Description of this transfer.
|
Description of this transfer.
|
||||||
|
@ -980,7 +1069,7 @@ let ShadowTransfer =
|
||||||
specified in other fields of this type.
|
specified in other fields of this type.
|
||||||
-}
|
-}
|
||||||
TransferMatcher.Type
|
TransferMatcher.Type
|
||||||
, stType : BudgetTransferType
|
, stType : TransferType
|
||||||
, stRatio :
|
, stRatio :
|
||||||
{-
|
{-
|
||||||
Fixed multipler to translate value of matched transfer to this one.
|
Fixed multipler to translate value of matched transfer to this one.
|
||||||
|
@ -988,17 +1077,11 @@ let ShadowTransfer =
|
||||||
Double
|
Double
|
||||||
}
|
}
|
||||||
|
|
||||||
let BudgetTransferValue =
|
|
||||||
{-
|
|
||||||
Means to determine the value of a budget transfer.
|
|
||||||
-}
|
|
||||||
{ btVal : Double, btType : BudgetTransferType }
|
|
||||||
|
|
||||||
let BudgetTransfer =
|
let BudgetTransfer =
|
||||||
{-
|
{-
|
||||||
A manually specified transaction for a budget
|
A manually specified transaction for a budget
|
||||||
-}
|
-}
|
||||||
Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
|
HistTransfer
|
||||||
|
|
||||||
let Budget =
|
let Budget =
|
||||||
{-
|
{-
|
||||||
|
@ -1040,6 +1123,7 @@ in { CurID
|
||||||
, CronPat
|
, CronPat
|
||||||
, DatePat
|
, DatePat
|
||||||
, TxOpts
|
, TxOpts
|
||||||
|
, TxOpts_
|
||||||
, StatementParser
|
, StatementParser
|
||||||
, StatementParser_
|
, StatementParser_
|
||||||
, ValMatcher
|
, ValMatcher
|
||||||
|
@ -1048,10 +1132,13 @@ in { CurID
|
||||||
, FieldMatcher
|
, FieldMatcher
|
||||||
, FieldMatcher_
|
, FieldMatcher_
|
||||||
, EntryNumGetter
|
, EntryNumGetter
|
||||||
|
, LinkedEntryNumGetter
|
||||||
|
, LinkedNumGetter
|
||||||
, Field
|
, Field
|
||||||
, FieldMap
|
, FieldMap
|
||||||
, Entry
|
, Entry
|
||||||
, EntryGetter
|
, FromEntryGetter
|
||||||
|
, ToEntryGetter
|
||||||
, EntryTextGetter
|
, EntryTextGetter
|
||||||
, EntryCurGetter
|
, EntryCurGetter
|
||||||
, EntryAcntGetter
|
, EntryAcntGetter
|
||||||
|
@ -1065,9 +1152,8 @@ in { CurID
|
||||||
, TransferMatcher
|
, TransferMatcher
|
||||||
, ShadowTransfer
|
, ShadowTransfer
|
||||||
, AcntSet
|
, AcntSet
|
||||||
, BudgetCurrency
|
|
||||||
, Exchange
|
|
||||||
, TaggedAcnt
|
, TaggedAcnt
|
||||||
|
, AccountTree
|
||||||
, Account
|
, Account
|
||||||
, Placeholder
|
, Placeholder
|
||||||
, PretaxValue
|
, PretaxValue
|
||||||
|
@ -1076,13 +1162,20 @@ in { CurID
|
||||||
, TaxProgression
|
, TaxProgression
|
||||||
, TaxMethod
|
, TaxMethod
|
||||||
, TaxValue
|
, TaxValue
|
||||||
, BudgetTransferValue
|
, TransferValue
|
||||||
, BudgetTransferType
|
, TransferType
|
||||||
, TxGetter
|
, TxGetter
|
||||||
|
, TxSubGetter
|
||||||
|
, TxHalfGetter
|
||||||
|
, FromTxHalfGetter
|
||||||
|
, ToTxHalfGetter
|
||||||
, HistTransfer
|
, HistTransfer
|
||||||
, SingleAllocation
|
, SingleAllocation
|
||||||
, MultiAllocation
|
, MultiAllocation
|
||||||
, HourlyPeriod
|
, HourlyPeriod
|
||||||
, Period
|
, Period
|
||||||
, PeriodType
|
, PeriodType
|
||||||
|
, TransferAmount
|
||||||
|
, MultiAlloAmount
|
||||||
|
, SingleAlloAmount
|
||||||
}
|
}
|
||||||
|
|
|
@ -4,18 +4,10 @@ let List/map =
|
||||||
|
|
||||||
let T = ./Types.dhall
|
let T = ./Types.dhall
|
||||||
|
|
||||||
let nullSplit =
|
let nullEntry =
|
||||||
\(a : T.EntryAcntGetter) ->
|
\(a : T.EntryAcntGetter) ->
|
||||||
\(c : T.EntryCurGetter) ->
|
\(v : T.EntryNumGetter) ->
|
||||||
T.EntryGetter::{ eAcnt = a, eCurrency = c, eTags = [] : List T.TagID }
|
T.FromEntryGetter::{ eAcnt = a, eValue = v }
|
||||||
|
|
||||||
let nullOpts = T.TxOpts::{=}
|
|
||||||
|
|
||||||
let nullVal = T.ValMatcher::{=}
|
|
||||||
|
|
||||||
let nullMatch = T.StatementParser::{=}
|
|
||||||
|
|
||||||
let nullCron = T.CronPat::{=}
|
|
||||||
|
|
||||||
let nullMod =
|
let nullMod =
|
||||||
\(by : Natural) ->
|
\(by : Natural) ->
|
||||||
|
@ -27,21 +19,22 @@ let cron1 =
|
||||||
\(m : Natural) ->
|
\(m : Natural) ->
|
||||||
\(d : Natural) ->
|
\(d : Natural) ->
|
||||||
T.DatePat.Cron
|
T.DatePat.Cron
|
||||||
( nullCron
|
T.CronPat::{
|
||||||
// { cpYear = Some (T.MDYPat.Single y)
|
, cpYear = Some (T.MDYPat.Single y)
|
||||||
, cpMonth = Some (T.MDYPat.Single m)
|
, cpMonth = Some (T.MDYPat.Single m)
|
||||||
, cpDay = Some (T.MDYPat.Single d)
|
, 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 =
|
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
|
let match1_ = matchN_ 1
|
||||||
|
|
||||||
|
@ -86,46 +79,45 @@ let mRngYMD =
|
||||||
\(r : Natural) ->
|
\(r : Natural) ->
|
||||||
T.DateMatcher.In { _1 = T.YMDMatcher.YMD (greg y m d), _2 = r }
|
T.DateMatcher.In { _1 = T.YMDMatcher.YMD (greg y m d), _2 = r }
|
||||||
|
|
||||||
let PartSplit = { _1 : T.AcntID, _2 : Double, _3 : Text }
|
let PartEntry = { _1 : T.AcntID, _2 : Double, _3 : Text }
|
||||||
|
|
||||||
let partN =
|
let partNFrom =
|
||||||
\(c : T.EntryCurGetter) ->
|
\(ss : List PartEntry) ->
|
||||||
\(a : T.EntryAcntGetter) ->
|
let toEntry =
|
||||||
\(comment : Text) ->
|
\(x : PartEntry) ->
|
||||||
\(ss : List PartSplit) ->
|
T.FromEntryGetter::{
|
||||||
let toSplit =
|
, eAcnt = T.EntryAcntGetter.ConstT x._1
|
||||||
\(x : PartSplit) ->
|
, eValue = T.EntryNumGetter.ConstN x._2
|
||||||
nullSplit (T.EntryAcntGetter.ConstT x._1) c
|
|
||||||
// { eValue = Some (T.EntryNumGetter.ConstN x._2)
|
|
||||||
, eComment = x._3
|
, eComment = x._3
|
||||||
}
|
}
|
||||||
|
|
||||||
in [ nullSplit a c // { eComment = comment } ]
|
in List/map PartEntry T.FromEntryGetter.Type toEntry ss
|
||||||
# List/map PartSplit T.EntryGetter.Type toSplit ss
|
|
||||||
|
|
||||||
let part1 =
|
let partNTo =
|
||||||
\(c : T.EntryCurGetter) ->
|
\(ss : List PartEntry) ->
|
||||||
\(a : T.EntryAcntGetter) ->
|
let toEntry =
|
||||||
\(comment : Text) ->
|
\(x : PartEntry) ->
|
||||||
partN c a comment ([] : List PartSplit)
|
T.ToEntryGetter::{
|
||||||
|
, eAcnt = T.EntryAcntGetter.ConstT x._1
|
||||||
|
, eValue =
|
||||||
|
T.LinkedEntryNumGetter.Getter (T.EntryNumGetter.ConstN x._2)
|
||||||
|
, eComment = x._3
|
||||||
|
}
|
||||||
|
|
||||||
let part1_ =
|
in List/map PartEntry T.ToEntryGetter.Type toEntry ss
|
||||||
\(c : T.EntryCurGetter) ->
|
|
||||||
\(a : T.EntryAcntGetter) ->
|
|
||||||
partN c a "" ([] : List PartSplit)
|
|
||||||
|
|
||||||
let addDay =
|
let addDay =
|
||||||
\(x : T.GregorianM) ->
|
\(x : T.GregorianM) ->
|
||||||
\(d : Natural) ->
|
\(d : Natural) ->
|
||||||
{ gYear = x.gmYear, gMonth = x.gmMonth, gDay = d }
|
{ 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 }
|
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 }
|
let mvDenN = \(x : Natural) -> mvN // { vmDen = Some x }
|
||||||
|
|
||||||
in { nullSplit
|
in { cron1
|
||||||
, nullMatch
|
|
||||||
, nullVal
|
|
||||||
, nullOpts
|
|
||||||
, nullCron
|
|
||||||
, nullMod
|
|
||||||
, cron1
|
|
||||||
, mY
|
, mY
|
||||||
, mYM
|
, mYM
|
||||||
, mYMD
|
, mYMD
|
||||||
|
@ -156,9 +142,8 @@ in { nullSplit
|
||||||
, match1
|
, match1
|
||||||
, greg
|
, greg
|
||||||
, gregM
|
, gregM
|
||||||
, partN
|
, partNFrom
|
||||||
, part1
|
, partNTo
|
||||||
, part1_
|
|
||||||
, addDay
|
, addDay
|
||||||
, comma = 44
|
, comma = 44
|
||||||
, tab = 9
|
, tab = 9
|
||||||
|
@ -170,6 +155,8 @@ in { nullSplit
|
||||||
, mvDen
|
, mvDen
|
||||||
, mvDenP
|
, mvDenP
|
||||||
, mvDenN
|
, mvDenN
|
||||||
, PartSplit
|
, PartEntry
|
||||||
|
, nullEntry
|
||||||
|
, nullMod
|
||||||
}
|
}
|
||||||
/\ T
|
/\ T
|
||||||
|
|
|
@ -1,9 +1,9 @@
|
||||||
module Internal.Budget (insertBudget) where
|
module Internal.Budget (readBudget) where
|
||||||
|
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
|
import Data.Decimal hiding (allocate)
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
import Database.Persist.Monad
|
import Data.Hashable
|
||||||
import Internal.Database
|
|
||||||
import Internal.Types.Main
|
import Internal.Types.Main
|
||||||
import Internal.Utils
|
import Internal.Utils
|
||||||
import RIO hiding (to)
|
import RIO hiding (to)
|
||||||
|
@ -13,22 +13,8 @@ import qualified RIO.NonEmpty as NE
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
import RIO.Time
|
import RIO.Time
|
||||||
|
|
||||||
-- each budget (designated at the top level by a 'name') is processed in the
|
readBudget :: (MonadAppError m, MonadFinance m) => Budget -> m [Tx CommitR]
|
||||||
-- following steps
|
readBudget
|
||||||
-- 1. expand all transactions given the desired date range and date patterns for
|
|
||||||
-- each directive in the budget
|
|
||||||
-- 2. sort all transactions by date
|
|
||||||
-- 3. propagate all balances forward, and while doing so assign values to each
|
|
||||||
-- transaction (some of which depend on the 'current' balance of the
|
|
||||||
-- target account)
|
|
||||||
-- 4. assign shadow transactions
|
|
||||||
-- 5. insert all transactions
|
|
||||||
|
|
||||||
insertBudget
|
|
||||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
|
||||||
=> Budget
|
|
||||||
-> m ()
|
|
||||||
insertBudget
|
|
||||||
b@Budget
|
b@Budget
|
||||||
{ bgtLabel
|
{ bgtLabel
|
||||||
, bgtIncomes
|
, bgtIncomes
|
||||||
|
@ -39,15 +25,19 @@ insertBudget
|
||||||
, bgtPosttax
|
, bgtPosttax
|
||||||
, bgtInterval
|
, bgtInterval
|
||||||
} =
|
} =
|
||||||
whenHash CTBudget b () $ \key -> do
|
do
|
||||||
|
spanRes <- getSpan
|
||||||
|
case spanRes of
|
||||||
|
Nothing -> return []
|
||||||
|
Just budgetSpan -> do
|
||||||
(intAllos, _) <- combineError intAlloRes acntRes (,)
|
(intAllos, _) <- combineError intAlloRes acntRes (,)
|
||||||
let res1 = mapErrors (insertIncome key bgtLabel intAllos bgtInterval) bgtIncomes
|
let res1 = mapErrors (readIncome c bgtLabel intAllos budgetSpan) bgtIncomes
|
||||||
let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers
|
let res2 = expandTransfers c bgtLabel budgetSpan bgtTransfers
|
||||||
txs <- combineError (concat <$> res1) res2 (++)
|
txs <- combineError (concat <$> res1) res2 (++)
|
||||||
m <- askDBState kmCurrency
|
shadow <- addShadowTransfers bgtShadowTransfers txs
|
||||||
shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs
|
return $ txs ++ shadow
|
||||||
void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow
|
|
||||||
where
|
where
|
||||||
|
c = CommitR (CommitHash $ hash b) CTBudget
|
||||||
acntRes = mapErrors isNotIncomeAcnt alloAcnts
|
acntRes = mapErrors isNotIncomeAcnt alloAcnts
|
||||||
intAlloRes = combineError3 pre_ tax_ post_ (,,)
|
intAlloRes = combineError3 pre_ tax_ post_ (,,)
|
||||||
pre_ = sortAllos bgtPretax
|
pre_ = sortAllos bgtPretax
|
||||||
|
@ -58,73 +48,15 @@ insertBudget
|
||||||
(alloAcnt <$> bgtPretax)
|
(alloAcnt <$> bgtPretax)
|
||||||
++ (alloAcnt <$> bgtTax)
|
++ (alloAcnt <$> bgtTax)
|
||||||
++ (alloAcnt <$> bgtPosttax)
|
++ (alloAcnt <$> bgtPosttax)
|
||||||
|
getSpan = do
|
||||||
|
globalSpan <- asks (unBSpan . csBudgetScope)
|
||||||
|
case bgtInterval of
|
||||||
|
Nothing -> return $ Just globalSpan
|
||||||
|
Just bi -> do
|
||||||
|
localSpan <- liftExcept $ resolveDaySpan bi
|
||||||
|
return $ intersectDaySpan globalSpan localSpan
|
||||||
|
|
||||||
balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
|
sortAllo :: MultiAllocation v -> AppExcept (DaySpanAllocation v)
|
||||||
balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
|
|
||||||
where
|
|
||||||
go bals f@FlatTransfer {ftFrom, ftTo, ftValue = UnbalancedValue {cvValue, cvType}} =
|
|
||||||
let balTo = M.findWithDefault 0 ftTo bals
|
|
||||||
x = amtToMove balTo cvType cvValue
|
|
||||||
bals' = mapAdd_ ftTo x $ mapAdd_ ftFrom (-x) bals
|
|
||||||
in (bals', f {ftValue = x})
|
|
||||||
-- TODO might need to query signs to make this intuitive; as it is this will
|
|
||||||
-- probably work, but for credit accounts I might need to supply a negative
|
|
||||||
-- target value
|
|
||||||
amtToMove _ BTFixed x = x
|
|
||||||
amtToMove bal BTPercent x = -(x / 100 * bal)
|
|
||||||
amtToMove bal BTTarget x = x - bal
|
|
||||||
|
|
||||||
-- TODO this seems too general for this module
|
|
||||||
mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
|
|
||||||
mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k
|
|
||||||
|
|
||||||
insertBudgetTx
|
|
||||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
|
||||||
=> BalancedTransfer
|
|
||||||
-> m ()
|
|
||||||
insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do
|
|
||||||
((sFrom, sTo), exchange) <- entryPair ftFrom ftTo ftCur ftValue
|
|
||||||
insertPair sFrom sTo
|
|
||||||
forM_ exchange $ uncurry insertPair
|
|
||||||
where
|
|
||||||
insertPair from to = do
|
|
||||||
k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc
|
|
||||||
insertBudgetLabel k from
|
|
||||||
insertBudgetLabel k to
|
|
||||||
insertBudgetLabel k entry = do
|
|
||||||
sk <- insertEntry k entry
|
|
||||||
insert_ $ BudgetLabelR sk $ bmName ftMeta
|
|
||||||
|
|
||||||
entryPair
|
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
|
||||||
=> TaggedAcnt
|
|
||||||
-> TaggedAcnt
|
|
||||||
-> BudgetCurrency
|
|
||||||
-> Rational
|
|
||||||
-> m (EntryPair, Maybe EntryPair)
|
|
||||||
entryPair from to cur val = case cur of
|
|
||||||
NoX curid -> (,Nothing) <$> pair curid from to val
|
|
||||||
X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do
|
|
||||||
let middle = TaggedAcnt xAcnt []
|
|
||||||
let res1 = pair xFromCur from middle val
|
|
||||||
let res2 = pair xToCur middle to (val * roundPrecision 3 xRate)
|
|
||||||
combineError res1 res2 $ \a b -> (a, Just b)
|
|
||||||
where
|
|
||||||
pair curid from_ to_ v = do
|
|
||||||
let s1 = entry curid from_ (-v)
|
|
||||||
let s2 = entry curid to_ v
|
|
||||||
combineError s1 s2 (,)
|
|
||||||
entry c TaggedAcnt {taAcnt, taTags} v =
|
|
||||||
resolveEntry $
|
|
||||||
Entry
|
|
||||||
{ eAcnt = taAcnt
|
|
||||||
, eValue = v
|
|
||||||
, eComment = ""
|
|
||||||
, eCurrency = c
|
|
||||||
, eTags = taTags
|
|
||||||
}
|
|
||||||
|
|
||||||
sortAllo :: MultiAllocation v -> InsertExcept (DaySpanAllocation v)
|
|
||||||
sortAllo a@Allocation {alloAmts = as} = do
|
sortAllo a@Allocation {alloAmts = as} = do
|
||||||
bs <- foldSpan [] $ L.sortOn amtWhen as
|
bs <- foldSpan [] $ L.sortOn amtWhen as
|
||||||
return $ a {alloAmts = reverse bs}
|
return $ a {alloAmts = reverse bs}
|
||||||
|
@ -143,100 +75,107 @@ sortAllo a@Allocation {alloAmts = as} = do
|
||||||
-- TODO this will scan the interval allocations fully each time
|
-- TODO this will scan the interval allocations fully each time
|
||||||
-- iteration which is a total waste, but the fix requires turning this
|
-- iteration which is a total waste, but the fix requires turning this
|
||||||
-- loop into a fold which I don't feel like doing now :(
|
-- loop into a fold which I don't feel like doing now :(
|
||||||
insertIncome
|
readIncome
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: (MonadAppError m, MonadFinance m)
|
||||||
=> CommitRId
|
=> CommitR
|
||||||
-> T.Text
|
-> BudgetName
|
||||||
-> IntAllocations
|
-> IntAllocations
|
||||||
-> Maybe Interval
|
-> DaySpan
|
||||||
-> Income
|
-> Income
|
||||||
-> m [UnbalancedTransfer]
|
-> m [Tx CommitR]
|
||||||
insertIncome
|
readIncome
|
||||||
key
|
key
|
||||||
name
|
name
|
||||||
(intPre, intTax, intPost)
|
(intPre, intTax, intPost)
|
||||||
localInterval
|
ds
|
||||||
Income
|
Income
|
||||||
{ incWhen
|
{ incWhen
|
||||||
, incCurrency
|
, incCurrency
|
||||||
, incFrom
|
, incFrom = TaggedAcnt {taAcnt = srcAcnt, taTags = srcTags}
|
||||||
, incPretax
|
, incPretax
|
||||||
, incPosttax
|
, incPosttax
|
||||||
, incTaxes
|
, incTaxes
|
||||||
, incToBal
|
, incToBal = TaggedAcnt {taAcnt = destAcnt, taTags = destTags}
|
||||||
, incGross
|
, incGross
|
||||||
, incPayPeriod
|
, incPayPeriod
|
||||||
|
, incPriority
|
||||||
} =
|
} =
|
||||||
combineErrorM
|
combineErrorM
|
||||||
(combineError incRes nonIncRes (,))
|
(combineError incRes nonIncRes (,))
|
||||||
(combineError precRes dayRes (,))
|
(combineError cpRes dayRes (,))
|
||||||
$ \_ (precision, days) -> do
|
$ \_ (cp, days) -> do
|
||||||
let gross = roundPrecision precision incGross
|
let gross = realFracToDecimalP (cpPrec cp) incGross
|
||||||
concat <$> foldDays (allocate precision gross) start days
|
foldDays (allocate cp gross) start days
|
||||||
where
|
where
|
||||||
incRes = isIncomeAcnt $ taAcnt incFrom
|
srcAcnt' = AcntID srcAcnt
|
||||||
|
destAcnt' = AcntID destAcnt
|
||||||
|
incRes = isIncomeAcnt srcAcnt'
|
||||||
nonIncRes =
|
nonIncRes =
|
||||||
mapErrors isNotIncomeAcnt $
|
mapErrors isNotIncomeAcnt $
|
||||||
taAcnt incToBal
|
destAcnt'
|
||||||
: (alloAcnt <$> incPretax)
|
: (alloAcnt <$> incPretax)
|
||||||
++ (alloAcnt <$> incTaxes)
|
++ (alloAcnt <$> incTaxes)
|
||||||
++ (alloAcnt <$> incPosttax)
|
++ (alloAcnt <$> incPosttax)
|
||||||
precRes = lookupCurrencyPrec incCurrency
|
cpRes = lookupCurrency incCurrency
|
||||||
dayRes = askDays incWhen localInterval
|
dayRes = liftExcept $ expandDatePat ds incWhen
|
||||||
start = fromGregorian' $ pStart incPayPeriod
|
start = fromGregorian' $ pStart incPayPeriod
|
||||||
pType' = pType incPayPeriod
|
pType' = pType incPayPeriod
|
||||||
meta = BudgetMeta key name
|
|
||||||
flatPre = concatMap flattenAllo incPretax
|
flatPre = concatMap flattenAllo incPretax
|
||||||
flatTax = concatMap flattenAllo incTaxes
|
flatTax = concatMap flattenAllo incTaxes
|
||||||
flatPost = concatMap flattenAllo incPosttax
|
flatPost = concatMap flattenAllo incPosttax
|
||||||
sumAllos = sum . fmap faValue
|
sumAllos = sum . fmap faValue
|
||||||
-- TODO ensure these are all the "correct" accounts
|
entry0 a c ts = Entry {eAcnt = a, eValue = (), eComment = c, eTags = ts}
|
||||||
allocate precision gross prevDay day = do
|
allocate cp gross prevDay day = do
|
||||||
scaler <- liftExcept $ periodScaler pType' prevDay day
|
scaler <- liftExcept $ periodScaler pType' prevDay day
|
||||||
|
let precision = cpPrec cp
|
||||||
let (preDeductions, pre) =
|
let (preDeductions, pre) =
|
||||||
allocatePre precision gross $
|
allocatePre precision gross $
|
||||||
flatPre ++ concatMap (selectAllos day) intPre
|
flatPre ++ concatMap (selectAllos day) intPre
|
||||||
tax =
|
let tax =
|
||||||
allocateTax precision gross preDeductions scaler $
|
allocateTax precision gross preDeductions scaler $
|
||||||
flatTax ++ concatMap (selectAllos day) intTax
|
flatTax ++ concatMap (selectAllos day) intTax
|
||||||
aftertaxGross = gross - sumAllos (tax ++ pre)
|
aftertaxGross = gross - sumAllos (tax ++ pre)
|
||||||
post =
|
let post =
|
||||||
allocatePost precision aftertaxGross $
|
allocatePost precision aftertaxGross $
|
||||||
flatPost ++ concatMap (selectAllos day) intPost
|
flatPost ++ concatMap (selectAllos day) intPost
|
||||||
balance = aftertaxGross - sumAllos post
|
let src = entry0 srcAcnt' "gross income" (TagID <$> srcTags)
|
||||||
bal =
|
let dest = entry0 destAcnt' "balance after deductions" (TagID <$> destTags)
|
||||||
FlatTransfer
|
let allos = allo2Trans <$> (pre ++ tax ++ post)
|
||||||
{ ftMeta = meta
|
let primary =
|
||||||
, ftWhen = day
|
EntrySet
|
||||||
, ftFrom = incFrom
|
{ esTotalValue = gross
|
||||||
, ftCur = NoX incCurrency
|
, esCurrency = cpID cp
|
||||||
, ftTo = incToBal
|
, esFrom = HalfEntrySet {hesPrimary = src, hesOther = []}
|
||||||
, ftValue = UnbalancedValue BTFixed balance
|
, esTo = HalfEntrySet {hesPrimary = dest, hesOther = allos}
|
||||||
, ftDesc = "balance after deductions"
|
}
|
||||||
|
return $
|
||||||
|
Tx
|
||||||
|
{ txCommit = key
|
||||||
|
, txDate = day
|
||||||
|
, txPrimary = Left primary
|
||||||
|
, txOther = []
|
||||||
|
, txDescr = TxDesc ""
|
||||||
|
, txBudget = name
|
||||||
|
, txPriority = incPriority
|
||||||
}
|
}
|
||||||
in if balance < 0
|
|
||||||
then throwError $ InsertException [IncomeError day name balance]
|
|
||||||
else return (bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post))
|
|
||||||
|
|
||||||
periodScaler
|
periodScaler
|
||||||
:: PeriodType
|
:: PeriodType
|
||||||
-> Day
|
-> Day
|
||||||
-> Day
|
-> Day
|
||||||
-> InsertExcept PeriodScaler
|
-> AppExcept PeriodScaler
|
||||||
periodScaler pt prev cur = return scale
|
periodScaler pt prev cur = return scale
|
||||||
where
|
where
|
||||||
n = fromIntegral $ workingDays wds prev cur
|
n = workingDays wds prev cur
|
||||||
wds = case pt of
|
wds = case pt of
|
||||||
Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays
|
Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays
|
||||||
Daily ds -> ds
|
Daily ds -> ds
|
||||||
scale precision x = case pt of
|
scale prec x = case pt of
|
||||||
Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
|
Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
|
||||||
fromRational (rnd $ x / fromIntegral hpAnnualHours)
|
realFracToDecimalP prec (x / fromIntegral hpAnnualHours)
|
||||||
* fromIntegral hpDailyHours
|
* fromIntegral hpDailyHours
|
||||||
* n
|
* fromIntegral n
|
||||||
Daily _ -> x * n / 365.25
|
Daily _ -> realFracToDecimalP prec (x * fromIntegral n / 365.25)
|
||||||
where
|
|
||||||
rnd = roundPrecision precision
|
|
||||||
|
|
||||||
-- ASSUME start < end
|
-- ASSUME start < end
|
||||||
workingDays :: [Weekday] -> Day -> Day -> Natural
|
workingDays :: [Weekday] -> Day -> Day -> Natural
|
||||||
|
@ -252,7 +191,7 @@ workingDays wds start end = fromIntegral $ daysFull + daysTail
|
||||||
|
|
||||||
-- ASSUME days is a sorted list
|
-- ASSUME days is a sorted list
|
||||||
foldDays
|
foldDays
|
||||||
:: MonadInsertError m
|
:: MonadAppError m
|
||||||
=> (Day -> Day -> m a)
|
=> (Day -> Day -> m a)
|
||||||
-> Day
|
-> Day
|
||||||
-> [Day]
|
-> [Day]
|
||||||
|
@ -262,27 +201,27 @@ foldDays f start days = case NE.nonEmpty days of
|
||||||
Just ds
|
Just ds
|
||||||
| any (start >) ds ->
|
| any (start >) ds ->
|
||||||
throwError $
|
throwError $
|
||||||
InsertException [PeriodError start $ minimum ds]
|
AppException [PeriodError start $ minimum ds]
|
||||||
| otherwise ->
|
| otherwise ->
|
||||||
combineErrors $
|
combineErrors $
|
||||||
snd $
|
snd $
|
||||||
L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days
|
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
|
isIncomeAcnt = checkAcntType IncomeT
|
||||||
|
|
||||||
isNotIncomeAcnt :: (MonadInsertError m, MonadFinance m) => AcntID -> m ()
|
isNotIncomeAcnt :: (MonadAppError m, MonadFinance m) => AcntID -> m ()
|
||||||
isNotIncomeAcnt = checkAcntTypes (AssetT :| [EquityT, ExpenseT, LiabilityT])
|
isNotIncomeAcnt = checkAcntTypes (AssetT :| [EquityT, ExpenseT, LiabilityT])
|
||||||
|
|
||||||
checkAcntType
|
checkAcntType
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: (MonadAppError m, MonadFinance m)
|
||||||
=> AcntType
|
=> AcntType
|
||||||
-> AcntID
|
-> AcntID
|
||||||
-> m ()
|
-> m ()
|
||||||
checkAcntType t = checkAcntTypes (t :| [])
|
checkAcntType t = checkAcntTypes (t :| [])
|
||||||
|
|
||||||
checkAcntTypes
|
checkAcntTypes
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: (MonadAppError m, MonadFinance m)
|
||||||
=> NE.NonEmpty AcntType
|
=> NE.NonEmpty AcntType
|
||||||
-> AcntID
|
-> AcntID
|
||||||
-> m ()
|
-> m ()
|
||||||
|
@ -290,83 +229,70 @@ checkAcntTypes ts i = void $ go =<< lookupAccountType i
|
||||||
where
|
where
|
||||||
go t
|
go t
|
||||||
| t `L.elem` ts = return i
|
| t `L.elem` ts = return i
|
||||||
| otherwise = throwError $ InsertException [AccountError i ts]
|
| otherwise = throwError $ AppException [AccountTypeError i ts]
|
||||||
|
|
||||||
flattenAllo :: SingleAllocation v -> [FlatAllocation v]
|
flattenAllo :: SingleAllocation v -> [FlatAllocation v]
|
||||||
flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
|
flattenAllo Allocation {alloAmts, alloTo} = fmap go alloAmts
|
||||||
where
|
where
|
||||||
go Amount {amtValue, amtDesc} =
|
go Amount {amtValue, amtDesc} =
|
||||||
FlatAllocation
|
FlatAllocation
|
||||||
{ faCur = NoX alloCur
|
{ faTo = alloTo
|
||||||
, faTo = alloTo
|
|
||||||
, faValue = amtValue
|
, faValue = amtValue
|
||||||
, faDesc = amtDesc
|
, faDesc = amtDesc
|
||||||
}
|
}
|
||||||
|
|
||||||
-- ASSUME allocations are sorted
|
-- ASSUME allocations are sorted
|
||||||
selectAllos :: Day -> DaySpanAllocation v -> [FlatAllocation v]
|
selectAllos :: Day -> DaySpanAllocation v -> [FlatAllocation v]
|
||||||
selectAllos day Allocation {alloAmts, alloCur, alloTo} =
|
selectAllos day Allocation {alloAmts, alloTo} =
|
||||||
go <$> filter ((`inDaySpan` day) . amtWhen) alloAmts
|
go <$> filter ((`inDaySpan` day) . amtWhen) alloAmts
|
||||||
where
|
where
|
||||||
go Amount {amtValue, amtDesc} =
|
go Amount {amtValue, amtDesc} =
|
||||||
FlatAllocation
|
FlatAllocation
|
||||||
{ faCur = NoX alloCur
|
{ faTo = alloTo
|
||||||
, faTo = alloTo
|
|
||||||
, faValue = amtValue
|
, faValue = amtValue
|
||||||
, faDesc = amtDesc
|
, faDesc = amtDesc
|
||||||
}
|
}
|
||||||
|
|
||||||
allo2Trans
|
allo2Trans :: FlatAllocation Decimal -> Entry AcntID EntryLink TagID
|
||||||
:: BudgetMeta
|
allo2Trans FlatAllocation {faValue, faTo = TaggedAcnt {taAcnt, taTags}, faDesc} =
|
||||||
-> Day
|
Entry
|
||||||
-> TaggedAcnt
|
{ eValue = LinkValue (EntryFixed faValue)
|
||||||
-> FlatAllocation Rational
|
, eComment = faDesc
|
||||||
-> UnbalancedTransfer
|
, eAcnt = AcntID taAcnt
|
||||||
allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} =
|
, eTags = TagID <$> taTags
|
||||||
FlatTransfer
|
|
||||||
{ ftMeta = meta
|
|
||||||
, ftWhen = day
|
|
||||||
, ftFrom = from
|
|
||||||
, ftCur = faCur
|
|
||||||
, ftTo = faTo
|
|
||||||
, ftValue = UnbalancedValue BTFixed faValue
|
|
||||||
, ftDesc = faDesc
|
|
||||||
}
|
}
|
||||||
|
|
||||||
|
type PreDeductions = M.Map T.Text Decimal
|
||||||
|
|
||||||
allocatePre
|
allocatePre
|
||||||
:: Natural
|
:: Precision
|
||||||
-> Rational
|
-> Decimal
|
||||||
-> [FlatAllocation PretaxValue]
|
-> [FlatAllocation PretaxValue]
|
||||||
-> (M.Map T.Text Rational, [FlatAllocation Rational])
|
-> (PreDeductions, [FlatAllocation Decimal])
|
||||||
allocatePre precision gross = L.mapAccumR go M.empty
|
allocatePre precision gross = L.mapAccumR go M.empty
|
||||||
where
|
where
|
||||||
go m f@FlatAllocation {faValue} =
|
go m f@FlatAllocation {faValue = PretaxValue {preCategory, preValue, prePercent}} =
|
||||||
let c = preCategory faValue
|
let v =
|
||||||
p = preValue faValue
|
if prePercent
|
||||||
v =
|
then gross *. (preValue / 100)
|
||||||
if prePercent faValue
|
else realFracToDecimalP precision preValue
|
||||||
then (roundPrecision 3 p / 100) * gross
|
in (mapAdd_ preCategory v m, f {faValue = v})
|
||||||
else roundPrecision precision p
|
|
||||||
in (mapAdd_ c v m, f {faValue = v})
|
|
||||||
|
|
||||||
allocateTax
|
allocateTax
|
||||||
:: Natural
|
:: Precision
|
||||||
-> Rational
|
-> Decimal
|
||||||
-> M.Map T.Text Rational
|
-> PreDeductions
|
||||||
-> PeriodScaler
|
-> PeriodScaler
|
||||||
-> [FlatAllocation TaxValue]
|
-> [FlatAllocation TaxValue]
|
||||||
-> [FlatAllocation Rational]
|
-> [FlatAllocation Decimal]
|
||||||
allocateTax precision gross preDeds f = fmap (fmap go)
|
allocateTax precision gross preDeds f = fmap (fmap go)
|
||||||
where
|
where
|
||||||
go TaxValue {tvCategories, tvMethod} =
|
go TaxValue {tvCategories, tvMethod} =
|
||||||
let agi = gross - sum (mapMaybe (`M.lookup` preDeds) tvCategories)
|
let agi = gross - sum (mapMaybe (`M.lookup` preDeds) tvCategories)
|
||||||
in case tvMethod of
|
in case tvMethod of
|
||||||
TMPercent p ->
|
TMPercent p -> agi *. p / 100
|
||||||
roundPrecision precision $
|
|
||||||
fromRational $
|
|
||||||
roundPrecision 3 p / 100 * agi
|
|
||||||
TMBracket TaxProgression {tpDeductible, tpBrackets} ->
|
TMBracket TaxProgression {tpDeductible, tpBrackets} ->
|
||||||
let taxDed = roundPrecision precision $ f precision tpDeductible
|
let taxDed = f precision tpDeductible
|
||||||
in foldBracket f precision (agi - taxDed) tpBrackets
|
in foldBracket f precision (agi - taxDed) tpBrackets
|
||||||
|
|
||||||
-- | Compute effective tax percentage of a bracket
|
-- | Compute effective tax percentage of a bracket
|
||||||
|
@ -380,174 +306,80 @@ allocateTax precision gross preDeds f = fmap (fmap go)
|
||||||
--
|
--
|
||||||
-- In reality, this can all be done with one loop, but it isn't clear these
|
-- In reality, this can all be done with one loop, but it isn't clear these
|
||||||
-- three steps are implemented from this alone.
|
-- three steps are implemented from this alone.
|
||||||
foldBracket :: PeriodScaler -> Natural -> Rational -> [TaxBracket] -> Rational
|
foldBracket :: PeriodScaler -> Precision -> Decimal -> [TaxBracket] -> Decimal
|
||||||
foldBracket f precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
|
foldBracket f prec agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
|
||||||
where
|
where
|
||||||
go TaxBracket {tbLowerLimit, tbPercent} a@(acc, remain) =
|
go TaxBracket {tbLowerLimit, tbPercent} a@(acc, remain) =
|
||||||
let l = roundPrecision precision $ f precision tbLowerLimit
|
let l = f prec tbLowerLimit
|
||||||
p = roundPrecision 3 tbPercent / 100
|
in if remain >= l
|
||||||
in if remain >= l then (acc + p * (remain - l), l) else a
|
then (acc + (remain - l) *. (tbPercent / 100), l)
|
||||||
|
else a
|
||||||
|
|
||||||
allocatePost
|
allocatePost
|
||||||
:: Natural
|
:: Precision
|
||||||
-> Rational
|
-> Decimal
|
||||||
-> [FlatAllocation PosttaxValue]
|
-> [FlatAllocation PosttaxValue]
|
||||||
-> [FlatAllocation Rational]
|
-> [FlatAllocation Decimal]
|
||||||
allocatePost precision aftertax = fmap (fmap go)
|
allocatePost prec aftertax = fmap (fmap go)
|
||||||
where
|
where
|
||||||
go PosttaxValue {postValue, postPercent} =
|
go PosttaxValue {postValue, postPercent}
|
||||||
let v = postValue
|
| postPercent = aftertax *. (postValue / 100)
|
||||||
in if postPercent
|
| otherwise = realFracToDecimalP prec postValue
|
||||||
then aftertax * roundPrecision 3 v / 100
|
|
||||||
else roundPrecision precision v
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- Standalone Transfer
|
|
||||||
|
|
||||||
expandTransfers
|
|
||||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
|
||||||
=> CommitRId
|
|
||||||
-> T.Text
|
|
||||||
-> Maybe Interval
|
|
||||||
-> [BudgetTransfer]
|
|
||||||
-> m [UnbalancedTransfer]
|
|
||||||
expandTransfers key name localInterval ts = do
|
|
||||||
txs <-
|
|
||||||
fmap (L.sortOn ftWhen . concat) $
|
|
||||||
combineErrors $
|
|
||||||
fmap (expandTransfer key name) ts
|
|
||||||
case localInterval of
|
|
||||||
Nothing -> return txs
|
|
||||||
Just i -> do
|
|
||||||
bounds <- liftExcept $ resolveDaySpan i
|
|
||||||
return $ filter (inDaySpan bounds . ftWhen) txs
|
|
||||||
|
|
||||||
expandTransfer
|
|
||||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
|
||||||
=> CommitRId
|
|
||||||
-> T.Text
|
|
||||||
-> BudgetTransfer
|
|
||||||
-> m [UnbalancedTransfer]
|
|
||||||
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do
|
|
||||||
precision <- lookupCurrencyPrec $ initialCurrency transCurrency
|
|
||||||
fmap concat $ combineErrors $ fmap (go precision) transAmounts
|
|
||||||
where
|
|
||||||
go
|
|
||||||
precision
|
|
||||||
Amount
|
|
||||||
{ amtWhen = pat
|
|
||||||
, amtValue = BudgetTransferValue {btVal = v, btType = y}
|
|
||||||
, amtDesc = desc
|
|
||||||
} =
|
|
||||||
withDates pat $ \day -> do
|
|
||||||
let meta = BudgetMeta {bmCommit = key, bmName = name}
|
|
||||||
return
|
|
||||||
FlatTransfer
|
|
||||||
{ ftMeta = meta
|
|
||||||
, ftWhen = day
|
|
||||||
, ftCur = transCurrency
|
|
||||||
, ftFrom = transFrom
|
|
||||||
, ftTo = transTo
|
|
||||||
, ftValue = UnbalancedValue y $ roundPrecision precision v
|
|
||||||
, ftDesc = desc
|
|
||||||
}
|
|
||||||
|
|
||||||
withDates
|
|
||||||
:: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
|
|
||||||
=> DatePat
|
|
||||||
-> (Day -> m a)
|
|
||||||
-> m [a]
|
|
||||||
withDates dp f = do
|
|
||||||
bounds <- askDBState kmBudgetInterval
|
|
||||||
days <- liftExcept $ expandDatePat bounds dp
|
|
||||||
combineErrors $ fmap f days
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- shadow transfers
|
-- shadow transfers
|
||||||
|
|
||||||
-- TODO this is going to be O(n*m), which might be a problem?
|
-- TODO this is going to be O(n*m), which might be a problem?
|
||||||
addShadowTransfers
|
addShadowTransfers
|
||||||
:: CurrencyMap
|
:: (MonadAppError m, MonadFinance m)
|
||||||
-> [ShadowTransfer]
|
=> [ShadowTransfer]
|
||||||
-> [UnbalancedTransfer]
|
-> [Tx CommitR]
|
||||||
-> InsertExcept [UnbalancedTransfer]
|
-> m [Tx CommitR]
|
||||||
addShadowTransfers cm ms txs =
|
addShadowTransfers ms = mapErrors go
|
||||||
fmap catMaybes $
|
where
|
||||||
combineErrors $
|
go tx = do
|
||||||
fmap (uncurry (fromShadow cm)) $
|
es <- catMaybes <$> mapErrors (fromShadow tx) ms
|
||||||
[(t, m) | t <- txs, m <- ms]
|
return $ tx {txOther = Right <$> es}
|
||||||
|
|
||||||
fromShadow
|
fromShadow
|
||||||
:: CurrencyMap
|
:: (MonadAppError m, MonadFinance m)
|
||||||
-> UnbalancedTransfer
|
=> Tx CommitR
|
||||||
-> ShadowTransfer
|
-> ShadowTransfer
|
||||||
-> InsertExcept (Maybe UnbalancedTransfer)
|
-> m (Maybe ShadowEntrySet)
|
||||||
fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
|
fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} =
|
||||||
res <- shadowMatches (stMatch t) tx
|
combineErrorM curRes shaRes $ \cur sha -> do
|
||||||
v <- roundPrecisionCur (initialCurrency stCurrency) cm stRatio
|
let es = entryPair stFrom stTo cur stDesc stRatio ()
|
||||||
return $
|
return $ if not sha then Nothing else Just es
|
||||||
if not res
|
where
|
||||||
then Nothing
|
curRes = lookupCurrencyKey (CurID stCurrency)
|
||||||
else
|
shaRes = liftExcept $ shadowMatches stMatch tx
|
||||||
Just $
|
|
||||||
FlatTransfer
|
|
||||||
{ ftMeta = ftMeta tx
|
|
||||||
, ftWhen = ftWhen tx
|
|
||||||
, ftCur = stCurrency
|
|
||||||
, ftFrom = stFrom
|
|
||||||
, ftTo = stTo
|
|
||||||
, ftValue = UnbalancedValue stType $ v * cvValue (ftValue tx)
|
|
||||||
, ftDesc = stDesc
|
|
||||||
}
|
|
||||||
|
|
||||||
shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool
|
shadowMatches :: TransferMatcher -> Tx CommitR -> AppExcept Bool
|
||||||
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
|
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} Tx {txPrimary, txDate} = do
|
||||||
valRes <- valMatches tmVal $ cvValue $ ftValue tx
|
-- 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 $
|
return $
|
||||||
memberMaybe (taAcnt $ ftFrom tx) tmFrom
|
memberMaybe fa tmFrom
|
||||||
&& memberMaybe (taAcnt $ ftTo tx) tmTo
|
&& memberMaybe ta tmTo
|
||||||
&& maybe True (`dateMatches` ftWhen tx) tmDate
|
&& maybe True (`dateMatches` txDate) tmDate
|
||||||
&& valRes
|
&& valRes
|
||||||
where
|
where
|
||||||
|
fa = either getAcntFrom getAcntFrom txPrimary
|
||||||
|
ta = either getAcntTo getAcntTo txPrimary
|
||||||
|
getAcntFrom = getAcnt esFrom
|
||||||
|
getAcntTo = getAcnt esTo
|
||||||
|
getAcnt f = eAcnt . hesPrimary . f
|
||||||
memberMaybe x AcntSet {asList, asInclude} =
|
memberMaybe x AcntSet {asList, asInclude} =
|
||||||
(if asInclude then id else not) $ x `elem` asList
|
(if asInclude then id else not) $ x `elem` (AcntID <$> asList)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- random
|
-- random
|
||||||
|
|
||||||
initialCurrency :: BudgetCurrency -> CurID
|
|
||||||
initialCurrency (NoX c) = c
|
|
||||||
initialCurrency (X Exchange {xFromCur = c}) = c
|
|
||||||
|
|
||||||
alloAcnt :: Allocation w v -> AcntID
|
alloAcnt :: Allocation w v -> AcntID
|
||||||
alloAcnt = taAcnt . alloTo
|
alloAcnt = AcntID . taAcnt . alloTo
|
||||||
|
|
||||||
data UnbalancedValue = UnbalancedValue
|
|
||||||
{ cvType :: !BudgetTransferType
|
|
||||||
, cvValue :: !Rational
|
|
||||||
}
|
|
||||||
deriving (Show)
|
|
||||||
|
|
||||||
type UnbalancedTransfer = FlatTransfer UnbalancedValue
|
|
||||||
|
|
||||||
type BalancedTransfer = FlatTransfer Rational
|
|
||||||
|
|
||||||
data FlatTransfer v = FlatTransfer
|
|
||||||
{ ftFrom :: !TaggedAcnt
|
|
||||||
, ftTo :: !TaggedAcnt
|
|
||||||
, ftValue :: !v
|
|
||||||
, ftWhen :: !Day
|
|
||||||
, ftDesc :: !T.Text
|
|
||||||
, ftMeta :: !BudgetMeta
|
|
||||||
, ftCur :: !BudgetCurrency
|
|
||||||
}
|
|
||||||
deriving (Show)
|
|
||||||
|
|
||||||
data BudgetMeta = BudgetMeta
|
|
||||||
{ bmCommit :: !CommitRId
|
|
||||||
, bmName :: !T.Text
|
|
||||||
}
|
|
||||||
deriving (Show)
|
|
||||||
|
|
||||||
type IntAllocations =
|
type IntAllocations =
|
||||||
( [DaySpanAllocation PretaxValue]
|
( [DaySpanAllocation PretaxValue]
|
||||||
|
@ -557,14 +389,11 @@ type IntAllocations =
|
||||||
|
|
||||||
type DaySpanAllocation = Allocation DaySpan
|
type DaySpanAllocation = Allocation DaySpan
|
||||||
|
|
||||||
type EntryPair = (KeyEntry, KeyEntry)
|
type PeriodScaler = Precision -> Double -> Decimal
|
||||||
|
|
||||||
type PeriodScaler = Natural -> Double -> Double
|
|
||||||
|
|
||||||
data FlatAllocation v = FlatAllocation
|
data FlatAllocation v = FlatAllocation
|
||||||
{ faValue :: !v
|
{ faValue :: !v
|
||||||
, faDesc :: !T.Text
|
, faDesc :: !T.Text
|
||||||
, faTo :: !TaggedAcnt
|
, faTo :: !TaggedAcnt
|
||||||
, faCur :: !BudgetCurrency
|
|
||||||
}
|
}
|
||||||
deriving (Functor, Show)
|
deriving (Functor, Show)
|
||||||
|
|
|
@ -1,35 +1,38 @@
|
||||||
module Internal.Database
|
module Internal.Database
|
||||||
( runDB
|
( runDB
|
||||||
|
, readConfigState
|
||||||
, nukeTables
|
, nukeTables
|
||||||
, updateHashes
|
|
||||||
, updateDBState
|
, updateDBState
|
||||||
, getDBState
|
|
||||||
, tree2Records
|
, tree2Records
|
||||||
, flattenAcntRoot
|
, flattenAcntRoot
|
||||||
|
, indexAcntRoot
|
||||||
, paths2IDs
|
, paths2IDs
|
||||||
, mkPool
|
, mkPool
|
||||||
, whenHash
|
|
||||||
, whenHash_
|
|
||||||
, insertEntry
|
, insertEntry
|
||||||
, resolveEntry
|
, readUpdates
|
||||||
|
, insertAll
|
||||||
|
, updateTx
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Conduit
|
import Conduit
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
import Control.Monad.Logger
|
import Control.Monad.Logger
|
||||||
|
import Data.Decimal
|
||||||
import Data.Hashable
|
import Data.Hashable
|
||||||
import Database.Esqueleto.Experimental ((==.), (^.))
|
import Database.Esqueleto.Experimental ((:&) (..), (==.), (?.), (^.))
|
||||||
import qualified Database.Esqueleto.Experimental as E
|
import qualified Database.Esqueleto.Experimental as E
|
||||||
import Database.Esqueleto.Internal.Internal (SqlSelect)
|
import Database.Esqueleto.Internal.Internal (SqlSelect)
|
||||||
import Database.Persist.Monad
|
import Database.Persist.Monad
|
||||||
import Database.Persist.Sqlite hiding
|
import Database.Persist.Sqlite hiding
|
||||||
( delete
|
( Statement
|
||||||
|
, delete
|
||||||
, deleteWhere
|
, deleteWhere
|
||||||
, insert
|
, insert
|
||||||
, insertKey
|
, insertKey
|
||||||
, insert_
|
, insert_
|
||||||
, runMigration
|
, runMigration
|
||||||
|
, update
|
||||||
, (==.)
|
, (==.)
|
||||||
, (||.)
|
, (||.)
|
||||||
)
|
)
|
||||||
|
@ -37,10 +40,10 @@ import GHC.Err
|
||||||
import Internal.Types.Main
|
import Internal.Types.Main
|
||||||
import Internal.Utils
|
import Internal.Utils
|
||||||
import RIO hiding (LogFunc, isNothing, on, (^.))
|
import RIO hiding (LogFunc, isNothing, on, (^.))
|
||||||
import RIO.List ((\\))
|
|
||||||
import qualified RIO.List as L
|
import qualified RIO.List as L
|
||||||
import qualified RIO.Map as M
|
import qualified RIO.Map as M
|
||||||
import qualified RIO.NonEmpty as N
|
import qualified RIO.NonEmpty as NE
|
||||||
|
import qualified RIO.Set as S
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
runDB
|
runDB
|
||||||
|
@ -103,85 +106,192 @@ nukeTables = do
|
||||||
-- toFullPath path name = T.unwords [unValue @T.Text path, "/", unValue @T.Text name]
|
-- toFullPath path name = T.unwords [unValue @T.Text path, "/", unValue @T.Text name]
|
||||||
-- toBal = maybe "???" (fmtRational 2) . unValue
|
-- toBal = maybe "???" (fmtRational 2) . unValue
|
||||||
|
|
||||||
hashConfig :: Config -> [Int]
|
readConfigState
|
||||||
hashConfig
|
:: (MonadAppError m, MonadSqlQuery m)
|
||||||
Config_
|
=> Config
|
||||||
{ budget = bs
|
-> [Budget]
|
||||||
, statements = ss
|
-> [History]
|
||||||
} = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
|
-> m ConfigState
|
||||||
|
readConfigState c bs hs = do
|
||||||
|
(acnts2Ins, acntsRem, acnts2Del) <- diff newAcnts
|
||||||
|
(pathsIns, _, pathsDel) <- diff newPaths
|
||||||
|
(curs2Ins, cursRem, curs2Del) <- diff newCurs
|
||||||
|
(tags2Ins, tagsRem, tags2Del) <- diff newTags
|
||||||
|
let amap = makeAcntMap $ acnts2Ins ++ (fst <$> acntsRem)
|
||||||
|
let cmap = currencyMap $ curs2Ins ++ (fst <$> cursRem)
|
||||||
|
let tmap = makeTagMap $ tags2Ins ++ (fst <$> tagsRem)
|
||||||
|
let fromMap f = S.fromList . fmap f . M.elems
|
||||||
|
let existing =
|
||||||
|
ExistingConfig (fromMap fst amap) (fromMap id tmap) (fromMap cpID cmap)
|
||||||
|
|
||||||
|
(curBgts, curHistTrs, curHistSts) <- readCurrentCommits
|
||||||
|
-- TODO refine this test to include the whole db (with data already mixed
|
||||||
|
-- in this algorithm)
|
||||||
|
let bsRes = BudgetSpan <$> resolveScope budgetInterval
|
||||||
|
let hsRes = HistorySpan <$> resolveScope statementInterval
|
||||||
|
combineErrorM bsRes hsRes $ \bscope hscope -> do
|
||||||
|
let dbempty = null $ curBgts ++ curHistTrs ++ curHistSts
|
||||||
|
(bChanged, hChanged) <- readScopeChanged dbempty bscope hscope
|
||||||
|
bgt <- makeTxCRUD existing bs curBgts bChanged
|
||||||
|
hTrans <- makeTxCRUD existing ts curHistTrs hChanged
|
||||||
|
hStmt <- makeTxCRUD existing ss curHistSts hChanged
|
||||||
|
|
||||||
|
return $
|
||||||
|
ConfigState
|
||||||
|
{ csCurrencies = CRUDOps curs2Ins () () curs2Del
|
||||||
|
, csTags = CRUDOps tags2Ins () () tags2Del
|
||||||
|
, csAccounts = CRUDOps acnts2Ins () () acnts2Del
|
||||||
|
, csPaths = CRUDOps pathsIns () () pathsDel
|
||||||
|
, csBudgets = bgt
|
||||||
|
, csHistTrans = hTrans
|
||||||
|
, csHistStmts = hStmt
|
||||||
|
, csAccountMap = amap
|
||||||
|
, csCurrencyMap = cmap
|
||||||
|
, csTagMap = tmap
|
||||||
|
, csBudgetScope = bscope
|
||||||
|
, csHistoryScope = hscope
|
||||||
|
}
|
||||||
|
where
|
||||||
|
(ts, ss) = splitHistory hs
|
||||||
|
diff new = setDiffWith (\a b -> E.entityKey a == b) new <$> readCurrentIds
|
||||||
|
(newAcnts, newPaths) = indexAcntRoot $ accounts c
|
||||||
|
newTags = tag2Record <$> tags c
|
||||||
|
newCurs = currency2Record <$> currencies c
|
||||||
|
resolveScope f = liftExcept $ resolveDaySpan $ f $ scope c
|
||||||
|
|
||||||
|
readScopeChanged
|
||||||
|
:: (MonadAppError m, MonadSqlQuery m)
|
||||||
|
=> Bool
|
||||||
|
-> BudgetSpan
|
||||||
|
-> HistorySpan
|
||||||
|
-> m (Bool, Bool)
|
||||||
|
readScopeChanged dbempty bscope hscope = do
|
||||||
|
rs <- dumpTbl
|
||||||
|
-- TODO these errors should only fire when someone messed with the DB
|
||||||
|
case rs of
|
||||||
|
[] -> if dbempty then return (True, True) else throwAppError $ DBError DBShouldBeEmpty
|
||||||
|
[r] -> do
|
||||||
|
let (ConfigStateR h b) = E.entityVal r
|
||||||
|
return (bscope /= b, hscope /= h)
|
||||||
|
_ -> throwAppError $ DBError DBMultiScope
|
||||||
|
|
||||||
|
makeTxCRUD
|
||||||
|
:: (MonadAppError m, MonadSqlQuery m, Hashable a)
|
||||||
|
=> ExistingConfig
|
||||||
|
-> [a]
|
||||||
|
-> [CommitHash]
|
||||||
|
-> Bool
|
||||||
|
-> m
|
||||||
|
( CRUDOps
|
||||||
|
[a]
|
||||||
|
[ReadEntry]
|
||||||
|
[Either TotalUpdateEntrySet FullUpdateEntrySet]
|
||||||
|
DeleteTxs
|
||||||
|
)
|
||||||
|
makeTxCRUD existing newThings curThings scopeChanged = do
|
||||||
|
let (toDelHashes, overlap, toIns) =
|
||||||
|
setDiffWith (\a b -> hash b == unCommitHash a) curThings newThings
|
||||||
|
-- Check the overlap for rows with accounts/tags/currencies that
|
||||||
|
-- won't exist on the next update. Those with invalid IDs will be set aside
|
||||||
|
-- to delete and reinsert (which may also fail) later
|
||||||
|
(noRetry, toInsRetry) <- readInvalidIds existing overlap
|
||||||
|
let (toDelAllHashes, toInsAll) = bimap (toDelHashes ++) (toIns ++) $ L.unzip toInsRetry
|
||||||
|
-- If we are inserting or deleting something or the scope changed, pull out
|
||||||
|
-- the remainder of the entries to update/read as we are (re)inserting other
|
||||||
|
-- stuff (this is necessary because a given transaction may depend on the
|
||||||
|
-- value of previous transactions, even if they are already in the DB).
|
||||||
|
(toRead, toUpdate) <- case (toInsAll, toDelAllHashes, scopeChanged) of
|
||||||
|
([], [], False) -> return ([], [])
|
||||||
|
_ -> readUpdates noRetry
|
||||||
|
toDelAll <- readTxIds toDelAllHashes
|
||||||
|
return $ CRUDOps toInsAll toRead toUpdate toDelAll
|
||||||
|
|
||||||
|
readTxIds :: MonadSqlQuery m => [CommitHash] -> m DeleteTxs
|
||||||
|
readTxIds cs = do
|
||||||
|
xs <- selectE $ do
|
||||||
|
(commits :& txs :& ess :& es :& ts) <-
|
||||||
|
E.from
|
||||||
|
$ E.table
|
||||||
|
`E.innerJoin` E.table
|
||||||
|
`E.on` (\(c :& t) -> c ^. CommitRId ==. t ^. TransactionRCommit)
|
||||||
|
`E.innerJoin` E.table
|
||||||
|
`E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
|
||||||
|
`E.innerJoin` E.table
|
||||||
|
`E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
|
||||||
|
`E.innerJoin` E.table
|
||||||
|
`E.on` (\(_ :& _ :& _ :& e :& t) -> e ^. EntryRId ==. t ^. TagRelationREntry)
|
||||||
|
E.where_ $ commits ^. CommitRHash `E.in_` E.valList cs
|
||||||
|
return
|
||||||
|
( txs ^. TransactionRId
|
||||||
|
, ess ^. EntrySetRId
|
||||||
|
, es ^. EntryRId
|
||||||
|
, ts ^. TagRelationRId
|
||||||
|
)
|
||||||
|
let (txs, ss, es, ts) = L.unzip4 xs
|
||||||
|
return $
|
||||||
|
DeleteTxs
|
||||||
|
{ dtTxs = go txs
|
||||||
|
, dtEntrySets = go ss
|
||||||
|
, dtEntries = go es
|
||||||
|
, dtTagRelations = E.unValue <$> ts
|
||||||
|
}
|
||||||
|
where
|
||||||
|
go :: Eq a => [E.Value a] -> [a]
|
||||||
|
go = fmap (E.unValue . NE.head) . NE.group
|
||||||
|
|
||||||
|
splitHistory :: [History] -> ([PairedTransfer], [Statement])
|
||||||
|
splitHistory = partitionEithers . fmap go
|
||||||
where
|
where
|
||||||
(ms, ps) = partitionEithers $ fmap go ss
|
|
||||||
go (HistTransfer x) = Left x
|
go (HistTransfer x) = Left x
|
||||||
go (HistStatement x) = Right x
|
go (HistStatement x) = Right x
|
||||||
|
|
||||||
setDiff :: Eq a => [a] -> [a] -> ([a], [a])
|
makeTagMap :: [Entity TagR] -> TagMap
|
||||||
-- setDiff = setDiff' (==)
|
makeTagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
|
||||||
setDiff as bs = (as \\ bs, bs \\ as)
|
|
||||||
|
|
||||||
-- setDiff' :: Eq a => (a -> b -> Bool) -> [a] -> [b] -> ([a], [b])
|
tag2Record :: Tag -> Entity TagR
|
||||||
-- setDiff' f = go []
|
tag2Record t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR (TagID tagID) tagDesc
|
||||||
-- where
|
|
||||||
-- go inA [] bs = (inA, bs)
|
|
||||||
-- go inA as [] = (as ++ inA, [])
|
|
||||||
-- go inA (a:as) bs = case inB a bs of
|
|
||||||
-- Just bs' -> go inA as bs'
|
|
||||||
-- Nothing -> go (a:inA) as bs
|
|
||||||
-- inB _ [] = Nothing
|
|
||||||
-- inB a (b:bs)
|
|
||||||
-- | f a b = Just bs
|
|
||||||
-- | otherwise = inB a bs
|
|
||||||
|
|
||||||
getDBHashes :: MonadSqlQuery m => m [Int]
|
|
||||||
getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
|
|
||||||
|
|
||||||
nukeDBHash :: MonadSqlQuery m => Int -> m ()
|
|
||||||
nukeDBHash h = deleteE $ do
|
|
||||||
c <- E.from E.table
|
|
||||||
E.where_ (c ^. CommitRHash ==. E.val h)
|
|
||||||
|
|
||||||
nukeDBHashes :: MonadSqlQuery m => [Int] -> m ()
|
|
||||||
nukeDBHashes = mapM_ nukeDBHash
|
|
||||||
|
|
||||||
getConfigHashes :: MonadSqlQuery m => Config -> m ([Int], [Int])
|
|
||||||
getConfigHashes c = do
|
|
||||||
let ch = hashConfig c
|
|
||||||
dh <- getDBHashes
|
|
||||||
return $ setDiff dh ch
|
|
||||||
|
|
||||||
dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r]
|
|
||||||
dumpTbl = selectE $ E.from E.table
|
|
||||||
|
|
||||||
deleteAccount :: MonadSqlQuery m => Entity AccountR -> m ()
|
|
||||||
deleteAccount e = deleteE $ do
|
|
||||||
c <- E.from $ E.table @AccountR
|
|
||||||
E.where_ (c ^. AccountRId ==. E.val k)
|
|
||||||
where
|
|
||||||
k = entityKey e
|
|
||||||
|
|
||||||
deleteCurrency :: MonadSqlQuery m => Entity CurrencyR -> m ()
|
|
||||||
deleteCurrency e = deleteE $ do
|
|
||||||
c <- E.from $ E.table @CurrencyR
|
|
||||||
E.where_ (c ^. CurrencyRId ==. E.val k)
|
|
||||||
where
|
|
||||||
k = entityKey e
|
|
||||||
|
|
||||||
deleteTag :: MonadSqlQuery m => Entity TagR -> m ()
|
|
||||||
deleteTag e = deleteE $ do
|
|
||||||
c <- E.from $ E.table @TagR
|
|
||||||
E.where_ (c ^. TagRId ==. E.val k)
|
|
||||||
where
|
|
||||||
k = entityKey e
|
|
||||||
|
|
||||||
-- TODO slip-n-slide code...
|
|
||||||
insertFull
|
|
||||||
:: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m)
|
|
||||||
=> Entity r
|
|
||||||
-> m ()
|
|
||||||
insertFull (Entity k v) = insertKey k v
|
|
||||||
|
|
||||||
currency2Record :: Currency -> Entity CurrencyR
|
currency2Record :: Currency -> Entity CurrencyR
|
||||||
currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
|
currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
|
||||||
Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision)
|
Entity (toKey c) $ CurrencyR (CurID curSymbol) curFullname (fromIntegral curPrecision)
|
||||||
|
|
||||||
|
readCurrentIds :: PersistEntity a => MonadSqlQuery m => m [Key a]
|
||||||
|
readCurrentIds = fmap (E.unValue <$>) $ selectE $ do
|
||||||
|
rs <- E.from E.table
|
||||||
|
return (rs ^. E.persistIdField)
|
||||||
|
|
||||||
|
readCurrentCommits :: MonadSqlQuery m => m ([CommitHash], [CommitHash], [CommitHash])
|
||||||
|
readCurrentCommits = do
|
||||||
|
xs <- selectE $ do
|
||||||
|
rs <- E.from E.table
|
||||||
|
return (rs ^. CommitRHash, rs ^. CommitRType)
|
||||||
|
return $ foldr go ([], [], []) xs
|
||||||
|
where
|
||||||
|
go (x, t) (bs, ts, hs) =
|
||||||
|
let y = E.unValue x
|
||||||
|
in case E.unValue t of
|
||||||
|
CTBudget -> (y : bs, ts, hs)
|
||||||
|
CTHistoryTransfer -> (bs, y : ts, hs)
|
||||||
|
CTHistoryStatement -> (bs, ts, y : hs)
|
||||||
|
|
||||||
|
setDiffWith :: (a -> b -> Bool) -> [a] -> [b] -> ([a], [(a, b)], [b])
|
||||||
|
setDiffWith f = go [] []
|
||||||
|
where
|
||||||
|
go inA inBoth [] bs = (inA, inBoth, bs)
|
||||||
|
go inA inBoth as [] = (as ++ inA, inBoth, [])
|
||||||
|
go inA inBoth (a : as) bs =
|
||||||
|
let (res, bs') = findDelete (f a) bs
|
||||||
|
in case res of
|
||||||
|
Nothing -> go (a : inA) inBoth as bs
|
||||||
|
Just b -> go inA ((a, b) : inBoth) as bs'
|
||||||
|
|
||||||
|
findDelete :: (a -> Bool) -> [a] -> (Maybe a, [a])
|
||||||
|
findDelete f xs = case break f xs of
|
||||||
|
(ys, []) -> (Nothing, ys)
|
||||||
|
(ys, z : zs) -> (Just z, ys ++ zs)
|
||||||
|
|
||||||
|
dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r]
|
||||||
|
dumpTbl = selectE $ E.from E.table
|
||||||
|
|
||||||
currencyMap :: [Entity CurrencyR] -> CurrencyMap
|
currencyMap :: [Entity CurrencyR] -> CurrencyMap
|
||||||
currencyMap =
|
currencyMap =
|
||||||
|
@ -189,46 +299,43 @@ currencyMap =
|
||||||
. fmap
|
. fmap
|
||||||
( \e ->
|
( \e ->
|
||||||
( currencyRSymbol $ entityVal e
|
( currencyRSymbol $ entityVal e
|
||||||
, (entityKey e, fromIntegral $ currencyRPrecision $ entityVal e)
|
, CurrencyPrec (entityKey e) $ currencyRPrecision $ entityVal e
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
|
||||||
toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
|
toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
|
||||||
toKey = toSqlKey . fromIntegral . hash
|
toKey = toSqlKey . fromIntegral . hash
|
||||||
|
|
||||||
tree2Entity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR
|
makeAccountEntity :: AccountR -> Entity AccountR
|
||||||
tree2Entity t parents name des =
|
makeAccountEntity a = Entity (toKey $ accountRFullpath a) a
|
||||||
Entity (toSqlKey $ fromIntegral h) $
|
|
||||||
AccountR name (toPath parents) des
|
|
||||||
where
|
|
||||||
p = AcntPath t (reverse (name : parents))
|
|
||||||
h = hash p
|
|
||||||
toPath = T.intercalate "/" . (atName t :) . reverse
|
|
||||||
|
|
||||||
tree2Records
|
makeAccountR :: AcntType -> T.Text -> [T.Text] -> T.Text -> Bool -> AccountR
|
||||||
:: AcntType
|
makeAccountR atype name parents des = AccountR name path des (accountSign atype)
|
||||||
-> AccountTree
|
where
|
||||||
-> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntSign, AcntType))])
|
path = AcntPath atype (reverse $ name : parents)
|
||||||
|
|
||||||
|
tree2Records :: AcntType -> AccountTree -> ([Entity AccountR], [Entity AccountPathR])
|
||||||
tree2Records t = go []
|
tree2Records t = go []
|
||||||
where
|
where
|
||||||
go ps (Placeholder d n cs) =
|
go ps (Placeholder d n cs) =
|
||||||
let e = tree2Entity t (fmap snd ps) n d
|
let (parentKeys, parentNames) = L.unzip ps
|
||||||
k = entityKey e
|
a = acnt n parentNames d False
|
||||||
(as, aps, ms) = L.unzip3 $ fmap (go ((k, n) : ps)) cs
|
k = entityKey a
|
||||||
a0 = acnt k n (fmap snd ps) d
|
thesePaths = expand k parentKeys
|
||||||
paths = expand k $ fmap fst ps
|
in bimap ((a :) . concat) ((thesePaths ++) . concat) $
|
||||||
in (a0 : concat as, paths ++ concat aps, concat ms)
|
L.unzip $
|
||||||
|
go ((k, n) : ps) <$> cs
|
||||||
go ps (Account d n) =
|
go ps (Account d n) =
|
||||||
let e = tree2Entity t (fmap snd ps) n d
|
let (parentKeys, parentNames) = L.unzip ps
|
||||||
k = entityKey e
|
a = acnt n parentNames d True
|
||||||
in ( [acnt k n (fmap snd ps) d]
|
k = entityKey a
|
||||||
, expand k $ fmap fst ps
|
in ([a], expand k parentKeys)
|
||||||
, [(AcntPath t $ reverse $ n : fmap snd ps, (k, sign, t))]
|
expand h0 hs = (\(h, d) -> accountPathRecord h h0 d) <$> zip (h0 : hs) [0 ..]
|
||||||
)
|
acnt n ps d = makeAccountEntity . makeAccountR t n ps d
|
||||||
toPath = T.intercalate "/" . (atName t :) . reverse
|
|
||||||
acnt k n ps = Entity k . AccountR n (toPath ps)
|
accountPathRecord :: Key AccountR -> Key AccountR -> Int -> Entity AccountPathR
|
||||||
expand h0 hs = (\(h, d) -> AccountPathR h h0 d) <$> zip (h0 : hs) [0 ..]
|
accountPathRecord p c d =
|
||||||
sign = accountSign t
|
Entity (toKey (fromSqlKey p, fromSqlKey c)) $ AccountPathR p c d
|
||||||
|
|
||||||
paths2IDs :: [(AcntPath, a)] -> [(AcntID, a)]
|
paths2IDs :: [(AcntPath, a)] -> [(AcntID, a)]
|
||||||
paths2IDs =
|
paths2IDs =
|
||||||
|
@ -236,49 +343,25 @@ paths2IDs =
|
||||||
. first trimNames
|
. first trimNames
|
||||||
. L.unzip
|
. L.unzip
|
||||||
. L.sortOn fst
|
. L.sortOn fst
|
||||||
. fmap (first pathList)
|
. fmap (first (NE.reverse . acntPath2NonEmpty))
|
||||||
where
|
|
||||||
pathList (AcntPath t []) = atName t :| []
|
|
||||||
pathList (AcntPath t ns) = N.reverse $ atName t :| ns
|
|
||||||
|
|
||||||
-- none of these errors should fire assuming that input is sorted and unique
|
-- none of these errors should fire assuming that input is sorted and unique
|
||||||
trimNames :: [N.NonEmpty T.Text] -> [AcntID]
|
trimNames :: [NonEmpty T.Text] -> [AcntID]
|
||||||
trimNames = fmap (T.intercalate "_" . reverse) . trimAll 0
|
trimNames = fmap (AcntID . T.intercalate "_") . go []
|
||||||
where
|
where
|
||||||
trimAll _ [] = []
|
go :: [T.Text] -> [NonEmpty T.Text] -> [[T.Text]]
|
||||||
trimAll i (y : ys) = case L.foldl' (matchPre i) (y, [], []) ys of
|
go prev = concatMap (go' prev) . groupNonEmpty
|
||||||
(a, [], bs) -> reverse $ trim i a : bs
|
go' prev (key, rest) = case rest of
|
||||||
(a, as, bs) -> reverse bs ++ trimAll (i + 1) (reverse $ a : as)
|
(_ :| []) -> [key : prev]
|
||||||
matchPre i (y, ys, old) new = case (y !? i, new !? i) of
|
([] :| xs) ->
|
||||||
(Nothing, Just _) ->
|
let next = key : prev
|
||||||
case ys of
|
other = go next $ fmap (fromMaybe err . NE.nonEmpty) xs
|
||||||
[] -> (new, [], trim i y : old)
|
in next : other
|
||||||
_ -> err "unsorted input"
|
(x :| xs) -> go (key : prev) $ fmap (fromMaybe err . NE.nonEmpty) (x : xs)
|
||||||
(Just _, Nothing) -> err "unsorted input"
|
err = error "account path list either not sorted or contains duplicates"
|
||||||
(Nothing, Nothing) -> err "duplicated inputs"
|
|
||||||
(Just a, Just b)
|
|
||||||
| a == b -> (new, y : ys, old)
|
|
||||||
| otherwise ->
|
|
||||||
let next = case ys of
|
|
||||||
[] -> [trim i y]
|
|
||||||
_ -> trimAll (i + 1) (reverse $ y : ys)
|
|
||||||
in (new, [], reverse next ++ old)
|
|
||||||
trim i = N.take (i + 1)
|
|
||||||
err msg = errorWithoutStackTrace $ "Import.Database.Ops.hs: " ++ msg
|
|
||||||
|
|
||||||
(!?) :: N.NonEmpty a -> Int -> Maybe a
|
groupNonEmpty :: Ord a => [NonEmpty a] -> [(a, NonEmpty [a])]
|
||||||
xs !? n
|
groupNonEmpty = fmap (second (NE.tail <$>)) . groupWith NE.head
|
||||||
| n < 0 = Nothing
|
|
||||||
-- Definition adapted from GHC.List
|
|
||||||
| otherwise =
|
|
||||||
foldr
|
|
||||||
( \x r k -> case k of
|
|
||||||
0 -> Just x
|
|
||||||
_ -> r (k - 1)
|
|
||||||
)
|
|
||||||
(const Nothing)
|
|
||||||
xs
|
|
||||||
n
|
|
||||||
|
|
||||||
flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)]
|
flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)]
|
||||||
flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arEquity} =
|
flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arEquity} =
|
||||||
|
@ -288,129 +371,372 @@ flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arE
|
||||||
++ ((AssetT,) <$> arAssets)
|
++ ((AssetT,) <$> arAssets)
|
||||||
++ ((EquityT,) <$> arEquity)
|
++ ((EquityT,) <$> arEquity)
|
||||||
|
|
||||||
indexAcntRoot :: AccountRoot -> ([Entity AccountR], [AccountPathR], AccountMap)
|
makeAcntMap :: [Entity AccountR] -> AccountMap
|
||||||
indexAcntRoot r =
|
makeAcntMap =
|
||||||
( concat ars
|
M.fromList
|
||||||
, concat aprs
|
. paths2IDs
|
||||||
, M.fromList $ paths2IDs $ concat ms
|
. fmap go
|
||||||
)
|
. filter (accountRLeaf . snd)
|
||||||
|
. fmap (\e -> (E.entityKey e, E.entityVal e))
|
||||||
where
|
where
|
||||||
(ars, aprs, ms) = L.unzip3 $ uncurry tree2Records <$> flattenAcntRoot r
|
go (k, v) = let p = accountRFullpath v in (p, (k, apType p))
|
||||||
|
|
||||||
getDBState
|
indexAcntRoot :: AccountRoot -> ([Entity AccountR], [Entity AccountPathR])
|
||||||
:: (MonadInsertError m, MonadSqlQuery m)
|
indexAcntRoot = bimap concat concat . L.unzip . fmap (uncurry tree2Records) . flattenAcntRoot
|
||||||
=> Config
|
|
||||||
-> m (DBState, DBUpdates)
|
updateCD
|
||||||
getDBState c = do
|
:: ( MonadSqlQuery m
|
||||||
(del, new) <- getConfigHashes c
|
, PersistRecordBackend a SqlBackend
|
||||||
combineError bi si $ \b s ->
|
, PersistRecordBackend b SqlBackend
|
||||||
( DBState
|
|
||||||
{ kmCurrency = currencyMap cs
|
|
||||||
, kmAccount = am
|
|
||||||
, kmBudgetInterval = b
|
|
||||||
, kmStatementInterval = s
|
|
||||||
, kmTag = tagMap ts
|
|
||||||
, kmNewCommits = new
|
|
||||||
}
|
|
||||||
, DBUpdates
|
|
||||||
{ duOldCommits = del
|
|
||||||
, duNewTagIds = ts
|
|
||||||
, duNewAcntPaths = paths
|
|
||||||
, duNewAcntIds = acnts
|
|
||||||
, duNewCurrencyIds = cs
|
|
||||||
}
|
|
||||||
)
|
)
|
||||||
|
=> CDOps (Entity a) (Key b)
|
||||||
|
-> m ()
|
||||||
|
updateCD (CRUDOps cs () () ds) = do
|
||||||
|
mapM_ deleteKeyE ds
|
||||||
|
insertEntityManyE cs
|
||||||
|
|
||||||
|
deleteTxs :: MonadSqlQuery m => DeleteTxs -> m ()
|
||||||
|
deleteTxs DeleteTxs {dtTxs, dtEntrySets, dtEntries, dtTagRelations} = do
|
||||||
|
mapM_ deleteKeyE dtTxs
|
||||||
|
mapM_ deleteKeyE dtEntrySets
|
||||||
|
mapM_ deleteKeyE dtEntries
|
||||||
|
mapM_ deleteKeyE dtTagRelations
|
||||||
|
|
||||||
|
updateDBState :: (MonadFinance m, MonadSqlQuery m) => m ()
|
||||||
|
updateDBState = do
|
||||||
|
updateCD =<< asks csCurrencies
|
||||||
|
updateCD =<< asks csAccounts
|
||||||
|
updateCD =<< asks csPaths
|
||||||
|
updateCD =<< asks csTags
|
||||||
|
deleteTxs =<< asks (coDelete . csBudgets)
|
||||||
|
deleteTxs =<< asks (coDelete . csHistTrans)
|
||||||
|
deleteTxs =<< asks (coDelete . csHistStmts)
|
||||||
|
b <- asks csBudgetScope
|
||||||
|
h <- asks csHistoryScope
|
||||||
|
repsertE (E.toSqlKey 1) $ ConfigStateR h b
|
||||||
|
|
||||||
|
readInvalidIds
|
||||||
|
:: MonadSqlQuery m
|
||||||
|
=> ExistingConfig
|
||||||
|
-> [(CommitHash, a)]
|
||||||
|
-> m ([CommitHash], [(CommitHash, a)])
|
||||||
|
readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
|
||||||
|
rs <- selectE $ do
|
||||||
|
(commits :& _ :& entrysets :& entries :& tags) <-
|
||||||
|
E.from
|
||||||
|
$ E.table
|
||||||
|
`E.innerJoin` E.table
|
||||||
|
`E.on` (\(c :& t) -> c ^. CommitRId ==. t ^. TransactionRCommit)
|
||||||
|
`E.innerJoin` E.table
|
||||||
|
`E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
|
||||||
|
`E.innerJoin` E.table
|
||||||
|
`E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
|
||||||
|
`E.leftJoin` E.table
|
||||||
|
`E.on` (\(_ :& _ :& _ :& e :& r) -> E.just (e ^. EntryRId) ==. r ?. TagRelationREntry)
|
||||||
|
E.where_ $ commits ^. CommitRHash `E.in_` E.valList (fmap fst xs)
|
||||||
|
return
|
||||||
|
( commits ^. CommitRHash
|
||||||
|
, entrysets ^. EntrySetRCurrency
|
||||||
|
, entries ^. EntryRAccount
|
||||||
|
, tags ?. TagRelationRTag
|
||||||
|
)
|
||||||
|
-- TODO there are faster ways to do this; may/may not matter
|
||||||
|
let cs = go ecCurrencies $ fmap (\(i, E.Value c, _, _) -> (i, c)) rs
|
||||||
|
let as = go ecAccounts $ fmap (\(i, _, E.Value a, _) -> (i, a)) rs
|
||||||
|
let ts = go ecTags [(i, t) | (i, _, _, E.Value (Just t)) <- rs]
|
||||||
|
let valid = (cs `S.intersection` as) `S.intersection` ts
|
||||||
|
let (a0, _) = first (fst <$>) $ L.partition ((`S.member` valid) . fst) xs
|
||||||
|
return (a0, [])
|
||||||
where
|
where
|
||||||
bi = liftExcept $ resolveDaySpan $ budgetInterval $ global c
|
go existing =
|
||||||
si = liftExcept $ resolveDaySpan $ statementInterval $ global c
|
S.fromList
|
||||||
(acnts, paths, am) = indexAcntRoot $ accounts c
|
. fmap (E.unValue . fst)
|
||||||
cs = currency2Record <$> currencies c
|
. L.filter (all (`S.member` existing) . snd)
|
||||||
ts = toRecord <$> tags c
|
. groupKey id
|
||||||
toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc
|
|
||||||
tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
|
|
||||||
|
|
||||||
updateHashes :: (MonadSqlQuery m) => DBUpdates -> m ()
|
readUpdates
|
||||||
updateHashes DBUpdates {duOldCommits} = nukeDBHashes duOldCommits
|
:: (MonadAppError m, MonadSqlQuery m)
|
||||||
|
=> [CommitHash]
|
||||||
|
-> m ([ReadEntry], [Either TotalUpdateEntrySet FullUpdateEntrySet])
|
||||||
|
readUpdates hashes = do
|
||||||
|
xs <- selectE $ do
|
||||||
|
(commits :& txs :& entrysets :& entries :& currencies) <-
|
||||||
|
E.from
|
||||||
|
$ E.table @CommitR
|
||||||
|
`E.innerJoin` E.table @TransactionR
|
||||||
|
`E.on` (\(c :& t) -> c ^. CommitRId ==. t ^. TransactionRCommit)
|
||||||
|
`E.innerJoin` E.table @EntrySetR
|
||||||
|
`E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
|
||||||
|
`E.innerJoin` E.table @EntryR
|
||||||
|
`E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
|
||||||
|
`E.innerJoin` E.table @CurrencyR
|
||||||
|
`E.on` (\(_ :& _ :& es :& _ :& cur) -> es ^. EntrySetRCurrency ==. cur ^. CurrencyRId)
|
||||||
|
E.where_ $ commits ^. CommitRHash `E.in_` E.valList hashes
|
||||||
|
return
|
||||||
|
( entrysets ^. EntrySetRRebalance
|
||||||
|
,
|
||||||
|
(
|
||||||
|
( entrysets ^. EntrySetRId
|
||||||
|
, txs ^. TransactionRDate
|
||||||
|
, txs ^. TransactionRBudgetName
|
||||||
|
, txs ^. TransactionRPriority
|
||||||
|
,
|
||||||
|
( entrysets ^. EntrySetRCurrency
|
||||||
|
, currencies ^. CurrencyRPrecision
|
||||||
|
)
|
||||||
|
)
|
||||||
|
, entries
|
||||||
|
)
|
||||||
|
)
|
||||||
|
let (toUpdate, toRead) = L.partition (E.unValue . fst) xs
|
||||||
|
toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _, _, _) -> i) (snd <$> toUpdate)
|
||||||
|
let toRead' = fmap (makeRE . snd) toRead
|
||||||
|
return (toRead', toUpdate')
|
||||||
|
where
|
||||||
|
makeUES ((_, day, name, pri, (curID, prec)), es) = do
|
||||||
|
let prec' = fromIntegral $ E.unValue prec
|
||||||
|
let cur = E.unValue curID
|
||||||
|
let res =
|
||||||
|
bimap NE.nonEmpty NE.nonEmpty $
|
||||||
|
NE.partition ((< 0) . entryRIndex . snd) $
|
||||||
|
NE.sortWith (entryRIndex . snd) $
|
||||||
|
fmap (\e -> (entityKey e, entityVal e)) es
|
||||||
|
case res of
|
||||||
|
(Just froms, Just tos) -> do
|
||||||
|
let tot = sum $ fmap (entryRValue . snd) froms
|
||||||
|
(from0, fromRO, fromUnkVec) <- splitFrom prec' $ NE.reverse froms
|
||||||
|
(from0', fromUnk, to0, toRO, toUnk) <- splitTo prec' from0 fromUnkVec tos
|
||||||
|
-- TODO WAP (wet ass programming)
|
||||||
|
return $ case from0' of
|
||||||
|
Left x ->
|
||||||
|
Left $
|
||||||
|
UpdateEntrySet
|
||||||
|
{ utDate = E.unValue day
|
||||||
|
, utCurrency = cur
|
||||||
|
, utFrom0 = x
|
||||||
|
, utTo0 = to0
|
||||||
|
, utFromRO = fromRO
|
||||||
|
, utToRO = toRO
|
||||||
|
, utFromUnk = fromUnk
|
||||||
|
, utToUnk = toUnk
|
||||||
|
, utTotalValue = realFracToDecimalP prec' tot
|
||||||
|
, utBudget = E.unValue name
|
||||||
|
, utPriority = E.unValue pri
|
||||||
|
}
|
||||||
|
Right x ->
|
||||||
|
Right $
|
||||||
|
UpdateEntrySet
|
||||||
|
{ utDate = E.unValue day
|
||||||
|
, utCurrency = cur
|
||||||
|
, utFrom0 = x
|
||||||
|
, utTo0 = to0
|
||||||
|
, utFromRO = fromRO
|
||||||
|
, utToRO = toRO
|
||||||
|
, utFromUnk = fromUnk
|
||||||
|
, utToUnk = toUnk
|
||||||
|
, utTotalValue = ()
|
||||||
|
, utBudget = E.unValue name
|
||||||
|
, utPriority = E.unValue pri
|
||||||
|
}
|
||||||
|
-- TODO this error is lame
|
||||||
|
_ -> throwAppError $ DBError $ DBUpdateUnbalanced
|
||||||
|
makeRE ((_, day, name, pri, (curID, prec)), entry) = do
|
||||||
|
let e = entityVal entry
|
||||||
|
in ReadEntry
|
||||||
|
{ reDate = E.unValue day
|
||||||
|
, reCurrency = E.unValue curID
|
||||||
|
, reAcnt = entryRAccount e
|
||||||
|
, reValue = realFracToDecimal (fromIntegral $ E.unValue prec) (entryRValue e)
|
||||||
|
, reBudget = E.unValue name
|
||||||
|
, rePriority = E.unValue pri
|
||||||
|
}
|
||||||
|
|
||||||
updateTags :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
|
splitFrom
|
||||||
updateTags DBUpdates {duNewTagIds} = do
|
:: Precision
|
||||||
tags' <- selectE $ E.from $ E.table @TagR
|
-> NonEmpty (EntryRId, EntryR)
|
||||||
let (toIns, toDel) = setDiff duNewTagIds tags'
|
-> AppExcept (Either UEBlank (Either UE_RO UEUnk), [UE_RO], [UEUnk])
|
||||||
mapM_ deleteTag toDel
|
splitFrom prec (f0 :| fs) = do
|
||||||
mapM_ insertFull toIns
|
-- ASSUME entries are sorted by index
|
||||||
|
-- TODO combine errors here
|
||||||
|
let f0Res = readDeferredValue prec f0
|
||||||
|
let fsRes = mapErrors (splitDeferredValue prec) fs
|
||||||
|
combineErrorM f0Res fsRes $ \f0' fs' -> do
|
||||||
|
let (ro, unk) = partitionEithers fs'
|
||||||
|
-- let idxVec = V.fromList $ fmap (either (const Nothing) Just) fs'
|
||||||
|
return (f0', ro, unk)
|
||||||
|
|
||||||
updateAccounts :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
|
splitTo
|
||||||
updateAccounts DBUpdates {duNewAcntIds, duNewAcntPaths} = do
|
:: Precision
|
||||||
acnts' <- dumpTbl
|
-> Either UEBlank (Either UE_RO UEUnk)
|
||||||
let (toIns, toDel) = setDiff duNewAcntIds acnts'
|
-> [UEUnk]
|
||||||
deleteWhere ([] :: [Filter AccountPathR])
|
-> NonEmpty (EntryRId, EntryR)
|
||||||
mapM_ deleteAccount toDel
|
-> AppExcept
|
||||||
mapM_ insertFull toIns
|
( Either (UEBlank, [UELink]) (Either UE_RO (UEUnk, [UELink]))
|
||||||
mapM_ insert duNewAcntPaths
|
, [(UEUnk, [UELink])]
|
||||||
|
, UEBlank
|
||||||
|
, [UE_RO]
|
||||||
|
, [UEUnk]
|
||||||
|
)
|
||||||
|
splitTo prec from0 fromUnk (t0 :| ts) = do
|
||||||
|
-- How to split the credit side of the database transaction in 1024 easy
|
||||||
|
-- steps:
|
||||||
|
--
|
||||||
|
-- 1. Split incoming entries (except primary) into those with links and not
|
||||||
|
let (unlinked, linked) = partitionEithers $ fmap splitLinked ts
|
||||||
|
|
||||||
updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
|
-- 2. For unlinked entries, split into read-only and unknown entries
|
||||||
updateCurrencies DBUpdates {duNewCurrencyIds} = do
|
let unlinkedRes = partitionEithers <$> mapErrors (splitDeferredValue prec) unlinked
|
||||||
curs' <- selectE $ E.from $ E.table @CurrencyR
|
|
||||||
let (toIns, toDel) = setDiff duNewCurrencyIds curs'
|
|
||||||
mapM_ deleteCurrency toDel
|
|
||||||
mapM_ insertFull toIns
|
|
||||||
|
|
||||||
updateDBState :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
|
-- 3. For linked entries, split into those that link to the primary debit
|
||||||
updateDBState u = do
|
-- entry and not
|
||||||
updateHashes u
|
let (linked0, linkedN) = second (groupKey id) $ L.partition ((== 0) . fst) linked
|
||||||
updateTags u
|
|
||||||
updateAccounts u
|
|
||||||
updateCurrencies u
|
|
||||||
|
|
||||||
deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m ()
|
-- 4. For linked entries that don't link to the primary debit entry, split
|
||||||
deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)
|
-- into those that link to an unknown debit entry or not. Those that
|
||||||
|
-- are not will be read-only and those that are will be collected with
|
||||||
|
-- their linked debit entry
|
||||||
|
let linkedRes = zipPaired prec fromUnk linkedN
|
||||||
|
|
||||||
|
-- 5. For entries linked to the primary debit entry, turn them into linked
|
||||||
|
-- entries (lazily only used when needed later)
|
||||||
|
let from0Res = mapErrors (makeLinkUnk . snd) linked0
|
||||||
|
|
||||||
|
combineErrorM3 from0Res linkedRes unlinkedRes $
|
||||||
|
-- 6. Depending on the type of primary debit entry we have, add linked
|
||||||
|
-- entries if it is either an unknown or a blank (to be solved) entry,
|
||||||
|
-- or turn the remaining linked entries to read-only and add to the other
|
||||||
|
-- read-only entries
|
||||||
|
\from0Links (fromUnk', toROLinkedN) (toROUnlinked, toUnk) -> do
|
||||||
|
let (from0', toROLinked0) = case from0 of
|
||||||
|
Left blnk -> (Left (blnk, from0Links), [])
|
||||||
|
Right (Left ro) -> (Right $ Left ro, makeRoUE prec . snd . snd <$> linked0)
|
||||||
|
Right (Right unk) -> (Right $ Right (unk, from0Links), [])
|
||||||
|
return (from0', fromUnk', primary, toROLinked0 ++ toROLinkedN ++ toROUnlinked, toUnk)
|
||||||
|
where
|
||||||
|
primary = uncurry makeUnkUE t0
|
||||||
|
splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRCachedLink e
|
||||||
|
|
||||||
|
-- | Match linked credit entries with unknown entries, returning a list of
|
||||||
|
-- matches and non-matching (read-only) credit entries. ASSUME both lists are
|
||||||
|
-- sorted according to index and 'fst' respectively. NOTE the output will NOT be
|
||||||
|
-- sorted.
|
||||||
|
zipPaired
|
||||||
|
:: Precision
|
||||||
|
-> [UEUnk]
|
||||||
|
-> [(EntryIndex, NonEmpty (EntryRId, EntryR))]
|
||||||
|
-> AppExcept ([(UEUnk, [UELink])], [UE_RO])
|
||||||
|
zipPaired prec = go ([], [])
|
||||||
|
where
|
||||||
|
nolinks = ((,[]) <$>)
|
||||||
|
go acc fs [] = return $ first (nolinks fs ++) acc
|
||||||
|
go (facc, tacc) fs ((ti, tls) : ts) = do
|
||||||
|
let (lesser, rest) = L.span ((< ti) . ueIndex) fs
|
||||||
|
links <- NE.toList <$> mapErrors makeLinkUnk tls
|
||||||
|
let (nextLink, fs') = case rest of
|
||||||
|
(r0 : rs)
|
||||||
|
| ueIndex r0 == ti -> (Just (r0, links), rs)
|
||||||
|
| otherwise -> (Nothing, rest)
|
||||||
|
_ -> (Nothing, rest)
|
||||||
|
let acc' = (nolinks lesser ++ facc, tacc)
|
||||||
|
let ros = NE.toList $ makeRoUE prec . snd <$> tls
|
||||||
|
let f = maybe (second (++ ros)) (\u -> first (u :)) nextLink
|
||||||
|
go (f acc') fs' ts
|
||||||
|
|
||||||
|
makeLinkUnk :: (EntryRId, EntryR) -> AppExcept UELink
|
||||||
|
makeLinkUnk (k, e) =
|
||||||
|
-- TODO error should state that scale must be present for a link in the db
|
||||||
|
maybe
|
||||||
|
(throwAppError $ DBError $ DBLinkError k DBLinkNoScale)
|
||||||
|
(return . makeUE k e . LinkScale)
|
||||||
|
$ fromRational <$> entryRCachedValue e
|
||||||
|
|
||||||
|
splitDeferredValue :: Precision -> (EntryRId, EntryR) -> AppExcept (Either UE_RO UEUnk)
|
||||||
|
splitDeferredValue prec p@(k, _) = do
|
||||||
|
res <- readDeferredValue prec p
|
||||||
|
case res of
|
||||||
|
Left _ -> throwAppError $ DBError $ DBLinkError k DBLinkNoValue
|
||||||
|
Right x -> return x
|
||||||
|
|
||||||
|
readDeferredValue :: Precision -> (EntryRId, EntryR) -> AppExcept (Either UEBlank (Either UE_RO UEUnk))
|
||||||
|
readDeferredValue prec (k, e) = case (entryRCachedValue e, entryRCachedType e) of
|
||||||
|
(Nothing, Just TFixed) -> return $ Right $ Left $ makeRoUE prec e
|
||||||
|
(Just v, Just TBalance) -> go $ fmap EVBalance $ makeUE k e $ realFracToDecimalP prec v
|
||||||
|
(Just v, Just TPercent) -> go $ fmap EVPercent $ makeUE k e $ fromRational v
|
||||||
|
(Nothing, Nothing) -> return $ Left $ makeUnkUE k e
|
||||||
|
(Just v, Nothing) -> err $ DBLinkInvalidValue v False
|
||||||
|
(Just v, Just TFixed) -> err $ DBLinkInvalidValue v True
|
||||||
|
(Nothing, Just TBalance) -> err $ DBLinkInvalidBalance
|
||||||
|
(Nothing, Just TPercent) -> err $ DBLinkInvalidPercent
|
||||||
|
where
|
||||||
|
go = return . Right . Right
|
||||||
|
err = throwAppError . DBError . DBLinkError k
|
||||||
|
|
||||||
|
makeUE :: i -> EntryR -> v -> UpdateEntry i v
|
||||||
|
makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e)
|
||||||
|
|
||||||
|
makeRoUE :: Precision -> EntryR -> UpdateEntry () StaticValue
|
||||||
|
makeRoUE prec e = makeUE () e $ StaticValue (realFracToDecimalP prec $ entryRValue e)
|
||||||
|
|
||||||
|
makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
|
||||||
|
makeUnkUE k e = makeUE k e ()
|
||||||
|
|
||||||
|
insertAll
|
||||||
|
:: (MonadAppError m, MonadSqlQuery m, MonadFinance m)
|
||||||
|
=> [EntryCRU]
|
||||||
|
-> m ()
|
||||||
|
insertAll ebs = do
|
||||||
|
(toUpdate, toInsert) <- balanceTxs ebs
|
||||||
|
mapM_ updateTx toUpdate
|
||||||
|
forM_ (groupWith itxCommit toInsert) $
|
||||||
|
\(c, ts) -> do
|
||||||
|
ck <- insert c
|
||||||
|
mapM_ (insertTx ck) ts
|
||||||
|
|
||||||
|
insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
|
||||||
|
insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget, itxPriority} = do
|
||||||
|
k <- insert $ TransactionR c itxDate itxDescr itxBudget itxPriority
|
||||||
|
mapM_ (uncurry (insertEntrySet k)) $ zip [0 ..] (NE.toList itxEntrySets)
|
||||||
|
where
|
||||||
|
insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do
|
||||||
|
let fs = NE.toList iesFromEntries
|
||||||
|
let ts = NE.toList iesToEntries
|
||||||
|
let rebalance = any (isJust . ieCached) (fs ++ ts)
|
||||||
|
esk <- insert $ EntrySetR tk iesCurrency i rebalance
|
||||||
|
mapM_ (uncurry (go esk)) $ zip [0 ..] ts ++ zip (negate <$> [1 ..]) fs
|
||||||
|
go k i e = void $ insertEntry k i e
|
||||||
|
|
||||||
|
insertEntry :: MonadSqlQuery m => EntrySetRId -> EntryIndex -> InsertEntry -> m EntryRId
|
||||||
|
insertEntry
|
||||||
|
k
|
||||||
|
i
|
||||||
|
InsertEntry
|
||||||
|
{ ieEntry = Entry {eValue, eTags, eAcnt, eComment}
|
||||||
|
, ieCached
|
||||||
|
} =
|
||||||
|
do
|
||||||
|
ek <- insert $ EntryR k eAcnt eComment (toRational eValue) i cval ctype deflink
|
||||||
|
mapM_ (insert_ . TagRelationR ek) eTags
|
||||||
|
return ek
|
||||||
|
where
|
||||||
|
(cval, ctype, deflink) = case ieCached of
|
||||||
|
(Just (CachedLink x s)) -> (Just (toRational s), Nothing, Just x)
|
||||||
|
(Just (CachedBalance b)) -> (Just (toRational b), Just TBalance, Nothing)
|
||||||
|
(Just (CachedPercent p)) -> (Just (toRational p), Just TPercent, Nothing)
|
||||||
|
Nothing -> (Nothing, Just TFixed, Nothing)
|
||||||
|
|
||||||
|
updateTx :: MonadSqlQuery m => UEBalanced -> m ()
|
||||||
|
updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. v]
|
||||||
|
where
|
||||||
|
v = toRational $ unStaticValue ueValue
|
||||||
|
|
||||||
|
repsertE :: (MonadSqlQuery m, PersistRecordBackend r SqlBackend) => Key r -> r -> m ()
|
||||||
|
repsertE k r = unsafeLiftSql "esqueleto-repsert" (E.repsert k r)
|
||||||
|
|
||||||
selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r]
|
selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r]
|
||||||
selectE q = unsafeLiftSql "esqueleto-select" (E.select q)
|
selectE q = unsafeLiftSql "esqueleto-select" (E.select q)
|
||||||
|
|
||||||
whenHash
|
deleteKeyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => Key a -> m ()
|
||||||
:: (Hashable a, MonadFinance m, MonadSqlQuery m)
|
deleteKeyE q = unsafeLiftSql "esqueleto-deleteKey" (E.deleteKey q)
|
||||||
=> ConfigType
|
|
||||||
-> a
|
|
||||||
-> b
|
|
||||||
-> (CommitRId -> m b)
|
|
||||||
-> m b
|
|
||||||
whenHash t o def f = do
|
|
||||||
let h = hash o
|
|
||||||
hs <- askDBState kmNewCommits
|
|
||||||
if h `elem` hs then f =<< insert (CommitR h t) else return def
|
|
||||||
|
|
||||||
whenHash_
|
insertEntityManyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => [Entity a] -> m ()
|
||||||
:: (Hashable a, MonadFinance m)
|
insertEntityManyE q = unsafeLiftSql "esqueleto-insertEntityMany" (E.insertEntityMany q)
|
||||||
=> ConfigType
|
|
||||||
-> a
|
|
||||||
-> m b
|
|
||||||
-> m (Maybe (CommitR, b))
|
|
||||||
whenHash_ t o f = do
|
|
||||||
let h = hash o
|
|
||||||
let c = CommitR h t
|
|
||||||
hs <- askDBState kmNewCommits
|
|
||||||
if h `elem` hs then Just . (c,) <$> f else return Nothing
|
|
||||||
|
|
||||||
insertEntry :: MonadSqlQuery m => TransactionRId -> KeyEntry -> m EntryRId
|
|
||||||
insertEntry t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do
|
|
||||||
k <- insert $ EntryR t eCurrency eAcnt eComment eValue
|
|
||||||
mapM_ (insert_ . TagRelationR k) eTags
|
|
||||||
return k
|
|
||||||
|
|
||||||
resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry
|
|
||||||
resolveEntry s@Entry {eAcnt, eCurrency, eValue, eTags} = do
|
|
||||||
let aRes = lookupAccountKey eAcnt
|
|
||||||
let cRes = lookupCurrencyKey eCurrency
|
|
||||||
let sRes = lookupAccountSign eAcnt
|
|
||||||
let tagRes = combineErrors $ fmap lookupTag eTags
|
|
||||||
-- TODO correct sign here?
|
|
||||||
-- TODO lenses would be nice here
|
|
||||||
combineError (combineError3 aRes cRes sRes (,,)) tagRes $
|
|
||||||
\(aid, cid, sign) tags ->
|
|
||||||
s
|
|
||||||
{ eAcnt = aid
|
|
||||||
, eCurrency = cid
|
|
||||||
, eValue = eValue * fromIntegral (sign2Int sign)
|
|
||||||
, eTags = tags
|
|
||||||
}
|
|
||||||
|
|
|
@ -1,15 +1,16 @@
|
||||||
module Internal.History
|
module Internal.History
|
||||||
( splitHistory
|
( readHistStmt
|
||||||
, insertHistTransfer
|
, readHistTransfer
|
||||||
, readHistStmt
|
, splitHistory
|
||||||
, insertHistStmt
|
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
import Data.Csv
|
import Data.Csv
|
||||||
import Database.Persist.Monad
|
import Data.Decimal
|
||||||
import Internal.Database
|
import Data.Foldable
|
||||||
|
import Data.Hashable
|
||||||
|
import GHC.Real
|
||||||
import Internal.Types.Main
|
import Internal.Types.Main
|
||||||
import Internal.Utils
|
import Internal.Utils
|
||||||
import RIO hiding (to)
|
import RIO hiding (to)
|
||||||
|
@ -20,107 +21,55 @@ import qualified RIO.Map as M
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
import RIO.Time
|
import RIO.Time
|
||||||
import qualified RIO.Vector as V
|
import qualified RIO.Vector as V
|
||||||
|
import Text.Regex.TDFA hiding (matchAll)
|
||||||
|
import Text.Regex.TDFA.Text
|
||||||
|
|
||||||
splitHistory :: [History] -> ([HistTransfer], [Statement])
|
-- 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
|
splitHistory = partitionEithers . fmap go
|
||||||
where
|
where
|
||||||
go (HistTransfer x) = Left x
|
go (HistTransfer x) = Left x
|
||||||
go (HistStatement x) = Right x
|
go (HistStatement x) = Right x
|
||||||
|
|
||||||
insertHistTransfer
|
--------------------------------------------------------------------------------
|
||||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
-- Transfers
|
||||||
=> HistTransfer
|
|
||||||
-> m ()
|
readHistTransfer
|
||||||
insertHistTransfer
|
:: (MonadAppError m, MonadFinance m)
|
||||||
m@Transfer
|
=> PairedTransfer
|
||||||
{ transFrom = from
|
-> m [Tx CommitR]
|
||||||
, transTo = to
|
readHistTransfer ht = do
|
||||||
, transCurrency = u
|
bounds <- asks (unHSpan . csHistoryScope)
|
||||||
, transAmounts = amts
|
expandTransfer c historyName bounds ht
|
||||||
} = do
|
where
|
||||||
whenHash CTManual m () $ \c -> do
|
c = CommitR (CommitHash $ hash ht) CTHistoryTransfer
|
||||||
bounds <- askDBState kmStatementInterval
|
|
||||||
let precRes = lookupCurrencyPrec u
|
--------------------------------------------------------------------------------
|
||||||
let go Amount {amtWhen, amtValue, amtDesc} = do
|
-- Statements
|
||||||
let dayRes = liftExcept $ expandDatePat bounds amtWhen
|
|
||||||
(days, precision) <- combineError dayRes precRes (,)
|
|
||||||
let tx day = txPair day from to u (roundPrecision precision amtValue) amtDesc
|
|
||||||
keys <- combineErrors $ fmap tx days
|
|
||||||
mapM_ (insertTx c) keys
|
|
||||||
void $ combineErrors $ fmap go amts
|
|
||||||
|
|
||||||
readHistStmt
|
readHistStmt
|
||||||
:: (MonadUnliftIO m, MonadFinance m)
|
:: (MonadUnliftIO m, MonadFinance m)
|
||||||
=> FilePath
|
=> FilePath
|
||||||
-> Statement
|
-> Statement
|
||||||
-> m (Maybe (CommitR, [KeyTx]))
|
-> m [Tx CommitR]
|
||||||
readHistStmt root i = whenHash_ CTImport i $ do
|
readHistStmt root i = do
|
||||||
bs <- readImport root i
|
bs <- readImport root i
|
||||||
bounds <- askDBState kmStatementInterval
|
bounds <- asks (unHSpan . csHistoryScope)
|
||||||
liftIOExceptT $ mapErrors resolveTx $ filter (inDaySpan bounds . txDate) bs
|
return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
|
||||||
|
|
||||||
insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m ()
|
|
||||||
insertHistStmt c ks = do
|
|
||||||
ck <- insert c
|
|
||||||
mapM_ (insertTx ck) ks
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- low-level transaction stuff
|
|
||||||
|
|
||||||
-- TODO tags here?
|
|
||||||
txPair
|
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
|
||||||
=> Day
|
|
||||||
-> AcntID
|
|
||||||
-> AcntID
|
|
||||||
-> CurID
|
|
||||||
-> Rational
|
|
||||||
-> T.Text
|
|
||||||
-> m KeyTx
|
|
||||||
txPair day from to cur val desc = resolveTx tx
|
|
||||||
where
|
where
|
||||||
split a v =
|
c = CommitR (CommitHash $ hash i) CTHistoryStatement
|
||||||
Entry
|
|
||||||
{ eAcnt = a
|
|
||||||
, eValue = v
|
|
||||||
, eComment = ""
|
|
||||||
, eCurrency = cur
|
|
||||||
, eTags = []
|
|
||||||
}
|
|
||||||
tx =
|
|
||||||
Tx
|
|
||||||
{ txDescr = desc
|
|
||||||
, txDate = day
|
|
||||||
, txEntries = [split from (-val), split to val]
|
|
||||||
}
|
|
||||||
|
|
||||||
resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
|
|
||||||
resolveTx t@Tx {txEntries = ss} =
|
|
||||||
fmap (\kss -> t {txEntries = kss}) $
|
|
||||||
combineErrors $
|
|
||||||
fmap resolveEntry ss
|
|
||||||
|
|
||||||
insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
|
|
||||||
insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
|
|
||||||
k <- insert $ TransactionR c d e
|
|
||||||
mapM_ (insertEntry k) ss
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- Statements
|
|
||||||
|
|
||||||
-- TODO this probably won't scale well (pipes?)
|
-- 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 [Tx ()]
|
||||||
readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
|
readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
|
||||||
let ores = compileOptions stmtTxOpts
|
let ores = compileOptions stmtTxOpts
|
||||||
let cres = combineErrors $ compileMatch <$> stmtParsers
|
let cres = combineErrors $ compileMatch <$> stmtParsers
|
||||||
(compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
|
(compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
|
||||||
let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
|
let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
|
||||||
records <- L.sort . concat <$> mapErrorsIO readStmt paths
|
records <- L.sort . concat <$> mapErrorsIO readStmt paths
|
||||||
m <- askDBState kmCurrency
|
fromEither =<< runExceptT (matchRecords compiledMatches records)
|
||||||
fromEither $
|
|
||||||
flip runReader m $
|
|
||||||
runExceptT $
|
|
||||||
matchRecords compiledMatches records
|
|
||||||
where
|
where
|
||||||
paths = (root </>) <$> stmtPaths
|
paths = (root </>) <$> stmtPaths
|
||||||
|
|
||||||
|
@ -133,9 +82,9 @@ readImport_
|
||||||
-> m [TxRecord]
|
-> m [TxRecord]
|
||||||
readImport_ n delim tns p = do
|
readImport_ n delim tns p = do
|
||||||
res <- tryIO $ BL.readFile p
|
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
|
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
|
Right (_, v) -> return $ catMaybes $ V.toList v
|
||||||
where
|
where
|
||||||
opts = defaultDecodeOptions {decDelimiter = fromIntegral delim}
|
opts = defaultDecodeOptions {decDelimiter = fromIntegral delim}
|
||||||
|
@ -149,18 +98,18 @@ parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFm
|
||||||
if d == ""
|
if d == ""
|
||||||
then return Nothing
|
then return Nothing
|
||||||
else do
|
else do
|
||||||
a <- parseRational toAmountFmt =<< r .: T.encodeUtf8 toAmount
|
a <- parseDecimal toAmountFmt =<< r .: T.encodeUtf8 toAmount
|
||||||
e <- r .: T.encodeUtf8 toDesc
|
e <- r .: T.encodeUtf8 toDesc
|
||||||
os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther
|
os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther
|
||||||
d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
|
d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
|
||||||
return $ Just $ TxRecord d' a e os p
|
return $ Just $ TxRecord d' a e os p
|
||||||
|
|
||||||
matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [BalTx]
|
matchRecords :: MonadFinance m => [MatchRe] -> [TxRecord] -> AppExceptT m [Tx ()]
|
||||||
matchRecords ms rs = do
|
matchRecords ms rs = do
|
||||||
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
|
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
|
||||||
case (matched, unmatched, notfound) of
|
case (matched, unmatched, notfound) of
|
||||||
(ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_
|
(ms_, [], []) -> return ms_
|
||||||
(_, us, ns) -> throwError $ InsertException [StatementError us ns]
|
(_, us, ns) -> throwError $ AppException [StatementError us ns]
|
||||||
|
|
||||||
matchPriorities :: [MatchRe] -> [MatchGroup]
|
matchPriorities :: [MatchRe] -> [MatchGroup]
|
||||||
matchPriorities =
|
matchPriorities =
|
||||||
|
@ -214,9 +163,10 @@ zipperSlice f x = go
|
||||||
LT -> z
|
LT -> z
|
||||||
|
|
||||||
zipperMatch
|
zipperMatch
|
||||||
:: Unzipped MatchRe
|
:: MonadFinance m
|
||||||
|
=> Unzipped MatchRe
|
||||||
-> TxRecord
|
-> TxRecord
|
||||||
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
|
-> AppExceptT m (Zipped MatchRe, MatchRes (Tx ()))
|
||||||
zipperMatch (Unzipped bs cs as) x = go [] cs
|
zipperMatch (Unzipped bs cs as) x = go [] cs
|
||||||
where
|
where
|
||||||
go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
|
go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
|
||||||
|
@ -230,9 +180,10 @@ zipperMatch (Unzipped bs cs as) x = go [] cs
|
||||||
in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
|
in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
|
||||||
|
|
||||||
zipperMatch'
|
zipperMatch'
|
||||||
:: Zipped MatchRe
|
:: MonadFinance m
|
||||||
|
=> Zipped MatchRe
|
||||||
-> TxRecord
|
-> TxRecord
|
||||||
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
|
-> AppExceptT m (Zipped MatchRe, MatchRes (Tx ()))
|
||||||
zipperMatch' z x = go z
|
zipperMatch' z x = go z
|
||||||
where
|
where
|
||||||
go (Zipped bs (a : as)) = do
|
go (Zipped bs (a : as)) = do
|
||||||
|
@ -249,7 +200,11 @@ matchDec m = case spTimes m of
|
||||||
Just n -> Just $ m {spTimes = Just $ n - 1}
|
Just n -> Just $ m {spTimes = Just $ n - 1}
|
||||||
Nothing -> Just m
|
Nothing -> Just m
|
||||||
|
|
||||||
matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
|
matchAll
|
||||||
|
:: MonadFinance m
|
||||||
|
=> [MatchGroup]
|
||||||
|
-> [TxRecord]
|
||||||
|
-> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
|
||||||
matchAll = go ([], [])
|
matchAll = go ([], [])
|
||||||
where
|
where
|
||||||
go (matched, unused) gs rs = case (gs, rs) of
|
go (matched, unused) gs rs = case (gs, rs) of
|
||||||
|
@ -259,13 +214,21 @@ matchAll = go ([], [])
|
||||||
(ts, unmatched, us) <- matchGroup g rs
|
(ts, unmatched, us) <- matchGroup g rs
|
||||||
go (ts ++ matched, us ++ unused) gs' unmatched
|
go (ts ++ matched, us ++ unused) gs' unmatched
|
||||||
|
|
||||||
matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
|
matchGroup
|
||||||
|
:: MonadFinance m
|
||||||
|
=> MatchGroup
|
||||||
|
-> [TxRecord]
|
||||||
|
-> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
|
||||||
matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
|
matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
|
||||||
(md, rest, ud) <- matchDates ds rs
|
(md, rest, ud) <- matchDates ds rs
|
||||||
(mn, unmatched, un) <- matchNonDates ns rest
|
(mn, unmatched, un) <- matchNonDates ns rest
|
||||||
return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un)
|
return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un)
|
||||||
|
|
||||||
matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
|
matchDates
|
||||||
|
:: MonadFinance m
|
||||||
|
=> [MatchRe]
|
||||||
|
-> [TxRecord]
|
||||||
|
-> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
|
||||||
matchDates ms = go ([], [], initZipper ms)
|
matchDates ms = go ([], [], initZipper ms)
|
||||||
where
|
where
|
||||||
go (matched, unmatched, z) [] =
|
go (matched, unmatched, z) [] =
|
||||||
|
@ -286,7 +249,11 @@ matchDates ms = go ([], [], initZipper ms)
|
||||||
go (m, u, z') rs
|
go (m, u, z') rs
|
||||||
findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
|
findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
|
||||||
|
|
||||||
matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
|
matchNonDates
|
||||||
|
:: MonadFinance m
|
||||||
|
=> [MatchRe]
|
||||||
|
-> [TxRecord]
|
||||||
|
-> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
|
||||||
matchNonDates ms = go ([], [], initZipper ms)
|
matchNonDates ms = go ([], [], initZipper ms)
|
||||||
where
|
where
|
||||||
go (matched, unmatched, z) [] =
|
go (matched, unmatched, z) [] =
|
||||||
|
@ -303,26 +270,246 @@ matchNonDates ms = go ([], [], initZipper ms)
|
||||||
MatchFail -> (matched, r : unmatched)
|
MatchFail -> (matched, r : unmatched)
|
||||||
in go (m, u, resetZipper z') rs
|
in go (m, u, resetZipper z') rs
|
||||||
|
|
||||||
balanceTx :: RawTx -> InsertExcept BalTx
|
matches :: MonadFinance m => MatchRe -> TxRecord -> AppExceptT m (MatchRes (Tx ()))
|
||||||
balanceTx t@Tx {txEntries = ss} = do
|
matches
|
||||||
bs <- balanceEntries ss
|
StatementParser {spTx, spOther, spVal, spDate, spDesc, spPriority}
|
||||||
return $ t {txEntries = bs}
|
r@TxRecord {trDate, trAmount, trDesc, trOther} = do
|
||||||
|
res <- liftInner $
|
||||||
balanceEntries :: [RawEntry] -> InsertExcept [BalEntry]
|
combineError3 val other desc $
|
||||||
balanceEntries ss =
|
\x y z -> x && y && z && date
|
||||||
fmap concat
|
if res
|
||||||
<$> mapM (uncurry bal)
|
then maybe (return MatchSkip) convert spTx
|
||||||
$ groupByKey
|
else return MatchFail
|
||||||
$ fmap (\s -> (eCurrency s, s)) ss
|
|
||||||
where
|
where
|
||||||
haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
|
val = valMatches spVal $ toRational trAmount
|
||||||
haeValue s = Left s
|
date = maybe True (`dateMatches` trDate) spDate
|
||||||
bal cur rss
|
other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther
|
||||||
| length rss < 2 = throwError $ InsertException [BalanceError TooFewEntries cur rss]
|
desc = maybe (return True) (matchMaybe (unTxDesc trDesc) . snd) spDesc
|
||||||
| otherwise = case partitionEithers $ fmap haeValue rss of
|
convert tg = MatchPass <$> toTx (fromIntegral spPriority) tg r
|
||||||
([noVal], val) -> return $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
|
|
||||||
([], val) -> return val
|
|
||||||
_ -> throwError $ InsertException [BalanceError NotOneBlank cur rss]
|
|
||||||
|
|
||||||
groupByKey :: Ord k => [(k, v)] -> [(k, [v])]
|
toTx :: MonadFinance m => Int -> TxGetter -> TxRecord -> AppExceptT m (Tx ())
|
||||||
groupByKey = M.toList . M.fromListWith (++) . fmap (second (: []))
|
toTx
|
||||||
|
priority
|
||||||
|
TxGetter
|
||||||
|
{ tgFrom
|
||||||
|
, tgTo
|
||||||
|
, tgCurrency
|
||||||
|
, tgOtherEntries
|
||||||
|
, tgScale
|
||||||
|
}
|
||||||
|
r@TxRecord {trAmount, trDate, trDesc} = do
|
||||||
|
combineError curRes subRes $ \(cur, f, t) ss ->
|
||||||
|
Tx
|
||||||
|
{ txDate = trDate
|
||||||
|
, txDescr = trDesc
|
||||||
|
, txCommit = ()
|
||||||
|
, txPrimary =
|
||||||
|
Left $
|
||||||
|
EntrySet
|
||||||
|
{ esTotalValue = roundToP (cpPrec cur) trAmount *. tgScale
|
||||||
|
, esCurrency = cpID cur
|
||||||
|
, esFrom = f
|
||||||
|
, esTo = t
|
||||||
|
}
|
||||||
|
, txOther = Left <$> ss
|
||||||
|
, txBudget = historyName
|
||||||
|
, txPriority = priority
|
||||||
|
}
|
||||||
|
where
|
||||||
|
curRes = do
|
||||||
|
m <- asks csCurrencyMap
|
||||||
|
cur <- liftInner $ resolveCurrency m r tgCurrency
|
||||||
|
let prec = cpPrec cur
|
||||||
|
let fromRes = liftInner $ resolveHalfEntry resolveFromValue prec r () tgFrom
|
||||||
|
let toRes = liftInner $ resolveHalfEntry resolveToValue prec r () tgTo
|
||||||
|
combineError fromRes toRes (cur,,)
|
||||||
|
subRes = mapErrors (resolveSubGetter r) tgOtherEntries
|
||||||
|
|
||||||
|
resolveSubGetter
|
||||||
|
:: MonadFinance m
|
||||||
|
=> TxRecord
|
||||||
|
-> TxSubGetter
|
||||||
|
-> AppExceptT m SecondayEntrySet
|
||||||
|
resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
|
||||||
|
m <- asks csCurrencyMap
|
||||||
|
cur <- liftInner $ resolveCurrency m r tsgCurrency
|
||||||
|
let prec = cpPrec cur
|
||||||
|
let toRes = resolveHalfEntry resolveToValue prec r () tsgTo
|
||||||
|
let valRes = liftInner $ resolveValue prec r tsgValue
|
||||||
|
liftInner $ combineErrorM toRes valRes $ \t v -> do
|
||||||
|
f <- resolveHalfEntry resolveFromValue prec r v tsgFrom
|
||||||
|
return $
|
||||||
|
EntrySet
|
||||||
|
{ esTotalValue = ()
|
||||||
|
, esCurrency = cpID cur
|
||||||
|
, esFrom = f
|
||||||
|
, esTo = t
|
||||||
|
}
|
||||||
|
|
||||||
|
resolveHalfEntry
|
||||||
|
:: (Precision -> TxRecord -> n -> AppExcept v')
|
||||||
|
-> Precision
|
||||||
|
-> TxRecord
|
||||||
|
-> v
|
||||||
|
-> TxHalfGetter (EntryGetter n)
|
||||||
|
-> AppExcept (HalfEntrySet v v')
|
||||||
|
resolveHalfEntry f prec r v TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
|
||||||
|
combineError acntRes esRes $ \a es ->
|
||||||
|
HalfEntrySet
|
||||||
|
{ hesPrimary =
|
||||||
|
Entry
|
||||||
|
{ eAcnt = a
|
||||||
|
, eValue = v
|
||||||
|
, eComment = thgComment
|
||||||
|
, eTags = thgTags
|
||||||
|
}
|
||||||
|
, hesOther = es
|
||||||
|
}
|
||||||
|
where
|
||||||
|
acntRes = resolveAcnt r thgAcnt
|
||||||
|
esRes = mapErrors (resolveEntry f prec r) thgEntries
|
||||||
|
|
||||||
|
otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> AppExcept Bool
|
||||||
|
otherMatches dict m = case m of
|
||||||
|
Val (Field n mv) -> valMatches mv =<< (readRational =<< lookup_ MatchNumeric n)
|
||||||
|
Desc (Field n (_, md)) -> (`matchMaybe` md) =<< lookup_ MatchText n
|
||||||
|
where
|
||||||
|
lookup_ t n = lookupErr (MatchField t) n dict
|
||||||
|
|
||||||
|
resolveEntry
|
||||||
|
:: (Precision -> TxRecord -> n -> AppExcept v)
|
||||||
|
-> Precision
|
||||||
|
-> TxRecord
|
||||||
|
-> EntryGetter n
|
||||||
|
-> AppExcept (Entry AcntID v TagID)
|
||||||
|
resolveEntry f prec r s@Entry {eAcnt, eValue} =
|
||||||
|
combineError acntRes valRes $ \a v -> s {eAcnt = a, eValue = v}
|
||||||
|
where
|
||||||
|
acntRes = resolveAcnt r eAcnt
|
||||||
|
valRes = f prec r eValue
|
||||||
|
|
||||||
|
resolveFromValue :: Precision -> TxRecord -> EntryNumGetter -> AppExcept EntryValue
|
||||||
|
resolveFromValue = resolveValue
|
||||||
|
|
||||||
|
resolveToValue :: Precision -> TxRecord -> LinkedEntryNumGetter -> AppExcept EntryLink
|
||||||
|
resolveToValue _ _ (Linked l) = return $ LinkIndex l
|
||||||
|
resolveToValue prec r (Getter g) = LinkValue <$> resolveValue prec r g
|
||||||
|
|
||||||
|
resolveValue :: Precision -> TxRecord -> EntryNumGetter -> AppExcept EntryValue
|
||||||
|
resolveValue prec TxRecord {trOther, trAmount} s = case s of
|
||||||
|
(LookupN t) -> EntryFixed . go <$> (readDouble =<< lookupErr EntryValField t trOther)
|
||||||
|
(ConstN c) -> return $ EntryFixed $ go c
|
||||||
|
AmountN m -> return $ EntryFixed $ trAmount *. m
|
||||||
|
BalanceN x -> return $ EntryBalance $ go x
|
||||||
|
PercentN x -> return $ EntryPercent x
|
||||||
|
where
|
||||||
|
go = realFracToDecimalP prec
|
||||||
|
|
||||||
|
resolveAcnt :: TxRecord -> EntryAcnt -> AppExcept AcntID
|
||||||
|
resolveAcnt r e = AcntID <$> resolveEntryField AcntField r (unAcntID <$> e)
|
||||||
|
|
||||||
|
resolveCurrency :: CurrencyMap -> TxRecord -> EntryCur -> AppExcept CurrencyPrec
|
||||||
|
resolveCurrency m r c = do
|
||||||
|
i <- resolveEntryField CurField r (unCurID <$> c)
|
||||||
|
case M.lookup (CurID i) m of
|
||||||
|
Just k -> return k
|
||||||
|
Nothing -> throwError $ AppException [LookupError (DBKey CurField) i]
|
||||||
|
|
||||||
|
resolveEntryField :: EntryIDType -> TxRecord -> EntryTextGetter T.Text -> AppExcept T.Text
|
||||||
|
resolveEntryField t TxRecord {trOther = o} s = case s of
|
||||||
|
ConstT p -> return p
|
||||||
|
LookupT f -> lookup_ f o
|
||||||
|
MapT (Field f m) -> do
|
||||||
|
k <- lookup_ f o
|
||||||
|
lookup_ k m
|
||||||
|
Map2T (Field (f1, f2) m) -> do
|
||||||
|
(k1, k2) <- combineError (lookup_ f1 o) (lookup_ f2 o) (,)
|
||||||
|
lookup_ (k1, k2) m
|
||||||
|
where
|
||||||
|
lookup_ :: (Ord k, Show k) => k -> M.Map k v -> AppExcept v
|
||||||
|
lookup_ = lookupErr (EntryIDField t)
|
||||||
|
|
||||||
|
readDouble :: T.Text -> AppExcept Double
|
||||||
|
readDouble s = case readMaybe $ T.unpack s of
|
||||||
|
Just x -> return x
|
||||||
|
Nothing -> throwError $ AppException [ConversionError s True]
|
||||||
|
|
||||||
|
readRational :: T.Text -> AppExcept Rational
|
||||||
|
readRational s = case T.split (== '.') s of
|
||||||
|
[x] -> maybe err (return . fromInteger) $ readT x
|
||||||
|
[x, y] -> case (readT x, readT y) of
|
||||||
|
(Just x', Just y') ->
|
||||||
|
let p = 10 ^ T.length y
|
||||||
|
k = if x' >= 0 then 1 else -1
|
||||||
|
in return $ fromInteger x' + k * y' % p
|
||||||
|
_ -> err
|
||||||
|
_ -> err
|
||||||
|
where
|
||||||
|
readT = readMaybe . T.unpack
|
||||||
|
err = throwError $ AppException [ConversionError s False]
|
||||||
|
|
||||||
|
compileOptions :: TxOpts T.Text -> AppExcept TxOptsRe
|
||||||
|
compileOptions o@TxOpts {toAmountFmt = pat} = do
|
||||||
|
re <- compileRegex True pat
|
||||||
|
return $ o {toAmountFmt = re}
|
||||||
|
|
||||||
|
compileMatch :: StatementParser T.Text -> AppExcept MatchRe
|
||||||
|
compileMatch m@StatementParser {spDesc, spOther} = do
|
||||||
|
combineError dres ores $ \d os -> m {spDesc = d, spOther = os}
|
||||||
|
where
|
||||||
|
go = compileRegex False
|
||||||
|
dres = mapM go spDesc
|
||||||
|
ores = combineErrors $ fmap (mapM go) spOther
|
||||||
|
|
||||||
|
compileRegex :: Bool -> T.Text -> AppExcept (Text, Regex)
|
||||||
|
compileRegex groups pat = case res of
|
||||||
|
Right re -> return (pat, re)
|
||||||
|
Left _ -> throwError $ AppException [RegexError pat]
|
||||||
|
where
|
||||||
|
res =
|
||||||
|
compile
|
||||||
|
(blankCompOpt {newSyntax = True})
|
||||||
|
(blankExecOpt {captureGroups = groups})
|
||||||
|
pat
|
||||||
|
|
||||||
|
matchMaybe :: T.Text -> Regex -> AppExcept Bool
|
||||||
|
matchMaybe q re = case execute re q of
|
||||||
|
Right res -> return $ isJust res
|
||||||
|
Left _ -> throwError $ AppException [RegexError "this should not happen"]
|
||||||
|
|
||||||
|
matchGroupsMaybe :: T.Text -> Regex -> [T.Text]
|
||||||
|
matchGroupsMaybe q re = case regexec re q of
|
||||||
|
Right Nothing -> []
|
||||||
|
Right (Just (_, _, _, xs)) -> xs
|
||||||
|
-- this should never fail as regexec always returns Right
|
||||||
|
Left _ -> []
|
||||||
|
|
||||||
|
parseDecimal :: MonadFail m => (T.Text, Regex) -> T.Text -> m Decimal
|
||||||
|
parseDecimal (pat, re) s = case matchGroupsMaybe s re of
|
||||||
|
[sign, x, ""] -> Decimal 0 . uncurry (*) <$> readWhole sign x
|
||||||
|
[sign, x, y] -> do
|
||||||
|
d <- readT "decimal" y
|
||||||
|
let p = T.length y
|
||||||
|
(k, w) <- readWhole sign x
|
||||||
|
return $ Decimal (fromIntegral p) (k * (w * (10 ^ p) + d))
|
||||||
|
_ -> msg "malformed decimal"
|
||||||
|
where
|
||||||
|
readT what t = case readMaybe $ T.unpack t of
|
||||||
|
Just d -> return $ fromInteger d
|
||||||
|
_ -> msg $ T.unwords ["could not parse", what, singleQuote t]
|
||||||
|
msg :: MonadFail m => T.Text -> m a
|
||||||
|
msg m =
|
||||||
|
fail $
|
||||||
|
T.unpack $
|
||||||
|
T.unwords [m, "-", keyVals [("pattern", pat), ("query", s)]]
|
||||||
|
readSign x
|
||||||
|
| x == "-" = return (-1)
|
||||||
|
| x == "+" || x == "" = return 1
|
||||||
|
| otherwise = msg $ T.append "invalid sign: " x
|
||||||
|
readWhole sign x = do
|
||||||
|
w <- readT "whole number" x
|
||||||
|
k <- readSign sign
|
||||||
|
return (k, w)
|
||||||
|
|
||||||
|
historyName :: BudgetName
|
||||||
|
historyName = BudgetName "history"
|
||||||
|
|
|
@ -7,9 +7,12 @@
|
||||||
-- | Types corresponding to the database model
|
-- | Types corresponding to the database model
|
||||||
module Internal.Types.Database where
|
module Internal.Types.Database where
|
||||||
|
|
||||||
|
import Data.Csv (FromField)
|
||||||
import Database.Persist.Sql hiding (Desc, In, Statement)
|
import Database.Persist.Sql hiding (Desc, In, Statement)
|
||||||
import Database.Persist.TH
|
import Database.Persist.TH
|
||||||
|
import Internal.Types.Dhall
|
||||||
import RIO
|
import RIO
|
||||||
|
import qualified RIO.NonEmpty as NE
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
import RIO.Time
|
import RIO.Time
|
||||||
|
|
||||||
|
@ -17,51 +20,94 @@ share
|
||||||
[mkPersist sqlSettings, mkMigrate "migrateAll"]
|
[mkPersist sqlSettings, mkMigrate "migrateAll"]
|
||||||
[persistLowerCase|
|
[persistLowerCase|
|
||||||
CommitR sql=commits
|
CommitR sql=commits
|
||||||
hash Int
|
hash CommitHash
|
||||||
type ConfigType
|
type ConfigType
|
||||||
deriving Show Eq
|
UniqueCommitHash hash
|
||||||
|
deriving Show Eq Ord
|
||||||
|
ConfigStateR sql=config_state
|
||||||
|
historySpan HistorySpan
|
||||||
|
budgetSpan BudgetSpan
|
||||||
|
deriving Show
|
||||||
CurrencyR sql=currencies
|
CurrencyR sql=currencies
|
||||||
symbol T.Text
|
symbol CurID
|
||||||
fullname T.Text
|
fullname T.Text
|
||||||
precision Int
|
precision Precision
|
||||||
deriving Show Eq
|
UniqueCurrencySymbol symbol
|
||||||
|
UniqueCurrencyFullname fullname
|
||||||
|
deriving Show Eq Ord
|
||||||
TagR sql=tags
|
TagR sql=tags
|
||||||
symbol T.Text
|
symbol TagID
|
||||||
fullname T.Text
|
fullname T.Text
|
||||||
deriving Show Eq
|
UniqueTagSymbol symbol
|
||||||
|
UniqueTagFullname fullname
|
||||||
|
deriving Show Eq Ord
|
||||||
AccountR sql=accounts
|
AccountR sql=accounts
|
||||||
name T.Text
|
name T.Text
|
||||||
fullpath T.Text
|
fullpath AcntPath
|
||||||
desc T.Text
|
desc T.Text
|
||||||
deriving Show Eq
|
sign AcntSign
|
||||||
|
leaf Bool
|
||||||
|
UniqueAccountFullpath fullpath
|
||||||
|
deriving Show Eq Ord
|
||||||
AccountPathR sql=account_paths
|
AccountPathR sql=account_paths
|
||||||
parent AccountRId OnDeleteCascade
|
parent AccountRId
|
||||||
child AccountRId OnDeleteCascade
|
child AccountRId
|
||||||
depth Int
|
depth Int
|
||||||
deriving Show Eq
|
deriving Show Eq Ord
|
||||||
TransactionR sql=transactions
|
TransactionR sql=transactions
|
||||||
commit CommitRId OnDeleteCascade
|
commit CommitRId
|
||||||
date Day
|
date Day
|
||||||
description T.Text
|
description TxDesc
|
||||||
|
budgetName BudgetName
|
||||||
|
priority Int
|
||||||
|
deriving Show Eq
|
||||||
|
EntrySetR sql=entry_sets
|
||||||
|
transaction TransactionRId
|
||||||
|
currency CurrencyRId
|
||||||
|
index EntrySetIndex
|
||||||
|
rebalance Bool
|
||||||
deriving Show Eq
|
deriving Show Eq
|
||||||
EntryR sql=entries
|
EntryR sql=entries
|
||||||
transaction TransactionRId OnDeleteCascade
|
entryset EntrySetRId
|
||||||
currency CurrencyRId OnDeleteCascade
|
account AccountRId
|
||||||
account AccountRId OnDeleteCascade
|
|
||||||
memo T.Text
|
memo T.Text
|
||||||
value Rational
|
value Rational
|
||||||
|
index EntryIndex
|
||||||
|
cachedValue (Maybe Rational)
|
||||||
|
cachedType (Maybe TransferType)
|
||||||
|
cachedLink (Maybe EntryIndex)
|
||||||
deriving Show Eq
|
deriving Show Eq
|
||||||
TagRelationR sql=tag_relations
|
TagRelationR sql=tag_relations
|
||||||
entry EntryRId OnDeleteCascade
|
entry EntryRId
|
||||||
tag TagRId OnDeleteCascade
|
tag TagRId
|
||||||
BudgetLabelR sql=budget_labels
|
|
||||||
entry EntryRId OnDeleteCascade
|
|
||||||
budgetName T.Text
|
|
||||||
deriving Show Eq
|
deriving Show Eq
|
||||||
|]
|
|]
|
||||||
|
|
||||||
data ConfigType = CTBudget | CTManual | CTImport
|
newtype EntrySetIndex = EntrySetIndex {unEntrySetIndex :: Int}
|
||||||
deriving (Eq, Show, Read, Enum)
|
deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)
|
||||||
|
|
||||||
|
newtype EntryIndex = EntryIndex {unEntryIndex :: Int}
|
||||||
|
deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)
|
||||||
|
|
||||||
|
newtype TxDesc = TxDesc {unTxDesc :: T.Text}
|
||||||
|
deriving newtype (Show, Eq, Ord, PersistField, PersistFieldSql, FromField)
|
||||||
|
|
||||||
|
newtype Precision = Precision {unPrecision :: Word8}
|
||||||
|
deriving newtype (Eq, Ord, Num, Show, Real, Enum, Integral, PersistField, PersistFieldSql)
|
||||||
|
|
||||||
|
type DaySpan = (Day, Int)
|
||||||
|
|
||||||
|
newtype CommitHash = CommitHash {unCommitHash :: Int}
|
||||||
|
deriving newtype (Show, Eq, Num, Ord, PersistField, PersistFieldSql)
|
||||||
|
|
||||||
|
newtype BudgetSpan = BudgetSpan {unBSpan :: DaySpan}
|
||||||
|
deriving newtype (Show, Eq, PersistField, PersistFieldSql)
|
||||||
|
|
||||||
|
newtype HistorySpan = HistorySpan {unHSpan :: DaySpan}
|
||||||
|
deriving newtype (Show, Eq, PersistField, PersistFieldSql)
|
||||||
|
|
||||||
|
data ConfigType = CTBudget | CTHistoryTransfer | CTHistoryStatement
|
||||||
|
deriving (Eq, Show, Read, Enum, Ord)
|
||||||
|
|
||||||
instance PersistFieldSql ConfigType where
|
instance PersistFieldSql ConfigType where
|
||||||
sqlType _ = SqlString
|
sqlType _ = SqlString
|
||||||
|
@ -69,7 +115,61 @@ instance PersistFieldSql ConfigType where
|
||||||
instance PersistField ConfigType where
|
instance PersistField ConfigType where
|
||||||
toPersistValue = PersistText . T.pack . show
|
toPersistValue = PersistText . T.pack . show
|
||||||
|
|
||||||
-- TODO these error messages *might* be good enough?
|
|
||||||
fromPersistValue (PersistText v) =
|
fromPersistValue (PersistText v) =
|
||||||
maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack 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"
|
||||||
|
|
|
@ -19,9 +19,9 @@ import Language.Haskell.TH.Syntax (Lift)
|
||||||
import RIO
|
import RIO
|
||||||
import qualified RIO.Map as M
|
import qualified RIO.Map as M
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
import RIO.Time
|
|
||||||
import Text.Regex.TDFA
|
import Text.Regex.TDFA
|
||||||
|
|
||||||
|
-- TODO find a way to conventiently make TaggedAcnt use my newtypes
|
||||||
makeHaskellTypesWith
|
makeHaskellTypesWith
|
||||||
(defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False})
|
(defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False})
|
||||||
[ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
|
[ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
|
||||||
|
@ -33,13 +33,14 @@ makeHaskellTypesWith
|
||||||
, MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
|
, MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
|
||||||
, MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
|
, MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
|
||||||
, MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
|
, MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
|
||||||
, MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
|
, MultipleConstructors "LinkedEntryNumGetter" "(./dhall/Types.dhall).LinkedEntryNumGetter"
|
||||||
, MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
|
, MultipleConstructors "TransferType" "(./dhall/Types.dhall).TransferType"
|
||||||
, MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
|
, MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
|
||||||
, MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType"
|
, MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType"
|
||||||
|
, SingleConstructor "LinkedNumGetter" "LinkedNumGetter" "(./dhall/Types.dhall).LinkedNumGetter.Type"
|
||||||
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
|
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
|
||||||
, SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag"
|
, 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 "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
|
||||||
, SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
|
, SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
|
||||||
, SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
|
, SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
|
||||||
|
@ -48,12 +49,17 @@ makeHaskellTypesWith
|
||||||
, SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type"
|
, SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type"
|
||||||
, SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type"
|
, SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type"
|
||||||
, SingleConstructor "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type"
|
, SingleConstructor "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type"
|
||||||
, SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount"
|
, SingleConstructor
|
||||||
|
"Amount"
|
||||||
|
"Amount"
|
||||||
|
"\\(w : Type) -> \\(v : Type) -> ((./dhall/Types.dhall).Amount w v).Type"
|
||||||
|
, SingleConstructor
|
||||||
|
"TxOpts"
|
||||||
|
"TxOpts"
|
||||||
|
"\\(re : Type) -> ((./dhall/Types.dhall).TxOpts_ re).Type"
|
||||||
, SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
|
, SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
|
||||||
, SingleConstructor "TransferMatcher" "TransferMatcher" "(./dhall/Types.dhall).TransferMatcher.Type"
|
, SingleConstructor "TransferMatcher" "TransferMatcher" "(./dhall/Types.dhall).TransferMatcher.Type"
|
||||||
, SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
|
, SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
|
||||||
, -- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income.Type"
|
|
||||||
SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
|
|
||||||
, SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
|
, SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
|
||||||
, SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry"
|
, SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry"
|
||||||
, SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue"
|
, SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue"
|
||||||
|
@ -61,14 +67,9 @@ makeHaskellTypesWith
|
||||||
, SingleConstructor "TaxProgression" "TaxProgression" "(./dhall/Types.dhall).TaxProgression"
|
, SingleConstructor "TaxProgression" "TaxProgression" "(./dhall/Types.dhall).TaxProgression"
|
||||||
, SingleConstructor "TaxValue" "TaxValue" "(./dhall/Types.dhall).TaxValue"
|
, SingleConstructor "TaxValue" "TaxValue" "(./dhall/Types.dhall).TaxValue"
|
||||||
, SingleConstructor "PosttaxValue" "PosttaxValue" "(./dhall/Types.dhall).PosttaxValue"
|
, 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 "Period" "Period" "(./dhall/Types.dhall).Period"
|
||||||
, SingleConstructor "HourlyPeriod" "HourlyPeriod" "(./dhall/Types.dhall).HourlyPeriod"
|
, 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
|
deriveProduct
|
||||||
|
@ -95,9 +96,9 @@ deriveProduct
|
||||||
, "DateMatcher"
|
, "DateMatcher"
|
||||||
, "ValMatcher"
|
, "ValMatcher"
|
||||||
, "YMDMatcher"
|
, "YMDMatcher"
|
||||||
, "BudgetCurrency"
|
|
||||||
, "Exchange"
|
|
||||||
, "EntryNumGetter"
|
, "EntryNumGetter"
|
||||||
|
, "LinkedNumGetter"
|
||||||
|
, "LinkedEntryNumGetter"
|
||||||
, "TemporalScope"
|
, "TemporalScope"
|
||||||
, "SqlConfig"
|
, "SqlConfig"
|
||||||
, "PretaxValue"
|
, "PretaxValue"
|
||||||
|
@ -106,8 +107,8 @@ deriveProduct
|
||||||
, "TaxProgression"
|
, "TaxProgression"
|
||||||
, "TaxMethod"
|
, "TaxMethod"
|
||||||
, "PosttaxValue"
|
, "PosttaxValue"
|
||||||
, "BudgetTransferValue"
|
, "TransferValue"
|
||||||
, "BudgetTransferType"
|
, "TransferType"
|
||||||
, "Period"
|
, "Period"
|
||||||
, "PeriodType"
|
, "PeriodType"
|
||||||
, "HourlyPeriod"
|
, "HourlyPeriod"
|
||||||
|
@ -178,22 +179,24 @@ deriving instance Ord DatePat
|
||||||
|
|
||||||
deriving instance Hashable DatePat
|
deriving instance Hashable DatePat
|
||||||
|
|
||||||
type BudgetTransfer =
|
type PairedTransfer = Transfer TaggedAcnt CurID DatePat TransferValue
|
||||||
Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
|
|
||||||
|
|
||||||
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
|
data Budget = Budget
|
||||||
{ bgtLabel :: Text
|
{ bgtLabel :: BudgetName
|
||||||
, bgtIncomes :: [Income]
|
, bgtIncomes :: [Income]
|
||||||
, bgtPretax :: [MultiAllocation PretaxValue]
|
, bgtPretax :: [MultiAllocation PretaxValue]
|
||||||
, bgtTax :: [MultiAllocation TaxValue]
|
, bgtTax :: [MultiAllocation TaxValue]
|
||||||
, bgtPosttax :: [MultiAllocation PosttaxValue]
|
, bgtPosttax :: [MultiAllocation PosttaxValue]
|
||||||
, bgtTransfers :: [BudgetTransfer]
|
, bgtTransfers :: [PairedTransfer]
|
||||||
, bgtShadowTransfers :: [ShadowTransfer]
|
, bgtShadowTransfers :: [ShadowTransfer]
|
||||||
, bgtInterval :: !(Maybe Interval)
|
, bgtInterval :: !(Maybe Interval)
|
||||||
}
|
}
|
||||||
|
@ -212,15 +215,28 @@ deriving instance Hashable PosttaxValue
|
||||||
|
|
||||||
deriving instance Hashable Budget
|
deriving instance Hashable Budget
|
||||||
|
|
||||||
deriving instance Hashable BudgetTransferValue
|
deriving instance Hashable TransferValue
|
||||||
|
|
||||||
deriving instance Hashable BudgetTransferType
|
deriving instance Hashable TransferType
|
||||||
|
|
||||||
|
deriving instance Read TransferType
|
||||||
|
|
||||||
|
instance PersistFieldSql TransferType where
|
||||||
|
sqlType _ = SqlString
|
||||||
|
|
||||||
|
instance PersistField TransferType where
|
||||||
|
toPersistValue = PersistText . T.pack . show
|
||||||
|
|
||||||
|
fromPersistValue (PersistText v) =
|
||||||
|
maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
|
||||||
|
fromPersistValue _ = Left "wrong type"
|
||||||
|
|
||||||
deriving instance Hashable TaggedAcnt
|
deriving instance Hashable TaggedAcnt
|
||||||
|
|
||||||
deriving instance Ord 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
|
data Income = Income
|
||||||
{ incGross :: Double
|
{ incGross :: Double
|
||||||
|
@ -232,6 +248,7 @@ data Income = Income
|
||||||
, incFrom :: TaggedAcnt
|
, incFrom :: TaggedAcnt
|
||||||
, incToBal :: TaggedAcnt
|
, incToBal :: TaggedAcnt
|
||||||
, incPayPeriod :: !Period
|
, incPayPeriod :: !Period
|
||||||
|
, incPriority :: !Int
|
||||||
}
|
}
|
||||||
|
|
||||||
deriving instance Hashable HourlyPeriod
|
deriving instance Hashable HourlyPeriod
|
||||||
|
@ -250,20 +267,13 @@ deriving instance (FromDhall v, FromDhall w) => FromDhall (Amount w v)
|
||||||
|
|
||||||
deriving instance (Hashable v, Hashable w) => Hashable (Amount w v)
|
deriving instance (Hashable v, Hashable w) => Hashable (Amount w v)
|
||||||
|
|
||||||
-- deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Amount w v)
|
|
||||||
|
|
||||||
deriving instance (Show w, Show v) => Show (Amount w v)
|
deriving instance (Show w, Show v) => Show (Amount w v)
|
||||||
|
|
||||||
deriving instance (Eq w, Eq v) => Eq (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
|
data Allocation w v = Allocation
|
||||||
{ alloTo :: TaggedAcnt
|
{ alloTo :: TaggedAcnt
|
||||||
, alloAmts :: [Amount w v]
|
, alloAmts :: [Amount w v]
|
||||||
, alloCur :: CurID
|
|
||||||
}
|
}
|
||||||
deriving (Eq, Show, Generic, Hashable)
|
deriving (Eq, Show, Generic, Hashable)
|
||||||
|
|
||||||
|
@ -340,6 +350,10 @@ instance Ord DateMatcher where
|
||||||
|
|
||||||
deriving instance Hashable EntryNumGetter
|
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
|
-- top level type with fixed account tree to unroll the recursion in the dhall
|
||||||
-- account tree type
|
-- account tree type
|
||||||
|
@ -362,7 +376,7 @@ data AccountRoot_ a = AccountRoot_
|
||||||
, arIncome :: ![a]
|
, arIncome :: ![a]
|
||||||
, arLiabilities :: ![a]
|
, arLiabilities :: ![a]
|
||||||
}
|
}
|
||||||
deriving (Generic)
|
deriving (Generic, Hashable)
|
||||||
|
|
||||||
type AccountRootF = AccountRoot_ (Fix AccountTreeF)
|
type AccountRootF = AccountRoot_ (Fix AccountTreeF)
|
||||||
|
|
||||||
|
@ -371,10 +385,8 @@ deriving instance FromDhall AccountRootF
|
||||||
type AccountRoot = AccountRoot_ AccountTree
|
type AccountRoot = AccountRoot_ AccountTree
|
||||||
|
|
||||||
data Config_ a = Config_
|
data Config_ a = Config_
|
||||||
{ global :: !TemporalScope
|
{ scope :: !TemporalScope
|
||||||
, budget :: ![Budget]
|
|
||||||
, currencies :: ![Currency]
|
, currencies :: ![Currency]
|
||||||
, statements :: ![History]
|
|
||||||
, accounts :: !a
|
, accounts :: !a
|
||||||
, tags :: ![Tag]
|
, tags :: ![Tag]
|
||||||
, sqlConfig :: !SqlConfig
|
, sqlConfig :: !SqlConfig
|
||||||
|
@ -404,55 +416,44 @@ instance FromDhall a => FromDhall (Config_ a)
|
||||||
-- dhall type overrides (since dhall can't import types with parameters...yet)
|
-- dhall type overrides (since dhall can't import types with parameters...yet)
|
||||||
|
|
||||||
-- TODO newtypes for these?
|
-- 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
|
newtype TagID = TagID {unTagID :: T.Text}
|
||||||
|
deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
|
||||||
type HistTransfer = Transfer AcntID CurID DatePat Double
|
|
||||||
|
|
||||||
deriving instance Generic HistTransfer
|
|
||||||
|
|
||||||
deriving instance Hashable HistTransfer
|
|
||||||
|
|
||||||
deriving instance FromDhall HistTransfer
|
|
||||||
|
|
||||||
data History
|
data History
|
||||||
= HistTransfer !HistTransfer
|
= HistTransfer !PairedTransfer
|
||||||
| HistStatement !Statement
|
| HistStatement !Statement
|
||||||
deriving (Eq, Generic, Hashable, FromDhall)
|
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
|
deriving instance Generic (Entry a v t)
|
||||||
{ txDescr :: !T.Text
|
|
||||||
, txDate :: !Day
|
|
||||||
, txEntries :: ![s]
|
|
||||||
}
|
|
||||||
deriving (Generic)
|
|
||||||
|
|
||||||
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
|
deriving instance Eq a => Eq (TxOpts a)
|
||||||
{ toDate :: !T.Text
|
|
||||||
, toAmount :: !T.Text
|
deriving instance Generic (TxOpts a)
|
||||||
, toDesc :: !T.Text
|
|
||||||
, toOther :: ![T.Text]
|
deriving instance Hashable a => Hashable (TxOpts a)
|
||||||
, toDateFmt :: !T.Text
|
|
||||||
, toAmountFmt :: !re
|
deriving instance FromDhall a => FromDhall (TxOpts a)
|
||||||
}
|
|
||||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
deriving instance Show a => Show (TxOpts a)
|
||||||
|
|
||||||
data Statement = Statement
|
data Statement = Statement
|
||||||
{ stmtPaths :: ![FilePath]
|
{ stmtPaths :: ![FilePath]
|
||||||
|
@ -461,7 +462,7 @@ data Statement = Statement
|
||||||
, stmtTxOpts :: !(TxOpts T.Text)
|
, stmtTxOpts :: !(TxOpts T.Text)
|
||||||
, stmtSkipLines :: !Natural
|
, stmtSkipLines :: !Natural
|
||||||
}
|
}
|
||||||
deriving (Eq, Hashable, Generic, FromDhall)
|
deriving (Eq, Hashable, Generic, FromDhall, Show)
|
||||||
|
|
||||||
-- | the value of a field in entry (text version)
|
-- | the value of a field in entry (text version)
|
||||||
-- can either be a raw (constant) value, a lookup from the record, or a map
|
-- can either be a raw (constant) value, a lookup from the record, or a map
|
||||||
|
@ -471,7 +472,7 @@ data EntryTextGetter t
|
||||||
| LookupT !T.Text
|
| LookupT !T.Text
|
||||||
| MapT !(FieldMap T.Text t)
|
| MapT !(FieldMap T.Text t)
|
||||||
| Map2T !(FieldMap (T.Text, 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
|
type EntryCur = EntryTextGetter CurID
|
||||||
|
|
||||||
|
@ -503,10 +504,32 @@ data FieldMatcher re
|
||||||
|
|
||||||
deriving instance Show (FieldMatcher T.Text)
|
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
|
data TxGetter = TxGetter
|
||||||
{ tgCurrency :: !EntryCur
|
{ tgFrom :: !(TxHalfGetter FromEntryGetter)
|
||||||
, tgAcnt :: !EntryAcnt
|
, tgTo :: !(TxHalfGetter ToEntryGetter)
|
||||||
, tgEntries :: ![EntryGetter]
|
, tgCurrency :: !EntryCur
|
||||||
|
, tgOtherEntries :: ![TxSubGetter]
|
||||||
|
, tgScale :: !Double
|
||||||
}
|
}
|
||||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,3 @@
|
||||||
{-# LANGUAGE DeriveAnyClass #-}
|
|
||||||
{-# LANGUAGE DerivingVia #-}
|
{-# LANGUAGE DerivingVia #-}
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
|
||||||
|
@ -12,11 +11,11 @@ module Internal.Types.Main
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
|
import Data.Decimal
|
||||||
import Database.Persist.Sql hiding (Desc, In, Statement)
|
import Database.Persist.Sql hiding (Desc, In, Statement)
|
||||||
import Dhall hiding (embed, maybe)
|
import Dhall hiding (embed, maybe)
|
||||||
import Internal.Types.Database
|
import Internal.Types.Database
|
||||||
import Internal.Types.Dhall
|
import Internal.Types.Dhall
|
||||||
import Language.Haskell.TH.Syntax (Lift)
|
|
||||||
import RIO
|
import RIO
|
||||||
import qualified RIO.Map as M
|
import qualified RIO.Map as M
|
||||||
import qualified RIO.NonEmpty as NE
|
import qualified RIO.NonEmpty as NE
|
||||||
|
@ -27,99 +26,139 @@ import Text.Regex.TDFA
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- database cache types
|
-- database cache types
|
||||||
|
|
||||||
data ConfigHashes = ConfigHashes
|
type MonadFinance = MonadReader ConfigState
|
||||||
{ chIncome :: ![Int]
|
|
||||||
, chExpense :: ![Int]
|
data DeleteTxs = DeleteTxs
|
||||||
, chManual :: ![Int]
|
{ dtTxs :: ![TransactionRId]
|
||||||
, chImport :: ![Int]
|
, dtEntrySets :: ![EntrySetRId]
|
||||||
|
, dtEntries :: ![EntryRId]
|
||||||
|
, dtTagRelations :: ![TagRelationRId]
|
||||||
|
}
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
|
type CDOps c d = CRUDOps [c] () () [d]
|
||||||
|
|
||||||
|
-- TODO split the entry stuff from the account metadata stuff
|
||||||
|
data ConfigState = ConfigState
|
||||||
|
{ csCurrencies :: !(CDOps (Entity CurrencyR) CurrencyRId)
|
||||||
|
, csAccounts :: !(CDOps (Entity AccountR) AccountRId)
|
||||||
|
, csPaths :: !(CDOps (Entity AccountPathR) AccountPathRId)
|
||||||
|
, csTags :: !(CDOps (Entity TagR) TagRId)
|
||||||
|
, csBudgets :: !(CRUDOps [Budget] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs)
|
||||||
|
, csHistTrans :: !(CRUDOps [PairedTransfer] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs)
|
||||||
|
, csHistStmts :: !(CRUDOps [Statement] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs)
|
||||||
|
, csAccountMap :: !AccountMap
|
||||||
|
, csCurrencyMap :: !CurrencyMap
|
||||||
|
, csTagMap :: !TagMap
|
||||||
|
, csBudgetScope :: !BudgetSpan
|
||||||
|
, csHistoryScope :: !HistorySpan
|
||||||
|
}
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
|
data ExistingConfig = ExistingConfig
|
||||||
|
{ ecAccounts :: !(Set AccountRId)
|
||||||
|
, ecTags :: !(Set TagRId)
|
||||||
|
, ecCurrencies :: !(Set CurrencyRId)
|
||||||
}
|
}
|
||||||
|
|
||||||
type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
|
type AccountMap = M.Map AcntID (AccountRId, AcntType)
|
||||||
|
|
||||||
type CurrencyMap = M.Map CurID (CurrencyRId, Natural)
|
data CurrencyPrec = CurrencyPrec {cpID :: !CurrencyRId, cpPrec :: !Precision}
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
|
type CurrencyMap = M.Map CurID CurrencyPrec
|
||||||
|
|
||||||
type TagMap = M.Map TagID TagRId
|
type TagMap = M.Map TagID TagRId
|
||||||
|
|
||||||
data DBState = DBState
|
data CRUDOps c r u d = CRUDOps
|
||||||
{ kmCurrency :: !CurrencyMap
|
{ coCreate :: !c
|
||||||
, kmAccount :: !AccountMap
|
, coRead :: !r
|
||||||
, kmTag :: !TagMap
|
, coUpdate :: !u
|
||||||
, kmBudgetInterval :: !DaySpan
|
, coDelete :: !d
|
||||||
, kmStatementInterval :: !DaySpan
|
|
||||||
, kmNewCommits :: ![Int]
|
|
||||||
}
|
}
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
data DBUpdates = DBUpdates
|
data CachedEntry
|
||||||
{ duOldCommits :: ![Int]
|
= CachedLink EntryIndex LinkScale
|
||||||
, duNewTagIds :: ![Entity TagR]
|
| CachedBalance Decimal
|
||||||
, duNewAcntPaths :: ![AccountPathR]
|
| CachedPercent Double
|
||||||
, duNewAcntIds :: ![Entity AccountR]
|
|
||||||
, duNewCurrencyIds :: ![Entity CurrencyR]
|
data ReadEntry = ReadEntry
|
||||||
|
{ reCurrency :: !CurrencyRId
|
||||||
|
, reAcnt :: !AccountRId
|
||||||
|
, reValue :: !Decimal
|
||||||
|
, reDate :: !Day
|
||||||
|
, rePriority :: !Int
|
||||||
|
, reBudget :: !BudgetName
|
||||||
}
|
}
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
type CurrencyM = Reader CurrencyMap
|
data UpdateEntry i v = UpdateEntry
|
||||||
|
{ ueID :: !i
|
||||||
|
, ueAcnt :: !AccountRId
|
||||||
|
, ueValue :: !v
|
||||||
|
, ueIndex :: !EntryIndex
|
||||||
|
}
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
type KeyEntry = Entry AccountRId Rational CurrencyRId TagRId
|
deriving instance Functor (UpdateEntry i)
|
||||||
|
|
||||||
type KeyTx = Tx KeyEntry
|
newtype LinkScale = LinkScale {unLinkScale :: Double}
|
||||||
|
deriving newtype (Num, Show, Eq, Ord, Real, Fractional)
|
||||||
|
|
||||||
type TreeR = Tree ([T.Text], AccountRId)
|
newtype StaticValue = StaticValue {unStaticValue :: Decimal}
|
||||||
|
deriving newtype (Num, Show)
|
||||||
|
|
||||||
type MonadFinance = MonadReader DBState
|
data EntryValueUnk = EVBalance Decimal | EVPercent Double deriving (Show)
|
||||||
|
|
||||||
askDBState :: MonadFinance m => (DBState -> a) -> m a
|
type UEUnk = UpdateEntry EntryRId EntryValueUnk
|
||||||
askDBState = asks
|
|
||||||
|
type UELink = UpdateEntry EntryRId LinkScale
|
||||||
|
|
||||||
|
type UEBlank = UpdateEntry EntryRId ()
|
||||||
|
|
||||||
|
type UE_RO = UpdateEntry () StaticValue
|
||||||
|
|
||||||
|
type UEBalanced = UpdateEntry EntryRId StaticValue
|
||||||
|
|
||||||
|
data UpdateEntrySet f t = UpdateEntrySet
|
||||||
|
{ utFrom0 :: !f
|
||||||
|
, utTo0 :: !UEBlank
|
||||||
|
, utFromUnk :: ![(UEUnk, [UELink])]
|
||||||
|
, utToUnk :: ![UEUnk]
|
||||||
|
, utFromRO :: ![UE_RO]
|
||||||
|
, utToRO :: ![UE_RO]
|
||||||
|
, utCurrency :: !CurrencyRId
|
||||||
|
, utDate :: !Day
|
||||||
|
, utTotalValue :: !t
|
||||||
|
, utBudget :: !BudgetName
|
||||||
|
, utPriority :: !Int
|
||||||
|
}
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
|
type TotalUpdateEntrySet = UpdateEntrySet (UEBlank, [UELink]) Decimal
|
||||||
|
|
||||||
|
type FullUpdateEntrySet = UpdateEntrySet (Either UE_RO (UEUnk, [UELink])) ()
|
||||||
|
|
||||||
|
data EntryCRU
|
||||||
|
= ToUpdate (Either TotalUpdateEntrySet FullUpdateEntrySet)
|
||||||
|
| ToRead ReadEntry
|
||||||
|
| ToInsert (Tx CommitR)
|
||||||
|
|
||||||
-------------------------------------------------------------------------------
|
-------------------------------------------------------------------------------
|
||||||
-- misc
|
-- 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
|
data TxRecord = TxRecord
|
||||||
{ trDate :: !Day
|
{ trDate :: !Day
|
||||||
, trAmount :: !Rational
|
, trAmount :: !Decimal
|
||||||
, trDesc :: !T.Text
|
, trDesc :: !TxDesc
|
||||||
, trOther :: !(M.Map T.Text T.Text)
|
, trOther :: !(M.Map T.Text T.Text)
|
||||||
, trFile :: !FilePath
|
, trFile :: !FilePath
|
||||||
}
|
}
|
||||||
deriving (Show, Eq, Ord)
|
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 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 :: AcntType -> AcntSign
|
||||||
accountSign AssetT = Debit
|
accountSign AssetT = Debit
|
||||||
accountSign ExpenseT = Debit
|
accountSign ExpenseT = Debit
|
||||||
|
@ -127,21 +166,81 @@ accountSign IncomeT = Credit
|
||||||
accountSign LiabilityT = Credit
|
accountSign LiabilityT = Credit
|
||||||
accountSign EquityT = 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 Tx k = Tx
|
||||||
|
{ txDescr :: !TxDesc
|
||||||
|
, txDate :: !Day
|
||||||
|
, txPriority :: !Int
|
||||||
|
, txPrimary :: !(Either PrimaryEntrySet TransferEntrySet)
|
||||||
|
, txOther :: ![Either SecondayEntrySet ShadowEntrySet]
|
||||||
|
, txCommit :: !k
|
||||||
|
, txBudget :: !BudgetName
|
||||||
|
}
|
||||||
|
deriving (Generic, Show)
|
||||||
|
|
||||||
|
data InsertEntry = InsertEntry
|
||||||
|
{ ieCached :: !(Maybe CachedEntry)
|
||||||
|
, ieEntry :: !(Entry AccountRId Decimal TagRId)
|
||||||
|
}
|
||||||
|
|
||||||
|
data InsertEntrySet = InsertEntrySet
|
||||||
|
{ iesCurrency :: !CurrencyRId
|
||||||
|
, iesFromEntries :: !(NonEmpty InsertEntry)
|
||||||
|
, iesToEntries :: !(NonEmpty InsertEntry)
|
||||||
|
}
|
||||||
|
|
||||||
|
data InsertTx = InsertTx
|
||||||
|
{ itxDescr :: !TxDesc
|
||||||
|
, itxDate :: !Day
|
||||||
|
, itxPriority :: !Int
|
||||||
|
, itxEntrySets :: !(NonEmpty InsertEntrySet)
|
||||||
|
, itxCommit :: !CommitR
|
||||||
|
, itxBudget :: !BudgetName
|
||||||
|
}
|
||||||
|
deriving (Generic)
|
||||||
|
|
||||||
|
data EntryValue_ a = EntryValue_ TransferType a
|
||||||
|
deriving (Show, Functor, Foldable, Traversable)
|
||||||
|
|
||||||
|
data EntryValue = EntryFixed Decimal | EntryPercent Double | EntryBalance Decimal
|
||||||
|
deriving (Show, Eq, Ord)
|
||||||
|
|
||||||
|
data EntryLink = LinkValue EntryValue | LinkIndex LinkedNumGetter
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
data MatchRes a = MatchPass !a | MatchFail | MatchSkip
|
data MatchRes a = MatchPass !a | MatchFail | MatchSkip
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- exception types
|
-- exception types
|
||||||
|
|
||||||
data BalanceType = TooFewEntries | NotOneBlank deriving (Show)
|
|
||||||
|
|
||||||
data MatchType = MatchNumeric | MatchText deriving (Show)
|
data MatchType = MatchNumeric | MatchText deriving (Show)
|
||||||
|
|
||||||
data EntryIDType = AcntField | CurField | TagField deriving (Show)
|
data EntryIDType = AcntField | CurField | TagField deriving (Show)
|
||||||
|
@ -153,48 +252,49 @@ data LookupSuberr
|
||||||
| DBKey !EntryIDType
|
| DBKey !EntryIDType
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
data AllocationSuberr
|
|
||||||
= NoAllocations
|
|
||||||
| ExceededTotal
|
|
||||||
| MissingBlank
|
|
||||||
| TooManyBlanks
|
|
||||||
deriving (Show)
|
|
||||||
|
|
||||||
data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show)
|
data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show)
|
||||||
|
|
||||||
data InsertError
|
data DBLinkSubError
|
||||||
|
= DBLinkNoScale
|
||||||
|
| DBLinkNoValue
|
||||||
|
| DBLinkInvalidValue !Rational !Bool
|
||||||
|
| DBLinkInvalidBalance
|
||||||
|
| DBLinkInvalidPercent
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
|
data DBSubError
|
||||||
|
= DBShouldBeEmpty
|
||||||
|
| DBMultiScope
|
||||||
|
| DBUpdateUnbalanced
|
||||||
|
| DBLinkError !EntryRId !DBLinkSubError
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
|
data AppError
|
||||||
= RegexError !T.Text
|
= RegexError !T.Text
|
||||||
| MatchValPrecisionError !Natural !Natural
|
| MatchValPrecisionError !Natural !Natural
|
||||||
| AccountError !AcntID !(NE.NonEmpty AcntType)
|
| AccountTypeError !AcntID !(NE.NonEmpty AcntType)
|
||||||
| InsertIOError !T.Text
|
| StatementIOError !T.Text
|
||||||
| ParseError !T.Text
|
| ParseError !T.Text
|
||||||
| ConversionError !T.Text
|
| ConversionError !T.Text !Bool
|
||||||
| LookupError !LookupSuberr !T.Text
|
| LookupError !LookupSuberr !T.Text
|
||||||
| BalanceError !BalanceType !CurID ![RawEntry]
|
| DatePatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
|
||||||
| IncomeError !Day !T.Text !Rational
|
|
||||||
| PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
|
|
||||||
| DaySpanError !Gregorian !(Maybe Gregorian)
|
| DaySpanError !Gregorian !(Maybe Gregorian)
|
||||||
| StatementError ![TxRecord] ![MatchRe]
|
| StatementError ![TxRecord] ![MatchRe]
|
||||||
| PeriodError !Day !Day
|
| PeriodError !Day !Day
|
||||||
|
| LinkError !EntryIndex !EntryIndex
|
||||||
|
| DBError !DBSubError
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
newtype InsertException = InsertException [InsertError]
|
newtype AppException = AppException [AppError]
|
||||||
deriving (Show, Semigroup) via [InsertError]
|
deriving (Show, Semigroup) via [AppError]
|
||||||
|
|
||||||
instance Exception InsertException
|
instance Exception AppException
|
||||||
|
|
||||||
type MonadInsertError = MonadError InsertException
|
type MonadAppError = MonadError AppException
|
||||||
|
|
||||||
type InsertExceptT = ExceptT InsertException
|
type AppExceptT = ExceptT AppException
|
||||||
|
|
||||||
type InsertExcept = InsertExceptT Identity
|
type AppExcept = AppExceptT Identity
|
||||||
|
|
||||||
data XGregorian = XGregorian
|
|
||||||
{ xgYear :: !Int
|
|
||||||
, xgMonth :: !Int
|
|
||||||
, xgDay :: !Int
|
|
||||||
, xgDayOfWeek :: !Int
|
|
||||||
}
|
|
||||||
|
|
||||||
type MatchRe = StatementParser (T.Text, Regex)
|
type MatchRe = StatementParser (T.Text, Regex)
|
||||||
|
|
||||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -87,6 +87,7 @@ dependencies:
|
||||||
- filepath
|
- filepath
|
||||||
- mtl
|
- mtl
|
||||||
- persistent-mtl >= 0.3.0.0
|
- persistent-mtl >= 0.3.0.0
|
||||||
|
- Decimal >= 0.5.2
|
||||||
|
|
||||||
library:
|
library:
|
||||||
source-dirs: lib/
|
source-dirs: lib/
|
||||||
|
|
Loading…
Reference in New Issue