2015-12-12 18:53:20 +01:00
|
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
|
|
|
|
|
|
module Handler.Tables where
|
|
|
|
|
|
|
|
|
|
import Import
|
|
|
|
|
|
|
|
|
|
import qualified Yesod.Table as Table
|
|
|
|
|
import Yesod.Table (Table)
|
|
|
|
|
|
|
|
|
|
import Data.Map (Map)
|
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
|
|
|
|
|
|
import qualified Data.Maybe as DM
|
|
|
|
|
|
|
|
|
|
import qualified Data.List as DL
|
|
|
|
|
|
2016-02-16 19:00:26 +01:00
|
|
|
|
import Data.Text (pack)
|
|
|
|
|
|
2015-12-12 18:53:20 +01:00
|
|
|
|
import GEval.Core
|
|
|
|
|
|
|
|
|
|
data LeaderboardEntry = LeaderboardEntry {
|
|
|
|
|
leaderboardUser :: User,
|
|
|
|
|
leaderboardBestSubmission :: Submission,
|
|
|
|
|
leaderboardEvaluation :: Evaluation,
|
|
|
|
|
leaderboardNumberOfSubmissions :: Int
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
submissionsTable :: [Entity Test] -> Table site (Entity Submission, Entity User, Map (Key Test) Evaluation)
|
|
|
|
|
submissionsTable tests = mempty
|
|
|
|
|
++ Table.text "submitter" (formatSubmitter . \(_, Entity _ submitter, _) -> submitter)
|
2016-02-16 19:00:26 +01:00
|
|
|
|
++ timestampCell "when" (submissionStamp . \(Entity _ s, _, _) -> s)
|
2015-12-12 18:53:20 +01:00
|
|
|
|
++ Table.text "description" (submissionDescription . \(Entity _ s, _, _) -> s)
|
|
|
|
|
++ mconcat (map (\(Entity k t) -> Table.string (testName t) (submissionScore k)) tests)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
leaderboardTable :: Table site (Int, LeaderboardEntry)
|
|
|
|
|
leaderboardTable = mempty
|
|
|
|
|
++ Table.int "#" fst
|
|
|
|
|
++ Table.text "submitter" (formatSubmitter . leaderboardUser . snd)
|
2016-02-16 19:00:26 +01:00
|
|
|
|
++ timestampCell "when" (submissionStamp . leaderboardBestSubmission . snd)
|
2015-12-12 18:53:20 +01:00
|
|
|
|
++ Table.text "description" (submissionDescription . leaderboardBestSubmission . snd)
|
|
|
|
|
++ Table.string "result" (presentScore . leaderboardEvaluation . snd)
|
|
|
|
|
++ Table.int "×" (leaderboardNumberOfSubmissions . snd)
|
|
|
|
|
|
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-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
|
|
|
|
|
|
|
|
|
getAuxSubmissionEnts :: Key Test -> [(Entity Submission, Entity User, Map (Key Test) Evaluation)] -> [(Key User, (User, [((Entity Submission), Evaluation)]))]
|
|
|
|
|
getAuxSubmissionEnts testId evaluationMaps = map (processEvaluationMap testId) evaluationMaps
|
|
|
|
|
where processEvaluationMap testId (s, (Entity ui u), m) = (ui, (u, case Map.lookup testId m of
|
|
|
|
|
Just e -> [(s, e)]
|
|
|
|
|
Nothing -> []))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
2015-12-12 18:53:20 +01:00
|
|
|
|
getLeaderboardEntries :: Key Challenge -> Handler [LeaderboardEntry]
|
|
|
|
|
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-11 21:54:22 +01:00
|
|
|
|
let auxSubmissions = getAuxSubmissions 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)
|
|
|
|
|
let entries = sortBy (flip entryComparator) $ map (toEntry mainTest) $ filter (\(_, (_, s)) -> not (null s)) $ Map.toList submissionsByUser
|
|
|
|
|
return entries
|
|
|
|
|
where submissionComparator mainTest (_, e1) (_, e2) = (compareResult mainTest) (evaluationScore e1) (evaluationScore e2)
|
|
|
|
|
toEntry mainTest (_, (u, ss)) = LeaderboardEntry {
|
|
|
|
|
leaderboardUser = u,
|
|
|
|
|
leaderboardBestSubmission = fst bestOne,
|
|
|
|
|
leaderboardEvaluation = snd bestOne,
|
|
|
|
|
leaderboardNumberOfSubmissions = length ss }
|
|
|
|
|
where bestOne = DL.maximumBy (submissionComparator mainTest) ss
|
|
|
|
|
|
|
|
|
|
compareResult :: Test -> Maybe Double -> Maybe Double -> Ordering
|
2015-12-20 21:00:00 +01:00
|
|
|
|
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
|
|
|
|
|
|
|
|
|
|
getChallengeSubmissionInfos :: ((Entity Submission) -> Bool) -> Key Challenge -> Handler ([(Entity Submission, Entity User, Map (Key Test) Evaluation)], [Entity Test])
|
|
|
|
|
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)
|
|
|
|
|
|
|
|
|
|
getEvaluationMap :: Entity Submission -> Handler (Entity Submission, Entity User, Map (Key Test) Evaluation)
|
|
|
|
|
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
|
|
|
|
|
return (s, Entity (submissionSubmitter submission) user, m)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
formatSubmitter :: User -> Text
|
2016-02-14 08:59:12 +01:00
|
|
|
|
formatSubmitter user = if userIsAnonymous user
|
|
|
|
|
then
|
|
|
|
|
"[anonymised]"
|
|
|
|
|
else
|
|
|
|
|
case userName user of
|
|
|
|
|
Just name -> name
|
|
|
|
|
Nothing -> "[name not given]"
|
2015-12-12 18:53:20 +01:00
|
|
|
|
|
|
|
|
|
submissionScore :: Key Test -> (Entity Submission, Entity User, Map (Key Test) Evaluation) -> String
|
|
|
|
|
submissionScore k (_, _, m) = fromMaybe "N/A" (presentScore <$> lookup k m)
|
|
|
|
|
|
|
|
|
|
presentScore :: Evaluation -> String
|
|
|
|
|
presentScore evaluation = fromMaybe "???" (show <$> evaluationScore evaluation)
|