diff --git a/Handler/CreateChallenge.hs b/Handler/CreateChallenge.hs index 979ce6d..20d50e0 100644 --- a/Handler/CreateChallenge.hs +++ b/Handler/CreateChallenge.hs @@ -119,7 +119,8 @@ checkTestDir chan challengeId challenge commit testDir = do testName=T.pack $ takeFileName testDir, testChecksum=(SHA1 checksum), testCommit=commit, - testActive=True } + testActive=True, + testPrecision=Nothing } return () else msg chan $ concat ["Test dir ", (T.pack testDir), " does not have expected results."] diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index b4ff338..08025e9 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -33,10 +33,10 @@ getShowChallengeR :: Text -> Handler Html getShowChallengeR name = do (Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name Just repo <- runDB $ get $ challengePublicRepo challenge - leaderboard <- getLeaderboardEntries challengeId + (mainTest, leaderboard) <- getLeaderboardEntries challengeId mauth <- maybeAuth let muserId = (\(Entity uid _) -> uid) <$> mauth - challengeLayout True challenge (showChallengeWidget muserId challenge repo leaderboard) + challengeLayout True challenge (showChallengeWidget muserId challenge mainTest repo leaderboard) getChallengeReadmeR :: Text -> Handler Html getChallengeReadmeR name = do @@ -47,7 +47,7 @@ getChallengeReadmeR name = do contents <- readFile readmeFilePath challengeLayout False challenge $ toWidget $ markdown def $ TL.fromStrict contents -showChallengeWidget muserId challenge repo leaderboard = $(widgetFile "show-challenge") +showChallengeWidget muserId challenge test repo leaderboard = $(widgetFile "show-challenge") where leaderboardWithRanks = zip [1..] leaderboard leaderboardWithRanksAndCurrentUser = map (\e -> (e, muserId)) leaderboardWithRanks maybeRepoLink = getRepoLink repo diff --git a/Handler/Tables.hs b/Handler/Tables.hs index 4e3b933..76cebbf 100644 --- a/Handler/Tables.hs +++ b/Handler/Tables.hs @@ -21,6 +21,8 @@ import PersistSHA1 import GEval.Core +import Text.Printf + data LeaderboardEntry = LeaderboardEntry { leaderboardUser :: User, leaderboardUserId :: UserId, @@ -35,16 +37,20 @@ submissionsTable challengeName tests = mempty ++ Table.text "submitter" (formatSubmitter . (\(_, Entity _ submitter, _) -> submitter) . fst) ++ timestampCell "when" (submissionStamp . (\(Entity _ s, _, _) -> s) . fst) ++ Table.text "description" (submissionDescription . (\(Entity _ s, _, _) -> s) . fst) - ++ mconcat (map (\(Entity k t) -> Table.string (testName t) ((submissionScore k) . fst)) tests) +-- ++ mconcat (map (\(Entity k t) -> Table.string (testName t) ((submissionScore k t) . fst)) tests) + ++ mconcat (map (\(Entity k t) -> resultCell t ((extractScore k) . fst)) tests) ++ statusCell challengeName (\((Entity submissionId submission, Entity userId _, _), mauthId) -> (submissionId, submission, userId, mauthId)) -leaderboardTable :: Text -> Table App ((Int, LeaderboardEntry), Maybe UserId) -leaderboardTable challengeName = mempty +extractScore :: Key Test -> (Entity Submission, Entity User, Map (Key Test) Evaluation) -> Maybe Evaluation +extractScore k (_, _, m) = lookup k m + +leaderboardTable :: Text -> Test -> Table App ((Int, LeaderboardEntry), Maybe UserId) +leaderboardTable challengeName test = mempty ++ Table.int "#" (fst . fst) ++ Table.text "submitter" (formatSubmitter . leaderboardUser . snd . fst) ++ timestampCell "when" (submissionStamp . leaderboardBestSubmission . snd . fst) ++ Table.text "description" (submissionDescription . leaderboardBestSubmission . snd . fst) - ++ Table.string "result" (presentScore . leaderboardEvaluation . snd . fst) + ++ resultCell test ((\e -> Just e) . leaderboardEvaluation . snd . fst) ++ Table.int "×" (leaderboardNumberOfSubmissions . snd . fst) ++ statusCell challengeName (\((_, e), mauthId) -> (leaderboardBestSubmissionId e, leaderboardBestSubmission e, @@ -63,6 +69,21 @@ timestampCell h timestampFun = hoverTextCell h (Data.Text.pack . shorterFormat . statusCell :: Text -> (a -> (SubmissionId, Submission, UserId, Maybe UserId)) -> Table App a statusCell challengeName fun = Table.widget "" (statusCellWidget challengeName . fun) +resultCell :: Test -> (a -> Maybe Evaluation) -> Table App a +resultCell test fun = hoverTextCell ((testName test) ++ "/" ++ (Data.Text.pack $ show $ testMetric test)) (formatTruncatedScore (testPrecision test) . fun) (formatFullScore . fun) + +formatFullScore :: Maybe Evaluation -> Text +formatFullScore (Just evaluation) = fromMaybe "???" (Data.Text.pack <$> show <$> evaluationScore evaluation) +formatFullScore Nothing = "N/A" + +formatTruncatedScore :: Maybe Int -> Maybe Evaluation -> Text +formatTruncatedScore Nothing e = formatFullScore e +formatTruncatedScore _ Nothing = formatFullScore Nothing +formatTruncatedScore (Just precision) (Just evaluation) = case evaluationScore evaluation of + Just score -> Data.Text.pack $ printf "%0.*f" precision score + Nothing -> formatFullScore Nothing + + statusCellWidget challengeName (submissionId, submission, userId, mauthId) = $(widgetFile "submission-status") where commitHash = fromSHA1ToText $ submissionCommit submission isPublic = submissionIsPublic submission @@ -94,7 +115,7 @@ getAuxSubmissionEnts testId evaluationMaps = map (processEvaluationMap testId) e -getLeaderboardEntries :: Key Challenge -> Handler [LeaderboardEntry] +getLeaderboardEntries :: Key Challenge -> Handler (Test, [LeaderboardEntry]) getLeaderboardEntries challengeId = do (evaluationMaps, tests) <- getChallengeSubmissionInfos (\_ -> True) challengeId let mainTestEnt = getMainTest tests @@ -103,7 +124,7 @@ getLeaderboardEntries challengeId = do let submissionsByUser = Map.fromListWith (\(u1, l1) (_, l2) -> (u1, l1++l2)) auxSubmissions let entryComparator a b = (compareResult mainTest) (evaluationScore $ leaderboardEvaluation a) (evaluationScore $ leaderboardEvaluation b) let entries = sortBy (flip entryComparator) $ map (toEntry mainTest) $ filter (\(_, (_, s)) -> not (null s)) $ Map.toList submissionsByUser - return entries + return (mainTest, entries) where submissionComparator mainTest (_, e1) (_, e2) = (compareResult mainTest) (evaluationScore e1) (evaluationScore e2) toEntry mainTest (ui, (u, ss)) = LeaderboardEntry { leaderboardUser = u, @@ -151,8 +172,8 @@ formatSubmitter user = if userIsAnonymous user Just name -> name Nothing -> "[name not given]" -submissionScore :: Key Test -> (Entity Submission, Entity User, Map (Key Test) Evaluation) -> String -submissionScore k (_, _, m) = fromMaybe "N/A" (presentScore <$> lookup k m) +submissionScore :: Key Test -> Test -> (Entity Submission, Entity User, Map (Key Test) Evaluation) -> String +submissionScore k t (_, _, m) = fromMaybe "N/A" (presentScore t <$> lookup k m) -presentScore :: Evaluation -> String -presentScore evaluation = fromMaybe "???" (show <$> evaluationScore evaluation) +presentScore :: Test -> Evaluation -> String +presentScore test evaluation = fromMaybe "???" (show <$> evaluationScore evaluation) diff --git a/config/models b/config/models index c4de368..6fbb4c8 100644 --- a/config/models +++ b/config/models @@ -39,6 +39,7 @@ Test checksum SHA1 commit SHA1 active Bool default=True + precision Int Maybe UniqueChallengeNameChecksum challenge name checksum Submission repo RepoId diff --git a/templates/show-challenge.hamlet b/templates/show-challenge.hamlet index 267c5f1..46aaadb 100644 --- a/templates/show-challenge.hamlet +++ b/templates/show-challenge.hamlet @@ -5,7 +5,7 @@ $nothing

Leaderboard -^{Table.buildBootstrap (leaderboardTable (challengeName challenge)) leaderboardWithRanksAndCurrentUser} +^{Table.buildBootstrap (leaderboardTable (challengeName challenge) test) leaderboardWithRanksAndCurrentUser}