From e8a5088d353408d3356e16349277315815bd8a5d Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sat, 19 Aug 2023 20:56:40 -0400
Subject: [PATCH] ENH clean up build plan printout

---
 app/Main.hs              |  3 ---
 lib/Internal/Database.hs | 46 ++++++++++++++++++++++++++++------------
 2 files changed, 32 insertions(+), 17 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 937ffad..03e7e38 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -204,15 +204,12 @@ runDumpAccountKeys c = do
 runSync :: Int -> FilePath -> [FilePath] -> [FilePath] -> IO ()
 runSync threads c bs hs = do
   setNumCapabilities threads
-  -- putStrLn "reading config"
   config <- readConfig c
-  -- putStrLn "reading statements"
   (bs', hs') <-
     fmap (bimap concat concat . partitionEithers) $
       pooledMapConcurrentlyN threads (bimapM readDhall readDhall) $
         (Left <$> bs) ++ (Right <$> hs)
   pool <- runNoLoggingT $ mkPool $ sqlConfig config
-  putStrLn "doing other stuff"
   setNumCapabilities 1
   handle err $ sync pool root config bs' hs'
   where
diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs
index 419c13a..d2986b3 100644
--- a/lib/Internal/Database.hs
+++ b/lib/Internal/Database.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE ImplicitPrelude #-}
-
 module Internal.Database
   ( runDB
   , readDB
@@ -24,6 +22,7 @@ import Control.Monad.IO.Rerunnable
 import Control.Monad.Logger
 import Data.Decimal
 import Data.Hashable
+import qualified Data.Text.IO as TI
 import Database.Esqueleto.Experimental ((:&) (..), (==.), (?.), (^.))
 import qualified Database.Esqueleto.Experimental as E
 import Database.Esqueleto.Internal.Internal (SqlSelect)
@@ -40,12 +39,11 @@ import Database.Persist.Sqlite hiding
   , (==.)
   , (||.)
   )
--- import GHC.Err
 import Internal.Budget
 import Internal.History
 import Internal.Types.Main
 import Internal.Utils
-import RIO hiding (LogFunc, isNothing, on, (^.))
+import RIO hiding (LogFunc, isNothing, logDebug, on, (^.))
 import qualified RIO.List as L
 import qualified RIO.Map as M
 import qualified RIO.NonEmpty as NE
@@ -75,16 +73,7 @@ sync pool root c bs hs = do
       b <- liftIOExceptT $ readBudgetCRUD budgets
       h <- readHistoryCRUD root history
       return (b, h)
-  -- liftIO $ print $ length $ coCreate budgets
-  liftIO $ print $ length $ fst $ coCreate history
-  liftIO $ print $ bimap length length $ coCreate history
-  liftIO $ print $ length $ coRead history
-  liftIO $ print $ length $ coUpdate history
-  liftIO $ print $ (\(DeleteTxs e a b c' d) -> (length e, length a, length b, length c', length d)) $ coDelete history
-  liftIO $ print $ fmap (length . snd) $ coCreate budgets'
-  -- liftIO $ print $ length $ M.elems $ tsAccountMap txState
-  -- liftIO $ print $ length $ M.elems $ tsCurrencyMap txState
-  -- liftIO $ print $ length $ M.elems $ tsTagMap txState
+  liftIO $ TI.putStr $ formatBuildPlan history budgets
 
   -- Update the DB.
   runSqlQueryT pool $ withTransaction $ flip runReaderT txState $ do
@@ -99,6 +88,35 @@ sync pool root c bs hs = do
     -- thrown error should be caught despite possibly needing to be rerun
     rerunnableIO $ fromEither res
 
+formatBuildPlan :: PreHistoryCRUD -> PreBudgetCRUD -> T.Text
+formatBuildPlan
+  CRUDOps {coCreate = hc, coRead = hr, coUpdate = hu, coDelete = hd}
+  CRUDOps {coCreate = bc, coDelete = bd} =
+    T.unlines $ "Build plan:" : (T.append "  " <$> ht ++ [""] ++ bt)
+    where
+      ht =
+        [ T.append "History transfers to create: " $ tshow hCt
+        , T.append "History statements to create: " $ tshow hCs
+        , T.append "History entries to read: " $ tshow $ length hr
+        , T.append "History entry sets to update: " $ tshow $ length hu
+        ]
+          ++ formatDel "History" hd
+      bt =
+        T.append "Budgets to create: " (tshow $ bgtLabel <$> bc)
+          : formatDel "Budget" bd
+      toDel what thing n = T.unwords [what, thing, "to delete:", tshow n]
+      formatDel what (DeleteTxs e a b c' d) =
+        [ f "commits" e
+        , f "transactions" a
+        , f "entry sets" b
+        , f "entries" c'
+        , f "tag relations" d
+        ]
+        where
+          f :: T.Text -> [a] -> T.Text
+          f thing = toDel what thing . length
+      (hCt, hCs) = bimap length length hc
+
 runDB
   :: MonadUnliftIO m
   => SqlConfig