diff --git a/Handler/EditSubmission.hs b/Handler/EditSubmission.hs index d4715ef..92df7e6 100644 --- a/Handler/EditSubmission.hs +++ b/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 diff --git a/Handler/SubmissionView.hs b/Handler/SubmissionView.hs index 6649fac..6942201 100644 --- a/Handler/SubmissionView.hs +++ b/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 diff --git a/Handler/Tables.hs b/Handler/Tables.hs index f858b95..bb61631 100644 --- a/Handler/Tables.hs +++ b/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 diff --git a/Handler/TagUtils.hs b/Handler/TagUtils.hs index 780a750..41bc2ff 100644 --- a/Handler/TagUtils.hs +++ b/Handler/TagUtils.hs @@ -27,3 +27,15 @@ fragmentWithTags t tagEnts = [whamlet| $forall (Entity _ v) <- tagEnts \ #{tagName v} |] + +fragmentWithSubmissionTags t tagEnts = [whamlet| +#{t} + +$forall ((Entity _ v), (Entity _ s)) <- tagEnts + \ #{tagName v} +|] + +tagClass :: Maybe Bool -> Text +tagClass (Just True) = "label-success" +tagClass (Just False) = "label-default" +tagClass Nothing = "label-primary"