git.iko.soy/Idris-dev
on master help sign in
Idris-dev/test/TestRun.hs
128 lines 4.4 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.Environment
15import System.Exit
16import System.FilePath ((</>))
17import System.Info
18import System.IO
19import System.Process
20import Test.Tasty
21import Test.Tasty.Golden
22import Test.Tasty.Ingredients.Rerun
23import Test.Tasty.Options
24import Test.Tasty.Runners
26--------------------------------------------------------------------- [ Config ]
28type Flags = [String]
30-- Add arguments to calls of idris executable
31idrisFlags :: Flags
32idrisFlags = []
34testDirectory :: String
35testDirectory = "test"
37-------------------------------------------------------------------- [ Options ]
39-- The `--node` option makes idris use the node code generator
40-- As a consequence, incompatible tests are removed
42newtype NodeOpt = NodeOpt Bool deriving (Eq, Ord, Typeable)
44nodeArg = "node"
45nodeHelp = "Performs the tests with the node code generator"
46instance IsOption NodeOpt where
47 defaultValue = NodeOpt False
48 parseValue = fmap NodeOpt . safeRead
49 optionName = return nodeArg
50 optionHelp = return nodeHelp
51 optionCLParser = NodeOpt <$> switch (long nodeArg <> help nodeHelp)
53ingredients :: [Ingredient]
54ingredients = defaultIngredients ++
55 [rerunningTests [consoleTestReporter],
56 includingOptions [Option (Proxy :: Proxy NodeOpt)] ]
58----------------------------------------------------------------------- [ Core ]
60-- Compare a given file contents against the golden file contents
61-- A ripoff of goldenVsFile from Tasty.Golden
62test :: String -> String -> IO () -> TestTree
63test testName path = goldenVsFileDiff testName diff ref output
64 where
65 ref = path </> "expected.out"
66 output = path </> "output"
67 diff ref new | os == "openbsd" = ["diff", "-u", new, ref]
68 | otherwise = ["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.sh" : 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 [] = []
107checkNode :: IO ()
108checkNode = 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 _ -> return ()
118main :: IO ()
119main = do
120 args <- getArgs
121 when ("--node" `elem` args) checkNode
122 defaultMainWithIngredients ingredients $
123 askOption $ \(NodeOpt node) ->
124 let (codegen, flags) = if node then (JS, ["--codegen", "node"])
125 else (C , [])
126 in
127 mkGoldenTests (testFamiliesForCodegen codegen) (flags ++ idrisFlags)