module Test.Tasty.Runners.Html
( HtmlPath(..)
, htmlRunner
) where
import Control.Applicative (Const(..), (<$), pure)
import Control.Monad ((>=>), unless)
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.Foldable (forM_)
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)
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 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 Paths_tasty_html (getDataFileName)
newtype HtmlPath = HtmlPath FilePath deriving (Typeable)
instance IsOption (Maybe HtmlPath) where
defaultValue = Nothing
parseValue = Just . Just . HtmlPath
optionName = Tagged "html"
optionHelp = Tagged "A file path to store the test results in HTML"
htmlRunner :: Ingredient
htmlRunner = TestReporter optionDescription $ \options testTree -> do
HtmlPath path <- lookupOption options
return $ \statusMap -> do
Const summary <- flip evalStateT 0 $ getCompose $ getTraversal $
Tasty.foldTestTree
Tasty.trivialFold { Tasty.foldSingle = runTest statusMap
, Tasty.foldGroup = runGroup
}
options
testTree
generateHtml summary path
return $ getSum (summaryFailures summary) == 0
where
optionDescription = [ Option (Proxy :: Proxy (Maybe HtmlPath)) ]
data Summary = Summary { summaryFailures :: Sum Int
, summarySuccesses :: Sum Int
, htmlRenderer :: Markup
} deriving (Generic)
instance Monoid Summary where
mempty = memptydefault
mappend = mappenddefault
type SummaryTraversal = Traversal (Compose (StateT Int IO) (Const Summary))
runTest :: IsTest t
=> StatusMap -> OptionSet -> TestName -> t -> SummaryTraversal
runTest statusMap _ testName _ = Traversal $ Compose $ do
ix <- State.get
summary <- lift $ atomically $ do
status <- readTVar $
fromMaybe (error "Attempted to lookup test by index outside bounds") $
IntMap.lookup ix statusMap
case status of
Done result
| Tasty.resultSuccessful result -> pure $
mkSuccess testName $ Tasty.resultDescription result
| otherwise ->
pure $ mkFailure testName $ Tasty.resultDescription result
_ -> STM.retry
Const summary <$ State.modify (+1)
runGroup :: TestName -> SummaryTraversal -> SummaryTraversal
runGroup groupName children = Traversal $ Compose $ do
Const soFar <- getCompose $ getTraversal children
let render = testGroupMarkup groupName
grouped = itemMarkup $ do
if summaryFailures soFar > Sum 0
then render "badge badge-important" "text-error"
else render "badge badge-success" "text-success"
treeMarkup $ htmlRenderer soFar
pure $ Const soFar { htmlRenderer = grouped }
generateHtml :: Summary
-> FilePath
-> IO ()
generateHtml summary path = do
let getRead = getDataFileName >=> B.readFile
includeMarkup = getRead >=> return . H.unsafeByteString
includeScript = getRead >=> \bs ->
return . H.unsafeByteString $ "<script>" <> bs <> "</script>"
bootStrapCSS <- includeMarkup "data/bootstrap-combined.min.css"
customCSS <- includeMarkup "data/style.css"
jquery <- includeScript "data/jquery-2.1.0.min.js"
bootstrapTree <- includeScript "data/bootstrap-tree.js"
TIO.writeFile path $
renderHtml $
H.docTypeHtml ! A.lang "en" $
H.head $ do
H.meta ! A.charset "utf-8"
H.title "Tasty Test Results"
H.meta ! A.name "viewport"
! A.content "width=device-width, initial-scale=1.0"
H.style bootStrapCSS
H.style customCSS
jquery
bootstrapTree
H.body $ H.div ! A.class_ "container" $ do
H.h1 ! A.class_ "text-center" $ "Tasty Test Results"
H.div ! A.class_ "row" $
if summaryFailures summary > Sum 0
then
H.div ! A.class_ "alert alert-block alert-error" $
H.p ! A.class_ "lead text-center" $ do
H.toMarkup . getSum $ summaryFailures summary
" out of " :: Markup
H.toMarkup tests
" tests failed"
else
H.div ! A.class_ "alert alert-block alert-success" $
H.p ! A.class_ "lead text-center" $ do
"All " :: Markup
H.toMarkup tests
" tests passed"
H.div ! A.class_ "row" $
H.div ! A.class_ "tree well" $
H.toMarkup $ treeMarkup $ htmlRenderer summary
where
tests = getSum $ summaryFailures summary <> summarySuccesses summary
mkSummary :: Markup -> Summary
mkSummary contents = mempty { htmlRenderer = itemMarkup contents }
mkSuccess :: TestName
-> String
-> Summary
mkSuccess testName desc =
( mkSummary $ testItemMarkup
testName
(Just (desc, "muted"))
"icon-ok-sign"
"badge badge-success"
"text-success"
) { summarySuccesses = Sum 1 }
mkFailure :: TestName
-> String
-> Summary
mkFailure testName desc = undefined
( mkSummary $ testItemMarkup
testName
(Just (desc, "text-error"))
"icon-remove-sign"
"badge badge-important"
"text-error"
) { summaryFailures = Sum 1 }
treeMarkup :: Markup -> Markup
treeMarkup = H.ul ! H.customAttribute "role" "tree"
itemMarkup :: Markup -> Markup
itemMarkup = H.li ! A.class_ "parent_li"
! H.customAttribute "role" "treeitem"
type MaybeCssDescription = Maybe (String, AttributeValue)
type CssIcon = AttributeValue
type CssExtra = AttributeValue
type CssText = AttributeValue
branchMarkup :: String
-> Bool
-> MaybeCssDescription
-> CssIcon
-> CssExtra
-> CssText
-> Markup
branchMarkup name_ isBig mdesc icon extra text = do
H.span ! A.class_ extra $
H.i ! A.class_ icon $ ""
(if isBig then H.h5 else H.h6) ! A.class_ text $
H.toMarkup $ " " ++ name_
forM_ mdesc $ \(desc,desca) ->
unless (null desc) $ do
H.br
H.pre $ H.small ! A.class_ desca $ H.toMarkup desc
testItemMarkup :: TestName
-> MaybeCssDescription
-> CssIcon
-> CssExtra
-> CssText
-> Markup
testItemMarkup testName = branchMarkup testName False
testGroupMarkup :: TestName -> CssExtra -> CssText -> Markup
testGroupMarkup groupName =
branchMarkup groupName True Nothing "icon-folder-open"