{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Control.Teardown.Internal.Types where
import RIO
import RIO.Time (NominalDiffTime)
#if MIN_VERSION_base(4,9,0)
import GHC.Generics (Generic)
#endif
import Data.Text.Prettyprint.Doc (Pretty, pretty, (<+>))
import qualified Data.Text.Prettyprint.Doc as Pretty
type Description = Text
data TeardownResult
= BranchResult
{
resultDescription :: !Description
, resultElapsedTime :: !NominalDiffTime
, resultDidFail :: !Bool
, resultListing :: ![TeardownResult]
}
| LeafResult
{
resultDescription :: !Description
, resultElapsedTime :: !NominalDiffTime
, resultError :: !(Maybe SomeException)
}
| EmptyResult
{
resultDescription :: !Description
}
deriving (Generic, Show)
instance Pretty TeardownResult where
pretty result =
case result of
EmptyResult {resultDescription} ->
"✓" <+> pretty resultDescription <+> Pretty.parens "empty"
LeafResult {resultDescription, resultElapsedTime, resultError} ->
case resultError of
Nothing ->
"✓" <+> pretty resultDescription <+> Pretty.parens (pretty $ show resultElapsedTime)
Just err ->
Pretty.hang 2
(Pretty.vsep ["✘"
<+> pretty resultDescription
<+> Pretty.parens (pretty $ show resultElapsedTime)
, "|" <+> pretty (show err) ])
BranchResult {resultDidFail, resultDescription, resultElapsedTime, resultListing} ->
let
symbolDoc = if resultDidFail then "✘" else "✓"
in
symbolDoc
<+> pretty resultDescription
<+> Pretty.parens (pretty $ show resultElapsedTime)
<> Pretty.hardline
<> Pretty.indent 2 (Pretty.align (Pretty.vsep (map pretty resultListing)))
instance Display TeardownResult where
display = displayShow . pretty
getElapsedTime :: TeardownResult -> NominalDiffTime
getElapsedTime result =
case result of
BranchResult {resultElapsedTime} -> resultElapsedTime
LeafResult {resultElapsedTime} -> resultElapsedTime
EmptyResult {} -> 0
instance NFData TeardownResult where
rnf result =
case result of
EmptyResult !_desc ->
()
LeafResult !_desc !_time !_err ->
()
BranchResult !_desc !_time !_didFail listing ->
rnf listing
newtype Teardown
= Teardown (IO TeardownResult)
deriving (Generic)
instance NFData Teardown where
rnf !_ = ()
class HasTeardown teardown where
getTeardown :: teardown -> Teardown
class IResource resource where
newTeardown :: Text -> resource -> IO Teardown