diff --git a/cli/CLI/Submit.hs b/cli/CLI/Submit.hs index 076aa1af..56c41784 100644 --- a/cli/CLI/Submit.hs +++ b/cli/CLI/Submit.hs @@ -14,6 +14,8 @@ import Core.Generator.Splitmix (SplitmixGenerator (SplitmixGenerator)) import Core.Test.Loader (loadTestSuite) import Core.Test.Runner ( SolutionBatch (SolutionBatch, entryMain, python3Utilities, sbLang, sbTimeout, solution, utilities), + TestCaseResult (tcrIdx, tcrInput, tcrResult), + TestInput (TestInput), TestResult (Internal, Pass, RE, TLE, WA), runSuiteWithProgress, ) @@ -140,15 +142,18 @@ executeSubmit ui resolved = do Left exc -> failSubmitStep runningChecklist (classifySuiteException exc) Right results -> - case find (\(_, res) -> case res of Pass _ -> False; _ -> True) results of - Just (idx, verdict) -> - failSubmitStep runningChecklist $ - case verdict of - Internal msg - | isOracleExecutionMessage msg -> SubmitInternalWhileJudging (Just idx) (stripOracleExecutionPrefix msg) - | otherwise -> SubmitJudgeInternal (Just idx) (stripOracleExecutionPrefix msg) - _ -> SubmitVerdict idx verdict - Nothing -> pure (Right (sum [t | (_, Pass t) <- results])) + case find (\caseResult -> case tcrResult caseResult of Pass _ -> False; _ -> True) results of + Just failedCase -> + let idx = tcrIdx failedCase + input = tcrInput failedCase + verdict = tcrResult failedCase + in failSubmitStep runningChecklist $ + case verdict of + Internal msg + | isOracleExecutionMessage msg -> SubmitInternalWhileJudging (Just idx) (Just input) (stripOracleExecutionPrefix msg) + | otherwise -> SubmitJudgeInternal (Just idx) (Just input) (stripOracleExecutionPrefix msg) + _ -> SubmitVerdict idx input verdict + Nothing -> pure (Right (sum [t | Pass t <- map tcrResult results])) loadRuntimeTemplates :: FilePath -> Language -> IO (Either SubmitFailure (Text, Text, Text)) loadRuntimeTemplates root lang = do @@ -311,26 +316,29 @@ renderSubmitFailure ui failure = case failure of SubmitBackendUnavailable backendUrl -> do renderErrorHeader ui "submit" ("Backend is not reachable: " ++ T.unpack backendUrl) emitDetail ui "submit" "Check `openleetcode config list` and your backend service" - SubmitJudgeInternal maybeIdx msg -> do + SubmitJudgeInternal maybeIdx maybeInput msg -> do renderErrorHeader ui "submit" $ case maybeIdx of Just idx -> "Judge internal error on test #" ++ show idx Nothing -> "Judge internal error" emitDetail ui "submit" (" " ++ T.unpack msg) - SubmitInternalWhileJudging maybeIdx msg -> do + renderMaybeVerdictInput ui "submit" maybeInput + SubmitInternalWhileJudging maybeIdx maybeInput msg -> do renderErrorHeader ui "submit" $ case maybeIdx of Just idx -> "Internal error while judging test #" ++ show idx Nothing -> "Internal error while judging" emitDetail ui "submit" (" " ++ T.unpack msg) + renderMaybeVerdictInput ui "submit" maybeInput SubmitInfraFailure msg -> renderErrorHeader ui "submit" ("Internal error: " ++ T.unpack msg) - SubmitVerdict idx verdict -> renderVerdict ui idx verdict + SubmitVerdict idx input verdict -> renderVerdict ui idx input verdict -renderVerdict :: UI -> Int -> TestResult -> IO () -renderVerdict ui idx verdict = case verdict of +renderVerdict :: UI -> Int -> TestInput -> TestResult -> IO () +renderVerdict ui idx input verdict = case verdict of WA expected got out -> do renderVerdictHeader ui "wa" ("Wrong answer on test #" ++ show idx) + renderVerdictInput ui "wa" input emitVerdictDetail ui "wa" (" Output: " ++ T.unpack got) emitVerdictDetail ui "wa" (" Expected: " ++ T.unpack (fromMaybe "Multiple valid outputs allowed" expected)) if T.null out @@ -340,6 +348,7 @@ renderVerdict ui idx verdict = case verdict of emitVerdictDetail ui "wa" (T.unpack out) TLE out -> do renderVerdictHeader ui "tle" ("Time limit exceeded on test #" ++ show idx) + renderVerdictInput ui "tle" input if T.null out then pure () else do @@ -347,6 +356,7 @@ renderVerdict ui idx verdict = case verdict of emitVerdictDetail ui "tle" (T.unpack out) RE err out -> do renderVerdictHeader ui "re" ("Runtime error on test #" ++ show idx) + renderVerdictInput ui "re" input emitVerdictDetail ui "re" (" " ++ T.unpack err) if T.null out then pure () @@ -355,9 +365,31 @@ renderVerdict ui idx verdict = case verdict of emitVerdictDetail ui "re" (T.unpack out) Internal msg -> do renderErrorHeader ui "submit" ("Judge internal error on test #" ++ show idx) + renderVerdictInput ui "submit" input emitDetail ui "submit" (" " ++ T.unpack (stripOracleExecutionPrefix msg)) Pass _ -> pure () +renderMaybeVerdictInput :: UI -> String -> Maybe TestInput -> IO () +renderMaybeVerdictInput _ _ Nothing = pure () +renderMaybeVerdictInput ui verdictTag (Just input) = renderVerdictInput ui verdictTag input + +renderVerdictInput :: UI -> String -> TestInput -> IO () +renderVerdictInput ui verdictTag (TestInput vars) = do + emitVerdictDetail ui verdictTag " Input:" + case vars of + [] -> emitVerdictDetail ui verdictTag " " + _ -> mapM_ renderVar vars + where + renderVar (name, value) = + emitVerdictDetail ui verdictTag (" " ++ T.unpack name ++ ": " ++ T.unpack (truncateInputValue value)) + +truncateInputValue :: Text -> Text +truncateInputValue value + | T.length value <= inputValuePreviewLimit = value + | otherwise = T.take inputValuePreviewLimit value <> "..." + where + inputValuePreviewLimit = 200 + renderErrorHeader :: UI -> String -> String -> IO () renderErrorHeader ui scope msg = case uiMode ui of Rich -> putErrorLine ui (T.pack msg) @@ -386,15 +418,15 @@ submitFailureExitCode failure = case failure of SubmitSuiteNotFoundById _ -> renderExitCode ExitInput SubmitSuiteNotFoundByTitle _ -> renderExitCode ExitInput SubmitBackendUnavailable _ -> renderExitCode ExitInfra - SubmitInternalWhileJudging _ _ -> renderExitCode ExitInfra - SubmitJudgeInternal _ _ -> renderExitCode ExitInfra + SubmitInternalWhileJudging _ _ _ -> renderExitCode ExitInfra + SubmitJudgeInternal _ _ _ -> renderExitCode ExitInfra SubmitInfraFailure _ -> renderExitCode ExitInfra - SubmitVerdict _ _ -> renderExitCode ExitVerdict + SubmitVerdict _ _ _ -> renderExitCode ExitVerdict classifySuiteException :: SomeException -> SubmitFailure classifySuiteException exc = if "Oracle execution error:" `isInfixOf` shown - then SubmitInternalWhileJudging Nothing (stripOracleExecutionPrefix (T.pack shown)) + then SubmitInternalWhileJudging Nothing Nothing (stripOracleExecutionPrefix (T.pack shown)) else SubmitInfraFailure (classifyException exc) where shown = show exc diff --git a/cli/CLI/SubmitPipeline.hs b/cli/CLI/SubmitPipeline.hs index cef7ff3f..1653f78c 100644 --- a/cli/CLI/SubmitPipeline.hs +++ b/cli/CLI/SubmitPipeline.hs @@ -1,7 +1,7 @@ module CLI.SubmitPipeline where import CLI.AppEnv (Config) -import Core.Test.Runner (SolutionBatch, TestResult) +import Core.Test.Runner (SolutionBatch, TestInput, TestResult) import Core.Test.Types (TestSuite) import Core.Types (Language) import Data.Text (Text) @@ -20,8 +20,8 @@ data SubmitFailure | SubmitSuiteNotFoundById Int | SubmitSuiteNotFoundByTitle Text | SubmitBackendUnavailable Text - | SubmitInternalWhileJudging (Maybe Int) Text - | SubmitJudgeInternal (Maybe Int) Text + | SubmitInternalWhileJudging (Maybe Int) (Maybe TestInput) Text + | SubmitJudgeInternal (Maybe Int) (Maybe TestInput) Text | SubmitInfraFailure Text - | SubmitVerdict Int TestResult + | SubmitVerdict Int TestInput TestResult deriving (Eq, Show) diff --git a/core/Core/Test/Runner.hs b/core/Core/Test/Runner.hs index c331ec79..62051fac 100644 --- a/core/Core/Test/Runner.hs +++ b/core/Core/Test/Runner.hs @@ -25,6 +25,15 @@ import Data.Text qualified as T import Data.Text.Encoding qualified as TE import Data.Vector qualified as V +newtype TestInput = TestInput [(Text, Text)] deriving (Show, Eq) + +data TestCaseResult = TestCaseResult + { tcrIdx :: Int, + tcrInput :: TestInput, + tcrResult :: TestResult + } + deriving (Show, Eq) + data TestResult = Pass Int | WA (Maybe Text) Text Text | TLE Text | RE Text Text | Internal Text deriving (Show, Eq) data SolutionBatch = SolutionBatch {entryMain :: Text, sbLang :: Language, solution :: Text, utilities :: Text, python3Utilities :: Text, sbTimeout :: Int} @@ -35,6 +44,7 @@ data PreparedCase = PreparedCase pcExpected :: Maybe Text, pcPrelude :: [Text], pcJsonInputs :: M.Map Text Value, + pcInput :: TestInput, pcMainCall :: Text, pcOracleCall :: Maybe Text } @@ -51,7 +61,7 @@ runSuite :: g -> SolutionBatch -> Types.TestSuite -> - IO [(Int, TestResult)] + IO [TestCaseResult] runSuite exec gen batch suite = runSuiteWithProgress exec gen batch suite (\_ _ -> pure ()) runSuiteWithProgress :: @@ -61,12 +71,12 @@ runSuiteWithProgress :: SolutionBatch -> Types.TestSuite -> (Int -> Int -> IO ()) -> - IO [(Int, TestResult)] + IO [TestCaseResult] runSuiteWithProgress exec gen batch suite onProgress = do let preparedCases = zipWith (prepareCase gen batch (Types.tsSeed suite) suite) [1 ..] (Types.tsCases suite) - mainOutputsOrExc <- try (runMainBatch exec batch suite preparedCases) :: IO (Either SomeException (Either (Int, TestResult) (M.Map Int MainCaseOutput))) + mainOutputsOrExc <- try (runMainBatch exec batch suite preparedCases) :: IO (Either SomeException (Either TestCaseResult (M.Map Int MainCaseOutput))) case mainOutputsOrExc of - Left exc -> pure [(1, Internal (T.pack (displayException exc)))] + Left exc -> pure [caseResultForIdx preparedCases 1 (Internal (T.pack (displayException exc)))] Right (Left failed) -> pure [failed] Right (Right mainOutputs) -> do oracleOutputsOrExc <- try (runOracleBatch exec gen batch suite preparedCases mainOutputs) :: IO (Either SomeException (M.Map Int Bool)) @@ -77,7 +87,7 @@ runSuiteWithProgress exec gen batch suite onProgress = do results <- mapM (evaluateCase timeLimit oracleFailure oracleOutputs mainOutputs) preparedCases mapM_ (`onProgress` total) [1 .. total] pure $ - case Data.List.find (\(_, res) -> case res of Pass _ -> False; _ -> True) results of + case Data.List.find (\result -> case tcrResult result of Pass _ -> False; _ -> True) results of Just failed -> [failed] Nothing -> results @@ -130,6 +140,7 @@ prepareCase gen batch sSeed suite idx test = cases mainCall = foldl (\acc (var, _) -> T.replace ("{" <> var <> "}") (jsonVarName idx var) acc) callStr (M.toList entryParams) jsonInputs = buildJsonInputs gen seed entryParams test + input = buildTestInput test jsonInputs prelude = buildParamPrelude lang idx entryParams oracleCall = case Types.tcOut test of @@ -147,6 +158,7 @@ prepareCase gen batch sSeed suite idx test = Nothing -> Nothing, pcPrelude = prelude, pcJsonInputs = jsonInputs, + pcInput = input, pcMainCall = mainCall, pcOracleCall = oracleCall } @@ -157,7 +169,7 @@ runMainBatch :: SolutionBatch -> Types.TestSuite -> [PreparedCase] -> - IO (Either (Int, TestResult) (M.Map Int MainCaseOutput)) + IO (Either TestCaseResult (M.Map Int MainCaseOutput)) runMainBatch exec batch suite cases = do response <- C.execute @@ -176,9 +188,9 @@ runMainBatch exec batch suite cases = do inferMainBatchFailure idx status err stdout = let out = T.unlines (filter (not . T.isPrefixOf "SOL_CASE_") (T.lines stdout)) in case status of - C.TLE -> (idx, TLE out) - C.RE -> (idx, RE (T.strip err) out) - C.Unknown _ -> (idx, Internal (renderExecError status err)) + C.TLE -> caseResultForIdx cases idx (TLE out) + C.RE -> caseResultForIdx cases idx (RE (T.strip err) out) + C.Unknown _ -> caseResultForIdx cases idx (Internal (renderExecError status err)) case response of C.ExecFail err stdout s -> pure (Left (inferMainBatchFailure (inferFailedCaseIndex stdout) s err stdout)) @@ -222,29 +234,46 @@ evaluateCase :: M.Map Int Bool -> M.Map Int MainCaseOutput -> PreparedCase -> - IO (Int, TestResult) + IO TestCaseResult evaluateCase timeLimit oracleFailure oracleOutputs mainOutputs pc = let out = fromJust (M.lookup (pcIdx pc) mainOutputs) in if mcoTimeMs out > timeLimit - then pure (pcIdx pc, TLE (T.unlines (filter (not . T.isPrefixOf "SOL_CASE_") (T.lines (mcoStdout out))))) + then pure (caseResult pc (TLE (T.unlines (filter (not . T.isPrefixOf "SOL_CASE_") (T.lines (mcoStdout out)))))) else case pcExpected pc of Just expected -> let res = judge (pcJudge pc) expected (mcoResult out) in pure $ case res of - J.Pass -> (pcIdx pc, Pass (mcoTimeMs out)) - J.Fail _ -> (pcIdx pc, WA (Just expected) (mcoResult out) (T.unlines (filter (not . T.isPrefixOf "SOL_CASE_") (T.lines (mcoStdout out))))) + J.Pass -> caseResult pc (Pass (mcoTimeMs out)) + J.Fail _ -> caseResult pc (WA (Just expected) (mcoResult out) (T.unlines (filter (not . T.isPrefixOf "SOL_CASE_") (T.lines (mcoStdout out))))) Nothing -> case oracleFailure of - Just msg -> pure (pcIdx pc, Internal msg) + Just msg -> pure (caseResult pc (Internal msg)) Nothing -> ( if fromJust (M.lookup (pcIdx pc) oracleOutputs) then - pure (pcIdx pc, Pass (mcoTimeMs out)) + pure (caseResult pc (Pass (mcoTimeMs out))) else - pure (pcIdx pc, WA Nothing (mcoResult out) (T.unlines (filter (not . T.isPrefixOf "SOL_CASE_") (T.lines (mcoStdout out))))) + pure (caseResult pc (WA Nothing (mcoResult out) (T.unlines (filter (not . T.isPrefixOf "SOL_CASE_") (T.lines (mcoStdout out)))))) ) +caseResultForIdx :: [PreparedCase] -> Int -> TestResult -> TestCaseResult +caseResultForIdx cases idx result = + case Data.List.find ((== idx) . pcIdx) cases of + Just pc -> caseResult pc result + Nothing -> TestCaseResult idx (TestInput []) result + +caseResult :: PreparedCase -> TestResult -> TestCaseResult +caseResult pc = TestCaseResult (pcIdx pc) (pcInput pc) + +buildTestInput :: Types.TestCase -> M.Map Text Value -> TestInput +buildTestInput test jsonInputs = + TestInput $ map buildInputVar (Types.tcIn test) + where + buildInputVar (name, _) = + let val = fromJust (M.lookup name jsonInputs) + in (name, TE.decodeUtf8 (BL.toStrict (encode val))) + buildMainProgram :: SolutionBatch -> [PreparedCase] -> Text buildMainProgram batch cases = buildProgramTemplate (sbLang batch) (entryMain batch) (solution batch) (utilities batch) snippets