WIP

Data/Diff.hs

@@ -0,0 +1,113 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE PackageImports #-}
+
+module Data.Diff where
+
+import Import
+
+import Text.Blaze
+import Text.Blaze.Html4.Strict hiding (map)
+import Text.Blaze.Html4.Strict.Attributes hiding (map)
+
+import Data.Foldable
+
+import qualified Data.Map.Lazy as LM
+
+data Diff a = OneThing a | TwoThings a a
+
+
+presentDiff :: (Eq a, IsString m, Monoid m) => (a -> m) -> (m -> m) -> (m -> m) -> (Diff a -> m)
+presentDiff presentAtom _ _ (OneThing u) = presentAtom u
+presentDiff presentAtom presentOld presentNew (TwoThings old new)
+  | old == new = presentAtom new
+  | otherwise = presentOld (presentAtom old) <> presentNew (presentAtom new)
+
+
+instance (Eq a, Show a) => Show (Diff a) where
+  show d = presentDiff show
+                       (\x -> "[-" ++ x ++ "-]")
+                       (\x -> "{+" ++ x ++ "+}")
+                       d
+
+instance (Eq a, ToMarkup a) => ToMarkup (Diff a) where
+  toMarkup d = presentDiff toMarkup
+                           (Text.Blaze.Html4.Strict.span ! (Text.Blaze.Html4.Strict.Attributes.style "color:red;text-decoration: line-through;"))
+                           (Text.Blaze.Html4.Strict.span ! (Text.Blaze.Html4.Strict.Attributes.style "color:green;text-decoration: underline;"))
+                           d
+
+  -- toMarkup (OneThing u) = toMarkup u
+  -- toMarkup (TwoThings old new) = ((Text.Blaze.Html4.Strict.span ! (Text.Blaze.Html4.Strict.Attributes.style "color:green;")) (toMarkup new)) <> " (" <> ((Text.Blaze.Html4.Strict.span ! (Text.Blaze.Html4.Strict.Attributes.style "color:red;")) (toMarkup old)) <> ")"
+
+
+instance Functor Diff where
+  fmap fun (OneThing u) = OneThing (fun u)
+  fmap fun (TwoThings old new) = TwoThings (fun old) (fun new)
+
+instance Foldable Diff where
+  foldMap f (OneThing u) = f u
+  foldMap f (TwoThings old new) = f old `mappend` f new
+
+instance Traversable Diff where
+  traverse f (OneThing u) = OneThing <$> f u
+  traverse f (TwoThings old new) = TwoThings <$> f old <*> f new
+
+current :: Diff a -> a
+current (OneThing u) = u
+current (TwoThings _ new) = new
+
+class Diffable t where
+  type DiffSettings t
+  type DiffResult t
+  diff :: DiffSettings t -> t -> t -> DiffResult t
+  single :: t -> DiffResult t
+  runDiff :: DiffSettings t -> Diff t -> DiffResult t
+  runDiff _ (OneThing u) = single u
+  runDiff s (TwoThings old new) = diff s old new
+
+instance Diffable Int where
+  type DiffSettings Int = ()
+  type DiffResult Int = Diff Int
+  single u = OneThing u
+  diff _ old new
+    | old == new = OneThing new
+    | otherwise = TwoThings old new
+
+instance Diffable Text where
+  type DiffSettings Text = ()
+  type DiffResult Text = Diff Text
+  single u = OneThing u
+  diff _ old new
+    | old == new = OneThing new
+    | otherwise = TwoThings old new
+
+instance Diffable t => Diffable (Maybe t) where
+  type DiffSettings (Maybe t) = (t, DiffSettings t)
+  type DiffResult (Maybe t) = Maybe (DiffResult t)
+  single Nothing = Nothing
+  single (Just u) = Just $ single u
+  diff (_, sub) (Just old) (Just new) = Just $ diff sub old new
+  diff (defaultValue, sub) (Just old) Nothing = Just $ diff sub old defaultValue
+  diff (defaultValue, sub) Nothing (Just new) = Just $ diff sub defaultValue new
+  diff (_, _) Nothing Nothing = Nothing
+
+instance (Eq v) => Diffable ([v]) where
+  type DiffSettings ([v]) = ()
+  type DiffResult ([v]) = [(v, Diff Bool)]
+  single t = map (\e -> (e, OneThing True)) t
+  diff () old new = [(oe, TwoThings True False) | oe <- old, not (oe `Import.elem` new) ]
+                   ++ map (\ne -> (ne, if ne `Import.elem` old then OneThing True else TwoThings False True)) new
+
+instance (Eq k, Ord k, Diffable v) => Diffable (LM.Map k v) where
+  type DiffSettings (LM.Map k v) = (v, DiffSettings v)
+  type DiffResult (LM.Map k v) = LM.Map k (DiffResult v)
+  single m = LM.map single m
+  diff (defaultValue, sub) old new = LM.mergeWithKey (\_ a b -> Just $ diff sub a b)
+                                                     (LM.map (\x -> diff sub x defaultValue))
+                                                     (LM.map (\x -> diff sub defaultValue x))
+                                                     old
+                                                     new

