adjust grade function to give feedback in multiple stages

Author: patritzenfeld

src/Haskell/Template/Task.hs

@@ -363,42 +363,47 @@ whileOpen h =
 
 grade
   :: MonadIO m
-  => (m () -> IO b)
+  => (forall a. m a -> (a -> m ()) -> (a -> m ()) -> IO (b, Maybe b))
   -> (forall c . Doc -> m c)
   -> (Doc -> m ())
   -> FilePath
   -> String
   -> String
-  -> IO b
+  -> IO (b, Maybe b)
 grade eval reject inform tmp task submission =
-  withTempDirectory tmp "Template" $ \ dirname -> eval $ do
-    when ("System.IO.Unsafe" `isInfixOf` submission)
-      $ void $ reject "wants to use System.IO.Unsafe"
-    when ("unsafePerformIO"  `isInfixOf` submission)
-      $ void $ reject "wants to use unsafePerformIO"
-    (mConfig, rawModules) <- splitConfigAndModules reject task
-    config                <- addDefaults reject mConfig
-    let exts = extensionsOf config
-    ((moduleName', template), others) <-
-      nameModules (reject . string) exts rawModules
-    files <- liftIO $ ((moduleName', submission) : others)
-      `forM` \(mName, contents) -> do
-        let fname = dirname </> mName <.> "hs"
-        strictWriteFile fname contents
-        return fname
-    let   existingModules = map takeBaseName
-            $ filter ((".hs" ==) . takeExtension)
-            $ filter (`notElem` [".",".."]) files
-          modules = ["Test"] `union` existingModules
-          solutionFile = dirname </> (moduleName' <.> "hs")
-    liftIO $ do
-      unless ("Test" `elem` existingModules) $
-        strictWriteFile (dirname </> "Test" <.> "hs") $ testModule moduleName'
-      strictWriteFile (dirname </> "TestHelper" <.> "hs") testHelperContents
-      strictWriteFile (dirname </> "TestHarness" <.> "hs")
-        $ testHarnessFor solutionFile
-    do
+  withTempDirectory tmp "Template" $ \ dirname -> do
+    let
+      prepare = do
+        when ("System.IO.Unsafe" `isInfixOf` submission)
+          $ void $ reject "wants to use System.IO.Unsafe"
+        when ("unsafePerformIO"  `isInfixOf` submission)
+          $ void $ reject "wants to use unsafePerformIO"
+        (mConfig, rawModules) <- splitConfigAndModules reject task
+        config                <- addDefaults reject mConfig
+        let exts = extensionsOf config
+        ((moduleName', template), others) <-
+          nameModules (reject . string) exts rawModules
+        files <- liftIO $ ((moduleName', submission) : others)
+          `forM` \(mName, contents) -> do
+            let fname = dirname </> mName <.> "hs"
+            strictWriteFile fname contents
+            return fname
+        let   existingModules = map takeBaseName
+                $ filter ((".hs" ==) . takeExtension)
+                $ filter (`notElem` [".",".."]) files
+              modules = ["Test"] `union` existingModules
+              solutionFile = dirname </> (moduleName' <.> "hs")
+        liftIO $ do
+          unless ("Test" `elem` existingModules) $
+            strictWriteFile (dirname </> "Test" <.> "hs") $ testModule moduleName'
+          strictWriteFile (dirname </> "TestHelper" <.> "hs") testHelperContents
+          strictWriteFile (dirname </> "TestHarness" <.> "hs")
+            $ testHarnessFor solutionFile
+
         let noTest = delete "Test" modules
+        pure (config, exts, template, modules, noTest, solutionFile)
+
+      syntax (config, exts, template, modules, noTest, solutionFile) = do
         compilation <- liftIO $ runInterpreter (compiler dirname config noTest)
         checkResult reject compilation reject Nothing $ const $ return ()
         when (runIdentity $ allowModifying config) $ do
@@ -408,10 +413,14 @@ grade eval reject inform tmp task submission =
         compileWithArgsAndCheck dirname reject undefined config noTest True
         void $ getHlintFeedback rejectWithHint config dirname solutionFile True
         matchTemplate reject config 2 exts template submission
+
+      semantics (config, _, _, modules, noTest, solutionFile) = do
         result      <- liftIO $ runInterpreter (interpreter dirname config modules)
         checkResult reject result reject Nothing $ handleCounts reject inform
         compileWithArgsAndCheck dirname reject inform config noTest False
         void $ getHlintFeedback inform config dirname solutionFile False
+
+    eval prepare syntax semantics
   where
     testHarnessFor file =
       let quoted xs = '"' : xs ++ "\""

test/Haskell/Template/TaskSpec.hs

@@ -14,7 +14,7 @@ import Control.Monad.Catch (
   MonadThrow (..),
   )
 import Control.Monad.IO.Class           (liftIO)
-import Control.Monad.Trans.Writer       (execWriterT, tell)
+import Control.Monad.Trans.Writer       (execWriterT, runWriterT, tell)
 import Data.List                        (intercalate, isPrefixOf)
 import Data.List.Extra                  (split)
 import Data.Maybe                       (fromJust)
@@ -165,7 +165,19 @@ gradeIO task submission = do
   tmp <- getTemporaryDirectory
   withTempDirectory tmp "Grade-test" $ \dir -> do
     setCurrentDirectory dir
-    grade execWriterT (throwM . CustomException) (tell . show) dir task submission
+    let eval prepare syntax semantics = do
+          (params,setupResult) <- runWriterT prepare
+          syntaxResult <- execWriterT $ syntax params
+          semanticsResult <- execWriterT $ semantics params
+          pure (setupResult ++ syntaxResult, Just semanticsResult)
+    (syntax,mSemantics) <- grade
+      eval
+      (throwM . CustomException)
+      (tell . show)
+      dir
+      task
+      submission
+    pure $ syntax ++ fromJust mSemantics
 
 hlintIO :: SolutionConfig -> String -> Bool -> IO [Either String String]
 hlintIO config content asError = do