FIX update bugs
This commit is contained in:
parent
223be34145
commit
8901fd6a64
24
app/Main.hs
24
app/Main.hs
|
|
@ -8,6 +8,7 @@ import Control.Monad.IO.Rerunnable
|
|||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Data.Bitraversable
|
||||
-- import Data.Hashable
|
||||
import qualified Data.Text.IO as TI
|
||||
import qualified Database.Esqueleto.Experimental as E
|
||||
import Database.Persist.Monad
|
||||
|
|
@ -20,7 +21,7 @@ import Internal.Utils
|
|||
import Options.Applicative
|
||||
import RIO
|
||||
import RIO.FilePath
|
||||
import qualified RIO.Map as M
|
||||
-- import qualified RIO.Map as M
|
||||
import qualified RIO.Text as T
|
||||
|
||||
main :: IO ()
|
||||
|
|
@ -233,7 +234,7 @@ runSync threads c bs hs = do
|
|||
-- TODO for some mysterious reason using multithreading just for this
|
||||
-- little bit slows the program down by several seconds
|
||||
-- lift $ setNumCapabilities threads
|
||||
(liftIO . print) =<< askDBState (M.keys . csAccountMap)
|
||||
-- (liftIO . print) =<< askDBState (M.keys . csAccountMap)
|
||||
-- (liftIO . print) =<< askDBState (fmap (accountRFullpath . E.entityVal) . coCreate . csAccounts)
|
||||
(CRUDOps hSs _ _ _) <- askDBState csHistStmts
|
||||
hSs' <- mapErrorsIO (readHistStmt root) hSs
|
||||
|
|
@ -247,12 +248,19 @@ runSync threads c bs hs = do
|
|||
bTs' <- liftIOExceptT $ mapErrors readBudget bTs
|
||||
-- lift $ print $ length $ lefts bTs
|
||||
return $ concat $ hSs' ++ hTs' ++ bTs'
|
||||
-- print $ length $ kmNewCommits state
|
||||
-- print $ length $ duOldCommits updates
|
||||
-- print $ length $ duNewTagIds updates
|
||||
-- print $ length $ duNewAcntPaths updates
|
||||
-- print $ length $ duNewAcntIds updates
|
||||
-- print $ length $ duNewCurrencyIds updates
|
||||
print $ length $ coCreate $ csBudgets state
|
||||
print $ length $ coCreate $ csHistTrans state
|
||||
print $ length $ coCreate $ csHistStmts state
|
||||
print $ length $ coUpdate $ csBudgets state
|
||||
print $ length $ coUpdate $ csHistTrans state
|
||||
print $ length $ coUpdate $ csHistStmts state
|
||||
print $ length $ coRead $ csBudgets state
|
||||
print $ length $ coRead $ csHistTrans state
|
||||
print $ length $ coRead $ csHistStmts state
|
||||
print $ coDelete $ csBudgets state
|
||||
print $ coDelete $ csHistTrans state
|
||||
print $ coDelete $ csHistStmts state
|
||||
-- print $ fmap hash $ coCreate $ csHistStmts state
|
||||
|
||||
-- Update the DB.
|
||||
runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ readBudget
|
|||
++ (alloAcnt <$> bgtTax)
|
||||
++ (alloAcnt <$> bgtPosttax)
|
||||
getSpan = do
|
||||
globalSpan <- askDBState csBudgetScope
|
||||
globalSpan <- askDBState (unBSpan . csBudgetScope)
|
||||
case bgtInterval of
|
||||
Nothing -> return $ Just globalSpan
|
||||
Just bi -> do
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@ import Control.Monad.Except
|
|||
import Control.Monad.Logger
|
||||
import Data.Decimal
|
||||
import Data.Hashable
|
||||
import Database.Esqueleto.Experimental ((:&) (..), (==.), (^.))
|
||||
import Database.Esqueleto.Experimental ((:&) (..), (==.), (?.), (^.))
|
||||
import qualified Database.Esqueleto.Experimental as E
|
||||
import Database.Esqueleto.Internal.Internal (SqlSelect)
|
||||
import Database.Persist.Monad
|
||||
|
|
@ -42,11 +42,10 @@ import GHC.Err
|
|||
import Internal.Types.Main
|
||||
import Internal.Utils
|
||||
import RIO hiding (LogFunc, isNothing, on, (^.))
|
||||
import qualified RIO.HashSet as HS
|
||||
import qualified RIO.List as L
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.NonEmpty as NE
|
||||
-- import qualified RIO.Set as S
|
||||
import qualified RIO.Set as S
|
||||
import qualified RIO.Text as T
|
||||
|
||||
runDB
|
||||
|
|
@ -126,67 +125,66 @@ readConfigState
|
|||
-> [History]
|
||||
-> m ConfigState
|
||||
readConfigState c bs hs = do
|
||||
curAcnts <- readCurrentIds AccountRId
|
||||
curTags <- readCurrentIds TagRId
|
||||
curCurs <- readCurrentIds CurrencyRId
|
||||
curPaths <- readCurrentIds AccountPathRId
|
||||
let (acnts2Ins, acntsRem, acnts2Del) = diff newAcnts curAcnts
|
||||
let (pathsIns, _, pathsDel) = diff newPaths curPaths
|
||||
let (curs2Ins, cursRem, curs2Del) = diff newCurs curCurs
|
||||
let (tags2Ins, tagsRem, tags2Del) = diff newTags curTags
|
||||
(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 = HS.fromList . fmap (fromIntegral . E.fromSqlKey . f) . M.elems
|
||||
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
|
||||
(bChanged, hChanged) <- readScopeChanged $ scope c
|
||||
bgt <- makeTxCRUD existing bs curBgts bChanged
|
||||
hTrans <- makeTxCRUD existing ts curHistTrs hChanged
|
||||
hStmt <- makeTxCRUD existing ss curHistSts hChanged
|
||||
-- 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
|
||||
|
||||
let bsRes = resolveScope budgetInterval
|
||||
let hsRes = resolveScope statementInterval
|
||||
combineError bsRes hsRes $ \b h ->
|
||||
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 = b
|
||||
, csHistoryScope = h
|
||||
}
|
||||
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 :: Eq (Key a) => [Entity a] -> [Key a] -> ([Entity a], [(Entity a, Key a)], [Key a])
|
||||
diff = setDiffWith (\a b -> E.entityKey a == b)
|
||||
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 :: (MonadInsertError m, MonadSqlQuery m) => TemporalScope -> m (Bool, Bool)
|
||||
readScopeChanged s = do
|
||||
readScopeChanged
|
||||
:: (MonadInsertError m, MonadSqlQuery m)
|
||||
=> Bool
|
||||
-> BudgetSpan
|
||||
-> HistorySpan
|
||||
-> m (Bool, Bool)
|
||||
readScopeChanged dbempty bscope hscope = do
|
||||
rs <- dumpTbl
|
||||
case rs of
|
||||
[] -> return (True, True)
|
||||
[] -> if dbempty then return (True, True) else throwError undefined
|
||||
[r] -> do
|
||||
let (ConfigStateR hsh bsh) = E.entityVal r
|
||||
return
|
||||
( hashScope budgetInterval == bsh
|
||||
, hashScope statementInterval == hsh
|
||||
)
|
||||
let (ConfigStateR h b) = E.entityVal r
|
||||
return (bscope /= b, hscope /= h)
|
||||
_ -> throwError undefined
|
||||
where
|
||||
hashScope f = hash $ f s
|
||||
|
||||
makeTxCRUD
|
||||
:: (MonadInsertError m, MonadSqlQuery m, Hashable a)
|
||||
|
|
@ -202,13 +200,13 @@ makeTxCRUD
|
|||
DeleteTxs
|
||||
)
|
||||
makeTxCRUD existing newThings curThings scopeChanged = do
|
||||
let (toDelHashes, overlap, toIns) = setDiffWith go curThings newThings
|
||||
let (toDelHashes, overlap, toIns) =
|
||||
setDiffWith (\a b -> hash b == 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
|
||||
(toInsRetry, noRetry) <- readInvalidIds existing overlap
|
||||
let toDelAllHashes = toDelHashes ++ (fst <$> toInsRetry)
|
||||
let toInsAll = (snd <$> toInsRetry) ++ toIns
|
||||
(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
|
||||
|
|
@ -218,8 +216,6 @@ makeTxCRUD existing newThings curThings scopeChanged = do
|
|||
_ -> readUpdates noRetry
|
||||
toDelAll <- readTxIds toDelAllHashes
|
||||
return $ CRUDOps toInsAll toRead toUpdate toDelAll
|
||||
where
|
||||
go a b = hash b == a
|
||||
|
||||
readTxIds :: MonadSqlQuery m => [Int] -> m DeleteTxs
|
||||
readTxIds cs = do
|
||||
|
|
@ -270,10 +266,10 @@ currency2Record :: Currency -> Entity CurrencyR
|
|||
currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
|
||||
Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision)
|
||||
|
||||
readCurrentIds :: PersistEntity a => MonadSqlQuery m => EntityField a (Key a) -> m [Key a]
|
||||
readCurrentIds f = fmap (E.unValue <$>) $ selectE $ do
|
||||
readCurrentIds :: PersistEntity a => MonadSqlQuery m => m [Key a]
|
||||
readCurrentIds = fmap (E.unValue <$>) $ selectE $ do
|
||||
rs <- E.from E.table
|
||||
return (rs ^. f)
|
||||
return (rs ^. E.persistIdField)
|
||||
|
||||
readCurrentCommits :: MonadSqlQuery m => m ([Int], [Int], [Int])
|
||||
readCurrentCommits = do
|
||||
|
|
@ -286,8 +282,8 @@ readCurrentCommits = do
|
|||
let y = E.unValue x
|
||||
in case E.unValue t of
|
||||
CTBudget -> (y : bs, ts, hs)
|
||||
CTTransfer -> (bs, y : ts, hs)
|
||||
CTHistory -> (bs, ts, y : hs)
|
||||
CTHistoryTransfer -> (bs, y : ts, hs)
|
||||
CTHistoryStatement -> (bs, ts, y : hs)
|
||||
|
||||
-- hashConfig :: [Budget] -> [History] -> [Int]
|
||||
-- hashConfig bs hs = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
|
||||
|
|
@ -311,13 +307,16 @@ setDiffWith f = go [] []
|
|||
where
|
||||
go inA inBoth [] bs = (inA, inBoth, bs)
|
||||
go inA inBoth as [] = (as ++ inA, inBoth, [])
|
||||
go inA inBoth (a : as) bs = case inB a bs of
|
||||
Just (b, bs') -> go inA ((a, b) : inBoth) as bs'
|
||||
Nothing -> go (a : inA) inBoth as bs
|
||||
inB _ [] = Nothing
|
||||
inB a (b : bs)
|
||||
| f a b = Just (b, bs)
|
||||
| otherwise = inB a bs
|
||||
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)
|
||||
|
||||
-- getDBHashes :: MonadSqlQuery m => m [Int]
|
||||
-- getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
|
||||
|
|
@ -594,23 +593,24 @@ updateDBState = do
|
|||
deleteTxs =<< asks (coDelete . csBudgets)
|
||||
deleteTxs =<< asks (coDelete . csHistTrans)
|
||||
deleteTxs =<< asks (coDelete . csHistStmts)
|
||||
|
||||
-- updateHashes u
|
||||
-- updateTags u
|
||||
-- updateAccounts u
|
||||
-- updateCurrencies u
|
||||
b <- asks csBudgetScope
|
||||
h <- asks csHistoryScope
|
||||
repsertE (E.toSqlKey 1) $ ConfigStateR h b
|
||||
|
||||
deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m ()
|
||||
deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)
|
||||
|
||||
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 q = unsafeLiftSql "esqueleto-select" (E.select q)
|
||||
|
||||
deleteKeyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => Key a -> m ()
|
||||
deleteKeyE q = unsafeLiftSql "esqueleto-select" (E.deleteKey q)
|
||||
deleteKeyE q = unsafeLiftSql "esqueleto-deleteKey" (E.deleteKey q)
|
||||
|
||||
insertEntityManyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => [Entity a] -> m ()
|
||||
insertEntityManyE q = unsafeLiftSql "esqueleto-select" (E.insertEntityMany q)
|
||||
insertEntityManyE q = unsafeLiftSql "esqueleto-insertEntityMany" (E.insertEntityMany q)
|
||||
|
||||
-- whenHash
|
||||
-- :: (Hashable a, MonadFinance m, MonadSqlQuery m)
|
||||
|
|
@ -661,7 +661,7 @@ insertEntityManyE q = unsafeLiftSql "esqueleto-select" (E.insertEntityMany q)
|
|||
-- hs <- askDBState kmNewCommits
|
||||
-- if h `elem` hs then Just . (c,) <$> f else return Nothing
|
||||
|
||||
readInvalidIds :: MonadSqlQuery m => ExistingConfig -> [(Int, a)] -> m ([(Int, a)], [Int])
|
||||
readInvalidIds :: MonadSqlQuery m => ExistingConfig -> [(Int, a)] -> m ([Int], [(Int, a)])
|
||||
readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
|
||||
rs <- selectE $ do
|
||||
(commits :& _ :& entrysets :& entries :& tags) <-
|
||||
|
|
@ -673,28 +673,28 @@ readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
|
|||
`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 :& r) -> e ^. EntryRId ==. r ^. TagRelationREntry)
|
||||
`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
|
||||
, tags ?. TagRelationRTag
|
||||
)
|
||||
-- TODO there are faster ways to do this; may/may not matter
|
||||
let cs = go ecCurrencies (\(i, c, _, _) -> (i, c)) rs
|
||||
let as = go ecAccounts (\(i, _, a, _) -> (i, a)) rs
|
||||
let ts = go ecTags (\(i, _, _, t) -> (i, t)) rs
|
||||
let valid = (cs `HS.intersection` as) `HS.intersection` ts
|
||||
return $ second (fst <$>) $ L.partition ((`HS.member` valid) . fst) xs
|
||||
let cs = go ecCurrencies $ fmap (\(i, E.Value c, _, _) -> (i, c)) rs
|
||||
let as = go ecAccounts $ fmap (\(i, _, E.Value a, _) -> (i, a)) rs
|
||||
let ts = go ecTags [(i, t) | (i, _, _, E.Value (Just t)) <- rs]
|
||||
let valid = (cs `S.intersection` as) `S.intersection` ts
|
||||
let (a0, _) = first (fst <$>) $ L.partition ((`S.member` valid) . fst) xs
|
||||
return (a0, [])
|
||||
where
|
||||
go existing f =
|
||||
HS.fromList
|
||||
go existing =
|
||||
S.fromList
|
||||
. fmap (E.unValue . fst)
|
||||
. L.filter (all (`HS.member` existing) . fmap (fromIntegral . E.fromSqlKey . E.unValue) . snd)
|
||||
. L.filter (all (`S.member` existing) . snd)
|
||||
. groupKey id
|
||||
. fmap f
|
||||
|
||||
readUpdates
|
||||
:: (MonadInsertError m, MonadSqlQuery m)
|
||||
|
|
|
|||
|
|
@ -41,10 +41,10 @@ readHistTransfer
|
|||
=> PairedTransfer
|
||||
-> m [Tx CommitR]
|
||||
readHistTransfer ht = do
|
||||
bounds <- askDBState csHistoryScope
|
||||
bounds <- askDBState (unHSpan . csHistoryScope)
|
||||
expandTransfer c historyName bounds ht
|
||||
where
|
||||
c = CommitR (hash ht) CTTransfer
|
||||
c = CommitR (hash ht) CTHistoryTransfer
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Statements
|
||||
|
|
@ -56,10 +56,10 @@ readHistStmt
|
|||
-> m [Tx CommitR]
|
||||
readHistStmt root i = do
|
||||
bs <- readImport root i
|
||||
bounds <- askDBState csHistoryScope
|
||||
bounds <- askDBState (unHSpan . csHistoryScope)
|
||||
return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
|
||||
where
|
||||
c = CommitR (hash i) CTTransfer
|
||||
c = CommitR (hash i) CTHistoryStatement
|
||||
|
||||
-- TODO this probably won't scale well (pipes?)
|
||||
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]
|
||||
|
|
|
|||
|
|
@ -22,47 +22,54 @@ share
|
|||
CommitR sql=commits
|
||||
hash Int
|
||||
type ConfigType
|
||||
UniqueCommitHash hash
|
||||
deriving Show Eq Ord
|
||||
ConfigStateR sql=config_state
|
||||
historyScopeHash Int
|
||||
budgetScopeHash Int
|
||||
historySpan HistorySpan
|
||||
budgetSpan BudgetSpan
|
||||
deriving Show
|
||||
CurrencyR sql=currencies
|
||||
symbol CurID
|
||||
fullname T.Text
|
||||
precision Int
|
||||
deriving Show Eq
|
||||
UniqueCurrencySymbol symbol
|
||||
UniqueCurrencyFullname fullname
|
||||
deriving Show Eq Ord
|
||||
TagR sql=tags
|
||||
symbol TagID
|
||||
fullname T.Text
|
||||
deriving Show Eq
|
||||
UniqueTagSymbol symbol
|
||||
UniqueTagFullname fullname
|
||||
deriving Show Eq Ord
|
||||
AccountR sql=accounts
|
||||
name T.Text
|
||||
fullpath AcntPath
|
||||
desc T.Text
|
||||
sign AcntSign
|
||||
leaf Bool
|
||||
deriving Show Eq
|
||||
UniqueAccountFullpath fullpath
|
||||
deriving Show Eq Ord
|
||||
AccountPathR sql=account_paths
|
||||
parent AccountRId OnDeleteCascade
|
||||
child AccountRId OnDeleteCascade
|
||||
parent AccountRId
|
||||
child AccountRId
|
||||
depth Int
|
||||
deriving Show Eq
|
||||
deriving Show Eq Ord
|
||||
TransactionR sql=transactions
|
||||
commit CommitRId OnDeleteCascade
|
||||
commit CommitRId
|
||||
date Day
|
||||
description T.Text
|
||||
budgetName T.Text
|
||||
priority Int
|
||||
deriving Show Eq
|
||||
EntrySetR sql=entry_sets
|
||||
transaction TransactionRId OnDeleteCascade
|
||||
currency CurrencyRId OnDeleteCascade
|
||||
transaction TransactionRId
|
||||
currency CurrencyRId
|
||||
index Int
|
||||
rebalance Bool
|
||||
deriving Show Eq
|
||||
EntryR sql=entries
|
||||
entryset EntrySetRId OnDeleteCascade
|
||||
account AccountRId OnDeleteCascade
|
||||
entryset EntrySetRId
|
||||
account AccountRId
|
||||
memo T.Text
|
||||
value Rational
|
||||
index Int
|
||||
|
|
@ -71,12 +78,20 @@ EntryR sql=entries
|
|||
cachedLink (Maybe Int)
|
||||
deriving Show Eq
|
||||
TagRelationR sql=tag_relations
|
||||
entry EntryRId OnDeleteCascade
|
||||
tag TagRId OnDeleteCascade
|
||||
entry EntryRId
|
||||
tag TagRId
|
||||
deriving Show Eq
|
||||
|]
|
||||
|
||||
data ConfigType = CTBudget | CTTransfer | CTHistory
|
||||
type DaySpan = (Day, Int)
|
||||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -39,6 +39,7 @@ data DeleteTxs = DeleteTxs
|
|||
, dtEntries :: ![EntryRId]
|
||||
, dtTagRelations :: ![TagRelationRId]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
type CDOps c d = CRUDOps [c] () () [d]
|
||||
|
||||
|
|
@ -53,14 +54,15 @@ data ConfigState = ConfigState
|
|||
, csAccountMap :: !AccountMap
|
||||
, csCurrencyMap :: !CurrencyMap
|
||||
, csTagMap :: !TagMap
|
||||
, csBudgetScope :: !DaySpan
|
||||
, csHistoryScope :: !DaySpan
|
||||
, csBudgetScope :: !BudgetSpan
|
||||
, csHistoryScope :: !HistorySpan
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data ExistingConfig = ExistingConfig
|
||||
{ ecAccounts :: !(HashSet Int)
|
||||
, ecTags :: !(HashSet Int)
|
||||
, ecCurrencies :: !(HashSet Int)
|
||||
{ ecAccounts :: !(Set AccountRId)
|
||||
, ecTags :: !(Set TagRId)
|
||||
, ecCurrencies :: !(Set CurrencyRId)
|
||||
}
|
||||
|
||||
type AccountMap = M.Map AcntID (AccountRId, AcntType)
|
||||
|
|
@ -78,6 +80,7 @@ data CRUDOps c r u d = CRUDOps
|
|||
, coUpdate :: !u
|
||||
, coDelete :: !d
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data DBState_ = DBState_
|
||||
{ dbsCurrencyMap :: !CurrencyMap
|
||||
|
|
@ -198,8 +201,6 @@ data TxRecord = TxRecord
|
|||
}
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
type DaySpan = (Day, Natural)
|
||||
|
||||
data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show)
|
||||
|
||||
accountSign :: AcntType -> AcntSign
|
||||
|
|
|
|||
|
|
@ -151,7 +151,7 @@ askDays
|
|||
-> Maybe Interval
|
||||
-> m [Day]
|
||||
askDays dp i = do
|
||||
globalSpan <- askDBState csBudgetScope
|
||||
globalSpan <- askDBState (unBSpan . csBudgetScope)
|
||||
case i of
|
||||
Just i' -> do
|
||||
localSpan <- liftExcept $ resolveDaySpan i'
|
||||
|
|
|
|||
Loading…
Reference in New Issue