Ability to see analyses for other metrics

Foundation.hs

@@ -152,7 +152,8 @@ instance Yesod App where
     isAuthorized QueryFormR _ = regularAuthorization
     isAuthorized (QueryResultsR _) _ = regularAuthorization
     isAuthorized ListChallengesR _ = regularAuthorization
-    isAuthorized (ViewVariantR _) _ = regularAuthorization
+    isAuthorized (ViewVariantR _ ) _ = regularAuthorization
+    isAuthorized (ViewVariantTestR _ _) _ = regularAuthorization
 
     isAuthorized TagsR _ = regularAuthorization
     isAuthorized AchievementsR _ = regularAuthorization

Handler/Query.hs

@@ -181,14 +181,16 @@ processQuery query = do
     setTitle "query results"
     $(widgetFile "query-results")
 
-
+getViewVariantTestR :: VariantId -> TestId -> Handler Html
-getViewVariantR :: VariantId -> Handler Html
+getViewVariantTestR variantId testId = do
-getViewVariantR variantId = do
   mauthId <- maybeAuth
   variant <- runDB $ get404 variantId
   let theSubmissionId = variantSubmission variant
   theSubmission <- runDB $ get404 theSubmissionId
 
+  testSelected <- runDB $ get404 testId
+  let testSelectedEnt = Entity testId testSelected
+
   ([entry], tests') <- runDB $ getChallengeSubmissionInfos 3
                                                           (\e -> entityKey e == theSubmissionId)
                                                           (\e -> entityKey e == variantId)
@@ -222,13 +224,28 @@ getViewVariantR variantId = do
       error "Cannot access this submission variant"
 
 
-crossTableDefinition :: TableWithValues Text -> Table.Table App (Text, [Text])
+getViewVariantR :: VariantId -> Handler Html
-crossTableDefinition (TableWithValues (headerH : headerR) _) = mempty
+getViewVariantR variantId = do
-  ++ Table.text headerH fst
+  variant <- runDB $ get404 variantId
-  ++ mconcat (map (\(ix, h) -> Table.text h ((!! ix) . snd)) $ zip [0..] headerR)
+  let theSubmissionId = variantSubmission variant
-crossTableDefinition _ = error $ "cross-tab of an unexpected size"
+  theSubmission <- runDB $ get404 theSubmissionId
 
-crossTableBody :: TableWithValues Text -> [(Text, [Text])]
+  (_, tests') <- runDB $ getChallengeSubmissionInfos 3
+                                                    (\e -> entityKey e == theSubmissionId)
+                                                    (\e -> entityKey e == variantId)
+                                                    id
+                                                    (submissionChallenge theSubmission)
+  let (mainTest:_) = sortBy (flip testComparator) tests'
+  getViewVariantTestR variantId (entityKey mainTest)
+
+
+crossTableDefinition :: VariantId -> TableWithValues (Entity Test, Text) -> Table.Table App (Text, [(Entity Test, Text)])
+crossTableDefinition variantId (TableWithValues (headerH : headerR) _) = mempty
+  ++ Table.text headerH fst
+  ++ mconcat (map (\(ix, h) -> Table.linked h (snd . (!! ix) . snd) ((\(e, _) -> ViewVariantTestR variantId (entityKey e)) . (!! ix) . snd)) $ zip [0..] headerR)
+crossTableDefinition _ _ = error $ "cross-tab of an unexpected size"
+
+crossTableBody :: TableWithValues (Entity Test, Text) -> [(Text, [(Entity Test, Text)])]
 crossTableBody (TableWithValues _ rows) = rows
 
 paramsTable :: Table.Table App Parameter
@@ -238,12 +255,19 @@ paramsTable = mempty
 
 viewOutput :: TableEntry -> [Entity Test] -> (SHA1, Text) -> WidgetFor App ()
 viewOutput entry tests (outputHash, testSet) = do
+  let (mainTest:_) = filter (\e -> (testName $ entityVal e) == testSet) tests
+  viewOutputWithNonDefaultTestSelected entry tests mainTest (outputHash, testSet)
+
+viewOutputWithNonDefaultTestSelected :: TableEntry -> [Entity Test] -> Entity Test -> (SHA1, Text) -> WidgetFor App ()
+viewOutputWithNonDefaultTestSelected entry tests mainTest (outputHash, testSet) = do
+  let tests' = filter (\e -> (testName $ entityVal e) == testSet) tests
+
   mauthId <- maybeAuthId
 
-  let tests'@(mainTest:_) = filter (\e -> (testName $ entityVal e) == testSet) tests
   let outputSha1AsText = fromSHA1ToText $ outputHash
 
   let variant = variantName $ entityVal $ tableEntryVariant entry
+  let variantId = entityKey $ tableEntryVariant entry
 
   let theStamp = submissionStamp $ entityVal $ tableEntrySubmission entry
   isViewable <- handlerToWidget $ runDB $ checkWhetherVisible (entityVal $ tableEntrySubmission entry) mauthId
@@ -256,8 +280,9 @@ viewOutput entry tests (outputHash, testSet) = do
 
   let testLabels = map (formatTestEvaluationScheme . entityVal) tests'
   let mapping = LM.fromList $ map (\test -> (formatTestEvaluationScheme $ entityVal test,
-                                            (formatTruncatedScore (testPrecision $ entityVal test)
+                                            (test,
-                                             $ extractScore (getTestReference test) entry))) tests'
+                                             (formatTruncatedScore (testPrecision $ entityVal test)
+                                              $ extractScore (getTestReference test) entry)))) tests'
   let crossTables = splitIntoTablesWithValues "Metric" "Score" mapping testLabels
 
   mResult <-

config/models

@@ -77,6 +77,7 @@ Test
     precision Int Maybe
     priority Int Maybe
     UniqueChallengeNameMetricChecksum challenge name metric checksum
+    deriving Show
 Submission
     repo RepoId
     commit SHA1

config/routes

@@ -41,6 +41,7 @@
 /q/#Text QueryResultsR  GET
 
 /view-variant/#VariantId ViewVariantR GET
+/view-variant-test/#VariantId/#TestId ViewVariantTestR GET
 
 /api/txt/score/#Text ApiTxtScoreR GET
 

templates/view-output.hamlet

@@ -6,7 +6,7 @@
    <div class="media-heading">
      <div .subm-commit>#{testSet} / #{outputSha1AsText}
      $forall crossTable <- crossTables
-       ^{Table.buildBootstrap (crossTableDefinition crossTable) (crossTableBody crossTable)}
+       ^{Table.buildBootstrap (crossTableDefinition variantId crossTable) (crossTableBody crossTable)}
      $maybe result <- mResult
         <h4>worst items
         ^{Table.buildBootstrap (lineByLineTable mainTest theStamp) result}

templates/view-variant.hamlet

@@ -11,4 +11,4 @@
       ^{Table.buildBootstrap paramsTable (map entityVal $ tableEntryParams entry)}
 
   $forall output <- outputs
-    ^{viewOutput entry tests output}
+    ^{viewOutputWithNonDefaultTestSelected entry tests testSelectedEnt output}