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 3f0b144..3d99096 100644 --- a/src/Haskell/Template/Task.hs +++ b/src/Haskell/Template/Task.hs @@ -125,6 +125,11 @@ 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 (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 @@ 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 +215,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 +245,8 @@ defaultSolutionConfig = SolutionConfig { configHlintRules = Just [], configHlintSuggestions = Just [], configLanguageExtensions = Just ["NPlusKPatterns","ScopedTypeVariables"], - configModules = Nothing + configModules = Nothing, + syntaxCutoff = Just TemplateMatch } toSolutionConfigOpt :: SolutionConfig -> SolutionConfigOpt @@ -250,6 +265,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 +286,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 +301,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 +318,8 @@ finaliseConfigs = finaliseConfig . foldl combineConfigs emptyConfig configHlintRules = Nothing, configHlintSuggestions = Nothing, configLanguageExtensions = Nothing, - configModules = Nothing + configModules = Nothing, + syntaxCutoff = Nothing } string :: String -> Doc @@ -361,14 +380,30 @@ whileOpen :: IO.Handle -> IO () 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 @@ grade eval reject inform tmp task submission = 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 diff --git a/test/Haskell/Template/TaskSpec.hs b/test/Haskell/Template/TaskSpec.hs index 80d5c51..8473f25 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,7 +167,13 @@ gradeIO task submission = do 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