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