packages feed

remark (empty) → 0.0.0.0

raw patch · 12 files changed

+548/−0 lines, 12 filesdep +GenericPrettydep +basedep +remarksetup-changed

Dependencies added: GenericPretty, base, remark, tasty, tasty-golden, tasty-hunit

Files

+ LICENSE view
@@ -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.
+ README.org view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -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
+ remark.cabal view
@@ -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
+ src/Ast.hs view
@@ -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
+ src/Parser.hs view
@@ -0,0 +1,11 @@+module Parser+  ( ParseError+  , parseString+  , parseFile+  ) where++import Parser.Impl+  ( ParseError+  , parseString+  , parseFile+  )
+ src/Parser/Impl.hs view
@@ -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
+ src/Validator.hs view
@@ -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
+ test/Parser/BlackBoxTests.hs view
@@ -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 ]
+ test/Tests.hs view
@@ -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 ]
+ test/ValidatorTests.hs view
@@ -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 ]