--- /dev/null
+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.
--- /dev/null
+##########################################
+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.
--- /dev/null
+#
+@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
--- /dev/null
+#! 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
+.
--- /dev/null
+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
--- /dev/null
+{-# 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
--- /dev/null
+-- 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
+
+------------------------------------------------------------------------ }}}
--- /dev/null
+{-# 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)
--- /dev/null
+-- | 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
--- /dev/null
+-- | 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
--- /dev/null
+-- | 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)
--- /dev/null
+-- | 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)
--- /dev/null
+-- | 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
--- /dev/null
+-- | 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
--- /dev/null
+{-# 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)
+
--- /dev/null
+-- 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) ++ " "
+ ++ "<fun> "
+ ++ (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]
+
+------------------------------------------------------------------------ }}}
--- /dev/null
+{-# 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'
projects / grade / commitdiff