show tag status

Handler/EditSubmission.hs

@@ -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
 

Handler/SubmissionView.hs

@@ -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

Handler/Tables.hs

@@ -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

Handler/TagUtils.hs

@@ -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"