Showing worst lines

This commit is contained in:
Filip Gralinski 2019-12-14 18:21:47 +01:00
parent 9554b45f8a
commit fc062cbd1f
6 changed files with 94 additions and 4 deletions

View File

@ -314,7 +314,8 @@ addChallenge name publicRepoId privateRepoId deadline chan = do
challengeImage=mImage,
challengeStarred=False,
challengeArchived=Just False,
challengeVersion=commit}
challengeVersion=commit,
challengeSensitive=Just False }
_ <- runDB $ insert $ Version {
versionChallenge=Just challengeId,

View File

@ -23,6 +23,12 @@ import Data.List.Extra (groupOn)
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
import Data.Conduit.SmartSource (lookForCompressedFiles)
import GEval.Core (GEvalSpecification(..), ResultOrdering(..))
import GEval.LineByLine (runLineByLineGeneralized, LineRecord(..))
import qualified Data.Conduit.List as CL
import System.FilePath (takeFileName)
rawCommitQuery :: (MonadIO m, RawSql a) => Text -> ReaderT SqlBackend m [a]
rawCommitQuery sha1Prefix =
rawSql "SELECT ?? FROM submission WHERE is_public AND cast(commit as text) like ?" [PersistText $ "\\\\x" ++ sha1Prefix ++ "%"]
@ -223,10 +229,68 @@ paramsTable = mempty
viewOutput :: TableEntry -> [Entity Test] -> (SHA1, Text) -> WidgetFor App ()
viewOutput entry tests (outputHash, testSet) = do
let tests' = filter (\e -> (testName $ entityVal e) == testSet) tests
let tests'@(mainTest:_) = filter (\e -> (testName $ entityVal e) == testSet) tests
let outputSha1AsText = fromSHA1ToText $ outputHash
mRepoDir <- handlerToWidget $ justGetSubmissionRepoDir (entityKey $ tableEntrySubmission entry)
let variant = variantName $ entityVal $ tableEntryVariant entry
let theStamp = submissionStamp $ entityVal $ tableEntrySubmission entry
let isPublic = submissionIsPublic $ entityVal $ tableEntrySubmission entry
challenge <- handlerToWidget $ runDB $ get404 $ submissionChallenge $ entityVal $ tableEntrySubmission entry
let isNonSensitive = challengeSensitive challenge == Just False
let shouldBeShown = not ("test-" `isInfixOf` testSet) && isPublic && isNonSensitive
let mainMetric = testMetric $ entityVal mainTest
mResult <-
if shouldBeShown
then
case mRepoDir of
Just repoDir -> do
outFile' <- liftIO $ lookForCompressedFiles (repoDir </> (T.unpack variant) <.> "tsv")
let outFile = takeFileName outFile'
let spec = GEvalSpecification {
gesOutDirectory = repoDir,
gesExpectedDirectory = Nothing,
gesTestName = (T.unpack testSet),
gesSelector = Nothing,
gesOutFile = outFile,
gesExpectedFile = "expected.tsv",
gesInputFile = "in.tsv",
gesMetrics = [mainMetric],
gesPrecision = Nothing,
gesTokenizer = Nothing,
gesGonitoHost = Nothing,
gesToken = Nothing,
gesGonitoGitAnnexRemote = Nothing,
gesReferences = Nothing }
result <- liftIO $ runLineByLineGeneralized FirstTheWorst spec (\_ -> CL.take 20)
return $ Just $ zip [1..] result
Nothing -> return Nothing
else
return Nothing
$(widgetFile "view-output")
lineByLineTable :: Entity Test -> UTCTime -> Table.Table App (Int, LineRecord)
lineByLineTable (Entity testId test) theStamp = mempty
++ Table.int "#" fst
++ theLimitedTextCell "input" (((\(LineRecord inp _ _ _ _) -> inp) . snd))
++ theLimitedTextCell "expected output" ((\(LineRecord _ expected _ _ _) -> expected) . snd)
++ theLimitedTextCell "actual output" ((\(LineRecord _ _ out _ _) -> out) . snd)
++ resultCell test (fakeEvaluation . (\(LineRecord _ _ _ _ score) -> score) . snd)
where fakeEvaluation score = Just $ Evaluation {
evaluationTest = testId,
evaluationChecksum = testChecksum test,
evaluationScore = Just score,
evaluationErrorMessage = Nothing,
evaluationStamp = theStamp,
evaluationVersion = Nothing }
resultTable :: Entity Submission -> WidgetFor App ()
resultTable (Entity submissionId submission) = do
(tableEntries, tests) <- handlerToWidget

View File

@ -181,6 +181,10 @@ getSubmissionRepoDir submissionId chan = do
ExitSuccess -> return (Just repoDir)
ExitFailure _ -> return Nothing
justGetSubmissionRepoDir :: SubmissionId -> Handler (Maybe FilePath)
justGetSubmissionRepoDir submissionId = do
devNullChan <- liftIO newTChanIO
getSubmissionRepoDir submissionId devNullChan
getHeadCommit :: FilePath -> Channel -> Handler (Maybe SHA1)
getHeadCommit repoDir chan = do

View File

@ -16,7 +16,7 @@ import Database.Esqueleto ((^.))
import qualified Data.Map as Map
import Data.Text (pack, unpack, unwords)
import Data.Text (pack, unpack, unwords, take)
import PersistSHA1
@ -162,6 +162,22 @@ statusCell challengeName repoScheme challengeRepo fun = Table.widget "" (statusC
resultCell :: Test -> (a -> Maybe Evaluation) -> Table App a
resultCell test fun = hoverTextCell (formatTestForHtml test) (formatTruncatedScore (testPrecision test) . fun) (formatFullScore . fun)
textLimited :: Int -> Text -> Text
textLimited limit t
| l < limit = t
| otherwise = (Data.Text.take limit t) <> ""
where l = length t
limitedTextCell :: Text -> Int -> Int -> (a -> Text) -> Table site a
limitedTextCell h softLimit hardLimit textFun = Table.widget h (
\v -> [whamlet|<span title="#{textLimited hardLimit $ textFun v}"><tt>#{textLimited softLimit $ textFun v}</tt>|])
theLimitedTextCell :: Text -> (a -> Text) -> Table site a
theLimitedTextCell h textFun = limitedTextCell h softLimit hardLimit textFun
where softLimit = 80
hardLimit = 5 * softLimit
statusCellWidget :: Text -> RepoScheme -> Repo -> (SubmissionId, Submission, VariantId, Variant, UserId, Maybe UserId) -> WidgetFor App ()
statusCellWidget challengeName repoScheme challengeRepo (submissionId, submission, variantId, _, userId, mauthId) = do
isReevaluable <- handlerToWidget $ runDB $ canBeReevaluated submissionId

View File

@ -41,6 +41,7 @@ Challenge
starred Bool
archived Bool Maybe
version SHA1
sensitive Bool Maybe
-- challenge version
Version
-- introduced later, hence Maybe

View File

@ -6,3 +6,7 @@
<div class="media-heading">
<div .subm-commit>#{testSet} / #{outputSha1AsText}
^{Table.buildBootstrap (outputEvaluationsTable entry) tests'}
$maybe result <- mResult
<h4>worst items
^{Table.buildBootstrap (lineByLineTable mainTest theStamp) result}
$nothing