Add option for ensuring specific line length

.github/actions/spelling/expect.txt

@@ -13,6 +13,7 @@ IOTASKS
 KPatterns
 Leijen
 lhs
+linebreak
 listify
 NPlus
 PCRE

src/Haskell/Template/Task.hs

@@ -42,7 +42,7 @@
 
 import Control.Applicative              ((<|>))
 import Control.Monad                    (forM, guard, msum, unless, void, when)
-import Control.Monad.Extra              (whenJust)
+import Control.Monad.Extra              ((&&^), whenJust)
 import Control.Monad.IO.Class           (MonadIO)
 import Data.Char                        (isUpper)
 import Data.Functor.Identity            (Identity (..))
@@ -78,7 +78,7 @@
   )
 import Test.HUnit                       (Counts (..))
 import Text.PrettyPrint.Leijen.Text
-  (Doc, nest, text, vcat)
+  (Doc, (<+>), int, linebreak, nest, punctuate, text, vcat)
 import Text.Read                        (readMaybe)
 import Text.Regex.PCRE.Heavy            (re, sub)
 
@@ -108,9 +108,10 @@
 \# configHlintSuggestions      - hlint hints to provide as suggestions
 \# configLanguageExtensions    - this sets LanguageExtensions for hlint as well
 \# configModules               - DEPRECATED (will be ignored)
+\# maxLineLength               - submissions with lines longer than this value are rejected
 \# 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
+\#                                 CodeWidth, Compilation, GhcErrors, HlintErrors, TemplateMatch, TestSuite
 \#                               default on omission is TemplateMatch; steps after TestSuite are (in this order):
 \#                                 GhcWarnings, HlintSuggestions
 \# disableSemantics            - will prevent the semantics phase (as determined by syntaxCutoff) from running;
@@ -197,12 +198,13 @@
  -}|]
 
 data FeedbackPhase
-  = Compilation
+  = CodeWidth
+  | Compilation
   | GhcErrors
   | HlintErrors
   | TemplateMatch
   | TestSuite
