ENH clean up build plan printout
This commit is contained in:
parent
8e2019ac5b
commit
e8a5088d35
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue