gonito/Handler/Tables.hs
2018-09-22 19:22:00 +02:00

244 lines
13 KiB
Haskell
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

{-# LANGUAGE ScopedTypeVariables #-}
module Handler.Tables where
import Import
import Handler.Shared
import Handler.SubmissionView
import Handler.TagUtils
import qualified Yesod.Table as Table
import Yesod.Table (Table)
import qualified Data.Map as Map
import Data.Text (pack, unpack, unwords)
import PersistSHA1
import qualified Data.List as DL
import GEval.Core
import GEval.ParseParams (parseParamsFromFilePath, OutputFileParsed(..))
data LeaderboardEntry = LeaderboardEntry {
leaderboardUser :: User,
leaderboardUserId :: UserId,
leaderboardBestSubmission :: Submission,
leaderboardBestSubmissionId :: SubmissionId,
leaderboardBestVariant :: Variant,
leaderboardBestVariantId :: VariantId,
leaderboardEvaluationMap :: Map (Key Test) Evaluation,
leaderboardNumberOfSubmissions :: Int,
leaderboardTags :: [(Entity Tag, Entity SubmissionTag)],
leaderboardParams :: [Parameter]
}
data TableEntry = TableEntry (Entity Submission)
(Entity Variant)
(Entity User)
(Map (Key Test) Evaluation)
[(Entity Tag, Entity SubmissionTag)]
[Entity Parameter]
-- TODO change into a record
tableEntryParams (TableEntry _ _ _ _ _ paramEnts) = paramEnts
tableEntryMapping (TableEntry _ _ _ mapping _ _) = mapping
tableEntryTagsInfo (TableEntry _ _ _ _ tagsInfo _) = tagsInfo
tableEntryStamp :: TableEntry -> UTCTime
tableEntryStamp (TableEntry submission _ _ _ _ _) = submissionStamp $ entityVal submission
submissionsTable :: Maybe UserId -> Text -> RepoScheme -> Repo -> [Entity Test] -> Table App TableEntry
submissionsTable mauthId challengeName repoScheme challengeRepo tests = mempty
++ Table.text "submitter" (formatSubmitter . (\(TableEntry _ _ (Entity _ submitter) _ _ _) -> submitter))
++ timestampCell "when" (submissionStamp . (\(TableEntry (Entity _ s) _ _ _ _ _) -> s))
++ descriptionCell
++ mconcat (map (\(Entity k t) -> resultCell t (extractScore k)) tests)
++ statusCell challengeName repoScheme challengeRepo (\(TableEntry (Entity submissionId submission) (Entity variantId variant) (Entity userId _) _ _ _) -> (submissionId, submission, variantId, variant, userId, mauthId))
descriptionCell :: Table site TableEntry
descriptionCell = Table.widget "description" (
\(TableEntry (Entity _ s) (Entity _ v) _ _ tagEnts paramEnts) -> fragmentWithSubmissionTags
(descriptionToBeShown s v (map entityVal paramEnts))
tagEnts)
descriptionToBeShown :: Submission -> Variant -> [Parameter] -> Text
descriptionToBeShown s v params = (submissionDescription s) ++ (Data.Text.pack vdescription) ++ " " ++ paramsShown
where (OutputFileParsed r _) = parseParamsFromFilePath (Data.Text.unpack $ variantName v)
vdescription = if r == "out"
then
""
else
" " ++ r
paramsShown = Data.Text.unwords $ map formatParameter params
extractScore :: Key Test -> TableEntry -> Maybe Evaluation
extractScore k (TableEntry _ _ _ m _ _) = lookup k m
leaderboardTable :: Maybe UserId -> Text -> RepoScheme -> Repo -> [Entity Test] -> Table App (Int, LeaderboardEntry)
leaderboardTable mauthId challengeName repoScheme challengeRepo tests = mempty
++ Table.int "#" fst
++ Table.text "submitter" (formatSubmitter . leaderboardUser . snd)
++ timestampCell "when" (submissionStamp . leaderboardBestSubmission . snd)
++ leaderboardDescriptionCell
++ mconcat (map (\(Entity k t) -> resultCell t (extractScoreFromLeaderboardEntry k . snd)) tests)
++ Table.int "×" (leaderboardNumberOfSubmissions . snd)
++ statusCell challengeName repoScheme challengeRepo (\(_, e) -> (leaderboardBestSubmissionId e,
leaderboardBestSubmission e,
leaderboardBestVariantId e,
leaderboardBestVariant e,
leaderboardUserId e,
mauthId))
extractScoreFromLeaderboardEntry :: Key Test -> LeaderboardEntry -> Maybe Evaluation
extractScoreFromLeaderboardEntry k entry = lookup k (leaderboardEvaluationMap entry)
leaderboardDescriptionCell :: Table site (a, LeaderboardEntry)
leaderboardDescriptionCell = Table.widget "description" (
\(_,entry) -> fragmentWithSubmissionTags (descriptionToBeShown (leaderboardBestSubmission entry)
(leaderboardBestVariant entry)
(leaderboardParams entry))
(leaderboardTags entry)
)
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"
statusCell :: Text -> RepoScheme -> Repo -> (a -> (SubmissionId, Submission, VariantId, Variant, UserId, Maybe UserId)) -> Table App a
statusCell challengeName repoScheme challengeRepo fun = Table.widget "" (statusCellWidget challengeName repoScheme challengeRepo . fun)
resultCell :: Test -> (a -> Maybe Evaluation) -> Table App a
resultCell test fun = hoverTextCell (formatTestForHtml test) (formatTruncatedScore (testPrecision test) . fun) (formatFullScore . fun)
statusCellWidget :: Eq a => Text -> RepoScheme -> Repo -> (SubmissionId, Submission, VariantId, Variant, a, Maybe a) -> WidgetFor App ()
statusCellWidget challengeName repoScheme challengeRepo (submissionId, submission, variantId, _, userId, mauthId) = $(widgetFile "submission-status")
where commitHash = fromSHA1ToText $ submissionCommit submission
isPublic = submissionIsPublic submission
isOwner = (mauthId == Just userId)
isVisible = isPublic || isOwner
publicSubmissionBranch = getPublicSubmissionBranch submissionId
maybeBrowsableUrl = if isPublic
then
Just $ browsableGitRepoBranch repoScheme challengeRepo challengeName publicSubmissionBranch
else
Nothing
getAuxSubmissionEnts :: Key Test -> [TableEntry] -> [(Key User, (User, [(Entity Submission, Entity Variant, Evaluation)]))]
getAuxSubmissionEnts testId evaluationMaps = map processEvaluationMap evaluationMaps
where processEvaluationMap (TableEntry s v (Entity ui u) m _ _) = (ui, (u, case Map.lookup testId m of
Just e -> [(s, v, e)]
Nothing -> []))
getLeaderboardEntriesByCriterion :: (Ord a) => Key Challenge
-> ((Entity Submission) -> Bool)
-> (TableEntry -> [a])
-> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
getLeaderboardEntriesByCriterion challengeId condition selector = do
(evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId
let mainTests = getMainTests tests
let mainTestEnt = getMainTest tests
let (Entity mainTestId mainTest) = mainTestEnt
let auxItems = concat
$ map (\i -> map (\s -> (s, [i])) (selector i))
$ filter (\(TableEntry _ _ _ em _ _) -> member mainTestId em)
$ evaluationMaps
let auxItemsMap = Map.fromListWith (++) auxItems
let entryComparator a b = (compareResult mainTest) (evaluationScore $ leaderboardEvaluationMap a Map.! mainTestId)
(evaluationScore $ leaderboardEvaluationMap b Map.! mainTestId)
entries' <- mapM (toLeaderboardEntry challengeId mainTests)
$ filter (\ll -> not (null ll))
$ map snd
$ Map.toList auxItemsMap
let entries = DL.nubBy (\a b -> leaderboardBestVariantId a == leaderboardBestVariantId b)
$ sortBy (flip entryComparator) entries'
return (entries, (evaluationMaps, mainTests))
toLeaderboardEntry :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistQueryRead (YesodPersistBackend site), YesodPersist site, Foldable t) => Key Challenge -> [Entity Test] -> t TableEntry -> HandlerFor site LeaderboardEntry
toLeaderboardEntry challengeId tests ss = do
let bestOne = DL.maximumBy submissionComparator ss
let (TableEntry bestSubmission bestVariant user evals _ _) = bestOne
let submissionId = entityKey bestSubmission
tagEnts <- runDB $ getTags submissionId
parameters <- runDB $ selectList [ParameterVariant ==. (entityKey bestVariant)] [Asc ParameterName]
-- get all user submissions, including hidden ones
allUserSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId,
SubmissionSubmitter ==. entityKey user]
[Desc SubmissionStamp]
return $ LeaderboardEntry {
leaderboardUser = entityVal user,
leaderboardUserId = entityKey user,
leaderboardBestSubmission = entityVal bestSubmission,
leaderboardBestSubmissionId = entityKey bestSubmission,
leaderboardBestVariant = entityVal bestVariant,
leaderboardBestVariantId = entityKey bestVariant,
leaderboardEvaluationMap = evals,
leaderboardNumberOfSubmissions = length allUserSubmissions,
leaderboardTags = tagEnts,
leaderboardParams = map entityVal parameters
}
where (Entity mainTestId mainTest) = getMainTest tests
submissionComparator (TableEntry _ _ _ em1 _ _) (TableEntry _ _ _ em2 _ _) =
(compareResult mainTest) (evaluationScore (em1 Map.! mainTestId))
(evaluationScore (em2 Map.! mainTestId))
getLeaderboardEntries :: LeaderboardStyle -> Key Challenge -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
getLeaderboardEntries BySubmitter challengeId =
getLeaderboardEntriesByCriterion challengeId
(const True)
(\(TableEntry _ _ (Entity userId _) _ _ _) -> [userId])
getLeaderboardEntries ByTag challengeId =
getLeaderboardEntriesByCriterion challengeId
(const True)
(noEmptyList . (map (entityKey . fst)) . tableEntryTagsInfo)
where noEmptyList [] = [Nothing]
noEmptyList l = map Just l
compareResult :: Test -> Maybe Double -> Maybe Double -> Ordering
compareResult test (Just x) (Just y) = (compareFun $ getMetricOrdering $ testMetric test) x y
compareResult _ (Just _) Nothing = GT
compareResult _ Nothing (Just _) = LT
compareResult _ Nothing Nothing = EQ
getChallengeSubmissionInfos :: ((Entity Submission) -> Bool)
-> Key Challenge
-> Handler ([TableEntry], [Entity Test])
getChallengeSubmissionInfos condition challengeId = do
allSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId,
SubmissionIsHidden !=. Just True]
[Desc SubmissionStamp]
let submissions = filter condition allSubmissions
tests <- runDB $ selectList [TestChallenge ==. challengeId, TestActive ==. True] []
evaluationMaps <- mapM getEvaluationMapForSubmission submissions
return (concat evaluationMaps, tests)
getEvaluationMapForSubmission :: Entity Submission -> Handler [TableEntry]
getEvaluationMapForSubmission s@(Entity submissionId _)= do
variants <- runDB $ selectList [VariantSubmission ==. submissionId] []
mapM (getEvaluationMap s) variants
getEvaluationMap :: Entity Submission -> Entity Variant -> Handler TableEntry
getEvaluationMap s@(Entity submissionId submission) v@(Entity variantId _) = do
outs <- runDB $ selectList [OutVariant ==. variantId] []
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
tagEnts <- runDB $ getTags submissionId
parameters <- runDB $ selectList [ParameterVariant ==. variantId] [Asc ParameterName]
return $ TableEntry s v (Entity (submissionSubmitter submission) user) m tagEnts parameters