From 1e7e0ac33bcade33de3fa457bdebb915a339fef4 Mon Sep 17 00:00:00 2001 From: Nathaniel Wesley Filardo Date: Mon, 31 Aug 2015 04:00:08 -0400 Subject: [PATCH] Initial Haskell version --- .gitignore | 1 + COPYING | 26 +++ README.rst | 263 +++++++++++++++++++++++ examples/data | 34 +++ examples/defines.conf | 41 ++++ grade.cabal | 49 +++++ lib/Grade/Grade.hs | 85 ++++++++ lib/Grade/Parse.hs | 138 ++++++++++++ lib/Grade/Print.hs | 51 +++++ lib/Grade/Score/Bounding.hs | 13 ++ lib/Grade/Score/EqualWeighted.hs | 33 +++ lib/Grade/Score/EqualWeightedCounting.hs | 27 +++ lib/Grade/Score/Setting.hs | 52 +++++ lib/Grade/Score/Simple.hs | 50 +++++ lib/Grade/Score/Zeroing.hs | 42 ++++ lib/Grade/Skeleton.hs | 37 ++++ lib/Grade/Types.hs | 159 ++++++++++++++ prog/Grade.hs | 99 +++++++++ 18 files changed, 1200 insertions(+) create mode 100644 .gitignore create mode 100644 COPYING create mode 100644 README.rst create mode 100644 examples/data create mode 100644 examples/defines.conf create mode 100644 grade.cabal create mode 100644 lib/Grade/Grade.hs create mode 100644 lib/Grade/Parse.hs create mode 100644 lib/Grade/Print.hs create mode 100644 lib/Grade/Score/Bounding.hs create mode 100644 lib/Grade/Score/EqualWeighted.hs create mode 100644 lib/Grade/Score/EqualWeightedCounting.hs create mode 100644 lib/Grade/Score/Setting.hs create mode 100644 lib/Grade/Score/Simple.hs create mode 100644 lib/Grade/Score/Zeroing.hs create mode 100644 lib/Grade/Skeleton.hs create mode 100644 lib/Grade/Types.hs create mode 100644 prog/Grade.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..a01ee28 --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +.*.swp diff --git a/COPYING b/COPYING new file mode 100644 index 0000000..b9d2113 --- /dev/null +++ b/COPYING @@ -0,0 +1,26 @@ +Copyright (c) 2015, Nathaniel Wesley Filardo +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. +2. 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. + +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. + +The views and conclusions contained in the software and documentation are those +of the authors and should not be interpreted as representing official policies, +either expressed or implied, of any entity other than the author. diff --git a/README.rst b/README.rst new file mode 100644 index 0000000..71747fb --- /dev/null +++ b/README.rst @@ -0,0 +1,263 @@ +########################################## +GRADE Reporting And Definition Environment +########################################## + +Inspired by the grading infrastructure developed by David Eckhardt at +Carnegie Mellon University for http://www.cs.cmu.edu/~410/ , GRADE is a +lightweight, file-based, *directive*-based approach to managing the work of +grading students in a course. It uses a minimal markup format for both its +machine-readable scoring rubric and for grader data files. + +Student View +############ + +Students will get back tastefully formatted grade files. A very short +example looks something like this:: + + Packaging: [10/10] (100.00%) + + Grader comments: + + Everything looks great here. Thanks for the very informative README! + + Functionality Tests: [30/40] (75.00%) + + (-6.0) + The buffer-passing test seems to mangle bytes on occasion. + + (-4.0) + There is a minor problem with the buffer-passing test output + when given an unusually long input string. + + Grader comments: + + Both of these test failures occur because ... + + TOTAL: [40/50] (80.00%) + +Basic Grader Use +################ + +The instructor will have prepared a ``skeleton`` file which will look +something like this:: + + # Basic features of the handin + @packaging + #:ftbfs_all + #:missing_readme + #:readme_no_commentary + #:readme_no_instructions + #:tarball_directory + #:missing_make + + $BEGIN_COMMENTS + + $END_COMMENTS + + # Automated test result section + @tests + # Un-comment the appropriate directive for each test failed. + #:ftbfs_all + #:simple_test + #:more_interesting_test + #:more_interesting_test_minor + #:test_everything + + $BEGIN_COMMENTS + + $END_COMMENTS + +etc. The graders should copy this skeleton and mutate it appropriately for +each assignment they grade. The example grade output above might have come +from a grading data file like this:: + + @packaging + $BEGIN_COMMENTS + + Everything looks great here. Thanks for the very informative README! + + $END_COMMENTS + + @tests + :simple_test + :more_interesting_test_minor + + $BEGIN_COMMENTS + + Both of these test failures occur because ... + + $END_COMMENTS + +In more detail: + +* Sections are separated by lines beginning with ``@``. + +* Blocks surrounded by ``$BEGIN_COMMENTS``/``$END_COMMENTS`` will be copied + into the appropriate section of the student report under the heading of + ``Grader comments``. + +* **outside** the comment blocks, all characters on a line after a ``#`` + mark will be ignored. Inside comment blocks, all bytes will be copied + over verbatim (modulo an indentation prefix for pretty-printing). + +* Text and scores associated with each un-commented ``:``-line (which are + defined by the instructor) will also be emitted to the correct section. + +Instructor Use +############## + +Constructing a Rubric +--------------------- + +A rubric file, typically called ``defines.conf``, consists of a number of +sections. Each section has a name as well as some other parameters, and +contains the definition of the flags seen in the grader data. + +Sections are introduced with ``@``-lines, like in the grading data, except +that here, they take arguments:: + + @section-name type [extra] - friendly-name + +where + +* ``section-name`` is the short name as used in the grade data. It may + not contain whitespace. + +* ``type`` indicates to the ``grade`` program how to interpret this + section. If ``type`` begins with ``!``, the section will be omitted + from the generated skeleton and this initial ``!`` will be stripped + from the type before consulting the following choices. + + * The word ``simple`` defines a section of define flags whose invoked + scores are simply summed. ``extra`` here should be the section's + maximum value. + + * The word ``equal`` defines a section of equally-weighted flags; again, + ``extra`` should be the section's maximum value. + + * The word ``bounding`` followed by (whitespace and) another ``type`` will + behave as that type except that the score will be between zero and that + type's derived maximum. That is, this section will behave as if it had + that ``type`` but will yield no scores below zero and no extra credit. + + * The word ``nonneg`` bounds the section's score from below at ``0``; that + is, it permits extra credit but not extra loss. + + * The word ``zeroing`` followed by (whitespace and) another ``type`` will + permit the definitions of flags with argument ``!0`` which will set the + section score to zero. + + * The word ``0`` is a shorthand for ``zeroing bounding simple``. + +* ``friendly-name`` is the section heading as presented to students. It may + contain spaces, and is in fact the remainder of the @ line. + +Within sections, each flag definition takes the form :: + + :flag-name score-modifier + Commentary paragraph 1 + paragraph 1 line 2 + + paragraph 2 + . + +``flag-name`` is the name of the flag used in the grading data files. +``score-modifier`` is defined by the section type. While most flags will be +introduced with ``:``, it is also possible to use ``;``; flags defined this +later way are OK for *multi-use* (with the commensurate impact on the +section's score), whereas ``:``-defined flags will trigger an error if used +more than once. + +* For ``simple`` sections, the ``score-modifier`` may be + + * a number, which adjusts the score of this section by that many absolute + points. As such, this number is almost always negative (i.e., + beginning with a ``-``), but positive numbers are understood for some form + of extra credit. (Note that the script will refuse to set a score higher + than the section maximum.) + + * a number followed by a ``%`` character, which will adjust the section + score by that percentage of the maximum number of points available in + the section. + + * The literal string ``!0``. Engaging any whole number of flags so + defined will set the section's score to zero. + +* For ``equal`` sections, the only permitted non-empty ``score-modifier`` + is ``!0``, which is interpreted as in ``simple`` sections. All other + flags in this type of section should have an empty ``score-modifier``. + +Text between the line beginning with ``:`` (or ``;``) and the dot on a line +by itself will be copied into student grade reports whenever the flag is +given in a grade data file. In many cases, there are many conditions that +may merit the use of the same flag, and students will benefit from +additional feedback about exactly what offense has been committed; +historically, rather than introduce many flags, a simple "see the note +below" in the prose has sufficed. Of course, this is up to judgement and +taste. + +Lines that begin with ``#`` and not ``#!`` will be copied into the skeleton. +Lines beginning with ``#!`` will be ignored entirely, except for some +additional advanced handling in comments immediately before a ``@`` section +heading: + +* ``#!\n`` (yes, a literal backslash) will cause an empty line to be emitted + into the skeleton if the containing section is not being skipped. + +* ``#!noskip`` will cause subsequent comment lines in a skipped section to + to be emitted. In a non-skipped section, it has no effect. + +* ``#!reskip`` will cause subsequent comment lines to be skipped if the + containing section is skipped. It has no effect otherwise. + +Continuing the example above, the corresponding ``defines.conf`` contains, +among other defines :: + + #! This line will be ignored + # Basic features of the handin + @packaging 0 10 - Packaging + :ftbfs_all -10 + The submission failed to compile. + . + + #! ... + + # Automated test result section + @tests 0 40 - Functionality Tests + # Un-comment the appropriate directive for each test failed. + + #! ... + + :simple_test -6 + The buffer-passing test seems to mangle bytes on occasion. + . + + #! ... + + :more_interesting_test_minor -4 + There is a minor problem with the buffer-passing test output + when given an unusually long input string. + . + + #! ... + +Generating a Skeleton +--------------------- + +Given a rubric, typically called ``defines.conf``, one can produce a +skeletal grading file by :: + + grade make-skeleton < defines.conf > skeleton + +Producing grade results +----------------------- + +Given a rubric and a grader data file, ``student.data``, one runs :: + + grade grade-one defines.conf < student.data + +to obtain the pretty-printed report and numeric score result. + +It is easy to adjust the weights of different flags and sections by simply +altering the values in ``defines.conf`` file and re-running the ``grade`` +program. diff --git a/examples/data b/examples/data new file mode 100644 index 0000000..7a39030 --- /dev/null +++ b/examples/data @@ -0,0 +1,34 @@ +# +@packaging +#:ftbfs_all + +$BEGIN_COMMENTS +Some grader comments on packaging +$END_COMMENTS + +@tests + +:simple_test +:more_interesting_test_minor + +# Note that this is OK to use twice: +:misc_ding +:misc_ding + +# But uncommenting this would give an error! +# :simple_test + +$BEGIN_COMMENTS +More grader comments in a different section +$END_COMMENTS + +# If we un-commented this line, it would result in a duplicate +# section error! +#@tests + +# If we had this, we'd get an unknown section error +#@foo + +@tests2 +:some_other_test +#:yet_another_test diff --git a/examples/defines.conf b/examples/defines.conf new file mode 100644 index 0000000..ca4cede --- /dev/null +++ b/examples/defines.conf @@ -0,0 +1,41 @@ +#! This line will be ignored +# Basic features of the handin +@packaging 0 10 - Packaging +:ftbfs_all !0 +The submission failed to compile. +. + +# Manual test result section +@tests bounding simple 40 - Functionality Tests +# Un-comment the appropriate directive for each test failed. + +:simple_test -6 +The buffer-passing test seems to mangle bytes on occasion. +. + +:more_interesting_test_minor -10% +There is a minor problem with the buffer-passing test output +when given an unusually long input string. +. + +# May be assessed more than once! +;misc_ding -1 +Some small problem happened (see grader commentary below). +. + +# Equal-weighted test section, hidden from the skeleton +#!noskip +# These lines will, despite this section being hidden, still +# appear in the skeleton file. This may be useful for giving +# instructions to graders. +#!\n +# This is a second paragraph appearing in the skeleton. +#!reskip +@tests2 !equal 40 - More Functionality Tests +:some_other_test +SOT +. + +:yet_another_test +YAT +. diff --git a/grade.cabal b/grade.cabal new file mode 100644 index 0000000..6e34951 --- /dev/null +++ b/grade.cabal @@ -0,0 +1,49 @@ +name: grade +version: 0.1.0.0 +-- synopsis: +-- description: +license: BSD2 +license-file: COPYING +author: Nathaniel Wesley Filardo +maintainer: nwf@ietfng.org +-- copyright: +-- category: +build-type: Simple +extra-source-files: README.rst +cabal-version: >=1.10 + +library + exposed-modules: Grade.Types, + Grade.Parse, + Grade.Grade, + Grade.Score.Zeroing, + Grade.Score.Setting, + Grade.Score.Bounding, + Grade.Score.Simple, + Grade.Score.EqualWeighted, + Grade.Score.EqualWeightedCounting, + Grade.Skeleton, + Grade.Print + hs-source-dirs: lib + default-language: Haskell2010 + build-depends: base >=4.6 && <5, + bytestring >=0.10 && <0.11, + containers >=0.5 && <1, + lens >=4 && <5, + mtl >=2.2 && <3, + parsers >=0.12 && <1, + text >=1.2 && <2, + trifecta >=1.5 && <2, + wl-pprint-extras >=3.5 && <4 + +executable grade + Main-Is: Grade.hs + hs-source-dirs: prog + default-language: Haskell2010 + other-extensions: CPP + build-depends: base >=4.6 && <5, + cmdlib >= 0.3 && <1, + trifecta >=1.5 && <2, + ansi-wl-pprint >= 0.6 && <1, + wl-pprint-extras >=3.5 && <4, + grade >=0.1 diff --git a/lib/Grade/Grade.hs b/lib/Grade/Grade.hs new file mode 100644 index 0000000..eea6e8e --- /dev/null +++ b/lib/Grade/Grade.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -Wall #-} + +module Grade.Grade (gradeOne) where + +import Control.Lens +import Control.Monad +import Control.Monad.State +import Data.Either +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.Text as T + +import Grade.Types + +collectErrors :: [Either e a] -> Either [e] [a] +collectErrors x = case partitionEithers x of + ([], r) -> Right r + (l, _) -> Left l + +lookupSectionDings :: [(DingName, loc)] + -> M.Map DingName (Ding sdt loc') + -> Either [SectionError loc] [(Ding sdt loc', loc)] +lookupSectionDings dns0 sm = collectErrors $ flip evalState M.empty $ mapM look dns0 + where + look (d,loc) = do + already <- gets (M.lookup d) + case already of + Just loc' -> return $ Left $ SEDuplicateDing d loc' loc + Nothing -> case M.lookup d sm of + Nothing -> return $ Left $ SEUndefinedDing d loc + Just dd -> do + when (not $ _ding_multiple dd) $ modify (M.insert d loc) + return $ Right (dd,loc) + +dingsToScore :: ExSection loc' + -> [(DingName, loc)] + -> Either [SectionError loc] (T.Text, Double, Double, [T.Text]) +dingsToScore es dns = + case es of + ExSec (Sec stitle smax _ sfn spo sdm _) -> + either Left (either (Left . pure . SEScoreError) + (\(sc, ds) -> Right (stitle, sc, smax, map dopo ds))) + $ bimap id (reduce . map fst) $ lookupSectionDings dns sdm + where + reduce ds = (\x -> (x,ds)) <$> (sfn $ mconcat $ map _ding_mod ds) + + dopo d = T.unlines $ addMod $ pure $ _ding_text d + where + addMod = if smax == 0.0 + then id -- Don't print if section is worthless + else maybe id -- Don't print if the section chooses to not + ((:) . T.cons '(' . flip T.snoc ')' . T.pack) -- Add parens otherwise + (spo (_ding_mod d)) + +processDFS :: Defines loc' + -> DataFileSection loc + -> Either (ReportError loc) (T.Text, Double, Double, [T.Text]) +processDFS (Defs sm) (DFS sn sl dns _) = maybe (Left $ REUnknownSection sn sl) + (bimap (RESectionError sn) id) + $ (\(es,_) -> dingsToScore es dns) <$> M.lookup sn sm + +checkProcessedAll :: Defines defloc + -> (Either [ReportError loc] a, M.Map SecName b) + -> Either [ReportError loc] a +checkProcessedAll (Defs sm) (ea, m) = + let missing = M.keysSet sm `S.difference` M.keysSet m in + if S.null missing + then ea + else Left $ case ea of + Right _ -> [REMissingSections missing] + Left es -> REMissingSections missing : es + +gradeOne :: Defines loc' -> DataFile loc -> Either [ReportError loc] ReportFile +gradeOne defs (DF dfss) = checkProcessedAll defs + $ over _1 (fmap RF . collectErrors) + $ flip runState M.empty $ mapM go dfss + where + go dfs@(DFS sn sloc _ gcs) = do + already <- gets (M.lookup sn) + case already of + Just loc' -> return $ Left $ REDuplicateSection sn loc' sloc + Nothing -> do + modify (M.insert sn sloc) + return $ (\(st,sc,smax,bs) -> RFS st sc smax bs gcs) <$> processDFS defs dfs diff --git a/lib/Grade/Parse.hs b/lib/Grade/Parse.hs new file mode 100644 index 0000000..fa21c7e --- /dev/null +++ b/lib/Grade/Parse.hs @@ -0,0 +1,138 @@ +-- Header -------------------------------------------------------------- {{{ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module Grade.Parse ( + SecCallback(..), parseDefns, parseData, commentStart, commentEnd +) where + +import Control.Applicative +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8') +import qualified Data.Char as C +import qualified Data.Map as M +import qualified Data.String as S +import Data.Maybe (isJust) +import qualified Text.Trifecta as T +import qualified Text.Trifecta.Delta as T +import qualified Text.Parser.LookAhead as T + +import Grade.Types + +------------------------------------------------------------------------ }}} +-- Common -------------------------------------------------------------- {{{ + +commentStart, commentEnd :: (S.IsString s) => s +commentStart = "$BEGIN_COMMENTS" +commentEnd = "$END_COMMENTS" + +toUtf8 :: (Monad f, T.Parsing f) => f ByteString -> f Text +toUtf8 = (>>= either (\e -> T.unexpected ("Invalid UTF-8: " ++ show e)) (pure) . decodeUtf8') + +-- | Grab a comment beginning with # and going to end of line. +hashComment :: T.DeltaParsing f => f Text +hashComment = toUtf8 (T.sliced (T.char '#' *> many (T.noneOf "\r\n"))) <* T.whiteSpace +-- hashComment = T.sliced (T.char '#' *> T.manyTill T.anyChar T.newline) <* T.whiteSpace + +word :: (T.DeltaParsing f) => f Text +word = toUtf8 (T.sliced (many $ T.satisfy (not . C.isSpace))) <* T.whiteSpace + +------------------------------------------------------------------------ }}} +-- Defines ------------------------------------------------------------- {{{ + +-- | Grab a ByteString that is a wad of text terminated by a dot on a line +-- by itself. This terminating line is not included. +untilDotLine :: (T.DeltaParsing f, T.LookAheadParsing f) => f Text +untilDotLine = toUtf8 (T.sliced (T.manyTill T.anyChar (T.try $ T.lookAhead end))) + <* end <* T.whiteSpace + where + end = T.newline *> T.char '.' *> T.newline + +-- | Given a parser for X, parse lines of the form ":-name X" preceeded by +-- any number of "# comment" lines and followed by the ding text, terminated +-- by a dot line. +parseDingDefn :: (T.DeltaParsing f, T.LookAheadParsing f) + => f (sdt,sds) -> f (DingName, sds, Ding sdt T.Caret) +parseDingDefn dl = do + (dcs, reuse) <- T.try ((,) <$> many (hashComment) <*> leadchar) + dn T.:^ c <- T.careted (DN <$> word) + (dm, ds) <- dl + dt <- untilDotLine + pure (dn, ds, Ding dm c reuse dt dcs) + where + leadchar = T.choice [ T.char ':' *> pure False + , T.char ';' *> pure True + ] + + +parseSectionDefn :: (T.DeltaParsing f, T.MarkParsing T.Delta f, T.Errable f, T.LookAheadParsing f) + => f (SecCallback f) -> f (SecName, T.Caret, ExSection T.Caret) +parseSectionDefn fsdap = do + scs <- many hashComment + _ T.:^ c <- T.careted (T.symbolic '@') + sname <- SN <$> word + shidden <- isJust <$> T.optional (T.char '!') + esdp <- fsdap + _ <- T.symbolic '-' + stitle <- toUtf8 (T.sliced (T.manyTill T.anyChar (T.lookAhead T.newline))) + _ <- T.newline + case esdp of + SC fsdt sdpo sfn smaxfn -> do + (sstate, sdings) <- getDings fsdt M.empty + return (sname, c, ExSec $ + Sec stitle (smaxfn sstate) shidden (sfn sstate) (sdpo sstate) sdings scs) + where + getDings sdp = go mempty + where + go s m = nextDing s m <|> return (s,m) + + nextDing s m = do + (dn, ds, db) <- parseDingDefn sdp + case M.lookup dn m of + Nothing -> go (s `mappend` ds) (M.insert dn db m) + Just db' -> do + T.raiseErr (T.Err (Just "Duplicate ding definition") [] mempty) + +-- | Parse a definitions file +parseDefns :: (T.DeltaParsing f, T.MarkParsing T.Delta f, T.Errable f, T.LookAheadParsing f) + => f (SecCallback f) -> f (Defines T.Caret) +parseDefns sectys = T.whiteSpace *> (Defs <$> go M.empty) <* T.eof + where + go m = nextSection m <|> return m + nextSection m = do + (sn, sc, sb) <- parseSectionDefn sectys + case M.lookup sn m of + Nothing -> go (M.insert sn (sb, sc) m) + Just (_, dc') -> do + T.release (T.delta sc) + T.raiseErr (T.Err (Just "Duplicate section definition") [] mempty) + +------------------------------------------------------------------------ }}} +-- Data ---------------------------------------------------------------- {{{ + +-- | Parse a grader data file +parseData :: (T.DeltaParsing f, T.LookAheadParsing f) => f (DataFile T.Caret) +parseData = T.whiteSpace *> (DF <$> many dataSection) <* T.eof + where + dataSection = do + _ <- many hashComment + _ T.:^ sc <- T.careted $ T.char '@' + sn <- SN <$> word + ds <- many (T.try (many hashComment *> T.symbolic ':') + *> fmap (\(d T.:^ c) -> (d,c)) (T.careted (DN <$> word))) + _ <- many hashComment + mcs <- T.optional $ + T.string commentStart *> T.newline *> + toUtf8 (T.sliced (T.manyTill T.anyChar (T.lookAhead cend))) <* cend + _ <- T.whiteSpace + return $ DFS sn sc ds mcs + + cend = T.string commentEnd *> T.newline + +------------------------------------------------------------------------ }}} diff --git a/lib/Grade/Print.hs b/lib/Grade/Print.hs new file mode 100644 index 0000000..fd85d5d --- /dev/null +++ b/lib/Grade/Print.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Grade.Print where + +import qualified Data.Set as S +import Numeric +import Text.PrettyPrint.Free + +import Grade.Types + +printSectionError :: (loc -> Doc e) -> SectionError loc -> Doc e +printSectionError pl (SEUndefinedDing dn dl) = + "Unknown ding" <+> pretty (unDN dn) <+> "at" <+> pl dl +printSectionError pl (SEDuplicateDing dn dl1 dl2) = + "Multiple occurrence of single-use ding" <+> pretty (unDN dn) <+> "at:" + `above` indent 1 (vcat $ map pl [dl1, dl2]) +printSectionError _ (SEScoreError se) = + "Score function error:" <+> pretty se + +printReportError :: (loc -> Doc e) -> ReportError loc -> Doc e +printReportError _ (REMissingSections s) = + "The following sections were missing:" `above` indent 1 (vcat $ map (pretty . unSN) (S.toList s)) +printReportError pl (REDuplicateSection s l1 l2) = + "The section" <+> pretty (unSN s) <+> "occurs twice:" + `above` indent 1 (vcat $ map pl [l1, l2]) +printReportError pl (REUnknownSection s l) = + "The section" <+> pretty (unSN s) <+> "is unknown, at:" + `above` indent 1 (pl l) +printReportError pl (RESectionError sn se) = + "Section " <+> pretty (unSN sn) <+> "reports:" `above` indent 1 (vcat $ map (printSectionError pl) se) + +printGrade :: Double -> Double -> Doc e +printGrade e t = brackets (p e <> "/" <> p t) <+> parens ((p $ e / t * 100.0) <> "%") + where + p x = text $ showFFloat (Just 1) x "" + +printSection :: ReportFileSection -> Doc e +printSection (RFS st ss smax sdc msgc) = + pretty st <> ":" <+> printGrade ss smax <> line + `above` indent 1 + (vcat (punctuate empty (map pretty sdc)) + <> maybe empty + (\x -> (if null sdc then empty else line) + <> "Additional Grader Comments:" <> line `above` indent 1 (pretty x)) + msgc) + +total :: ReportFile -> (Double,Double) +total (RF secs) = foldr (\(RFS _ ss sm _ _) (e,t) -> (ss+e,sm+t)) (0.0,0.0) secs + +printReport :: ReportFile -> Doc e +printReport r@(RF s) = vcat (map printSection s) <> line <> "TOTAL:" <+> (uncurry printGrade $ total r) diff --git a/lib/Grade/Score/Bounding.hs b/lib/Grade/Score/Bounding.hs new file mode 100644 index 0000000..062301c --- /dev/null +++ b/lib/Grade/Score/Bounding.hs @@ -0,0 +1,13 @@ +-- | Bound scores both above (by section max) and below (by zero) +module Grade.Score.Bounding (BoundHow(..), bounding) where +import Grade.Types (SecCallback(..)) + +data BoundHow = Below | Above | Both + +bound Below _ = max 0.0 +bound Above m = min m +bound Both m = max 0.0 . min m + +bounding :: BoundHow -> SecCallback f -> SecCallback f +bounding how s = + case s of SC pa po g pm -> SC pa po (\sps sdt -> bound how (pm sps) <$> g sps sdt) pm diff --git a/lib/Grade/Score/EqualWeighted.hs b/lib/Grade/Score/EqualWeighted.hs new file mode 100644 index 0000000..1a9f391 --- /dev/null +++ b/lib/Grade/Score/EqualWeighted.hs @@ -0,0 +1,33 @@ +-- | Offers a section of equally-weighted dings. +-- +-- Expects the section header to specify the section maximum +-- +-- Dings must have no arguments +module Grade.Score.EqualWeighted (sectyEqualWeighted) where + +import Control.Exception (assert) +import Data.Monoid (Sum(getSum)) +import Numeric +import Grade.Types (SecCallback(..)) +import qualified Text.Trifecta as T + +efid :: (T.TokenParsing f) => f Double +efid = (either fromIntegral id) <$> T.integerOrDouble + +parseDing :: (Applicative f) => f (Sum Int,Sum Int) +parseDing = pure (1, 1) + +impact :: Double -> Sum Int -> Sum Int -> Double +impact smax ntotal ndinged = smax / fis ntotal * fis ndinged + where + fis = fromIntegral . getSum + +printDing :: Double -> Sum Int -> Sum Int -> Maybe String +printDing smax ntotal ding = assert (getSum ding == 1) + $ Just (showFFloat (Just 1) (0.0 - impact smax ntotal ding) "") + +scorefn :: Double -> Sum Int -> Sum Int -> Either String Double +scorefn smax ntotal ndinged = Right $ smax - impact smax ntotal ndinged + +sectyEqualWeighted :: (T.TokenParsing f) => f (SecCallback f) +sectyEqualWeighted = (\smax -> SC parseDing (printDing smax) (scorefn smax) (\_ -> smax)) <$> efid diff --git a/lib/Grade/Score/EqualWeightedCounting.hs b/lib/Grade/Score/EqualWeightedCounting.hs new file mode 100644 index 0000000..4745e70 --- /dev/null +++ b/lib/Grade/Score/EqualWeightedCounting.hs @@ -0,0 +1,27 @@ +-- | Offers a section of equally-weighted dings, with +-- the section maximum being determined by the number of dings. +-- +-- There should be no section heading parameters, and +-- dings must have no arguments. +module Grade.Score.EqualWeightedCounting (sectyEqualWeighted) where + +import Control.Exception (assert) +import Data.Monoid (Sum(getSum)) +import Numeric +import Grade.Types (SecCallback(..)) +import qualified Text.Trifecta as T + +parseDing :: (Applicative f) => f (Sum Int,Sum Int) +parseDing = pure (1, 1) + +fis :: Sum Int -> Double +fis = fromIntegral . getSum + +printDing :: Sum Int -> Sum Int -> Maybe String +printDing _ ding = assert (getSum ding == 1) $ Just "-1" + +scorefn :: Sum Int -> Sum Int -> Either String Double +scorefn ntotal ndinged = Right $ fis $ ntotal - ndinged + +sectyEqualWeighted :: (T.TokenParsing f) => f (SecCallback f) +sectyEqualWeighted = pure $ SC parseDing printDing scorefn (fromIntegral . getSum) diff --git a/lib/Grade/Score/Setting.hs b/lib/Grade/Score/Setting.hs new file mode 100644 index 0000000..bf7938b --- /dev/null +++ b/lib/Grade/Score/Setting.hs @@ -0,0 +1,52 @@ +-- | Like Zeroing, this allows overrides of some other section type's score. +-- This one, more generally, allows the defines file to specify overrides +-- other than zero. +module Grade.Score.Setting (sectySetting) where + +import Numeric +import qualified Text.Trifecta as T +import Grade.Types (SecCallback(..)) + +data Setting a = SetTwice | Set Double | Earned a + deriving (Show) + +instance Monoid a => Monoid (Setting a) where + mempty = Earned mempty + + mappend SetTwice _ = SetTwice + mappend _ SetTwice = SetTwice + + mappend (Set _) (Set _) = SetTwice + mappend s@(Set _) (Earned _) = s + mappend (Earned _) s@(Set _) = s + + mappend (Earned l) (Earned r) = Earned (l `mappend` r) + +parseSet :: (T.TokenParsing f, Monoid sds) + => f Double -- ^ Parse a score-setting ding + -> f (sdt,sds) -- ^ What is the underlying ding parser? + -> f (Setting sdt, sds) +parseSet ps pd = T.choice + [ -- Try parsing a setting form + (\s -> (Set s, mempty)) <$> T.try ps + , -- Otherwise, invoke the underlying parser + (\(a,b) -> (Earned a, b)) <$> pd + ] + +printSet :: (sds -> sdt -> Maybe String) + -> sds -> Setting sdt -> Maybe String +printSet po ss r = case r of + SetTwice -> error "Score.Setting was asked to print out impossible state" + Set v -> Just $ showFFloat (Just 1) v "Score set to " + Earned v -> po ss v + +scoreSet :: (sds -> sdt -> Either String Double) + -> sds -> Setting sdt -> Either String Double +scoreSet ug ss r = case r of + SetTwice -> Left "Multiple score-setting dings in section" + Set v -> Right v + Earned r' -> ug ss r' + +sectySetting :: (T.TokenParsing f) => f Double -> f (SecCallback f) -> f (SecCallback f) +sectySetting ps = fmap + (\shp -> case shp of SC up uo ug um -> SC (parseSet ps up) (printSet uo) (scoreSet ug) um) diff --git a/lib/Grade/Score/Simple.hs b/lib/Grade/Score/Simple.hs new file mode 100644 index 0000000..7277c84 --- /dev/null +++ b/lib/Grade/Score/Simple.hs @@ -0,0 +1,50 @@ +-- | A Simple section just adds absolute and relative influences +-- on a score, which is presumed to get full credit if no dings +-- are given. +-- +-- Expects the section header to specify the section maximum +-- +-- Accepts a number or number-followed-by-%-sign for its ding arg. +module Grade.Score.Simple (sectySimple) where + +import Numeric +import qualified Text.Trifecta as T +import Grade.Types (SecCallback(..)) + +data Score = S Double Double + deriving (Show) + +instance Monoid Score where + mempty = S 0.0 0.0 + mappend (S la lr) (S ra rr) = S (la + ra) (lr + rr) + +efid :: (T.TokenParsing f) => f Double +efid = (either fromIntegral id) <$> T.integerOrDouble + +parseDingScore :: (T.TokenParsing f) => f (Score,()) +parseDingScore = (\x -> (x,())) <$> T.choice + [ -- A number followed by a '%' sign is a relative modifier + T.try ( ((\n -> S 0.0 (n/100.0)) <$> efid) <* T.symbolic '%' ) + + -- A number by itself is an absolute modifier + , (\n -> S n 0.0) <$> efid + ] + +impact :: Double -> Score -> Double +impact sm (S a r) = a + (sm * r) + +printfn :: Double -> () -> Score -> Maybe String +printfn sm () s = Just $ case s of + (S 0.0 0.0) -> "0" + (S 0.0 r) -> (p (r*100)) ++ "% == " ++ si + (S _ 0.0) -> si + (S a r ) -> (p a) ++ " and " ++ (p r) ++ "% == " ++ si + where + si = p $ impact sm s + p x = showFFloat (Just 1) x "" + +scorefn :: Double -> () -> Score -> Either String Double +scorefn sm () s = Right $ sm + impact sm s + +sectySimple :: (T.TokenParsing f) => f (SecCallback f) +sectySimple = (\smax -> SC parseDingScore (printfn smax) (scorefn smax) (\_ -> smax)) <$> efid diff --git a/lib/Grade/Score/Zeroing.hs b/lib/Grade/Score/Zeroing.hs new file mode 100644 index 0000000..547f08c --- /dev/null +++ b/lib/Grade/Score/Zeroing.hs @@ -0,0 +1,42 @@ +-- | Allow the defines file to indicate dings that will zero out a section. +module Grade.Score.Zeroing (zeroing) where + +import qualified Text.Trifecta as T +import Grade.Types (SecCallback(..)) + +data Zeroing a = Zeroed | Earned a + deriving (Show) + +instance Monoid a => Monoid (Zeroing a) where + mempty = Earned mempty + + mappend Zeroed _ = Zeroed + mappend _ Zeroed = Zeroed + mappend (Earned l) (Earned r) = Earned (l `mappend` r) + +parseZeroed :: (T.TokenParsing f, Monoid sds) + => f () -- ^ How do we parse a zeroizing ding? + -> f (sdt,sds) -- ^ What is the underlying ding parser? + -> f (Zeroing sdt, sds) +parseZeroed pz pd = T.choice + [ -- Try parsing a zeroizing form + T.try pz *> pure (Zeroed, mempty) + , -- Otherwise, invoke the underlying parser + (\(a,b) -> (Earned a, b)) <$> pd + ] + +printZeroed :: (sds -> sdt -> Maybe String) + -> sds -> Zeroing sdt -> Maybe String +printZeroed po ss r = case r of + Zeroed -> Just "Score set to 0" + Earned v -> po ss v + +scoreZeroed :: (sds -> sdt -> Either String Double) + -> sds -> Zeroing sdt -> Either String Double +scoreZeroed ug ss r = case r of + Zeroed -> Right 0.0 + Earned r' -> ug ss r' + +zeroing :: (T.TokenParsing f) => f () -> SecCallback f -> SecCallback f +zeroing pz shp = + case shp of SC up uo ug um -> SC (parseZeroed pz up) (printZeroed uo) (scoreZeroed ug) um diff --git a/lib/Grade/Skeleton.hs b/lib/Grade/Skeleton.hs new file mode 100644 index 0000000..546b85b --- /dev/null +++ b/lib/Grade/Skeleton.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Grade.Skeleton where + +import qualified Data.Map as M +import qualified Data.Text as T +import Text.PrettyPrint.Free +import Grade.Types +import Grade.Parse (commentStart, commentEnd) + +interpSectionComments :: Bool -> [T.Text] -> Doc e +interpSectionComments f0 = vcat . go f0 + where + go _ [] = [] + go _ ("#!noskip":bs) = go False bs + go _ ("#!reskip":bs) = go f0 bs + go False ("#!\\n":bs) = empty : go False bs + go f (b:bs) | "#!" `T.isPrefixOf` b = go f bs + go False (b:bs) = pretty b : go False bs + go True (_:bs) = go True bs + +makeSkel :: Defines loc -> Doc e +makeSkel (Defs sm) = + vcat $ punctuate line + $ flip fmap (M.toList sm) + $ \(sn, (ExSec (Sec _ _ shidden _ _ sdm scl), _)) -> + let scl' = interpSectionComments shidden scl in + if shidden + then scl' + else scl' + `above` "@" <> pretty (unSN sn) + `above` indent 1 (vcat $ map prettyDing (M.toList sdm)) + `above` vcat [empty, commentStart, empty, commentEnd] + + where + prettyDing (dn, _) = "#:" <> pretty (unDN dn) + diff --git a/lib/Grade/Types.hs b/lib/Grade/Types.hs new file mode 100644 index 0000000..5bff9de --- /dev/null +++ b/lib/Grade/Types.hs @@ -0,0 +1,159 @@ +-- Header -------------------------------------------------------------- {{{ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wall -Werror #-} + +module Grade.Types where + +import qualified Control.Lens.TH as LTH +import Data.Map (Map) +import Data.Set (Set) +import Data.Text (Text) +import Data.Typeable (Typeable) + +------------------------------------------------------------------------ }}} +-- Defines ------------------------------------------------------------- {{{ + +newtype DingName = DN { unDN :: Text } + deriving (Eq,Ord,Show,Typeable) + +-- | A point deduction definition +-- +-- A Ding is parameterized by some modifier for its section. +-- All dings have text to display and a list of comments for +-- internal use. +-- +-- Each Ding is associated with a location (parameterized to avoid +-- dependency on any particular parsing framework) +-- +data Ding sdt loc = Ding + { _ding_mod :: sdt + , _ding_loc :: loc + , _ding_multiple :: Bool + , _ding_text :: Text + , _ding_comment_lines :: [Text] + } + deriving (Eq,Ord,{-Show-}Typeable) +$(LTH.makeLenses ''Ding) + +-- | A Section is mostly a collection of Dings. +-- +-- Each section, like each Ding, may have a collection of comments +-- associated with it. +-- +-- It also conains a section scoring function, which +-- reduces dingmods to a score. +data Section sdt loc = Sec + { _sec_title :: Text + , _sec_max :: Double + , _sec_hidden :: Bool + , _sec_scorefn :: sdt -> Either String Double + , _sec_dingprinter :: sdt -> Maybe String + , _sec_dings :: Map DingName (Ding sdt loc) + , _sec_comment_lines :: [Text] + } + deriving (Typeable) +$(LTH.makeLenses ''Section) + +{- +instance (Show sdt, Show loc) => Show (Section sdt loc) where + show (Sec t m h _ d c) = "Section " + ++ (show t) ++ " " + ++ (show m) ++ " " + ++ (show h) ++ " " + ++ " " + ++ (show d) ++ " " + ++ (show c) +-} + +-- | Existentially quantify the section data type for a given section +data ExSection loc = forall sdt . ({-Show sdt,-} Monoid sdt) => ExSec (Section sdt loc) + +{- +instance (Show loc) => Show (ExSection loc) where + show es = case es of ExSec s -> show s +-} + +-- | A Section Callback object, as returned by a section type parser +data SecCallback f = forall sps sdt . ({-Show sdt,-} Monoid sdt, Monoid sps) => + SC + { -- | Parse section-specific ding weights + sc_ding_parse :: f (sdt,sps) + , -- | Optional printout of the sdt data, given + -- the section's maximum and final sps. + sc_show_sdt :: sps -> sdt -> Maybe String + , -- | Scoring function, given section maximum + -- value and the monoidal summary of section-specific dings + sc_score :: sps -> sdt -> Either String Double + , -- | Maximum scoring function + sc_max :: sps -> Double + } + deriving (Typeable) + +newtype SecName = SN { unSN :: Text } + deriving (Eq,Ord,Show,Typeable) + +-- | Defines is a collection of Sections, with possibly different types of +-- scoring data in each. +-- +data Defines loc = Defs + { _def_sections :: Map SecName (ExSection loc, loc) + } + deriving ({-Show,-} Typeable) +$(LTH.makeLenses ''Defines) + +------------------------------------------------------------------------ }}} +-- Data ---------------------------------------------------------------- {{{ + +data DataFileSection loc = DFS + { _dfs_secname :: SecName + , _dfs_secloc :: loc + , _dfs_dings :: [(DingName,loc)] + , _dfs_grader_comments :: Maybe Text + } + deriving (Show, Typeable) +$(LTH.makeLenses ''DataFileSection) + +-- | A report for a student, as produced by a TA +newtype DataFile loc = DF [DataFileSection loc] + deriving (Show, Typeable) + +------------------------------------------------------------------------ }}} +-- Reports ------------------------------------------------------------- {{{ + +data SectionError loc = + -- | An unknown ding directive is encountered in the DataFile + SEUndefinedDing DingName loc + -- | A ding which was not declared as multiple-use occured twice + | SEDuplicateDing DingName loc loc + -- | A scoring error occurred + | SEScoreError String + deriving (Show) + +data ReportError loc = + -- | A section is defined in the Defines but is not present in the + -- DataFile + REMissingSections (Set SecName) + -- | A section is invoked twice in the DataFile + | REDuplicateSection SecName loc loc + -- | An unknown section directive is encountered in the DataFile + | REUnknownSection SecName loc + -- | Error(s) occurring in a particular section + | RESectionError SecName [SectionError loc] + deriving (Show) + +data ReportFileSection = RFS + { _rfs_sectitle :: Text + , _rfs_score :: Double + , _rfs_max :: Double + , _rfs_dingtext :: [Text] + , _rfs_comments :: Maybe Text + } + deriving (Show, Typeable) +$(LTH.makeLenses ''ReportFileSection) + +-- | A report for a student, as they see it +newtype ReportFile = RF [ReportFileSection] + +------------------------------------------------------------------------ }}} diff --git a/prog/Grade.hs b/prog/Grade.hs new file mode 100644 index 0000000..72561d2 --- /dev/null +++ b/prog/Grade.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Data.Data (Data) + +import qualified Text.PrettyPrint.ANSI.Leijen as TPP +import qualified Text.PrettyPrint.Free as PP +import qualified Text.Trifecta as T +import qualified Text.Trifecta.Delta as T + +import qualified System.Console.CmdLib as C +import System.IO + +import Grade.Parse +import Grade.Score.EqualWeighted +import Grade.Score.Simple +import qualified Grade.Score.Bounding as GSB +import qualified Grade.Score.Zeroing as GSZ +import Grade.Grade +import Grade.Skeleton +import Grade.Print + +--- + +sectys :: T.TokenParsing m => m (SecCallback m) +sectys = T.choice + [ -- A shortcut + T.symbolic '0' *> (GSZ.zeroing zs <$> GSB.bounding GSB.Both <$> sectySimple) + + , -- Look ma, a little language + -- Base cases + T.symbol "simple" *> sectySimple + , T.symbol "equal" *> sectyEqualWeighted + + , -- Recursive cases + T.symbol "bounding" *> (GSB.bounding GSB.Both <$> sectys) + , T.symbol "nonneg" *> (GSB.bounding GSB.Below <$> sectys) + , T.symbol "zeroing" *> (GSZ.zeroing zs <$> sectys) + ] + where + zs = T.symbol "!0" *> pure () + +doMakeSkeleton :: String -> IO () +doMakeSkeleton defi = do + mdefines <- T.parseFromFileEx (parseDefns sectys) defi + case mdefines of + T.Failure f -> hPutStrLn stderr (show f) + T.Success d -> print $ makeSkel d + +doGradeOne :: String -> String -> IO () +doGradeOne defi dati = do + mdefines <- T.parseFromFileEx (parseDefns sectys) defi + case mdefines of + T.Failure f -> hPutStrLn stderr "Error while parsing defines:" + *> hPutStrLn stderr (show f) + T.Success defs -> do + mdata <- T.parseFromFileEx parseData dati + case mdata of + T.Failure f -> hPutStrLn stderr "Error while parsing data:" + *> hPutStrLn stderr (show f) + T.Success dats -> case gradeOne defs dats of + Left e -> do + hPutStrLn stderr "Error while grading:" + hPutStrLn stderr $ show $ PP.vcat + $ map (printReportError showcaret) e + Right r -> print $ printReport r + where + showcaret = PP.text . show . TPP.pretty . T.delta + + +data Cmd = MakeSkeleton { defines :: String } + | GradeOne { defines :: String, datafile :: String } + -- XXX TODO | GradeDir { defines :: String, in_dir :: String, out_dir :: String } + deriving (Data,Eq,Show) +instance C.Attributes Cmd +instance C.RecordCommand Cmd where + mode_summary (MakeSkeleton {}) = "Make grader skeleton from defines file" + mode_summary (GradeOne {}) = "Grade one student file" + + rec_options (MakeSkeleton {}) = defines C.%> C.Default ("/dev/fd/0" :: String) + C.%+ C.Positional 0 + C.%+ C.Required True + rec_options (GradeOne {}) = (defines C.%> C.Positional 0 + C.%+ C.Required True) + C.%% + (datafile C.%> C.Long ["data"] + C.%+ C.Help "grade data file" + C.%+ C.Default ("/dev/fd/0" :: String)) + + run' (MakeSkeleton {defines = i}) _ = doMakeSkeleton i + run' (GradeOne { defines = defi, datafile = dati }) _ = doGradeOne defi dati + +main' :: [String] -> IO () +main' ars = C.dispatchR [] ars >>= \(x :: Cmd) -> C.run' x [] + +main :: IO () +main = C.getArgs >>= main' -- 2.50.1