From 81f09d12807df88bdd65c5560d76b13242a1eff3 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sun, 16 Jul 2023 00:10:49 -0400
Subject: [PATCH] REF use newtypes for ids and commits

---
 app/Main.hs                    |  2 +-
 lib/Internal/Budget.hs         | 22 +++++++++++---------
 lib/Internal/Database.hs       | 37 ++++++++++++----------------------
 lib/Internal/History.hs        | 14 ++++++-------
 lib/Internal/Types/Database.hs |  6 ++++--
 lib/Internal/Types/Dhall.hs    | 12 +++++++----
 lib/Internal/Types/Main.hs     | 29 --------------------------
 lib/Internal/Utils.hs          | 20 +++++++++---------
 8 files changed, 55 insertions(+), 87 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 3845f45..89dee6f 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -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 ()
diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs
index feeb26c..5f6a9dc 100644
--- a/lib/Internal/Budget.hs
+++ b/lib/Internal/Budget.hs
@@ -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]
diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index b41937f..d5af3bf 100644
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@@ -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)
 
diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs
index c3d2970..4baf99b 100644
--- a/lib/Internal/History.hs
+++ b/lib/Internal/History.hs
@@ -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
diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs
index 812363b..a6fbc2f 100644
--- a/lib/Internal/Types/Database.hs
+++ b/lib/Internal/Types/Database.hs
@@ -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)
 
diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs
index a4b6ba4..1ea0c60 100644
--- a/lib/Internal/Types/Dhall.hs
+++ b/lib/Internal/Types/Dhall.hs
@@ -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
 
diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs
index 9872ae2..2e14ab1 100644
--- a/lib/Internal/Types/Main.hs
+++ b/lib/Internal/Types/Main.hs
@@ -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
diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs
index 7d18586..ba62619 100644
--- a/lib/Internal/Utils.hs
+++ b/lib/Internal/Utils.hs
@@ -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