module Test.Framework.Runners.XML.JUnitWriter (
RunDescription(..),
serialize, toXml,
#ifdef TEST
morphTestCase
#endif
) where
import Test.Framework.Runners.Core (RunTest(..), FinishedTest)
import Data.Maybe ( fromMaybe )
import Text.XML.Light ( ppTopElement, unqual, unode
, Attr(..), Element(..), QName(..), Content(..))
data RunDescription = RunDescription {
errors :: Int
, failedCount :: Int
, skipped :: Maybe Int
, hostname :: Maybe String
, suiteName :: String
, testCount :: Int
, time :: Double
, timeStamp :: Maybe String
, runId :: Maybe String
, package :: Maybe String
, tests :: [FinishedTest]
} deriving (Show)
serialize :: RunDescription -> String
serialize = ppTopElement . fixClassNames . toXml
where fixClassNames = setAttributeValue (unqual "classname") (setUnsetClassName "<none>")
toXml :: RunDescription -> Element
toXml runDesc = unode "testsuite" (attrs, concatMap morphTestCase $ tests runDesc)
where
attrs :: [Attr]
attrs = map (\(x,f)->Attr (unqual x) (f runDesc)) fields
fields = [ ("errors", show . errors)
, ("failures", show . failedCount)
, ("skipped", fromMaybe "" . fmap show . skipped)
, ("hostname", fromMaybe "" . hostname)
, ("name", id . suiteName)
, ("tests", show . testCount)
, ("time", show . time)
, ("timeStamp", fromMaybe "" . timeStamp)
, ("id", fromMaybe "" . runId)
, ("package", fromMaybe "" . package)
]
morphTestCase :: FinishedTest -> [Element]
morphTestCase (RunTestGroup gname testList) = map (setClassName gname) $
concatMap morphTestCase testList
where
setClassName :: String -> Element -> Element
setClassName group e@(Element _ attribs _ _) =
e { elAttribs=setClassAttr group attribs }
setClassAttr :: String -> [Attr] -> [Attr]
setClassAttr _ [] = []
setClassAttr group (a@(Attr k v):as)
| qName k == "classname" = (Attr k (updateName gname v)):as
| otherwise = a:setClassAttr group as
where
updateName prefix suffix | suffix == "" = prefix
| otherwise = prefix++"."++suffix
morphTestCase (RunTest tName _ (tout, pass)) = case pass of
True -> [unode "testcase" caseAttrs]
False -> [unode "testcase" (caseAttrs, unode "failure" (failAttrs, tout))]
where caseAttrs = [ Attr (unqual "name") tName
, Attr (unqual "classname") ""
, Attr (unqual "time") ""
]
failAttrs = [ Attr (unqual "message") ""
, Attr (unqual "type") ""
]
setAttributeValue :: QName -> (Attr -> Attr) -> Element -> Element
setAttributeValue aName fn e@(Element _ attribs contents _) = e {
elAttribs = map fn attribs
, elContent = map recurse contents }
where
recurse :: Content -> Content
recurse (Elem el) = Elem $ setAttributeValue aName fn el
recurse x = x
setUnsetClassName :: String -> Attr -> Attr
setUnsetClassName newV a@(Attr qn v) | qn == (unqual "classname") && v == "" = a { attrVal = newV }
| otherwise = a