mirror of
https://github.com/ilyakooo0/Idris-dev.git
synced 2024-09-17 11:47:20 +03:00
Port the test infrastructure to Tasty
(This is WIP) [ci skip] `runtest.hs` is replaced by `TestRun.hs`. This program imports `TestData.hs` which holds the tests metadata, then turns it into tests usable by Tasty. The functional changes are the following: - The tasty framework provides a pretty output by default (colors, individual timings, proper indentation). Tests can run in parallel but the output is still deterministic. - Tasty.Golden does the heavy lifting, i.e. comparing outputs and measuring time spent. - Output is captured through a pipe connected to a bash process running the `run` script for each test ; this is implemented by the `runTest` function - Tests are organised in families, reflecting directories' prefixes. They are listed in `testFamiliesData` in `TestData.hs`. - Each test must be registered in `testFamiliesData` under its own family. - A custom option has been implemented to run the test suite with the node code generator. The list of compatible code generators for each test is provided in `testFamiliesData`. - Tasty.Rerun provides rudimentary incremental testing. The cache is in the `.tasty-rerun-log` file, which is therefore added to `.gitignore`. The previous Makefile in `test` has disappeared in favour of passing arguments to the test program. Note that this commit disables testing because a compatibility layer for `cabal test` must be implemented first. This is necessary because the test program requires external dependencies. However, you should be able to run the tests with `stack test`.
This commit is contained in:
gpyh
parent
4e696581c0
commit
54b94b9184
1
.gitignore
vendored
1
.gitignore
vendored
@ -22,6 +22,7 @@ test/*[0-9][0-9][0-9]/output
|
||||
test/*[0-9][0-9][0-9]/*.exe
|
||||
test/runtest.exe
|
||||
test/runtest
|
||||
.tasty-rerun-log
|
||||
|
||||
# Haskell build tools
|
||||
cabal-dev/
|
||||
|
||||
6
Makefile
6
Makefile
@ -20,13 +20,13 @@ build: dist/setup-config
|
||||
test: doc test_c
|
||||
|
||||
test_c:
|
||||
$(MAKE) -C test IDRIS=../dist/build/idris/idris test
|
||||
echo "test_c not supported"
|
||||
|
||||
test_js:
|
||||
$(MAKE) -C test IDRIS=../dist/build/idris/idris test_js
|
||||
echo "test_js not supported"
|
||||
|
||||
test_timed:
|
||||
$(MAKE) -C test IDRIS=../dist/build/idris/idris time
|
||||
echo "test_timed not supported"
|
||||
|
||||
lib_clean:
|
||||
$(MAKE) -C libs IDRIS=../../dist/build/idris/idris RTS=../../dist/build/rts/libidris_rts clean
|
||||
|
||||
16
idris.cabal
16
idris.cabal
@ -156,8 +156,8 @@ Extra-source-files:
|
||||
libs/pruviloj/Pruviloj/Derive/*.idr
|
||||
libs/pruviloj/Pruviloj/Internals/*.idr
|
||||
|
||||
test/Makefile
|
||||
test/runtest.hs
|
||||
test/TestRun.hs
|
||||
test/TestData.hs
|
||||
|
||||
test/regression001/run
|
||||
test/regression001/expected
|
||||
@ -1158,7 +1158,8 @@ Executable idris
|
||||
|
||||
Test-suite regression-and-sanity-tests
|
||||
Type: exitcode-stdio-1.0
|
||||
Main-is: runtest.hs
|
||||
Main-is: TestRun.hs
|
||||
Other-modules: TestData
|
||||
hs-source-dirs: test
|
||||
|
||||
Build-depends: idris
|
||||
@ -1169,7 +1170,16 @@ Test-suite regression-and-sanity-tests
|
||||
, filepath
|
||||
, directory
|
||||
, haskeline >= 0.7
|
||||
, optparse-applicative >= 0.11 && < 0.13
|
||||
, tagged
|
||||
, tasty >= 0.8
|
||||
, tasty-golden >= 2.0
|
||||
, tasty-rerun >= 1.0.0
|
||||
, bytestring
|
||||
, transformers
|
||||
if impl(ghc < 7.10)
|
||||
Extensions: DeriveDataTypeable
|
||||
|
||||
|
||||
ghc-prof-options: -auto-all -caf-all
|
||||
ghc-options: -threaded -rtsopts -funbox-strict-fields
|
||||
|
||||
@ -1,34 +0,0 @@
|
||||
.PHONY: test test_js time update diff distclean $(TESTS)
|
||||
|
||||
TESTS = $(sort $(patsubst %/,%.test,$(wildcard */)))
|
||||
|
||||
test: $(TESTS)
|
||||
|
||||
|
||||
info: runtest
|
||||
@./runtest all
|
||||
|
||||
%.test: runtest
|
||||
@./runtest $(patsubst %.test,%,$@) -q
|
||||
|
||||
test_js: runtest
|
||||
@./runtest without tutorial007 sugar004 reg029 reg052 io001 dsl002 io003 effects001 effects002 basic007 basic011 ffi006 ffi007 ffi008 primitives005 primitives006 views003 opts --codegen node
|
||||
|
||||
update: runtest
|
||||
@./runtest all -u
|
||||
|
||||
diff: runtest
|
||||
@./runtest all -d
|
||||
|
||||
time: runtest
|
||||
@./runtest all -t
|
||||
|
||||
distclean:
|
||||
@rm runtest
|
||||
@rm -f *~
|
||||
@rm -f */output
|
||||
|
||||
|
||||
runtest:
|
||||
@ghc --make runtest.hs
|
||||
@rm runtest.o runtest.hi
|
||||
300
test/TestData.hs
Normal file
300
test/TestData.hs
Normal file
@ -0,0 +1,300 @@
|
||||
module TestData where
|
||||
|
||||
import Data.IntMap as IMap
|
||||
import Data.Map.Strict as Map
|
||||
import Data.Set as Set
|
||||
|
||||
data Codegen = C | JS deriving (Show, Eq, Ord)
|
||||
type Index = Int
|
||||
data CompatCodegen = ANY | C_CG | NODE_CG | NONE
|
||||
|
||||
-- A TestFamily groups tests that share the same theme
|
||||
data TestFamily = TestFamily {
|
||||
-- A shorter lowcase name to use in filenames
|
||||
id :: String,
|
||||
-- A proper name for the test family that will be displayed
|
||||
name :: String,
|
||||
-- A map of test metadata:
|
||||
-- - The key is the index (>=1 && <1000)
|
||||
-- - The value is the set of compatible code generators,
|
||||
-- or Nothing if the test doesn't depend on a code generator
|
||||
tests :: IntMap (Maybe (Set Codegen))
|
||||
} deriving (Show)
|
||||
|
||||
toCodegenSet :: CompatCodegen -> Maybe (Set Codegen)
|
||||
toCodegenSet compatCodegen = fmap Set.fromList mList where
|
||||
mList = case compatCodegen of
|
||||
ANY -> Just [ C, JS ]
|
||||
C_CG -> Just [ C ]
|
||||
NODE_CG -> Just [ JS ]
|
||||
NONE -> Nothing
|
||||
|
||||
testFamilies :: [TestFamily]
|
||||
testFamilies = fmap instanciate testFamiliesData where
|
||||
instanciate (id, name, testsData) = TestFamily id name tests where
|
||||
tests = IMap.fromList (fmap makeSetCodegen testsData)
|
||||
makeSetCodegen (index, codegens) = (index, toCodegenSet codegens)
|
||||
|
||||
testFamiliesForCodegen :: Codegen -> [TestFamily]
|
||||
testFamiliesForCodegen codegen =
|
||||
fmap (\testFamily -> testFamily {tests = IMap.filter f (tests testFamily)})
|
||||
testFamilies
|
||||
where
|
||||
f mCodegens = case mCodegens of
|
||||
Just codegens -> Set.member codegen codegens
|
||||
Nothing -> True
|
||||
|
||||
-- The data to instanciate testFamilies
|
||||
-- The first column is the id
|
||||
-- The second column is the proper name (the prefix of the subfolders)
|
||||
-- The third column is the data for each test
|
||||
testFamiliesData :: [(String, String, [(Index, CompatCodegen)])]
|
||||
testFamiliesData = [
|
||||
("basic", "Basic",
|
||||
[ ( 1, ANY ),
|
||||
( 2, ANY ),
|
||||
( 3, ANY ),
|
||||
( 4, ANY ),
|
||||
( 5, ANY ),
|
||||
( 6, ANY ),
|
||||
( 7, C_CG ),
|
||||
( 8, ANY ),
|
||||
( 9, ANY ),
|
||||
( 10, ANY ),
|
||||
( 11, C_CG ),
|
||||
( 12, ANY ),
|
||||
( 13, ANY ),
|
||||
( 14, ANY ),
|
||||
( 15, ANY ),
|
||||
( 16, ANY ),
|
||||
( 17, ANY ),
|
||||
( 18, ANY )]),
|
||||
("bignum", "Bignum",
|
||||
[ ( 1, ANY ),
|
||||
( 2, ANY )]),
|
||||
("bounded", "Bounded",
|
||||
[ ( 1, ANY )]),
|
||||
("corecords", "Corecords",
|
||||
[ ( 1, ANY ),
|
||||
( 2, ANY )]),
|
||||
("delab", "De-elaboration",
|
||||
[ ( 1, ANY )]),
|
||||
("directives", "Directives",
|
||||
[ ( 1, ANY ),
|
||||
( 2, ANY )]),
|
||||
("disambig", "Disambiguation",
|
||||
[ ( 2, ANY )]),
|
||||
("docs", "Documentation",
|
||||
[ ( 1, ANY ),
|
||||
( 2, ANY ),
|
||||
( 3, ANY ),
|
||||
( 4, ANY ),
|
||||
( 5, ANY )]),
|
||||
("dsl", "DSL",
|
||||
[ ( 1, ANY ),
|
||||
( 2, C_CG ),
|
||||
( 3, ANY ),
|
||||
( 4, ANY )]),
|
||||
("effects", "Effects",
|
||||
[ ( 1, C_CG ),
|
||||
( 2, C_CG ),
|
||||
( 3, ANY ),
|
||||
( 4, ANY ),
|
||||
( 5, ANY )]),
|
||||
("error", "Errors",
|
||||
[ ( 1, ANY ),
|
||||
( 2, ANY ),
|
||||
( 3, ANY ),
|
||||
( 4, ANY ),
|
||||
( 5, ANY ),
|
||||
( 6, ANY ),
|
||||
( 7, ANY ),
|
||||
( 8, ANY )]),
|
||||
("ffi", "FFI",
|
||||
[ ( 1, ANY ),
|
||||
( 2, ANY ),
|
||||
( 3, ANY ),
|
||||
( 4, ANY ),
|
||||
( 5, ANY ),
|
||||
( 6, C_CG ),
|
||||
( 7, C_CG ),
|
||||
( 8, C_CG )]),
|
||||
("folding", "Folding",
|
||||
[ ( 1, ANY )]),
|
||||
("idrisdoc", "Idris documentation",
|
||||
[ ( 1, ANY ),
|
||||
( 2, ANY ),
|
||||
( 3, ANY ),
|
||||
( 4, ANY ),
|
||||
( 5, ANY ),
|
||||
( 6, ANY ),
|
||||
( 7, ANY ),
|
||||
( 8, ANY ),
|
||||
( 9, ANY )]),
|
||||
("interactive", "Interactive editing",
|
||||
[ ( 1, ANY ),
|
||||
( 2, ANY ),
|
||||
( 3, ANY ),
|
||||
( 4, ANY ),
|
||||
( 5, ANY ),
|
||||
( 6, ANY ),
|
||||
( 7, ANY ),
|
||||
( 8, ANY ),
|
||||
( 9, ANY ),
|
||||
( 10, ANY ),
|
||||
( 11, ANY ),
|
||||
( 12, ANY ),
|
||||
( 13, ANY )]),
|
||||
("interfaces", "Interfaces",
|
||||
[ ( 1, ANY ),
|
||||
( 2, ANY ),
|
||||
( 3, ANY ),
|
||||
( 4, ANY ),
|
||||
( 5, ANY ),
|
||||
( 6, ANY )]),
|
||||
("io", "IO monad",
|
||||
[ ( 1, C_CG ),
|
||||
( 2, ANY ),
|
||||
( 3, C_CG )]),
|
||||
("literate", "Literate programming",
|
||||
[ ( 1, ANY )]),
|
||||
("meta", "Meta-programming",
|
||||
[ ( 1, ANY ),
|
||||
( 2, ANY ),
|
||||
( 3, ANY ),
|
||||
( 4, ANY )]),
|
||||
("pkg", "Packages",
|
||||
[ ( 1, ANY ),
|
||||
( 2, ANY ),
|
||||
( 3, ANY ),
|
||||
( 4, ANY )]),
|
||||
("primitives", "Primitive types",
|
||||
[ ( 1, ANY ),
|
||||
( 2, ANY ),
|
||||
( 3, ANY ),
|
||||
( 5, C_CG ),
|
||||
( 6, C_CG )]),
|
||||
("proof", "Theorem proving",
|
||||
[ ( 1, ANY ),
|
||||
( 2, ANY ),
|
||||
( 3, ANY ),
|
||||
( 4, ANY ),
|
||||
( 5, ANY ),
|
||||
( 6, ANY ),
|
||||
( 7, ANY ),
|
||||
( 8, ANY ),
|
||||
( 9, ANY ),
|
||||
( 10, ANY ),
|
||||
( 11, ANY )]),
|
||||
("proofsearch", "Proof search",
|
||||
[ ( 1, ANY ),
|
||||
( 2, ANY ),
|
||||
( 3, ANY )]),
|
||||
("pruviloj", "Pruviloj",
|
||||
[ ( 1, ANY )]),
|
||||
("quasiquote", "Quasiquotations",
|
||||
[ ( 1, ANY ),
|
||||
( 2, ANY ),
|
||||
( 3, ANY ),
|
||||
( 4, ANY ),
|
||||
( 5, ANY ),
|
||||
( 6, ANY )]),
|
||||
("records", "Records",
|
||||
[ ( 1, ANY ),
|
||||
( 2, ANY ),
|
||||
( 3, ANY ),
|
||||
( 4, ANY ),
|
||||
( 5, ANY )]),
|
||||
("reg", "Regressions",
|
||||
[ ( 2, ANY ),
|
||||
( 3, ANY ),
|
||||
( 4, ANY ),
|
||||
( 5, ANY ),
|
||||
( 6, ANY ),
|
||||
( 7, ANY ),
|
||||
( 10, ANY ),
|
||||
( 13, ANY ),
|
||||
( 16, ANY ),
|
||||
( 17, ANY ),
|
||||
( 18, ANY ),
|
||||
( 20, ANY ),
|
||||
( 23, ANY ),
|
||||
( 24, ANY ),
|
||||
( 25, ANY ),
|
||||
( 27, ANY ),
|
||||
( 28, ANY ),
|
||||
( 29, C_CG ),
|
||||
( 31, ANY ),
|
||||
( 32, ANY ),
|
||||
( 34, ANY ),
|
||||
( 35, ANY ),
|
||||
( 39, ANY ),
|
||||
( 40, ANY ),
|
||||
( 41, ANY ),
|
||||
( 42, ANY ),
|
||||
( 44, ANY ),
|
||||
( 45, ANY ),
|
||||
( 48, ANY ),
|
||||
( 49, ANY ),
|
||||
( 50, ANY ),
|
||||
( 52, C_CG ),
|
||||
( 54, ANY ),
|
||||
( 55, ANY ),
|
||||
( 56, ANY ),
|
||||
( 67, ANY ),
|
||||
( 68, ANY ),
|
||||
( 69, ANY ),
|
||||
( 70, ANY ),
|
||||
( 72, ANY ),
|
||||
( 75, ANY )]),
|
||||
("regression", "Regression (loner)",
|
||||
[ ( 1 , ANY )]),
|
||||
("sourceLocation", "Source location",
|
||||
[ ( 1 , ANY )]),
|
||||
("sugar", "Syntactic sugar",
|
||||
[ ( 1, ANY ),
|
||||
( 2, ANY ),
|
||||
( 3, ANY ),
|
||||
( 4, C_CG ),
|
||||
( 5, ANY )]),
|
||||
("syntax", "Syntax extensions",
|
||||
[ ( 1, ANY ),
|
||||
( 2, ANY )]),
|
||||
("tactics", "Tactics",
|
||||
[ ( 1, ANY )]),
|
||||
("totality", "Totality checking",
|
||||
[ ( 1, ANY ),
|
||||
( 2, ANY ),
|
||||
( 3, ANY ),
|
||||
( 4, ANY ),
|
||||
( 5, ANY ),
|
||||
( 6, ANY ),
|
||||
( 7, ANY ),
|
||||
( 8, ANY ),
|
||||
( 9, ANY ),
|
||||
( 10, ANY ),
|
||||
( 11, ANY ),
|
||||
( 12, ANY ),
|
||||
( 13, ANY ),
|
||||
( 14, ANY ),
|
||||
( 15, ANY )]),
|
||||
("tutorial", "Tutorial examples",
|
||||
[ ( 1, ANY ),
|
||||
( 2, ANY ),
|
||||
( 3, ANY ),
|
||||
( 4, ANY ),
|
||||
( 5, ANY ),
|
||||
( 6, ANY ),
|
||||
( 7, C_CG )]),
|
||||
("unique", "Uniqueness types",
|
||||
[ ( 1, ANY ),
|
||||
( 2, ANY ),
|
||||
( 3, ANY )]),
|
||||
("universes", "Universes",
|
||||
[ ( 1, ANY ),
|
||||
( 2, ANY )]),
|
||||
("views", "Views",
|
||||
[ ( 1, ANY ),
|
||||
( 2, ANY ),
|
||||
( 3, C_CG )])]
|
||||
|
||||
128
test/TestRun.hs
Normal file
128
test/TestRun.hs
Normal file
@ -0,0 +1,128 @@
|
||||
module Main where
|
||||
|
||||
import Control.Monad
|
||||
import Data.Typeable
|
||||
import Data.Proxy
|
||||
import Data.List
|
||||
import Data.Map.Strict as Map
|
||||
import Data.IntSet as ISet
|
||||
import Data.IntMap as IMap
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Char8 as BSC
|
||||
|
||||
import System.Directory
|
||||
import System.Environment
|
||||
import System.Process
|
||||
import System.Info
|
||||
import System.IO
|
||||
import System.FilePath ((</>))
|
||||
import Options.Applicative
|
||||
import Test.Tasty
|
||||
import Test.Tasty.Golden
|
||||
import Test.Tasty.Golden.Advanced
|
||||
import Test.Tasty.Runners
|
||||
import Test.Tasty.Options
|
||||
import Test.Tasty.Ingredients.Rerun
|
||||
|
||||
import TestData
|
||||
|
||||
--------------------------------------------------------------------- [ Config ]
|
||||
|
||||
type Flags = [String]
|
||||
|
||||
-- Add arguments to calls of idris executable
|
||||
idrisFlags :: Flags
|
||||
idrisFlags = []
|
||||
|
||||
testDirectory :: String
|
||||
testDirectory = "test"
|
||||
|
||||
-------------------------------------------------------------------- [ Options ]
|
||||
|
||||
-- The `--node` option makes idris use the node code generator
|
||||
-- As a consequence, incompatible tests are removed
|
||||
|
||||
newtype NodeOpt = NodeOpt Bool deriving (Eq, Ord, Typeable)
|
||||
|
||||
nodeArg = "node"
|
||||
nodeHelp = "Performs the tests with the node code generator"
|
||||
instance IsOption NodeOpt where
|
||||
defaultValue = NodeOpt False
|
||||
parseValue = fmap NodeOpt . safeRead
|
||||
optionName = return nodeArg
|
||||
optionHelp = return nodeHelp
|
||||
optionCLParser = fmap NodeOpt $ switch (long nodeArg <> help nodeHelp)
|
||||
|
||||
ingredients :: [Ingredient]
|
||||
ingredients = [rerunningTests [consoleTestReporter],
|
||||
includingOptions [Option (Proxy :: Proxy NodeOpt)] ]
|
||||
|
||||
----------------------------------------------------------------------- [ Core ]
|
||||
|
||||
-- Compare a given file contents against the golden file contents
|
||||
-- A ripoff of goldenVsFile from Tasty.Golden
|
||||
test :: String -> String -> IO () -> TestTree
|
||||
test name path act =
|
||||
goldenTest name (BS.readFile ref) (act >> BS.readFile new) cmp upd
|
||||
where
|
||||
ref = path </> "expected"
|
||||
new = path </> "output"
|
||||
cmp x y = return $ if x == y then Nothing
|
||||
else Just $ printDiff (ref, x) (new, y)
|
||||
upd = BS.writeFile ref
|
||||
|
||||
-- Takes the filepath and content of `expected` and `output`
|
||||
-- and formats an error message stating their difference
|
||||
printDiff :: (String, BS.ByteString) -> (String, BS.ByteString) -> String
|
||||
printDiff (ref, x) (new, y) =
|
||||
let refcnt = BSC.unpack x
|
||||
newcnt = BSC.unpack y
|
||||
printContent cnt =
|
||||
if Data.List.null cnt
|
||||
then " is empty...\n"
|
||||
else " is: \n" ++ unlines (fmap ((++) " ") (lines cnt))
|
||||
in
|
||||
"Test mismatch!\n" ++
|
||||
"Golden file " ++ ref ++ printContent refcnt ++
|
||||
"However, " ++ new ++ printContent newcnt
|
||||
|
||||
-- Should always output a 3-charater string from a postive Int
|
||||
indexToString :: Int -> String
|
||||
indexToString index = let str = show index in
|
||||
(replicate (3 - length str) '0') ++ str
|
||||
|
||||
-- Turns the collection of TestFamily into actual tests usable by Tasty
|
||||
mkGoldenTests :: [TestFamily] -> Flags -> TestTree
|
||||
mkGoldenTests testFamilies flags =
|
||||
testGroup "Regression and sanity tests"
|
||||
(fmap mkTestFamily testFamilies)
|
||||
where
|
||||
mkTestFamily (TestFamily id name tests) =
|
||||
testGroup name (fmap (mkTest id) (IMap.keys tests))
|
||||
mkTest id index =
|
||||
let testname = id ++ indexToString index
|
||||
path = testDirectory </> testname
|
||||
in
|
||||
test testname path (runTest path flags)
|
||||
|
||||
-- Runs a test script
|
||||
-- "bash" needed because Haskell has cmd as the default shell on windows, and
|
||||
-- we also want to run the process with another current directory, so we get
|
||||
-- this thing.
|
||||
runTest :: String -> Flags -> IO ()
|
||||
runTest path flags = do
|
||||
let run = (proc "bash" ("run" : flags)) {cwd = Just path,
|
||||
std_out = CreatePipe}
|
||||
(_, output, _) <- readCreateProcessWithExitCode run ""
|
||||
writeFile (path </> "output") output
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
defaultMainWithIngredients ingredients $
|
||||
askOption $ \(NodeOpt node) ->
|
||||
let (codegen, flags) = if node then (JS, ["--codegen", "node"])
|
||||
else (C , [])
|
||||
in
|
||||
mkGoldenTests (testFamiliesForCodegen codegen)
|
||||
(flags ++ idrisFlags)
|
||||
|
||||
230
test/runtest.hs
230
test/runtest.hs
@ -1,230 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Main where
|
||||
|
||||
import Control.Monad
|
||||
import Data.Char
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import qualified Data.Set as S
|
||||
import Data.Time.Clock
|
||||
import System.Directory
|
||||
import System.Environment
|
||||
import System.FilePath
|
||||
import System.Exit
|
||||
import System.Info
|
||||
import System.IO
|
||||
import System.Process
|
||||
|
||||
-- Because GHC earlier than 7.8 lacks setEnv
|
||||
-- Install the setenv package on Windows.
|
||||
#if __GLASGOW_HASKELL__ < 708
|
||||
#ifndef mingw32_HOST_OS
|
||||
import qualified System.Posix.Env as PE(setEnv)
|
||||
|
||||
setEnv k v = PE.setEnv k v True
|
||||
#else
|
||||
import System.SetEnv(setEnv)
|
||||
#endif
|
||||
#endif
|
||||
|
||||
data Flag = Update | Diff | ShowOutput | Quiet | Time deriving (Eq, Show, Ord)
|
||||
|
||||
type Flags = S.Set Flag
|
||||
|
||||
data Status = Success | Failure | Updated deriving (Eq, Show)
|
||||
|
||||
data Config = Config {
|
||||
flags :: Flags,
|
||||
idrOpts :: [String],
|
||||
tests :: [String]
|
||||
} deriving (Show, Eq)
|
||||
|
||||
isQuiet conf = Quiet `S.member` (flags conf)
|
||||
showOutput conf = ShowOutput `S.member` (flags conf)
|
||||
showTime conf = Time `S.member` (flags conf)
|
||||
showDiff conf = Diff `S.member` (flags conf)
|
||||
doUpdate conf = Update `S.member` (flags conf)
|
||||
|
||||
checkTestName :: String -> Bool
|
||||
checkTestName d = (all isDigit $ take 3 $ reverse d)
|
||||
&& (not $ isInfixOf "disabled" d)
|
||||
|
||||
enumTests :: IO [String]
|
||||
enumTests = do
|
||||
cwd <- getCurrentDirectory
|
||||
dirs <- getDirectoryContents cwd
|
||||
return $ sort $ filter checkTestName dirs
|
||||
|
||||
parseFlag :: String -> Maybe Flag
|
||||
parseFlag s = case s of
|
||||
"-u" -> Just Update
|
||||
"-d" -> Just Diff
|
||||
"-s" -> Just ShowOutput
|
||||
"-t" -> Just Time
|
||||
"-q" -> Just Quiet
|
||||
_ -> Nothing
|
||||
|
||||
parseFlags :: [String] -> (S.Set Flag, [String])
|
||||
parseFlags xs = (S.fromList f, i)
|
||||
where
|
||||
f = catMaybes $ map parseFlag fl
|
||||
(fl, i) = partition (\s -> parseFlag s /= Nothing) xs
|
||||
|
||||
parseArgs :: [String] -> IO Config
|
||||
parseArgs args = do
|
||||
(tests, rest) <- case args of
|
||||
("all":xs) -> do
|
||||
et <- enumTests
|
||||
return (et, xs)
|
||||
("without":xs) -> do
|
||||
t <- enumTests
|
||||
(blacklist, ys) <- return $ break (== "opts") xs
|
||||
return (t \\ blacklist, ys \\ ["opts"])
|
||||
(x:xs) -> do
|
||||
exists <- doesDirectoryExist x
|
||||
return (if checkTestName x && exists then [x] else [], xs)
|
||||
[] -> do
|
||||
et <- enumTests
|
||||
return (et, [])
|
||||
let (testOpts, idOpts) = parseFlags rest
|
||||
return $ Config testOpts idOpts tests
|
||||
|
||||
-- "bash" needed because Haskell has cmd as the default shell on windows, and
|
||||
-- we also want to run the process with another current directory, so we get
|
||||
-- this thing.
|
||||
runInShell :: String -> [String] -> IO (ExitCode, String)
|
||||
runInShell test opts = do
|
||||
(ec, output, _) <- readCreateProcessWithExitCode
|
||||
((proc "bash" ("run":opts)) { cwd = Just test,
|
||||
std_out = CreatePipe })
|
||||
""
|
||||
return (ec, output)
|
||||
|
||||
runTest :: Config -> String -> IO Status
|
||||
runTest conf test = do
|
||||
-- don't touch the current directory as we want to run these things
|
||||
-- in parallel in the future
|
||||
let inTest s = test ++ "/" ++ s
|
||||
t1 <- getCurrentTime
|
||||
(exitCode, output) <- runInShell test (idrOpts conf)
|
||||
t2 <- getCurrentTime
|
||||
expected <- readFile $ inTest "expected"
|
||||
writeFile (inTest "output") output
|
||||
res <- if (norm output == norm expected)
|
||||
then do putStrLn $ test ++ " finished...success"
|
||||
return Success
|
||||
else if doUpdate conf
|
||||
then do putStrLn $ test ++ " finished...UPDATE"
|
||||
writeFile (inTest "expected") output
|
||||
return Updated
|
||||
else do putStrLn $ test ++ " finished...FAILURE"
|
||||
_ <- rawSystem "diff" [inTest "output", inTest "expected"]
|
||||
return Failure
|
||||
when (showTime conf) $ do
|
||||
let dt = diffUTCTime t2 t1
|
||||
putStrLn $ "Duration of " ++ test ++ " was " ++ show dt
|
||||
return res
|
||||
where
|
||||
-- just pretend that backslashes are slashes for comparison
|
||||
-- purposes to avoid path problems, so don't write any tests
|
||||
-- that depend on that distinction in other contexts.
|
||||
-- Also rewrite newlines for consistency.
|
||||
norm ('\r':'\n':xs) = '\n' : norm xs
|
||||
norm ('\\':'\\':xs) = '/' : norm xs
|
||||
norm ('\\':xs) = '/' : norm xs
|
||||
norm (x : xs) = x : norm xs
|
||||
norm [] = []
|
||||
|
||||
printStats :: Config -> [Status] -> IO ()
|
||||
printStats conf stats = do
|
||||
let total = length stats
|
||||
let successful = length $ filter (== Success) stats
|
||||
let failures = length $ filter (== Failure) stats
|
||||
let updates = length $ filter (== Updated) stats
|
||||
putStrLn "\n----"
|
||||
putStrLn $ show total ++ " tests run: " ++ show successful ++ " succesful, "
|
||||
++ show failures ++ " failed, " ++ show updates ++ " updated."
|
||||
let failed = map fst $ filter ((== Failure) . snd) $ zip (tests conf) stats
|
||||
when (failed /= []) $ do
|
||||
putStrLn "\nFailed tests:"
|
||||
mapM_ putStrLn failed
|
||||
putStrLn ""
|
||||
|
||||
runTests :: Config -> IO Bool
|
||||
runTests conf = do
|
||||
stats <- mapM (runTest conf) (tests conf)
|
||||
unless (isQuiet conf) $ printStats conf stats
|
||||
return $ all (== Success) stats
|
||||
|
||||
runShow :: Config -> IO Bool
|
||||
runShow conf = do
|
||||
mapM_ (\t -> callProcess "cat" [t++"/output"]) (tests conf)
|
||||
return True
|
||||
|
||||
runDiff :: Config -> IO Bool
|
||||
runDiff conf = do
|
||||
mapM_ (\t -> do putStrLn $ "Differences in " ++ t ++ ":"
|
||||
ec <- rawSystem "diff" [t++"/output", t++"/expected"]
|
||||
when (ec == ExitSuccess) $ putStrLn "No differences found.")
|
||||
(tests conf)
|
||||
return True
|
||||
|
||||
whisper :: Config -> String -> IO ()
|
||||
whisper conf s = do unless (isQuiet conf) $ putStrLn s
|
||||
|
||||
isWindows :: Bool
|
||||
isWindows = os `elem` ["win32", "mingw32", "cygwin32"]
|
||||
|
||||
setPath :: Config -> IO ()
|
||||
setPath conf = do
|
||||
maybeEnv <- lookupEnv "IDRIS"
|
||||
idrisExists <- case maybeEnv of
|
||||
Just idrisExe -> do
|
||||
let exeExtension = if isWindows then ".exe" else ""
|
||||
doesFileExist (idrisExe ++ exeExtension)
|
||||
Nothing -> return False
|
||||
if (idrisExists)
|
||||
then do
|
||||
idrisAbs <- makeAbsolute $ fromMaybe "" maybeEnv
|
||||
setEnv "IDRIS" idrisAbs
|
||||
whisper conf $ "Using " ++ idrisAbs
|
||||
else do
|
||||
path <- getEnv "PATH"
|
||||
setEnv "IDRIS" ""
|
||||
let sandbox = "../.cabal-sandbox/bin"
|
||||
hasBox <- doesDirectoryExist sandbox
|
||||
bindir <- if hasBox
|
||||
then do
|
||||
whisper conf $ "Using Cabal sandbox at " ++ sandbox
|
||||
makeAbsolute sandbox
|
||||
else do
|
||||
stackExe <- findExecutable "stack"
|
||||
case stackExe of
|
||||
Just stack -> do
|
||||
out <- readProcess stack ["path", "--dist-dir"] []
|
||||
stackDistDir <- return $ takeWhile (/= '\n') out
|
||||
let stackDir = "../" ++ stackDistDir ++ "/build/idris"
|
||||
whisper conf $ "Using stack work dir at " ++ stackDir
|
||||
makeAbsolute stackDir
|
||||
Nothing -> return ""
|
||||
when (bindir /= "") $ setEnv "PATH" (bindir ++ [searchPathSeparator] ++ path)
|
||||
|
||||
main = do
|
||||
hSetBuffering stdout LineBuffering
|
||||
withCabal <- doesDirectoryExist "test"
|
||||
when withCabal $ do
|
||||
setCurrentDirectory "test"
|
||||
args <- getArgs
|
||||
conf <- parseArgs args
|
||||
setPath conf
|
||||
t1 <- getCurrentTime
|
||||
res <- case tests conf of
|
||||
[] -> return True
|
||||
xs | showOutput conf -> runShow conf
|
||||
xs | showDiff conf -> runDiff conf
|
||||
xs -> runTests conf
|
||||
t2 <- getCurrentTime
|
||||
when (showTime conf) $ do
|
||||
let dt = diffUTCTime t2 t1
|
||||
putStrLn $ "Duration of Entire Test Suite was " ++ show dt
|
||||
unless res exitFailure
|
||||
Loading…
Reference in New Issue
Block a user