Separate syntax and semantics feedback

.github/workflows/haskell.yml

@@ -3,7 +3,7 @@ name: Haskell CI
 
 on:
   push:
-    branches: ["master"]
+    branches: ["**"]
   pull_request:
     branches: ["master"]
 

src/Haskell/Template/Task.hs

@@ -125,6 +125,11 @@
 \# configHlintSuggestions      - hlint hints to provide as suggestions
 \# configLanguageExtensions    - this sets LanguageExtensions for hlint as well
 \# configModules               - DEPRECATED (will be ignored)
+\# syntaxCutoff                - determines the last step in the syntax phase (later steps are considered semantics)
+\#                               possible values (and also the order of steps):
+\#                                 Compilation, GhcErrors, HlintErrors, TemplateMatch, TestSuite
+\#                               default on omission is TemplateMatch; steps after TestSuite are (in this order):
+\#                                 GhcWarnings, HlintSuggestions
 ----------
 module Solution where
 import Prelude
@@ -188,6 +193,14 @@
       with the option to allow a fixed number of tests to fail.)
  -}|]
 
+data FeedbackPhase
+  = Compilation
+  | GhcErrors
+  | HlintErrors
+  | TemplateMatch
+  | TestSuite
+  deriving (Enum, Generic, Show, FromJSON, ToJSON)
+
 data FSolutionConfig m = SolutionConfig {
     allowAdding                 :: m Bool,
     allowModifying              :: m Bool,
@@ -202,7 +215,8 @@
     configHlintRules            :: m [String],
     configHlintSuggestions      :: m [String],
     configLanguageExtensions    :: m [String],
-    configModules               :: m [String]
+    configModules               :: m [String],
+    syntaxCutoff                :: m FeedbackPhase
   } deriving Generic
 {-# DEPRECATED configModules "config Modules will be removed" #-}
 
@@ -231,7 +245,8 @@
     configHlintRules            = Just [],
     configHlintSuggestions      = Just [],
     configLanguageExtensions    = Just ["NPlusKPatterns","ScopedTypeVariables"],
-    configModules               = Nothing
+    configModules               = Nothing,
+    syntaxCutoff                = Just TemplateMatch
   }
 
 toSolutionConfigOpt :: SolutionConfig -> SolutionConfigOpt
@@ -250,6 +265,7 @@
   <*> fmap Just configHlintSuggestions
   <*> fmap Just configLanguageExtensions
   <*> fmap Just configModules
+  <*> fmap Just syntaxCutoff
 
 finaliseConfigs :: [SolutionConfigOpt] -> Maybe SolutionConfig
 finaliseConfigs = finaliseConfig . foldl combineConfigs emptyConfig
@@ -270,6 +286,7 @@
       <*> fmap Identity configHlintSuggestions
       <*> fmap Identity configLanguageExtensions
       <*> fmap Identity configModules
+      <*> fmap Identity syntaxCutoff
     combineConfigs x y = SolutionConfig {
         allowAdding                 = allowAdding                 x <|> allowAdding                 y,
         allowModifying              = allowModifying              x <|> allowModifying              y,
@@ -284,7 +301,8 @@
         configHlintRules            = configHlintRules            x <|> configHlintRules            y,
         configHlintSuggestions      = configHlintSuggestions      x <|> configHlintSuggestions      y,
         configLanguageExtensions    = configLanguageExtensions    x <|> configLanguageExtensions    y,
-        configModules               = Just []
+        configModules               = Just [],
+        syntaxCutoff                = syntaxCutoff                x <|> syntaxCutoff                y
       }
     emptyConfig = SolutionConfig {
         allowAdding                 = Nothing,
@@ -300,7 +318,8 @@
         configHlintRules            = Nothing,
         configHlintSuggestions      = Nothing,
         configLanguageExtensions    = Nothing,
-        configModules               = Nothing
+        configModules               = Nothing,
+        syntaxCutoff                = Nothing
       }
 
 string :: String -> Doc
@@ -361,14 +380,30 @@
 whileOpen h =
   IO.hIsClosed h >>= flip unless (whileOpen h)
 
+{-|
+Generate consecutive syntax and possible semantics feedback in the context of an evaluation Monad.
+
+This Monad is expected to provide a mechanism to prematurely end the evaluation
+in case of failure.
+-}
 grade
   :: MonadIO m
-  => (m () -> IO b)
+  => (m (m ()) -> IO b)
+  {- ^
+    Evaluation function that constructs the feedback from nested monadic computations.
+    The function's argument executes the file setup and constructs syntax feedback,
+    then returns the unevaluated semantics computation.
+  -}
   -> (forall c . Doc -> m c)
+  -- ^ display a message and fail
   -> (Doc -> m ())
+  -- ^ display a message and continue
   -> FilePath
+  -- ^ parent directory to use for file operations
   -> String
+  -- ^ the task
   -> String
