remarks 0.1.5 → 0.1.6
raw patch · 4 files changed
+129/−2 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Collector: collectHTML :: [Judgement] -> String
+ Collector.Html: htmlRemarks :: [Judgement] -> Doc
Files
- app/Main.hs +8/−0
- remarks.cabal +4/−2
- src/Collector.hs +9/−0
- src/Collector/Html.hs +108/−0
app/Main.hs view
@@ -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
remarks.cabal view
@@ -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 <oleks@oleks.info>, 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
+ src/Collector.hs view
@@ -0,0 +1,9 @@+module Collector (collectHTML) where++import Ast+import Collector.Html++import Text.PrettyPrint++collectHTML :: [Judgement] -> String+collectHTML = render . htmlRemarks
+ src/Collector/Html.hs view
@@ -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 ("</" ++ tagStr ++ ">") ++etag :: String -> Doc -> Doc+etag tagStr = tag tagStr empty++atag :: String -> String -> Doc -> Doc+atag tagStr attrStr = tag tagStr (text attrStr)++doctype = ($$) (text "<!DOCTYPE html>")+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 "<br>"++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