-  deriving (Enum, Generic, Show, FromJSON, ToJSON)
+  deriving (Enum, Eq, Generic, Show, FromJSON, ToJSON)
 
 data FSolutionConfig m = SolutionConfig {
     allowAdding                 :: m Bool,
@@ -221,6 +223,7 @@
     configHlintSuggestions      :: m [String],
     configLanguageExtensions    :: m [String],
     configModules               :: m [String],
+    maxLineLength               :: m (Maybe Natural),
     provideSampleSolution       :: m Bool,
     messageOnCloningSampleSolution :: m (Maybe String),
     disableSemantics            :: m Bool,
@@ -256,6 +259,7 @@
     configHlintSuggestions      = Just [],
     configLanguageExtensions    = Just ["NPlusKPatterns","ScopedTypeVariables"],
     configModules               = Nothing,
+    maxLineLength               = Just Nothing,
     provideSampleSolution       = Just False,
     messageOnCloningSampleSolution = Just Nothing,
     disableSemantics            = Just False,
@@ -280,6 +284,7 @@
   <*> fmap Just configHlintSuggestions
   <*> fmap Just configLanguageExtensions
   <*> fmap Just configModules
+  <*> fmap Just maxLineLength
   <*> fmap Just provideSampleSolution
   <*> fmap Just messageOnCloningSampleSolution
   <*> fmap Just disableSemantics
@@ -306,6 +311,7 @@
       <*> fmap Identity configHlintSuggestions
       <*> fmap Identity configLanguageExtensions
       <*> fmap Identity configModules
+      <*> fmap Identity maxLineLength
       <*> fmap Identity provideSampleSolution
       <*> fmap Identity messageOnCloningSampleSolution
       <*> fmap Identity disableSemantics
@@ -327,6 +333,7 @@
         configHlintSuggestions      = configHlintSuggestions      x <|> configHlintSuggestions      y,
         configLanguageExtensions    = configLanguageExtensions    x <|> configLanguageExtensions    y,
         configModules               = Just [],
+        maxLineLength               = maxLineLength               x <|> maxLineLength               y,
         provideSampleSolution       = provideSampleSolution       x <|> provideSampleSolution       y,
         messageOnCloningSampleSolution = messageOnCloningSampleSolution x <|> messageOnCloningSampleSolution y,
         disableSemantics            = disableSemantics            x <|> disableSemantics            y,
@@ -349,6 +356,7 @@
         configHlintSuggestions      = Nothing,
         configLanguageExtensions    = Nothing,
         configModules               = Nothing,
+        maxLineLength               = Nothing,
         provideSampleSolution       = Nothing,
         messageOnCloningSampleSolution = Nothing,
         disableSemantics            = Nothing,
@@ -496,22 +504,26 @@
   -- ^ whether the conditions outlined in the description apply or not
 grade withSyntax withSemantics reject inform dirname task submission = do
     withSyntax $ checkUnsafe reject submission
-    (config, exts, (moduleName', template), others) <- processConfig
+    (config@SolutionConfig{..}, exts, (moduleName', template), others) <- processConfig
       (rejectWithMessage reject $ string informTutorMessage)
       (const $ pure ())
       task
-    (modules, solutionFile) <- writeModules (moduleName', submission) others dirname
+    (modules, solutionFile) <- if runIdentity $ fmap (== CodeWidth) syntaxCutoff &&^ disableSemantics
+      -- Completely skip file writing if code length is the only syntax phase action
+      -- and semantics phase is disabled.
+      then pure (undefined, undefined)
+      else writeModules (moduleName', submission) others dirname
     let
-     (syntax, semantics) = splitAt (fromEnum (syntaxCutoff config) + 1)
+     (syntax, semantics) = splitAt (fromEnum syntaxCutoff + 1)
       $ testPhases reject inform template solutionFile modules config exts submission dirname
     withSyntax $ sequence_ syntax
-    if runIdentity $ disableSemantics config
+    if runIdentity disableSemantics
     then pure False
     else do
      withSemantics $ sequence_ semantics
      case
       (,) <$> lookup "SampleSolution" others
-          <*> runIdentity (messageOnCloningSampleSolution config)
+          <*> runIdentity messageOnCloningSampleSolution
       of
         Nothing                       -> pure False
         Just (sampleSolution,message) -> catchSampleSolutionClone
@@ -596,7 +608,7 @@
     liftIO $ unsafeRunInterpreterWithArgs ghcOpts (compiler dirname extensions modules)
   checkResult reject ghcErrors how howMany $ const $ return ()
   where
     makeOpts xs = ("-w":) $ ("-Werror=" ++) <$> xs
     ghcOpts  = makeOpts $ msum (warnings config)
     (warnings, how) =
       if asError
@@ -616,7 +628,7 @@
   -> String
   -> m ()
 matchTemplate reject config context exts template submission =
   runMatchTestOn reject exts template submission $ \case
     Fail loc -> mapM_ (rejectMatch rejectWithHint config context template submission) loc
       where
         rejectWithHint = rejectWithMessage reject rejectHint
@@ -812,7 +824,7 @@
          (return . (,rawModules))
          eConfig
   where
     configJson:rawModules = splitModules False configAndModules
     eConfig :: Either ParseException SolutionConfigOpt
     eConfig = decodeEither' $ BS.pack configJson
 
@@ -943,6 +955,10 @@
   -> [m ()]
 testPhases reject inform template solutionFile modules config exts submission dirname =
   [
+    -- Reject if submission has lines violating the configured maximum line length.
+    -- Only checked if the setting is configured.
+    mapM_ (checkLineLength reject submission) $ runIdentity $ maxLineLength config
+  ,
     do
     -- Reject if submission does not compile with provided hidden modules,
     -- but without Test module.
@@ -990,3 +1006,26 @@
       Your code is not compatible with the test suite.
       Please do not change type signatures in the given code template.
       |]
+
+checkLineLength :: Applicative m => (forall a. Doc -> m a) -> String -> Natural -> m ()
+checkLineLength reject code maxLength = case hasLonger of
+  [] -> pure ()
+  xs -> rejectWithHint $ separated
+    [ "Your submission contains overlong lines:"
+    , separated xs
+    , "The maximum line length allowed is" <+> string (show maxLength) <> "."
+    ]
+  where
+    codeLines = lines code
+    hasLonger =
+      [ format i l lineLength
+      | (i, l) <- zip [1..] codeLines
+      , let lineLength = length l
+      , fromIntegral lineLength > maxLength
+      ]
+    format i l lineLength = nest 2 $ vcat
+      [ "Line" <+> int i <+> "(length" <+> int lineLength <> "):"
+      , string l
+      ]
+    separated = vcat . punctuate linebreak
+    rejectWithHint = rejectWithMessage reject rejectHint