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, challengeImage=mImage,
challengeStarred=False, challengeStarred=False,
challengeArchived=Just False, challengeArchived=Just False,
challengeVersion=commit} challengeVersion=commit,
challengeSensitive=Just False }
_ <- runDB $ insert $ Version { _ <- runDB $ insert $ Version {
versionChallenge=Just challengeId, versionChallenge=Just challengeId,

View File

@ -23,6 +23,12 @@ import Data.List.Extra (groupOn)
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3) 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 :: (MonadIO m, RawSql a) => Text -> ReaderT SqlBackend m [a]
rawCommitQuery sha1Prefix = rawCommitQuery sha1Prefix =
rawSql "SELECT ?? FROM submission WHERE is_public AND cast(commit as text) like ?" [PersistText $ "\\\\x" ++ sha1Prefix ++ "%"] rawSql "SELECT ?? FROM submission WHERE is_public AND cast(commit as text) like ?" [PersistText $ "\\\\x" ++ sha1Prefix ++ "%"]
@ -222,11 +228,69 @@ paramsTable = mempty
++ Table.text "Value" parameterValue ++ Table.text "Value" parameterValue
viewOutput :: TableEntry -> [Entity Test] -> (SHA1, Text) -> WidgetFor App () viewOutput :: TableEntry -> [Entity Test] -> (SHA1, Text) -> WidgetFor App ()
viewOutput entry tests (outputHash, testSet) = do 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 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") $(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 Submission -> WidgetFor App ()
resultTable (Entity submissionId submission) = do resultTable (Entity submissionId submission) = do
(tableEntries, tests) <- handlerToWidget (tableEntries, tests) <- handlerToWidget

View File

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

View File

@ -16,7 +16,7 @@ import Database.Esqueleto ((^.))
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Text (pack, unpack, unwords) import Data.Text (pack, unpack, unwords, take)
import PersistSHA1 import PersistSHA1
@ -162,6 +162,22 @@ statusCell challengeName repoScheme challengeRepo fun = Table.widget "" (statusC
resultCell :: Test -> (a -> Maybe Evaluation) -> Table App a resultCell :: Test -> (a -> Maybe Evaluation) -> Table App a
resultCell test fun = hoverTextCell (formatTestForHtml test) (formatTruncatedScore (testPrecision test) . fun) (formatFullScore . fun) 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 :: Text -> RepoScheme -> Repo -> (SubmissionId, Submission, VariantId, Variant, UserId, Maybe UserId) -> WidgetFor App ()
statusCellWidget challengeName repoScheme challengeRepo (submissionId, submission, variantId, _, userId, mauthId) = do statusCellWidget challengeName repoScheme challengeRepo (submissionId, submission, variantId, _, userId, mauthId) = do
isReevaluable <- handlerToWidget $ runDB $ canBeReevaluated submissionId isReevaluable <- handlerToWidget $ runDB $ canBeReevaluated submissionId

View File

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

View File

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