forked from filipg/gonito
WIP
This commit is contained in:
parent
db8c1d6917
commit
b3c259a478
113
Data/Diff.hs
Normal file
113
Data/Diff.hs
Normal file
@ -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
|
||||
220
Handler/Query.hs
220
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|<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 "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,23 +402,26 @@ 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 testName = T.unpack testSet
|
||||
|
||||
let spec = GEvalSpecification {
|
||||
gesOutDirectory = repoDir,
|
||||
gesOutDirectory = current repoDir,
|
||||
gesExpectedDirectory = Nothing,
|
||||
gesTestName = (T.unpack testSet),
|
||||
gesTestName = testName,
|
||||
gesSelector = Nothing,
|
||||
gesOutFile = outFile,
|
||||
gesAltOutFiles = Nothing,
|
||||
@ -335,20 +441,31 @@ viewOutputWithNonDefaultTestSelected entry tests mainTest (outputHash, testSet)
|
||||
gesOutHeader = Nothing,
|
||||
gesShowPreprocessed = True }
|
||||
|
||||
result <- liftIO $ runLineByLineGeneralized FirstTheWorst spec (\_ -> CL.take maximumNumberOfItemsToBeShown)
|
||||
return $ Just $ zip [1..] result
|
||||
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
|
||||
|
||||
@ -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
|
||||
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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -58,6 +58,7 @@ library
|
||||
Handler.Evaluate
|
||||
Data.SubmissionConditions
|
||||
Gonito.ExtractMetadata
|
||||
Data.Diff
|
||||
|
||||
if flag(dev) || flag(library-only)
|
||||
cpp-options: -DDEVELOPMENT
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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> </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)
|
||||
<code><a href="#{url}">#{repoUrl $ fsiRepo submission}</code></a> / branch <a href="#{url <> branchPart}"><code>#{repoBranch $ fsiRepo submission}</code></a>
|
||||
$maybe (url, branchPart) <- getHttpLink (fsiRepo $ current submission)
|
||||
<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>
|
||||
$if submissionIsPublic $ fsiSubmission submission
|
||||
<code>#{repoUrl $ fsiRepo $ current submission}</code> / branch <code>#{repoBranch $ fsiRepo $ current submission}</code>
|
||||
$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>
|
||||
$if not (null (fsiExternalLinks submission))
|
||||
<dd><code>git clone --single-branch #{current publicSubmissionRepo} -b #{current publicSubmissionBranch}</code>
|
||||
$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
|
||||
|
||||
@ -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
|
||||
$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}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user