mirror of
https://github.com/ilyakooo0/Idris-dev.git
synced 2024-09-11 08:55:23 +03:00
129 lines
4.3 KiB
Haskell
129 lines
4.3 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
module Main where
|
|
|
|
import TestData
|
|
|
|
import Control.Monad
|
|
import Data.Char (isLetter)
|
|
import qualified Data.IntMap as IMap
|
|
import Data.Monoid ((<>))
|
|
import Data.Proxy
|
|
import Data.Typeable
|
|
import Options.Applicative
|
|
import System.Directory
|
|
import System.Environment
|
|
import System.Exit
|
|
import System.FilePath ((</>))
|
|
import System.Info
|
|
import System.IO
|
|
import System.Process
|
|
import Test.Tasty
|
|
import Test.Tasty.Golden
|
|
import Test.Tasty.Ingredients.Rerun
|
|
import Test.Tasty.Options
|
|
import Test.Tasty.Runners
|
|
|
|
--------------------------------------------------------------------- [ 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 = NodeOpt <$> switch (long nodeArg <> help nodeHelp)
|
|
|
|
ingredients :: [Ingredient]
|
|
ingredients = defaultIngredients ++
|
|
[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 testName path = goldenVsFileDiff testName diff ref output
|
|
where
|
|
ref = path </> "expected.out"
|
|
output = path </> "output"
|
|
diff ref new | os == "openbsd" = ["diff", "-u", new, ref]
|
|
| otherwise = ["diff", "--strip-trailing-cr", "-u", new, ref]
|
|
|
|
-- 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 feature 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.sh" : flags)) {cwd = Just path}
|
|
(_, output, error_out) <- readCreateProcessWithExitCode run ""
|
|
writeFile (path </> "output") (normalise output)
|
|
when (error_out /= "") $ hPutStrLn stderr ("\nError: " ++ path ++ "\n" ++ error_out)
|
|
where
|
|
-- Normalise paths e.g. '.\foo.idr' to './foo.idr'.
|
|
-- Also embedded paths e.g. ".\\Prelude\\List.idr" to "./Prelude/List.idr".
|
|
normalise ('.' : '\\' : c : xs) | isLetter c = '.' : '/' : c : normalise xs
|
|
normalise ('\\':'\\':xs) = '/' : normalise xs
|
|
normalise (x : xs) = x : normalise xs
|
|
normalise [] = []
|
|
|
|
checkNode :: IO ()
|
|
checkNode = do
|
|
nodePath <- findExecutable "node"
|
|
nodejsPath <- findExecutable "nodejs"
|
|
let node = nodePath <|> nodejsPath
|
|
case node of
|
|
Nothing -> do
|
|
putStrLn "For running the test suite against Node, node must be installed."
|
|
exitFailure
|
|
Just _ -> return ()
|
|
|
|
main :: IO ()
|
|
main = do
|
|
args <- getArgs
|
|
when ("--node" `elem` args) checkNode
|
|
defaultMainWithIngredients ingredients $
|
|
askOption $ \(NodeOpt node) ->
|
|
let (codegen, flags) = if node then (JS, ["--codegen", "node"])
|
|
else (C , [])
|
|
in
|
|
mkGoldenTests (testFamiliesForCodegen codegen) (flags ++ idrisFlags)
|
|
|