forked from purescript/purescript
/
TestMain.hs
150 lines (126 loc) · 4.49 KB
/
TestMain.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
-------------------------------------------------------------------------------
--
-- Module : Main
-- Copyright : (c) 2015 Andy Arvanitis and other contributors
-- License : MIT
--
-- Maintainer : Andy Arvanitis
-- Stability : experimental
-- Portability :
--
--
--
-------------------------------------------------------------------------------
module Main where
import Data.List
import Control.Applicative
import Control.Monad
import System.Process
import System.FilePath
import System.IO
import System.Directory
-------------------------------------------------------------------------------
testsDir :: IO (FilePath, FilePath)
-------------------------------------------------------------------------------
testsDir = do
baseDir <- getCurrentDirectory
return (baseDir </> "pcc-tests", baseDir)
-------------------------------------------------------------------------------
main :: IO ()
-------------------------------------------------------------------------------
main = do
(outputDir, baseDir) <- testsDir
outputDirExists <- doesDirectoryExist outputDir
when outputDirExists $ removeDirectoryRecursive outputDir
createDirectory outputDir
let srcDir = outputDir </> "src"
createDirectory srcDir
let passingDir = baseDir </> "examples" </> "passing"
passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passingDir
-- Auto-generate Makefile
setCurrentDirectory outputDir
callProcess "pcc" []
fetchPackages
let tests = filter (`notElem` skipped) passingTestCases
tmp <- getTemporaryDirectory
createDirectoryIfMissing False (tmp </> logpath)
outputFile <- openFile (tmp </> logpath </> logfile) WriteMode
hClose outputFile
-- Run the tests
--
forM_ tests $ \inputFile -> do
--
-- Compile/build
--
putStrLn $ "Compiling test " ++ inputFile ++ " ..."
setCurrentDirectory outputDir
copyFile (passingDir </> inputFile) (srcDir </> inputFile)
let testCaseDir = passingDir </> (takeWhile (/='.') inputFile)
testCaseDirExists <- doesDirectoryExist testCaseDir
when testCaseDirExists $ callProcess "cp" ["-R", testCaseDir, srcDir]
callProcess "make" ["clean"]
callProcess "make" ["debug", "CXXFLAGS=-Werror", "-j2"]
--
-- Run C++ files
--
outputFile <- openFile (tmp </> logpath </> logfile) AppendMode
hPutStrLn outputFile ("\n" ++ inputFile ++ ":")
proc <- runProcess ("output" </> "bin" </> "main") [] Nothing Nothing Nothing (Just outputFile) Nothing
removeFile (srcDir </> inputFile)
when testCaseDirExists $ callProcess "rm" ["-rf", srcDir </> (takeWhile (/='.') inputFile)]
-- TODO: support failing test cases
--
-- let failing = baseDir </> "examples" </> "failing"
-- failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing
--
setCurrentDirectory baseDir
putStrLn "pcc-tests finished"
putStrLn $ "Total tests available: " ++ show (length passingTestCases)
putStrLn $ "Tests run: " ++ show (length tests)
putStrLn $ "Tests skipped: " ++ show (length skipped)
-------------------------------------------------------------------------------
repo :: String
-------------------------------------------------------------------------------
repo = "git://github.com/pure11/"
-------------------------------------------------------------------------------
packages :: [String]
-------------------------------------------------------------------------------
packages =
[ "eff"
, "arrays"
, "assert"
, "console"
, "control"
, "foldable-traversable"
, "functions"
, "generics-rep"
, "invariant"
, "monoid"
, "newtype"
, "partial"
, "prelude"
, "proxy"
, "st"
, "symbols"
, "type-equality"
, "typelevel-prelude"
]
-------------------------------------------------------------------------------
fetchPackages :: IO ()
-------------------------------------------------------------------------------
fetchPackages = do
mapM (callProcess "psc-package" . (\p -> ["install", p])) packages
return ()
-------------------------------------------------------------------------------
skipped :: [String]
-------------------------------------------------------------------------------
skipped =
[ "NumberLiterals.purs" -- unreliable float comparison, test manually
, "FunWithFunDeps.purs" -- requires FFI
, "StringEdgeCases.purs" -- TODO: depends on new package needing porting
, "StringEscapes.purs" -- TODO: UTF16-specific
]
logpath :: FilePath
logpath = "purescript-output"
logfile :: FilePath
logfile = "pcc-tests.out"