REF delete lots of dead code

app/Main.hs

@@ -231,36 +231,13 @@ runSync threads c bs hs = do
     -- the database, don't read it but record the commit so we can update it.
     toIns <-
       flip runReaderT state $ 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 (fmap (accountRFullpath . E.entityVal) . coCreate . csAccounts)
         (CRUDOps hSs _ _ _) <- askDBState csHistStmts
         hSs' <- mapErrorsIO (readHistStmt root) hSs
-        -- lift $ setNumCapabilities 1
-        -- lift $ print $ length $ lefts hSs'
-        -- lift $ print $ length $ rights hSs'
         (CRUDOps hTs _ _ _) <- askDBState csHistTrans
         hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
-        -- lift $ print $ length $ lefts hTs'
         (CRUDOps bTs _ _ _) <- askDBState csBudgets
         bTs' <- liftIOExceptT $ mapErrors readBudget bTs
-        -- lift $ print $ length $ lefts bTs
         return $ concat $ hSs' ++ hTs' ++ bTs'
-    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
@@ -288,8 +265,4 @@ readConfig :: MonadUnliftIO m => FilePath -> m Config
 readConfig = fmap unfix . readDhall
 
 readDhall :: Dhall.FromDhall a => MonadUnliftIO m => FilePath -> m a
-readDhall confpath = do
+readDhall confpath = liftIO $ Dhall.inputFile Dhall.auto confpath
-  -- tid <- myThreadId
-  -- liftIO $ print $ show tid
-  -- liftIO $ print confpath
-  liftIO $ Dhall.inputFile Dhall.auto confpath

lib/Internal/Database.hs

@@ -4,7 +4,6 @@ module Internal.Database
   , nukeTables
   , updateHashes
   , updateDBState
-  -- , getDBState
   , tree2Records
   , flattenAcntRoot
   , indexAcntRoot
@@ -108,16 +107,6 @@ nukeTables = do
 --     toFullPath path name = T.unwords [unValue @T.Text path, "/", unValue @T.Text name]
 --     toBal = maybe "???" (fmtRational 2) . unValue
 
--- data TxState = TxState
---   { tsBudget :: !(CRUDOps () () () ())
---   , tsHistTransfer :: !(CRUDOps () () () ())
---   , tsHistStatement :: !(CRUDOps () () () ())
---   }
-
--- readTxState :: (MonadFinance m, MonadUnliftIO m) -> [Budget] -> [History] -> m TxState
--- readTxState bs hs = do
---   (curBgts, curHistTrs, curHistSts) <- readCurrentCommits
-
 readConfigState
   :: (MonadInsertError m, MonadSqlQuery m)
   => Config
@@ -285,23 +274,6 @@ readCurrentCommits = do
             CTHistoryTransfer -> (bs, y : ts, hs)
             CTHistoryStatement -> (bs, ts, y : hs)
 
--- hashConfig :: [Budget] -> [History] -> [Int]
--- hashConfig bs hs = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
---   where
---     (ms, ps) = partitionEithers $ fmap go hs
---     go (HistTransfer x) = Left x
---     go (HistStatement x) = Right x
-
--- setDiff2 :: Eq a => [a] -> [a] -> ([a], [a])
--- setDiff2 = setDiffWith2 (==)
-
--- -- setDiff :: Eq a => [a] -> [a] -> ([a], [a], [a])
--- -- setDiff as bs = let (as', os, bs') = setDiffWith (==) as bs in (as', fst <$> os, bs')
-
--- -- setDiff as bs = (as \\ bs, bs \\ as)
--- setDiffWith2 :: (a -> b -> Bool) -> [a] -> [b] -> ([a], [b])
--- setDiffWith2 f as bs = let (as', _, bs') = setDiffWith f as bs in (as', bs')
-
 setDiffWith :: (a -> b -> Bool) -> [a] -> [b] -> ([a], [(a, b)], [b])
 setDiffWith f = go [] []
   where
@@ -318,9 +290,6 @@ 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
-
 nukeDBHash :: MonadSqlQuery m => Int -> m ()
 nukeDBHash h = deleteE $ do
   c <- E.from E.table
@@ -329,43 +298,9 @@ nukeDBHash h = deleteE $ do
 nukeDBHashes :: MonadSqlQuery m => [Int] -> m ()
 nukeDBHashes = mapM_ nukeDBHash
 
