remarks 0.1.6 → 0.1.7

raw patch · 10 files changed

+178/−160 lines, 10 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• app/Main.hs +3/−3
• remarks.cabal +3/−3
• src/Ast.hs +2/−1
• src/Parser/Impl.hs +25/−15
• src/PointsChecker.hs +61/−0
• src/PrettyPrinter.hs +3/−0
• src/Validator.hs +0/−57
• test/PointsCheckerTests.hs +79/−0
• test/Tests.hs +2/−2
• test/ValidatorTests.hs +0/−79

@@ -2,7 +2,7 @@  import Ast import Parser-import Validator+import PointsChecker import PrettyPrinter import Collector @@ -121,7 +121,7 @@  check :: [Judgement] -> IO () check js = do-  case mapM validate js of+  case mapM checkPoints js of     Right newJs -> printJs newJs     Left e -> putStrLn $ show e @@ -130,7 +130,7 @@  collect :: [Judgement] -> IO () collect js = do-  case mapM validate js of+  case mapM checkPoints js of     Right newJs -> putStrLn $ collectHTML newJs     Left e -> putStrLn $ show e 

@@ -1,5 +1,5 @@ name:                remarks-version:             0.1.6+version:             0.1.7 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@@ -18,7 +18,7 @@   exposed-modules:     Ast                      , Parser                      , Parser.Impl-                     , Validator+                     , PointsChecker                      , PrettyPrinter                      , Config                      , Collector@@ -44,7 +44,7 @@   hs-source-dirs:      test   main-is:             Tests.hs   other-modules:       Parser.BlackBoxTests-                       ValidatorTests+                       PointsCheckerTests   build-depends:       base                      , remarks                      , GenericPretty >= 1.2.1

@@ -32,8 +32,9 @@  instance Out Comment -newtype Judgement+data Judgement   = Judgement (Header, [Comment], [Judgement])+  | Bonus (Double, [Comment])   deriving (Eq, Show, Generic)  instance Out Judgement

