First version of viewing a specific variant

Handler/Dashboard.hs

@@ -19,6 +19,8 @@ import Handler.Tables (timestampCell)
 import GEval.Core (isBetter)
 import GEval.EvaluationScheme
 
+import Text.Blaze
+
 import qualified Database.Esqueleto      as E
 import           Database.Esqueleto      ((^.))
 
@@ -93,6 +95,7 @@ postEditIndicatorR indicatorId = do
 
   doEditIndicator mUser indicatorId formWidget formEnctype
 
+doEditIndicator :: (Text.Blaze.ToMarkup a1, ToWidget App a2) => Maybe (Entity User) -> Key Indicator -> a2 -> a1 -> HandlerT App IO Html
 doEditIndicator mUser indicatorId formWidget formEnctype = do
   (addTargetformWidget, addTargetFormEnctype) <- generateFormPost addTargetForm
 
@@ -128,6 +131,7 @@ getDeleteTargetR targetId = do
   doEditIndicator mUser (targetIndicator target) formWidget formEnctype
 
 
+doDashboard :: (Text.Blaze.ToMarkup a1, ToWidget App a2) => Maybe (Entity User) -> a2 -> a1 -> HandlerFor App Html
 doDashboard mUser formWidget formEnctype = do
   indicators <- runDB $ selectList [] [Asc IndicatorId]
 
@@ -247,7 +251,7 @@ getOngoingTargets challengeId = do
                         return indicator
   indicatorEntries <- mapM indicatorToEntry indicators
   theNow <- liftIO $ getCurrentTime
-  (entries, _) <- runDB $ getChallengeSubmissionInfos (const True) challengeId
+  (entries, _) <- runDB $ getChallengeSubmissionInfos (const True) (const True) challengeId
   let indicatorEntries' = map (onlyWithOngoingTargets theNow entries) indicatorEntries
   return indicatorEntries'
 

Handler/Graph.hs

@@ -33,7 +33,7 @@ getChallengeParamGraphDataR challengeName testId paramName = do
   test <- runDB $ get404 testId
   let testRef = getTestReference (Entity testId test)
 
-  (entries, _) <- runDB $ getChallengeSubmissionInfos (const True) challengeId
+  (entries, _) <- runDB $ getChallengeSubmissionInfos (const True) (const True) challengeId
 
   let values = map (findParamValue paramName) entries
 
@@ -162,7 +162,7 @@ getIndicatorGraphDataR indicatorId = do
   test <- runDB $ get404 testId
   let mPrecision = testPrecision test
 
-  (entries, _) <- runDB $ getChallengeSubmissionInfos (const True) (testChallenge test)
+  (entries, _) <- runDB $ getChallengeSubmissionInfos (const True) (const True) (testChallenge test)
 
   theNow <- liftIO $ getCurrentTime -- needed to draw the "now" vertical line
 

Handler/Presentation.hs

@@ -36,7 +36,7 @@ getPresentation4RealR = do
 
   (Just (Entity sampleUserId _)) <- runDB $ getBy $ UniqueUser sampleUserIdent
   let condition = (\(Entity _ submission) -> (submissionSubmitter submission == sampleUserId))
