{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Run a 'Tasty.TestTree' and produce an HTML file summarising the test results.
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)

-- * Exported

-- | Path where the HTML will be rendered.
newtype HtmlPath = HtmlPath FilePath deriving (Typeable)

-- | HTML 'Option' for the HTML 'Ingredient'.
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"

-- | Path where external assets will be looked up
newtype AssetsPath = AssetsPath FilePath deriving (Typeable)

-- | Assets 'Option' for the HTML 'Ingredient'.
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."

{-| To run tests using this ingredient, use 'Tasty.defaultMainWithIngredients',
    passing 'htmlRunner' as one possible ingredient. This ingredient will run
    tests if you pass the @--html@ command line option. For example,
    @--html=results.html@ will run all the tests and generate @results.html@ as
    output.

    Note enabling @--html@ will ignore all ingredients following 'htmlRunner'.
    If you want to produce the HTML report /in addition/ to other outputs, you can
    use 'Tasty.composeReporters', as in

    > main = defaultMainWithIngredients ingredients tests
    >   where ingredients = [ listingTests, htmlRunner `composeReporters` consoleTestReporter ]

-}
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))
                      ]

-- Silence unused import warning
_onlyUsedByHaddock :: ()
_onlyUsedByHaddock :: ()
_onlyUsedByHaddock = ()
  where Ingredient -> Ingredient -> Ingredient
_ = Ingredient -> Ingredient -> Ingredient
Tasty.composeReporters


-- * Internal

-- ** Types
--
{-| Includes the number of successful and failed tests and the 'Markup' to
    render the results of a test run.
-}
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
(<>)

-- | A 'Traversal' composed of a 'Summary' and a test count.
type SummaryTraversal = Traversal (Compose (StateT Int IO) (Const Summary))

-- ** Test folding

-- | To be used for an individual test when when folding the final 'TestTree'.
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
      -- If the test is done, return the result
      Done Result
result -> Result -> STM Result
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
result
      -- Otherwise the test has either not been started or is currently
      -- executing
      Status
_ -> STM Result
forall a. STM a
STM.retry

  -- Generate HTML for the test
  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)

-- | To be used for a 'TestGroup' when folding the final 'TestTree'.
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 }

-- ** HTML

-- | Generates the final HTML report.
generateHtml :: Summary  -- ^ Test summary.
             -> Tasty.Time -- ^ Total run time.
             -> FilePath -- ^ Where to write.
             -> 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

-- | Set the 'htmlRenderer' of a 'Summary' with the given 'Markup'.
mkSummary :: Markup -> Summary
mkSummary :: Html -> Summary
mkSummary Html
contents = Summary
forall a. Monoid a => a
mempty { htmlRenderer :: Html
htmlRenderer = Html
contents }

-- | Create an HTML 'Summary' with a test success.
mkSuccess :: TestName
          -> Tasty.Time
          -> String -- ^ Description for the test.
          -> 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

-- | Create an HTML 'Summary' with a test failure.
mkFailure :: TestName
          -> Tasty.Time
          -> String -- ^ Description for the test.
          -> 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

-- | Markup representing the branching of a /tree/.
treeMarkup :: Markup -> Markup
treeMarkup :: Html -> Html
treeMarkup = Html -> Html
H.ul

-- | Markup for a test group.
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
"&#x2026;" -- "…"

  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

-- | Markup for a single test.
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
    -- for check mark / cross
    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
"&#x2713;" -- "✓"
      else Text
"&#x2715;" -- "✕"
    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)"

-- vim: textwidth=79 shiftwidth=2