@@ -51,21 +51,38 @@ munchTillExcl :: Char -> ReadP String munchTillExcl c = munch (/= c) <* char c -parseHeader :: Int -> ReadP Header-parseHeader depth = do-  let mark = take depth $ repeat '#'-  void $ string mark-  void $ char ' '-  title <- lineToken $ munchTillExcl ':'+parseBonus :: String -> ReadP Judgement+parseBonus title = do+  lineToken $ char '+'+  points <- parsePoints+  void $ lineBreak+  comments <- many parseComment'+  pure $ Bonus (points, comments) +parseRegularJudgement :: Int -> String -> ReadP Judgement+parseRegularJudgement depth title = do   points <- (lineToken $ parsePoints) +++ (return $ 1/0)   void $ lineToken $ char '/'   maxPoints <- lineToken $ parseMaxPoints-   void $ lineBreak -  pure $ Header (title, points, maxPoints)+  let header = Header (title, points, maxPoints) +  comments <- many parseComment'+  subjs <- many $ parseJudgement (depth + 1)+  pure $ Judgement (header, comments, subjs)++parseJudgement :: Int -> ReadP Judgement+parseJudgement depth = skipSpaces *> do+  let mark = take depth $ repeat '#'+  void $ string mark+  void $ char ' '+  title <- lineToken $ munchTillExcl ':'++  case title of+    "Bonus" -> parseBonus title+    _ -> parseRegularJudgement depth title+ parseMood :: ReadP Mood parseMood = choice   [ char '+' *> pure Positive@@ -98,13 +115,6 @@ parseComment' = many lineBreak *> do   void $ string indentation   parseComment indentation--parseJudgement :: Int -> ReadP Judgement-parseJudgement depth = skipSpaces *> do-  header <- parseHeader depth-  comments <- many parseComment'-  subjs <- many $ parseJudgement (depth + 1)-  pure $ Judgement (header, comments, subjs)  parseJudgements :: Int -> ReadP [Judgement] parseJudgements depth = many $ parseJudgement depth

@@ -0,0 +1,61 @@+{-# LANGUAGE DeriveGeneric #-}++module PointsChecker ( checkPoints, Invalid(..) ) where++import Ast++import Control.Monad ( forM_ )++import Text.PrettyPrint.GenericPretty++data Invalid+  = PointsExceedMaxPoints Header+  | BadSubJudgementPointsSum Judgement+  | BadSubJudgementMaxPointsSum Judgement+  | NoPointsInBottomJudgement Judgement+  deriving (Eq, Show, Generic)++instance Out Invalid++try :: Bool -> Invalid -> Either Invalid ()+try True = \_ -> Right ()+try False = Left++infix 4 ~=+(~=) :: Double -> Double -> Bool+x ~= y = abs (x - y) <= 0.01++checkPointsSubJs :: Judgement -> Either Invalid Judgement+checkPointsSubJs (Judgement (h @ (Header (t, _, maxP)), cs, subJs)) = do+  newSubJs <- mapM checkPoints subJs+  let newP = sum $ map points newSubJs+  pure $ Judgement (Header (t, newP, maxP), cs, newSubJs)+checkPointsSubJs j = pure j++checkPoints :: Judgement -> Either Invalid Judgement+checkPoints j @ (Judgement (h @ (Header (_, p, maxP)), _, [])) | isInfinite p = do+  Left $ NoPointsInBottomJudgement j+checkPoints j @ (Judgement (h @ (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+  try (p <= maxP)+    (PointsExceedMaxPoints h)+  case subJs of+    [] -> pure j+    _ -> do+      try ((sum $ map points subJs) ~= p)+        (BadSubJudgementPointsSum j)+      try ((sum $ map maxPoints subJs) ~= maxP)+        (BadSubJudgementMaxPointsSum j)+      checkPointsSubJs j+checkPoints j = pure j++points :: Judgement -> Double+points (Bonus (v, _)) = v+points (Judgement (Header (_, v, _), _, _)) = v++maxPoints :: Judgement -> Double+maxPoints (Bonus _) = 0.0+maxPoints (Judgement (Header (_, _, v), _, _)) = v

@@ -9,6 +9,9 @@ ppJs = render . vcat . intersperse (text "") . map (formatJudgement 1)  formatJudgement :: Int -> Judgement -> Doc+formatJudgement level (Bonus (points, comments)) =+  (text $ replicate level '#') <+> text "Bonus" <> colon <+> text "+" <>+    pointsDoc points formatJudgement level (Judgement (header, comments, judgements)) =   formatHeader level header $+$   (nest 2 $ vcat $ map (formatComment) comments) $+$

@@ -1,57 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--module Validator ( validate, Invalid(..) ) where--import Ast--import Control.Monad ( forM_ )--import Text.PrettyPrint.GenericPretty--data Invalid-  = PointsExceedMaxPoints Header-  | BadSubJudgementPointsSum Judgement-  | BadSubJudgementMaxPointsSum Judgement-  | NoPointsInBottomJudgement Judgement-  deriving (Eq, Show, Generic)--instance Out Invalid--try :: Bool -> Invalid -> Either Invalid ()-try True = \_ -> Right ()-try False = Left--infix 4 ~=-(~=) :: Double -> Double -> Bool-x ~= y = abs (x - y) <= 0.01--validateSubJs :: Judgement -> Either Invalid Judgement-validateSubJs (Judgement (h @ (Header (t, _, maxP)), cs, subJs)) = do-  newSubJs <- mapM validate subJs-  let newP = sum $ map points newSubJs-  pure $ Judgement (Header (t, newP, maxP), cs, newSubJs)--validate :: Judgement -> Either Invalid Judgement-validate j @ (Judgement (h @ (Header (_, p, maxP)), _, [])) | isInfinite p = do-  Left $ NoPointsInBottomJudgement j-validate j @ (Judgement (h @ (Header (_, p, maxP)), _, subJs @ (_:_))) | isInfinite p = do-  try ((sum $ map maxPoints subJs) ~= maxP)-    (BadSubJudgementMaxPointsSum j)-  validateSubJs j-validate j @ (Judgement (h @ (Header (_, p, maxP)), _, subJs)) = do-  try (p <= maxP)-    (PointsExceedMaxPoints h)-  case subJs of-    [] -> pure j-    _ -> do-      try ((sum $ map points subJs) ~= p)-        (BadSubJudgementPointsSum j)-      try ((sum $ map maxPoints subJs) ~= maxP)-        (BadSubJudgementMaxPointsSum j)-      validateSubJs j--points :: Judgement -> Double-points (Judgement (Header (_, v, _), _, _)) = v--maxPoints :: Judgement -> Double-maxPoints (Judgement (Header (_, _, v), _, _)) = v

@@ -0,0 +1,79 @@+{-# LANGUAGE DeriveGeneric #-}++module PointsCheckerTests ( allTests ) where++import Ast+import Parser+import PointsChecker++import Test.Tasty+import Test.Tasty.HUnit+-- import Test.Tasty.QuickCheck+import Test.Tasty.Golden++import Text.PrettyPrint.GenericPretty++checkPointsStr :: String -> [Either Invalid Judgement]+checkPointsStr s =+  case parseString s of+    Right js -> map checkPoints js+    Left e -> []++posUnitTests :: TestTree+posUnitTests = testGroup "Positive Unit Tests"+  [ testCase "Lone header line" $+      checkPointsStr "# A: 0/0\n" @?=+        [ Right $+          Judgement (Header ("A", 0.0, 0.0), [], [])]+  , testCase "A couple same-depth header lines" $+      checkPointsStr "# A: 0/0\n# B: 0/0\n" @?=+        [ Right $+          Judgement (Header ("A", 0.0, 0.0), [], [])+        , Right $+          Judgement (Header ("B", 0.0, 0.0), [], [])+        ]+  , testCase "A simple hierarchy of headers" $+      checkPointsStr "# A: 0/0\n## B: 0/0\n" @?=+        [ Right $+          Judgement (Header ("A", 0.0, 0.0), [],+            [Judgement (Header ("B", 0.0, 0.0), [], [])])]+  , testCase "A couple simple hierarchies" $+      checkPointsStr "# A: 0/0\n## B: 0/0\n# C: 0/0\n" @?=+        [ Right $+          Judgement (Header ("A", 0.0, 0.0), [],+            [Judgement (Header ("B", 0.0, 0.0), [], [])])+        , Right $+          Judgement (Header ("C", 0.0, 0.0), [], [])+        ]+  ]++negUnitTests :: TestTree+negUnitTests = testGroup "Positive Unit Tests"+  [ testCase "Points exceed max points" $+      checkPointsStr "# A: 1/0\n" @?=+        [Left $ PointsExceedMaxPoints (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+          (Judgement (Header ("A", 0.0, 0.0), [],+            [Judgement (Header ("B", 1.0, 0.0), [], [])]))]+  , testCase "Sub-judgement max-points don't sum up to max-points" $+      checkPointsStr "# A: 0/0\n## B: 0/1\n" @?=+        [Left $ BadSubJudgementMaxPointsSum+          (Judgement (Header ("A", 0.0, 0.0), [],+            [Judgement (Header ("B", 0.0, 1.0), [], [])]))]+  , testCase "Single judgement with no points" $+      checkPointsStr "# A: /0\n" @?=+        [Left $ NoPointsInBottomJudgement+          (Judgement (Header ("A", 1/0, 0.0), [], []))]+  ]++qcTests :: TestTree+qcTests = testGroup "QuickCheck tests" []++goldenTests :: TestTree+goldenTests = testGroup "Golden tests" []++allTests :: TestTree+allTests = testGroup "PointsChecker tests"+  [ posUnitTests, negUnitTests, qcTests, goldenTests ]

@@ -3,8 +3,8 @@ import Test.Tasty  import qualified Parser.BlackBoxTests as PBBT-import qualified ValidatorTests as VT+import qualified PointsCheckerTests as PCT  main :: IO () main = defaultMain $ testGroup "All Tests"-  [ PBBT.allTests, VT.allTests ]+  [ PBBT.allTests, PCT.allTests ]

@@ -1,79 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--module ValidatorTests ( allTests ) where--import Ast-import Parser-import Validator--import Test.Tasty-import Test.Tasty.HUnit--- import Test.Tasty.QuickCheck-import Test.Tasty.Golden--import Text.PrettyPrint.GenericPretty--validateStr :: String -> [Either Invalid Judgement]-validateStr s =-  case parseString s of-    Right js -> map validate js-    Left e -> []--posUnitTests :: TestTree-posUnitTests = testGroup "Positive Unit Tests"-  [ testCase "Lone header line" $-      validateStr "# A: 0/0\n" @?=-        [ Right $-          Judgement (Header ("A", 0.0, 0.0), [], [])]-  , testCase "A couple same-depth header lines" $-      validateStr "# A: 0/0\n# B: 0/0\n" @?=-        [ Right $-          Judgement (Header ("A", 0.0, 0.0), [], [])-        , Right $-          Judgement (Header ("B", 0.0, 0.0), [], [])-        ]-  , testCase "A simple hierarchy of headers" $-      validateStr "# A: 0/0\n## B: 0/0\n" @?=-        [ Right $-          Judgement (Header ("A", 0.0, 0.0), [],-            [Judgement (Header ("B", 0.0, 0.0), [], [])])]-  , testCase "A couple simple hierarchies" $-      validateStr "# A: 0/0\n## B: 0/0\n# C: 0/0\n" @?=-        [ Right $-          Judgement (Header ("A", 0.0, 0.0), [],-            [Judgement (Header ("B", 0.0, 0.0), [], [])])-        , Right $-          Judgement (Header ("C", 0.0, 0.0), [], [])-        ]-  ]--negUnitTests :: TestTree-negUnitTests = testGroup "Positive Unit Tests"-  [ testCase "Points exceed max points" $-      validateStr "# A: 1/0\n" @?=-        [Left $ PointsExceedMaxPoints (Header ("A", 1.0, 0.0))]-  , testCase "Sub-judgement points don't sum up to points" $-      validateStr "# A: 0/0\n## B: 1/0\n" @?=-        [Left $ BadSubJudgementPointsSum-          (Judgement (Header ("A", 0.0, 0.0), [],-            [Judgement (Header ("B", 1.0, 0.0), [], [])]))]-  , testCase "Sub-judgement max-points don't sum up to max-points" $-      validateStr "# A: 0/0\n## B: 0/1\n" @?=-        [Left $ BadSubJudgementMaxPointsSum-          (Judgement (Header ("A", 0.0, 0.0), [],-            [Judgement (Header ("B", 0.0, 1.0), [], [])]))]-  , testCase "Single judgement with no points" $-      validateStr "# A: /0\n" @?=-        [Left $ NoPointsInBottomJudgement-          (Judgement (Header ("A", 1/0, 0.0), [], []))]-  ]--qcTests :: TestTree-qcTests = testGroup "QuickCheck tests" []--goldenTests :: TestTree-goldenTests = testGroup "Golden tests" []--allTests :: TestTree-allTests = testGroup "Validator tests"-  [ posUnitTests, negUnitTests, qcTests, goldenTests ]