module Export.Html (htmlRemarks) where
import Ast
import Export.Generic
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 (space <> text attrStr)
doctype :: Doc -> Doc
doctype = ($$) (text "")
html :: Doc -> Doc
html = etag "html"
head_ :: Doc -> Doc
head_ = etag "head"
body :: Doc -> Doc
body = etag "body"
script :: Doc -> Doc
script = atag "script" "type=\"text/javascript\""
style_ :: Doc -> Doc
style_ = etag "style"
table :: Doc -> Doc
table = atag "table" "border=\"1\""
tr :: Doc -> Doc
tr = etag "tr"
trhidden :: Doc -> Doc
trhidden = atag "tr" "style=\"display: none;\""
th :: Doc -> Doc
th = etag "th"
td :: Doc -> Doc
td = etag "td"
toggle :: Doc -> Doc
toggle = atag "a" "href=\"#\" onclick=\"toggleRow(this);\""
ul :: Doc -> Doc
ul = etag "ul"
liclass :: String -> Doc -> Doc
liclass c = atag "li" $ "class=\"" ++ c ++ "\""
tdspan :: Show a => a -> Doc -> Doc
tdspan i = atag "td" $ "colspan=\"" ++ (show i) ++ "\""
details :: Doc -> Doc -> Doc
details d1 d2 = etag "details" ((etag "summary" d1) $$ d2)
documentStyle :: Doc
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.excl:before {content: \"!\"; margin-right: 4px;}" $$
text "li.star:before {content: \"*\"; margin-right: 4px;}"
documentScript :: Doc
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 "}"))
htmlTableHead :: Judgement -> Doc
htmlTableHead (Bonus _) =
tr $ th (text "Bonus")
htmlTableHead (Judgement (_, _, _, js)) =
tr $ th (text "Title") $$ (vcat $ map maketh js) $$ th (text "Total")
where
maketh (Judgement (Header(title, _, maxPoint), _, _, _)) =
th $ text (title ++ "/") <> pointsDoc maxPoint
maketh (Bonus _) =
th $ text "Bonus"
htmlJudgement :: Judgement -> Doc
htmlJudgement (j @ (Bonus (_, _, comments))) =
(tr $ td $ lookupTotal j) $$ (trhidden $ htmlDetailComments comments)
htmlJudgement (j @ (Judgement (_, _, comments, judgements))) =
(tr $ (td . toggle $ lookupTitle j) $$
vcat (map htmlSubJudgement judgements) $$
(td $ lookupTotal j)) $$
(trhidden $ tdspan (length judgements+2) $ (htmlDetailComments comments $$ htmlDetailJudgements judgements))
htmlSubJudgement :: Judgement -> Doc
htmlSubJudgement j = td $ lookupTotal j
htmlDetailJudgements :: [Judgement] -> Doc
htmlDetailJudgements = vcat . (map htmlDetailJudgement)
htmlDetailJudgement :: Judgement -> Doc
htmlDetailJudgement (j @ (Bonus (_, _, comments))) =
details (text "Bonus" <+> parens (lookupTotal j)) (htmlDetailComments comments)
htmlDetailJudgement (j @ (Judgement (_, _, comments, judgements))) =
details
(lookupTitle j <+> parens (lookupTotal j <> text "/" <> lookupMaxPoints j))
(htmlDetailComments comments $$ htmlDetailJudgements judgements)
htmlDetailComments :: [Comment] -> Doc
htmlDetailComments [] = empty
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"
htmlDetailMood Warning = "excl"
htmlDetailCommentPart :: CommentPart -> Doc
htmlDetailCommentPart (CommentStr string) = text string
htmlDetailCommentPart (CommentCmt comment) =
ul $ htmlDetailComment comment