{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Control.Teardown.Internal.Core
( emptyTeardown
, didTeardownFail
, failedToredownCount
, toredownCount
, runTeardown
, runTeardown_
)
where
import RIO
import RIO.Time (NominalDiffTime, diffUTCTime, getCurrentTime)
import Control.Teardown.Internal.Types
trackExecutionTime :: IO a -> IO (NominalDiffTime, a)
trackExecutionTime routine = do
start <- getCurrentTime
result <- routine
end <- getCurrentTime
return (diffUTCTime end start, result)
emptyTeardownResult :: Description -> TeardownResult
emptyTeardownResult = EmptyResult
didTeardownFail :: TeardownResult -> Bool
didTeardownFail result = case result of
LeafResult{} -> isJust (resultError result)
BranchResult{} -> resultDidFail result
EmptyResult{} -> False
newTeardownIO :: Description -> IO () -> IO Teardown
newTeardownIO desc disposingAction = do
teardownResultLock <- newIORef False
teardownResultRef <- newIORef Nothing
return $ Teardown $ do
shouldExecute <- atomicModifyIORef
teardownResultLock
(\toredown -> if toredown then (True, False) else (True, True))
if shouldExecute
then do
(elapsed, disposeResult0) <- trackExecutionTime (try disposingAction)
let disposeResult = LeafResult
desc
elapsed
(either Just (const Nothing) disposeResult0)
writeIORef teardownResultRef (Just disposeResult)
return disposeResult
else fromMaybe (emptyTeardownResult desc) <$> readIORef teardownResultRef
concatTeardown :: Description -> [Teardown] -> Teardown
concatTeardown desc teardownChildren = Teardown $ do
teardownResults <- mapM (\(Teardown action) -> action) teardownChildren
let elapsed = sum $ map getElapsedTime teardownResults
teardownFailed = any didTeardownFail teardownResults
return $ BranchResult desc elapsed teardownFailed teardownResults
newDynTeardown :: Description -> IO [TeardownResult] -> Teardown
newDynTeardown desc action = Teardown $ do
teardownResults <- action
let elapsed = sum $ map getElapsedTime teardownResults
teardownFailed = any didTeardownFail teardownResults
return $ BranchResult desc elapsed teardownFailed teardownResults
emptyTeardown :: Description -> Teardown
emptyTeardown desc = Teardown (return $ emptyTeardownResult desc)
foldTeardownResult
:: (acc -> Description -> Maybe SomeException -> acc)
-> ([acc] -> Description -> acc)
-> acc
-> TeardownResult
-> acc
foldTeardownResult leafStep branchStep acc disposeResult =
case disposeResult of
EmptyResult desc -> leafStep acc desc Nothing
LeafResult desc _ mErr -> leafStep acc desc mErr
BranchResult desc _ _ results ->
let result = map (foldTeardownResult leafStep branchStep acc) results
in branchStep result desc
toredownCount :: TeardownResult -> Int
toredownCount =
foldTeardownResult (\acc _ _ -> acc + 1) (\results _ -> sum results) 0
failedToredownCount :: TeardownResult -> Int
failedToredownCount = foldTeardownResult
(\acc _ mErr -> acc + maybe 0 (const 1) mErr)
(\results _ -> sum results)
0
instance HasTeardown Teardown where
getTeardown = id
instance IResource (IO ()) where
newTeardown =
newTeardownIO
instance IResource [(Text, IO ())] where
newTeardown desc actionList =
concatTeardown desc <$> mapM (uncurry newTeardown) actionList
instance IResource Teardown where
newTeardown desc =
return . concatTeardown desc . return
instance IResource [Teardown] where
newTeardown desc =
return . concatTeardown desc
instance IResource (IO [Teardown]) where
newTeardown desc getTeardownList =
concatTeardown desc <$> getTeardownList
instance IResource (IO [TeardownResult]) where
newTeardown desc =
return . newDynTeardown desc
runTeardown :: HasTeardown t => t -> IO TeardownResult
runTeardown t0 =
let (Teardown teardownAction) = getTeardown t0 in teardownAction
runTeardown_ :: HasTeardown t => t -> IO ()
runTeardown_ = void . runTeardown