+  -- ^ the submission
   -> IO b
 grade eval reject inform tmp task submission =
   withTempDirectory tmp "Template" $ \ dirname -> eval $ do
@@ -397,22 +432,50 @@
       strictWriteFile (dirname </> "TestHelper" <.> "hs") testHelperContents
       strictWriteFile (dirname </> "TestHarness" <.> "hs")
         $ testHarnessFor solutionFile
-    do
-        let noTest = delete "Test" modules
+
+    let noTest = delete "Test" modules
+
+    let
+     (syntax, semantics) = splitAt (fromEnum (syntaxCutoff config) + 1)
+      [
+       do
+        -- Reject if submission does not compile with provided hidden modules,
+        -- but without Test module.
         compilation <- liftIO $ runInterpreter (compiler dirname config noTest)
         checkResult reject compilation reject Nothing $ const $ return ()
+
+        -- Reject if submission does not compile with provided hidden modules.
+        -- This only runs when allowModifying is set to True in the config
+        -- and displays a custom message telling students not to change type signatures.
         when (runIdentity $ allowModifying config) $ do
           compilationWithTests <- liftIO $ runInterpreter $
             compiler dirname config modules
           checkResult reject compilationWithTests signatureError Nothing $ const $ return ()
+      ,
+        -- Reject if GHC warnings configured as errors are triggered by solution.
         compileWithArgsAndCheck dirname reject undefined config noTest True
+      ,
+        -- Reject if HLint warnings configured as errors are triggered by solution.
         void $ getHlintFeedback rejectWithHint config dirname solutionFile True
+      ,
+        -- Reject on task template violations according to settings (modifying, adding, deleting).
         matchTemplate reject config 2 exts template submission
+      ,
+        -- Reject if test suite fails for submission.
+       do
         result      <- liftIO $ runInterpreter (interpreter dirname config modules)
         checkResult reject result reject Nothing $ handleCounts reject inform
+      ,
+       do
+        -- Displays GHC warnings configured as non-errors triggered by submission.
         compileWithArgsAndCheck dirname reject inform config noTest False
+
+        -- Displays HLint suggestions configured as non-errors triggered by submission.
         void $ getHlintFeedback inform config dirname solutionFile False
-  where
+      ]
+    sequence_ syntax
+    return $ sequence_ semantics
+ where
     testHarnessFor file =
       let quoted xs = '"' : xs ++ "\""
       in replace (quoted "Solution.hs") (quoted file) testHarnessContents
@@ -502,7 +565,7 @@
     liftIO $ unsafeRunInterpreterWithArgs ghcOpts (compiler dirname config modules)
   checkResult reject ghcErrors how howMany $ const $ return ()
   where
     makeOpts xs = ("-w":) $ ("-Werror=" ++) <$> xs
     ghcOpts  = makeOpts $ msum (warnings config)
     (warnings, how) =
       if asError
@@ -684,7 +747,7 @@
          (return . (,rawModules))
          eConfig
   where
     configJson:rawModules = splitModules False configAndModules
     eConfig :: Either ParseException SolutionConfigOpt
     eConfig = decodeEither' $ BS.pack configJson
 
@@ -709,7 +772,7 @@
 
 unsafeTemplateSegment :: String -> String
 unsafeTemplateSegment task = either id id $ do
   let Just (mConfig, modules) =
         splitConfigAndModules (const $ Just (defaultSolutionConfig, [])) task
       exts = maybe [] extensionsOf $ addDefaults (const Nothing) mConfig
   snd . fst <$> nameModules Left exts modules

test/Haskell/Template/TaskSpec.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TupleSections #-}
 module Haskell.Template.TaskSpec where
 
 import qualified Data.ByteString.Char8            as BS (unpack)
@@ -8,6 +9,7 @@
 import Haskell.Template.Task
 
 import Control.Arrow                    ((+++))
+import Control.Monad                    (join)
 import Control.Monad.Catch (
   Exception,
   MonadCatch (..),
@@ -113,10 +115,10 @@
       incomplete [] = undefined
       incomplete2 (_:_) = undefined
       |]
     (config : program : tests : remaining) =
       split ("---" `isPrefixOf`) $ lines defaultCode
     withSyntaxCheck withReverse = unlines $ intercalate ["-------"] $
       let (config : program : _ : remaining) =
             split ("---" `isPrefixOf`) $ lines defaultCode
       in config : program : [syntaxCheck withReverse] : remaining
     syntaxCheck :: Bool -> String
@@ -165,7 +167,13 @@
   tmp <- getTemporaryDirectory
   withTempDirectory tmp "Grade-test" $ \dir -> do
     setCurrentDirectory dir
-    grade execWriterT (throwM . CustomException) (tell . show) dir task submission
+    grade
+      (execWriterT . join)
+      (throwM . CustomException)
+      (tell . show)
+      dir
+      task
+      submission
 
 hlintIO :: SolutionConfig -> String -> Bool -> IO [Either String String]
 hlintIO config content asError = do