clean up and refactor

This commit is contained in:
Filip Gralinski 2018-07-28 21:53:13 +02:00
parent 3a4c85c501
commit 3388971ed6
4 changed files with 36 additions and 22 deletions

View File

@ -71,7 +71,9 @@ submissionsToJSON :: ((Entity Submission) -> Bool) -> Text -> Handler Value
submissionsToJSON condition challengeName = do submissionsToJSON condition challengeName = do
(Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName (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 naturalRange = getNaturalRange entries
let submissionIds = map leaderboardBestSubmissionId entries let submissionIds = map leaderboardBestSubmissionId entries

View File

@ -6,7 +6,6 @@ import Handler.ShowChallenge
import Handler.Tables import Handler.Tables
import qualified Yesod.Table as Table import qualified Yesod.Table as Table
import Yesod.Table (Table)
import Text.Hamlet (hamletFile) import Text.Hamlet (hamletFile)
@ -30,7 +29,7 @@ getPresentation4RealR :: Handler Html
getPresentation4RealR = do getPresentation4RealR = do
readme <- challengeReadme sampleChallengeName 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 (Just (Entity sampleUserId _)) <- runDB $ getBy $ UniqueUser sampleUserIdent
let condition = (\(Entity _ submission) -> (submissionSubmitter submission == sampleUserId)) let condition = (\(Entity _ submission) -> (submissionSubmitter submission == sampleUserId))
@ -54,11 +53,11 @@ getPresentationDATeCH2017R = do
presentationLayout $(widgetFile "presentation-datech-2017") presentationLayout $(widgetFile "presentation-datech-2017")
getSampleLeaderboard :: Text -> HandlerFor App (WidgetT App IO ())
getSampleLeaderboard name = do 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) let leaderboardWithRanks = zip [1..] (take 10 leaderboard)
app <- getYesod app <- getYesod
@ -66,13 +65,11 @@ getSampleLeaderboard name = do
challengeRepo <- runDB $ get404 $ challengePublicRepo challenge 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 presentationLayout widget = do
master <- getYesod
mmsg <- getMessage
maybeUser <- maybeAuth
pc <- widgetToPageContent widget pc <- widgetToPageContent widget
withUrlRenderer $(hamletFile "templates/presentation-layout.hamlet") withUrlRenderer $(hamletFile "templates/presentation-layout.hamlet")

View File

@ -44,7 +44,7 @@ getShowChallengeR :: Text -> Handler Html
getShowChallengeR name = do getShowChallengeR name = do
(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name (Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
Just repo <- runDB $ get $ challengePublicRepo challenge Just repo <- runDB $ get $ challengePublicRepo challenge
(mainTest, leaderboard) <- getLeaderboardEntries challengeId (mainTest, leaderboard, _) <- getLeaderboardEntries challengeId
mauth <- maybeAuth mauth <- maybeAuth
let muserId = (\(Entity uid _) -> uid) <$> mauth let muserId = (\(Entity uid _) -> uid) <$> mauth

View File

@ -132,17 +132,23 @@ getAuxSubmissionEnts testId evaluationMaps = map processEvaluationMap evaluation
Nothing -> [])) 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 getLeaderboardEntriesByCriterion challengeId condition selector = do
(evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId infos@(evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId
let mainTestEnt = getMainTest tests let mainTestEnt = getMainTest tests
let (Entity mainTestId mainTest) = mainTestEnt let (Entity mainTestId mainTest) = mainTestEnt
let auxItems = map (\i -> (selector i, [i])) $ filter (\(TableEntry _ _ _ em _ _) -> member mainTestId em) $ evaluationMaps let auxItems = map (\i -> (selector i, [i])) $ filter (\(TableEntry _ _ _ em _ _) -> member mainTestId em) $ evaluationMaps
let auxItemsMap = Map.fromListWith (++) auxItems let auxItemsMap = Map.fromListWith (++) auxItems
let entryComparator a b = (compareResult mainTest) (evaluationScore $ leaderboardEvaluation a) (evaluationScore $ leaderboardEvaluation b) 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' 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 :: (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 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] parameters <- runDB $ selectList [ParameterVariant ==. (entityKey bestVariant)] [Asc ParameterName]
-- get all user submissions, including hidden ones -- 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 { return $ LeaderboardEntry {
leaderboardUser = entityVal user, leaderboardUser = entityVal user,
leaderboardUserId = entityKey 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)) where submissionComparator (TableEntry _ _ _ em1 _ _) (TableEntry _ _ _ em2 _ _) = (compareResult mainTest) (evaluationScore (em1 Map.! mainTestId)) (evaluationScore (em2 Map.! mainTestId))
getLeaderboardEntries :: Key Challenge -> Handler (Test, [LeaderboardEntry]) getLeaderboardEntries :: Key Challenge -> Handler (Test, [LeaderboardEntry], ([TableEntry], [Entity Test]))
getLeaderboardEntries challengeId = getLeaderboardEntriesByCriterion challengeId (const True) (\(TableEntry _ _ (Entity userId _) _ _ _) -> userId) getLeaderboardEntries challengeId =
getLeaderboardEntriesByCriterion challengeId
(const True)
(\(TableEntry _ _ (Entity userId _) _ _ _) -> userId)
compareResult :: Test -> Maybe Double -> Maybe Double -> Ordering compareResult :: Test -> Maybe Double -> Maybe Double -> Ordering
compareResult test (Just x) (Just y) = (compareFun $ getMetricOrdering $ testMetric test) x y 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 TheLowerTheBetter = flip compare
compareFun TheHigherTheBetter = 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 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 let submissions = filter condition allSubmissions
tests <- runDB $ selectList [TestChallenge ==. challengeId, TestActive ==. True] [] tests <- runDB $ selectList [TestChallenge ==. challengeId, TestActive ==. True] []
evaluationMaps <- mapM getEvaluationMapForSubmission submissions evaluationMaps <- mapM getEvaluationMapForSubmission submissions