From d90caf3bbaf3223cefa5d74421118c88c8cd4446 Mon Sep 17 00:00:00 2001 From: Nathaniel Wesley Filardo Date: Fri, 11 Sep 2015 19:47:20 -0400 Subject: [PATCH] Move some 'grading' work to the data parser --- lib/Grade/Grade.hs | 85 ++++---------- lib/Grade/Parse.hs | 140 +++++++++++++++++------ lib/Grade/Score/Bounding.hs | 4 +- lib/Grade/Score/EqualWeighted.hs | 4 +- lib/Grade/Score/EqualWeightedCounting.hs | 2 +- lib/Grade/Score/Setting.hs | 5 +- lib/Grade/Score/Simple.hs | 6 +- lib/Grade/Score/Zeroing.hs | 7 +- lib/Grade/Skeleton.hs | 14 ++- lib/Grade/Types.hs | 42 ++++--- prog/Grade.hs | 38 +++--- 11 files changed, 206 insertions(+), 141 deletions(-) diff --git a/lib/Grade/Grade.hs b/lib/Grade/Grade.hs index 91f4b66..19ee24f 100644 --- a/lib/Grade/Grade.hs +++ b/lib/Grade/Grade.hs @@ -4,8 +4,6 @@ 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 @@ -18,68 +16,29 @@ collectErrors x = case partitionEithers x of ([], 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 diff --git a/lib/Grade/Parse.hs b/lib/Grade/Parse.hs index 21fc8f9..9aa7cfc 100644 --- a/lib/Grade/Parse.hs +++ b/lib/Grade/Parse.hs @@ -12,23 +12,29 @@ module Grade.Parse ( ) 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" @@ -40,10 +46,25 @@ 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 +-- | 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 ------------------------------------------------------------- {{{ @@ -56,7 +77,7 @@ untilDotLine = toUtf8 (T.sliced (T.manyTill T.anyChar (T.try $ T.lookAhead end)) 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) @@ -74,7 +95,7 @@ parseDingDefn dl = do 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 '@') @@ -87,8 +108,9 @@ parseSectionDefn fsdap = do 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 @@ -98,43 +120,95 @@ parseSectionDefn fsdap = 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 + 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) +-} ------------------------------------------------------------------------ }}} diff --git a/lib/Grade/Score/Bounding.hs b/lib/Grade/Score/Bounding.hs index 062301c..09902bc 100644 --- a/lib/Grade/Score/Bounding.hs +++ b/lib/Grade/Score/Bounding.hs @@ -10,4 +10,6 @@ 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 + 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 index 1a9f391..835d969 100644 --- a/lib/Grade/Score/EqualWeighted.hs +++ b/lib/Grade/Score/EqualWeighted.hs @@ -24,10 +24,10 @@ impact smax ntotal ndinged = smax / fis ntotal * fis ndinged 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 diff --git a/lib/Grade/Score/EqualWeightedCounting.hs b/lib/Grade/Score/EqualWeightedCounting.hs index 4745e70..79eb3e6 100644 --- a/lib/Grade/Score/EqualWeightedCounting.hs +++ b/lib/Grade/Score/EqualWeightedCounting.hs @@ -18,7 +18,7 @@ fis :: Sum Int -> Double 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 diff --git a/lib/Grade/Score/Setting.hs b/lib/Grade/Score/Setting.hs index bf7938b..69a8576 100644 --- a/lib/Grade/Score/Setting.hs +++ b/lib/Grade/Score/Setting.hs @@ -47,6 +47,5 @@ scoreSet ug ss r = case r of 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 diff --git a/lib/Grade/Score/Simple.hs b/lib/Grade/Score/Simple.hs index 7277c84..723b06b 100644 --- a/lib/Grade/Score/Simple.hs +++ b/lib/Grade/Score/Simple.hs @@ -47,4 +47,8 @@ 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 +sectySimple = (\smax -> SC parseDingScore + (printfn smax) + (scorefn smax) + (\_ -> smax)) + <$> efid diff --git a/lib/Grade/Score/Zeroing.hs b/lib/Grade/Score/Zeroing.hs index 547f08c..8605df9 100644 --- a/lib/Grade/Score/Zeroing.hs +++ b/lib/Grade/Score/Zeroing.hs @@ -39,4 +39,9 @@ scoreZeroed ug ss r = case r of 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 diff --git a/lib/Grade/Skeleton.hs b/lib/Grade/Skeleton.hs index 5dedc4d..66fc4d9 100644 --- a/lib/Grade/Skeleton.hs +++ b/lib/Grade/Skeleton.hs @@ -20,18 +20,20 @@ interpSectionComments f0 = vcat . go f0 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) diff --git a/lib/Grade/Types.hs b/lib/Grade/Types.hs index 958afdd..8354d61 100644 --- a/lib/Grade/Types.hs +++ b/lib/Grade/Types.hs @@ -69,6 +69,7 @@ $(LTH.makeLenses ''SecMeta) -- 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) @@ -96,18 +97,17 @@ instance (Show loc) => Show (ExSection loc) where -} -- | 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) @@ -117,8 +117,11 @@ newtype SecName = SN { unSN :: Text } -- | 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) @@ -126,18 +129,27 @@ $(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 ------------------------------------------------------------- {{{ diff --git a/prog/Grade.hs b/prog/Grade.hs index 72561d2..7eb7f40 100644 --- a/prog/Grade.hs +++ b/prog/Grade.hs @@ -14,25 +14,25 @@ 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 ---- +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) @@ -42,6 +42,8 @@ sectys = T.choice where zs = T.symbol "!0" *> pure () +--- + doMakeSkeleton :: String -> IO () doMakeSkeleton defi = do mdefines <- T.parseFromFileEx (parseDefns sectys) defi @@ -56,16 +58,22 @@ doGradeOne defi dati = do 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 -- 2.50.1