This commit is contained in:
Filip Gralinski 2018-02-13 10:16:03 +01:00 committed by Filip Gralinski
parent 88f69156e7
commit 9d4aab5f2c
3 changed files with 48 additions and 7 deletions

View File

@ -33,7 +33,8 @@ module GEval.Core
EvaluationContext(..), EvaluationContext(..),
ParserSpec(..), ParserSpec(..),
fileAsLineSource, fileAsLineSource,
checkAndGetFiles checkAndGetFiles,
getOutFile
) where ) where
import Data.Conduit import Data.Conduit
@ -154,7 +155,7 @@ getExpectedDirectory :: GEvalSpecification -> FilePath
getExpectedDirectory spec = fromMaybe outDirectory $ gesExpectedDirectory spec getExpectedDirectory spec = fromMaybe outDirectory $ gesExpectedDirectory spec
where outDirectory = gesOutDirectory spec where outDirectory = gesOutDirectory spec
data GEvalSpecialCommand = Init | LineByLine data GEvalSpecialCommand = Init | LineByLine | Diff FilePath
data GEvalOptions = GEvalOptions data GEvalOptions = GEvalOptions
{ geoSpecialCommand :: Maybe GEvalSpecialCommand, { geoSpecialCommand :: Maybe GEvalSpecialCommand,
@ -232,7 +233,7 @@ checkAndGetFiles gevalSpec = do
checkInputFileIfNeeded metric inputFilePath checkInputFileIfNeeded metric inputFilePath
return (inputFilePath, expectedFilePath, outFilePath) return (inputFilePath, expectedFilePath, outFilePath)
where expectedFilePath = expectedTestDirectory </> (gesExpectedFile gevalSpec) where expectedFilePath = expectedTestDirectory </> (gesExpectedFile gevalSpec)
outFilePath = outTestDirectory </> (gesOutFile gevalSpec) outFilePath = getOutFile gevalSpec (gesOutFile gevalSpec)
inputFilePath = expectedTestDirectory </> (gesInputFile gevalSpec) inputFilePath = expectedTestDirectory </> (gesInputFile gevalSpec)
expectedTestDirectory = expectedDirectory </> testName expectedTestDirectory = expectedDirectory </> testName
outTestDirectory = outDirectory </> testName outTestDirectory = outDirectory </> testName
@ -241,6 +242,11 @@ checkAndGetFiles gevalSpec = do
testName = gesTestName gevalSpec testName = gesTestName gevalSpec
metric = gesMetric gevalSpec metric = gesMetric gevalSpec
getOutFile :: GEvalSpecification -> FilePath -> FilePath
getOutFile gevalSpec out = outDirectory </> testName </> out
where outDirectory = gesOutDirectory gevalSpec
testName = gesTestName gevalSpec
checkInputFileIfNeeded :: Metric -> FilePath -> IO () checkInputFileIfNeeded :: Metric -> FilePath -> IO ()
checkInputFileIfNeeded CharMatch inputFilePath = do checkInputFileIfNeeded CharMatch inputFilePath = do
unlessM (D.doesFileExist inputFilePath) $ throwM $ NoInputFile inputFilePath unlessM (D.doesFileExist inputFilePath) $ throwM $ NoInputFile inputFilePath

View File

@ -8,7 +8,8 @@
module GEval.LineByLine module GEval.LineByLine
(runLineByLine (runLineByLine,
runDiff
) where ) where
import GEval.Core import GEval.Core
@ -34,7 +35,6 @@ runLineByLine spec = do
(inputFilePath, expectedFilePath, outFilePath) <- checkAndGetFiles spec (inputFilePath, expectedFilePath, outFilePath) <- checkAndGetFiles spec
gevalLineByLineCore metric inputFilePath expectedFilePath outFilePath consum gevalLineByLineCore metric inputFilePath expectedFilePath outFilePath consum
where metric = gesMetric spec where metric = gesMetric spec
justScore (LineRecord _ _ _ _ score) = score
consum :: Consumer LineRecord (ResourceT IO) () consum :: Consumer LineRecord (ResourceT IO) ()
consum = (CL.map (encodeUtf8 . formatOutput) =$= CC.unlinesAscii =$= CC.stdout) consum = (CL.map (encodeUtf8 . formatOutput) =$= CC.unlinesAscii =$= CC.stdout)
formatOutput (LineRecord inp exp out _ score) = Data.Text.intercalate "\t" [ formatOutput (LineRecord inp exp out _ score) = Data.Text.intercalate "\t" [
@ -44,7 +44,33 @@ runLineByLine spec = do
escapeTabs out] escapeTabs out]
formatScore :: MetricValue -> Text formatScore :: MetricValue -> Text
formatScore = Data.Text.pack . printf "%f" formatScore = Data.Text.pack . printf "%f"
escapeTabs = Data.Text.replace "\t" "<tab>"
runDiff :: FilePath -> GEvalSpecification -> IO ()
runDiff otherOut spec = do
let otherOutFilePath = getOutFile spec otherOut
(inputFilePath, expectedFilePath, outFilePath) <- checkAndGetFiles spec
let sourceA = gevalLineByLineSource metric inputFilePath expectedFilePath outFilePath
let sourceB = gevalLineByLineSource metric inputFilePath expectedFilePath otherOutFilePath
runResourceT $
((getZipSource $ (,)
<$> ZipSource sourceA
<*> ZipSource sourceB) $$ consum)
where metric = gesMetric spec
consum :: Consumer (LineRecord, LineRecord) (ResourceT IO) ()
consum = (CL.filter shouldBeShown =$= CL.map (encodeUtf8 . formatOutput) =$= CC.unlinesAscii =$= CC.stdout)
shouldBeShown (LineRecord _ _ outA _ scoreA, LineRecord _ _ outB _ scoreB) =
outA /= outB && scoreA /= scoreB
formatOutput (LineRecord inp exp outA _ scoreA, LineRecord _ _ outB _ scoreB) = Data.Text.intercalate "\t" [
formatScoreDiff (scoreB - scoreA),
escapeTabs inp,
escapeTabs exp,
escapeTabs outA,
escapeTabs outB]
formatScoreDiff :: Double -> Text
formatScoreDiff = Data.Text.pack . printf "%f"
escapeTabs :: Text -> Text
escapeTabs = Data.Text.replace "\t" "<tab>"
gevalLineByLineCore :: Metric -> FilePath -> FilePath -> FilePath -> Sink LineRecord (ResourceT IO) () -> IO () gevalLineByLineCore :: Metric -> FilePath -> FilePath -> FilePath -> Sink LineRecord (ResourceT IO) () -> IO ()
gevalLineByLineCore metric inputFilePath expectedFilePath outFilePath consum = gevalLineByLineCore metric inputFilePath expectedFilePath outFilePath consum =

View File

@ -34,7 +34,13 @@ optionsParser = GEvalOptions
(flag' LineByLine (flag' LineByLine
( long "line-by-line" ( long "line-by-line"
<> short 'l' <> short 'l'
<> help "Give scores for each line rather than the whole test set" ))) <> help "Give scores for each line rather than the whole test set" ))
<|>
(Diff <$> strOption
( long "diff"
<> short 'd'
<> metavar "OTHER-OUT"
<> help "compare results")))
<*> specParser <*> specParser
precisionArgParser :: Parser Int precisionArgParser :: Parser Int
@ -151,6 +157,9 @@ runGEval''' (Just Init) spec = do
runGEval''' (Just LineByLine) spec = do runGEval''' (Just LineByLine) spec = do
runLineByLine spec runLineByLine spec
return Nothing return Nothing
runGEval''' (Just (Diff otherOut)) spec = do
runDiff otherOut spec
return Nothing
initChallenge :: GEvalSpecification -> IO () initChallenge :: GEvalSpecification -> IO ()
initChallenge spec = case gesExpectedDirectory spec of initChallenge spec = case gesExpectedDirectory spec of