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
([], r) -> Right r
(l, _) -> Left l
-lookupSectionDings :: [(DingName, loc)]
- -> M.Map DingName (DingDefn sdt loc')
- -> Either [SectionError loc] [(DingDefn sdt loc', loc)]
-lookupSectionDings dns0 sm = collectErrors $ flip evalState M.empty $ mapM look dns0
+processDFS :: ExDFS loc
+ -> Either String ReportFileSection
+processDFS (ExDFS (DFS (SecMeta stitle smax sfn sdpo) _ dds dgcs)) = do
+ sscore <- sfn $ mconcat $ (_dm_mod . _dfd_meta) <$> dds
+ pure $ RFS stitle sscore smax (dopo <$> dds) dgcs
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 $ _dingd_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 (SecMeta 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 (_dm_mod . _dingd_meta) ds)
-
- dopo d = T.unlines $ addMod $ pure $ (_dm_text . _dingd_meta) 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 (_dm_mod $ _dingd_meta 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
+ dopo d = T.unlines $ addMod $ pure $ (_dm_text . _dfd_meta) 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
+ (sdpo (_dm_mod $ _dfd_meta d))
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
+gradeOne (Defs defs _) (DF dfss) =
+ let availScores = collectErrors $ fmap processSec dfss in
+ let residualSecs = M.keysSet $ foldr (\(k,_) f -> (M.delete k) . f) id dfss defs in
+ if S.null residualSecs
+ then RF <$> availScores
+ else let e = REMissingSections residualSecs in
+ case availScores of
+ Left es -> Left (e:es)
+ Right _ -> Left [e]
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
+ processSec (sn,s) = bimap (RESectionError sn . pure . SEScoreError) id $ processDFS s
) where
import Control.Applicative
+-- import qualified Control.Lens as L
+-- import Control.Monad (guard, when)
+import Control.Monad.State
import Data.ByteString (ByteString)
-import Data.Text (Text)
+import Data.Text (Text,unpack)
import Data.Text.Encoding (decodeUtf8')
-import qualified Data.Char as C
+-- import qualified Data.Char as C
import qualified Data.Map as M
-import qualified Data.String as S
+-- import qualified Data.Set as S
+import Data.String (IsString)
+-- import Data.Semigroup ((<>))
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 qualified Text.PrettyPrint.ANSI.Leijen as PP
import Grade.Types
------------------------------------------------------------------------ }}}
-- Common -------------------------------------------------------------- {{{
-commentStart, commentEnd :: (S.IsString s) => s
+commentStart, commentEnd :: (IsString s) => s
commentStart = "$BEGIN_COMMENTS"
commentEnd = "$END_COMMENTS"
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
+-- | Sometimes we want to be more forceful than T.whiteSpace and actually
+-- ensure that there is some space or that we're at the end of input.
+sseof :: (T.TokenParsing f) => f ()
+sseof = (T.someSpace <|> T.eof)
+
-- | Grab a word in its entirety. Note that this is a little strange as
-- we check the 'notFollowedBy' condition *first*!
word :: (T.DeltaParsing f) => f Text
-word = toUtf8 (T.sliced (many $ T.satisfy (not . C.isSpace))) <* T.whiteSpace
+word = toUtf8 (T.sliced (many $ T.notFollowedBy T.someSpace *> T.anyChar)) <* sseof
+
+-- | Choose by key in a map
+parseMapKeys :: (T.TokenParsing f)
+ => (k -> String)
+ -> M.Map k v
+ -> f (k, v)
+parseMapKeys ks m = T.choice $ (uncurry arm) <$> M.toList m
+ where
+ arm k v = ((T.try ((T.string $ ks k) <* sseof)) *> pure (k,v))
+ T.<?> show (ks k)
------------------------------------------------------------------------ }}}
-- Defines ------------------------------------------------------------- {{{
where
end = T.newline *> T.char '.' *> T.newline
--- | Given a parser for X, parse lines of the form ":-name X" preceeded by
+-- | 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)
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)
+ => f (SecCallback f) -> f (SecName, ExSection T.Caret)
parseSectionDefn fsdap = do
scs <- many hashComment
_ T.:^ c <- T.careted (T.symbolic '@')
case esdp of
SC fsdt sdpo sfn smaxfn -> do
(sstate, sdings) <- getDings fsdt M.empty
- return (sname, c, ExSec $
- Sec (SecMeta stitle (smaxfn sstate) (sfn sstate) (sdpo sstate)) shidden scs sdings)
+ _ <- T.whiteSpace
+ return (sname, ExSec $
+ Sec (SecMeta stitle (smaxfn sstate) (sfn sstate) (sdpo sstate)) c shidden scs sdings)
where
getDings sdp = go mempty
where
(dn, ds, db) <- parseDingDefn sdp
case M.lookup dn m of
Nothing -> go (s `mappend` ds) (M.insert dn db m)
- Just db' -> do
+ Just _ -> 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
+parseDefns sectys = T.whiteSpace *> go M.empty [] <* T.eof
where
- go m = nextSection m <|> return m
- nextSection m = do
- (sn, sc, sb) <- parseSectionDefn sectys
+ go m l = nextSection m l <|> return (Defs m (reverse l))
+ nextSection m l = do
+ (sn, 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)
+ Nothing -> go (M.insert sn sb m) ((sn,sb):l)
+ Just _ -> do
+ T.release (T.delta $ case sb of ExSec s -> _sec_loc s)
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
+parseData :: forall f loc . (T.DeltaParsing f, T.LookAheadParsing f)
+ => Defines loc -> f (DataFile T.Caret, [ReportError T.Caret])
+parseData defs = do
+ _ <- T.whiteSpace
+ (ss, fsm) <- sections defs
+ _ <- many hashComment
+ _ <- T.eof
+ pure (DF ss, (if M.null fsm then id else (REMissingSections (M.keysSet fsm) :)) [])
+ where
+ sections (Defs sm0 _) = flip runStateT sm0 $ go M.empty
+ where
+ go already = do
+ _ <- many hashComment
+ another already <|> pure []
+
+ another already = do
+ (sn,esb) T.:^ sc <- get >>= \sm -> sectionDirective sm
+ case esb of
+ ExSec (Sec smeta _ _ _ sdm) -> do
+ ds <- sectionDings sdm
+ mcs <- T.optional $
+ T.string commentStart *> T.newline *>
+ toUtf8 (T.sliced (T.manyTill T.anyChar (T.lookAhead cend))) <* cend
+ _ <- T.whiteSpace
+ ((sn, ExDFS $ DFS smeta sc ds mcs) :)
+ <$> (modify (M.delete sn) >> go (M.insert sn () already))
+
+ cend = T.string commentEnd *> T.newline
+
+ sectionDirective = directiveChoice '@' (unpack . unSN)
+
+ sectionDings dm0 = go dm0 M.empty
+ where
+ go dm already = do
+ _ <- many hashComment
+ another dm already <|> pure []
+
+ another dm already = do
+ ((dn,DingDefn dmeta _ dingmany _) T.:^ dc) <- dingDirective dm
+ ((DFD dmeta dc) :) <$> go (if dingmany then dm else M.delete dn dm)
+ (if dingmany then already else M.insert dn () already)
+
+ dingDirective = directiveChoice ':' (unpack . unDN)
+
+ directiveChoice lc f m = do
+ _ T.:^ sc <- T.lookAhead (T.careted $ T.char lc)
+ (T.:^ sc) <$> parseMapKeys ((lc :) . f) m
+
+{-
+-- | Gobble characters until we're looking at something we probably know and
+-- love; it's a guess, of course.
+recover = T.skipSome (T.notFollowedBy (T.choice (T.try <$> sigil)) *> T.anyChar)
+ *> T.whiteSpace
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
+ sigil = [ T.newline *> T.whiteSpace *> T.char '@' *> pure ()
+ , T.newline *> T.whiteSpace *> T.char ':' *> pure ()
+ , T.char '#' *> pure ()
+ , T.symbol commentStart *> pure ()
+ ]
+
+dcErr lc fk falr fnew malr myet = do
+ _ T.:^ sc <- T.lookAhead (T.careted $ T.char lc)
+ T.choice [ (Right . (T.:^ sc)) <$> parseMapKeys ((lc :) . fk) myet
+ , (Left . falr sc . fst) <$> parseMapKeys ((lc :) . fk) malr
+ , (Left . fnew sc) <$> (T.char lc *> word <* sseof)
+ ]
+
+dcErr' lc fk malr myet = dcErr lc fk (flip SEDuplicateDing) (flip SEUndefinedDing)
+-}
------------------------------------------------------------------------ }}}
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
+ case s of
+ SC pa po g pm ->
+ SC pa po (\sps sdt -> bound how (pm sps) <$> g sps sdt) pm
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) "")
+ $ 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 :: (T.TokenParsing f) => f (SecCallback f)
sectyEqualWeighted = (\smax -> SC parseDing (printDing smax) (scorefn smax) (\_ -> smax)) <$> efid
fis = fromIntegral . getSum
printDing :: Sum Int -> Sum Int -> Maybe String
-printDing _ ding = assert (getSum ding == 1) $ Just "-1"
+printDing _ ding = assert (getSum ding == 1) $ Just "-1"
scorefn :: Sum Int -> Sum Int -> Either String Double
scorefn ntotal ndinged = Right $ fis $ ntotal - ndinged
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)
+sectySetting :: (T.TokenParsing f) => f Double -> SecCallback f -> SecCallback f
+sectySetting ps (SC up uo ug um) = SC (parseSet ps up) (printSet uo) (scoreSet ug) um
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
+sectySimple = (\smax -> SC parseDingScore
+ (printfn smax)
+ (scorefn smax)
+ (\_ -> smax))
+ <$> efid
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
+ case shp of
+ SC up uo ug um ->
+ SC (parseZeroed pz up)
+ (printZeroed uo)
+ (scoreZeroed ug)
+ um
go True (_:bs) = go True bs
makeSkel :: Defines loc -> Doc e
-makeSkel (Defs sm) =
+makeSkel (Defs _ sl) =
vcat $ punctuate line
- $ flip fmap (M.toList sm)
- $ \(sn, (ExSec (Sec _ shidden scl sdm), _)) ->
+ $ flip fmap sl
+ $ \(sn, ExSec (Sec _ _ shidden scl sdm)) ->
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]
+ `above` prettyDingMap sdm (vcat [empty, commentStart, empty, commentEnd])
where
- prettyDing (dn, _) = "#:" <> pretty (unDN dn)
+ prettyDingMap dm = if M.null dm
+ then id
+ else (indent 1 (vcat $ map prettyDing (M.toList dm)) `above`)
+ prettyDing (dn, _) = "#:" <> pretty (unDN dn)
-- reduces dingmods to a score.
data Section sdt loc = Sec
{ _sec_meta :: SecMeta sdt
+ , _sec_loc :: loc
, _sec_hidden :: Bool
, _sec_comment_lines :: [Text]
, _sec_dings :: Map DingName (DingDefn sdt loc)
-}
-- | A Section Callback object, as returned by a section type parser
-data SecCallback f = forall sps sdt . ({-Show sdt,-} Monoid sdt, Monoid sps) =>
- SC
+data SecCallback f = forall sps sdt . ({-Show sdt,-} Monoid sdt, Monoid sps) => SC
{ -- | Parse section-specific ding weights
- sc_ding_parse :: f (sdt,sps)
+ 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
+ -- the section's 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
+ sc_score :: sps -> sdt -> Either String Double
, -- | Maximum scoring function
- sc_max :: sps -> Double
+ sc_max :: sps -> Double
}
deriving (Typeable)
-- | Defines is a collection of Sections, with possibly different types of
-- scoring data in each.
--
+-- The same collection is indexed by name and presented in order.
+--
data Defines loc = Defs
- { _def_sections :: Map SecName (ExSection loc, loc)
+ { _def_section_by_name :: Map SecName (ExSection loc)
+ , _def_sections :: [(SecName, ExSection loc)]
}
deriving ({-Show,-} Typeable)
$(LTH.makeLenses ''Defines)
------------------------------------------------------------------------ }}}
-- Data ---------------------------------------------------------------- {{{
-data DataFileSection loc = DFS
- { _dfs_secname :: SecName
- , _dfs_secloc :: loc
- , _dfs_dings :: [(DingName,loc)]
+-- | Ding usage by a grader
+data DataFileDing mt loc = DFD
+ { _dfd_meta :: DingMeta mt
+ , _dfd_loc :: loc
+ }
+$(LTH.makeLenses ''DataFileDing)
+
+data DataFileSection sdt loc = DFS
+ { _dfs_meta :: SecMeta sdt
+ , _dfs_loc :: loc
+ , _dfs_dings :: [DataFileDing sdt loc]
, _dfs_grader_comments :: Maybe Text
}
- deriving (Show, Typeable)
+ deriving (Typeable)
$(LTH.makeLenses ''DataFileSection)
+data ExDFS loc = forall sdt . Monoid sdt => ExDFS (DataFileSection sdt loc)
+
-- | A report for a student, as produced by a TA
-newtype DataFile loc = DF [DataFileSection loc]
- deriving (Show, Typeable)
+newtype DataFile loc = DF [(SecName, ExDFS loc)]
+ deriving (Typeable)
------------------------------------------------------------------------ }}}
-- Reports ------------------------------------------------------------- {{{
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
----
+import qualified Grade.Score.EqualWeighted as GSE
+import qualified Grade.Score.Simple as GSS
+import qualified Grade.Score.Bounding as GSB
+import qualified Grade.Score.Zeroing as GSZ
+import Grade.Types
sectys :: T.TokenParsing m => m (SecCallback m)
sectys = T.choice
[ -- A shortcut
- T.symbolic '0' *> (GSZ.zeroing zs <$> GSB.bounding GSB.Both <$> sectySimple)
+ T.symbolic '0' *> (GSZ.zeroing zs <$> GSB.bounding GSB.Both <$> GSS.sectySimple)
, -- Look ma, a little language
-- Base cases
- T.symbol "simple" *> sectySimple
- , T.symbol "equal" *> sectyEqualWeighted
+ T.symbol "simple" *> GSS.sectySimple
+ , T.symbol "equal" *> GSE.sectyEqualWeighted
, -- Recursive cases
T.symbol "bounding" *> (GSB.bounding GSB.Both <$> sectys)
where
zs = T.symbol "!0" *> pure ()
+---
+
doMakeSkeleton :: String -> IO ()
doMakeSkeleton defi = do
mdefines <- T.parseFromFileEx (parseDefns sectys) defi
T.Failure f -> hPutStrLn stderr "Error while parsing defines:"
*> hPutStrLn stderr (show f)
T.Success defs -> do
- mdata <- T.parseFromFileEx parseData dati
+ mdata <- T.parseFromFileEx (parseData defs) 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
+ T.Success (dats, errs) -> case errs of
+ [] -> 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
+ _ -> do
+ hPutStrLn stderr "Error while parsing data:"
+ hPutStrLn stderr $ show $ PP.vcat
+ $ map (printReportError showcaret) errs
+
where
showcaret = PP.text . show . TPP.pretty . T.delta
projects / grade / commitdiff