From 3388971ed66e9ce3c717426ccabddf4556df12bd Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Sat, 28 Jul 2018 21:53:13 +0200 Subject: [PATCH] clean up and refactor --- Handler/Graph.hs | 4 +++- Handler/Presentation.hs | 19 ++++++++----------- Handler/ShowChallenge.hs | 2 +- Handler/Tables.hs | 33 ++++++++++++++++++++++++--------- 4 files changed, 36 insertions(+), 22 deletions(-) diff --git a/Handler/Graph.hs b/Handler/Graph.hs index 9ac3607..eac24e3 100644 --- a/Handler/Graph.hs +++ b/Handler/Graph.hs @@ -71,7 +71,9 @@ submissionsToJSON :: ((Entity Submission) -> Bool) -> Text -> Handler Value submissionsToJSON condition challengeName = do (Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName - (_, entries) <- getLeaderboardEntriesByCriterion challengeId condition (\(TableEntry (Entity submissionId _) _ _ _ _ _) -> submissionId) + (_, entries, _) <- getLeaderboardEntriesByCriterion challengeId + condition + (\(TableEntry (Entity submissionId _) _ _ _ _ _) -> submissionId) let naturalRange = getNaturalRange entries let submissionIds = map leaderboardBestSubmissionId entries diff --git a/Handler/Presentation.hs b/Handler/Presentation.hs index 754cdae..b4c428b 100644 --- a/Handler/Presentation.hs +++ b/Handler/Presentation.hs @@ -6,7 +6,6 @@ import Handler.ShowChallenge import Handler.Tables import qualified Yesod.Table as Table -import Yesod.Table (Table) import Text.Hamlet (hamletFile) @@ -30,7 +29,7 @@ getPresentation4RealR :: Handler Html getPresentation4RealR = do readme <- challengeReadme sampleChallengeName - challengeEnt@(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName sampleChallengeName + (Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName sampleChallengeName (Just (Entity sampleUserId _)) <- runDB $ getBy $ UniqueUser sampleUserIdent let condition = (\(Entity _ submission) -> (submissionSubmitter submission == sampleUserId)) @@ -54,11 +53,11 @@ getPresentationDATeCH2017R = do presentationLayout $(widgetFile "presentation-datech-2017") +getSampleLeaderboard :: Text -> HandlerFor App (WidgetT App IO ()) getSampleLeaderboard name = do - challengeEnt@(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name + (Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name - Just repo <- runDB $ get $ challengePublicRepo challenge - (test, leaderboard) <- getLeaderboardEntries challengeId + (test, leaderboard, _) <- getLeaderboardEntries challengeId let leaderboardWithRanks = zip [1..] (take 10 leaderboard) app <- getYesod @@ -66,13 +65,11 @@ getSampleLeaderboard name = do challengeRepo <- runDB $ get404 $ challengePublicRepo challenge - return $ Table.buildBootstrap (leaderboardTable Nothing (challengeName challenge) scheme challengeRepo test) leaderboardWithRanks + return $ Table.buildBootstrap (leaderboardTable Nothing + (challengeName challenge) + scheme challengeRepo test) + leaderboardWithRanks presentationLayout widget = do - master <- getYesod - mmsg <- getMessage - - maybeUser <- maybeAuth - pc <- widgetToPageContent widget withUrlRenderer $(hamletFile "templates/presentation-layout.hamlet") diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index 09da88f..d20db23 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -44,7 +44,7 @@ getShowChallengeR :: Text -> Handler Html getShowChallengeR name = do (Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name Just repo <- runDB $ get $ challengePublicRepo challenge - (mainTest, leaderboard) <- getLeaderboardEntries challengeId + (mainTest, leaderboard, _) <- getLeaderboardEntries challengeId mauth <- maybeAuth let muserId = (\(Entity uid _) -> uid) <$> mauth diff --git a/Handler/Tables.hs b/Handler/Tables.hs index 2129909..512335f 100644 --- a/Handler/Tables.hs +++ b/Handler/Tables.hs @@ -132,17 +132,23 @@ getAuxSubmissionEnts testId evaluationMaps = map processEvaluationMap evaluation Nothing -> [])) -getLeaderboardEntriesByCriterion :: (Ord a) => Key Challenge -> ((Entity Submission) -> Bool) -> (TableEntry -> a) -> Handler (Test, [LeaderboardEntry]) +getLeaderboardEntriesByCriterion :: (Ord a) => Key Challenge + -> ((Entity Submission) -> Bool) + -> (TableEntry -> a) + -> Handler (Test, [LeaderboardEntry], ([TableEntry], [Entity Test])) getLeaderboardEntriesByCriterion challengeId condition selector = do - (evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId + infos@(evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId let mainTestEnt = getMainTest tests let (Entity mainTestId mainTest) = mainTestEnt let auxItems = map (\i -> (selector i, [i])) $ filter (\(TableEntry _ _ _ em _ _) -> member mainTestId em) $ evaluationMaps let auxItemsMap = Map.fromListWith (++) auxItems let entryComparator a b = (compareResult mainTest) (evaluationScore $ leaderboardEvaluation a) (evaluationScore $ leaderboardEvaluation b) - entries' <- mapM (toLeaderboardEntry challengeId mainTestEnt) $ filter (\ll -> not (null ll)) $ map snd $ Map.toList auxItemsMap + entries' <- mapM (toLeaderboardEntry challengeId mainTestEnt) + $ filter (\ll -> not (null ll)) + $ map snd + $ Map.toList auxItemsMap let entries = sortBy (flip entryComparator) entries' - return (mainTest, entries) + return (mainTest, entries, infos) toLeaderboardEntry :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistQueryRead (YesodPersistBackend site), YesodPersist site, Foldable t) => Key Challenge -> Entity Test -> t TableEntry -> HandlerFor site LeaderboardEntry toLeaderboardEntry challengeId (Entity mainTestId mainTest) ss = do @@ -155,7 +161,9 @@ toLeaderboardEntry challengeId (Entity mainTestId mainTest) ss = do parameters <- runDB $ selectList [ParameterVariant ==. (entityKey bestVariant)] [Asc ParameterName] -- get all user submissions, including hidden ones - allUserSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId, SubmissionSubmitter ==. entityKey user] [Desc SubmissionStamp] + allUserSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId, + SubmissionSubmitter ==. entityKey user] + [Desc SubmissionStamp] return $ LeaderboardEntry { leaderboardUser = entityVal user, leaderboardUserId = entityKey user, @@ -170,8 +178,11 @@ toLeaderboardEntry challengeId (Entity mainTestId mainTest) ss = do } where submissionComparator (TableEntry _ _ _ em1 _ _) (TableEntry _ _ _ em2 _ _) = (compareResult mainTest) (evaluationScore (em1 Map.! mainTestId)) (evaluationScore (em2 Map.! mainTestId)) -getLeaderboardEntries :: Key Challenge -> Handler (Test, [LeaderboardEntry]) -getLeaderboardEntries challengeId = getLeaderboardEntriesByCriterion challengeId (const True) (\(TableEntry _ _ (Entity userId _) _ _ _) -> userId) +getLeaderboardEntries :: Key Challenge -> Handler (Test, [LeaderboardEntry], ([TableEntry], [Entity Test])) +getLeaderboardEntries challengeId = + getLeaderboardEntriesByCriterion challengeId + (const True) + (\(TableEntry _ _ (Entity userId _) _ _ _) -> userId) compareResult :: Test -> Maybe Double -> Maybe Double -> Ordering compareResult test (Just x) (Just y) = (compareFun $ getMetricOrdering $ testMetric test) x y @@ -183,9 +194,13 @@ compareFun :: MetricOrdering -> Double -> Double -> Ordering compareFun TheLowerTheBetter = flip compare compareFun TheHigherTheBetter = compare -getChallengeSubmissionInfos :: ((Entity Submission) -> Bool) -> Key Challenge -> Handler ([TableEntry], [Entity Test]) +getChallengeSubmissionInfos :: ((Entity Submission) -> Bool) + -> Key Challenge + -> Handler ([TableEntry], [Entity Test]) getChallengeSubmissionInfos condition challengeId = do - allSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId, SubmissionIsHidden !=. Just True] [Desc SubmissionStamp] + allSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId, + SubmissionIsHidden !=. Just True] + [Desc SubmissionStamp] let submissions = filter condition allSubmissions tests <- runDB $ selectList [TestChallenge ==. challengeId, TestActive ==. True] [] evaluationMaps <- mapM getEvaluationMapForSubmission submissions