ENH clean up build plan printout

This commit is contained in:
Nathan Dwarshuis 2023-08-19 20:56:40 -04:00
parent 8e2019ac5b
commit e8a5088d35
2 changed files with 32 additions and 17 deletions

View File

@ -204,15 +204,12 @@ runDumpAccountKeys c = do
runSync :: Int -> FilePath -> [FilePath] -> [FilePath] -> IO () runSync :: Int -> FilePath -> [FilePath] -> [FilePath] -> IO ()
runSync threads c bs hs = do runSync threads c bs hs = do
setNumCapabilities threads setNumCapabilities threads
-- putStrLn "reading config"
config <- readConfig c config <- readConfig c
-- putStrLn "reading statements"
(bs', hs') <- (bs', hs') <-
fmap (bimap concat concat . partitionEithers) $ fmap (bimap concat concat . partitionEithers) $
pooledMapConcurrentlyN threads (bimapM readDhall readDhall) $ pooledMapConcurrentlyN threads (bimapM readDhall readDhall) $
(Left <$> bs) ++ (Right <$> hs) (Left <$> bs) ++ (Right <$> hs)
pool <- runNoLoggingT $ mkPool $ sqlConfig config pool <- runNoLoggingT $ mkPool $ sqlConfig config
putStrLn "doing other stuff"
setNumCapabilities 1 setNumCapabilities 1
handle err $ sync pool root config bs' hs' handle err $ sync pool root config bs' hs'
where where

View File

@ -1,5 +1,3 @@
{-# LANGUAGE ImplicitPrelude #-}
module Internal.Database module Internal.Database
( runDB ( runDB
, readDB , readDB
@ -24,6 +22,7 @@ import Control.Monad.IO.Rerunnable
import Control.Monad.Logger import Control.Monad.Logger
import Data.Decimal import Data.Decimal
import Data.Hashable import Data.Hashable
import qualified Data.Text.IO as TI
import Database.Esqueleto.Experimental ((:&) (..), (==.), (?.), (^.)) import Database.Esqueleto.Experimental ((:&) (..), (==.), (?.), (^.))
import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Experimental as E
import Database.Esqueleto.Internal.Internal (SqlSelect) import Database.Esqueleto.Internal.Internal (SqlSelect)
@ -40,12 +39,11 @@ import Database.Persist.Sqlite hiding
, (==.) , (==.)
, (||.) , (||.)
) )
-- import GHC.Err
import Internal.Budget import Internal.Budget
import Internal.History import Internal.History
import Internal.Types.Main import Internal.Types.Main
import Internal.Utils 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.List as L
import qualified RIO.Map as M import qualified RIO.Map as M
import qualified RIO.NonEmpty as NE import qualified RIO.NonEmpty as NE
@ -75,16 +73,7 @@ sync pool root c bs hs = do
b <- liftIOExceptT $ readBudgetCRUD budgets b <- liftIOExceptT $ readBudgetCRUD budgets
h <- readHistoryCRUD root history h <- readHistoryCRUD root history
return (b, h) return (b, h)
-- liftIO $ print $ length $ coCreate budgets liftIO $ TI.putStr $ formatBuildPlan history 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
-- Update the DB. -- Update the DB.
runSqlQueryT pool $ withTransaction $ flip runReaderT txState $ do 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 -- thrown error should be caught despite possibly needing to be rerun
rerunnableIO $ fromEither res 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 runDB
:: MonadUnliftIO m :: MonadUnliftIO m
=> SqlConfig => SqlConfig