--- getConfigHashes :: MonadSqlQuery m => [Budget] -> [History] -> m ([Int], [Int])
--- getConfigHashes bs hs = do
---   let ch = hashConfig bs hs
---   dh <- getDBHashes
---   return $ setDiff2 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
-
 currencyMap :: [Entity CurrencyR] -> CurrencyMap
 currencyMap =
   M.fromList
@@ -418,31 +353,6 @@ paths2IDs =
     . L.sortOn fst
     . fmap (first (NE.reverse . acntPath2NonEmpty))
 
--- -- none of these errors should fire assuming that input is sorted and unique
--- trimNames :: [NE.NonEmpty T.Text] -> [AcntID]
--- trimNames = fmap (T.intercalate "_" . reverse) . trimAll 0
---   where
---     trimAll _ [] = []
---     trimAll i (y : ys) = case L.foldl' (matchPre i) (y, [], []) ys of
---       (a, [], bs) -> reverse $ trim i a : bs
---       (a, as, bs) -> reverse bs ++ trimAll (i + 1) (reverse $ a : as)
---     matchPre i (y, ys, old) new = case (y !? i, new !? i) of
---       (Nothing, Just _) ->
---         case ys of
---           [] -> (new, [], trim i y : old)
---           _ -> err "unsorted input"
---       (Just _, Nothing) -> err "unsorted input"
---       (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 = NE.take (i + 1)
---     err msg = errorWithoutStackTrace $ "Import.Database.Ops.hs: " ++ msg
-
 -- none of these errors should fire assuming that input is sorted and unique
 trimNames :: [NonEmpty T.Text] -> [AcntID]
 trimNames = fmap (T.intercalate "_") . go []
@@ -460,31 +370,6 @@ trimNames = fmap (T.intercalate "_") . go []
 groupNonEmpty :: Ord a => [NonEmpty a] -> [(a, NonEmpty [a])]
 groupNonEmpty = fmap (second (NE.tail <$>)) . groupWith NE.head
 
--- groupNonEmpty :: Ord a => [NonEmpty a] -> [(a, (Maybe a, [NonEmpty a]))]
--- groupNonEmpty = fmap (second (go <$>)) . groupWith NE.head
---   where
---     go xs = case NE.nonEmpty $ NE.tail xs of
---       (x :| [])
-
--- where
---   go xs@((key :| _) :| _) = (key, xs)
-
--- go (x :| xs) = (x, Just xs)
-
--- (!?) :: NE.NonEmpty a -> Int -> Maybe a
--- xs !? n
---   | 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_ {arIncome, arExpenses, arLiabilities, arAssets, arEquity} =
   ((IncomeT,) <$> arIncome)
@@ -506,66 +391,9 @@ makeAcntMap =
 indexAcntRoot :: AccountRoot -> ([Entity AccountR], [Entity AccountPathR])
 indexAcntRoot = bimap concat concat . L.unzip . fmap (uncurry tree2Records) . flattenAcntRoot
 
--- getDBState
---   :: (MonadInsertError m, MonadSqlQuery m)
---   => Config
---   -> [Budget]
---   -> [History]
---   -> m (DBState, DBUpdates)
--- getDBState c bs hs = do
---   (del, new) <- getConfigHashes bs hs
---   combineError bi si $ \b s ->
---     ( DBState
---         { kmCurrency = currencyMap cs
---         , kmAccount = undefined
---         , kmBudgetInterval = b
---         , kmStatementInterval = s
---         , kmTag = tagMap ts
---         , kmNewCommits = new
---         }
---     , DBUpdates
---         { duOldCommits = del
---         , duNewTagIds = ts
---         , duNewAcntPaths = undefined
---         , duNewAcntIds = acnts
---         , duNewCurrencyIds = cs
---         }
---     )
---   where
---     bi = liftExcept $ resolveDaySpan $ budgetInterval $ scope c
---     si = liftExcept $ resolveDaySpan $ statementInterval $ scope c
---     (acnts, _) = indexAcntRoot $ accounts c
---     cs = currency2Record <$> currencies c
---     ts = toRecord <$> tags c
---     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 ()
 updateHashes DBUpdates {duOldCommits} = nukeDBHashes duOldCommits
 
--- updateTags :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
--- updateTags DBUpdates {duNewTagIds} = do
---   tags' <- selectE $ E.from $ E.table @TagR
---   let (toIns, toDel) = setDiff2 duNewTagIds tags'
---   mapM_ deleteTag toDel
---   mapM_ insertFull toIns
-
--- updateAccounts :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
--- updateAccounts DBUpdates {duNewAcntIds, duNewAcntPaths} = do
---   acnts' <- dumpTbl
---   let (toIns, toDel) = setDiff2 duNewAcntIds acnts'
---   deleteWhere ([] :: [Filter AccountPathR])
---   mapM_ deleteAccount toDel
---   mapM_ insertFull toIns
---   mapM_ insert duNewAcntPaths
-
--- updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
--- updateCurrencies DBUpdates {duNewCurrencyIds} = do
---   curs' <- selectE $ E.from $ E.table @CurrencyR
---   let (toIns, toDel) = setDiff2 duNewCurrencyIds curs'
---   mapM_ deleteCurrency toDel
---   mapM_ insertFull toIns
-
 updateCD
   :: ( MonadSqlQuery m
      , PersistRecordBackend a SqlBackend
@@ -597,70 +425,6 @@ updateDBState = do
   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-deleteKey" (E.deleteKey q)
-
-insertEntityManyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => [Entity a] -> m ()
-insertEntityManyE q = unsafeLiftSql "esqueleto-insertEntityMany" (E.insertEntityMany q)
-
--- whenHash
---   :: (Hashable a, MonadFinance m, MonadSqlQuery m)
---   => 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
-
--- whenHash0
---   :: (Hashable a, MonadFinance m)
---   => ConfigType
---   -> a
---   -> b
---   -> (CommitR -> m b)
---   -> m b
--- whenHash0 t o def f = do
---   let h = hash o
---   hs <- askDBState kmNewCommits
---   if h `elem` hs then f (CommitR h t) else return def
-
--- eitherHash
---   :: (Hashable a, MonadFinance m)
---   => ConfigType
---   -> a
---   -> (CommitR -> m b)
---   -> (CommitR -> m c)
---   -> m (Either b c)
--- eitherHash t o f g = do
---   let h = hash o
---   let c = CommitR h t
---   hs <- askDBState kmNewCommits
---   if h `elem` hs then Right <$> g c else Left <$> f c
-
--- whenHash_
---   :: (Hashable a, MonadFinance m)
---   => 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
-
 readInvalidIds :: MonadSqlQuery m => ExistingConfig -> [(Int, a)] -> m ([Int], [(Int, a)])
 readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
   rs <- selectE $ do
@@ -883,17 +647,6 @@ zipPaired prec = go ([], [])
       let f = maybe (second (++ ros)) (\u -> first (u :)) nextLink
       go (f acc') fs' ts
 
--- go (facc, tacc) (f : fs) ((ti, tls) : ts)
---   | ueIndex f == ti = do
---       tls' <- mapErrors makeLinkUnk tls
---       go ((f, NE.toList tls') : facc, tacc) fs ts
---   | otherwise = go ((f, []) : facc, tacc ++ toRO tls) fs ts
--- go (facc, tacc) fs ts =
---   return
---     ( reverse facc ++ ((,[]) <$> fs)
---     , tacc ++ concatMap (toRO . snd) ts
---     )
-
 makeLinkUnk :: (EntryRId, EntryR) -> InsertExcept UELink
 makeLinkUnk (k, e) =
   maybe
@@ -939,10 +692,6 @@ insertAll ebs = do
       ck <- insert c
       mapM_ (insertTx ck) ts
 
--- where
---   getCommit (HistoryCommit c) = c
---   getCommit (BudgetCommit c _) = c
-
 insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
 insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget, itxPriority} = do
   k <- insert $ TransactionR c itxDate itxDescr itxBudget itxPriority
@@ -956,10 +705,6 @@ insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget, itxPriority} =
       mapM_ (uncurry (go esk)) $ zip [0 ..] ts ++ zip (negate <$> [1 ..]) fs
     go k i e = void $ insertEntry k i e
 
--- case itxCommit of
---   BudgetCommit _ name -> insert_ $ BudgetLabelR ek name
---   _ -> return ()
-
 insertEntry :: MonadSqlQuery m => EntrySetRId -> Int -> InsertEntry -> m EntryRId
 insertEntry
   k
@@ -983,3 +728,18 @@ updateTx :: MonadSqlQuery m => UEBalanced -> m ()
 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)
+
+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-deleteKey" (E.deleteKey q)
+
+insertEntityManyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => [Entity a] -> m ()
+insertEntityManyE q = unsafeLiftSql "esqueleto-insertEntityMany" (E.insertEntityMany q)