{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module Test.Tasty.Runners.Html
( HtmlPath(..)
, htmlRunner
, AssetsPath(..)
) where
import Control.Applicative (Const(..), (<$))
import Control.Monad ((>=>), unless, forM_, 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 (Monoid(mempty,mappend), Sum(Sum,getSum))
import Data.Semigroup ((<>))
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import System.FilePath ((</>))
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, AttributeValue, (!))
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. \
\The following files must be present: \
\`bootstrap.min.css`, `bootstrap.min.js`, `jquery-2.1.1.min.js`"
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 (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 (f :: k1 -> *) k2 (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 (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 (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 -> Markup
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
$cto :: forall x. Rep Summary x -> Summary
$cfrom :: forall x. Summary -> Rep Summary x
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 :: 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 (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 (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 (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 (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 (f :: k1 -> *) k2 (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))
children
let (CssExtra
extra,CssExtra
text) = if Summary -> Sum Int
summaryFailures Summary
soFar Sum Int -> Sum Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int -> Sum Int
forall a. a -> Sum a
Sum Int
0
then ( CssExtra
"btn-danger"
, CssExtra
"text-danger"
)
else ( CssExtra
"btn-success"
, CssExtra
"text-success"
)
grouped :: Markup
grouped = String -> CssExtra -> CssExtra -> Markup -> Markup
testGroupMarkup String
groupName CssExtra
extra CssExtra
text (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$
Markup -> Markup
treeMarkup (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Summary -> Markup
htmlRenderer Summary
soFar
Const Summary () -> StateT Int IO (Const Summary ())
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 :: Markup
htmlRenderer = Markup
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
let 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
includeMarkup :: String -> IO Markup
includeMarkup = String -> IO ByteString
getRead (String -> IO ByteString)
-> (ByteString -> IO Markup) -> String -> IO Markup
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Markup -> IO Markup
forall (m :: * -> *) a. Monad m => a -> m a
return (Markup -> IO Markup)
-> (ByteString -> Markup) -> ByteString -> IO Markup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Markup
H.unsafeByteString
includeScript :: String -> IO Markup
includeScript = String -> IO ByteString
getRead (String -> IO ByteString)
-> (ByteString -> IO Markup) -> String -> IO Markup
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \ByteString
bs ->
Markup -> IO Markup
forall (m :: * -> *) a. Monad m => a -> m a
return (Markup -> IO Markup)
-> (ByteString -> Markup) -> ByteString -> IO Markup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Markup
H.unsafeByteString (ByteString -> IO Markup) -> ByteString -> IO Markup
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>"
Markup
bootStrapCss <- String -> IO Markup
includeMarkup String
"data/bootstrap/dist/css/bootstrap.min.css"
Markup
jQueryJs <- String -> IO Markup
includeScript String
"data/jquery-2.1.1.min.js"
Markup
bootStrapJs <- String -> IO Markup
includeScript String
"data/bootstrap/dist/js/bootstrap.min.js"
Markup
scriptJs <- String -> IO Markup
includeScript String
"data/script.js"
String -> Text -> IO ()
TIO.writeFile String
htmlPath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
Markup -> Text
renderHtml (Markup -> Text) -> Markup -> Text
forall a b. (a -> b) -> a -> b
$
Markup -> Markup
H.docTypeHtml (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.lang CssExtra
"en" (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ do
Markup -> Markup
H.head (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ do
Markup
H.meta Markup -> Attribute -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.charset CssExtra
"utf-8"
Markup
H.meta Markup -> Attribute -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.name CssExtra
"viewport"
Markup -> Attribute -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.content CssExtra
"width=device-width, initial-scale=1.0"
Markup -> Markup
H.title Markup
"Tasty Test Results"
case Maybe AssetsPath
mAssetsPath of
Maybe AssetsPath
Nothing -> do Markup -> Markup
H.style Markup
bootStrapCss
Markup
jQueryJs
Markup
bootStrapJs
Just (AssetsPath String
assetsPath) -> do
Markup
H.link Markup -> Attribute -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.rel CssExtra
"stylesheet"
Markup -> Attribute -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.href (String -> CssExtra
forall a. ToValue a => a -> CssExtra
H.toValue (String -> CssExtra) -> String -> CssExtra
forall a b. (a -> b) -> a -> b
$ String
assetsPath String -> String -> String
</> String
"bootstrap.min.css")
[String] -> (String -> Markup) -> Markup
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String
"bootstrap.min.js", String
"jquery-2.1.1.min.js", String
"bootstrap.min.js"] ((String -> Markup) -> Markup) -> (String -> Markup) -> Markup
forall a b. (a -> b) -> a -> b
$ \String
str ->
Markup -> Markup
H.script (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.src (String -> CssExtra
forall a. ToValue a => a -> CssExtra
H.toValue (String -> CssExtra) -> String -> CssExtra
forall a b. (a -> b) -> a -> b
$ String
assetsPath String -> String -> String
</> String
str ) (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Markup
forall a. Monoid a => a
mempty
Markup -> Markup
H.body (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ do
Markup -> Markup
H.div (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.class_ CssExtra
"container" (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ do
Markup -> Markup
H.h1 (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.class_ CssExtra
"text-center" (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Markup
"Tasty Test Results"
Markup -> Markup
H.div (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.class_ CssExtra
"row" (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$
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
Markup -> Markup
H.div (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.class_ CssExtra
"alert alert-danger" (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$
Markup -> Markup
H.p (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.class_ CssExtra
"lead text-center" (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ do
Int -> Markup
forall a. ToMarkup a => a -> Markup
H.toMarkup (Int -> Markup) -> (Sum Int -> Int) -> Sum Int -> Markup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sum Int -> Int
forall a. Sum a -> a
getSum (Sum Int -> Markup) -> Sum Int -> Markup
forall a b. (a -> b) -> a -> b
$ Summary -> Sum Int
summaryFailures Summary
summary
Markup
" out of " :: Markup
Int -> Markup
forall a. ToMarkup a => a -> Markup
H.toMarkup Int
tests
Markup
" tests failed" :: Markup
Markup -> Markup
H.span (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.class_ CssExtra
"text-muted" (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ String -> Markup
forall a. ToMarkup a => a -> Markup
H.toMarkup (Time -> String
formatTime Time
time)
else
Markup -> Markup
H.div (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.class_ CssExtra
"alert alert-success" (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$
Markup -> Markup
H.p (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.class_ CssExtra
"lead text-center" (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ do
Markup
"All " :: Markup
Int -> Markup
forall a. ToMarkup a => a -> Markup
H.toMarkup Int
tests
Markup
" tests passed" :: Markup
Markup -> Markup
H.span (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.class_ CssExtra
"text-muted" (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ String -> Markup
forall a. ToMarkup a => a -> Markup
H.toMarkup (Time -> String
formatTime Time
time)
Markup -> Markup
H.div (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.class_ CssExtra
"row" (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$
Markup -> Markup
H.div (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.class_ CssExtra
"well" (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$
Markup -> Markup
forall a. ToMarkup a => a -> Markup
H.toMarkup (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Markup -> Markup
treeMarkup (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Summary -> Markup
htmlRenderer Summary
summary
Markup
scriptJs
where
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 :: Markup -> Summary
mkSummary Markup
contents = Summary
forall a. Monoid a => a
mempty { htmlRenderer :: Markup
htmlRenderer = Markup -> Markup
itemMarkup Markup
contents }
mkSuccess :: (TestName, Tasty.Time)
-> String
-> Summary
mkSuccess :: (String, Time) -> String -> Summary
mkSuccess (String, Time)
nameAndTime String
desc =
( Markup -> Summary
mkSummary (Markup -> Summary) -> Markup -> Summary
forall a b. (a -> b) -> a -> b
$ (String, Time)
-> CssDescription -> CssExtra -> CssExtra -> CssExtra -> Markup
testItemMarkup
(String, Time)
nameAndTime
(String
desc, CssExtra
"text-muted")
CssExtra
"glyphicon-ok-sign"
CssExtra
"btn-success"
CssExtra
"text-success"
) { summarySuccesses :: Sum Int
summarySuccesses = Int -> Sum Int
forall a. a -> Sum a
Sum Int
1 }
mkFailure :: (TestName, Tasty.Time)
-> String
-> Summary
mkFailure :: (String, Time) -> String -> Summary
mkFailure (String, Time)
nameAndTime String
desc =
( Markup -> Summary
mkSummary (Markup -> Summary) -> Markup -> Summary
forall a b. (a -> b) -> a -> b
$ (String, Time)
-> CssDescription -> CssExtra -> CssExtra -> CssExtra -> Markup
testItemMarkup
(String, Time)
nameAndTime
(String
desc, CssExtra
"text-danger")
CssExtra
"glyphicon-remove-sign"
CssExtra
"btn-danger"
CssExtra
"text-danger"
) { summaryFailures :: Sum Int
summaryFailures = Int -> Sum Int
forall a. a -> Sum a
Sum Int
1 }
treeMarkup :: Markup -> Markup
treeMarkup :: Markup -> Markup
treeMarkup Markup
rest =
Markup -> Markup
H.div (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.class_ CssExtra
"media collapse in" (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$
Markup -> Markup
H.ul (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.class_ CssExtra
"media-list" (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$
Markup
rest
itemMarkup :: Markup -> Markup
itemMarkup :: Markup -> Markup
itemMarkup = Markup -> Markup
H.li (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.class_ CssExtra
"media"
type CssDescription = (String, AttributeValue)
type CssIcon = AttributeValue
type = AttributeValue
type CssText = AttributeValue
buttonMarkup :: CssExtra -> CssIcon -> Markup
buttonMarkup :: CssExtra -> CssExtra -> Markup
buttonMarkup CssExtra
extra CssExtra
icon =
Markup -> Markup
H.button (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.type_ CssExtra
"button"
(Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.class_ (CssExtra
"btn btn-xs pull-left media-object " CssExtra -> CssExtra -> CssExtra
forall a. Semigroup a => a -> a -> a
<> CssExtra
extra)
(Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Markup -> Markup
H.span (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.class_ (CssExtra
"glyphicon " CssExtra -> CssExtra -> CssExtra
forall a. Semigroup a => a -> a -> a
<> CssExtra
icon) (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Markup
""
testGroupMarkup :: TestName -> CssExtra -> CssText -> Markup -> Markup
testGroupMarkup :: String -> CssExtra -> CssExtra -> Markup -> Markup
testGroupMarkup String
groupName CssExtra
extra CssExtra
text Markup
body =
Markup -> Markup
H.li (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.class_ CssExtra
"media" (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ do
CssExtra -> CssExtra -> Markup
buttonMarkup (CssExtra
extra CssExtra -> CssExtra -> CssExtra
forall a. Semigroup a => a -> a -> a
<> CssExtra
" collapsible") CssExtra
"glyphicon-folder-open"
Markup -> Markup
H.div (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.class_ CssExtra
"media-body" (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ do
Markup -> Markup
H.h4 (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.class_ (CssExtra
"media-heading " CssExtra -> CssExtra -> CssExtra
forall a. Semigroup a => a -> a -> a
<> CssExtra
text) (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$
String -> Markup
forall a. ToMarkup a => a -> Markup
H.toMarkup String
groupName
Markup
body
testItemMarkup :: (TestName, Tasty.Time)
-> CssDescription
-> CssIcon
-> CssExtra
-> CssText
-> Markup
testItemMarkup :: (String, Time)
-> CssDescription -> CssExtra -> CssExtra -> CssExtra -> Markup
testItemMarkup (String
testName,Time
time) (String
desc,CssExtra
desca) CssExtra
icon CssExtra
extra CssExtra
text = do
CssExtra -> CssExtra -> Markup
buttonMarkup CssExtra
extra CssExtra
icon
Markup -> Markup
H.div (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.class_ CssExtra
"media-body" (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ do
Markup -> Markup
H.h5 (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.class_ (CssExtra
"media-heading " CssExtra -> CssExtra -> CssExtra
forall a. Semigroup a => a -> a -> a
<> CssExtra
text) (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ do
String -> Markup
forall a. ToMarkup a => a -> Markup
H.toMarkup String
testName
Bool -> Markup -> Markup
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Time
time Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
0.01) (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$
Markup -> Markup
H.span (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.class_ CssExtra
"text-muted" (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ String -> Markup
forall a. ToMarkup a => a -> Markup
H.toMarkup (Time -> String
formatTime Time
time)
Bool -> Markup -> Markup
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
desc) (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$
Markup -> Markup
H.pre (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Markup -> Markup
H.small (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! CssExtra -> Attribute
A.class_ CssExtra
desca (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ String -> Markup
forall a. ToMarkup a => a -> Markup
H.toMarkup String
desc
formatTime :: Tasty.Time -> String
formatTime :: Time -> String
formatTime = String -> Time -> String
forall r. PrintfType r => String -> r
printf String
" (%.2fs)"