diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Oleks (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Oleks name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.org b/README.org new file mode 100644 --- /dev/null +++ b/README.org @@ -0,0 +1,42 @@ +#+TITLE: remark — a DSL for marking student work + +#+ATTR_HTML: title="License: BSD 3-Clause" +[[LICENSE][file:https://img.shields.io/badge/License-BSD%203--Clause-blue.svg]] +#+ATTR_HTML: title="Travis CI Status" +[[https://travis-ci.org/oleks/remark][file:https://travis-ci.org/oleks/remark.svg]] + +When judging student performance, it is useful to have both small, composable, +quantitive judgements, and qualitative remarks. This makes both spreadsheets +and mere text-files ill-suited for marking student work. Although +[[http://orgmode.org/][org-mode]] can solve this problem to a great extent, it +becomes a heavy tool in the light of having to mark hundreds of students in a +distributed fashion. With org-mode, everything is in one file, while global, +intra-student statistics are not needed until all the students have been fully +marked. + +* Design Goals + + 1. One human-readable/editable file per student. + 2. Export options to spreadsheet-formats. + 3. git-friendly file format. + 4. Synchronization options with Dropbox and/or Google Drive. + +Goal 4 is not necessarily related to remark, but is related to marking student +work with external examiners, who are not always willing to use more explicit +version-control systems, such as git. + +* Files and Directories + +#+BEGIN_SRC +oleks-1.mrk +oleks-2.mrk +oleks-3.mrk +oleks/4.mrk +oleks/5.mrk +oleks/6.mrk +#+END_SRC + +* Syntax + +A =.mrk= file is a list of judgements. A judgement is a header, with a title, +set points, and maximum points, followed by some comments. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,62 @@ +module Main where + +import Parser +import Validator + +import System.Directory ( doesFileExist ) +import System.Environment ( getArgs ) +import System.Exit ( exitWith, ExitCode ( ExitFailure ) ) +import System.IO ( hPutStrLn, stderr ) + +import Text.PrettyPrint.GenericPretty + +report :: String -> IO () +report = hPutStrLn stderr + +noCommand :: IO () +noCommand = do + report "Tell me what to do!" + exitWith (ExitFailure 1) + +notAPath :: String -> IO () +notAPath s = do + report $ s ++ " is not a filesystem path!" + exitWith (ExitFailure 1) + +invalidCommand :: String -> [String] -> IO () +invalidCommand c _ = do + report $ c ++ " is not a valid command." + exitWith (ExitFailure 1) + +printParse :: FilePath -> IO () +printParse path = do + p <- parseFile path + case p of + Right js -> putStrLn $ pretty $ map validate js + Left e -> putStrLn $ show e + +checkDir :: FilePath -> IO () +checkDir path = do + paths = + +checkPath :: FilePath -> IO () +checkPath path = do + isFile <- doesFileExist path + if isFile + then printParse path + else do + isDir <- doesDirectoryExist path + if not isDir + then notAPath path + else + +check :: [FilePath] -> IO () +check = mapM_ checkPath + +main :: IO () +main = do + args <- getArgs + case args of + [] -> noCommand + ("check" : paths) -> check paths + (c:args) -> invalidCommand c args diff --git a/remark.cabal b/remark.cabal new file mode 100644 --- /dev/null +++ b/remark.cabal @@ -0,0 +1,52 @@ +name: remark +version: 0.0.0.0 +synopsis: A DSL for marking student work +description: Please see README.org +homepage: https://github.com/oleks/remark#readme +license: BSD3 +license-file: LICENSE +author: Oleks +maintainer: oleks@oleks.info +copyright: 2017 Oleks +category: Web +build-type: Simple +extra-source-files: README.org +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Ast + , Parser + , Parser.Impl + , Validator + build-depends: base >= 4.7 && < 5 + , GenericPretty >= 1.2.1 + default-language: Haskell2010 + +executable remark + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , remark + , GenericPretty >= 1.2.1 + default-language: Haskell2010 + +test-suite remark-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Tests.hs + other-modules: Parser.BlackBoxTests + ValidatorTests + build-depends: base + , remark + , GenericPretty >= 1.2.1 + , tasty >= 0.11.0.4 + , tasty-hunit >= 0.9.2 + , tasty-golden >= 2.3.1.1 + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/oleks/remark diff --git a/src/Ast.hs b/src/Ast.hs new file mode 100644 --- /dev/null +++ b/src/Ast.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Ast where + +import Text.PrettyPrint.GenericPretty + +newtype Header + = Header (String, Double, Double) + deriving (Eq, Show, Generic) + +instance Out Header + +data Mood + = Positive + | Negative + | Neutral + | Impartial + deriving (Eq, Show, Generic) + +instance Out Mood + +data CommentPart + = CommentStr String + | CommentCmt Comment + deriving (Eq, Show, Generic) + +instance Out CommentPart + +newtype Comment + = Comment (Mood, [CommentPart]) + deriving (Eq, Show, Generic) + +instance Out Comment + +newtype Judgement + = Judgement (Header, [Comment], [Judgement]) + deriving (Eq, Show, Generic) + +instance Out Judgement diff --git a/src/Parser.hs b/src/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Parser.hs @@ -0,0 +1,11 @@ +module Parser + ( ParseError + , parseString + , parseFile + ) where + +import Parser.Impl + ( ParseError + , parseString + , parseFile + ) diff --git a/src/Parser/Impl.hs b/src/Parser/Impl.hs new file mode 100644 --- /dev/null +++ b/src/Parser/Impl.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Parser.Impl where + +import Ast +import Text.ParserCombinators.ReadP +import Text.PrettyPrint.GenericPretty + +import Control.Monad ( void ) +import Data.Maybe ( listToMaybe ) + +data ParseErrorImpl a + = NoParse + | AmbiguousGrammar [a] + | NotImplemented + deriving (Eq, Show, Generic) + +instance (Out a) => Out (ParseErrorImpl a) + +type ParseError = ParseErrorImpl [Judgement] + +parseIntegral :: ReadP String +parseIntegral = munch1 (`elem` ['0'..'9']) + +-- Source: http://hackage.haskell.org/package/cgi-3001.3.0.2/docs/src/Network-CGI-Protocol.html#maybeRead +maybeRead :: Read a => String -> Maybe a +maybeRead = fmap fst . listToMaybe . reads + +parsePoints :: ReadP Double +parsePoints = do + is <- parseIntegral + fs <- (char '.' *> parseIntegral) +++ pure "0" + case (maybeRead (is ++ "." ++ fs)) of + Just x -> pure x + _ -> pfail + +lineToken :: ReadP a -> ReadP a +lineToken p = munch (`elem` [' ', '\t', '\r', '\v', '\f']) *> p + +lineBreak :: ReadP () +lineBreak = void $ lineToken $ char '\n' + +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 ':' + + points <- lineToken $ parsePoints + void $ lineToken $ char '/' + maxPoints <- lineToken $ parsePoints + + void $ lineBreak + + pure $ Header (title, points, maxPoints) + +parseMood :: ReadP Mood +parseMood = choice + [ char '+' *> pure Positive + , char '-' *> pure Negative + , char '*' *> pure Neutral + , char '?' *> pure Impartial + ] + +parseLine :: ReadP String +parseLine = munchTillExcl '\n' + +parseLines :: String -> ReadP [String] +parseLines indent = many $ string indent *> parseLine + +parseCommentPart :: String -> ReadP CommentPart +parseCommentPart indent = many lineBreak *> do + void $ string indent + (fmap CommentCmt $ parseComment indent) <++ + (fmap CommentStr parseLine) + +parseComment :: String -> ReadP Comment +parseComment indent = do + mood <- parseMood + void $ char ' ' + first <- fmap CommentStr parseLine + rest <- many $ parseCommentPart (indent ++ " ") + pure $ Comment (mood, (first : rest)) + +parseComment' :: ReadP Comment +parseComment' = many lineBreak *> do + void $ string " " + parseComment " " + +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 = many . parseJudgement + +parse :: ReadP a -> String -> [(a, String)] +parse = readP_to_S + +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 = + case fullParse p s of + [] -> Left NoParse + [a] -> Right a + as -> Left $ AmbiguousGrammar as + +parseEntry :: ReadP [Judgement] +parseEntry = parseJudgements 1 <* skipSpaces + +parseString :: String -> Either ParseError [Judgement] +parseString = parseString' parseEntry + +parseFile' :: ReadP a -> FilePath -> IO (Either (ParseErrorImpl a) a) +parseFile' p path = fmap (parseString' p) $ readFile path + +parseFile :: FilePath -> IO (Either ParseError [Judgement]) +parseFile = parseFile' parseEntry diff --git a/src/Validator.hs b/src/Validator.hs new file mode 100644 --- /dev/null +++ b/src/Validator.hs @@ -0,0 +1,41 @@ +{-# 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 + 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 + +validate :: Judgement -> Either Invalid () +validate j @ (Judgement (h @ (Header (_, p, maxP)), _, subjs)) = do + try (p <= maxP) + (PointsExceedMaxPoints h) + try ((sum $ map points subjs) ~= p) + (BadSubJudgementPointsSum j) + try ((sum $ map maxPoints subjs) ~= maxP) + (BadSubJudgementMaxPointsSum j) + forM_ subjs validate + +points :: Judgement -> Double +points (Judgement (Header (_, v, _), _, _)) = v + +maxPoints :: Judgement -> Double +maxPoints (Judgement (Header (_, _, v), _, _)) = v diff --git a/test/Parser/BlackBoxTests.hs b/test/Parser/BlackBoxTests.hs new file mode 100644 --- /dev/null +++ b/test/Parser/BlackBoxTests.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Parser.BlackBoxTests ( allTests ) where + +import Ast +import Parser + +import Test.Tasty +import Test.Tasty.HUnit +-- import Test.Tasty.QuickCheck +import Test.Tasty.Golden + +import Text.PrettyPrint.GenericPretty + +unitTests :: TestTree +unitTests = testGroup "Unit tests" + [ testCase "Lone header line" $ + parseString "# A: 0/0\n" @?= + Right + [ Judgement (Header ("A",0.0,0.0), [], []) + ] + , testCase "A couple same-depth header lines" $ + parseString "# 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 simple hierarchy of headers" $ + parseString "# 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" $ + parseString "# 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), [], []) + ]) + , Judgement (Header ("C",0.0,0.0), [], []) + ] + ] + +qcTests :: TestTree +qcTests = testGroup "QuickCheck tests" [] + +golden' :: String -> TestTree +golden' basename = + goldenVsFile name fref fout $ do + p <- parseFile fin + writeFile fout $ (pretty p) ++ "\n" + where + prefix = "test/golden/" + name = basename ++ ".mrk" + fin = prefix ++ name + fref = prefix ++ basename ++ ".ref" + fout = prefix ++ basename ++ ".out" + +goldenTests :: TestTree +goldenTests = testGroup "Golden tests" + [ golden' "deep-judgement" + , golden' "some-top-level-judgements" + , golden' "some-judgements" + ] + +allTests :: TestTree +allTests = testGroup "Black-box parser tests" + [ unitTests, qcTests, goldenTests ] diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,10 @@ +module Main where + +import Test.Tasty + +import qualified Parser.BlackBoxTests as PBBT +import qualified ValidatorTests as VT + +main :: IO () +main = defaultMain $ testGroup "All Tests" + [ PBBT.allTests, VT.allTests ] diff --git a/test/ValidatorTests.hs b/test/ValidatorTests.hs new file mode 100644 --- /dev/null +++ b/test/ValidatorTests.hs @@ -0,0 +1,63 @@ +{-# 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 ()] +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 ()] + , testCase "A couple same-depth header lines" $ + validateStr "# A: 0/0\n# B: 0/0\n" @?= + [Right (), Right ()] + , testCase "A simple hierarchy of headers" $ + validateStr "# A: 0/0\n## B: 0/0\n" @?= + [Right ()] + , testCase "A couple simple hierarchies" $ + validateStr "# A: 0/0\n## B: 0/0\n# C: 0/0\n" @?= + [Right (), Right ()] + ] + +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), [], [])]))] + ] + +qcTests :: TestTree +qcTests = testGroup "QuickCheck tests" [] + +goldenTests :: TestTree +goldenTests = testGroup "Golden tests" [] + +allTests :: TestTree +allTests = testGroup "Validator tests" + [ posUnitTests, negUnitTests, qcTests, goldenTests ]