packages feed

remarks 0.1.9 → 0.1.10

raw patch · 13 files changed

+253/−77 lines, 13 filesdep +containers

Dependencies added: containers

Files

README.md view
@@ -46,29 +46,47 @@   are correct. * `remarks show [<file>]` checks the file system structure as above, and shows   the overall judgement for each given argument.-* `remarks summary <depth> [<file>]` checks and summarizes the points. Depth 0-  lists just the top-level judgements.-+* `remarks summary [--depth <depth>] [<file>]` checks and summarizes the points.+  Depth 0 (default) lists just the top-level judgements.+* `remarks pending [--depth <depth>] [<file>]` shown the corrections that has not+  been completed. Can be cut at a given depth; depth 0 lists just the top-level judgements.+* `remarks export [--format "<format>"] [<file>]` exports corrections to a semicolon separated +  list. The format is a semicolon separated string of properties.+* `remarks exportHTML [<file>]` exports all corrections to a dynamic html-table. Developer features:  * `remarks parse [<file>]` parses the given files and shows their ASTs.  ## Installation -[`remarks` is on Hackage](http://hackage.haskell.org/package/remarks), so you-can just use [Cabal](https://www.haskell.org/cabal/):+`remarks` is on [Hackage](http://hackage.haskell.org/package/remarks), so you+can use [Cabal](https://www.haskell.org/cabal/):  ``` $ cabal install remarks ``` -You can also clone this repository and use-[Stack](https://docs.haskellstack.org/en/stable/README/):+If you clone the repository, or [download the+sources](https://github.com/oleks/remarks/releases), you get two further+options: -```-$ stack build-$ stack install-```+* If you are using the purely functional package manager+  [Nix](https://nixos.org/nix/), you can do this:++  ```+  $ nix-build+  ```++  This will create a symlink `result`, pointing to the directory in your Nix+  store, containing the binary.++* Or, if using [Stack](https://docs.haskellstack.org/en/stable/README/), you+  can do this:++  ```+  $ stack build+  $ stack install+  ```  ## Syntax
app/Main.hs view
@@ -6,6 +6,7 @@ import Parser import PointsChecker import PropertyInterp+import Pending import PrettyPrinter  import Control.Monad ( liftM, (<=<) )@@ -134,20 +135,23 @@ check js = do   case marshall js of     Right newJs -> printJs newJs-    Left e -> putStrLn $ show e+    Left e -> putStrLn $ reportInvalid e  printJs :: [Judgement] -> IO () printJs = putStrLn . ppJs -export :: [String] -> [Judgement] -> IO ()+export :: String -> [Judgement] -> IO () export format js = do-  case (exportCSV ";" format =<< (marshall js)) of+  case (exportCSV [delimiter] formatList =<< (marshall js)) of     Right docs -> putStrLn docs-    Left e -> putStrLn $ show e+    Left e -> putStrLn $ reportInvalid e+  where +    delimiter = findDelimiter format+    formatList = splitBy delimiter format  export_html :: [Judgement] -> IO () export_html js = do-  case (mapM checkPoints js) of+  case (mapM interpProps js) of     Right newJs -> putStrLn $ exportHTML newJs     Left e -> putStrLn $ show e @@ -157,6 +161,19 @@     Right mJs -> printJs $ map (summary depth) mJs     Left e -> putStrLn $ show e +pending :: Maybe Int -> [Judgement] -> IO ()+pending dl js = do+  case findPending dl js of+    Nothing  -> putStrLn "No pending corrections."+    (Just s) -> putStrLn "The following corrections are pending:" >> putStrLn s++findDelimiter :: String -> Char+findDelimiter [] = ';' -- There is no delimiter so it doesn't matter+findDelimiter (s:ss) =+  if (elem s [',',';'])+  then s+  else findDelimiter ss+ main :: IO () main = do   args <- getArgs@@ -168,12 +185,18 @@       with paths $ mapM_ check     ("show" : paths) ->       with paths $ mapM_ printJs-    ("summary" : depth : paths) ->-      with paths $ mapM_ $ showSummary (read depth)+    ("pending" : "--depth" : d : paths) ->+      with paths $ mapM_ (pending (Just $ read d))+    ("pending" : paths) ->+      with paths $ mapM_ (pending Nothing)+    ("summary" : "--depth" : d : paths) ->+      with paths $ mapM_ $ showSummary $ read d+    ("summary" : paths) ->+      with paths $ mapM_ $ showSummary 0     ("export" : "--format" : format : paths) ->-      with paths $ mapM_ $ export (splitBy ';' format)+      with paths $ mapM_ $ export format     ("export" : paths) ->-      with paths $ mapM_ $ export ["Title", "Total", "MaxPoints"]+      with paths $ mapM_ $ export "Title;Total;MaxPoints"     ("exportHTML" : paths) ->       with paths $ mapM_ export_html     (c:rest) -> invalidCommand c rest
remarks.cabal view
@@ -1,5 +1,5 @@ name:                remarks-version:             0.1.9+version:             0.1.10 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@@ -24,6 +24,7 @@                      , Invalid                      , Parser                      , Parser.Impl+                     , Pending                      , PointsChecker                      , PrettyPrinter                      , PropertyInterp@@ -31,6 +32,7 @@   build-depends:       base >= 4.7 && < 5                      , GenericPretty >= 1.2.1                      , pretty >= 1.1.3.3+                     , containers >= 0.5.7.1   default-language:    Haskell2010  executable remarks
src/Export/CSV.hs view
@@ -18,18 +18,7 @@   doc <- mapM (mapfun judgement) properties   pure $ hcat $ (intersperse (text delimiter)) doc   where-    mapfun = flip lookupProperty--lookupProperty :: String -> Judgement -> Either Invalid Doc-lookupProperty name (Judgement (_, properties, _, _)) =-  case (lookup name (map (\(Property (n,v)) -> (n,v)) properties)) of-    Nothing -> Left $ PropertyNotFound name-    Just(value) -> pure $ formatPropertyExp value-lookupProperty name _ =-  Left $ PropertyNotFound name--formatPropertyExp :: PropertyExp -> Doc-formatPropertyExp (Lookup (index, name)) =-  brackets $ int index <> text "." <> text name-formatPropertyExp (Value value) = text value-formatPropertyExp (Num value) = pointsDoc value+    mapfun j p = +      case lookupProperty p j of+        Nothing  -> Left $ PropertyNotFound p j+        (Just v) -> pure v
src/Export/Generic.hs view
@@ -7,9 +7,23 @@ isIntegral x = x == fromInteger (round x)  pointsDoc :: Double -> Doc+pointsDoc v | isInfinite v = empty 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)) =+  brackets $ int index <> text "." <> text name+formatPropertyExp (Value value) = text value+formatPropertyExp (Num value) = pointsDoc value  unify :: Judgement -> Judgement -> Maybe Judgement unify
src/Export/Html.hs view
@@ -12,13 +12,13 @@     (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 ++ ">")+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)+atag tagStr attrStr = tag tagStr (space <> text attrStr)  doctype :: Doc -> Doc doctype = ($$) (text "<!DOCTYPE html>")@@ -115,14 +115,14 @@  htmlDetailJudgement :: Judgement -> Doc htmlDetailJudgement (Bonus (points, comments)) =-  details (pointsDoc points) (htmlDetailComments comments)+  details (text "Bonus" <+> parens (pointsDoc points)) (htmlDetailComments comments) htmlDetailJudgement (Judgement (Header(title, points, maxPoint), _, comments, judgements)) =   details-    (text title <> parens (pointsDoc points <> text "/" <> pointsDoc maxPoint))+    (text title <+> parens (pointsDoc points <> text "/" <> pointsDoc maxPoint))     (htmlDetailComments comments $$ htmlDetailJudgements judgements)  htmlDetailComments :: [Comment] -> Doc-htmlDetailComments [] = text ""+htmlDetailComments [] = empty htmlDetailComments comments =   ul . vcat $ map htmlDetailComment comments
src/Invalid.hs view
@@ -1,18 +1,65 @@ {-# LANGUAGE DeriveGeneric #-} -module Invalid where+module Invalid ( reportInvalid, Invalid (..) ) where  import Ast+import PrettyPrinter +import Data.List (intersperse) import Text.PrettyPrint.GenericPretty  data Invalid-  = PointsExceedMaxPoints Header+  = PointsExceedMaxPoints Judgement   | BadSubJudgementPointsSum Judgement   | BadSubJudgementMaxPointsSum Judgement   | NoPointsInBottomJudgement Judgement-  | PropertyNotFound String+  | 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" +++    reportStrippedJudgement j+reportInvalid (BadSubJudgementPointsSum (j @ (Judgement (Header (_, p, _), _, _, _)))) =+    "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" +++    reportJudgement 0 j+reportInvalid (NoPointsInBottomJudgement j) = +  "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!"++reportJudgement :: Int -> Judgement -> String+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)))+reportJudgement _ _ = ""++reportStrippedJudgement :: Judgement -> String+reportStrippedJudgement j | isLeafJ j = reportJudgement 0 (stripJ j)+reportStrippedJudgement j | isNodeJ j = (reportJudgement 0 (stripJ j)) ++ "\n  ..."+reportStrippedJudgement _ = "" -- Bonus++subJs :: Judgement -> [Judgement]+subJs (Judgement (_, _, _, js)) = js+subJs _ = [] -- Bunus++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
@@ -38,7 +38,8 @@ parseMaxPoints :: ReadP Double parseMaxPoints = do   is <- parseIntegral-  case (maybeRead is) of+  fs <- (string ".5") +++ pure "0"+  case (maybeRead (is ++ "." ++ fs)) of     Just x -> pure x     _ -> pfail
+ src/Pending.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE DeriveGeneric #-}++module Pending ( findPending ) where++import Ast++import Data.Tree+import Text.PrettyPrint++type PendingTree = Tree String++data FormatTree+  = TEmpty  FormatTree+  | TSpace  FormatTree+  | TBranch FormatTree+  | TNode+  | TLeaf++showTree :: FormatTree -> Doc+showTree (TEmpty t)  = showTree t+showTree (TBranch t) = text " | " <> showTree t+showTree (TSpace t)  = text "   " <> showTree t+showTree TNode       = text " |- "+showTree TLeaf       = text " |> "++linebreak :: Doc+linebreak = text "\n"++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] =+  showTree (ft TNode) <> formatSubTree (ft . TSpace) t+formatSubTrees ft ((Node s []):ts) =+  showTree (ft TLeaf) <> text s <> linebreak <>+  (formatSubTrees ft ts)+formatSubTrees ft (t:ts) =+  showTree (ft TNode) <> formatSubTree (ft . TBranch) t <> linebreak <>+  (formatSubTrees ft ts)++formatSubTree :: (FormatTree -> FormatTree) -> PendingTree -> Doc+formatSubTree _ (Node s []) =+  text s+formatSubTree tree (Node s ts) =+  text s <> linebreak <> formatSubTrees tree ts++size :: PendingTree -> Int+size (Node _ []) = 1+size (Node _ (t @ (_:_))) = sum $ map size t++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))++showTasks :: Int -> String+showTasks 1 = " (1 task)"+showTasks n = " (" ++ (show n) ++ " tasks)"++pendingJudgement :: Judgement -> [PendingTree]+pendingJudgement (Bonus (_, _)) = []+pendingJudgement (Judgement (Header (t, p, _), _, _, [])) | isInfinite p = [Node t []]+pendingJudgement (Judgement (Header (_, _, _), _, _, [])) = [] -- Not infinite+pendingJudgement (Judgement (Header (t, _, _), _, _, subJs @ (_:_))) =+  case (concatMap pendingJudgement subJs) of+    [] -> []+    sub  -> [Node t sub]++findPending :: Maybe Int -> [Judgement] -> Maybe(String)+findPending detailLevel js =+  case (concatMap pendingJudgement js) of+    [] -> Nothing+    t  ->+      case detailLevel of+        Nothing  -> Just $ render $ vcat $ map formatTree t+        (Just i) -> Just $ render $ vcat $ map (formatTree . (limitPendingTree i)) t
src/PointsChecker.hs view
@@ -12,22 +12,22 @@ x ~= y = abs (x - y) <= 0.01  checkPointsSubJs :: Judgement -> Either Invalid Judgement-checkPointsSubJs (Judgement ((Header (t, _, maxP)), prop, cs, subJs)) = do+checkPointsSubJs (Judgement (Header (t, _, maxP), prop, cs, subJs)) = do   newSubJs <- mapM checkPoints subJs   let newP = sum $ map points newSubJs   pure $ Judgement (Header (t, newP, maxP), prop, cs, newSubJs) checkPointsSubJs j = pure j  checkPoints :: Judgement -> Either Invalid Judgement-checkPoints j @ (Judgement ((Header (_, p, _)), _, _, [])) | isInfinite p = do+checkPoints j @ (Judgement ((Header (_, p, _)), _, _, [])) | isInfinite p =   Left $ NoPointsInBottomJudgement j-checkPoints j @ (Judgement ((Header (_, p, maxP)), _, _, subJs @ (_:_))) | isInfinite p = do+checkPoints j @ (Judgement (Header (_, p, maxP), _, _, subJs @ (_:_))) | isInfinite p = do   try ((sum $ map maxPoints subJs) ~= maxP)     (BadSubJudgementMaxPointsSum j)   checkPointsSubJs j-checkPoints j @ (Judgement (h @ (Header (_, p, maxP)), _, _, subJs)) = do+checkPoints j @ (Judgement (Header (_, p, maxP), _, _, subJs)) = do   try (p <= maxP)-    (PointsExceedMaxPoints h)+    (PointsExceedMaxPoints j)   case subJs of     [] -> pure j     _ -> do@@ -36,10 +36,11 @@       try ((sum $ map maxPoints subJs) ~= maxP)         (BadSubJudgementMaxPointsSum j)       checkPointsSubJs j-checkPoints j = pure j+checkPoints j @ (Bonus _) = pure j  points :: Judgement -> Double points (Bonus (v, _)) = v+points (Judgement (Header (_, v, _), _, _, [])) | isInfinite v = 0 points (Judgement (Header (_, v, _), _, _, _)) = v  maxPoints :: Judgement -> Double
src/PrettyPrinter.hs view
@@ -1,4 +1,4 @@-module PrettyPrinter (ppJs) where+module PrettyPrinter (ppJ_d, ppJs, ppPoints) where  import Ast import Export.Generic@@ -6,33 +6,33 @@ import Text.PrettyPrint import Data.List (intersperse) +ppJ_d :: Int -> Judgement -> String+ppJ_d d = render . (formatJudgement (d + 1))+ ppJs :: [Judgement] -> String ppJs = render . vcat . intersperse (text "") . map (formatJudgement 1) +ppPoints :: Double -> String+ppPoints = render . pointsDoc+ formatJudgement :: Int -> Judgement -> Doc-formatJudgement level (Bonus (points, _)) =-  (text $ replicate level '#') <+> text "Bonus" <> colon <+> text "+" <>+formatJudgement depth (Bonus (points, _)) =+  (text $ replicate depth '#') <+> text "Bonus" <> colon <+> text "+" <>     pointsDoc points-formatJudgement level (Judgement (header, properties, comments, judgements)) =-  formatHeader level header $+$+formatJudgement depth (Judgement (header, properties, comments, judgements)) =+  formatHeader depth header $+$   (nest 2 $ vcat $ map formatProperty properties) $+$   (nest 2 $ vcat $ map formatComment comments) $+$-  (vcat $ map (formatJudgement (level + 1)) judgements)+  (vcat $ map (formatJudgement (depth + 1)) judgements)  formatHeader :: Int -> Header -> Doc-formatHeader level (Header (title, point, maxPoints)) =-  (text $ replicate level '#') <+> text title <> colon <> space <>+formatHeader depth (Header (title, point, maxPoints)) =+  (text $ replicate depth '#') <+> text title <> colon <> space <>     pointsDoc point <> text "/" <> pointsDoc maxPoints  formatProperty :: Property -> Doc formatProperty (Property (name, value)) =   colon <> text name <> colon <+> formatPropertyExp value--formatPropertyExp :: PropertyExp -> Doc-formatPropertyExp (Lookup (index, name)) =-  brackets $ int index <> text "." <> text name-formatPropertyExp (Value v) = text v-formatPropertyExp (Num v) = pointsDoc v  formatComment :: Comment -> Doc formatComment (Comment (mood, commentParts)) =
src/PropertyInterp.hs view
@@ -24,11 +24,11 @@     Left invalid -> Left invalid  interpJudgement :: Judgement -> Either Invalid (Judgement, [(String, PropertyValue)])-interpJudgement (Judgement (h, prop, cs, js)) = do+interpJudgement (j @ (Judgement (h, prop, cs, js))) = do   updlist <- mapM interpJudgement js   let (jupdates, jsPropVals) = unzip updlist   predef <- generatePredefinedValues h-  propVals <- mapM (bindProp (predef:jsPropVals)) (addPredifinedProps prop)+  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)])@@ -47,18 +47,18 @@ generatePredefinedValues (Header (t, p, maxP)) =   pure [("Title", StrVal t), ("Total", DoubVal p), ("MaxPoints", DoubVal maxP)] -bindProp :: [[(String, PropertyValue)]] -> Property ->+bindProp :: Judgement -> [[(String, PropertyValue)]] -> Property ->   Either Invalid (String, PropertyValue)-bindProp propEnv (Property (name, propExp)) =-  case (evalPropExp propExp propEnv) of+bindProp rj propEnv (Property (name, propExp)) =+  case (evalPropExp rj propExp propEnv) of     Right (val)  -> pure (name, val)     Left invalid -> Left invalid -evalPropExp :: PropertyExp -> [[(String, PropertyValue)]] ->+evalPropExp :: Judgement -> PropertyExp -> [[(String, PropertyValue)]] ->   Either Invalid PropertyValue-evalPropExp (Value s) _ = pure $ StrVal s-evalPropExp (Num n) _ = pure $ DoubVal n-evalPropExp (Lookup (i, p)) propEnv =+evalPropExp _ (Value s) _ = pure $ StrVal s+evalPropExp _ (Num n) _ = pure $ DoubVal n+evalPropExp rj (Lookup (i, p)) propEnv =   case (lookup p (propEnv !! (i))) of-    Nothing -> Left $ PropertyNotFound p+    Nothing -> Left $ PropertyNotFound p rj     (Just s) -> pure s
test/PointsCheckerTests.hs view
@@ -45,10 +45,11 @@   ]  negUnitTests :: TestTree-negUnitTests = testGroup "Positive Unit Tests"+negUnitTests = testGroup "Negative Unit Tests"   [ testCase "Points exceed max points" $       checkPointsStr "# A: 1/0\n" @?=-        [Left $ PointsExceedMaxPoints (Header ("A", 1.0, 0.0))]+        [Left $ PointsExceedMaxPoints $+          (Judgement (Header ("A", 1.0, 0.0), [], [], []))]   , testCase "Sub-judgement points don't sum up to points" $       checkPointsStr "# A: 0/0\n## B: 1/0\n" @?=         [Left $ BadSubJudgementPointsSum