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

show tag status

Browse Source
This commit is contained in:
Filip Gralinski 2017-05-27 22:31:53 +02:00
parent 84862ac13d
commit f8779ce044
4 changed files with 23 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Handler/EditSubmission.hs
View File

@ -17,7 +17,7 @@ getEditSubmissionR submissionId = do
tags <- runDB $ getTags submissionId
let mTagsAsText = case tags of
[] -> 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
doEditSubmission formWidget formEnctype submissionId

3
Handler/SubmissionView.hs
View File

@ -38,4 +38,5 @@ getTags submissionId = do
sts <- selectList [SubmissionTagSubmission ==. submissionId] []
let tagIds = Import.map (submissionTagTag . entityVal) sts
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

16
Handler/Tables.hs
View File

@ -29,10 +29,10 @@ data LeaderboardEntry = LeaderboardEntry {
leaderboardBestSubmissionId :: SubmissionId,
leaderboardEvaluation :: Evaluation,
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
++ Table.text "submitter" (formatSubmitter . (\(_, Entity _ submitter, _, _) -> submitter))
++ 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))
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
leaderboardTable :: Maybe UserId -> Text -> Test -> Table App (Int, LeaderboardEntry)
@ -60,7 +60,7 @@ leaderboardTable mauthId challengeName test = mempty
mauthId))
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 -> []))
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
where processEvaluationMap testId (s, (Entity ui u), m, _) = (ui, (u, case Map.lookup testId m of
Just e -> [(s, e)]
@ -160,7 +160,7 @@ 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 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
allSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId] [Desc SubmissionStamp]
let submissions = filter condition allSubmissions
@ -168,7 +168,7 @@ getChallengeSubmissionInfos condition challengeId = do
evaluationMaps <- mapM getEvaluationMap submissions
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
outs <- runDB $ selectList [OutSubmission ==. submissionId] []
user <- runDB $ get404 $ submissionSubmitter submission

12
Handler/TagUtils.hs
View File

@ -27,3 +27,15 @@ fragmentWithTags t tagEnts = [whamlet|
$forall (Entity _ v) <- tagEnts
\ <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"