diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/remarks.cabal b/remarks.cabal --- a/remarks.cabal +++ b/remarks.cabal @@ -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 diff --git a/src/Ast.hs b/src/Ast.hs --- a/src/Ast.hs +++ b/src/Ast.hs @@ -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 diff --git a/src/Parser/Impl.hs b/src/Parser/Impl.hs --- a/src/Parser/Impl.hs +++ b/src/Parser/Impl.hs @@ -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 diff --git a/src/PointsChecker.hs b/src/PointsChecker.hs new file mode 100644 --- /dev/null +++ b/src/PointsChecker.hs @@ -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 diff --git a/src/PrettyPrinter.hs b/src/PrettyPrinter.hs --- a/src/PrettyPrinter.hs +++ b/src/PrettyPrinter.hs @@ -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) $+$ diff --git a/src/Validator.hs b/src/Validator.hs deleted file mode 100644 --- a/src/Validator.hs +++ /dev/null @@ -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 diff --git a/test/PointsCheckerTests.hs b/test/PointsCheckerTests.hs new file mode 100644 --- /dev/null +++ b/test/PointsCheckerTests.hs @@ -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 ] diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -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 ] diff --git a/test/ValidatorTests.hs b/test/ValidatorTests.hs deleted file mode 100644 --- a/test/ValidatorTests.hs +++ /dev/null @@ -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 ]