git.iko.soy/Idris-dev
on ca34dec help sign in
Idris-dev/test/TestRun.hs
122 lines 4.2 kB history raw
1{-# LANGUAGE CPP #-}
2module Main where
4import TestData
6import Control.Monad
7import Data.Char (isLetter)
8import qualified Data.IntMap as IMap
9import Data.Monoid ((<>))
10import Data.Proxy
11import Data.Typeable
12import Options.Applicative
13import System.Directory
14import System.Exit
15import System.FilePath ((</>))
16import System.Info
17import System.IO
18import System.Process
19import Test.Tasty
20import Test.Tasty.Golden
21import Test.Tasty.Ingredients.Rerun
22import Test.Tasty.Options
23import Test.Tasty.Runners
25--------------------------------------------------------------------- [ Config ]
27type Flags = [String]
29-- Add arguments to calls of idris executable
30idrisFlags :: Flags
31idrisFlags = []
33testDirectory :: String
34testDirectory = "test"
36-------------------------------------------------------------------- [ Options ]
38-- The `--node` option makes idris use the node code generator
39-- As a consequence, incompatible tests are removed
41newtype NodeOpt = NodeOpt Bool deriving (Eq, Ord, Typeable)
43nodeArg = "node"
44nodeHelp = "Performs the tests with the node code generator"
45instance IsOption NodeOpt where
46 defaultValue = NodeOpt False
47 parseValue = fmap NodeOpt . safeRead
48 optionName = return nodeArg
49 optionHelp = return nodeHelp
50 optionCLParser = NodeOpt <$> switch (long nodeArg <> help nodeHelp)
52ingredients :: [Ingredient]
53ingredients = defaultIngredients ++
54 [rerunningTests [consoleTestReporter],
55 includingOptions [Option (Proxy :: Proxy NodeOpt)] ]
57----------------------------------------------------------------------- [ Core ]
59-- Compare a given file contents against the golden file contents
60-- A ripoff of goldenVsFile from Tasty.Golden
61test :: String -> String -> IO () -> TestTree
62test testName path = goldenVsFileDiff testName diff ref output
63 where
64 ref = path </> "expected"
65 output = path </> "output"
66 diff ref new | os == "openbsd" = ["diff", "-u", new, ref]
67 | otherwise = ["diff", "--strip-trailing-cr", "-u", new, ref]
69-- Should always output a 3-charater string from a postive Int
70indexToString :: Int -> String
71indexToString index = let str = show index in
72 replicate (3 - length str) '0' ++ str
74-- Turns the collection of TestFamily into actual tests usable by Tasty
75mkGoldenTests :: [TestFamily] -> Flags -> TestTree
76mkGoldenTests testFamilies flags =
77 testGroup "Regression and feature tests"
78 (fmap mkTestFamily testFamilies)
79 where
80 mkTestFamily (TestFamily id name tests) =
81 testGroup name (fmap (mkTest id) (IMap.keys tests))
82 mkTest id index =
83 let testname = id ++ indexToString index
84 path = testDirectory </> testname
85 in
86 test testname path (runTest path flags)
88-- Runs a test script
89-- "bash" needed because Haskell has cmd as the default shell on windows, and
90-- we also want to run the process with another current directory, so we get
91-- this thing.
92runTest :: String -> Flags -> IO ()
93runTest path flags = do
94 let run = (proc "bash" ("run" : flags)) {cwd = Just path}
95 (_, output, error_out) <- readCreateProcessWithExitCode run ""
96 writeFile (path </> "output") (normalise output)
97 when (error_out /= "") $ hPutStrLn stderr ("\nError: " ++ path ++ "\n" ++ error_out)
98 where
99 -- Normalise paths e.g. '.\foo.idr' to './foo.idr'.
100 -- Also embedded paths e.g. ".\\Prelude\\List.idr" to "./Prelude/List.idr".
101 normalise ('.' : '\\' : c : xs) | isLetter c = '.' : '/' : c : normalise xs
102 normalise ('\\':'\\':xs) = '/' : normalise xs
103 normalise (x : xs) = x : normalise xs
104 normalise [] = []
106main :: IO ()
107main = do
108 nodePath <- findExecutable "node"
109 nodejsPath <- findExecutable "nodejs"
110 let node = nodePath <|> nodejsPath
111 case node of
112 Nothing -> do
113 putStrLn "For running the test suite against Node, node must be installed."
114 exitFailure
115 Just _ -> do
116 defaultMainWithIngredients ingredients $
117 askOption $ \(NodeOpt node) ->
118 let (codegen, flags) = if node then (JS, ["--codegen", "node"])
119 else (C , [])
120 in
121 mkGoldenTests (testFamiliesForCodegen codegen)
122 (flags ++ idrisFlags)