{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Teardown.Internal.Core
( emptyTeardown
, didTeardownFail
, failedToredownCount
, toredownCount
, runTeardown
, runTeardown_
, newTeardown
)
where
import RIO
import RIO.Time (NominalDiffTime, diffUTCTime, getCurrentTime)
#if MIN_VERSION_base(4,11,0)
import qualified GHC.TypeLits as Ty
#endif
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)
{-# INLINE emptyTeardown #-}
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
{-# INLINE toredownCount #-}
failedToredownCount :: TeardownResult -> Int
failedToredownCount = foldTeardownResult
(\acc _ mErr -> acc + maybe 0 (const 1) mErr)
(\results _ -> sum results)
0
instance HasTeardown Teardown where
getTeardown = id
{-# INLINE getTeardown #-}
instance IResource (IO ()) where
newTeardown =
newTeardownIO
{-# INLINE newTeardown #-}
#if MIN_VERSION_base(4,11,0)
instance Ty.TypeError ('Ty.Text "DEPRECATED: Execute a 'newTeardown' call per allocated resource")
=> IResource [(Text, IO ())] where
newTeardown desc actionList =
concatTeardown desc <$> mapM (uncurry newTeardown) actionList
#else
instance IResource [(Text, IO ())] where
newTeardown desc actionList =
concatTeardown desc <$> mapM (uncurry newTeardown) actionList
#endif
instance IResource Teardown where
newTeardown desc =
return . concatTeardown desc . return
instance IResource [Teardown] where
newTeardown desc =
return . concatTeardown desc
{-# INLINE newTeardown #-}
instance IResource (IO [Teardown]) where
newTeardown desc getTeardownList =
concatTeardown desc <$> getTeardownList
{-# INLINE newTeardown #-}
instance IResource (IO [TeardownResult]) where
newTeardown desc =
return . newDynTeardown desc
{-# INLINE newTeardown #-}
runTeardown :: HasTeardown t => t -> IO TeardownResult
runTeardown t0 =
let (Teardown teardownAction) = getTeardown t0 in uninterruptibleMask_ teardownAction
{-# INLINE runTeardown #-}
runTeardown_ :: HasTeardown t => t -> IO ()
runTeardown_ = void . runTeardown
{-# INLINE runTeardown_ #-}