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
|
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]
|
||||||
double x = (x, x)
|
double x = (x, x)
|
||||||
|
|
||||||
runSync :: Int -> FilePath -> [FilePath] -> [FilePath] -> IO ()
|
runSync :: Int -> FilePath -> [FilePath] -> [FilePath] -> IO ()
|
||||||
|
|
|
@ -37,7 +37,7 @@ readBudget
|
||||||
shadow <- addShadowTransfers bgtShadowTransfers txs
|
shadow <- addShadowTransfers bgtShadowTransfers txs
|
||||||
return $ txs ++ shadow
|
return $ txs ++ shadow
|
||||||
where
|
where
|
||||||
c = CommitR (hash b) CTBudget
|
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
|
||||||
|
@ -107,10 +107,12 @@ readIncome
|
||||||
let gross = realFracToDecimal (cpPrec cp) incGross
|
let gross = realFracToDecimal (cpPrec cp) incGross
|
||||||
foldDays (allocate cp gross) start days
|
foldDays (allocate cp gross) start days
|
||||||
where
|
where
|
||||||
incRes = isIncomeAcnt srcAcnt
|
srcAcnt' = AcntID srcAcnt
|
||||||
|
destAcnt' = AcntID destAcnt
|
||||||
|
incRes = isIncomeAcnt srcAcnt'
|
||||||
nonIncRes =
|
nonIncRes =
|
||||||
mapErrors isNotIncomeAcnt $
|
mapErrors isNotIncomeAcnt $
|
||||||
destAcnt
|
destAcnt'
|
||||||
: (alloAcnt <$> incPretax)
|
: (alloAcnt <$> incPretax)
|
||||||
++ (alloAcnt <$> incTaxes)
|
++ (alloAcnt <$> incTaxes)
|
||||||
++ (alloAcnt <$> incPosttax)
|
++ (alloAcnt <$> incPosttax)
|
||||||
|
@ -136,8 +138,8 @@ readIncome
|
||||||
let post =
|
let post =
|
||||||
allocatePost precision aftertaxGross $
|
allocatePost precision aftertaxGross $
|
||||||
flatPost ++ concatMap (selectAllos day) intPost
|
flatPost ++ concatMap (selectAllos day) intPost
|
||||||
let src = entry0 srcAcnt "gross income" srcTags
|
let src = entry0 srcAcnt' "gross income" (TagID <$> srcTags)
|
||||||
let dest = entry0 destAcnt "balance after deductions" destTags
|
let dest = entry0 destAcnt' "balance after deductions" (TagID <$> destTags)
|
||||||
let allos = allo2Trans <$> (pre ++ tax ++ post)
|
let allos = allo2Trans <$> (pre ++ tax ++ post)
|
||||||
let primary =
|
let primary =
|
||||||
EntrySet
|
EntrySet
|
||||||
|
@ -256,8 +258,8 @@ allo2Trans FlatAllocation {faValue, faTo = TaggedAcnt {taAcnt, taTags}, faDesc}
|
||||||
Entry
|
Entry
|
||||||
{ eValue = LinkDeferred (EntryFixed faValue)
|
{ eValue = LinkDeferred (EntryFixed faValue)
|
||||||
, eComment = faDesc
|
, eComment = faDesc
|
||||||
, eAcnt = taAcnt
|
, eAcnt = AcntID taAcnt
|
||||||
, eTags = taTags
|
, eTags = TagID <$> taTags
|
||||||
}
|
}
|
||||||
|
|
||||||
allocatePre
|
allocatePre
|
||||||
|
@ -347,7 +349,7 @@ fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch
|
||||||
let es = entryPair stFrom stTo cur stDesc stRatio ()
|
let es = entryPair stFrom stTo cur stDesc stRatio ()
|
||||||
return $ if not sha then Nothing else Just es
|
return $ if not sha then Nothing else Just es
|
||||||
where
|
where
|
||||||
curRes = lookupCurrencyKey stCurrency
|
curRes = lookupCurrencyKey (CurID stCurrency)
|
||||||
shaRes = liftExcept $ shadowMatches stMatch tx
|
shaRes = liftExcept $ shadowMatches stMatch tx
|
||||||
|
|
||||||
shadowMatches :: TransferMatcher -> Tx CommitR -> InsertExcept Bool
|
shadowMatches :: TransferMatcher -> Tx CommitR -> InsertExcept Bool
|
||||||
|
@ -369,13 +371,13 @@ shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} Tx {txPrimary, txDat
|
||||||
getAcntTo = getAcnt esTo
|
getAcntTo = getAcnt esTo
|
||||||
getAcnt f = eAcnt . hesPrimary . f
|
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
|
||||||
|
|
||||||
alloAcnt :: Allocation w v -> AcntID
|
alloAcnt :: Allocation w v -> AcntID
|
||||||
alloAcnt = taAcnt . alloTo
|
alloAcnt = AcntID . taAcnt . alloTo
|
||||||
|
|
||||||
type IntAllocations =
|
type IntAllocations =
|
||||||
( [DaySpanAllocation PretaxValue]
|
( [DaySpanAllocation PretaxValue]
|
||||||
|
|
|
@ -2,7 +2,6 @@ module Internal.Database
|
||||||
( runDB
|
( runDB
|
||||||
, readConfigState
|
, readConfigState
|
||||||
, nukeTables
|
, nukeTables
|
||||||
, updateHashes
|
|
||||||
, updateDBState
|
, updateDBState
|
||||||
, tree2Records
|
, tree2Records
|
||||||
, flattenAcntRoot
|
, flattenAcntRoot
|
||||||
|
@ -179,7 +178,7 @@ makeTxCRUD
|
||||||
:: (MonadInsertError m, MonadSqlQuery m, Hashable a)
|
:: (MonadInsertError m, MonadSqlQuery m, Hashable a)
|
||||||
=> ExistingConfig
|
=> ExistingConfig
|
||||||
-> [a]
|
-> [a]
|
||||||
-> [Int]
|
-> [CommitHash]
|
||||||
-> Bool
|
-> Bool
|
||||||
-> m
|
-> m
|
||||||
( CRUDOps
|
( CRUDOps
|
||||||
|
@ -190,7 +189,7 @@ makeTxCRUD
|
||||||
)
|
)
|
||||||
makeTxCRUD existing newThings curThings scopeChanged = do
|
makeTxCRUD existing newThings curThings scopeChanged = do
|
||||||
let (toDelHashes, overlap, toIns) =
|
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
|
-- 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
|
-- won't exist on the next update. Those with invalid IDs will be set aside
|
||||||
-- to delete and reinsert (which may also fail) later
|
-- to delete and reinsert (which may also fail) later
|
||||||
|
@ -206,7 +205,7 @@ makeTxCRUD existing newThings curThings scopeChanged = do
|
||||||
toDelAll <- readTxIds toDelAllHashes
|
toDelAll <- readTxIds toDelAllHashes
|
||||||
return $ CRUDOps toInsAll toRead toUpdate toDelAll
|
return $ CRUDOps toInsAll toRead toUpdate toDelAll
|
||||||
|
|
||||||
readTxIds :: MonadSqlQuery m => [Int] -> m DeleteTxs
|
readTxIds :: MonadSqlQuery m => [CommitHash] -> m DeleteTxs
|
||||||
readTxIds cs = do
|
readTxIds cs = do
|
||||||
xs <- selectE $ do
|
xs <- selectE $ do
|
||||||
(commits :& txs :& ess :& es :& ts) <-
|
(commits :& txs :& ess :& es :& ts) <-
|
||||||
|
@ -249,18 +248,18 @@ makeTagMap :: [Entity TagR] -> TagMap
|
||||||
makeTagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
|
makeTagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
|
||||||
|
|
||||||
tag2Record :: Tag -> Entity TagR
|
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 :: 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 :: PersistEntity a => MonadSqlQuery m => m [Key a]
|
||||||
readCurrentIds = fmap (E.unValue <$>) $ selectE $ do
|
readCurrentIds = fmap (E.unValue <$>) $ selectE $ do
|
||||||
rs <- E.from E.table
|
rs <- E.from E.table
|
||||||
return (rs ^. E.persistIdField)
|
return (rs ^. E.persistIdField)
|
||||||
|
|
||||||
readCurrentCommits :: MonadSqlQuery m => m ([Int], [Int], [Int])
|
readCurrentCommits :: MonadSqlQuery m => m ([CommitHash], [CommitHash], [CommitHash])
|
||||||
readCurrentCommits = do
|
readCurrentCommits = do
|
||||||
xs <- selectE $ do
|
xs <- selectE $ do
|
||||||
rs <- E.from E.table
|
rs <- E.from E.table
|
||||||
|
@ -290,14 +289,6 @@ findDelete f xs = case break f xs of
|
||||||
(ys, []) -> (Nothing, ys)
|
(ys, []) -> (Nothing, ys)
|
||||||
(ys, z : zs) -> (Just z, ys ++ zs)
|
(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 :: (MonadSqlQuery m, PersistEntity r) => m [Entity r]
|
||||||
dumpTbl = selectE $ E.from E.table
|
dumpTbl = selectE $ E.from E.table
|
||||||
|
|
||||||
|
@ -355,7 +346,7 @@ paths2IDs =
|
||||||
|
|
||||||
-- 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 :: [NonEmpty T.Text] -> [AcntID]
|
trimNames :: [NonEmpty T.Text] -> [AcntID]
|
||||||
trimNames = fmap (T.intercalate "_") . go []
|
trimNames = fmap (AcntID . T.intercalate "_") . go []
|
||||||
where
|
where
|
||||||
go :: [T.Text] -> [NonEmpty T.Text] -> [[T.Text]]
|
go :: [T.Text] -> [NonEmpty T.Text] -> [[T.Text]]
|
||||||
go prev = concatMap (go' prev) . groupNonEmpty
|
go prev = concatMap (go' prev) . groupNonEmpty
|
||||||
|
@ -391,9 +382,6 @@ makeAcntMap =
|
||||||
indexAcntRoot :: AccountRoot -> ([Entity AccountR], [Entity AccountPathR])
|
indexAcntRoot :: AccountRoot -> ([Entity AccountR], [Entity AccountPathR])
|
||||||
indexAcntRoot = bimap concat concat . L.unzip . fmap (uncurry tree2Records) . flattenAcntRoot
|
indexAcntRoot = bimap concat concat . L.unzip . fmap (uncurry tree2Records) . flattenAcntRoot
|
||||||
|
|
||||||
updateHashes :: (MonadSqlQuery m) => DBUpdates -> m ()
|
|
||||||
updateHashes DBUpdates {duOldCommits} = nukeDBHashes duOldCommits
|
|
||||||
|
|
||||||
updateCD
|
updateCD
|
||||||
:: ( MonadSqlQuery m
|
:: ( MonadSqlQuery m
|
||||||
, PersistRecordBackend a SqlBackend
|
, PersistRecordBackend a SqlBackend
|
||||||
|
@ -425,7 +413,11 @@ updateDBState = do
|
||||||
h <- asks csHistoryScope
|
h <- asks csHistoryScope
|
||||||
repsertE (E.toSqlKey 1) $ ConfigStateR h b
|
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
|
readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
|
||||||
rs <- selectE $ do
|
rs <- selectE $ do
|
||||||
(commits :& _ :& entrysets :& entries :& tags) <-
|
(commits :& _ :& entrysets :& entries :& tags) <-
|
||||||
|
@ -462,7 +454,7 @@ readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
|
||||||
|
|
||||||
readUpdates
|
readUpdates
|
||||||
:: (MonadInsertError m, MonadSqlQuery m)
|
:: (MonadInsertError m, MonadSqlQuery m)
|
||||||
=> [Int]
|
=> [CommitHash]
|
||||||
-> m ([ReadEntry], [Either TotalUpdateEntrySet FullUpdateEntrySet])
|
-> m ([ReadEntry], [Either TotalUpdateEntrySet FullUpdateEntrySet])
|
||||||
readUpdates hashes = do
|
readUpdates hashes = do
|
||||||
xs <- selectE $ do
|
xs <- selectE $ do
|
||||||
|
@ -729,9 +721,6 @@ updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. v]
|
||||||
where
|
where
|
||||||
v = toRational $ unStaticValue ueValue
|
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 :: (MonadSqlQuery m, PersistRecordBackend r SqlBackend) => Key r -> r -> m ()
|
||||||
repsertE k r = unsafeLiftSql "esqueleto-repsert" (E.repsert k r)
|
repsertE k r = unsafeLiftSql "esqueleto-repsert" (E.repsert k r)
|
||||||
|
|
||||||
|
|
|
@ -44,7 +44,7 @@ readHistTransfer ht = do
|
||||||
bounds <- askDBState (unHSpan . csHistoryScope)
|
bounds <- askDBState (unHSpan . csHistoryScope)
|
||||||
expandTransfer c historyName bounds ht
|
expandTransfer c historyName bounds ht
|
||||||
where
|
where
|
||||||
c = CommitR (hash ht) CTHistoryTransfer
|
c = CommitR (CommitHash $ hash ht) CTHistoryTransfer
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Statements
|
-- Statements
|
||||||
|
@ -59,7 +59,7 @@ readHistStmt root i = do
|
||||||
bounds <- askDBState (unHSpan . csHistoryScope)
|
bounds <- askDBState (unHSpan . csHistoryScope)
|
||||||
return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
|
return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
|
||||||
where
|
where
|
||||||
c = CommitR (hash i) CTHistoryStatement
|
c = CommitR (CommitHash $ hash i) CTHistoryStatement
|
||||||
|
|
||||||
-- TODO this probably won't scale well (pipes?)
|
-- TODO this probably won't scale well (pipes?)
|
||||||
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]
|
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]
|
||||||
|
@ -405,18 +405,18 @@ resolveValue prec TxRecord {trOther, trAmount} s = case s of
|
||||||
where
|
where
|
||||||
go = realFracToDecimal prec
|
go = realFracToDecimal prec
|
||||||
|
|
||||||
resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text
|
resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept AcntID
|
||||||
resolveAcnt = resolveEntryField AcntField
|
resolveAcnt r e = AcntID <$> resolveEntryField AcntField r (unAcntID <$> e)
|
||||||
|
|
||||||
resolveCurrency :: CurrencyMap -> TxRecord -> EntryCur -> InsertExcept CurrencyPrec
|
resolveCurrency :: CurrencyMap -> TxRecord -> EntryCur -> InsertExcept CurrencyPrec
|
||||||
resolveCurrency m r c = do
|
resolveCurrency m r c = do
|
||||||
i <- resolveEntryField CurField r c
|
i <- resolveEntryField CurField r (unCurID <$> c)
|
||||||
case M.lookup i m of
|
case M.lookup (CurID i) m of
|
||||||
Just k -> return k
|
Just k -> return k
|
||||||
-- TODO this should be its own error (I think)
|
-- TODO this should be its own error (I think)
|
||||||
Nothing -> throwError $ InsertException [LookupError (EntryIDField CurField) undefined]
|
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
|
resolveEntryField t TxRecord {trOther = o} s = case s of
|
||||||
ConstT p -> return p
|
ConstT p -> return p
|
||||||
LookupT f -> lookup_ f o
|
LookupT f -> lookup_ f o
|
||||||
|
|
|
@ -15,12 +15,11 @@ import qualified RIO.NonEmpty as NE
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
import RIO.Time
|
import RIO.Time
|
||||||
|
|
||||||
-- TODO use newtypes for all the different numbers so they don't get mixed up
|
|
||||||
share
|
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
|
||||||
UniqueCommitHash hash
|
UniqueCommitHash hash
|
||||||
deriving Show Eq Ord
|
deriving Show Eq Ord
|
||||||
|
@ -85,6 +84,9 @@ TagRelationR sql=tag_relations
|
||||||
|
|
||||||
type DaySpan = (Day, Int)
|
type DaySpan = (Day, Int)
|
||||||
|
|
||||||
|
newtype CommitHash = CommitHash {unCommitHash :: Int}
|
||||||
|
deriving newtype (Show, Eq, Num, Ord, PersistField, PersistFieldSql)
|
||||||
|
|
||||||
newtype BudgetSpan = BudgetSpan {unBSpan :: DaySpan}
|
newtype BudgetSpan = BudgetSpan {unBSpan :: DaySpan}
|
||||||
deriving newtype (Show, Eq, PersistField, PersistFieldSql)
|
deriving newtype (Show, Eq, PersistField, PersistFieldSql)
|
||||||
|
|
||||||
|
|
|
@ -21,6 +21,7 @@ import qualified RIO.Map as M
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
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"
|
||||||
|
@ -231,7 +232,8 @@ 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
|
||||||
|
@ -411,9 +413,11 @@ 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)
|
||||||
|
|
||||||
data History
|
data History
|
||||||
= HistTransfer !PairedTransfer
|
= HistTransfer !PairedTransfer
|
||||||
|
@ -465,7 +469,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
|
||||||
|
|
||||||
|
|
|
@ -82,35 +82,6 @@ data CRUDOps c r u d = CRUDOps
|
||||||
}
|
}
|
||||||
deriving (Show)
|
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
|
data DBDeferred
|
||||||
= DBEntryLinked Natural Double
|
= DBEntryLinked Natural Double
|
||||||
| DBEntryBalance Decimal
|
| DBEntryBalance Decimal
|
||||||
|
|
|
@ -432,7 +432,7 @@ showError other = case other of
|
||||||
(AccountError a ts) ->
|
(AccountError a ts) ->
|
||||||
[ T.unwords
|
[ T.unwords
|
||||||
[ "account type of key"
|
[ "account type of key"
|
||||||
, singleQuote a
|
, singleQuote $ unAcntID a
|
||||||
, "is not one of:"
|
, "is not one of:"
|
||||||
, ts_
|
, ts_
|
||||||
]
|
]
|
||||||
|
@ -496,7 +496,7 @@ showError other = case other of
|
||||||
[ "No credit entry for index"
|
[ "No credit entry for index"
|
||||||
, singleQuote $ tshow lngIndex
|
, singleQuote $ tshow lngIndex
|
||||||
, "for entry with account"
|
, "for entry with account"
|
||||||
, singleQuote eAcnt
|
, singleQuote $ unAcntID eAcnt
|
||||||
, "on"
|
, "on"
|
||||||
, tshow day
|
, tshow day
|
||||||
]
|
]
|
||||||
|
@ -504,7 +504,7 @@ showError other = case other of
|
||||||
(RoundError cur) ->
|
(RoundError cur) ->
|
||||||
[ T.unwords
|
[ T.unwords
|
||||||
[ "Could not look up precision for currency"
|
[ "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 :: (MonadInsertError m, MonadFinance m) => CurID -> m CurrencyPrec
|
||||||
lookupCurrency = lookupFinance CurField csCurrencyMap
|
lookupCurrency = lookupFinance CurField csCurrencyMap
|
||||||
|
|
||||||
lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId
|
lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => CurID -> m CurrencyRId
|
||||||
lookupCurrencyKey = fmap cpID . lookupCurrency
|
lookupCurrencyKey = fmap cpID . lookupCurrency
|
||||||
|
|
||||||
lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Precision
|
lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => CurID -> m Precision
|
||||||
lookupCurrencyPrec = fmap cpPrec . lookupCurrency
|
lookupCurrencyPrec = fmap cpPrec . lookupCurrency
|
||||||
|
|
||||||
lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId
|
lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId
|
||||||
lookupTag = lookupFinance TagField csTagMap
|
lookupTag = lookupFinance TagField csTagMap
|
||||||
|
|
||||||
lookupFinance
|
lookupFinance
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m, Ord k, Show k)
|
||||||
=> EntryIDType
|
=> EntryIDType
|
||||||
-> (ConfigState -> M.Map T.Text a)
|
-> (ConfigState -> M.Map k a)
|
||||||
-> T.Text
|
-> k
|
||||||
-> m a
|
-> m a
|
||||||
lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f
|
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
|
EntrySet
|
||||||
{ esCurrency = curid
|
{ esCurrency = curid
|
||||||
, esTotalValue = totval
|
, esTotalValue = totval
|
||||||
, esFrom = halfEntry fa fts val1
|
, esFrom = halfEntry (AcntID fa) (TagID <$> fts) val1
|
||||||
, esTo = halfEntry ta tts ()
|
, esTo = halfEntry (AcntID ta) (TagID <$> tts) ()
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
halfEntry :: AcntID -> [TagID] -> v -> HalfEntrySet v v0
|
halfEntry :: AcntID -> [TagID] -> v -> HalfEntrySet v v0
|
||||||
|
|
Loading…
Reference in New Issue