{-# 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
  , 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)

-- * 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. \
                        \The following files must be present: \
                        \`bootstrap.min.css`, `bootstrap.min.js`, `jquery-2.1.1.min.js`"

{-| 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 (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))
                      ]

-- 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 -> 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
(<>)

-- | 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 :: 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
      -- If the test is done, return the result
      Done Result
result -> Result -> STM Result
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 (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)

-- | 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 (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 }

-- ** HTML

-- | Generates the final HTML report.
generateHtml :: Summary  -- ^ Test summary.
             -> Tasty.Time -- ^ Total run time.
             -> FilePath -- ^ Where to write.
             -> Maybe AssetsPath -- ^ Path to external assets
             -> IO ()
generateHtml :: Summary -> Time -> String -> Maybe AssetsPath -> IO ()
generateHtml Summary
summary Time
time String
htmlPath Maybe AssetsPath
mAssetsPath = do
      -- Helpers to load external assets
  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
      -- blaze-html 'script' doesn't admit HTML inside
      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>"

  -- Only used when no external assets path specified
  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
  -- Total number of tests
  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 :: Markup -> Summary
mkSummary Markup
contents = Summary
forall a. Monoid a => a
mempty { htmlRenderer :: Markup
htmlRenderer = Markup -> Markup
itemMarkup Markup
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, 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 }

-- | 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, 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 }

-- | Markup representing the branching of a /tree/.
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

-- | Markup representing an /item/ in a /tree/.
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 CssExtra = AttributeValue
type CssText  = AttributeValue

-- | Markup for a button.
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
""

-- | Markup for a test group.
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

-- | Markup for a single test.
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)"

-- vim: textwidth=79 shiftwidth=2