module NLP.GenI.Report where
import Control.Applicative
import Control.Monad
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Char (isDigit, toLower)
import Data.Function (on)
import Data.List
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Version (showVersion)
import Prelude hiding (readFile)
import qualified Prelude as P
import System.Directory
import System.Environment
import System.FilePath
import System.IO
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
import Text.Blaze.Html5 hiding (map)
import qualified Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes
import qualified Text.Blaze.Html5.Attributes as A
import Text.JSON hiding (Result)
import qualified Text.JSON as J
import NLP.GenI
import NLP.GenI.GeniShow
import NLP.GenI.GeniVal
import NLP.GenI.Parser
import NLP.GenI.Semantics
createReport :: FilePath -> FilePath -> IO FilePath
createReport idir odir_ = do
mres <- readResults idir
res <- case mres of
Just x -> return [x]
Nothing -> do
subdirs <- map (idir </>) <$> getRealDirectoryContents idir
catMaybes <$> mapM readResults subdirs
odir <- case odir_ of
"" -> do
tmp <- getTemporaryDirectory
let dir = tmp </> "genireport"
hPutStrLn stderr $ "Report will be saved in " ++ dir
return dir
o -> do
createDirectoryIfMissing False o
return o
BL.writeFile (odir </> "report.html") $ renderHtml (mkSummary res)
BL.writeFile (odir </> "details.html") $ renderHtml (mkDetailsSummary res)
return odir
readResults :: FilePath -> IO (Maybe Section)
readResults d = do
cases <- getRealDirectoryContents d
isAllCases <- and <$> mapM isCase cases
if isAllCases
then Just . (d,) <$> mapM readCase cases
else return Nothing
where
isCase c = isTestCaseDir (d </> c)
readDerivationsFile t =
if T.null t
then J.Ok []
else J.decode (T.unpack t)
readCase c = do
let dc = d </> c
derivFile = dc </> "derivations"
mderivs <- readFileIfExists (J.Ok []) readDerivationsFile derivFile
derivs <- case mderivs of
J.Error err -> fail ("When reading " ++ derivFile ++ ": " ++ err)
J.Ok x -> return x
msem <- parseFromFile geniSemanticInput (dc </> "semantics")
sem <- case msem of
Left err -> fail (show err)
Right s -> return s
Result (T.pack c) sem
<$> (T.lines <$> readFileUtf8 (dc </> "responses"))
<*> readFileIfExists [] T.lines (dc </> "warnings")
<*> pure derivs
isTestCaseDir :: FilePath -> IO Bool
isTestCaseDir d = doesFileExist (d </> "semantics")
data Result = Result
{ reKey :: Text
, reSemInput :: SemInput
, reRealisations :: [Text]
, reWarnings :: [Text]
, reDerivation :: [GeniResult]
}
type Section = (FilePath, [Result])
mkReport :: Html -> Html -> ([Result] -> Html) -> [Section] -> Html
mkReport scriptsStyles header mkTable xs = do
H.head $ do
H.link ! rel "stylesheet" ! type_ "text/css" ! href "report.css"
H.script "" ! type_ "text/javascript" ! src "jquery-1.6.2.min.js"
H.script "" ! type_ "text/javascript" ! src "jquery.tablesorter.min.js"
scriptsStyles
H.body $ do
header
overviewTable xs
forM_ xs $ \(takeBaseName -> name, res) -> do
H.h1 (H.a (toHtml name) ! A.id (H.toValue name))
mkTable res
overviewTable :: [Section] -> Html
overviewTable rs =
table content ! A.id "summaryTable" ! class_ "tablesorter"
where
content = do
thead . tr $ do
th "suite" ! colspan "2"
th "pass (has results)"
th "fail (no results)"
th "total"
tbody $ mapM_ overviewRow rs
overviewRow :: Section -> Html
overviewRow (takeBaseName -> name,res) =
tr cells
where
cells = do
td (return ()) ! class_ sectionStatus
td (H.a (toHtml name) ! A.href (H.toValue anchor))
td (toHtml (length pass))
td (toHtml (length fail))
td (toHtml (length res))
anchor = H.toValue $ "#" ++ name
(fail, pass) = partition (null . reRealisations) res
sectionStatus
| length fail >= 1 = "failure"
| otherwise = "success"
mkSummary :: [Section] -> Html
mkSummary =
mkReport scriptsStyles header summaryTable
where
scriptsStyles = H.script . toHtml $ unlines
[ "$(document).ready(function()"
, " {"
, " $(\".tablesorter\").tablesorter();"
, " }"
, ");"
]
header = do
H.h1 "Summary"
H.a "More details" ! A.href "details.html"
summaryTable :: [Result] -> Html
summaryTable rs =
table content ! class_ "tablesorter"
where
content = do
thead . tr $ do
th "case" ! colspan "2"
th "results"
th "warnings"
tbody $ forM_ rs summaryRow
summaryRow :: Result -> Html
summaryRow r@(Result {..}) =
tr cells
where
cells = do
td (return ()) ! class_ (status r)
td (prettyKey reKey)
td (toHtml (length reRealisations))
td (toHtml (length reWarnings))
status :: Result -> AttributeValue
status (Result {..})
| length reRealisations == 0 = "failure"
| length reWarnings > 0 = "warnings"
| otherwise = "success"
mkDetailsSummary :: [Section] -> Html
mkDetailsSummary =
mkReport scriptsStyles header detailsTable
where
scriptsStyles = do
H.style . toHtml . unlines $
[ "td { border-bottom-style: solid; border-bottom-width: 1px; }"
, ".count { color: grey } "
, ".mute { color: grey } "
]
H.script . toHtml . unlines $
[ "$(document).ready(function()"
, " {"
, " $(\".tablesorter\").tablesorter();"
, " }"
, ");"
]
header = do
H.h1 "Details"
H.a "Summary" ! A.href "report.html"
detailsTable :: [Result] -> Html
detailsTable rs =
table content ! class_ "tablesorter"
where
content = do
thead . tr $ do
th "case" ! colspan "2"
th "results" ! colspan "2"
th "warnings" ! colspan "2"
tbody $ forM_ rs detailsRow
detailsRow :: Result -> Html
detailsRow r@(Result {..}) =
tr cells
where
cells = do
td (return ()) ! class_ (status r)
td (H.span tcName ! A.style "width:60em; display: inline-block;")
td (toHtml (length reRealisations))
td (toHtml (unlinesCountHtml reRealisations))
td (toHtml (length reWarnings))
td (toHtml (unlinesCountHtml . concatMap expandCount $ reWarnings))
traces = [ lcSort . nub $ concatMap nlTrace $ grLexSelection g | GSuccess g <- reDerivation ]
tcName = do
prettyKey reKey
br
H.div (semInputToHtml reSemInput) ! A.style "margin-top: 1em;"
br
H.div (sequence_ . intersperse br $ map (toHtml . T.unwords) traces)
semInputToHtml :: SemInput -> Html
semInputToHtml (sem,icons,lcons) = do
keyword "semantics"
squares $ sequence_ . intersperse sp $ map withConstraints sem
unless (null icons) $ do
br
keyword "idxconstraints"
squares $ toHtml (geniShow icons)
where
keyword :: String -> Html
keyword txt = H.span (toHtml txt)
mute = class_ "mute"
sp = toHtml (" " :: String)
withConstraints lit = toHtml lit >> constraints lit
constraints lit =
case concat [ cs | (p,cs) <- lcons, p == lit ] of
[] -> return ()
cs -> squares (toHtml (T.unwords cs) ! mute)
squares x = do
H.span (toHtml ("[" :: Text))
x
H.span (toHtml ("]" :: Text))
instance ToMarkup (Literal GeniVal) where
toMarkup (Literal h p l) = do
H.span (toHtml (geniShow h ++ ":")) ! mute
toMarkup (geniShow p ++ "(" ++ unwords (map geniShow l) ++ ")")
where
mute = class_ "mute"
prettyKey :: Text -> Html
prettyKey = toHtml
expandCount :: Text -> [Text]
expandCount x =
maybe [x] exp (T.stripSuffix suff x)
where
exp t =
replicate count msg
where
msg = T.dropWhileEnd isDigit t
count = read . T.unpack
. T.dropWhile (not . isDigit)
. T.drop (T.length msg) $ t
suff = " times)"
unlinesCountHtml :: [Text] -> Html
unlinesCountHtml =
sequence_ . intersperse br . map htmlC . groupAndCount
where
htmlC (s, 1) = toHtml s
htmlC (s, c) = toHtml s >> " " >> H.span ("⨉" >> toHtml c) ! class_ "count"
dataFiles :: [FilePath]
dataFiles =
[ "jquery-1.6.2.min.js"
, "jquery.tablesorter.min.js"
, "asc.gif"
, "bg.gif"
, "desc.gif"
, "report.css"
]
lcSort :: [Text] -> [Text]
lcSort = sortBy (compare `on` T.toLower)
readFileIfExists :: a -> (Text -> a) -> FilePath -> IO a
readFileIfExists z job f = do
x <- doesFileExist f
if x then job <$> readFileUtf8 f
else return z
readFileUtf8 :: FilePath -> IO Text
readFileUtf8 f = T.decodeUtf8 <$> B.readFile f
groupAndCount :: (Eq a, Ord a) => [a] -> [(a, Int)]
groupAndCount xs =
map (\x -> (P.head x, length x)) grouped
where grouped = (group . sort) xs
dropPrefix :: Eq a => [a] -> [a] -> ([a],[a])
dropPrefix (x:xs) (y:ys) | x == y = dropPrefix xs ys
dropPrefix left right = (left,right)
getRealDirectoryContents :: FilePath -> IO [String]
getRealDirectoryContents d =
filter (not . (`elem` [".",".."])) <$> getDirectoryContents d