git.iko.soy/Idris-dev
on af3a163 help sign in
Idris-dev/test/TestRun.hs
123 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.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 = ["diff", "--strip-trailing-cr", "-u", new, ref]
70-- Should always output a 3-charater string from a postive Int
71indexToString :: Int -> String
72indexToString index = let str = show index in
73 replicate (3 - length str) '0' ++ str
75-- Turns the collection of TestFamily into actual tests usable by Tasty
76mkGoldenTests :: [TestFamily] -> Flags -> TestTree
77mkGoldenTests testFamilies flags =
78 testGroup "Regression and feature tests"
79 (fmap mkTestFamily testFamilies)
80 where
81 mkTestFamily (TestFamily id name tests) =
82 testGroup name (fmap (mkTest id) (IMap.keys tests))
83 mkTest id index =
84 let testname = id ++ indexToString index
85 path = testDirectory </> testname
86 in
87 test testname path (runTest path flags)
89-- Runs a test script
90-- "bash" needed because Haskell has cmd as the default shell on windows, and
91-- we also want to run the process with another current directory, so we get
92-- this thing.
93runTest :: String -> Flags -> IO ()
94runTest path flags = do
95 let run = (proc "bash" ("run" : flags)) {cwd = Just path}
96 (_, output, error_out) <- readCreateProcessWithExitCode run ""
97 writeFile (path </> "output") (normalise output)
98 when (error_out /= "") $ hPutStrLn stderr ("\nError: " ++ path ++ "\n" ++ error_out)
99 where
100 -- Normalise paths e.g. '.\foo.idr' to './foo.idr'.
101 -- Also embedded paths e.g. ".\\Prelude\\List.idr" to "./Prelude/List.idr".
102 normalise ('.' : '\\' : c : xs) | isLetter c = '.' : '/' : c : normalise xs
103 normalise ('\\':'\\':xs) = '/' : normalise xs
104 normalise (x : xs) = x : normalise xs
105 normalise [] = []
107main :: IO ()
108main = do
109 nodePath <- findExecutable "node"
110 nodejsPath <- findExecutable "nodejs"
111 let node = nodePath <|> nodejsPath
112 case node of
113 Nothing -> do
114 putStrLn "For running the test suite against Node, node must be installed."
115 exitFailure
116 Just _ -> do
117 defaultMainWithIngredients ingredients $
118 askOption $ \(NodeOpt node) ->
119 let (codegen, flags) = if node then (JS, ["--codegen", "node"])
120 else (C , [])
121 in
122 mkGoldenTests (testFamiliesForCodegen codegen)
123 (flags ++ idrisFlags)