From e773cbc47c8bf11ba4120dcaa0f732b69181264a Mon Sep 17 00:00:00 2001 From: patritzenfeld Date: Thu, 26 Mar 2026 18:08:20 +0100 Subject: [PATCH 01/20] adjust grade function to give feedback in multiple stages --- src/Haskell/Template/Task.hs | 67 ++++++++++++++++++------------- test/Haskell/Template/TaskSpec.hs | 16 +++++++- 2 files changed, 52 insertions(+), 31 deletions(-) diff --git a/src/Haskell/Template/Task.hs b/src/Haskell/Template/Task.hs index 3f0b144..a55d393 100644 --- a/src/Haskell/Template/Task.hs +++ b/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 ++ "\"" diff --git a/test/Haskell/Template/TaskSpec.hs b/test/Haskell/Template/TaskSpec.hs index 80d5c51..68c933f 100644 --- a/test/Haskell/Template/TaskSpec.hs +++ b/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 From 87bc570b8054a6a29270d44bb9204330ed2bfe6f Mon Sep 17 00:00:00 2001 From: patritzenfeld Date: Thu, 26 Mar 2026 18:11:40 +0100 Subject: [PATCH 02/20] move hlint checks completely into syntax phase --- src/Haskell/Template/Task.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Haskell/Template/Task.hs b/src/Haskell/Template/Task.hs index a55d393..3dbb0ef 100644 --- a/src/Haskell/Template/Task.hs +++ b/src/Haskell/Template/Task.hs @@ -412,13 +412,13 @@ grade eval reject inform tmp task submission = checkResult reject compilationWithTests signatureError Nothing $ const $ return () compileWithArgsAndCheck dirname reject undefined config noTest True void $ getHlintFeedback rejectWithHint config dirname solutionFile True + void $ getHlintFeedback inform config dirname solutionFile False matchTemplate reject config 2 exts template submission - semantics (config, _, _, modules, noTest, solutionFile) = do + semantics (config, _, _, modules, noTest, _) = 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 From 6ffcc86ae3e415c4337be9b485431a2dae6deb5a Mon Sep 17 00:00:00 2001 From: patritzenfeld Date: Thu, 26 Mar 2026 18:12:17 +0100 Subject: [PATCH 03/20] check template violations before hlint --- src/Haskell/Template/Task.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Haskell/Template/Task.hs b/src/Haskell/Template/Task.hs index 3dbb0ef..66ef9ce 100644 --- a/src/Haskell/Template/Task.hs +++ b/src/Haskell/Template/Task.hs @@ -411,9 +411,9 @@ grade eval reject inform tmp task submission = compiler dirname config modules checkResult reject compilationWithTests signatureError Nothing $ const $ return () compileWithArgsAndCheck dirname reject undefined config noTest True + matchTemplate reject config 2 exts template submission void $ getHlintFeedback rejectWithHint config dirname solutionFile True void $ getHlintFeedback inform config dirname solutionFile False - matchTemplate reject config 2 exts template submission semantics (config, _, _, modules, noTest, _) = do result <- liftIO $ runInterpreter (interpreter dirname config modules) From d8a380b7a60f763b91379861c345893173ae4c1c Mon Sep 17 00:00:00 2001 From: patritzenfeld Date: Fri, 27 Mar 2026 10:42:06 +0100 Subject: [PATCH 04/20] restore original order --- src/Haskell/Template/Task.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Haskell/Template/Task.hs b/src/Haskell/Template/Task.hs index 66ef9ce..a55d393 100644 --- a/src/Haskell/Template/Task.hs +++ b/src/Haskell/Template/Task.hs @@ -411,14 +411,14 @@ grade eval reject inform tmp task submission = compiler dirname config modules checkResult reject compilationWithTests signatureError Nothing $ const $ return () compileWithArgsAndCheck dirname reject undefined config noTest True - matchTemplate reject config 2 exts template submission void $ getHlintFeedback rejectWithHint config dirname solutionFile True - void $ getHlintFeedback inform config dirname solutionFile False + matchTemplate reject config 2 exts template submission - semantics (config, _, _, modules, noTest, _) = do + 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 From af764cde0bb590a21ef58c22c6e5d7458f7918a7 Mon Sep 17 00:00:00 2001 From: patritzenfeld Date: Fri, 27 Mar 2026 11:03:03 +0100 Subject: [PATCH 05/20] annotate steps in grade --- src/Haskell/Template/Task.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/Haskell/Template/Task.hs b/src/Haskell/Template/Task.hs index a55d393..0b019cf 100644 --- a/src/Haskell/Template/Task.hs +++ b/src/Haskell/Template/Task.hs @@ -404,20 +404,31 @@ grade eval reject inform tmp task submission = pure (config, exts, template, modules, noTest, solutionFile) syntax (config, exts, template, modules, noTest, solutionFile) = 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 semantics (config, _, _, modules, noTest, solutionFile) = do + -- Reject if test suite fails for submission. result <- liftIO $ runInterpreter (interpreter dirname config modules) checkResult reject result reject Nothing $ handleCounts reject inform + -- 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 eval prepare syntax semantics From 2e3ccf6bb07705628b27bfacd86d716c8511f041 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Fri, 27 Mar 2026 16:21:14 +0200 Subject: [PATCH 06/20] layout, to avoid spurious diff --- src/Haskell/Template/Task.hs | 72 ++++++++++++++++++------------------ 1 file changed, 36 insertions(+), 36 deletions(-) diff --git a/src/Haskell/Template/Task.hs b/src/Haskell/Template/Task.hs index 0b019cf..1791856 100644 --- a/src/Haskell/Template/Task.hs +++ b/src/Haskell/Template/Task.hs @@ -371,39 +371,39 @@ grade -> String -> IO (b, Maybe b) grade eval reject inform tmp task submission = - 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 + 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 -- Reject if submission does not compile with provided hidden modules, -- but without Test module. compilation <- liftIO $ runInterpreter (compiler dirname config noTest) @@ -422,7 +422,7 @@ grade eval reject inform tmp task submission = -- Reject on task template violations according to settings (modifying, adding, deleting). matchTemplate reject config 2 exts template submission - semantics (config, _, _, modules, noTest, solutionFile) = do + semantics (config, _, _, modules, noTest, solutionFile) = do -- Reject if test suite fails for submission. result <- liftIO $ runInterpreter (interpreter dirname config modules) checkResult reject result reject Nothing $ handleCounts reject inform @@ -431,8 +431,8 @@ grade eval reject inform tmp task submission = -- Displays HLint suggestions configured as non-errors triggered by submission. void $ getHlintFeedback inform config dirname solutionFile False - eval prepare syntax semantics - where + eval prepare syntax semantics + where testHarnessFor file = let quoted xs = '"' : xs ++ "\"" in replace (quoted "Solution.hs") (quoted file) testHarnessContents From de1e4af85a3393da10dc67b214a660a53f762d6c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Sat, 28 Mar 2026 11:06:10 +0200 Subject: [PATCH 07/20] explicit lists of checks --- .github/workflows/haskell.yml | 2 +- src/Haskell/Template/Task.hs | 18 ++++++++++++++++-- 2 files changed, 17 insertions(+), 3 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 2942cb7..222a01a 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -3,7 +3,7 @@ name: Haskell CI on: push: - branches: ["master"] + branches: ["**"] pull_request: branches: ["master"] diff --git a/src/Haskell/Template/Task.hs b/src/Haskell/Template/Task.hs index 1791856..7199f84 100644 --- a/src/Haskell/Template/Task.hs +++ b/src/Haskell/Template/Task.hs @@ -403,11 +403,15 @@ grade eval reject inform tmp task submission = let noTest = delete "Test" modules pure (config, exts, template, modules, noTest, solutionFile) - syntax (config, exts, template, modules, noTest, solutionFile) = do + syntax (config, exts, template, modules, noTest, solutionFile) = + sequence_ + [ -- Reject if submission does not compile with provided hidden modules, -- but without Test module. + do 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. @@ -415,21 +419,31 @@ grade eval reject inform tmp task submission = 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 + ] - semantics (config, _, _, modules, noTest, solutionFile) = do + semantics (config, _, _, modules, noTest, solutionFile) = + sequence_ + [ -- Reject if test suite fails for submission. + do result <- liftIO $ runInterpreter (interpreter dirname config modules) checkResult reject result reject Nothing $ handleCounts reject inform + , -- 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 + ] eval prepare syntax semantics where From e8709c81afdbe1d84988f1f80085e1ea1cdeaa88 Mon Sep 17 00:00:00 2001 From: patritzenfeld Date: Tue, 31 Mar 2026 13:05:15 +0200 Subject: [PATCH 08/20] adjust eval structure --- src/Haskell/Template/Task.hs | 7 +++++-- test/Haskell/Template/TaskSpec.hs | 9 ++++----- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/src/Haskell/Template/Task.hs b/src/Haskell/Template/Task.hs index 7199f84..9dceeaf 100644 --- a/src/Haskell/Template/Task.hs +++ b/src/Haskell/Template/Task.hs @@ -363,7 +363,7 @@ whileOpen h = grade :: MonadIO m - => (forall a. m a -> (a -> m ()) -> (a -> m ()) -> IO (b, Maybe b)) + => (m (m ()) -> IO (b, Maybe b)) -> (forall c . Doc -> m c) -> (Doc -> m ()) -> FilePath @@ -445,7 +445,10 @@ grade eval reject inform tmp task submission = void $ getHlintFeedback inform config dirname solutionFile False ] - eval prepare syntax semantics + eval $ do + params <- prepare + syntax params + return (semantics params) where testHarnessFor file = let quoted xs = '"' : xs ++ "\"" diff --git a/test/Haskell/Template/TaskSpec.hs b/test/Haskell/Template/TaskSpec.hs index 68c933f..91a8188 100644 --- a/test/Haskell/Template/TaskSpec.hs +++ b/test/Haskell/Template/TaskSpec.hs @@ -165,11 +165,10 @@ gradeIO task submission = do tmp <- getTemporaryDirectory withTempDirectory tmp "Grade-test" $ \dir -> do setCurrentDirectory dir - let eval prepare syntax semantics = do - (params,setupResult) <- runWriterT prepare - syntaxResult <- execWriterT $ syntax params - semanticsResult <- execWriterT $ semantics params - pure (setupResult ++ syntaxResult, Just semanticsResult) + let eval phases = do + (semanticsPhase, setupAndSyntaxResults) <- runWriterT phases + semanticsResult <- execWriterT semanticsPhase + pure (setupAndSyntaxResults, Just semanticsResult) (syntax,mSemantics) <- grade eval (throwM . CustomException) From 27b4dee95b528345590407268e6ddcdeca0c07cf Mon Sep 17 00:00:00 2001 From: patritzenfeld Date: Tue, 31 Mar 2026 14:02:50 +0200 Subject: [PATCH 09/20] restructure to single block and make cutoff configurable --- src/Haskell/Template/Task.hs | 49 ++++++++++++++++++++---------------- 1 file changed, 28 insertions(+), 21 deletions(-) diff --git a/src/Haskell/Template/Task.hs b/src/Haskell/Template/Task.hs index 9dceeaf..603e61d 100644 --- a/src/Haskell/Template/Task.hs +++ b/src/Haskell/Template/Task.hs @@ -125,6 +125,9 @@ defaultCode = BS.unpack (encode defaultSolutionConfig) ++ \# 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 (everything afterwards is considered semantics) +\# possible values: Compilation, GhcErrors, HlintErrors, TemplateMatch, TestSuite +\# default on omission is TemplateMatch ---------- module Solution where import Prelude @@ -188,6 +191,14 @@ Also available are the following modules: 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 +213,8 @@ data FSolutionConfig m = SolutionConfig { 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 +243,8 @@ defaultSolutionConfig = SolutionConfig { configHlintRules = Just [], configHlintSuggestions = Just [], configLanguageExtensions = Just ["NPlusKPatterns","ScopedTypeVariables"], - configModules = Nothing + configModules = Nothing, + syntaxCutoff = Just TemplateMatch } toSolutionConfigOpt :: SolutionConfig -> SolutionConfigOpt @@ -250,6 +263,7 @@ toSolutionConfigOpt SolutionConfig {..} = runIdentity $ SolutionConfig <*> fmap Just configHlintSuggestions <*> fmap Just configLanguageExtensions <*> fmap Just configModules + <*> fmap Just syntaxCutoff finaliseConfigs :: [SolutionConfigOpt] -> Maybe SolutionConfig finaliseConfigs = finaliseConfig . foldl combineConfigs emptyConfig @@ -270,6 +284,7 @@ finaliseConfigs = finaliseConfig . foldl combineConfigs emptyConfig <*> 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 +299,8 @@ finaliseConfigs = finaliseConfig . foldl combineConfigs emptyConfig 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 +316,8 @@ finaliseConfigs = finaliseConfig . foldl combineConfigs emptyConfig configHlintRules = Nothing, configHlintSuggestions = Nothing, configLanguageExtensions = Nothing, - configModules = Nothing + configModules = Nothing, + syntaxCutoff = Nothing } string :: String -> Doc @@ -371,9 +388,7 @@ grade -> String -> IO (b, Maybe b) grade eval reject inform tmp task submission = - withTempDirectory tmp "Template" $ \ dirname -> do - let - prepare = do + withTempDirectory tmp "Template" $ \ dirname -> eval $ do when ("System.IO.Unsafe" `isInfixOf` submission) $ void $ reject "wants to use System.IO.Unsafe" when ("unsafePerformIO" `isInfixOf` submission) @@ -401,17 +416,16 @@ grade eval reject inform tmp task submission = $ testHarnessFor solutionFile let noTest = delete "Test" modules - pure (config, exts, template, modules, noTest, solutionFile) - syntax (config, exts, template, modules, noTest, solutionFile) = - sequence_ + let + (syntax, semantics) = splitAt (fromEnum (syntaxCutoff config) + 1) [ -- Reject if submission does not compile with provided hidden modules, -- but without Test module. do 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. @@ -428,11 +442,7 @@ grade eval reject inform tmp task submission = , -- Reject on task template violations according to settings (modifying, adding, deleting). matchTemplate reject config 2 exts template submission - ] - - semantics (config, _, _, modules, noTest, solutionFile) = - sequence_ - [ + , -- Reject if test suite fails for submission. do result <- liftIO $ runInterpreter (interpreter dirname config modules) @@ -444,11 +454,8 @@ grade eval reject inform tmp task submission = -- Displays HLint suggestions configured as non-errors triggered by submission. void $ getHlintFeedback inform config dirname solutionFile False ] - - eval $ do - params <- prepare - syntax params - return (semantics params) + sequence_ syntax + return $ sequence_ semantics where testHarnessFor file = let quoted xs = '"' : xs ++ "\"" From 1b673389508fe3cddf13c2436baed92cd1ff0870 Mon Sep 17 00:00:00 2001 From: patritzenfeld Date: Tue, 31 Mar 2026 14:53:13 +0200 Subject: [PATCH 10/20] make skipping phase separation in test suite more explicit --- test/Haskell/Template/TaskSpec.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/test/Haskell/Template/TaskSpec.hs b/test/Haskell/Template/TaskSpec.hs index 91a8188..1cb1ea7 100644 --- a/test/Haskell/Template/TaskSpec.hs +++ b/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 qualified Text.PrettyPrint.Leijen.Text as PP import Haskell.Template.Task import Control.Arrow ((+++)) +import Control.Monad (join) import Control.Monad.Catch ( Exception, MonadCatch (..), @@ -165,18 +167,15 @@ gradeIO task submission = do tmp <- getTemporaryDirectory withTempDirectory tmp "Grade-test" $ \dir -> do setCurrentDirectory dir - let eval phases = do - (semanticsPhase, setupAndSyntaxResults) <- runWriterT phases - semanticsResult <- execWriterT semanticsPhase - pure (setupAndSyntaxResults, Just semanticsResult) - (syntax,mSemantics) <- grade + let eval = fmap (, Nothing) . execWriterT . join + (output, _) <- grade eval (throwM . CustomException) (tell . show) dir task submission - pure $ syntax ++ fromJust mSemantics + pure output hlintIO :: SolutionConfig -> String -> Bool -> IO [Either String String] hlintIO config content asError = do From 95b4a4467560720446b657ccc7c21d7f1fd12f52 Mon Sep 17 00:00:00 2001 From: patritzenfeld Date: Tue, 31 Mar 2026 14:54:08 +0200 Subject: [PATCH 11/20] document arguments of grade and write out expectation regarding eval --- src/Haskell/Template/Task.hs | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/src/Haskell/Template/Task.hs b/src/Haskell/Template/Task.hs index 603e61d..bdd14e8 100644 --- a/src/Haskell/Template/Task.hs +++ b/src/Haskell/Template/Task.hs @@ -378,14 +378,29 @@ whileOpen :: IO.Handle -> IO () whileOpen h = IO.hIsClosed h >>= flip unless (whileOpen h) +{-| +Generate separate syntax and possible semantics feedback in the context of an evaluation Monad. +-} grade :: MonadIO m => (m (m ()) -> IO (b, Maybe 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. + it is expected that the caller implements an efficient mechanism + to prevent computing the semantics feedback (denoted by `Nothing`) in case of failure during the syntax feedback. + -} -> (forall c . Doc -> m c) + -- ^ fail and display a message -> (Doc -> m ()) + -- ^ continue and display a message -> FilePath + -- ^ parent directory to use for file operations -> String + -- ^ the task -> String + -- ^ the submission -> IO (b, Maybe b) grade eval reject inform tmp task submission = withTempDirectory tmp "Template" $ \ dirname -> eval $ do From 42bca9069669dedbb10b9239caadefcfdbeca6a5 Mon Sep 17 00:00:00 2001 From: patritzenfeld Date: Tue, 31 Mar 2026 14:59:48 +0200 Subject: [PATCH 12/20] remove unneeded import --- test/Haskell/Template/TaskSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Haskell/Template/TaskSpec.hs b/test/Haskell/Template/TaskSpec.hs index 1cb1ea7..4991156 100644 --- a/test/Haskell/Template/TaskSpec.hs +++ b/test/Haskell/Template/TaskSpec.hs @@ -16,7 +16,7 @@ import Control.Monad.Catch ( MonadThrow (..), ) import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Writer (execWriterT, runWriterT, tell) +import Control.Monad.Trans.Writer (execWriterT, tell) import Data.List (intercalate, isPrefixOf) import Data.List.Extra (split) import Data.Maybe (fromJust) From e367367e53009bba1de64ecfd14411423502162d Mon Sep 17 00:00:00 2001 From: patritzenfeld Date: Tue, 31 Mar 2026 15:01:49 +0200 Subject: [PATCH 13/20] shrten comment --- src/Haskell/Template/Task.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Haskell/Template/Task.hs b/src/Haskell/Template/Task.hs index bdd14e8..f28d265 100644 --- a/src/Haskell/Template/Task.hs +++ b/src/Haskell/Template/Task.hs @@ -125,7 +125,7 @@ defaultCode = BS.unpack (encode defaultSolutionConfig) ++ \# 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 (everything afterwards is considered semantics) +\# syntaxCutoff - determines the last step in the syntax phase (later steps are considered semantics) \# possible values: Compilation, GhcErrors, HlintErrors, TemplateMatch, TestSuite \# default on omission is TemplateMatch ---------- From a4ed028c5c379fd973715832f34ee9e5a0a9b5d1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Tue, 31 Mar 2026 15:30:15 +0200 Subject: [PATCH 14/20] small comment tweaks --- src/Haskell/Template/Task.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Haskell/Template/Task.hs b/src/Haskell/Template/Task.hs index f28d265..cfb7d87 100644 --- a/src/Haskell/Template/Task.hs +++ b/src/Haskell/Template/Task.hs @@ -126,7 +126,7 @@ defaultCode = BS.unpack (encode defaultSolutionConfig) ++ \# 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: Compilation, GhcErrors, HlintErrors, TemplateMatch, TestSuite +\# possible values (and also the order of steps): Compilation, GhcErrors, HlintErrors, TemplateMatch, TestSuite \# default on omission is TemplateMatch ---------- module Solution where @@ -388,7 +388,7 @@ grade 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. - it is expected that the caller implements an efficient mechanism + It is expected that the caller implements an efficient mechanism to prevent computing the semantics feedback (denoted by `Nothing`) in case of failure during the syntax feedback. -} -> (forall c . Doc -> m c) From 02b303aeb618f4cc8973c971661c3a50fbdedf4d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Tue, 31 Mar 2026 15:36:45 +0200 Subject: [PATCH 15/20] more in comments --- src/Haskell/Template/Task.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Haskell/Template/Task.hs b/src/Haskell/Template/Task.hs index cfb7d87..9db7adc 100644 --- a/src/Haskell/Template/Task.hs +++ b/src/Haskell/Template/Task.hs @@ -126,8 +126,10 @@ defaultCode = BS.unpack (encode defaultSolutionConfig) ++ \# 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 +\# possible values (and also the order of steps): +\# Compilation, GhcErrors, HlintErrors, TemplateMatch, TestSuite +\# default on omission is TemplateMatch; steps after TestSuite are: +\# GhcWarnings, HlintSuggestions ---------- module Solution where import Prelude From 266a135a81379be3fbfa2cff21c375d738a16e7a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Tue, 31 Mar 2026 15:39:48 +0200 Subject: [PATCH 16/20] not gonna split in there --- src/Haskell/Template/Task.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Haskell/Template/Task.hs b/src/Haskell/Template/Task.hs index 9db7adc..52900a2 100644 --- a/src/Haskell/Template/Task.hs +++ b/src/Haskell/Template/Task.hs @@ -437,9 +437,9 @@ grade eval reject inform tmp task submission = let (syntax, semantics) = splitAt (fromEnum (syntaxCutoff config) + 1) [ + do -- Reject if submission does not compile with provided hidden modules, -- but without Test module. - do compilation <- liftIO $ runInterpreter (compiler dirname config noTest) checkResult reject compilation reject Nothing $ const $ return () @@ -465,9 +465,10 @@ grade eval reject inform tmp task submission = 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 ] From 34a8fe144cdf222bdc0885bf9f0f3e10dcd991f4 Mon Sep 17 00:00:00 2001 From: patritzenfeld Date: Tue, 31 Mar 2026 16:00:40 +0200 Subject: [PATCH 17/20] replace Nothing with undefined in test suite call --- test/Haskell/Template/TaskSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Haskell/Template/TaskSpec.hs b/test/Haskell/Template/TaskSpec.hs index 4991156..9f04bb8 100644 --- a/test/Haskell/Template/TaskSpec.hs +++ b/test/Haskell/Template/TaskSpec.hs @@ -167,7 +167,7 @@ gradeIO task submission = do tmp <- getTemporaryDirectory withTempDirectory tmp "Grade-test" $ \dir -> do setCurrentDirectory dir - let eval = fmap (, Nothing) . execWriterT . join + let eval = fmap (, undefined) . execWriterT . join (output, _) <- grade eval (throwM . CustomException) From 5a1ee21b97dbb41c2ea62fcef6bf27bfbbc5b83e Mon Sep 17 00:00:00 2001 From: patritzenfeld Date: Thu, 2 Apr 2026 13:54:48 +0200 Subject: [PATCH 18/20] improve result type of grade and adjust docs --- src/Haskell/Template/Task.hs | 13 +++++++------ test/Haskell/Template/TaskSpec.hs | 6 ++---- 2 files changed, 9 insertions(+), 10 deletions(-) diff --git a/src/Haskell/Template/Task.hs b/src/Haskell/Template/Task.hs index 52900a2..9712369 100644 --- a/src/Haskell/Template/Task.hs +++ b/src/Haskell/Template/Task.hs @@ -381,17 +381,18 @@ whileOpen h = IO.hIsClosed h >>= flip unless (whileOpen h) {-| -Generate separate syntax and possible semantics feedback in the context of an evaluation Monad. +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 (m ()) -> IO (b, Maybe b)) + => (m (m ()) -> IO b) {- ^ - evaluation function that constructs the feedback from nested monadic computations. + 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. - It is expected that the caller implements an efficient mechanism - to prevent computing the semantics feedback (denoted by `Nothing`) in case of failure during the syntax feedback. -} -> (forall c . Doc -> m c) -- ^ fail and display a message @@ -403,7 +404,7 @@ grade -- ^ the task -> String -- ^ the submission - -> IO (b, Maybe b) + -> IO b grade eval reject inform tmp task submission = withTempDirectory tmp "Template" $ \ dirname -> eval $ do when ("System.IO.Unsafe" `isInfixOf` submission) diff --git a/test/Haskell/Template/TaskSpec.hs b/test/Haskell/Template/TaskSpec.hs index 9f04bb8..8473f25 100644 --- a/test/Haskell/Template/TaskSpec.hs +++ b/test/Haskell/Template/TaskSpec.hs @@ -167,15 +167,13 @@ gradeIO task submission = do tmp <- getTemporaryDirectory withTempDirectory tmp "Grade-test" $ \dir -> do setCurrentDirectory dir - let eval = fmap (, undefined) . execWriterT . join - (output, _) <- grade - eval + grade + (execWriterT . join) (throwM . CustomException) (tell . show) dir task submission - pure output hlintIO :: SolutionConfig -> String -> Bool -> IO [Either String String] hlintIO config content asError = do From 2f5b52b189eb0c783dd8031bdf981ae09cf26570 Mon Sep 17 00:00:00 2001 From: patritzenfeld Date: Thu, 2 Apr 2026 13:56:45 +0200 Subject: [PATCH 19/20] docs wording --- src/Haskell/Template/Task.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Haskell/Template/Task.hs b/src/Haskell/Template/Task.hs index 9712369..0668a91 100644 --- a/src/Haskell/Template/Task.hs +++ b/src/Haskell/Template/Task.hs @@ -395,9 +395,9 @@ grade then returns the unevaluated semantics computation. -} -> (forall c . Doc -> m c) - -- ^ fail and display a message + -- ^ display a message and fail -> (Doc -> m ()) - -- ^ continue and display a message + -- ^ display a message and continue -> FilePath -- ^ parent directory to use for file operations -> String From bf5400735c7dc3d09359d8653ccb2ee8e1133ea8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Thu, 2 Apr 2026 16:05:23 +0300 Subject: [PATCH 20/20] comment --- src/Haskell/Template/Task.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Haskell/Template/Task.hs b/src/Haskell/Template/Task.hs index 0668a91..3d99096 100644 --- a/src/Haskell/Template/Task.hs +++ b/src/Haskell/Template/Task.hs @@ -128,7 +128,7 @@ defaultCode = BS.unpack (encode defaultSolutionConfig) ++ \# 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: +\# default on omission is TemplateMatch; steps after TestSuite are (in this order): \# GhcWarnings, HlintSuggestions ---------- module Solution where