diff --git a/run-codeworld-tasks/app/Main.hs b/run-codeworld-tasks/app/Main.hs index 134b4a7..0cb09f1 100644 --- a/run-codeworld-tasks/app/Main.hs +++ b/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 () diff --git a/run-codeworld-tasks/package.yaml b/run-codeworld-tasks/package.yaml index 5c68f64..200d0c4 100644 --- a/run-codeworld-tasks/package.yaml +++ b/run-codeworld-tasks/package.yaml @@ -16,6 +16,7 @@ dependencies: - haskell-template-task - haskell-template-task-raw - hint + - mtl - rainbow - text - wl-pprint-text diff --git a/run-codeworld-tasks/run-codeworld-tasks.cabal b/run-codeworld-tasks/run-codeworld-tasks.cabal index f7cd16f..2ea9273 100644 --- a/run-codeworld-tasks/run-codeworld-tasks.cabal +++ b/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