packages feed

remarks 0.1.11 → 0.1.12

raw patch · 13 files changed

+301/−150 lines, 13 files

Files

README.md view
@@ -24,19 +24,6 @@ student work with external examiners, who are not always willing to use more explicit version-control systems, such as git. -## Status--There is:-* a [parser](src/Parser/Impl.hs);-* a (basic) [validator](src/Validator.hs); and-* a [pretty printer](src/PrettyPrinter.hs).--These can be invoked using `remarks parse`, `remarks check`, and `remarks-show`, respectively.--See [Issues](https://github.com/DIKU-EDU/remarks/issues) for a roadmap. Feel free-to add or fix a couple issues.- ## Usage  User features:
app/Main.hs view
@@ -155,6 +155,18 @@     Right newJs -> putStrLn $ exportHTML newJs     Left e -> putStrLn $ show e +export_table :: [Judgement] -> IO ()+export_table js = do+  case (mapM interpProps js) of+    Right newJs -> putStrLn $ exportHTMLTable newJs+    Left e -> putStrLn $ show e++export_md :: [Judgement] -> IO ()+export_md js = do+  case (mapM interpProps js) of+    Right newJs -> putStrLn $ exportMD newJs+    Left e -> putStrLn $ show e+ showSummary :: Word -> [Judgement] -> IO () showSummary depth js = do   case marshall js of@@ -197,6 +209,10 @@       with paths $ mapM_ $ export format     ("export" : paths) ->       with paths $ mapM_ $ export "Title;Total;MaxPoints"+    ("exportTable" : paths) ->+      with paths $ mapM_ export_table+    ("exportMD" : paths) ->+      with paths $ mapM_ export_md     ("exportHTML" : paths) ->       with paths $ mapM_ export_html     (c:rest) -> invalidCommand c rest
remarks.cabal view
@@ -1,5 +1,5 @@ name:                remarks-version:             0.1.11+version:             0.1.12 synopsis:            A DSL for marking student work description:         A DSL for marking student work; see README.md for further details. homepage:            https://github.com/DIKU-EDU/remarks#readme
src/Ast.hs view
@@ -24,6 +24,7 @@   | Negative   | Neutral   | Impartial+  | Warning   deriving (Eq, Show, Generic)  instance Out Mood@@ -49,6 +50,7 @@  data PropertyExp   = Lookup (Int, String)+  | Sum String   | Value  String   | Num  Double   deriving (Eq, Show, Generic)@@ -57,7 +59,22 @@  data Judgement   = Judgement (Header, [Property], [Comment], [Judgement])-  | Bonus (Double, [Comment])+  | Bonus (Double, [Property], [Comment])   deriving (Eq, Show, Generic)  instance Out Judgement+++isLeafJ :: Judgement -> Bool+isLeafJ (Judgement (_, _, _, []))    = True+isLeafJ (Judgement (_, _, _, (_:_))) = False+isLeafJ (Bonus _)                    = False++isNodeJ :: Judgement -> Bool+isNodeJ (Judgement (_, _, _, []))    = False+isNodeJ (Judgement (_, _, _, (_:_))) = True+isNodeJ (Bonus _)                    = False++isBonus :: Judgement -> Bool+isBonus (Bonus _)     = True+isBonus (Judgement _) = False
src/Export.hs view
@@ -1,10 +1,12 @@-module Export (exportHTML, exportCSV, unify, summary) where+module Export (exportHTML, exportCSV, exportHTMLTable, exportMD, unify, summary) where  import Ast import Invalid import Export.Html import Export.CSV-import Export.Generic ( unify, summary )+import Export.HtmlTable+import Export.MD+import Export.Generic ( unify, summary, toHTML, transp )  import Text.PrettyPrint @@ -14,3 +16,8 @@ exportCSV :: String -> [String] -> [Judgement] -> Either Invalid String exportCSV delim ps js = (pure . render) =<< csvRemarks delim ps js +exportHTMLTable :: [Judgement] -> String+exportHTMLTable js = toHTML $ transp $ htmlTableRemarks js++exportMD :: [Judgement] -> String+exportMD js = mdRemarks js
src/Export/Generic.hs view
@@ -3,27 +3,54 @@ import Ast import Text.PrettyPrint +import Data.List (intersperse, transpose)++data Table+  = Rows [Row]+  | Cols [Col]+  deriving (Eq, Show)++type Row = [Elem]+type Col = [Elem]+type Elem = String++reformat :: Table -> Table+reformat (Rows t) = Cols $ transpose t+reformat (Cols t) = Rows $ transpose t++transp :: Table -> Table+transp (Rows t) = Cols t+transp (Cols t) = Rows t++toCSV :: String -> Table -> String+toCSV s (t@(Cols _)) = toCSV s $ reformat t+toCSV s (Rows rs) = concat $ intersperse "\n" $ map formatRow rs+  where+    formatRow r  = concat $ intersperse s $ map formatElem r+    formatElem e = e -- Currently only string to string++toHTML :: Table -> String+toHTML (t@(Cols _)) = toHTML $ reformat t+toHTML (Rows rs) = "<table>" ++ (concatMap formatRow rs) ++ "</table>"+  where+    formatRow r  = "<tr>" ++ (concatMap formatElem r) ++ "</tr>"+    formatElem e = "<td>" ++ e ++ "</td>"+ isIntegral :: Double -> Bool isIntegral x = x == fromInteger (round x)  pointsDoc :: Double -> Doc-pointsDoc v | isInfinite v = empty+pointsDoc v | isInfinite v = text "*" pointsDoc v | isNaN v = empty pointsDoc v | isIntegral v = integer (round v) pointsDoc v = double v -lookupProperty :: String -> Judgement -> Maybe Doc-lookupProperty name (Judgement (_, properties, _, _)) =-  case (lookup name (map (\(Property (n,v)) -> (n,v)) properties)) of-    Nothing -> Nothing-    Just(value) -> pure $ formatPropertyExp value-lookupProperty _ _ = Nothing -- Bonus does not have properties--formatPropertyExp :: PropertyExp -> Doc-formatPropertyExp (Lookup (index, name)) =+propertyExpDoc :: PropertyExp -> Doc+propertyExpDoc (Lookup (index, name)) =   brackets $ int index <> text "." <> text name-formatPropertyExp (Value value) = text value-formatPropertyExp (Num value) = pointsDoc value+propertyExpDoc (Value value) = text value+propertyExpDoc (Num value) = pointsDoc value+propertyExpDoc (Sum str) = text "sum" <> (parens $ text str)  unify :: Judgement -> Judgement -> Maybe Judgement unify@@ -42,9 +69,48 @@ unify _ _ = Nothing  summary :: Word -> Judgement -> Judgement-summary _ (Bonus (p, _)) =-  (Bonus (p, []))-summary 0 (Judgement (h, _, _, _)) =-  Judgement (h, [], [], [])+summary _ (Bonus (h, prop, _)) =+  (Bonus (h, prop, []))+summary 0 (Judgement (h, _, p, _)) =+  Judgement (h, [], p, []) summary depth (Judgement (h, _, _, js)) =   Judgement (h, [], [], map (summary $ depth - 1) js)++-- For retrieval of property values++lookupProperty :: String -> Judgement -> Maybe Doc+lookupProperty name (Judgement (_, properties, _, _)) =+  case (lookup name (map (\(Property (n,v)) -> (n,v)) properties)) of+    Nothing -> Nothing+    Just(value) -> pure $ propertyExpDoc value+lookupProperty name (Bonus (_, properties, _)) =+  case (lookup name (map (\(Property (n,v)) -> (n,v)) properties)) of+    Nothing -> Nothing+    Just(value) -> pure $ propertyExpDoc value++lookupTotal :: Judgement -> Doc+lookupTotal j =+  case lookupProperty "Total" j of+    Nothing -> error $ "Total not found. Please report!"+    Just d  -> d++lookupMaxPoints :: Judgement -> Doc+lookupMaxPoints j =+  case lookupProperty "MaxPoints" j of+    Nothing -> error "MaxPoint not found. Please report!"+    Just d  -> d++lookupTitle :: Judgement -> Doc+lookupTitle j =+  case lookupProperty "Title" j of+    Nothing -> error "Title not found. Please report!"+    Just d  -> d++getTotal :: Judgement -> String+getTotal = render . lookupTotal++getTitle :: Judgement -> String+getTitle = render . lookupTitle++getMaxPoints :: Judgement -> String+getMaxPoints = render . lookupMaxPoints
src/Export/Html.hs view
@@ -75,6 +75,7 @@   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@@ -88,37 +89,34 @@ htmlTableHead (Bonus _) =   tr $ th (text "Bonus") htmlTableHead (Judgement (_, _, _, js)) =-  tr $ th (text "Title") $$ (vcat $ map maketd js) $$ th (text "Total")+  tr $ th (text "Title") $$ (vcat $ map maketh js) $$ th (text "Total")   where-    maketd (Judgement (Header(title, _, maxPoint), _, _, _)) =+    maketh (Judgement (Header(title, _, maxPoint), _, _, _)) =       th $ text (title ++ "/") <> pointsDoc maxPoint-    maketd (Bonus _) =+    maketh (Bonus _) =       th $ text "Bonus"  htmlJudgement :: Judgement -> Doc-htmlJudgement (Bonus (points, comments)) =-  (tr $ td $ pointsDoc points) $$ (trhidden $ htmlDetailComments comments)-htmlJudgement (Judgement (Header(title, points, _), _, comments, judgements)) =-  (tr $ (td . toggle $ text title) $$+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 $ pointsDoc points)) $$+    (td $ lookupTotal j)) $$   (trhidden $ tdspan (length judgements+2) $ (htmlDetailComments comments $$ htmlDetailJudgements judgements))  htmlSubJudgement :: Judgement -> Doc-htmlSubJudgement (Bonus (points, _)) =-  (td $ pointsDoc points)-htmlSubJudgement (Judgement (Header(_, points, _), _, _, _)) =-  (td $ pointsDoc points)+htmlSubJudgement j = td $ lookupTotal j  htmlDetailJudgements :: [Judgement] -> Doc htmlDetailJudgements = vcat . (map htmlDetailJudgement)  htmlDetailJudgement :: Judgement -> Doc-htmlDetailJudgement (Bonus (points, comments)) =-  details (text "Bonus" <+> parens (pointsDoc points)) (htmlDetailComments comments)-htmlDetailJudgement (Judgement (Header(title, points, maxPoint), _, comments, judgements)) =+htmlDetailJudgement (j @ (Bonus (_, _, comments))) =+  details (text "Bonus" <+> parens (lookupTotal j)) (htmlDetailComments comments)+htmlDetailJudgement (j @ (Judgement (_, _, comments, judgements))) =   details-    (text title <+> parens (pointsDoc points <> text "/" <> pointsDoc maxPoint))+    (lookupTitle j <+> parens (lookupTotal j <> text "/" <> lookupMaxPoints j))     (htmlDetailComments comments $$ htmlDetailJudgements judgements)  htmlDetailComments :: [Comment] -> Doc@@ -135,6 +133,7 @@ htmlDetailMood Negative  = "minus" htmlDetailMood Neutral   = "star" htmlDetailMood Impartial = "quest"+htmlDetailMood Warning   = "excl"  htmlDetailCommentPart :: CommentPart -> Doc htmlDetailCommentPart (CommentStr string) = text string
src/Invalid.hs view
@@ -9,27 +9,27 @@ import Text.PrettyPrint.GenericPretty  data Invalid-  = PointsExceedMaxPoints Judgement-  | BadSubJudgementPointsSum Judgement-  | BadSubJudgementMaxPointsSum Judgement-  | NoPointsInBottomJudgement Judgement+  = PointsExceedMaxPoints String Judgement+  | BadSubJudgementPointsSum String Judgement+  | BadSubJudgementMaxPointsSum String Judgement+  | NoPointsInBottomJudgement String Judgement   | PropertyNotFound String Judgement   deriving (Eq, Show, Generic)  instance Out Invalid  reportInvalid :: Invalid -> String-reportInvalid (PointsExceedMaxPoints (j @ (Judgement ((Header (_, p, m)), _, _, _)))) =-    "The total points (" ++ ppPoints p ++ ") exceeded maximum (" ++ ppPoints m ++ ") in the judgement\n" +++reportInvalid (PointsExceedMaxPoints s (j @ (Judgement ((Header (_, p, m)), _, _, _)))) =+    "In " ++ s ++ " the total points (" ++ ppPoints p ++ ") exceeded maximum (" ++ ppPoints m ++ ") in the judgement\n" ++     reportStrippedJudgement j-reportInvalid (BadSubJudgementPointsSum (j @ (Judgement (Header (_, p, _), _, _, _)))) =-    "The sum of points (" ++ ppPoints p ++ ") in judgement is not the sum of sub-judgements\n" +++reportInvalid (BadSubJudgementPointsSum s (j @ (Judgement (Header (_, p, _), _, _, _)))) =+    "In " ++ s ++ " the sum of points (" ++ ppPoints p ++ ") in judgement is not the sum of sub-judgements\n" ++     reportJudgement 0 j-reportInvalid (BadSubJudgementMaxPointsSum (j @ (Judgement (Header (_, _, m), _, _, _)))) =-    "The maximum points (" ++ ppPoints m ++ ") in judgement is not the sum of sub-judgements\n" +++reportInvalid (BadSubJudgementMaxPointsSum s (j @ (Judgement (Header (_, _, m), _, _, _)))) =+    "In " ++ s ++ " the maximum points (" ++ ppPoints m ++ ") in judgement is not the sum of sub-judgements\n" ++     reportJudgement 0 j-reportInvalid (NoPointsInBottomJudgement j) = -  "No points reported in leaf-judgement\n" ++ reportStrippedJudgement j+reportInvalid (NoPointsInBottomJudgement s j) = +  "In " ++ s ++ " no points reported in leaf-judgement\n" ++ reportStrippedJudgement j reportInvalid (PropertyNotFound s j) =    "Property " ++ s ++ " not found in judgement\n" ++ reportJudgement 0 j reportInvalid m = "Cannot parse error message\n" ++ show m ++ "\nPlease report this message to someone!"@@ -38,7 +38,7 @@ reportJudgement d j | isLeafJ j = ppJ_d d (stripJ j) reportJudgement 1 j | isNodeJ j = (ppJ_d 1 $ stripJ j) ++ "\n  ..." reportJudgement 0 j | isNodeJ j = -  (ppJ_d 0 $ stripJ j) ++ (concat $ intersperse "\n" (map (reportJudgement 1) (subJs j)))+  (ppJ_d 0 $ stripJ j) ++ "\n" ++ (concat $ intersperse "\n" (map (reportJudgement 1) (subJs j))) reportJudgement _ _ = ""  reportStrippedJudgement :: Judgement -> String@@ -53,13 +53,3 @@ stripJ :: Judgement -> Judgement stripJ (Judgement (h, _, _, _)) = Judgement (h, [], [], []) stripJ b = b -- Bunus--isLeafJ :: Judgement -> Bool-isLeafJ (Judgement (_, _, _, []))    = True-isLeafJ (Judgement (_, _, _, (_:_))) = False-isLeafJ (Bonus _)                    = False--isNodeJ :: Judgement -> Bool-isNodeJ (Judgement (_, _, _, []))    = False-isNodeJ (Judgement (_, _, _, (_:_))) = True-isNodeJ (Bonus _)                    = False
src/Parser/Impl.hs view
@@ -11,8 +11,8 @@ import Data.Maybe ( listToMaybe )  data ParseErrorImpl a-  = NoParse-  | AmbiguousGrammar [a]+  = NoParse FilePath+  | AmbiguousGrammar [a] FilePath   | NotImplemented   deriving (Eq, Show, Generic) @@ -28,20 +28,26 @@ maybeRead = fmap fst . listToMaybe . reads  parsePoints :: ReadP Double-parsePoints = do-  is <- parseIntegral-  fs <- (string ".5") +++ pure "0"-  case (maybeRead (is ++ "." ++ fs)) of-    Just x -> pure x-    _ -> pfail--parseMaxPoints :: ReadP Double-parseMaxPoints = do-  is <- parseIntegral-  fs <- (string ".5") +++ pure "0"-  case (maybeRead (is ++ "." ++ fs)) of-    Just x -> pure x-    _ -> pfail+parsePoints = choice [p3, p2, p1]+  where+    p1 = do+      is <- parseIntegral+      case (maybeRead is) of+        Just x -> pure x+        _ -> pfail+    p2 = do+      is <- parseIntegral+      void $ char '.'+      fs <- parseIntegral+      case (maybeRead (is ++ "." ++ fs)) of+        Just x -> pure x+        _ -> pfail+    p3 = do+      void $ char '.'+      fs <- parseIntegral+      case (maybeRead ("0." ++ fs)) of+        Just x -> pure x+        _ -> pfail  lineToken :: ReadP a -> ReadP a lineToken p = munch (`elem` [' ', '\t', '\r', '\v', '\f']) *> p@@ -58,7 +64,7 @@   points <- parsePoints   void $ lineBreak   comments <- many parseComment'-  pure $ Bonus (points, comments)+  pure $ Bonus (points, [], comments)  parsePropertyExp :: ReadP PropertyExp parsePropertyExp = choice [lookupProp, value]@@ -90,7 +96,7 @@ parseRegularJudgement depth title = do   points <- (lineToken $ parsePoints) +++ (return $ 1/0)   void $ lineToken $ char '/'-  maxPoints <- lineToken $ parseMaxPoints+  maxPoints <- lineToken $ parsePoints   void $ lineBreak    let header = Header (title, points, maxPoints)@@ -117,6 +123,7 @@   , char '-' *> pure Negative   , char '*' *> pure Neutral   , char '?' *> pure Impartial+  , char '!' *> pure Warning   ]  parseLine :: ReadP String@@ -153,21 +160,21 @@ fullParse :: ReadP a -> String -> [a] fullParse p s = fmap fst $ parse (p <* (skipSpaces >> eof)) s -parseString' :: ReadP a -> String -> Either (ParseErrorImpl a) a-parseString' p s =+parseString' :: ReadP a -> FilePath -> String -> Either (ParseErrorImpl a) a+parseString' p path s =   case fullParse p s of-    [] -> Left NoParse+    [] -> Left $ NoParse path     [a] -> Right a-    as -> Left $ AmbiguousGrammar as+    as -> Left $ AmbiguousGrammar as path  parseEntry :: ReadP [Judgement] parseEntry = parseJudgements 1 <* skipSpaces  parseString :: String -> Either ParseError [Judgement]-parseString = parseString' parseEntry+parseString = parseString' parseEntry "String"  parseFile' :: ReadP a -> FilePath -> IO (Either (ParseErrorImpl a) a)-parseFile' p path = fmap (parseString' p) $ readFile path+parseFile' p path = fmap (parseString' p path) $ readFile path  parseFile :: FilePath -> IO (Either ParseError [Judgement]) parseFile = parseFile' parseEntry
src/Pending.hs view
@@ -4,10 +4,11 @@  import Ast -import Data.Tree import Text.PrettyPrint -type PendingTree = Tree String+data PendingTree+  = Node String Int Bool [PendingTree]+  deriving (Eq, Show)  data FormatTree   = TEmpty  FormatTree@@ -15,6 +16,8 @@   | TBranch FormatTree   | TNode   | TLeaf+  | TQuest+  deriving (Eq, Show)  showTree :: FormatTree -> Doc showTree (TEmpty t)  = showTree t@@ -22,53 +25,85 @@ showTree (TSpace t)  = text "   " <> showTree t showTree TNode       = text " |- " showTree TLeaf       = text " |> "+showTree TQuest      = text " |? "  linebreak :: Doc linebreak = text "\n" +isLeaf :: PendingTree -> Bool+isLeaf (Node _ _ _ [])    = True+isLeaf (Node _ _ _ (_:_)) = False+ formatTree :: PendingTree -> Doc formatTree t = formatSubTree (TEmpty) t  formatSubTrees :: (FormatTree -> FormatTree) -> [PendingTree] -> Doc formatSubTrees _ [] = empty-formatSubTrees ft [(Node s [])] =-  showTree (ft TLeaf) <> text s+formatSubTrees ft [t] | isLeaf t =+  linebreak <> showTree (ft TLeaf) <> formatSubTree (ft . TSpace) t formatSubTrees ft [t] =-  showTree (ft TNode) <> formatSubTree (ft . TSpace) t-formatSubTrees ft ((Node s []):ts) =-  showTree (ft TLeaf) <> text s <> linebreak <>-  (formatSubTrees ft ts)+  linebreak <> showTree (ft TNode) <> formatSubTree (ft . TSpace) t+formatSubTrees ft (t:ts) | isLeaf t =+  linebreak <> showTree (ft TLeaf) <> formatSubTree (ft . TBranch) t <>+  formatSubTrees ft ts formatSubTrees ft (t:ts) =-  showTree (ft TNode) <> formatSubTree (ft . TBranch) t <> linebreak <>-  (formatSubTrees ft ts)+  linebreak <> showTree (ft TNode) <> formatSubTree (ft . TBranch) t <>+  formatSubTrees ft ts  formatSubTree :: (FormatTree -> FormatTree) -> PendingTree -> Doc-formatSubTree _ (Node s []) =-  text s-formatSubTree tree (Node s ts) =-  text s <> linebreak <> formatSubTrees tree ts+formatSubTree ft (Node s cs _ ts) = text s <> formatTreeComments ft cs <> formatSubTrees ft ts -size :: PendingTree -> Int-size (Node _ []) = 1-size (Node _ (t @ (_:_))) = sum $ map size t+formatTreeComments :: (FormatTree -> FormatTree) -> Int -> Doc+formatTreeComments _ 0 = empty+formatTreeComments ft cs =+  linebreak <> showTree (ft TQuest) <> text (makePlural cs "impartial comment") +size :: PendingTree -> (Int, Int)+size (Node _ cs True []) = (1, cs)+size (Node _ cs False []) = (0, cs)+size (Node _ cs _ pt) = foldl tupAdd (0, cs) $ map size pt+  where tupAdd a b = (fst a + fst b, snd a + snd b)+ limitPendingTree :: Int -> PendingTree -> PendingTree-limitPendingTree _ (Node t []) = (Node t [])-limitPendingTree 0 (Node t sub) = (Node (t ++ showTasks (sum $ map size sub)) [])-limitPendingTree n (Node t sub) = (Node t (map (limitPendingTree (n-1)) sub))+limitPendingTree _    (Node s 0 b [])  = Node s 0 b []+limitPendingTree 0 (t@(Node s _ b _))  = Node (s ++ showTasks (size t)) 0 b []+limitPendingTree n    (Node s cs b ts) = Node s cs b (map (limitPendingTree (n-1)) ts) -showTasks :: Int -> String-showTasks 1 = " (1 task)"-showTasks n = " (" ++ (show n) ++ " tasks)"+showTasks :: (Int, Int) -> String+showTasks (n, 0) = " (" ++ makePlural n "task" ++ ")"+showTasks (0, m) = " (" ++ makePlural m "comment" ++ ")"+showTasks (n, m) = " (" ++ makePlural n "task" ++ " and " ++ makePlural m "comment" ++ ")" +makePlural :: Int -> String -> String+makePlural 0 s = "0 " ++ s ++ "s"+makePlural 1 s = "1 " ++ s+makePlural n s = show n ++ " " ++ s ++ "s"+ pendingJudgement :: Judgement -> [PendingTree]-pendingJudgement (Bonus (_, _)) = []-pendingJudgement (Judgement (Header (t, p, _), _, _, [])) | isInfinite p = [Node t []]-pendingJudgement (Judgement (Header (_, _, _), _, _, [])) = [] -- Not infinite-pendingJudgement (Judgement (Header (t, _, _), _, _, subJs @ (_:_))) =+pendingJudgement (Bonus (_, _, cs)) =+  case countImpartials cs of+    0 -> []+    n -> [Node "Bonus" n False []]+pendingJudgement (Judgement (Header (t, p, _), _, cs, [])) | isInfinite p =+  [Node t (countImpartials cs) True []]+pendingJudgement (Judgement (Header (t, _, _), _, cs, subJs)) =   case (concatMap pendingJudgement subJs) of-    [] -> []-    sub  -> [Node t sub]+    [] ->+      case countImpartials cs of+        0 -> []+        n -> [Node t n False []]+    sub  -> [Node t (countImpartials cs) False sub]++countImpartials :: [Comment] -> Int+countImpartials = sum . (map countImpartial)++countImpartial :: Comment -> Int+countImpartial (Comment (Impartial, cps)) = 1 + (sum $ map countImpartialCP cps)+countImpartial (Comment (_, cps)) = sum $ map countImpartialCP cps++countImpartialCP :: CommentPart -> Int+countImpartialCP (CommentStr _) = 0+countImpartialCP (CommentCmt c) = countImpartial c  findPending :: Maybe Int -> [Judgement] -> Maybe(String) findPending detailLevel js =
src/PointsChecker.hs view
@@ -11,35 +11,39 @@ (~=) :: Double -> Double -> Bool x ~= y = abs (x - y) <= 0.01 -checkPointsSubJs :: Judgement -> Either Invalid Judgement-checkPointsSubJs (Judgement (Header (t, _, maxP), prop, cs, subJs)) = do-  newSubJs <- mapM checkPoints subJs+checkPoints :: Judgement -> Either Invalid Judgement+checkPoints (j@(Judgement (Header (t, _, _), _, _, _))) = checkPointsJ t j+checkPoints b = pure b++checkPointsSubJs :: String -> Judgement -> Either Invalid Judgement+checkPointsSubJs s (Judgement (Header (t, _, maxP), prop, cs, subJs)) = do+  newSubJs <- mapM (checkPointsJ s) subJs   let newP = sum $ map points newSubJs   pure $ Judgement (Header (t, newP, maxP), prop, cs, newSubJs)-checkPointsSubJs j = pure j+checkPointsSubJs _ j = pure j -checkPoints :: Judgement -> Either Invalid Judgement-checkPoints j @ (Judgement ((Header (_, p, _)), _, _, [])) | isInfinite p =-  Left $ NoPointsInBottomJudgement j-checkPoints j @ (Judgement (Header (_, p, maxP), _, _, subJs @ (_:_))) | isInfinite p = do+checkPointsJ :: String ->  Judgement -> Either Invalid Judgement+checkPointsJ s (j @ (Judgement ((Header (_, p, _)), _, _, []))) | isInfinite p =+  Left $ NoPointsInBottomJudgement s j+checkPointsJ s (j @ (Judgement (Header (_, p, maxP), _, _, subJs @ (_:_)))) | isInfinite p = do   try ((sum $ map maxPoints subJs) ~= maxP)-    (BadSubJudgementMaxPointsSum j)-  checkPointsSubJs j-checkPoints j @ (Judgement (Header (_, p, maxP), _, _, subJs)) = do+    (BadSubJudgementMaxPointsSum s j)+  checkPointsSubJs s j+checkPointsJ s (j @ (Judgement (Header (_, p, maxP), _, _, subJs))) = do   try (p <= maxP)-    (PointsExceedMaxPoints j)+    (PointsExceedMaxPoints s j)   case subJs of     [] -> pure j     _ -> do       try ((sum $ map points subJs) ~= p)-        (BadSubJudgementPointsSum j)+        (BadSubJudgementPointsSum s j)       try ((sum $ map maxPoints subJs) ~= maxP)-        (BadSubJudgementMaxPointsSum j)-      checkPointsSubJs j-checkPoints j @ (Bonus _) = pure j+        (BadSubJudgementMaxPointsSum s j)+      checkPointsSubJs s j+checkPointsJ _ j @ (Bonus _) = pure j  points :: Judgement -> Double-points (Bonus (v, _)) = v+points (Bonus (v, _, _)) = v points (Judgement (Header (_, v, _), _, _, [])) | isInfinite v = 0 points (Judgement (Header (_, v, _), _, _, _)) = v
src/PrettyPrinter.hs view
@@ -1,7 +1,7 @@-module PrettyPrinter (ppJ_d, ppJs, ppPoints) where+module PrettyPrinter (ppJ_d, ppJs, ppPoints, ppComments) where  import Ast-import Export.Generic+import Export.Generic (pointsDoc, propertyExpDoc)  import Text.PrettyPrint import Data.List (intersperse)@@ -15,10 +15,15 @@ ppPoints :: Double -> String ppPoints = render . pointsDoc +ppComments :: [Comment] -> String+ppComments = render . vcat . (map formatComment)+ formatJudgement :: Int -> Judgement -> Doc-formatJudgement depth (Bonus (points, _)) =+formatJudgement depth (Bonus (p, properties, comments)) =   (text $ replicate depth '#') <+> text "Bonus" <> colon <+> text "+" <>-    pointsDoc points+  pointsDoc p $+$+  (nest 2 $ vcat $ map formatProperty properties) $+$+  (nest 2 $ vcat $ map formatComment comments) formatJudgement depth (Judgement (header, properties, comments, judgements)) =   formatHeader depth header $+$   (nest 2 $ vcat $ map formatProperty properties) $+$@@ -32,7 +37,7 @@  formatProperty :: Property -> Doc formatProperty (Property (name, value)) =-  colon <> text name <> colon <+> formatPropertyExp value+  colon <> text name <> colon <+> propertyExpDoc value  formatComment :: Comment -> Doc formatComment (Comment (mood, commentParts)) =@@ -43,6 +48,7 @@ formatMood Negative  = text "-" formatMood Neutral   = text "*" formatMood Impartial = text "?"+formatMood Warning   = text "!"  formatCommentPart :: CommentPart -> Doc formatCommentPart (CommentStr string)  = text string
src/PropertyInterp.hs view
@@ -31,7 +31,10 @@   propVals <- mapM (bindProp j (predef:jsPropVals)) (addPredifinedProps prop)   let newProps = map propValToProperties propVals   pure (Judgement (h, newProps, cs, jupdates), propVals)-interpJudgement j @ (Bonus (v, _)) = pure (j, [("Bonus", DoubVal v)])+interpJudgement (Bonus (v, _, c)) = pure (Bonus (v, preProps, c), newProps)+  where+    newProps = [("Title", StrVal "Bonus"), ("Total", DoubVal v)]+    preProps = [Property ("Title", Value "Bonus"), Property ("Total", Num v)]  propValToProperties :: (String, PropertyValue) -> Property propValToProperties (str, StrVal string) = Property (str, Value string)@@ -40,8 +43,8 @@ addPredifinedProps :: [Property] -> [Property] addPredifinedProps p =   Property("Title", Lookup (0, "Title")) :-  Property("Total", Lookup (0, "Total")) :-  Property("MaxPoints", Lookup (0, "MaxPoints")) : p+  Property("Total", Sum "Total") :+  Property("MaxPoints", Sum "MaxPoints") : p  generatePredefinedValues :: Header -> Either Invalid [(String, PropertyValue)] generatePredefinedValues (Header (t, p, maxP)) =@@ -62,3 +65,17 @@   case (lookup p (propEnv !! (i))) of     Nothing -> Left $ PropertyNotFound p rj     (Just s) -> pure s+evalPropExp rj (Sum pname) propEnv | isLeafJ rj =+    evalPropExp rj (Lookup (0, pname)) propEnv+evalPropExp _ (Sum pname) propEnv =+    pure $ sumPV vals+  where+    vals = map snd $ concatMap (filter (\x -> (fst x) == pname)) (tail propEnv)++sumPV :: [PropertyValue] -> PropertyValue+sumPV [] = DoubVal 0+sumPV ((DoubVal v):vals) =+  case sumPV vals of+    DoubVal vs -> DoubVal $ vs + v+    StrVal _ -> error "I cannot sum a string. Please report this error!"+sumPV _ = error "I cannot sum a string. Please report this error!"