module Parser
( testResults
, TestCase
, TestResult(..)
, FailureReason
, testCase
, testId
, testResult
, failureMessage
, stackTrace
) where
import Prelude hiding (lookup)
import Data.Map (lookup)
import Data.Maybe (fromMaybe)
import Data.Text (pack, unpack, Text, append, strip)
import Text.XML (parseText, def, documentRoot, Element(Element),
nameLocalName, Node(NodeContent, NodeElement),
Name(Name))
import qualified Data.Text.Lazy as L
data FailureReason = FailureReason
{ failureMessage :: Text
, stackTrace :: Text
}
deriving (Show, Eq)
data TestResult = TestSuccess
| TestFailure FailureReason
| UnknownResult Text
deriving (Show, Eq)
data TestCase = TestCase
{ testCase :: Text
, testId :: Int
, testResult :: TestResult
}
deriving (Show, Eq)
testResults :: String -> Either String [TestCase]
testResults results =
case parseText def (L.pack results) of
Left _ -> Left "could not parse"
Right doc -> Right $ accumulateResults (documentRoot doc)
accumulateResults :: Element -> [TestCase]
accumulateResults (Element name a nodes) =
case nameLocalName name of
"test-case" -> return $ TestCase name' (read (unpack id)) testresult
_ -> concatMap accumulateResults children
where children = elements nodes
name' = fromMaybe "" (a !? "name")
id = fromMaybe "?" (a !? "id")
testresult = case fromMaybe "result not found" (a !? "result") of
"Passed" -> TestSuccess
"Failed" -> TestFailure reason
res -> UnknownResult res
reason = case filter (/= Nothing) (findFailure <$> children) of
(Just f:_) -> f
_ -> FailureReason
"<malformed xml>"
"<malformed xml>"
findFailure :: Element -> Maybe FailureReason
findFailure (Element name a nodes) =
case nameLocalName name of
"failure" -> Just $ FailureReason message stacktrace
_ -> case filter (/= Nothing) (findFailure <$> children) of
(f:_) -> f
_ -> Nothing
where children = elements nodes
message = strip . fromMaybe "<no message found>" $
case filter (/= Nothing) (findTag "message" <$> children) of
(m:_) -> m
_ -> Nothing
stacktrace = strip . fromMaybe "<no stack trace found>" $
case filter (/= Nothing) (findTag "stack-trace" <$> children) of
(m:_) -> m
_ -> Nothing
findTag :: Text -> Element -> Maybe Text
findTag tag (Element name a nodes) =
if nameLocalName name == tag then
fromContent (head nodes)
else
case filter (/= Nothing) (findTag tag <$> children) of
(m:_) -> m
_ -> Nothing
where children = elements nodes
elements :: [Node] -> [Element]
elements [] = []
elements (NodeElement e:es) = e : elements es
elements (_:es) = elements es
fromContent :: Node -> Maybe Text
fromContent (NodeContent t) = Just t
fromContent _ = Nothing
(!?) = flip lookup