differentiate feedback types

run-codeworld-tasks/app/Main.hs

@@ -7,6 +7,15 @@ import qualified Data.Text              as T
 import qualified Data.Text.Lazy         as LT
 
 import Control.Monad                    (void)
+import Control.Monad.Except (
+  ExceptT,
+  runExceptT,
+  throwError,
+  withExceptT,
+  )
+import Control.Monad.IO.Class
+import Data.Char                        (toUpper)
+import Data.String                      (fromString)
 import Data.Text                        (Text)
 import Data.Text.Lazy.Builder           (toLazyText)
 import Haskell.Template.Task            (grade)
@@ -25,6 +34,7 @@ import Rainbow (
   green,
   red,
   yellow,
+  putChunk,
   putChunkLn,
   )
 import System.Directory                 (getTemporaryDirectory)
@@ -59,6 +69,10 @@ suggestionStyle = bold . fore brightYellow . chunk
 
 data Mode = Submission | Solution
 
+data Rejection = Syntax | Semantics | Unknown deriving (Show)
+
+type Output = ExceptT Rejection IO
+
 
 instance Read Mode where
   readPrec = lift $ do
@@ -81,24 +95,37 @@ main = do
         (openFileInDir . modeToDir)
         $ readMaybe subMode
       runTemplateTask taskContents submissionContents
-      exitSuccess
     _              -> usage
 
 
 runTemplateTask :: String -> String -> IO ()
 runTemplateTask task submission = do
   tmp <- getTemporaryDirectory
-  grade
-    id
-    id
+  result <- runExceptT $ grade
+    syntax
+    semantics
     rejection
     suggestion
     tmp
     task
     submission
-  putChunkLn $ bold $ fore green "Your submission passed!"
-  emptyLine
-  putChunkLn $ statusLabel green "SUCCESS"
+  case result of
+    Right () -> do
+      putChunkLn $ bold $ fore green "Your submission passed!"
+      emptyLine
+      putChunkLn $ statusLabel green "SUCCESS"
+      exitSuccess
+    Left reason -> do
+      putChunkLn $ statusLabel red $ fromString $ map toUpper $ show reason
+      exitFailure
+
+
+syntax :: Output () -> Output ()
+syntax = withExceptT $ const Syntax
+
+
+semantics :: Output () -> Output ()
+semantics = withExceptT $ const Semantics
 
 
 modeToDir :: Mode -> FilePath
@@ -140,22 +167,23 @@ styleCommon t
   | otherwise = bold $ chunk t
 
 
-suggestion :: Doc -> IO ()
-suggestion doc = do
+suggestion :: Doc -> Output ()
+suggestion doc = liftIO $ do
   putChunkLn $ statusLabel yellow "SUGGESTION:"
   emptyLine
   unlinesChunks $ map styleSuggestions $ toLines doc
   emptyLine
 
 
-rejection :: Doc -> IO a
+rejection :: Doc -> Output a
 rejection doc = do
-  putChunkLn $ statusLabel red "ERROR:"
-  emptyLine
-  unlinesChunks $ map styleRejections $ toLines doc
-  emptyLine
-  putChunkLn $ statusLabel red "REJECTED"
-  exitFailure
+  liftIO $ do
+    putChunkLn $ statusLabel red "ERROR:"
+    emptyLine
+    unlinesChunks $ map styleRejections $ toLines doc
+    emptyLine
+    putChunk $ statusLabel red "REJECTED DUE TO: "
+  throwError Unknown
 
 
 emptyLine :: IO ()

run-codeworld-tasks/package.yaml

@@ -16,6 +16,7 @@ dependencies:
   - haskell-template-task
   - haskell-template-task-raw
   - hint
+  - mtl
   - rainbow
   - text
   - wl-pprint-text

run-codeworld-tasks/run-codeworld-tasks.cabal

@@ -38,6 +38,7 @@ executable test-task
     , haskell-template-task
     , haskell-template-task-raw
     , hint
+    , mtl
     , rainbow
     , random
     , syb