filipg/gonito
1
0
Fork 1
Code Issues 1 Pull Requests Releases Wiki Activity

refactor tables

Browse Source
This commit is contained in:
Filip Gralinski 2018-07-14 17:02:30 +02:00
parent f3960c371d
commit ca9bcbac55
2 changed files with 23 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Handler/ShowChallenge.hs
View File

@ -489,7 +489,7 @@ getChallengeSubmissions condition name = do
challengeLayout True challenge (challengeAllSubmissionsWidget muserId challenge scheme challengeRepo evaluationMaps tests)
challengeAllSubmissionsWidget :: Maybe UserId -> Challenge -> RepoScheme -> Repo -> [(Entity Submission, Entity Variant, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)])] -> [Entity Test] -> WidgetFor App ()
challengeAllSubmissionsWidget :: Maybe UserId -> Challenge -> RepoScheme -> Repo -> [TableEntry] -> [Entity Test] -> WidgetFor App ()
challengeAllSubmissionsWidget muserId challenge scheme challengeRepo submissions tests = $(widgetFile "challenge-all-submissions")
challengeLayout :: Bool -> Challenge -> WidgetFor App () -> HandlerFor App Html

38
Handler/Tables.hs
View File

@ -31,20 +31,26 @@ data LeaderboardEntry = LeaderboardEntry {
leaderboardTags :: [(Entity Tag, Entity SubmissionTag)]
}
submissionsTable :: Maybe UserId -> Text -> RepoScheme -> Repo -> [Entity Test] -> Table App (Entity Submission, Entity Variant, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)])
data TableEntry = TableEntry (Entity Submission)
(Entity Variant)
(Entity User)
(Map (Key Test) Evaluation)
[(Entity Tag, Entity SubmissionTag)]
submissionsTable :: Maybe UserId -> Text -> RepoScheme -> Repo -> [Entity Test] -> Table App TableEntry
submissionsTable mauthId challengeName repoScheme challengeRepo tests = mempty
++ Table.text "submitter" (formatSubmitter . (\(_, _, Entity _ submitter, _, _) -> submitter))
++ timestampCell "when" (submissionStamp . (\(Entity _ s, _, _, _, _) -> s))
++ 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 (\(Entity submissionId submission, _, Entity userId _, _, _) -> (submissionId, submission, userId, mauthId))
++ statusCell challengeName repoScheme challengeRepo (\(TableEntry (Entity submissionId submission) _ (Entity userId _) _ _) -> (submissionId, submission, userId, mauthId))
descriptionCell :: Foldable t => Table site (Entity Submission, v, b, c, t (Entity Tag, Entity SubmissionTag))
descriptionCell :: Table site TableEntry
descriptionCell = Table.widget "description" (
\(Entity _ s, _, _, _ ,tagEnts) -> fragmentWithSubmissionTags (submissionDescription s) tagEnts)
\(TableEntry (Entity _ s) _ _ _ tagEnts) -> fragmentWithSubmissionTags (submissionDescription s) tagEnts)
extractScore :: Key Test -> (Entity Submission, Entity Variant, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)]) -> Maybe Evaluation
extractScore k (_, _, _, m, _) = lookup k m
extractScore :: Key Test -> TableEntry -> Maybe Evaluation
extractScore k (TableEntry _ _ _ m _) = lookup k m
leaderboardTable :: Maybe UserId -> Text -> RepoScheme -> Repo -> Test -> Table App (Int, LeaderboardEntry)
leaderboardTable mauthId challengeName repoScheme challengeRepo test = mempty
@ -99,9 +105,9 @@ getAuxSubmissions testId evaluationMaps = map processEvaluationMap evaluationMap
Nothing -> []))
getAuxSubmissionEnts :: Key Test -> [(Entity Submission, Entity Variant, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)])] -> [(Key User, (User, [((Entity Submission), Evaluation)]))]
getAuxSubmissionEnts :: Key Test -> [TableEntry] -> [(Key User, (User, [((Entity Submission), Evaluation)]))]
getAuxSubmissionEnts testId evaluationMaps = map processEvaluationMap evaluationMaps
where processEvaluationMap (s, v, (Entity ui u), m, _) = (ui, (u, case Map.lookup testId m of
where processEvaluationMap (TableEntry s _ (Entity ui u) m _) = (ui, (u, case Map.lookup testId m of
Just e -> [(s, e)]
Nothing -> []))
@ -150,7 +156,7 @@ compareFun :: MetricOrdering -> Double -> Double -> Ordering
compareFun TheLowerTheBetter = flip compare
compareFun TheHigherTheBetter = compare
getChallengeSubmissionInfos :: ((Entity Submission) -> Bool) -> Key Challenge -> Handler ([(Entity Submission,Entity Variant, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)])], [Entity Test])
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
@ -158,17 +164,17 @@ getChallengeSubmissionInfos condition challengeId = do
evaluationMaps <- mapM getEvaluationMapForSubmission submissions
return (concat evaluationMaps, tests)
getEvaluationMapForSubmission :: Entity Submission -> Handler [(Entity Submission, Entity Variant, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)])]
getEvaluationMapForSubmission s@(Entity submissionId submission)= do
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 (Entity Submission, Entity Variant, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)])
getEvaluationMap s@(Entity submissionId submission) v@(Entity variantId variant) = do
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
return (s, v, Entity (submissionSubmitter submission) user, m, tagEnts)
return $ TableEntry s v (Entity (submissionSubmitter submission) user) m tagEnts