From b3c259a478bcb3f5f5abb4180c6808c7e576f4cf Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Sat, 5 Sep 2020 23:26:53 +0200 Subject: [PATCH] WIP --- Data/Diff.hs | 113 +++++++++++++ Handler/Query.hs | 262 +++++++++++++++++++++-------- Handler/Tables.hs | 19 ++- config/routes | 1 + gonito.cabal | 1 + templates/query-result.hamlet | 2 +- templates/submission-header.hamlet | 22 +-- templates/view-variant.hamlet | 9 +- 8 files changed, 340 insertions(+), 89 deletions(-) create mode 100644 Data/Diff.hs diff --git a/Data/Diff.hs b/Data/Diff.hs new file mode 100644 index 0000000..9ab5b93 --- /dev/null +++ b/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 diff --git a/Handler/Query.hs b/Handler/Query.hs index 39fdf8e..bb55073 100644 --- a/Handler/Query.hs +++ b/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.Common (FormattingOptions(..)) +import GEval.LineByLine (runLineByLineGeneralized, runDiffGeneralized, LineRecord(..)) +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 - setTitle "Variant" - $(widgetFile "view-variant") + return $ ViewVariantData (fullSubmissionInfo, Just $ variantName variant) entry tests outputs 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|#{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 "Value" parameterValue + ++ Table.text "Parameter" fst + ++ 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 - isViewable <- handlerToWidget $ runDB $ checkWhetherVisible (entityVal $ tableEntrySubmission entry) mauthId - challenge <- handlerToWidget $ runDB $ get404 $ submissionChallenge $ entityVal $ tableEntrySubmission entry + let theStamp = submissionStamp $ entityVal $ tableEntrySubmission $ current entry + challenge <- handlerToWidget $ runDB $ get404 $ submissionChallenge $ entityVal $ tableEntrySubmission $ current 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) - case mRepoDir of - Just repoDir -> do - outFile' <- liftIO $ lookForCompressedFiles (repoDir (T.unpack variant) <.> "tsv") - let outFile = takeFileName outFile' + outPaths <- mapM (getOut mauthId) entry + case current outPaths of + Just _ -> do + let repoDir = fst <$> fromJust <$> outPaths + let outFilePath = snd <$> fromJust <$> outPaths + let outFile = takeFileName $ current outFilePath - let spec = GEvalSpecification { - 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 } + let testName = T.unpack testSet - result <- liftIO $ runLineByLineGeneralized FirstTheWorst spec (\_ -> CL.take maximumNumberOfItemsToBeShown) - return $ Just $ zip [1..] result - Nothing -> return Nothing + let spec = GEvalSpecification { + gesOutDirectory = current repoDir, + 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 "expected output" ((\(LineRecord _ expected _ _ _) -> expected) . snd) - ++ theLimitedTextCell "actual output" ((\(LineRecord _ _ out _ _) -> out) . snd) - ++ resultCell test (fakeEvaluation . (\(LineRecord _ _ _ _ score) -> score) . snd) + ++ theLimitedTextCell "input" (((\(DiffLineRecord inp _ _ _) -> inp) . snd)) + ++ theLimitedTextCell "expected output" ((\(DiffLineRecord _ expected _ _) -> expected) . snd) + ++ theLimitedDiffTextCell "actual output" (fmap fst . (\(DiffLineRecord _ _ out _) -> out) . 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 submission mVariantName = +submissionHeader :: Diff (FullSubmissionInfo, Maybe Text) -> WidgetFor App () +submissionHeader param = $(widgetFile "submission-header") - where commitSha1AsText = fromSHA1ToText $ submissionCommit $ fsiSubmission submission - submitter = formatSubmitter $ fsiUser submission - publicSubmissionBranch = getPublicSubmissionBranch $ fsiSubmissionId submission - publicSubmissionRepo = getReadOnlySubmissionUrl (fsiScheme submission) (fsiChallengeRepo submission) $ challengeName $ fsiChallenge submission - browsableUrl = browsableGitRepoBranch (fsiScheme submission) (fsiChallengeRepo submission) (challengeName $ fsiChallenge submission) publicSubmissionBranch - stamp = T.pack $ show $ submissionStamp $ fsiSubmission submission + where variantSettings = ("out", ()) + submission = fst <$> param + mVariantName = snd <$> param + commitSha1AsText = fromSHA1ToText <$> submissionCommit <$> fsiSubmission <$> submission + submitter = formatSubmitter <$> fsiUser <$> 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 diff --git a/Handler/Tables.hs b/Handler/Tables.hs index a958d6a..d0b4536 100644 --- a/Handler/Tables.hs +++ b/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|#{textLimited softLimit v}|] + limitedTextCell :: Text -> Int -> Int -> (a -> Text) -> Table site a limitedTextCell h softLimit hardLimit textFun = Table.widget h ( - \v -> [whamlet|#{textLimited softLimit $ textFun v}|]) + \v -> limitedWidget softLimit hardLimit (textFun v)) theLimitedTextCell :: Text -> (a -> Text) -> Table site a -theLimitedTextCell h textFun = limitedTextCell h softLimit hardLimit textFun - where softLimit = 140 - hardLimit = 5 * softLimit +theLimitedTextCell h textFun = limitedTextCell h textCellSoftLimit textCellHardLimit textFun +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 diff --git a/config/routes b/config/routes index 79c4377..c6901df 100644 --- a/config/routes +++ b/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 diff --git a/gonito.cabal b/gonito.cabal index d21b731..effdce3 100644 --- a/gonito.cabal +++ b/gonito.cabal @@ -58,6 +58,7 @@ library Handler.Evaluate Data.SubmissionConditions Gonito.ExtractMetadata + Data.Diff if flag(dev) || flag(library-only) cpp-options: -DDEVELOPMENT diff --git a/templates/query-result.hamlet b/templates/query-result.hamlet index acbd89f..19cd5ca 100644 --- a/templates/query-result.hamlet +++ b/templates/query-result.hamlet @@ -3,7 +3,7 @@

