remarks 0.1.8 → 0.1.9

raw patch · 14 files changed

+230/−118 lines, 14 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• README.md +16/−0
• app/Main.hs +44/−14
• remarks.cabal +4/−3
• src/Ast.hs +2/−2
• src/Export.hs +5/−3
• src/Export/CSV.hs +17/−12
• src/Export/Generic.hs +25/−0
• src/Export/Html.hs +63/−22
• src/Parser/Impl.hs +9/−8
• src/PointsChecker.hs +3/−7
• src/PrettyPrinter.hs +4/−4
• src/PropertyInterp.hs +14/−10
• test/Parser/BlackBoxTests.hs +8/−8
• test/PointsCheckerTests.hs +16/−25

@@ -37,6 +37,22 @@ See [Issues](https://github.com/oleks/remarks/issues) for a roadmap. Feel free to add or fix a couple issues. +## Usage++User features:++* `remarks check [<file>]` checks that the file system structure is+  well-formed. For instance, checks that all explicitly stated point sums+  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.++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

@@ -1,26 +1,29 @@ module Main where  import Ast+import Export+import Invalid import Parser import PointsChecker import PropertyInterp import PrettyPrinter-import Export -import Control.Monad ( void, filterM, liftM, (<=<) )+import Control.Monad ( liftM, (<=<) ) import Data.List ( sort ) import System.Directory   ( doesFileExist, doesDirectoryExist, listDirectory ) import System.FilePath-  ( (<.>), (</>), takeDirectory, takeExtension, dropExtension )+  ( (<.>), (</>), takeExtension, dropExtension ) import System.Environment( getArgs ) import System.Exit ( exitWith, ExitCode ( ExitFailure ) ) import System.IO ( hPutStrLn, stderr )  import Text.PrettyPrint.GenericPretty -splitBy delimiter = foldr f [[]] -  where f c l@(x:xs) | c == delimiter = []:l+splitBy :: (Foldable f, Eq t) => t -> f t -> [[t]]+splitBy delimiter = foldr f []+  where f c [] = f c [[]]+        f c l@(x:xs) | c == delimiter = []:l                      | otherwise = (c:x):xs  report :: String -> IO ()@@ -124,9 +127,12 @@ parsePaths :: [FilePath] -> IO [[Judgement]] parsePaths = mapM parsePath +marshall :: [Judgement] -> Either Invalid [Judgement]+marshall = mapM (interpProps <=< checkPoints)+ check :: [Judgement] -> IO () check js = do-  case mapM (interpProps <=< checkPoints) js of+  case marshall js of     Right newJs -> printJs newJs     Left e -> putStrLn $ show e @@ -135,18 +141,42 @@  export :: [String] -> [Judgement] -> IO () export format js = do-  case mapM (interpProps <=< checkPoints) js of-    Right newJs -> putStrLn $ exportCSV ";" format newJs+  case (exportCSV ";" format =<< (marshall js)) of+    Right docs -> putStrLn docs     Left e -> putStrLn $ show e +export_html :: [Judgement] -> IO ()+export_html js = do+  case (mapM checkPoints js) of+    Right newJs -> putStrLn $ exportHTML newJs+    Left e -> putStrLn $ show e++showSummary :: Word -> [Judgement] -> IO ()+showSummary depth js = do+  case marshall js of+    Right mJs -> printJs $ map (summary depth) mJs+    Left e -> putStrLn $ show e+ main :: IO () main = do   args <- getArgs   case args of     [] -> noCommand-    ("parse" : paths) -> parsePaths paths >>= putStrLn . pretty-    ("check" : paths) -> parsePaths paths >>= mapM_ check-    ("show" : paths) -> parsePaths paths >>= mapM_ printJs-    ("export" : "--format" : format : paths) -> parsePaths paths >>= mapM_ (export (splitBy ';' format))-    ("export" : paths) -> parsePaths paths >>= mapM_ (export ["Title", "Total", "MaxPoints"])-    (c:args) -> invalidCommand c args+    ("parse" : paths) ->+      with paths $ putStrLn . pretty+    ("check" : paths) ->+      with paths $ mapM_ check+    ("show" : paths) ->+      with paths $ mapM_ printJs+    ("summary" : depth : paths) ->+      with paths $ mapM_ $ showSummary (read depth)+    ("export" : "--format" : format : paths) ->+      with paths $ mapM_ $ export (splitBy ';' format)+    ("export" : paths) ->+      with paths $ mapM_ $ export ["Title", "Total", "MaxPoints"]+    ("exportHTML" : paths) ->+      with paths $ mapM_ export_html+    (c:rest) -> invalidCommand c rest+  where+    with :: [FilePath] -> ([[Judgement]] -> IO ()) -> IO ()+    with paths f = parsePaths paths >>= f

@@ -1,5 +1,5 @@ name:                remarks-version:             0.1.8+version:             0.1.9 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@@ -27,6 +27,7 @@                      , PointsChecker                      , PrettyPrinter                      , PropertyInterp+  ghc-options:         -Wall   build-depends:       base >= 4.7 && < 5                      , GenericPretty >= 1.2.1                      , pretty >= 1.1.3.3@@ -35,7 +36,7 @@ executable remarks   hs-source-dirs:      app   main-is:             Main.hs-  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N   build-depends:       base                      , remarks                      , GenericPretty >= 1.2.1@@ -55,7 +56,7 @@                      , tasty >= 0.11.0.4                      , tasty-hunit >= 0.9.2                      , tasty-golden >= 2.3.1.1-  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N   default-language:    Haskell2010  source-repository head

@@ -32,13 +32,13 @@  instance Out Comment -newtype Property +newtype Property   = Property (String, PropertyExp)   deriving (Eq, Show, Generic)  instance Out Property -data PropertyExp +data PropertyExp   = Lookup (Int, String)   | Value  String   | Num  Double

@@ -1,14 +1,16 @@-module Export (exportHTML, exportCSV) where+module Export (exportHTML, exportCSV, unify, summary) where  import Ast+import Invalid import Export.Html import Export.CSV+import Export.Generic ( unify, summary )  import Text.PrettyPrint  exportHTML :: [Judgement] -> String exportHTML = render . htmlRemarks -exportCSV :: String -> [String] -> [Judgement] -> String-exportCSV delim ps js = render $ csvRemarks delim ps js+exportCSV :: String -> [String] -> [Judgement] -> Either Invalid String+exportCSV delim ps js = (pure . render) =<< csvRemarks delim ps js 

@@ -1,27 +1,32 @@ module Export.CSV (csvRemarks) where  import Ast+import Invalid import Export.Generic  import Text.PrettyPrint import Data.List (intersperse) -csvRemarks :: String -> [String] -> [Judgement] -> Doc-csvRemarks delimiter propertyList judgements = -  (hcat $ (intersperse (text delimiter)) $ map text propertyList) $$-  (vcat $ map (formatJudgement delimiter propertyList) judgements)+csvRemarks :: String -> [String] -> [Judgement] -> Either Invalid Doc+csvRemarks delimiter propertyList judgements = do+  doc <- mapM (formatJudgement delimiter propertyList) judgements+  pure ((hcat $ (intersperse (text delimiter)) $ map text propertyList) $$ (vcat $ doc)) -formatJudgement :: String -> [String] -> Judgement -> Doc-formatJudgement delimiter properties judgement = -  hcat $ (intersperse (text delimiter)) $ map (mapfun judgement) properties++formatJudgement :: String -> [String] -> Judgement -> Either Invalid Doc+formatJudgement delimiter properties judgement = do+  doc <- mapM (mapfun judgement) properties+  pure $ hcat $ (intersperse (text delimiter)) doc   where-    mapfun = flip lookupProperty +    mapfun = flip lookupProperty -lookupProperty :: String -> Judgement -> Doc-lookupProperty name (Judgement (_, properties, _, _)) = +lookupProperty :: String -> Judgement -> Either Invalid Doc+lookupProperty name (Judgement (_, properties, _, _)) =   case (lookup name (map (\(Property (n,v)) -> (n,v)) properties)) of-    Nothing -> error "Property not found."-    Just(value) -> formatPropertyExp value+    Nothing -> Left $ PropertyNotFound name+    Just(value) -> pure $ formatPropertyExp value+lookupProperty name _ =+  Left $ PropertyNotFound name  formatPropertyExp :: PropertyExp -> Doc formatPropertyExp (Lookup (index, name)) =

@@ -1,5 +1,6 @@ module Export.Generic where +import Ast import Text.PrettyPrint  isIntegral :: Double -> Bool@@ -9,3 +10,27 @@ pointsDoc v | isNaN v = empty pointsDoc v | isIntegral v = integer (round v) pointsDoc v = double v++unify :: Judgement -> Judgement -> Maybe Judgement+unify+  (Judgement (lh, _, lcs, []))+  (Judgement (rh, rps, rcs, _))+        | lh == rh && lcs == rcs = do+    pure $ Judgement (lh, rps, lcs, [])+unify+  (Judgement (lh, _, lcs, ljs))+  (Judgement (rh, rps, rcs, rjs))+        | lh == rh && lcs == rcs = do+    newJs <- mapM (uncurry unify) (zip ljs rjs)+    pure $ Judgement (lh, rps, lcs, newJs)+unify (Bonus l) (Bonus r) | l == r =+    pure $ (Bonus l)+unify _ _ = Nothing++summary :: Word -> Judgement -> Judgement+summary _ (Bonus (p, _)) =+  (Bonus (p, []))+summary 0 (Judgement (h, _, _, _)) =+  Judgement (h, [], [], [])+summary depth (Judgement (h, _, _, js)) =+  Judgement (h, [], [], map (summary $ depth - 1) js)

@@ -6,13 +6,13 @@ import Text.PrettyPrint  htmlRemarks :: [Judgement] -> Doc-htmlRemarks js = -  doctype $ html $ -    (head_ $ documentStyle $$ documentScript) $$ +htmlRemarks js =+  doctype $ html $+    (head_ $ documentStyle $$ documentScript) $$     (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@@ -20,69 +20,110 @@ atag :: String -> String -> Doc -> Doc atag tagStr attrStr = tag tagStr (text attrStr) +doctype :: Doc -> Doc doctype = ($$) (text "<!DOCTYPE html>")++html :: Doc -> Doc html   = etag "html"++head_ :: Doc -> Doc head_  = etag "head"++body :: Doc -> Doc body   = etag "body"++script :: Doc -> Doc script = atag "script" "type=\"text/javascript\""++style_ :: Doc -> Doc style_ = etag "style"++table :: Doc -> Doc table  = atag "table" "border=\"1\""++tr :: Doc -> Doc tr     = etag "tr"++trhidden :: Doc -> Doc trhidden = atag "tr" "style=\"display: none;\""++th :: Doc -> Doc th     = etag "th"++td :: Doc -> Doc td     = etag "td"++toggle :: Doc -> Doc toggle = atag "a" "href=\"#\" onclick=\"toggleRow(this);\""++ul :: Doc -> Doc ul     = etag "ul"-li     = etag "li" +liclass :: String -> Doc -> Doc liclass c = atag "li" $ "class=\"" ++ c ++ "\""-tdspan i  = atag "td" $ "colspan=\"" ++ (show i) ++ "\"" -br = text "<br>"+tdspan :: Show a => a -> Doc -> Doc+tdspan i  = atag "td" $ "colspan=\"" ++ (show i) ++ "\"" +details :: Doc -> Doc -> Doc details d1 d2 = etag "details" ((etag "summary" d1) $$ d2) -documentStyle = style_ $ -  text "details {padding-left: 16px;}" $$      +documentStyle :: Doc+documentStyle = style_ $+  text "details {padding-left: 16px;}" $$   text "ul {list-style: none; padding-left: 16px; padding-top: 0px; padding-bottom: 0px; margin-top: 0px; margin-bottom: 0px;}" $$   text "li.plus:before {content: \"+\"; margin-right: 4px;}" $$   text "li.minus:before {content: \"-\"; margin-right: 4px;}" $$   text "li.quest:before {content: \"?\"; margin-right: 4px;}" $$   text "li.star:before {content: \"*\"; margin-right: 4px;}" -documentScript = script $ +documentScript :: Doc+documentScript = script $   nest 2 ((text "function toggleRow(e){") $$           nest  2 ((text "var subRow = e.parentNode.parentNode.nextElementSibling;") $$           text "subRow.style.display = subRow.style.display === 'none' ? 'table-row' : 'none';") $$    (text "}"))  htmlTableHead :: Judgement -> Doc-htmlTableHead (Judgement (_, _, _, js)) = +htmlTableHead (Bonus _) =+  tr $ th (text "Bonus")+htmlTableHead (Judgement (_, _, _, js)) =   tr $ th (text "Title") $$ (vcat $ map maketd js) $$ th (text "Total")   where-    maketd (Judgement (Header(title, _, maxPoint), _, _, _)) = th $ text (title ++ "/") <> pointsDoc maxPoint+    maketd (Judgement (Header(title, _, maxPoint), _, _, _)) =+      th $ text (title ++ "/") <> pointsDoc maxPoint+    maketd (Bonus _) =+      th $ text "Bonus"  htmlJudgement :: Judgement -> Doc-htmlJudgement (Judgement (Header(title, points, maxPoint), _, comments, judgements)) = -  (tr $ (td . toggle $ text title) $$ vcat (map htmlSubJudgement judgements) $$ (td $ pointsDoc points)) $$+htmlJudgement (Bonus (points, comments)) =+  (tr $ td $ pointsDoc points) $$ (trhidden $ htmlDetailComments comments)+htmlJudgement (Judgement (Header(title, points, _), _, comments, judgements)) =+  (tr $ (td . toggle $ text title) $$+    vcat (map htmlSubJudgement judgements) $$+    (td $ pointsDoc points)) $$   (trhidden $ tdspan (length judgements+2) $ (htmlDetailComments comments $$ htmlDetailJudgements judgements))  htmlSubJudgement :: Judgement -> Doc-htmlSubJudgement (Judgement (Header(title, points, maxPoint), _, comments, judgements)) = -  (td $ pointsDoc points) +htmlSubJudgement (Bonus (points, _)) =+  (td $ pointsDoc points)+htmlSubJudgement (Judgement (Header(_, points, _), _, _, _)) =+  (td $ pointsDoc points) -htmlDetailJudgements :: [Judgement] -> Doc -htmlDetailJudgements = vcat . (map htmlDetailJudgement) +htmlDetailJudgements :: [Judgement] -> Doc+htmlDetailJudgements = vcat . (map htmlDetailJudgement)  htmlDetailJudgement :: Judgement -> Doc-htmlDetailJudgement (Judgement (Header(title, points, maxPoint), _, comments, judgements)) = -  details -    (text title <> parens (pointsDoc points <> text "/" <> pointsDoc maxPoint)) +htmlDetailJudgement (Bonus (points, comments)) =+  details (pointsDoc points) (htmlDetailComments comments)+htmlDetailJudgement (Judgement (Header(title, points, maxPoint), _, comments, judgements)) =+  details+    (text title <> parens (pointsDoc points <> text "/" <> pointsDoc maxPoint))     (htmlDetailComments comments $$ htmlDetailJudgements judgements)  htmlDetailComments :: [Comment] -> Doc htmlDetailComments [] = text ""-htmlDetailComments comments = +htmlDetailComments comments =   ul . vcat $ map htmlDetailComment comments  htmlDetailComment :: Comment -> Doc

@@ -51,9 +51,9 @@ munchTillExcl :: Char -> ReadP String munchTillExcl c = munch (/= c) <* char c -parseBonus :: String -> ReadP Judgement-parseBonus title = do-  lineToken $ char '+'+parseBonus :: ReadP Judgement+parseBonus = do+  void $ lineToken $ char '+'   points <- parsePoints   void $ lineBreak   comments <- many parseComment'@@ -61,7 +61,7 @@  parsePropertyExp :: ReadP PropertyExp parsePropertyExp = choice [lookupProp, value]-  where +  where     lookupProp = do       void $ char '['       index <- parseIntegral@@ -72,9 +72,10 @@         Just i -> pure $ Lookup (i, name)         _ -> pfail     value = do-      v <- satisfy (/='[')-      value <- parseLine-      pure $ Value (v:value)+      c <- satisfy (/='[')+      case c of+       '\n' -> pure $ Value ""+       _    -> (\cs -> pure $ Value (c:cs)) =<< parseLine  parseProperty :: ReadP Property parseProperty = do@@ -106,7 +107,7 @@   title <- lineToken $ munchTillExcl ':'    case title of-    "Bonus" -> parseBonus title+    "Bonus" -> parseBonus     _ -> parseRegularJudgement depth title  parseMood :: ReadP Mood

@@ -1,12 +1,8 @@-{-# LANGUAGE DeriveGeneric #-}- module PointsChecker ( checkPoints ) where  import Ast import Invalid -import Control.Monad ( forM_ )- try :: Bool -> Invalid -> Either Invalid () try True = \_ -> Right () try False = Left@@ -16,16 +12,16 @@ x ~= y = abs (x - y) <= 0.01  checkPointsSubJs :: Judgement -> Either Invalid Judgement-checkPointsSubJs (Judgement (h @ (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 (h @ (Header (_, p, maxP)), _, _, [])) | isInfinite p = do+checkPoints j @ (Judgement ((Header (_, p, _)), _, _, [])) | isInfinite p = do   Left $ NoPointsInBottomJudgement j-checkPoints j @ (Judgement (h @ (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

@@ -10,7 +10,7 @@ ppJs = render . vcat . intersperse (text "") . map (formatJudgement 1)  formatJudgement :: Int -> Judgement -> Doc-formatJudgement level (Bonus (points, comments)) =+formatJudgement level (Bonus (points, _)) =   (text $ replicate level '#') <+> text "Bonus" <> colon <+> text "+" <>     pointsDoc points formatJudgement level (Judgement (header, properties, comments, judgements)) =@@ -21,7 +21,7 @@  formatHeader :: Int -> Header -> Doc formatHeader level (Header (title, point, maxPoints)) =-  (text $ replicate level '#') <+> text title <> colon <>+  (text $ replicate level '#') <+> text title <> colon <> space <>     pointsDoc point <> text "/" <> pointsDoc maxPoints  formatProperty :: Property -> Doc@@ -31,8 +31,8 @@ formatPropertyExp :: PropertyExp -> Doc formatPropertyExp (Lookup (index, name)) =   brackets $ int index <> text "." <> text name-formatPropertyExp (Value value) = text value-formatPropertyExp (Num double) = pointsDoc double+formatPropertyExp (Value v) = text v+formatPropertyExp (Num v) = pointsDoc v  formatComment :: Comment -> Doc formatComment (Comment (mood, commentParts)) =

@@ -18,43 +18,47 @@ instance Out PropertyValue  interpProps :: Judgement -> Either Invalid Judgement-interpProps j = +interpProps j =   case (interpJudgement j) of     Right (jnew, _) -> Right jnew     Left invalid -> Left invalid  interpJudgement :: Judgement -> Either Invalid (Judgement, [(String, PropertyValue)])-interpJudgement j @ (Judgement (h, prop, cs, js)) = do+interpJudgement (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)   let newProps = map propValToProperties propVals   pure (Judgement (h, newProps, cs, jupdates), propVals)+interpJudgement j @ (Bonus (v, _)) = pure (j, [("Bonus", DoubVal v)])  propValToProperties :: (String, PropertyValue) -> Property propValToProperties (str, StrVal string) = Property (str, Value string) propValToProperties (str, DoubVal double) = Property (str, Num double)  addPredifinedProps :: [Property] -> [Property]-addPredifinedProps p = -  Property("Title", Lookup (0, "Title")) : -  Property("Total", Lookup (0, "Total")) : +addPredifinedProps p =+  Property("Title", Lookup (0, "Title")) :+  Property("Total", Lookup (0, "Total")) :   Property("MaxPoints", Lookup (0, "MaxPoints")) : p  generatePredefinedValues :: Header -> Either Invalid [(String, PropertyValue)]-generatePredefinedValues (Header (t, p, maxP)) = +generatePredefinedValues (Header (t, p, maxP)) =   pure [("Title", StrVal t), ("Total", DoubVal p), ("MaxPoints", DoubVal maxP)] -bindProp :: [[(String, PropertyValue)]] -> Property -> Either Invalid (String, PropertyValue)-bindProp propEnv (Property (name, propExp)) = +bindProp :: [[(String, PropertyValue)]] -> Property ->+  Either Invalid (String, PropertyValue)+bindProp propEnv (Property (name, propExp)) =   case (evalPropExp propExp propEnv) of     Right (val)  -> pure (name, val)     Left invalid -> Left invalid -evalPropExp :: PropertyExp -> [[(String, PropertyValue)]] -> Either Invalid PropertyValue+evalPropExp :: PropertyExp -> [[(String, PropertyValue)]] ->+  Either Invalid PropertyValue evalPropExp (Value s) _ = pure $ StrVal s-evalPropExp (Lookup (i, p)) propEnv = +evalPropExp (Num n) _ = pure $ DoubVal n+evalPropExp (Lookup (i, p)) propEnv =   case (lookup p (propEnv !! (i))) of     Nothing -> Left $ PropertyNotFound p     (Just s) -> pure s

@@ -17,28 +17,28 @@   [ testCase "Lone header line" $       parseString "# A: 0/0\n" @?=         Right-          [ Judgement (Header ("A",0.0,0.0), [], [])+          [ 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), [], [])+          [ 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), [], [])+          [ 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 ("A",0.0,0.0), [], [],+            [ Judgement (Header ("B",0.0,0.0), [], [], [])             ])-          , Judgement (Header ("C",0.0,0.0), [], [])+          , Judgement (Header ("C",0.0,0.0), [], [], [])           ]   ] 

@@ -5,45 +5,42 @@ import Ast import Parser import PointsChecker+import Invalid  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 -> []+    Left _ -> []  posUnitTests :: TestTree posUnitTests = testGroup "Positive Unit Tests"   [ testCase "Lone header line" $       checkPointsStr "# A: 0/0\n" @?=         [ Right $-          Judgement (Header ("A", 0.0, 0.0), [], [])]+          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), [], [])+          Judgement (Header ("A", 0.0, 0.0), [], [], [])         , Right $-          Judgement (Header ("B", 0.0, 0.0), [], [])+          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), [], [])])]+          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), [], [])])+          Judgement (Header ("A", 0.0, 0.0), [], [],+            [Judgement (Header ("B", 0.0, 0.0), [], [], [])])         , Right $-          Judgement (Header ("C", 0.0, 0.0), [], [])+          Judgement (Header ("C", 0.0, 0.0), [], [], [])         ]   ] @@ -55,25 +52,19 @@   , 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), [], [])]))]+          (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), [], [])]))]+          (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), [], []))]+          (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 ]+  [ posUnitTests, negUnitTests ]