Handler/Query.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
 module Handler.Query where
 
 import Import
@@ -7,6 +9,8 @@ import Handler.Shared
 import Handler.TagUtils
 import PersistSHA1
 
+import Data.Diff
+
 import Handler.Tables
 
 import Text.Blaze
@@ -18,6 +22,8 @@ import Database.Persist.Sql
 import qualified Database.Esqueleto      as E
 import           Database.Esqueleto      ((^.))
 
+import Data.Maybe (fromJust)
+
 import qualified Data.Text as T
 
 import Data.List (nub, (!!))
@@ -28,10 +34,11 @@ import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
 
 import Data.Conduit.SmartSource (lookForCompressedFiles)
 import GEval.Core (GEvalSpecification(..), ResultOrdering(..))
-import GEval.LineByLine (runLineByLineGeneralized, LineRecord(..))
+import GEval.LineByLine (runLineByLineGeneralized, runDiffGeneralized, LineRecord(..))
-import GEval.Common (FormattingOptions(..))
+import GEval.Common (FormattingOptions(..), MetricValue)
 import qualified Data.Conduit.List as CL
-import System.FilePath (takeFileName)
+import System.FilePath (takeFileName, makeRelative)
+import System.Directory (makeAbsolute)
 
 import Data.SplitIntoCrossTabs
 
@@ -186,16 +193,28 @@ processQuery query = do
 priorityLimitForViewVariant :: Int
 priorityLimitForViewVariant = 4
 
+getViewVariantDiffR :: VariantId -> VariantId -> TestId -> Handler Html
+getViewVariantDiffR oldVariantId newVariantId testId = do
+  doViewVariantTestR (TwoThings oldVariantId newVariantId) testId
+
 getViewVariantTestR :: VariantId -> TestId -> Handler Html
 getViewVariantTestR variantId testId = do
+  doViewVariantTestR (OneThing variantId) testId
+
+data ViewVariantData = ViewVariantData {
+  viewVariantDataFullSubmissionInfo :: (FullSubmissionInfo, Maybe Text),
+  viewVariantDataTableEntry :: TableEntry,
+  viewVariantDataTests :: [Entity Test],
+  viewVariantDataOuts :: [(SHA1, Text)]
+  }
+
+fetchViewVariantData :: VariantId -> Handler ViewVariantData
+fetchViewVariantData 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 priorityLimitForViewVariant
                                                           (\e -> entityKey e == theSubmissionId)
                                                           (\e -> entityKey e == variantId)
@@ -222,13 +241,52 @@ getViewVariantTestR variantId testId = do
             $ nub
             $ map (\(out, test) -> (outChecksum $ entityVal out, testName $ entityVal test)) testOutputs
 
-      defaultLayout $ do
+      return $ ViewVariantData (fullSubmissionInfo, Just $ variantName variant) entry tests outputs
-        setTitle "Variant"
-        $(widgetFile "view-variant")
     else
       error "Cannot access this submission variant"
 
 