- ^{submissionHeader submission Nothing} + ^{submissionHeader (OneThing (submission, Nothing))} ^{resultTable (Entity (fsiSubmissionId submission) (fsiSubmission submission))} $if not (null (fsiSuperSubmissions submission)) diff --git a/templates/submission-header.hamlet b/templates/submission-header.hamlet index 62e9dff..4e4db25 100644 --- a/templates/submission-header.hamlet +++ b/templates/submission-header.hamlet @@ -1,36 +1,36 @@
#{commitSha1AsText} -
^{fragmentWithTags (submissionDescription $ fsiSubmission submission) (map fst $ fsiTags submission)} +
^{fragmentWithTags (submissionDescription $ fsiSubmission $ current submission) (map fst $ fsiTags $ current submission)}

 

challenge -
#{challengeTitle $ fsiChallenge submission} +
#{challengeTitle $ fsiChallenge $ current submission}
submitter
#{submitter}
submitted
#{stamp}
original repo
- $maybe (url, branchPart) <- getHttpLink (fsiRepo submission) - #{repoUrl $ fsiRepo submission} / branch #{repoBranch $ fsiRepo submission} + $maybe (url, branchPart) <- getHttpLink (fsiRepo $ current submission) + #{repoUrl $ fsiRepo $ current submission} / branch #{repoBranch $ fsiRepo $ current submission} $nothing - #{repoUrl $ fsiRepo submission} / branch #{repoBranch $ fsiRepo submission} - $if submissionIsPublic $ fsiSubmission submission + #{repoUrl $ fsiRepo $ current submission} / branch #{repoBranch $ fsiRepo $ current submission} + $if submissionIsPublic $ fsiSubmission $ current submission
publicly available at
#{publicSubmissionRepo} / branch #{publicSubmissionBranch}
browsable at -
#{browsableUrl} +
#{current browsableUrl}
clone by -
git clone --single-branch #{publicSubmissionRepo} -b #{publicSubmissionBranch} - $if not (null (fsiExternalLinks submission)) +
git clone --single-branch #{current publicSubmissionRepo} -b #{current publicSubmissionBranch} + $if not (null (fsiExternalLinks $ current submission))
see also
- $forall (Entity _ externalLink) <- fsiExternalLinks submission + $forall (Entity _ externalLink) <- fsiExternalLinks $ current submission #{fromMaybe (externalLinkUrl externalLink) (externalLinkTitle externalLink)}
- $maybe variant <- mVariantName + $maybe variant <- runDiff variantSettings mVariantName
file basename
#{variant} $nothing diff --git a/templates/view-variant.hamlet b/templates/view-variant.hamlet index e7d7b15..900ba2b 100644 --- a/templates/view-variant.hamlet +++ b/templates/view-variant.hamlet @@ -3,12 +3,13 @@

- ^{submissionHeader fullSubmissionInfo (Just $ variantName variant)} + ^{submissionHeader fullSubmissionInfo} - $case tableEntryParams entry - $of [] + $case tableEntryParams <$> entry + $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}