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