module Collector.Html (htmlRemarks) where
import Ast
import Text.PrettyPrint
htmlRemarks :: [Judgement] -> Doc
htmlRemarks js =
doctype $ html $
(head_ $ documentStyle $$ documentScript) $$
(body . table $ htmlTableHead (head js) $+$ vcat (map htmlJudgement js))
tag :: String -> Doc -> Doc -> Doc
tag tagStr attr doc = (text "<" <> text tagStr <+> attr <> text ">") $$ nest 2 doc $$ text ("")
etag :: String -> Doc -> Doc
etag tagStr = tag tagStr empty
atag :: String -> String -> Doc -> Doc
atag tagStr attrStr = tag tagStr (text attrStr)
doctype = ($$) (text "")
html = etag "html"
head_ = etag "head"
body = etag "body"
script = atag "script" "type=\"text/javascript\""
style_ = etag "style"
table = atag "table" "border=\"1\""
tr = etag "tr"
trhidden = atag "tr" "style=\"display: none;\""
th = etag "th"
td = etag "td"
toggle = atag "a" "href=\"#\" onclick=\"toggleRow(this);\""
ul = etag "ul"
li = etag "li"
liclass c = atag "li" $ "class=\"" ++ c ++ "\""
tdspan i = atag "td" $ "colspan=\"" ++ (show i) ++ "\""
br = text "
"
details d1 d2 = etag "details" ((etag "summary" d1) $$ d2)
documentStyle = style_ $
text "details {padding-left: 16px;}" $$
text "ul {list-style: none; padding-left: 16px; padding-top: 0px; padding-bottom: 0px; margin-top: 0px; margin-bottom: 0px;}" $$
text "li.plus:before {content: \"+\"; margin-right: 4px;}" $$
text "li.minus:before {content: \"-\"; margin-right: 4px;}" $$
text "li.quest:before {content: \"?\"; margin-right: 4px;}" $$
text "li.star:before {content: \"*\"; margin-right: 4px;}"
documentScript = script $
nest 2 ((text "function toggleRow(e){") $$
nest 2 ((text "var subRow = e.parentNode.parentNode.nextElementSibling;") $$
text "subRow.style.display = subRow.style.display === 'none' ? 'table-row' : 'none';") $$
(text "}"))
isIntegral :: Double -> Bool
isIntegral x = x == fromInteger (round x)
pointsDoc :: Double -> Doc
pointsDoc v | isNaN v = empty
pointsDoc v | isIntegral v = integer (round v)
pointsDoc v = double v
htmlTableHead :: Judgement -> Doc
htmlTableHead (Judgement (_, _, js)) =
tr $ th (text "Title") $$ (vcat $ map maketd js) $$ th (text "Total")
where
maketd (Judgement (Header(title, _, maxPoint), _, _)) = th $ text (title ++ "/") <> pointsDoc maxPoint
htmlJudgement :: Judgement -> Doc
htmlJudgement (Judgement (Header(title, points, maxPoint), comments, judgements)) =
(tr $ (td . toggle $ text title) $$ vcat (map htmlSubJudgement judgements) $$ (td $ pointsDoc points)) $$
(trhidden $ tdspan (length judgements+2) $ (htmlDetailComments comments $$ htmlDetailJudgements judgements))
htmlSubJudgement :: Judgement -> Doc
htmlSubJudgement (Judgement (Header(title, points, maxPoint), comments, judgements)) =
(td $ pointsDoc points)
htmlDetailJudgements :: [Judgement] -> Doc
htmlDetailJudgements = vcat . (map htmlDetailJudgement)
htmlDetailJudgement :: Judgement -> Doc
htmlDetailJudgement (Judgement (Header(title, points, maxPoint), comments, judgements)) =
details
(text title <> parens (pointsDoc points <> text "/" <> pointsDoc maxPoint))
(htmlDetailComments comments $$ htmlDetailJudgements judgements)
htmlDetailComments :: [Comment] -> Doc
htmlDetailComments [] = text ""
htmlDetailComments comments =
ul . vcat $ map htmlDetailComment comments
htmlDetailComment :: Comment -> Doc
htmlDetailComment (Comment (mood, commentParts)) =
liclass (htmlDetailMood mood) $ vcat $ map htmlDetailCommentPart commentParts
htmlDetailMood :: Mood -> String
htmlDetailMood Positive = "plus"
htmlDetailMood Negative = "minus"
htmlDetailMood Neutral = "star"
htmlDetailMood Impartial = "quest"
htmlDetailCommentPart :: CommentPart -> Doc
htmlDetailCommentPart (CommentStr string) = text string
htmlDetailCommentPart (CommentCmt comment) =
ul $ htmlDetailComment comment