{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module Test.Tasty.Runners.Html
( HtmlPath(..)
, htmlRunner
) where
import Control.Applicative (Const(..))
import Control.Monad ((>=>), unless, when)
import Control.Monad.Trans.Class (lift)
import Control.Concurrent.STM (atomically, readTVar)
import qualified Control.Concurrent.STM as STM(retry)
import Data.Maybe (fromMaybe)
import Data.Monoid (Sum(Sum,getSum))
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import qualified Data.Text.Lazy.IO as TIO
import qualified Data.ByteString as B
import Control.Monad.State (StateT, evalStateT, liftIO)
import qualified Control.Monad.State as State (get, modify)
import Data.Functor.Compose (Compose(Compose,getCompose))
import qualified Data.IntMap as IntMap
import Data.Proxy (Proxy(..))
import Data.Tagged (Tagged(..))
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
import Test.Tasty.Runners
( Ingredient(TestReporter)
, Status(Done)
, StatusMap
, Traversal(Traversal,getTraversal)
)
import Test.Tasty.Providers (IsTest, TestName)
import qualified Test.Tasty.Runners as Tasty
import qualified Test.Tasty.Ingredients as Tasty
import Test.Tasty.Options as Tasty
import Text.Blaze.Html5 (Markup, (!))
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import Text.Blaze.Html.Renderer.Text (renderHtml)
import Text.Printf (printf)
import Paths_tasty_html (getDataFileName)
newtype HtmlPath = HtmlPath FilePath deriving (Typeable)
instance IsOption (Maybe HtmlPath) where
defaultValue :: Maybe HtmlPath
defaultValue = Maybe HtmlPath
forall a. Maybe a
Nothing
parseValue :: String -> Maybe (Maybe HtmlPath)
parseValue = Maybe HtmlPath -> Maybe (Maybe HtmlPath)
forall a. a -> Maybe a
Just (Maybe HtmlPath -> Maybe (Maybe HtmlPath))
-> (String -> Maybe HtmlPath) -> String -> Maybe (Maybe HtmlPath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HtmlPath -> Maybe HtmlPath
forall a. a -> Maybe a
Just (HtmlPath -> Maybe HtmlPath)
-> (String -> HtmlPath) -> String -> Maybe HtmlPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HtmlPath
HtmlPath
optionName :: Tagged (Maybe HtmlPath) String
optionName = String -> Tagged (Maybe HtmlPath) String
forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"html"
optionHelp :: Tagged (Maybe HtmlPath) String
optionHelp = String -> Tagged (Maybe HtmlPath) String
forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"A file path to store the test results in HTML"
newtype AssetsPath = AssetsPath FilePath deriving (Typeable)
instance IsOption (Maybe AssetsPath) where
defaultValue :: Maybe AssetsPath
defaultValue = Maybe AssetsPath
forall a. Maybe a
Nothing
parseValue :: String -> Maybe (Maybe AssetsPath)
parseValue = Maybe AssetsPath -> Maybe (Maybe AssetsPath)
forall a. a -> Maybe a
Just (Maybe AssetsPath -> Maybe (Maybe AssetsPath))
-> (String -> Maybe AssetsPath)
-> String
-> Maybe (Maybe AssetsPath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AssetsPath -> Maybe AssetsPath
forall a. a -> Maybe a
Just (AssetsPath -> Maybe AssetsPath)
-> (String -> AssetsPath) -> String -> Maybe AssetsPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AssetsPath
AssetsPath
optionName :: Tagged (Maybe AssetsPath) String
optionName = String -> Tagged (Maybe AssetsPath) String
forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"assets"
optionHelp :: Tagged (Maybe AssetsPath) String
optionHelp = String -> Tagged (Maybe AssetsPath) String
forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"Directory where HTML assets will be looked up. \
\If not given the assets will be inlined within the \
\HTML file."
htmlRunner :: Ingredient
htmlRunner :: Ingredient
htmlRunner = [OptionDescription]
-> (OptionSet
-> TestTree -> Maybe (StatusMap -> IO (Time -> IO Bool)))
-> Ingredient
TestReporter [OptionDescription]
optionDescription ((OptionSet
-> TestTree -> Maybe (StatusMap -> IO (Time -> IO Bool)))
-> Ingredient)
-> (OptionSet
-> TestTree -> Maybe (StatusMap -> IO (Time -> IO Bool)))
-> Ingredient
forall a b. (a -> b) -> a -> b
$ \OptionSet
options TestTree
testTree -> do
HtmlPath String
htmlPath <- OptionSet -> Maybe HtmlPath
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
options
let mAssetsPath :: Maybe AssetsPath
mAssetsPath = OptionSet -> Maybe AssetsPath
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
options
(StatusMap -> IO (Time -> IO Bool))
-> Maybe (StatusMap -> IO (Time -> IO Bool))
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ((StatusMap -> IO (Time -> IO Bool))
-> Maybe (StatusMap -> IO (Time -> IO Bool)))
-> (StatusMap -> IO (Time -> IO Bool))
-> Maybe (StatusMap -> IO (Time -> IO Bool))
forall a b. (a -> b) -> a -> b
$ \StatusMap
statusMap -> do
Const Summary
summary <- (StateT Int IO (Const Summary ()) -> Int -> IO (Const Summary ()))
-> Int -> StateT Int IO (Const Summary ()) -> IO (Const Summary ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Int IO (Const Summary ()) -> Int -> IO (Const Summary ())
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT Int
0 (StateT Int IO (Const Summary ()) -> IO (Const Summary ()))
-> StateT Int IO (Const Summary ()) -> IO (Const Summary ())
forall a b. (a -> b) -> a -> b
$ Compose (StateT Int IO) (Const Summary) ()
-> StateT Int IO (Const Summary ())
forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose (StateT Int IO) (Const Summary) ()
-> StateT Int IO (Const Summary ()))
-> Compose (StateT Int IO) (Const Summary) ()
-> StateT Int IO (Const Summary ())
forall a b. (a -> b) -> a -> b
$ Traversal (Compose (StateT Int IO) (Const Summary))
-> Compose (StateT Int IO) (Const Summary) ()
forall (f :: * -> *). Traversal f -> f ()
getTraversal (Traversal (Compose (StateT Int IO) (Const Summary))
-> Compose (StateT Int IO) (Const Summary) ())
-> Traversal (Compose (StateT Int IO) (Const Summary))
-> Compose (StateT Int IO) (Const Summary) ()
forall a b. (a -> b) -> a -> b
$
TreeFold (Traversal (Compose (StateT Int IO) (Const Summary)))
-> OptionSet
-> TestTree
-> Traversal (Compose (StateT Int IO) (Const Summary))
forall b. Monoid b => TreeFold b -> OptionSet -> TestTree -> b
Tasty.foldTestTree
TreeFold (Traversal (Compose (StateT Int IO) (Const Summary)))
forall b. Monoid b => TreeFold b
Tasty.trivialFold { foldSingle :: forall t.
IsTest t =>
OptionSet
-> String
-> t
-> Traversal (Compose (StateT Int IO) (Const Summary))
Tasty.foldSingle = StatusMap
-> OptionSet
-> String
-> t
-> Traversal (Compose (StateT Int IO) (Const Summary))
forall t.
IsTest t =>
StatusMap
-> OptionSet
-> String
-> t
-> Traversal (Compose (StateT Int IO) (Const Summary))
runTest StatusMap
statusMap
, foldGroup :: OptionSet
-> String
-> [Traversal (Compose (StateT Int IO) (Const Summary))]
-> Traversal (Compose (StateT Int IO) (Const Summary))
Tasty.foldGroup = OptionSet
-> String
-> [Traversal (Compose (StateT Int IO) (Const Summary))]
-> Traversal (Compose (StateT Int IO) (Const Summary))
runGroup
}
OptionSet
options
TestTree
testTree
(Time -> IO Bool) -> IO (Time -> IO Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Time -> IO Bool) -> IO (Time -> IO Bool))
-> (Time -> IO Bool) -> IO (Time -> IO Bool)
forall a b. (a -> b) -> a -> b
$ \Time
time -> do
Summary -> Time -> String -> Maybe AssetsPath -> IO ()
generateHtml Summary
summary Time
time String
htmlPath Maybe AssetsPath
mAssetsPath
Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Sum Int -> Int
forall a. Sum a -> a
getSum (Summary -> Sum Int
summaryFailures Summary
summary) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
where
optionDescription :: [OptionDescription]
optionDescription = [ Proxy (Maybe HtmlPath) -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy (Maybe HtmlPath)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (Maybe HtmlPath))
, Proxy (Maybe AssetsPath) -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy (Maybe AssetsPath)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (Maybe AssetsPath))
]
_onlyUsedByHaddock :: ()
_onlyUsedByHaddock :: ()
_onlyUsedByHaddock = ()
where Ingredient -> Ingredient -> Ingredient
_ = Ingredient -> Ingredient -> Ingredient
Tasty.composeReporters
data Summary = Summary { Summary -> Sum Int
summaryFailures :: Sum Int
, Summary -> Sum Int
summarySuccesses :: Sum Int
, Summary -> Html
htmlRenderer :: Markup
} deriving ((forall x. Summary -> Rep Summary x)
-> (forall x. Rep Summary x -> Summary) -> Generic Summary
forall x. Rep Summary x -> Summary
forall x. Summary -> Rep Summary x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Summary -> Rep Summary x
from :: forall x. Summary -> Rep Summary x
$cto :: forall x. Rep Summary x -> Summary
to :: forall x. Rep Summary x -> Summary
Generic)
instance Semigroup Summary where
<> :: Summary -> Summary -> Summary
(<>) = Summary -> Summary -> Summary
forall a. (Generic a, Monoid' (Rep a)) => a -> a -> a
mappenddefault
instance Monoid Summary where
mempty :: Summary
mempty = Summary
forall a. (Generic a, Monoid' (Rep a)) => a
memptydefault
mappend :: Summary -> Summary -> Summary
mappend = Summary -> Summary -> Summary
forall a. Semigroup a => a -> a -> a
(<>)
type SummaryTraversal = Traversal (Compose (StateT Int IO) (Const Summary))
runTest :: IsTest t
=> StatusMap -> OptionSet -> TestName -> t -> SummaryTraversal
runTest :: forall t.
IsTest t =>
StatusMap
-> OptionSet
-> String
-> t
-> Traversal (Compose (StateT Int IO) (Const Summary))
runTest StatusMap
statusMap OptionSet
_ String
testName t
_ = Compose (StateT Int IO) (Const Summary) ()
-> Traversal (Compose (StateT Int IO) (Const Summary))
forall (f :: * -> *). f () -> Traversal f
Traversal (Compose (StateT Int IO) (Const Summary) ()
-> Traversal (Compose (StateT Int IO) (Const Summary)))
-> Compose (StateT Int IO) (Const Summary) ()
-> Traversal (Compose (StateT Int IO) (Const Summary))
forall a b. (a -> b) -> a -> b
$ StateT Int IO (Const Summary ())
-> Compose (StateT Int IO) (Const Summary) ()
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (StateT Int IO (Const Summary ())
-> Compose (StateT Int IO) (Const Summary) ())
-> StateT Int IO (Const Summary ())
-> Compose (StateT Int IO) (Const Summary) ()
forall a b. (a -> b) -> a -> b
$ do
Int
ix <- StateT Int IO Int
forall s (m :: * -> *). MonadState s m => m s
State.get
Result
result <- IO Result -> StateT Int IO Result
forall (m :: * -> *) a. Monad m => m a -> StateT Int m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Result -> StateT Int IO Result)
-> IO Result -> StateT Int IO Result
forall a b. (a -> b) -> a -> b
$ STM Result -> IO Result
forall a. STM a -> IO a
atomically (STM Result -> IO Result) -> STM Result -> IO Result
forall a b. (a -> b) -> a -> b
$ do
Status
status <- TVar Status -> STM Status
forall a. TVar a -> STM a
readTVar (TVar Status -> STM Status) -> TVar Status -> STM Status
forall a b. (a -> b) -> a -> b
$
TVar Status -> Maybe (TVar Status) -> TVar Status
forall a. a -> Maybe a -> a
fromMaybe (String -> TVar Status
forall a. HasCallStack => String -> a
error String
"Attempted to lookup test by index outside bounds") (Maybe (TVar Status) -> TVar Status)
-> Maybe (TVar Status) -> TVar Status
forall a b. (a -> b) -> a -> b
$
Int -> StatusMap -> Maybe (TVar Status)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
ix StatusMap
statusMap
case Status
status of
Done Result
result -> Result -> STM Result
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
result
Status
_ -> STM Result
forall a. STM a
STM.retry
String
msg <- IO String -> StateT Int IO String
forall a. IO a -> StateT Int IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> StateT Int IO String)
-> (Result -> IO String) -> Result -> StateT Int IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO String
Tasty.formatMessage (String -> IO String) -> (Result -> String) -> Result -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> String
Tasty.resultDescription (Result -> StateT Int IO String) -> Result -> StateT Int IO String
forall a b. (a -> b) -> a -> b
$ Result
result
let time :: Time
time = Result -> Time
Tasty.resultTime Result
result
summary :: Summary
summary = if Result -> Bool
Tasty.resultSuccessful Result
result
then String -> Time -> String -> Summary
mkSuccess String
testName Time
time String
msg
else String -> Time -> String -> Summary
mkFailure String
testName Time
time String
msg
Summary -> Const Summary ()
forall {k} a (b :: k). a -> Const a b
Const Summary
summary Const Summary ()
-> StateT Int IO () -> StateT Int IO (Const Summary ())
forall a b. a -> StateT Int IO b -> StateT Int IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Int -> Int) -> StateT Int IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
runGroup :: OptionSet -> TestName -> [SummaryTraversal] -> SummaryTraversal
runGroup :: OptionSet
-> String
-> [Traversal (Compose (StateT Int IO) (Const Summary))]
-> Traversal (Compose (StateT Int IO) (Const Summary))
runGroup OptionSet
_opts String
groupName [Traversal (Compose (StateT Int IO) (Const Summary))]
children = Compose (StateT Int IO) (Const Summary) ()
-> Traversal (Compose (StateT Int IO) (Const Summary))
forall (f :: * -> *). f () -> Traversal f
Traversal (Compose (StateT Int IO) (Const Summary) ()
-> Traversal (Compose (StateT Int IO) (Const Summary)))
-> Compose (StateT Int IO) (Const Summary) ()
-> Traversal (Compose (StateT Int IO) (Const Summary))
forall a b. (a -> b) -> a -> b
$ StateT Int IO (Const Summary ())
-> Compose (StateT Int IO) (Const Summary) ()
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (StateT Int IO (Const Summary ())
-> Compose (StateT Int IO) (Const Summary) ())
-> StateT Int IO (Const Summary ())
-> Compose (StateT Int IO) (Const Summary) ()
forall a b. (a -> b) -> a -> b
$ do
Const Summary
soFar <- Compose (StateT Int IO) (Const Summary) ()
-> StateT Int IO (Const Summary ())
forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose (StateT Int IO) (Const Summary) ()
-> StateT Int IO (Const Summary ()))
-> Compose (StateT Int IO) (Const Summary) ()
-> StateT Int IO (Const Summary ())
forall a b. (a -> b) -> a -> b
$ Traversal (Compose (StateT Int IO) (Const Summary))
-> Compose (StateT Int IO) (Const Summary) ()
forall (f :: * -> *). Traversal f -> f ()
getTraversal (Traversal (Compose (StateT Int IO) (Const Summary))
-> Compose (StateT Int IO) (Const Summary) ())
-> Traversal (Compose (StateT Int IO) (Const Summary))
-> Compose (StateT Int IO) (Const Summary) ()
forall a b. (a -> b) -> a -> b
$ [Traversal (Compose (StateT Int IO) (Const Summary))]
-> Traversal (Compose (StateT Int IO) (Const Summary))
forall a. Monoid a => [a] -> a
mconcat [Traversal (Compose (StateT Int IO) (Const Summary))]
children
let successful :: Bool
successful = Summary -> Sum Int
summaryFailures Summary
soFar Sum Int -> Sum Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Sum Int
forall a. a -> Sum a
Sum Int
0
let grouped :: Html
grouped = String -> Bool -> Html -> Html
testGroupMarkup String
groupName Bool
successful (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
treeMarkup (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Summary -> Html
htmlRenderer Summary
soFar
Const Summary () -> StateT Int IO (Const Summary ())
forall a. a -> StateT Int IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Const Summary () -> StateT Int IO (Const Summary ()))
-> Const Summary () -> StateT Int IO (Const Summary ())
forall a b. (a -> b) -> a -> b
$ Summary -> Const Summary ()
forall {k} a (b :: k). a -> Const a b
Const Summary
soFar { htmlRenderer :: Html
htmlRenderer = Html
grouped }
generateHtml :: Summary
-> Tasty.Time
-> FilePath
-> Maybe AssetsPath
-> IO ()
generateHtml :: Summary -> Time -> String -> Maybe AssetsPath -> IO ()
generateHtml Summary
summary Time
time String
htmlPath Maybe AssetsPath
mAssetsPath = do
Html
prologue <- case Maybe AssetsPath
mAssetsPath of
Maybe AssetsPath
Nothing -> String -> IO Html
includeStyle String
"data/tasty.css"
Just (AssetsPath String
path) -> Html -> IO Html
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html -> IO Html) -> Html -> IO Html
forall a b. (a -> b) -> a -> b
$ Html
H.link Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.rel AttributeValue
"stylesheet" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ String
path String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"tasty.css")
Html
epilogue <- case Maybe AssetsPath
mAssetsPath of
Maybe AssetsPath
Nothing -> String -> IO Html
includeScript String
"data/tasty.js"
Just (AssetsPath String
path) -> Html -> IO Html
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html -> IO Html) -> Html -> IO Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.script (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.src (String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ String
path String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"tasty.js") (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
forall a. Monoid a => a
mempty
String -> Text -> IO ()
TIO.writeFile String
htmlPath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
Html -> Text
renderHtml (Html -> Text) -> Html -> Text
forall a b. (a -> b) -> a -> b
$
Html -> Html
H.docTypeHtml (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.lang AttributeValue
"en" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
Html -> Html
H.head (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
Html
H.meta Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.charset AttributeValue
"utf-8"
Html
H.meta Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.name AttributeValue
"viewport"
Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.content AttributeValue
"width=device-width, initial-scale=1.0"
Html -> Html
H.title Html
"Tasty Test Results"
Html
prologue
case Maybe AssetsPath
mAssetsPath of
Maybe AssetsPath
Nothing -> Html
forall a. Monoid a => a
mempty
Just (AssetsPath String
_) -> Html
forall a. Monoid a => a
mempty
Html -> Html
H.body (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
Html -> Html
H.h1 Html
"Tasty Test Results"
if Summary -> Sum Int
summaryFailures Summary
summary Sum Int -> Sum Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int -> Sum Int
forall a. a -> Sum a
Sum Int
0
then Html
failureBanner
else Html
successBanner
Html -> Html
H.button (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id AttributeValue
"expand-all" (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"hidden" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
"Expand all"
Html -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
treeMarkup (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Summary -> Html
htmlRenderer Summary
summary
Html
epilogue
where
getRead :: String -> IO ByteString
getRead = String -> IO String
getDataFileName (String -> IO String)
-> (String -> IO ByteString) -> String -> IO ByteString
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> String -> IO ByteString
B.readFile
includeScript :: String -> IO Html
includeScript = String -> IO ByteString
getRead (String -> IO ByteString)
-> (ByteString -> IO Html) -> String -> IO Html
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \ByteString
bs ->
Html -> IO Html
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Html -> IO Html) -> (ByteString -> Html) -> ByteString -> IO Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Html
H.unsafeByteString (ByteString -> IO Html) -> ByteString -> IO Html
forall a b. (a -> b) -> a -> b
$ ByteString
"<script>" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
bs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"</script>"
includeStyle :: String -> IO Html
includeStyle String
path = do
ByteString
bs <- String -> IO ByteString
getRead String
path
Html -> IO Html
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html -> IO Html) -> Html -> IO Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.style (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ ByteString -> Html
H.unsafeByteString ByteString
bs
failureBanner :: Html
failureBanner = Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id AttributeValue
"status-banner" (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"fail" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
Int -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (Int -> Html) -> (Sum Int -> Int) -> Sum Int -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sum Int -> Int
forall a. Sum a -> a
getSum (Sum Int -> Html) -> Sum Int -> Html
forall a b. (a -> b) -> a -> b
$ Summary -> Sum Int
summaryFailures Summary
summary
Html
" out of " :: Markup
Int -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup Int
tests
Html
" tests failed" :: Markup
Html -> Html
H.span (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ Time -> String
formatTime Time
time
successBanner :: Html
successBanner = Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id AttributeValue
"status-banner" (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"pass" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
Html
"All " :: Markup
Int -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup Int
tests
Html
" tests passed" :: Markup
Html -> Html
H.span (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ Time -> String
formatTime Time
time
tests :: Int
tests = Sum Int -> Int
forall a. Sum a -> a
getSum (Sum Int -> Int) -> Sum Int -> Int
forall a b. (a -> b) -> a -> b
$ Summary -> Sum Int
summaryFailures Summary
summary Sum Int -> Sum Int -> Sum Int
forall a. Semigroup a => a -> a -> a
<> Summary -> Sum Int
summarySuccesses Summary
summary
mkSummary :: Markup -> Summary
mkSummary :: Html -> Summary
mkSummary Html
contents = Summary
forall a. Monoid a => a
mempty { htmlRenderer :: Html
htmlRenderer = Html
contents }
mkSuccess :: TestName
-> Tasty.Time
-> String
-> Summary
mkSuccess :: String -> Time -> String -> Summary
mkSuccess String
name Time
time String
desc = Summary
summary { summarySuccesses :: Sum Int
summarySuccesses = Int -> Sum Int
forall a. a -> Sum a
Sum Int
1 }
where
summary :: Summary
summary = Html -> Summary
mkSummary (Html -> Summary) -> Html -> Summary
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Time -> String -> Html
testItemMarkup String
name Bool
True Time
time String
desc
mkFailure :: TestName
-> Tasty.Time
-> String
-> Summary
mkFailure :: String -> Time -> String -> Summary
mkFailure String
name Time
time String
desc = Summary
summary { summaryFailures :: Sum Int
summaryFailures = Int -> Sum Int
forall a. a -> Sum a
Sum Int
1 }
where
summary :: Summary
summary = Html -> Summary
mkSummary (Html -> Summary) -> Html -> Summary
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Time -> String -> Html
testItemMarkup String
name Bool
False Time
time String
desc
treeMarkup :: Markup -> Markup
treeMarkup :: Html -> Html
treeMarkup = Html -> Html
H.ul
testGroupMarkup :: TestName -> Bool -> Markup -> Markup
testGroupMarkup :: String -> Bool -> Html -> Html
testGroupMarkup String
groupName Bool
successful Html
body =
Html -> Html
H.li (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
Html -> Html
H.h4 (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! Attribute
className (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup String
groupName
Html -> Html
H.span (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"expand" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
" (click to expand)"
Html
body
Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"ellipsis" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
H.preEscapedText Text
"…"
where
className :: H.Attribute
className :: Attribute
className = [String] -> Attribute
classNames ([String] -> Attribute) -> [String] -> Attribute
forall a b. (a -> b) -> a -> b
$ [String
"group"] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String
"fail" | Bool -> Bool
not Bool
successful]
classNames :: [String] -> H.Attribute
classNames :: [String] -> Attribute
classNames = AttributeValue -> Attribute
A.class_ (AttributeValue -> Attribute)
-> ([String] -> AttributeValue) -> [String] -> Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue (String -> AttributeValue)
-> ([String] -> String) -> [String] -> AttributeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unwords
testItemMarkup :: TestName
-> Bool
-> Tasty.Time
-> String
-> Markup
testItemMarkup :: String -> Bool -> Time -> String -> Html
testItemMarkup String
testName Bool
successful Time
time String
desc = do
Html -> Html
H.li (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! Attribute
className (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"mark" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
H.preEscapedText (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$
if Bool
successful
then Text
"✓"
else Text
"✕"
Html -> Html
H.div (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
Html -> Html
H.h5 (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup String
testName
Bool -> Html -> Html
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Time
time Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
0.01) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
Html -> Html
H.span (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (Time -> String
formatTime Time
time)
Bool -> Html -> Html
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
desc) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
Html -> Html
H.pre (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.small (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup String
desc
where
className :: H.Attribute
className :: Attribute
className = [String] -> Attribute
classNames ([String] -> Attribute) -> [String] -> Attribute
forall a b. (a -> b) -> a -> b
$ [String
"item"] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String
"fail" | Bool -> Bool
not Bool
successful]
formatTime :: Tasty.Time -> String
formatTime :: Time -> String
formatTime = String -> Time -> String
forall r. PrintfType r => String -> r
printf String
" (%.2fs)"