+instance Diffable SHA1 where
+  type DiffSettings SHA1 = ()
+  type DiffResult SHA1 = Diff SHA1
+  single u = OneThing u
+  diff _ old new
+    | old == new = OneThing new
+    | otherwise = TwoThings old new
+
+nullSHA1 :: SHA1
+nullSHA1 = fromTextToSHA1 "da39a3ee5e6b4b0d3255bfef95601890afd80709"
+
+doViewVariantTestR :: Diff VariantId -> TestId -> Handler Html
+doViewVariantTestR variantId testId = do
+  testSelected <- runDB $ get404 testId
+  let testSelectedEnt = Entity testId testSelected
+
+  variantInfos <- mapM (fetchViewVariantData) variantId
+  let fullSubmissionInfo = viewVariantDataFullSubmissionInfo <$> variantInfos
+  let entry = viewVariantDataTableEntry <$> variantInfos
+  let tests' = viewVariantDataTests <$> variantInfos
+  let outputs' = viewVariantDataOuts <$> variantInfos
+
+
+  let testIds = map fst $ runDiff () $ fmap (map entityKey) tests'
+  testEnts <- mapM (runDB . get404) testIds
+  let tests = map (\(i,e) -> Entity i e) $ zip testIds testEnts
+  let outputs :: [(Diff SHA1, Text)] =
+        sortBy (\a b -> ((snd b) `compare` (snd a)))
+        $ map swap $ LM.toList $ runDiff (nullSHA1, ()) $ fmap (LM.fromList . map swap) outputs'
+
+  defaultLayout $ do
+    setTitle "Variant"
+    $(widgetFile "view-variant")
+
+mergeEntryParams :: Diff [Parameter] -> [(Text, Diff Text)]
+mergeEntryParams (OneThing u) = map (\(Parameter _ name val) -> (name, OneThing val)) u
+mergeEntryParams (TwoThings old new) = LM.toList $ diff ("", ()) oldMap newMap
+   where oldMap = mapify old
+         newMap = mapify new
+         mapify l = LM.fromList $ map (\(Parameter _ name val) -> (name, val)) l
+
 getViewVariantR :: VariantId -> Handler Html
 getViewVariantR variantId = do
   variant <- runDB $ get404 variantId
