gonito/Handler/Tables.hs

180 lines
8.8 KiB
Haskell
Raw Normal View History

2015-12-12 18:53:20 +01:00
{-# LANGUAGE ScopedTypeVariables #-}
module Handler.Tables where
import Import
2016-02-16 21:26:57 +01:00
import Handler.Shared
2017-02-25 22:53:17 +01:00
import Handler.SubmissionView
2017-03-18 15:57:27 +01:00
import Handler.TagUtils
2015-12-12 18:53:20 +01:00
import qualified Yesod.Table as Table
import Yesod.Table (Table)
import qualified Data.Map as Map
import qualified Data.List as DL
2016-02-16 19:00:26 +01:00
import Data.Text (pack)
2016-02-16 21:10:10 +01:00
import PersistSHA1
2015-12-12 18:53:20 +01:00
import GEval.Core
2016-02-17 09:34:34 +01:00
import Text.Printf
2015-12-12 18:53:20 +01:00
data LeaderboardEntry = LeaderboardEntry {
leaderboardUser :: User,
2016-02-16 21:10:10 +01:00
leaderboardUserId :: UserId,
2015-12-12 18:53:20 +01:00
leaderboardBestSubmission :: Submission,
2016-02-16 21:10:10 +01:00
leaderboardBestSubmissionId :: SubmissionId,
2015-12-12 18:53:20 +01:00
leaderboardEvaluation :: Evaluation,
2017-03-18 15:57:27 +01:00
leaderboardNumberOfSubmissions :: Int,
leaderboardTags :: [Entity Tag]
2015-12-12 18:53:20 +01:00
}
2017-02-25 22:53:17 +01:00
submissionsTable :: Maybe UserId -> Text -> [Entity Test] -> Table App (Entity Submission, Entity User, Map (Key Test) Evaluation, [Entity Tag])
2016-02-17 09:43:25 +01:00
submissionsTable mauthId challengeName tests = mempty
2017-02-25 22:53:17 +01:00
++ Table.text "submitter" (formatSubmitter . (\(_, Entity _ submitter, _, _) -> submitter))
++ timestampCell "when" (submissionStamp . (\(Entity _ s, _, _, _) -> s))
++ descriptionCell
2016-02-17 09:43:25 +01:00
++ mconcat (map (\(Entity k t) -> resultCell t (extractScore k)) tests)
2017-02-25 22:53:17 +01:00
++ statusCell challengeName (\(Entity submissionId submission, Entity userId _, _, _) -> (submissionId, submission, userId, mauthId))
descriptionCell = Table.widget "description" (
2017-03-18 15:57:27 +01:00
\(Entity _ s, _, _ ,tagEnts) -> fragmentWithTags (submissionDescription s) tagEnts)
2017-02-25 22:53:17 +01:00
extractScore :: Key Test -> (Entity Submission, Entity User, Map (Key Test) Evaluation, [Entity Tag]) -> Maybe Evaluation
extractScore k (_, _, m, _) = lookup k m
2016-02-17 09:34:34 +01:00
2016-02-17 09:43:25 +01:00
leaderboardTable :: Maybe UserId -> Text -> Test -> Table App (Int, LeaderboardEntry)
leaderboardTable mauthId challengeName test = mempty
++ Table.int "#" fst
++ Table.text "submitter" (formatSubmitter . leaderboardUser . snd)
++ timestampCell "when" (submissionStamp . leaderboardBestSubmission . snd)
2017-03-18 15:57:27 +01:00
++ leaderboardDescriptionCell
2016-02-17 09:43:25 +01:00
++ resultCell test ((\e -> Just e) . leaderboardEvaluation . snd)
++ Table.int "×" (leaderboardNumberOfSubmissions . snd)
++ statusCell challengeName (\(_, e) -> (leaderboardBestSubmissionId e,
2016-02-16 21:10:10 +01:00
leaderboardBestSubmission e,
leaderboardUserId e,
mauthId))
2015-12-12 18:53:20 +01:00
2017-03-18 15:57:27 +01:00
leaderboardDescriptionCell = Table.widget "description" (
\(_,entry) -> fragmentWithTags (submissionDescription $ leaderboardBestSubmission entry) (leaderboardTags entry))
2016-02-11 21:54:22 +01:00
2016-02-16 19:00:26 +01:00
hoverTextCell :: Text -> (a -> Text) -> (a -> Text) -> Table site a
hoverTextCell h mainTextFun hoverTextFun = Table.widget h (
\v -> [whamlet|<span title="#{hoverTextFun v}">#{mainTextFun v}|])
timestampCell :: Text -> (a -> UTCTime) -> Table site a
timestampCell h timestampFun = hoverTextCell h (Data.Text.pack . shorterFormat . timestampFun) (Data.Text.pack . show . timestampFun)
where shorterFormat = formatTime defaultTimeLocale "%Y-%m-%d %H:%M"
2016-02-16 21:26:57 +01:00
statusCell :: Text -> (a -> (SubmissionId, Submission, UserId, Maybe UserId)) -> Table App a
statusCell challengeName fun = Table.widget "" (statusCellWidget challengeName . fun)
2016-02-16 21:10:10 +01:00
2016-02-17 09:34:34 +01:00
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
2016-02-16 21:26:57 +01:00
statusCellWidget challengeName (submissionId, submission, userId, mauthId) = $(widgetFile "submission-status")
2016-02-16 21:10:10 +01:00
where commitHash = fromSHA1ToText $ submissionCommit submission
isPublic = submissionIsPublic submission
isOwner = (mauthId == Just userId)
isVisible = isPublic || isOwner
2016-02-16 21:26:57 +01:00
publicSubmissionBranch = getPublicSubmissionBranch submissionId
maybeBrowsableUrl = if isPublic
then
Just $ browsableGitRepoBranch challengeName publicSubmissionBranch
else
Nothing
2016-02-16 21:10:10 +01:00
2016-02-11 21:54:22 +01:00
getMainTest :: [Entity Test] -> Entity Test
getMainTest tests = DL.maximumBy (\(Entity _ a) (Entity _ b) -> ((testName a) `compare` (testName b))) tests
getAuxSubmissions :: Key Test -> [(Entity Submission, Entity User, Map (Key Test) Evaluation)] -> [(Key User, (User, [(Submission, Evaluation)]))]
getAuxSubmissions testId evaluationMaps = map (processEvaluationMap testId) evaluationMaps
where processEvaluationMap testId ((Entity _ s), (Entity ui u), m) = (ui, (u, case Map.lookup testId m of
Just e -> [(s, e)]
Nothing -> []))
2016-02-12 23:21:26 +01:00
2017-02-25 22:53:17 +01:00
getAuxSubmissionEnts :: Key Test -> [(Entity Submission, Entity User, Map (Key Test) Evaluation, [Entity Tag])] -> [(Key User, (User, [((Entity Submission), Evaluation)]))]
2016-02-12 23:21:26 +01:00
getAuxSubmissionEnts testId evaluationMaps = map (processEvaluationMap testId) evaluationMaps
2017-02-25 22:53:17 +01:00
where processEvaluationMap testId (s, (Entity ui u), m, _) = (ui, (u, case Map.lookup testId m of
2016-02-12 23:21:26 +01:00
Just e -> [(s, e)]
Nothing -> []))
2016-02-17 09:34:34 +01:00
getLeaderboardEntries :: Key Challenge -> Handler (Test, [LeaderboardEntry])
2015-12-12 18:53:20 +01:00
getLeaderboardEntries challengeId = do
(evaluationMaps, tests) <- getChallengeSubmissionInfos (\_ -> True) challengeId
2016-02-11 21:54:22 +01:00
let mainTestEnt = getMainTest tests
2015-12-12 18:53:20 +01:00
let (Entity mainTestId mainTest) = mainTestEnt
2016-02-16 21:10:10 +01:00
let auxSubmissions = getAuxSubmissionEnts mainTestId evaluationMaps
2015-12-12 18:53:20 +01:00
let submissionsByUser = Map.fromListWith (\(u1, l1) (_, l2) -> (u1, l1++l2)) auxSubmissions
let entryComparator a b = (compareResult mainTest) (evaluationScore $ leaderboardEvaluation a) (evaluationScore $ leaderboardEvaluation b)
2017-03-18 15:57:27 +01:00
entries' <- mapM (toEntry mainTest) $ filter (\(_, (_, s)) -> not (null s)) $ Map.toList submissionsByUser
let entries = sortBy (flip entryComparator) entries'
2016-02-17 09:34:34 +01:00
return (mainTest, entries)
2017-03-18 15:57:27 +01:00
toEntry mainTest (ui, (u, ss)) = do
let bestOne = DL.maximumBy (submissionComparator mainTest) ss
let submissionId = entityKey $ fst bestOne
tagEnts <- runDB $ getTags submissionId
return $ LeaderboardEntry {
2015-12-12 18:53:20 +01:00
leaderboardUser = u,
2016-02-16 21:10:10 +01:00
leaderboardUserId = ui,
leaderboardBestSubmission = (\(Entity _ s) -> s) $ fst bestOne,
leaderboardBestSubmissionId = (\(Entity si _) -> si) $ fst bestOne,
2015-12-12 18:53:20 +01:00
leaderboardEvaluation = snd bestOne,
2017-03-18 15:57:27 +01:00
leaderboardNumberOfSubmissions = length ss,
leaderboardTags = tagEnts
2017-02-25 22:53:17 +01:00
}
2017-03-18 15:57:27 +01:00
where submissionComparator mainTest (_, e1) (_, e2) = (compareResult mainTest) (evaluationScore e1) (evaluationScore e2)
2017-02-25 22:53:17 +01:00
2015-12-12 18:53:20 +01:00
compareResult :: Test -> Maybe Double -> Maybe Double -> Ordering
compareResult test (Just x) (Just y) = (compareFun $ getMetricOrdering $ testMetric test) x y
2015-12-12 18:53:20 +01:00
compareResult _ (Just _) Nothing = GT
compareResult _ Nothing (Just _) = LT
compareResult _ Nothing Nothing = EQ
compareFun :: MetricOrdering -> Double -> Double -> Ordering
compareFun TheLowerTheBetter = flip compare
compareFun TheHigherTheBetter = compare
2017-02-25 22:53:17 +01:00
getChallengeSubmissionInfos :: ((Entity Submission) -> Bool) -> Key Challenge -> Handler ([(Entity Submission, Entity User, Map (Key Test) Evaluation, [Entity Tag])], [Entity Test])
2015-12-12 18:53:20 +01:00
getChallengeSubmissionInfos condition challengeId = do
allSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId] [Desc SubmissionStamp]
let submissions = filter condition allSubmissions
tests <- runDB $ selectList [TestChallenge ==. challengeId, TestActive ==. True] []
evaluationMaps <- mapM getEvaluationMap submissions
return (evaluationMaps, tests)
2017-02-25 22:53:17 +01:00
getEvaluationMap :: Entity Submission -> Handler (Entity Submission, Entity User, Map (Key Test) Evaluation, [Entity Tag])
2015-12-12 18:53:20 +01:00
getEvaluationMap s@(Entity submissionId submission) = do
outs <- runDB $ selectList [OutSubmission ==. submissionId] []
user <- runDB $ get404 $ submissionSubmitter submission
maybeEvaluations <- runDB $ mapM (\(Entity _ o) -> getBy $ UniqueEvaluationTestChecksum (outTest o) (outChecksum o)) outs
let evaluations = catMaybes maybeEvaluations
let m = Map.fromList $ map (\(Entity _ e) -> (evaluationTest e, e)) evaluations
2017-02-25 22:53:17 +01:00
tagEnts <- runDB $ getTags submissionId
return (s, Entity (submissionSubmitter submission) user, m, tagEnts)