diff --git a/Handler/Tables.hs b/Handler/Tables.hs
index 6058973..f858b95 100644
--- a/Handler/Tables.hs
+++ b/Handler/Tables.hs
@@ -5,6 +5,7 @@ module Handler.Tables where
import Import
import Handler.Shared
import Handler.SubmissionView
+import Handler.TagUtils
import qualified Yesod.Table as Table
import Yesod.Table (Table)
@@ -27,7 +28,8 @@ data LeaderboardEntry = LeaderboardEntry {
leaderboardBestSubmission :: Submission,
leaderboardBestSubmissionId :: SubmissionId,
leaderboardEvaluation :: Evaluation,
- leaderboardNumberOfSubmissions :: Int
+ leaderboardNumberOfSubmissions :: Int,
+ leaderboardTags :: [Entity Tag]
}
submissionsTable :: Maybe UserId -> Text -> [Entity Test] -> Table App (Entity Submission, Entity User, Map (Key Test) Evaluation, [Entity Tag])
@@ -39,14 +41,7 @@ submissionsTable mauthId challengeName tests = mempty
++ statusCell challengeName (\(Entity submissionId submission, Entity userId _, _, _) -> (submissionId, submission, userId, mauthId))
descriptionCell = Table.widget "description" (
- \(Entity _ s, _, _ ,tagEnts) -> [whamlet|
-#{submissionDescription s}
-
-$forall (Entity _ v) <- tagEnts
- \ #{tagName v}
-|])
-
--- Table.text "description" (submissionDescription . (\(Entity _ s, _, _, _) -> s))
+ \(Entity _ s, _, _ ,tagEnts) -> fragmentWithTags (submissionDescription s) tagEnts)
extractScore :: Key Test -> (Entity Submission, Entity User, Map (Key Test) Evaluation, [Entity Tag]) -> Maybe Evaluation
extractScore k (_, _, m, _) = lookup k m
@@ -56,7 +51,7 @@ leaderboardTable mauthId challengeName test = mempty
++ Table.int "#" fst
++ Table.text "submitter" (formatSubmitter . leaderboardUser . snd)
++ timestampCell "when" (submissionStamp . leaderboardBestSubmission . snd)
- ++ Table.text "description" (submissionDescription . leaderboardBestSubmission . snd)
+ ++ leaderboardDescriptionCell
++ resultCell test ((\e -> Just e) . leaderboardEvaluation . snd)
++ Table.int "×" (leaderboardNumberOfSubmissions . snd)
++ statusCell challengeName (\(_, e) -> (leaderboardBestSubmissionId e,
@@ -64,6 +59,10 @@ leaderboardTable mauthId challengeName test = mempty
leaderboardUserId e,
mauthId))
+leaderboardDescriptionCell = Table.widget "description" (
+ \(_,entry) -> fragmentWithTags (submissionDescription $ leaderboardBestSubmission entry) (leaderboardTags entry))
+
+
hoverTextCell :: Text -> (a -> Text) -> (a -> Text) -> Table site a
hoverTextCell h mainTextFun hoverTextFun = Table.widget h (
@@ -130,19 +129,25 @@ getLeaderboardEntries challengeId = do
let auxSubmissions = getAuxSubmissionEnts mainTestId evaluationMaps
let submissionsByUser = Map.fromListWith (\(u1, l1) (_, l2) -> (u1, l1++l2)) auxSubmissions
let entryComparator a b = (compareResult mainTest) (evaluationScore $ leaderboardEvaluation a) (evaluationScore $ leaderboardEvaluation b)
- let entries = sortBy (flip entryComparator) $ map (toEntry mainTest) $ filter (\(_, (_, s)) -> not (null s)) $ Map.toList submissionsByUser
+ entries' <- mapM (toEntry mainTest) $ filter (\(_, (_, s)) -> not (null s)) $ Map.toList submissionsByUser
+ let entries = sortBy (flip entryComparator) entries'
return (mainTest, entries)
- where submissionComparator mainTest (_, e1) (_, e2) = (compareResult mainTest) (evaluationScore e1) (evaluationScore e2)
- toEntry mainTest (ui, (u, ss)) = LeaderboardEntry {
+
+
+toEntry mainTest (ui, (u, ss)) = do
+ let bestOne = DL.maximumBy (submissionComparator mainTest) ss
+ let submissionId = entityKey $ fst bestOne
+ tagEnts <- runDB $ getTags submissionId
+ return $ LeaderboardEntry {
leaderboardUser = u,
leaderboardUserId = ui,
leaderboardBestSubmission = (\(Entity _ s) -> s) $ fst bestOne,
leaderboardBestSubmissionId = (\(Entity si _) -> si) $ fst bestOne,
leaderboardEvaluation = snd bestOne,
- leaderboardNumberOfSubmissions = length ss
+ leaderboardNumberOfSubmissions = length ss,
+ leaderboardTags = tagEnts
}
- where bestOne = DL.maximumBy (submissionComparator mainTest) ss
-
+ where submissionComparator mainTest (_, e1) (_, e2) = (compareResult mainTest) (evaluationScore e1) (evaluationScore e2)
compareResult :: Test -> Maybe Double -> Maybe Double -> Ordering
diff --git a/Handler/TagUtils.hs b/Handler/TagUtils.hs
index 17cae1d..780a750 100644
--- a/Handler/TagUtils.hs
+++ b/Handler/TagUtils.hs
@@ -20,3 +20,10 @@ tagsAsTextToTagIds mTagsAsText = do
Nothing -> []
mTs <- mapM (\t -> getBy $ UniqueTagName t) newTags
return $ Import.map entityKey $ Import.catMaybes mTs
+
+fragmentWithTags t tagEnts = [whamlet|
+#{t}
+
+$forall (Entity _ v) <- tagEnts
+ \ #{tagName v}
+|]