diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -4,6 +4,7 @@ import Parser import Validator import PrettyPrinter +import Collector import Control.Monad ( void, filterM, liftM ) import Data.List ( sort ) @@ -127,6 +128,12 @@ printJs :: [Judgement] -> IO () printJs = putStrLn . ppJs +collect :: [Judgement] -> IO () +collect js = do + case mapM validate js of + Right newJs -> putStrLn $ collectHTML newJs + Left e -> putStrLn $ show e + main :: IO () main = do args <- getArgs @@ -135,4 +142,5 @@ ("parse" : paths) -> parsePaths paths >>= putStrLn . pretty ("check" : paths) -> parsePaths paths >>= mapM_ check ("show" : paths) -> parsePaths paths >>= mapM_ printJs + ("collect" : paths) -> parsePaths paths >>= mapM_ collect (c:args) -> invalidCommand c args diff --git a/remarks.cabal b/remarks.cabal --- a/remarks.cabal +++ b/remarks.cabal @@ -1,11 +1,11 @@ name: remarks -version: 0.1.5 +version: 0.1.6 synopsis: A DSL for marking student work description: A DSL for marking student work; see README.md for further details. homepage: https://github.com/oleks/remarks#readme license: BSD3 license-file: LICENSE -author: Oleks +author: Oleks Shturmov , Michael Kirkedal maintainer: oleks@oleks.info copyright: 2017 DIKU category: Web @@ -21,6 +21,8 @@ , Validator , PrettyPrinter , Config + , Collector + , Collector.Html build-depends: base >= 4.7 && < 5 , GenericPretty >= 1.2.1 , pretty >= 1.1.3.3 diff --git a/src/Collector.hs b/src/Collector.hs new file mode 100644 --- /dev/null +++ b/src/Collector.hs @@ -0,0 +1,9 @@ +module Collector (collectHTML) where + +import Ast +import Collector.Html + +import Text.PrettyPrint + +collectHTML :: [Judgement] -> String +collectHTML = render . htmlRemarks diff --git a/src/Collector/Html.hs b/src/Collector/Html.hs new file mode 100644 --- /dev/null +++ b/src/Collector/Html.hs @@ -0,0 +1,108 @@ +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