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