REF use newtypes for ids and commits
This commit is contained in:
parent
cd89597b1f
commit
81f09d1280
|
|
@ -203,7 +203,7 @@ runDumpAccountKeys c = do
|
|||
mapM_ (uncurry printPair) ks
|
||||
where
|
||||
printPair i p = do
|
||||
liftIO $ putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", i]
|
||||
liftIO $ putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", unAcntID i]
|
||||
double x = (x, x)
|
||||
|
||||
runSync :: Int -> FilePath -> [FilePath] -> [FilePath] -> IO ()
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ readBudget
|
|||
shadow <- addShadowTransfers bgtShadowTransfers txs
|
||||
return $ txs ++ shadow
|
||||
where
|
||||
c = CommitR (hash b) CTBudget
|
||||
c = CommitR (CommitHash $ hash b) CTBudget
|
||||
acntRes = mapErrors isNotIncomeAcnt alloAcnts
|
||||
intAlloRes = combineError3 pre_ tax_ post_ (,,)
|
||||
pre_ = sortAllos bgtPretax
|
||||
|
|
@ -107,10 +107,12 @@ readIncome
|
|||
let gross = realFracToDecimal (cpPrec cp) incGross
|
||||
foldDays (allocate cp gross) start days
|
||||
where
|
||||
incRes = isIncomeAcnt srcAcnt
|
||||
srcAcnt' = AcntID srcAcnt
|
||||
destAcnt' = AcntID destAcnt
|
||||
incRes = isIncomeAcnt srcAcnt'
|
||||
nonIncRes =
|
||||
mapErrors isNotIncomeAcnt $
|
||||
destAcnt
|
||||
destAcnt'
|
||||
: (alloAcnt <$> incPretax)
|
||||
++ (alloAcnt <$> incTaxes)
|
||||
++ (alloAcnt <$> incPosttax)
|
||||
|
|
@ -136,8 +138,8 @@ readIncome
|
|||
let post =
|
||||
allocatePost precision aftertaxGross $
|
||||
flatPost ++ concatMap (selectAllos day) intPost
|
||||
let src = entry0 srcAcnt "gross income" srcTags
|
||||
let dest = entry0 destAcnt "balance after deductions" destTags
|
||||
let src = entry0 srcAcnt' "gross income" (TagID <$> srcTags)
|
||||
let dest = entry0 destAcnt' "balance after deductions" (TagID <$> destTags)
|
||||
let allos = allo2Trans <$> (pre ++ tax ++ post)
|
||||
let primary =
|
||||
EntrySet
|
||||
|
|
@ -256,8 +258,8 @@ allo2Trans FlatAllocation {faValue, faTo = TaggedAcnt {taAcnt, taTags}, faDesc}
|
|||
Entry
|
||||
{ eValue = LinkDeferred (EntryFixed faValue)
|
||||
, eComment = faDesc
|
||||
, eAcnt = taAcnt
|
||||
, eTags = taTags
|
||||
, eAcnt = AcntID taAcnt
|
||||
, eTags = TagID <$> taTags
|
||||
}
|
||||
|
||||
allocatePre
|
||||
|
|
@ -347,7 +349,7 @@ fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch
|
|||
let es = entryPair stFrom stTo cur stDesc stRatio ()
|
||||
return $ if not sha then Nothing else Just es
|
||||
where
|
||||
curRes = lookupCurrencyKey stCurrency
|
||||
curRes = lookupCurrencyKey (CurID stCurrency)
|
||||
shaRes = liftExcept $ shadowMatches stMatch tx
|
||||
|
||||
shadowMatches :: TransferMatcher -> Tx CommitR -> InsertExcept Bool
|
||||
|
|
@ -369,13 +371,13 @@ shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} Tx {txPrimary, txDat
|
|||
getAcntTo = getAcnt esTo
|
||||
getAcnt f = eAcnt . hesPrimary . f
|
||||
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
|
||||
|
||||
alloAcnt :: Allocation w v -> AcntID
|
||||
alloAcnt = taAcnt . alloTo
|
||||
alloAcnt = AcntID . taAcnt . alloTo
|
||||
|
||||
type IntAllocations =
|
||||
( [DaySpanAllocation PretaxValue]
|
||||
|
|
|
|||
|
|
@ -2,7 +2,6 @@ module Internal.Database
|
|||
( runDB
|
||||
, readConfigState
|
||||
, nukeTables
|
||||
, updateHashes
|
||||
, updateDBState
|
||||
, tree2Records
|
||||
, flattenAcntRoot
|
||||
|
|
@ -179,7 +178,7 @@ makeTxCRUD
|
|||
:: (MonadInsertError m, MonadSqlQuery m, Hashable a)
|
||||
=> ExistingConfig
|
||||
-> [a]
|
||||
-> [Int]
|
||||
-> [CommitHash]
|
||||
-> Bool
|
||||
-> m
|
||||
( CRUDOps
|
||||
|
|
@ -190,7 +189,7 @@ makeTxCRUD
|
|||
)
|
||||
makeTxCRUD existing newThings curThings scopeChanged = do
|
||||
let (toDelHashes, overlap, toIns) =
|
||||
setDiffWith (\a b -> hash b == a) curThings newThings
|
||||
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
|
||||
|
|
@ -206,7 +205,7 @@ makeTxCRUD existing newThings curThings scopeChanged = do
|
|||
toDelAll <- readTxIds toDelAllHashes
|
||||
return $ CRUDOps toInsAll toRead toUpdate toDelAll
|
||||
|
||||
readTxIds :: MonadSqlQuery m => [Int] -> m DeleteTxs
|
||||
readTxIds :: MonadSqlQuery m => [CommitHash] -> m DeleteTxs
|
||||
readTxIds cs = do
|
||||
xs <- selectE $ do
|
||||
(commits :& txs :& ess :& es :& ts) <-
|
||||
|
|
@ -249,18 +248,18 @@ makeTagMap :: [Entity TagR] -> TagMap
|
|||
makeTagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
|
||||
|
||||
tag2Record :: Tag -> Entity TagR
|
||||
tag2Record t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc
|
||||
tag2Record t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR (TagID tagID) tagDesc
|
||||
|
||||
currency2Record :: Currency -> Entity CurrencyR
|
||||
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 ([Int], [Int], [Int])
|
||||
readCurrentCommits :: MonadSqlQuery m => m ([CommitHash], [CommitHash], [CommitHash])
|
||||
readCurrentCommits = do
|
||||
xs <- selectE $ do
|
||||
rs <- E.from E.table
|
||||
|
|
@ -290,14 +289,6 @@ findDelete f xs = case break f xs of
|
|||
(ys, []) -> (Nothing, ys)
|
||||
(ys, z : zs) -> (Just z, ys ++ zs)
|
||||
|
||||
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
|
||||
|
||||
dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r]
|
||||
dumpTbl = selectE $ E.from E.table
|
||||
|
||||
|
|
@ -355,7 +346,7 @@ paths2IDs =
|
|||
|
||||
-- none of these errors should fire assuming that input is sorted and unique
|
||||
trimNames :: [NonEmpty T.Text] -> [AcntID]
|
||||
trimNames = fmap (T.intercalate "_") . go []
|
||||
trimNames = fmap (AcntID . T.intercalate "_") . go []
|
||||
where
|
||||
go :: [T.Text] -> [NonEmpty T.Text] -> [[T.Text]]
|
||||
go prev = concatMap (go' prev) . groupNonEmpty
|
||||
|
|
@ -391,9 +382,6 @@ makeAcntMap =
|
|||
indexAcntRoot :: AccountRoot -> ([Entity AccountR], [Entity AccountPathR])
|
||||
indexAcntRoot = bimap concat concat . L.unzip . fmap (uncurry tree2Records) . flattenAcntRoot
|
||||
|
||||
updateHashes :: (MonadSqlQuery m) => DBUpdates -> m ()
|
||||
updateHashes DBUpdates {duOldCommits} = nukeDBHashes duOldCommits
|
||||
|
||||
updateCD
|
||||
:: ( MonadSqlQuery m
|
||||
, PersistRecordBackend a SqlBackend
|
||||
|
|
@ -425,7 +413,11 @@ updateDBState = do
|
|||
h <- asks csHistoryScope
|
||||
repsertE (E.toSqlKey 1) $ ConfigStateR h b
|
||||
|
||||
readInvalidIds :: MonadSqlQuery m => ExistingConfig -> [(Int, a)] -> m ([Int], [(Int, a)])
|
||||
readInvalidIds
|
||||
:: MonadSqlQuery m
|
||||
=> ExistingConfig
|
||||
-> [(CommitHash, a)]
|
||||
-> m ([CommitHash], [(CommitHash, a)])
|
||||
readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
|
||||
rs <- selectE $ do
|
||||
(commits :& _ :& entrysets :& entries :& tags) <-
|
||||
|
|
@ -462,7 +454,7 @@ readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
|
|||
|
||||
readUpdates
|
||||
:: (MonadInsertError m, MonadSqlQuery m)
|
||||
=> [Int]
|
||||
=> [CommitHash]
|
||||
-> m ([ReadEntry], [Either TotalUpdateEntrySet FullUpdateEntrySet])
|
||||
readUpdates hashes = do
|
||||
xs <- selectE $ do
|
||||
|
|
@ -729,9 +721,6 @@ updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. v]
|
|||
where
|
||||
v = toRational $ unStaticValue ueValue
|
||||
|
||||
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)
|
||||
|
||||
|
|
|
|||
|
|
@ -44,7 +44,7 @@ readHistTransfer ht = do
|
|||
bounds <- askDBState (unHSpan . csHistoryScope)
|
||||
expandTransfer c historyName bounds ht
|
||||
where
|
||||
c = CommitR (hash ht) CTHistoryTransfer
|
||||
c = CommitR (CommitHash $ hash ht) CTHistoryTransfer
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Statements
|
||||
|
|
@ -59,7 +59,7 @@ readHistStmt root i = do
|
|||
bounds <- askDBState (unHSpan . csHistoryScope)
|
||||
return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
|
||||
where
|
||||
c = CommitR (hash i) CTHistoryStatement
|
||||
c = CommitR (CommitHash $ hash i) CTHistoryStatement
|
||||
|
||||
-- TODO this probably won't scale well (pipes?)
|
||||
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]
|
||||
|
|
@ -405,18 +405,18 @@ resolveValue prec TxRecord {trOther, trAmount} s = case s of
|
|||
where
|
||||
go = realFracToDecimal prec
|
||||
|
||||
resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text
|
||||
resolveAcnt = resolveEntryField AcntField
|
||||
resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept AcntID
|
||||
resolveAcnt r e = AcntID <$> resolveEntryField AcntField r (unAcntID <$> e)
|
||||
|
||||
resolveCurrency :: CurrencyMap -> TxRecord -> EntryCur -> InsertExcept CurrencyPrec
|
||||
resolveCurrency m r c = do
|
||||
i <- resolveEntryField CurField r c
|
||||
case M.lookup i m of
|
||||
i <- resolveEntryField CurField r (unCurID <$> c)
|
||||
case M.lookup (CurID i) m of
|
||||
Just k -> return k
|
||||
-- TODO this should be its own error (I think)
|
||||
Nothing -> throwError $ InsertException [LookupError (EntryIDField CurField) undefined]
|
||||
|
||||
resolveEntryField :: EntryIDType -> TxRecord -> EntryAcnt -> InsertExcept T.Text
|
||||
resolveEntryField :: EntryIDType -> TxRecord -> EntryTextGetter T.Text -> InsertExcept T.Text
|
||||
resolveEntryField t TxRecord {trOther = o} s = case s of
|
||||
ConstT p -> return p
|
||||
LookupT f -> lookup_ f o
|
||||
|
|
|
|||
|
|
@ -15,12 +15,11 @@ import qualified RIO.NonEmpty as NE
|
|||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
|
||||
-- TODO use newtypes for all the different numbers so they don't get mixed up
|
||||
share
|
||||
[mkPersist sqlSettings, mkMigrate "migrateAll"]
|
||||
[persistLowerCase|
|
||||
CommitR sql=commits
|
||||
hash Int
|
||||
hash CommitHash
|
||||
type ConfigType
|
||||
UniqueCommitHash hash
|
||||
deriving Show Eq Ord
|
||||
|
|
@ -85,6 +84,9 @@ TagRelationR sql=tag_relations
|
|||
|
||||
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)
|
||||
|
||||
|
|
|
|||
|
|
@ -21,6 +21,7 @@ import qualified RIO.Map as M
|
|||
import qualified RIO.Text as T
|
||||
import Text.Regex.TDFA
|
||||
|
||||
-- TODO find a way to conventiently make TaggedAcnt use my newtypes
|
||||
makeHaskellTypesWith
|
||||
(defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False})
|
||||
[ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
|
||||
|
|
@ -231,7 +232,8 @@ deriving instance Hashable TaggedAcnt
|
|||
|
||||
deriving instance Ord TaggedAcnt
|
||||
|
||||
type CurID = T.Text
|
||||
newtype CurID = CurID {unCurID :: T.Text}
|
||||
deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
|
||||
|
||||
data Income = Income
|
||||
{ incGross :: Double
|
||||
|
|
@ -411,9 +413,11 @@ instance FromDhall a => FromDhall (Config_ a)
|
|||
-- dhall type overrides (since dhall can't import types with parameters...yet)
|
||||
|
||||
-- TODO newtypes for these?
|
||||
type AcntID = T.Text
|
||||
newtype AcntID = AcntID {unAcntID :: T.Text}
|
||||
deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
|
||||
|
||||
type TagID = T.Text
|
||||
newtype TagID = TagID {unTagID :: T.Text}
|
||||
deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
|
||||
|
||||
data History
|
||||
= HistTransfer !PairedTransfer
|
||||
|
|
@ -465,7 +469,7 @@ data EntryTextGetter t
|
|||
| LookupT !T.Text
|
||||
| MapT !(FieldMap T.Text t)
|
||||
| Map2T !(FieldMap (T.Text, T.Text) t)
|
||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||
deriving (Eq, Generic, Hashable, Show, FromDhall, Functor)
|
||||
|
||||
type EntryCur = EntryTextGetter CurID
|
||||
|
||||
|
|
|
|||
|
|
@ -82,35 +82,6 @@ data CRUDOps c r u d = CRUDOps
|
|||
}
|
||||
deriving (Show)
|
||||
|
||||
data DBState_ = DBState_
|
||||
{ dbsCurrencyMap :: !CurrencyMap
|
||||
, dbsAccountMap :: !AccountMap
|
||||
, dbsTagMap :: !TagMap
|
||||
, dbsBudgetInterval :: !DaySpan
|
||||
, dbsHistoryInterval :: !DaySpan
|
||||
, dbsNewCommits :: ![Int]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data DBState = DBState
|
||||
{ kmCurrency :: !CurrencyMap
|
||||
, kmAccount :: !AccountMap
|
||||
, kmTag :: !TagMap
|
||||
, kmBudgetInterval :: !DaySpan
|
||||
, kmStatementInterval :: !DaySpan
|
||||
, kmNewCommits :: ![Int]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data DBUpdates = DBUpdates
|
||||
{ duOldCommits :: ![Int]
|
||||
, duNewTagIds :: ![Entity TagR]
|
||||
, duNewAcntPaths :: ![AccountPathR]
|
||||
, duNewAcntIds :: ![Entity AccountR]
|
||||
, duNewCurrencyIds :: ![Entity CurrencyR]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data DBDeferred
|
||||
= DBEntryLinked Natural Double
|
||||
| DBEntryBalance Decimal
|
||||
|
|
|
|||
|
|
@ -432,7 +432,7 @@ showError other = case other of
|
|||
(AccountError a ts) ->
|
||||
[ T.unwords
|
||||
[ "account type of key"
|
||||
, singleQuote a
|
||||
, singleQuote $ unAcntID a
|
||||
, "is not one of:"
|
||||
, ts_
|
||||
]
|
||||
|
|
@ -496,7 +496,7 @@ showError other = case other of
|
|||
[ "No credit entry for index"
|
||||
, singleQuote $ tshow lngIndex
|
||||
, "for entry with account"
|
||||
, singleQuote eAcnt
|
||||
, singleQuote $ unAcntID eAcnt
|
||||
, "on"
|
||||
, tshow day
|
||||
]
|
||||
|
|
@ -504,7 +504,7 @@ showError other = case other of
|
|||
(RoundError cur) ->
|
||||
[ T.unwords
|
||||
[ "Could not look up precision for currency"
|
||||
, singleQuote cur
|
||||
, singleQuote $ unCurID cur
|
||||
]
|
||||
]
|
||||
|
||||
|
|
@ -637,20 +637,20 @@ lookupAccountType = fmap snd . lookupAccount
|
|||
lookupCurrency :: (MonadInsertError m, MonadFinance m) => CurID -> m CurrencyPrec
|
||||
lookupCurrency = lookupFinance CurField csCurrencyMap
|
||||
|
||||
lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId
|
||||
lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => CurID -> m CurrencyRId
|
||||
lookupCurrencyKey = fmap cpID . lookupCurrency
|
||||
|
||||
lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Precision
|
||||
lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => CurID -> m Precision
|
||||
lookupCurrencyPrec = fmap cpPrec . lookupCurrency
|
||||
|
||||
lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId
|
||||
lookupTag = lookupFinance TagField csTagMap
|
||||
|
||||
lookupFinance
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
:: (MonadInsertError m, MonadFinance m, Ord k, Show k)
|
||||
=> EntryIDType
|
||||
-> (ConfigState -> M.Map T.Text a)
|
||||
-> T.Text
|
||||
-> (ConfigState -> M.Map k a)
|
||||
-> k
|
||||
-> m a
|
||||
lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f
|
||||
|
||||
|
|
@ -1045,8 +1045,8 @@ entryPair (TaggedAcnt fa fts) (TaggedAcnt ta tts) curid com totval val1 =
|
|||
EntrySet
|
||||
{ esCurrency = curid
|
||||
, esTotalValue = totval
|
||||
, esFrom = halfEntry fa fts val1
|
||||
, esTo = halfEntry ta tts ()
|
||||
, esFrom = halfEntry (AcntID fa) (TagID <$> fts) val1
|
||||
, esTo = halfEntry (AcntID ta) (TagID <$> tts) ()
|
||||
}
|
||||
where
|
||||
halfEntry :: AcntID -> [TagID] -> v -> HalfEntrySet v v0
|
||||
|
|
|
|||
Loading…
Reference in New Issue