@@ -249,49 +307,94 @@ linkedWithAnchor h propFunc routeFunc anchorFunc =
   Table.widget h (
     \v -> [whamlet|<a href=@{routeFunc v}\\##{anchorFunc v}>#{propFunc v}|])
 
-crossTableDefinition :: VariantId -> TableWithValues (Entity Test, Text) -> Table.Table App (Text, [(Entity Test, Text)])
+getVariantTestLink :: Diff VariantId -> TestId -> Route App
+getVariantTestLink (OneThing u) testId = ViewVariantTestR u testId
+getVariantTestLink (TwoThings old new) testId = ViewVariantDiffR old new testId
+
+crossTableDefinition :: Diff VariantId -> TableWithValues (Entity Test, Diff Text) -> Table.Table App (Text, [(Entity Test, Diff Text)])
 crossTableDefinition variantId (TableWithValues (headerH : headerR) _) = mempty
   ++ Table.text headerH fst
   ++ mconcat (map (\(ix, h) -> linkedWithAnchor h
                                                (snd . (!! ix) . snd)
-                                               ((\(e, _) -> ViewVariantTestR variantId (entityKey e)) . (!! ix) . snd)
+                                               ((\(e, _) -> getVariantTestLink variantId (entityKey e)) . (!! ix) . snd)
                                                (("worst-items-" <>) . testName . entityVal . fst . (!! ix) . snd))
                $ zip [0..] headerR)
 crossTableDefinition _ _ = error $ "cross-tab of an unexpected size"
 
-crossTableBody :: TableWithValues (Entity Test, Text) -> [(Text, [(Entity Test, Text)])]
+crossTableBody :: TableWithValues (Entity Test, Diff Text) -> [(Text, [(Entity Test, Diff Text)])]
 crossTableBody (TableWithValues _ rows) = rows
 
-paramsTable :: Table.Table App Parameter
+paramsTable :: Table.Table App (Text, Diff Text)
 paramsTable = mempty
-  ++ Table.text "Parameter" parameterName
+  ++ Table.text "Parameter" fst
-  ++ Table.text "Value" parameterValue
+  ++ Table.widget "Value" ((\t -> [whamlet|#{t}|]) . snd)
 
-viewOutput :: TableEntry -> [Entity Test] -> (SHA1, Text) -> WidgetFor App ()
+viewOutput :: Diff 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 entry tests mainTest (OneThing outputHash, testSet)
 
 maximumNumberOfItemsToBeShown :: Int
 maximumNumberOfItemsToBeShown = 40
 
-viewOutputWithNonDefaultTestSelected :: TableEntry -> [Entity Test] -> Entity Test -> (SHA1, Text) -> WidgetFor App ()
+getOut :: Maybe UserId -> TableEntry -> WidgetFor App (Maybe (FilePath, FilePath))
+getOut mauthId entry = do
+  let variant = variantName $ entityVal $ tableEntryVariant entry
+
+  isViewable <- handlerToWidget $ runDB $ checkWhetherVisible (entityVal $ tableEntrySubmission entry) mauthId
+  if isViewable
+   then
+    do
+     mRepoDir <- handlerToWidget $ justGetSubmissionRepoDir $ entityKey $ tableEntrySubmission entry
+     case mRepoDir of
+       Just repoDir -> do
+         outFilePath <- liftIO $ lookForCompressedFiles (repoDir </> (T.unpack variant) <.> "tsv")
+         return $ Just (repoDir, outFilePath)
+       Nothing -> return Nothing
+   else
+    do
+     return Nothing
+
+data DiffLineRecord = DiffLineRecord Text Text (Diff (Text, MetricValue)) Word32
+                      deriving (Show)
+
+getUniLineRecord :: LineRecord -> DiffLineRecord
+getUniLineRecord (LineRecord inp exp out lineNo val) = DiffLineRecord inp exp (OneThing (out, val)) lineNo
+
+getBiLineRecord :: (LineRecord, LineRecord) -> DiffLineRecord
+getBiLineRecord ((LineRecord oldInp oldExp oldOut oldLineNo oldVal), (LineRecord newInp newExp newOut newLineNo newVal))
+  | oldInp == newInp && oldExp == newExp && oldLineNo == newLineNo =  DiffLineRecord newInp
+                                                                                newExp
+                                                                                (TwoThings (oldOut, oldVal)
+                                                                                           (newOut, newVal))
+                                                                                newLineNo
+  | otherwise = error "inconsistent line records when diffing"
+
+
+getScoreFromDiff :: DiffLineRecord -> MetricValue
+getScoreFromDiff (DiffLineRecord _ _ (OneThing (_, s)) _) = s
+getScoreFromDiff (DiffLineRecord _ _ (TwoThings (_, oldS) (_, newS)) _) = newS - oldS
+
+
+viewOutputWithNonDefaultTestSelected :: Diff TableEntry
+                                       -> [Entity Test]
+                                       -> Entity Test
+                                       -> (Diff SHA1, Text)
+                                       -> WidgetFor App ()
 viewOutputWithNonDefaultTestSelected entry tests mainTest (outputHash, testSet) = do
   let tests' = filter (\e -> (testName $ entityVal e) == testSet) tests
 
   mauthId <- maybeAuthId
 
-  let outputSha1AsText = fromSHA1ToText $ outputHash
+  let outputSha1AsText = fromSHA1ToText $ current outputHash
 
-  let variant = variantName $ entityVal $ tableEntryVariant entry
+  let variantId = entityKey <$> tableEntryVariant <$> entry
-  let variantId = entityKey $ tableEntryVariant entry
 
-  let theStamp = submissionStamp $ entityVal $ tableEntrySubmission entry
+  let theStamp = submissionStamp $ entityVal $ tableEntrySubmission $ current entry
-  isViewable <- handlerToWidget $ runDB $ checkWhetherVisible (entityVal $ tableEntrySubmission entry) mauthId
+  challenge <- handlerToWidget $ runDB $ get404 $ submissionChallenge $ entityVal $ tableEntrySubmission $ current entry
-  challenge <- handlerToWidget $ runDB $ get404 $ submissionChallenge $ entityVal $ tableEntrySubmission entry
   let isNonSensitive = challengeSensitive challenge == Just False
 
-  let shouldBeShown = not ("test-" `isInfixOf` testSet) && isViewable && isNonSensitive
+  let shouldBeShown = not ("test-" `isInfixOf` testSet) && isNonSensitive
 
   let mainMetric = testMetric $ entityVal mainTest
 
@@ -299,56 +402,70 @@ viewOutputWithNonDefaultTestSelected entry tests mainTest (outputHash, testSet)
   let mapping = LM.fromList $ map (\test -> (formatTestEvaluationScheme $ entityVal test,
                                             (test,
                                              (formatTruncatedScore (getTestFormattingOpts $ entityVal test)
-                                              $ extractScore (getTestReference test) entry)))) tests'
+                                              <$> extractScore (getTestReference test) <$> entry)))) tests'
   let crossTables = splitIntoTablesWithValues "Metric" "Score" mapping testLabels
 
   mResult <-
     if shouldBeShown
       then
        do
-        mRepoDir <- handlerToWidget $ justGetSubmissionRepoDir (entityKey $ tableEntrySubmission entry)
+        outPaths <- mapM (getOut mauthId) entry
-        case mRepoDir of
+        case current outPaths of
-               Just repoDir -> do
+          Just _ -> do
-                 outFile' <- liftIO $ lookForCompressedFiles (repoDir </> (T.unpack variant) <.> "tsv")
+            let repoDir = fst <$> fromJust <$> outPaths
-                 let outFile = takeFileName outFile'
+            let outFilePath = snd <$> fromJust <$> outPaths
+            let outFile = takeFileName $ current outFilePath
 
-                 let spec = GEvalSpecification {
+            let testName = T.unpack testSet
-                       gesOutDirectory = repoDir,
-                       gesExpectedDirectory = Nothing,
-                       gesTestName = (T.unpack testSet),
-                       gesSelector = Nothing,
-                       gesOutFile = outFile,
-                       gesAltOutFiles = Nothing,
-                       gesExpectedFile = "expected.tsv",
-                       gesInputFile = "in.tsv",
-                       gesMetrics = [mainMetric],
-                       gesFormatting = FormattingOptions {
-                           decimalPlaces = Nothing,
-                           asPercentage = False },
-                       gesTokenizer = Nothing,
-                       gesGonitoHost = Nothing,
-                       gesToken = Nothing,
-                       gesGonitoGitAnnexRemote = Nothing,
-                       gesReferences = Nothing,
-                       gesBootstrapResampling = Nothing,
-                       gesInHeader = Nothing,
-                       gesOutHeader = Nothing,
-                       gesShowPreprocessed = True }
 
-                 result <- liftIO $ runLineByLineGeneralized FirstTheWorst spec (\_ -> CL.take maximumNumberOfItemsToBeShown)
+            let spec = GEvalSpecification {
-                 return $ Just $ zip [1..] result
+                  gesOutDirectory = current repoDir,
-               Nothing -> return Nothing
+                  gesExpectedDirectory = Nothing,
+                  gesTestName = testName,
+                  gesSelector = Nothing,
+                  gesOutFile = outFile,
+                  gesAltOutFiles = Nothing,
+                  gesExpectedFile = "expected.tsv",
+                  gesInputFile = "in.tsv",
+                  gesMetrics = [mainMetric],
+                  gesFormatting = FormattingOptions {
+                      decimalPlaces = Nothing,
+                      asPercentage = False },
+                  gesTokenizer = Nothing,
+                  gesGonitoHost = Nothing,
+                  gesToken = Nothing,
+                  gesGonitoGitAnnexRemote = Nothing,
+                  gesReferences = Nothing,
+                  gesBootstrapResampling = Nothing,
+                  gesInHeader = Nothing,
+                  gesOutHeader = Nothing,
+                  gesShowPreprocessed = True }
+
+            case outPaths of
+              OneThing _ -> do
+                result <- liftIO $ runLineByLineGeneralized FirstTheWorst
+                                                       spec
+                                                       (\_ -> CL.take maximumNumberOfItemsToBeShown)
+                return $ Just $ zip [1..] $ map getUniLineRecord result
+              TwoThings (Just (oldRepoDir, oldOutFilePath)) _ -> do
+                absOldOutFilePath <- liftIO $ makeAbsolute (oldRepoDir </> testName </> (takeFileName oldOutFilePath))
+                result <- liftIO $ runDiffGeneralized FirstTheWorst
+                                                     absOldOutFilePath
+                                                     spec
+                                                     (\_ -> CL.take maximumNumberOfItemsToBeShown)
+                return $ Just $ zip [1..] $ map getBiLineRecord result
+          Nothing -> return Nothing
       else
         return Nothing
   $(widgetFile "view-output")
 
-lineByLineTable :: Entity Test -> UTCTime -> Table.Table App (Int, LineRecord)
+lineByLineTable :: Entity Test -> UTCTime -> Table.Table App (Int, DiffLineRecord)
 lineByLineTable (Entity testId test) theStamp = mempty
   ++ Table.int "#" fst
-  ++ theLimitedTextCell "input" (((\(LineRecord inp _ _ _ _) -> inp) . snd))
+  ++ theLimitedTextCell "input" (((\(DiffLineRecord inp _ _ _) -> inp) . snd))
-  ++ theLimitedTextCell "expected output" ((\(LineRecord _ expected _ _ _) -> expected) . snd)
+  ++ theLimitedTextCell "expected output" ((\(DiffLineRecord _ expected _ _) -> expected) . snd)
-  ++ theLimitedTextCell "actual output" ((\(LineRecord _ _ out _ _) -> out) . snd)
+  ++ theLimitedDiffTextCell "actual output" (fmap fst . (\(DiffLineRecord _ _ out _) -> out) . snd)
-  ++ resultCell test (fakeEvaluation . (\(LineRecord _ _ _ _ score) -> score) . snd)
+  ++ resultCell test (fakeEvaluation . getScoreFromDiff . snd)
   where fakeEvaluation score = Just $ Evaluation {
           evaluationTest = testId,
           evaluationChecksum = testChecksum test,
@@ -420,15 +537,22 @@ getHttpLink repo = case guessGitServer bareUrl of
         branch = repoBranch repo
         convertToHttpLink = ("https://" <>) . (T.replace ":" "/") . (T.replace ".git" "")
 
-submissionHeader :: FullSubmissionInfo -> Maybe Text -> WidgetFor App ()
+submissionHeader :: Diff (FullSubmissionInfo, Maybe Text) -> WidgetFor App ()
-submissionHeader submission mVariantName =
+submissionHeader param =
   $(widgetFile "submission-header")
-    where commitSha1AsText = fromSHA1ToText $ submissionCommit $ fsiSubmission submission
+    where variantSettings = ("out", ())
-          submitter = formatSubmitter $ fsiUser submission
+          submission = fst <$> param
-          publicSubmissionBranch = getPublicSubmissionBranch $ fsiSubmissionId submission
+          mVariantName = snd <$> param
-          publicSubmissionRepo = getReadOnlySubmissionUrl (fsiScheme submission) (fsiChallengeRepo submission) $ challengeName $ fsiChallenge submission
+          commitSha1AsText = fromSHA1ToText <$> submissionCommit <$> fsiSubmission <$> submission
-          browsableUrl = browsableGitRepoBranch (fsiScheme submission) (fsiChallengeRepo submission) (challengeName $ fsiChallenge submission) publicSubmissionBranch
+          submitter = formatSubmitter <$> fsiUser <$> submission
-          stamp = T.pack $ show $ submissionStamp $ fsiSubmission submission
+          publicSubmissionBranch = getPublicSubmissionBranch <$> fsiSubmissionId <$> submission
+          publicSubmissionRepo = submissionToSubmissionUrl <$> submission
+          browsableUrl = submissionToBrowsableUrl <$> submission
+          stamp = T.pack <$> show <$> submissionStamp <$> fsiSubmission <$> submission
+
+          submissionToSubmissionUrl submission' = getReadOnlySubmissionUrl (fsiScheme submission') (fsiChallengeRepo submission') $ challengeName $ fsiChallenge submission'
+          submissionToBrowsableUrl submission' = browsableGitRepoBranch (fsiScheme submission') (fsiChallengeRepo submission') (challengeName $ fsiChallenge submission') (getPublicSubmissionBranch $ fsiSubmissionId submission')
+
 
 queryResult :: FullSubmissionInfo -> WidgetFor App ()
 queryResult submission = do

Handler/Tables.hs

@@ -8,6 +8,8 @@ import Handler.Evaluate
 import Handler.SubmissionView
 import Handler.TagUtils
 
+import Data.Diff
+
 import qualified Yesod.Table as Table
 import Yesod.Table (Table)
 
@@ -185,15 +187,24 @@ textLimited limit t
   | otherwise = (Data.Text.take limit t) <> "…"
   where l = length t
 
+textCellSoftLimit = 140
+textCellHardLimit = 5 * textCellSoftLimit
+
+limitedWidget softLimit hardLimit v =
+  [whamlet|<span title="#{textLimited hardLimit v}"><tt>#{textLimited softLimit v}</tt>|]
+
 limitedTextCell :: Text -> Int -> Int -> (a -> Text) -> Table site a
 limitedTextCell h softLimit hardLimit textFun = Table.widget h (
-  \v -> [whamlet|<span title="#{textLimited hardLimit $ textFun v}"><tt>#{textLimited softLimit $ textFun v}</tt>|])
+  \v -> limitedWidget softLimit hardLimit (textFun v))
 
 theLimitedTextCell :: Text -> (a -> Text) -> Table site a
-theLimitedTextCell h textFun = limitedTextCell h softLimit hardLimit textFun
+theLimitedTextCell h textFun = limitedTextCell h textCellSoftLimit textCellHardLimit textFun
-  where softLimit = 140
-        hardLimit = 5 * softLimit
 
+theLimitedDiffTextCell :: Text -> (a -> Diff Text) -> Table site a
+theLimitedDiffTextCell h textFun = Table.widget h (
+  \v -> case textFun v of
+         OneThing u -> limitedWidget textCellSoftLimit textCellHardLimit u
+         d@(TwoThings _ _) -> [whamlet|#{d}|])
 
 statusCellWidget :: Text -> RepoScheme -> Repo -> (SubmissionId, Submission, VariantId, Variant, Maybe UserId) -> WidgetFor App ()
 statusCellWidget challengeName repoScheme challengeRepo (submissionId, submission, variantId, _, mauthId) = do

config/routes

@@ -42,6 +42,7 @@
 
 /view-variant/#VariantId ViewVariantR GET
 /view-variant-test/#VariantId/#TestId ViewVariantTestR GET
+/view-variant-diff/#VariantId/#VariantId/#TestId ViewVariantDiffR GET
 
 /api/txt/score/#Text ApiTxtScoreR GET
 

gonito.cabal

@@ -58,6 +58,7 @@ library
                      Handler.Evaluate
                      Data.SubmissionConditions
                      Gonito.ExtractMetadata
+                     Data.Diff
 
     if flag(dev) || flag(library-only)
         cpp-options:   -DDEVELOPMENT

templates/query-result.hamlet

@@ -3,7 +3,7 @@
    <p class="media-object">
      <span class="glyphicon glyphicon-asterisk" aria-hidden="hidden">
  <div class="media-body">
-  ^{submissionHeader submission Nothing}
+  ^{submissionHeader (OneThing (submission, Nothing))}
   ^{resultTable (Entity (fsiSubmissionId submission) (fsiSubmission submission))}
 
   $if not (null (fsiSuperSubmissions submission))

templates/submission-header.hamlet

@@ -1,36 +1,36 @@
 <div class="media-heading">
   <div .subm-commit>#{commitSha1AsText}
 
-<div .subm-description>^{fragmentWithTags (submissionDescription $ fsiSubmission submission) (map fst $ fsiTags submission)}
+<div .subm-description>^{fragmentWithTags (submissionDescription $ fsiSubmission $ current submission) (map fst $ fsiTags $ current submission)}
 <p>&nbsp;</p>
 <dl class="dl-horizontal">
   <dt>challenge
-  <dd><a href="@{ShowChallengeR $ challengeName $ fsiChallenge submission}">#{challengeTitle $ fsiChallenge submission}</a>
+  <dd><a href="@{ShowChallengeR $ challengeName $ fsiChallenge $ current submission}">#{challengeTitle $ fsiChallenge $ current submission}</a>
   <dt>submitter
   <dd>#{submitter}
   <dt>submitted
   <dd>#{stamp}
   <dt>original repo
   <dd>
-    $maybe (url, branchPart) <- getHttpLink (fsiRepo submission)
+    $maybe (url, branchPart) <- getHttpLink (fsiRepo $ current submission)
-      <code><a href="#{url}">#{repoUrl $ fsiRepo submission}</code></a> / branch <a href="#{url <> branchPart}"><code>#{repoBranch $ fsiRepo submission}</code></a>
+      <code><a href="#{url}">#{repoUrl $ fsiRepo $ current submission}</code></a> / branch <a href="#{url <> branchPart}"><code>#{repoBranch $ fsiRepo $ current submission}</code></a>
     $nothing
-      <code>#{repoUrl $ fsiRepo submission}</code> / branch <code>#{repoBranch $ fsiRepo submission}</code>
+      <code>#{repoUrl $ fsiRepo $ current submission}</code> / branch <code>#{repoBranch $ fsiRepo $ current submission}</code>
-  $if submissionIsPublic $ fsiSubmission submission
+  $if submissionIsPublic $ fsiSubmission $ current submission
     <dt>publicly available at
     <dd><code>#{publicSubmissionRepo}</code> / branch <code>#{publicSubmissionBranch}</code>
     <dt>browsable at
-    <dd><a href="#{browsableUrl}">#{browsableUrl}</a>
+    <dd><a href="#{current browsableUrl}">#{current browsableUrl}</a>
     <dt>clone by
-    <dd><code>git clone --single-branch #{publicSubmissionRepo} -b #{publicSubmissionBranch}</code>
+    <dd><code>git clone --single-branch #{current publicSubmissionRepo} -b #{current publicSubmissionBranch}</code>
-  $if not (null (fsiExternalLinks submission))
+  $if not (null (fsiExternalLinks $ current submission))
     <dt>see also
     <dd>
-      $forall (Entity _ externalLink) <- fsiExternalLinks submission
+      $forall (Entity _ externalLink) <- fsiExternalLinks $ current submission
         <a href="#{externalLinkUrl externalLink}">
            #{fromMaybe (externalLinkUrl externalLink) (externalLinkTitle externalLink)}
         <br>
-  $maybe variant <- mVariantName
+  $maybe variant <- runDiff variantSettings mVariantName
     <dt>file basename
     <dd><tt>#{variant}</tt>
   $nothing

templates/view-variant.hamlet

@@ -3,12 +3,13 @@
    <p class="media-object">
      <span class="glyphicon glyphicon-asterisk" aria-hidden="hidden">
  <div class="media-body">
-  ^{submissionHeader fullSubmissionInfo (Just $ variantName variant)}
+  ^{submissionHeader fullSubmissionInfo}
 
-  $case tableEntryParams entry
+  $case tableEntryParams <$> entry
-    $of []
+    $of OneThing []
+    $of TwoThings [] []
     $of _
-      ^{Table.buildBootstrap paramsTable (map entityVal $ tableEntryParams entry)}
+      ^{Table.buildBootstrap paramsTable (mergeEntryParams $ map entityVal <$> (tableEntryParams <$> entry))}
 
   $forall output <- outputs
     ^{viewOutputWithNonDefaultTestSelected entry tests testSelectedEnt output}