-  (evaluationMaps', tests) <- runDB $ getChallengeSubmissionInfos condition challengeId
+  (evaluationMaps', tests) <- runDB $ getChallengeSubmissionInfos condition (const True) challengeId
   let evaluationMaps = take 10 evaluationMaps'
 
   sampleLeaderboard <- getSampleLeaderboard sampleChallengeName
@@ -57,7 +57,7 @@ getPresentationPSNC2019R = do
 
   (Just (Entity sampleUserId _)) <- runDB $ getBy $ UniqueUser sampleUserIdent
   let condition = (\(Entity _ submission) -> (submissionSubmitter submission == sampleUserId))
-  (evaluationMaps', tests) <- runDB $ getChallengeSubmissionInfos condition challengeId
+  (evaluationMaps', tests) <- runDB $ getChallengeSubmissionInfos condition (const True) challengeId
   let evaluationMaps = take 10 evaluationMaps'
 
   sampleLeaderboard <- getSampleLeaderboard sampleChallengeName

Handler/Query.hs

@@ -100,6 +100,10 @@ getViewVariantR variantId = do
   let theSubmissionId = variantSubmission variant
   theSubmission <- runDB $ get404 theSubmissionId
 
+  ([entry], tests) <- runDB $ getChallengeSubmissionInfos (\e -> entityKey e == theSubmissionId)
+                                                         (\e -> entityKey e == variantId)
+                                                         (submissionChallenge theSubmission)
+
   if submissionIsPublic theSubmission || Just (submissionSubmitter theSubmission) == (entityKey <$> mauthId)
     then
      do
@@ -112,7 +116,6 @@ getViewVariantR variantId = do
                             E.orderBy []
                             return (out, test)
 
-
       let outputs =
             sortBy (\a b -> ((snd b) `compare` (snd a)))
             $ nub
@@ -124,15 +127,32 @@ getViewVariantR variantId = do
     else
       error "Cannot access this submission variant"
 
-viewOutput :: (SHA1, Text) -> WidgetFor App ()
+
-viewOutput (outputHash, test) =  do
+outputEvaluationsTable :: TableEntry -> Table.Table App (Entity Test)
+outputEvaluationsTable tableEntry = mempty
+  ++ Table.text "Metric" (formatTestEvaluationScheme . entityVal)
+  ++ Table.text "Score" (\test -> (formatTruncatedScore (testPrecision $ entityVal test)
+                                  $ extractScore (getTestReference test) tableEntry))
+
+
+paramsTable :: Table.Table App Parameter
+paramsTable = mempty
+  ++ Table.text "Parameter" parameterName
+  ++ Table.text "Value" parameterValue
+
+viewOutput :: TableEntry -> [Entity Test] -> (SHA1, Text) -> WidgetFor App ()
+viewOutput entry tests (outputHash, testSet) =  do
+  let tests' = filter (\e -> (testName $ entityVal e) == testSet) tests
   let outputSha1AsText = fromSHA1ToText $ outputHash
   $(widgetFile "view-output")
 
 resultTable :: Entity Submission -> WidgetFor App ()
 resultTable (Entity submissionId submission) = do
-  (tableEntries, tests) <- handlerToWidget $ runDB $ getChallengeSubmissionInfos (\s -> entityKey s == submissionId)
+  (tableEntries, tests) <- handlerToWidget
-                                                                                (submissionChallenge submission)
+                          $ runDB
+                          $ getChallengeSubmissionInfos (\s -> entityKey s == submissionId)
+                                                        (const True)
+                                                        (submissionChallenge submission)
   let paramNames =
         nub
         $ map (parameterName . entityVal)

Handler/ShowChallenge.hs

@@ -174,7 +174,7 @@ idToBeShown _ maybeUser =
 
 defaultRepo :: RepoScheme -> Text -> Challenge -> Repo -> Maybe (Entity User) -> Text
 defaultRepo SelfHosted repoHost challenge _ maybeUser = repoHost ++ (idToBeShown challenge maybeUser) ++ "/" ++ (challengeName challenge)
-defaultRepo Branches repoHost _ repo _ = repoUrl repo
+defaultRepo Branches _ _ repo _ = repoUrl repo
 
 defaultBranch :: IsString a => RepoScheme -> Maybe a
 defaultBranch SelfHosted = Just "master"
@@ -430,7 +430,7 @@ checkIndicators user challengeId submissionId submissionLink relevantIndicators
 
 checkIndicator :: UTCTime -> User -> ChallengeId -> SubmissionId -> Text -> IndicatorEntry -> Channel -> Handler ()
 checkIndicator theNow user challengeId submissionId submissionLink indicator chan = do
-  (entries, _) <- runDB $ getChallengeSubmissionInfos (\(Entity sid _) -> sid == submissionId) challengeId
+  (entries, _) <- runDB $ getChallengeSubmissionInfos (\(Entity sid _) -> sid == submissionId) (const True) challengeId
   mapM_ (\t -> checkTarget theNow user submissionLink entries indicator t chan) (indicatorEntryTargets indicator)
 
 checkTarget :: UTCTime -> User -> Text -> [TableEntry] -> IndicatorEntry -> Entity Target -> Channel -> Handler ()
@@ -655,7 +655,7 @@ getChallengeAllSubmissionsR name = getChallengeSubmissions (\_ -> True) name
 getChallengeSubmissions :: ((Entity Submission) -> Bool) -> Text -> Handler Html
 getChallengeSubmissions condition name = do
   Entity challengeId challenge <- runDB $ getBy404 $ UniqueName name
-  (evaluationMaps, tests') <- runDB $ getChallengeSubmissionInfos condition challengeId
+  (evaluationMaps, tests') <- runDB $ getChallengeSubmissionInfos condition (const True) challengeId
   let tests = sortBy testComparator tests'
   mauth <- maybeAuth
   let muserId = (\(Entity uid _) -> uid) <$> mauth

Handler/Tables.hs

@@ -77,8 +77,8 @@ submissionsTable mauthId challengeName repoScheme challengeRepo tests = mempty
                                                                        entityKey $ tableEntrySubmitter tableEntry,
                                                                        mauthId))
 
-paramTable :: [Text] -> [Entity Test] -> Table App TableEntry
+variantTable :: [Text] -> [Entity Test] -> Table App TableEntry
-paramTable paramNames tests = mempty
+variantTable paramNames tests = mempty
   ++ Table.int "#" tableEntryRank
   ++ mconcat (map paramExtractor paramNames)
   ++ mconcat (map (\e@(Entity _ t) -> resultCell t (extractScore $ getTestReference e)) tests)
@@ -203,7 +203,7 @@ getLeaderboardEntriesByCriterion :: (Ord a) => Key Challenge
                                              -> (TableEntry -> [a])
                                              -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
 getLeaderboardEntriesByCriterion challengeId condition selector = do
-  (evaluationMaps, tests) <- runDB $ getChallengeSubmissionInfos condition challengeId
+  (evaluationMaps, tests) <- runDB $ getChallengeSubmissionInfos condition (const True) challengeId
   let mainTests = getMainTests tests
   let mainTestEnt = getMainTest tests
   let mainTestRef = getTestReference mainTestEnt
@@ -290,8 +290,8 @@ compareResult _ (Just _) Nothing = GT
 compareResult _ Nothing (Just _) = LT
 compareResult _ Nothing Nothing = EQ
 
-getChallengeSubmissionInfos :: (MonadIO m, PersistQueryRead backend, BackendCompatible SqlBackend backend, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend) => (Entity Submission -> Bool) -> Key Challenge -> ReaderT backend m ([TableEntry], [Entity Test])
+getChallengeSubmissionInfos :: (MonadIO m, PersistQueryRead backend, BackendCompatible SqlBackend backend, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend) => (Entity Submission -> Bool) -> (Entity Variant -> Bool) -> Key Challenge -> ReaderT backend m ([TableEntry], [Entity Test])
-getChallengeSubmissionInfos condition challengeId = do
+getChallengeSubmissionInfos condition variantCondition challengeId = do
 
   challenge <- get404 challengeId
   let commit = challengeVersion challenge
@@ -317,7 +317,8 @@ getChallengeSubmissionInfos condition challengeId = do
         $ sortBy (\(s1, _) (s2, _) -> compareResult (entityVal mainTest) s2 s1)
         $ zip scores allSubmissionsVariants
 
-  evaluationMaps <- mapM getEvaluationMap allSubmissionsVariantsWithRanks
+  evaluationMaps' <- mapM getEvaluationMap allSubmissionsVariantsWithRanks
+  let evaluationMaps = filter (variantCondition . tableEntryVariant) evaluationMaps'
   return (evaluationMaps, tests)
 
 getScore :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryRead backend, PersistUniqueRead backend) => Key Test -> Key Variant -> ReaderT backend m (Maybe Double)

templates/result-table.hamlet

@@ -2,4 +2,4 @@
   $if null tableEntries
      <p>No results available. The submission is probably broken.
   $else
-     ^{Table.buildBootstrap (paramTable paramNames tests) tableEntries}
+     ^{Table.buildBootstrap (variantTable paramNames tests) tableEntries}

templates/view-output.hamlet

@@ -4,4 +4,5 @@
       <span class="glyphicon glyphicon-asterisk" aria-hidden="hidden">
   <div class="media-body">
    <div class="media-heading">
-     <div .subm-commit>#{test} / #{outputSha1AsText}
+     <div .subm-commit>#{testSet} / #{outputSha1AsText}
+     ^{Table.buildBootstrap (outputEvaluationsTable entry) tests'}

templates/view-variant.hamlet

@@ -4,5 +4,11 @@
      <span class="glyphicon glyphicon-asterisk" aria-hidden="hidden">
  <div class="media-body">
   ^{submissionHeader fullSubmissionInfo}
+
+  $case tableEntryParams entry
+    $of []
+    $of _
+      ^{Table.buildBootstrap paramsTable (map entityVal $ tableEntryParams entry)}
+
   $forall output <- outputs
-    ^{viewOutput output}
+    ^{viewOutput entry tests output}