show tag status
This commit is contained in:
parent
84862ac13d
commit
f8779ce044
@ -17,7 +17,7 @@ getEditSubmissionR submissionId = do
|
|||||||
tags <- runDB $ getTags submissionId
|
tags <- runDB $ getTags submissionId
|
||||||
let mTagsAsText = case tags of
|
let mTagsAsText = case tags of
|
||||||
[] -> Nothing
|
[] -> Nothing
|
||||||
_ -> Just $ T.intercalate ", " $ Import.map (tagName . entityVal) tags
|
_ -> Just $ T.intercalate ", " $ Import.map (tagName . entityVal . fst) tags
|
||||||
(formWidget, formEnctype) <- generateFormPost $ editSubmissionForm (submissionDescription submission) mTagsAsText
|
(formWidget, formEnctype) <- generateFormPost $ editSubmissionForm (submissionDescription submission) mTagsAsText
|
||||||
doEditSubmission formWidget formEnctype submissionId
|
doEditSubmission formWidget formEnctype submissionId
|
||||||
|
|
||||||
|
@ -38,4 +38,5 @@ getTags submissionId = do
|
|||||||
sts <- selectList [SubmissionTagSubmission ==. submissionId] []
|
sts <- selectList [SubmissionTagSubmission ==. submissionId] []
|
||||||
let tagIds = Import.map (submissionTagTag . entityVal) sts
|
let tagIds = Import.map (submissionTagTag . entityVal) sts
|
||||||
tags <- mapM get404 $ tagIds
|
tags <- mapM get404 $ tagIds
|
||||||
return $ Import.map (\(k, v) -> Entity k v) $ Import.zip tagIds tags
|
let tagEnts = Import.map (\(k, v) -> Entity k v) $ Import.zip tagIds tags
|
||||||
|
return $ zip tagEnts sts
|
||||||
|
@ -29,10 +29,10 @@ data LeaderboardEntry = LeaderboardEntry {
|
|||||||
leaderboardBestSubmissionId :: SubmissionId,
|
leaderboardBestSubmissionId :: SubmissionId,
|
||||||
leaderboardEvaluation :: Evaluation,
|
leaderboardEvaluation :: Evaluation,
|
||||||
leaderboardNumberOfSubmissions :: Int,
|
leaderboardNumberOfSubmissions :: Int,
|
||||||
leaderboardTags :: [Entity Tag]
|
leaderboardTags :: [(Entity Tag, Entity SubmissionTag)]
|
||||||
}
|
}
|
||||||
|
|
||||||
submissionsTable :: Maybe UserId -> Text -> [Entity Test] -> Table App (Entity Submission, Entity User, Map (Key Test) Evaluation, [Entity Tag])
|
submissionsTable :: Maybe UserId -> Text -> [Entity Test] -> Table App (Entity Submission, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)])
|
||||||
submissionsTable mauthId challengeName tests = mempty
|
submissionsTable mauthId challengeName tests = mempty
|
||||||
++ Table.text "submitter" (formatSubmitter . (\(_, Entity _ submitter, _, _) -> submitter))
|
++ Table.text "submitter" (formatSubmitter . (\(_, Entity _ submitter, _, _) -> submitter))
|
||||||
++ timestampCell "when" (submissionStamp . (\(Entity _ s, _, _, _) -> s))
|
++ timestampCell "when" (submissionStamp . (\(Entity _ s, _, _, _) -> s))
|
||||||
@ -41,9 +41,9 @@ submissionsTable mauthId challengeName tests = mempty
|
|||||||
++ statusCell challengeName (\(Entity submissionId submission, Entity userId _, _, _) -> (submissionId, submission, userId, mauthId))
|
++ statusCell challengeName (\(Entity submissionId submission, Entity userId _, _, _) -> (submissionId, submission, userId, mauthId))
|
||||||
|
|
||||||
descriptionCell = Table.widget "description" (
|
descriptionCell = Table.widget "description" (
|
||||||
\(Entity _ s, _, _ ,tagEnts) -> fragmentWithTags (submissionDescription s) tagEnts)
|
\(Entity _ s, _, _ ,tagEnts) -> fragmentWithSubmissionTags (submissionDescription s) tagEnts)
|
||||||
|
|
||||||
extractScore :: Key Test -> (Entity Submission, Entity User, Map (Key Test) Evaluation, [Entity Tag]) -> Maybe Evaluation
|
extractScore :: Key Test -> (Entity Submission, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)]) -> Maybe Evaluation
|
||||||
extractScore k (_, _, m, _) = lookup k m
|
extractScore k (_, _, m, _) = lookup k m
|
||||||
|
|
||||||
leaderboardTable :: Maybe UserId -> Text -> Test -> Table App (Int, LeaderboardEntry)
|
leaderboardTable :: Maybe UserId -> Text -> Test -> Table App (Int, LeaderboardEntry)
|
||||||
@ -60,7 +60,7 @@ leaderboardTable mauthId challengeName test = mempty
|
|||||||
mauthId))
|
mauthId))
|
||||||
|
|
||||||
leaderboardDescriptionCell = Table.widget "description" (
|
leaderboardDescriptionCell = Table.widget "description" (
|
||||||
\(_,entry) -> fragmentWithTags (submissionDescription $ leaderboardBestSubmission entry) (leaderboardTags entry))
|
\(_,entry) -> fragmentWithSubmissionTags (submissionDescription $ leaderboardBestSubmission entry) (leaderboardTags entry))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@ -112,7 +112,7 @@ getAuxSubmissions testId evaluationMaps = map (processEvaluationMap testId) eval
|
|||||||
Nothing -> []))
|
Nothing -> []))
|
||||||
|
|
||||||
|
|
||||||
getAuxSubmissionEnts :: Key Test -> [(Entity Submission, Entity User, Map (Key Test) Evaluation, [Entity Tag])] -> [(Key User, (User, [((Entity Submission), Evaluation)]))]
|
getAuxSubmissionEnts :: Key Test -> [(Entity Submission, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)])] -> [(Key User, (User, [((Entity Submission), Evaluation)]))]
|
||||||
getAuxSubmissionEnts testId evaluationMaps = map (processEvaluationMap testId) evaluationMaps
|
getAuxSubmissionEnts testId evaluationMaps = map (processEvaluationMap testId) evaluationMaps
|
||||||
where processEvaluationMap testId (s, (Entity ui u), m, _) = (ui, (u, case Map.lookup testId m of
|
where processEvaluationMap testId (s, (Entity ui u), m, _) = (ui, (u, case Map.lookup testId m of
|
||||||
Just e -> [(s, e)]
|
Just e -> [(s, e)]
|
||||||
@ -160,7 +160,7 @@ compareFun :: MetricOrdering -> Double -> Double -> Ordering
|
|||||||
compareFun TheLowerTheBetter = flip compare
|
compareFun TheLowerTheBetter = flip compare
|
||||||
compareFun TheHigherTheBetter = compare
|
compareFun TheHigherTheBetter = compare
|
||||||
|
|
||||||
getChallengeSubmissionInfos :: ((Entity Submission) -> Bool) -> Key Challenge -> Handler ([(Entity Submission, Entity User, Map (Key Test) Evaluation, [Entity Tag])], [Entity Test])
|
getChallengeSubmissionInfos :: ((Entity Submission) -> Bool) -> Key Challenge -> Handler ([(Entity Submission, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)])], [Entity Test])
|
||||||
getChallengeSubmissionInfos condition challengeId = do
|
getChallengeSubmissionInfos condition challengeId = do
|
||||||
allSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId] [Desc SubmissionStamp]
|
allSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId] [Desc SubmissionStamp]
|
||||||
let submissions = filter condition allSubmissions
|
let submissions = filter condition allSubmissions
|
||||||
@ -168,7 +168,7 @@ getChallengeSubmissionInfos condition challengeId = do
|
|||||||
evaluationMaps <- mapM getEvaluationMap submissions
|
evaluationMaps <- mapM getEvaluationMap submissions
|
||||||
return (evaluationMaps, tests)
|
return (evaluationMaps, tests)
|
||||||
|
|
||||||
getEvaluationMap :: Entity Submission -> Handler (Entity Submission, Entity User, Map (Key Test) Evaluation, [Entity Tag])
|
getEvaluationMap :: Entity Submission -> Handler (Entity Submission, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)])
|
||||||
getEvaluationMap s@(Entity submissionId submission) = do
|
getEvaluationMap s@(Entity submissionId submission) = do
|
||||||
outs <- runDB $ selectList [OutSubmission ==. submissionId] []
|
outs <- runDB $ selectList [OutSubmission ==. submissionId] []
|
||||||
user <- runDB $ get404 $ submissionSubmitter submission
|
user <- runDB $ get404 $ submissionSubmitter submission
|
||||||
|
@ -27,3 +27,15 @@ fragmentWithTags t tagEnts = [whamlet|
|
|||||||
$forall (Entity _ v) <- tagEnts
|
$forall (Entity _ v) <- tagEnts
|
||||||
\ <span class="label label-primary">#{tagName v}</span>
|
\ <span class="label label-primary">#{tagName v}</span>
|
||||||
|]
|
|]
|
||||||
|
|
||||||
|
fragmentWithSubmissionTags t tagEnts = [whamlet|
|
||||||
|
#{t}
|
||||||
|
|
||||||
|
$forall ((Entity _ v), (Entity _ s)) <- tagEnts
|
||||||
|
\ <span class="label #{tagClass $ submissionTagAccepted s}">#{tagName v}</span>
|
||||||
|
|]
|
||||||
|
|
||||||
|
tagClass :: Maybe Bool -> Text
|
||||||
|
tagClass (Just True) = "label-success"
|
||||||
|
tagClass (Just False) = "label-default"
|
||||||
|
tagClass Nothing = "label-primary"
|
||||||
|
Loading…
Reference in New Issue
Block a user