module Parser
( testResults
, TestCase
, TestResult(..)
, FailureReason
, testCase
, testId
, testResult
, failureMessage
, stackTrace
) where
import Prelude hiding (lookup)
import Data.Functor ((<$>))
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