git.iko.soy/Idris-dev
on 20d4426 help sign in
Idris-dev/test/TestRun.hs
113 lines 3.9 kB history raw
1module Main where
3import TestData
5import Control.Monad
6import Data.Char (isLetter)
7import qualified Data.IntMap as IMap
8import Data.List
9import Data.Proxy
10import Data.Typeable
11import Options.Applicative
12import System.Directory
13import System.Environment
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 = ["diff", "--strip-trailing-cr", "-u", new, ref]
68-- Should always output a 3-charater string from a postive Int
69indexToString :: Int -> String
70indexToString index = let str = show index in
71 replicate (3 - length str) '0' ++ str
73-- Turns the collection of TestFamily into actual tests usable by Tasty
74mkGoldenTests :: [TestFamily] -> Flags -> TestTree
75mkGoldenTests testFamilies flags =
76 testGroup "Regression and feature tests"
77 (fmap mkTestFamily testFamilies)
78 where
79 mkTestFamily (TestFamily id name tests) =
80 testGroup name (fmap (mkTest id) (IMap.keys tests))
81 mkTest id index =
82 let testname = id ++ indexToString index
83 path = testDirectory </> testname
84 in
85 test testname path (runTest path flags)
87-- Runs a test script
88-- "bash" needed because Haskell has cmd as the default shell on windows, and
89-- we also want to run the process with another current directory, so we get
90-- this thing.
91runTest :: String -> Flags -> IO ()
92runTest path flags = do
93 let run = (proc "bash" ("run" : flags)) {cwd = Just path}
94 (_, output, error_out) <- readCreateProcessWithExitCode run ""
95 writeFile (path </> "output") (normalise output)
96 when (error_out /= "") $ hPutStrLn stderr ("\nError: " ++ path ++ "\n" ++ error_out)
97 where
98 -- Normalise paths e.g. '.\foo.idr' to './foo.idr'.
99 -- Also embedded paths e.g. ".\\Prelude\\List.idr" to "./Prelude/List.idr".
100 normalise ('.' : '\\' : c : xs) | isLetter c = '.' : '/' : c : normalise xs
101 normalise ('\\':'\\':xs) = '/' : normalise xs
102 normalise (x : xs) = x : normalise xs
103 normalise [] = []
105main :: IO ()
106main =
107 defaultMainWithIngredients ingredients $
108 askOption $ \(NodeOpt node) ->
109 let (codegen, flags) = if node then (JS, ["--codegen", "node"])
110 else (C , [])
111 in
112 mkGoldenTests (testFamiliesForCodegen codegen)
113 (flags ++ idrisFlags)