git.iko.soy/rowtype-yoga/purescript-native
on 4e33a7e help sign in
rowtype-yoga/purescript-native/tests/TestCompiler.hs
309 lines 12 kB history raw
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DoAndIfThenElse #-}
3{-# LANGUAGE TupleSections #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE OverloadedStrings #-}
7module TestCompiler where
9-- Failing tests can specify the kind of error that should be thrown with a
10-- @shouldFailWith declaration. For example:
11--
12-- "-- @shouldFailWith TypesDoNotUnify"
13--
14-- will cause the test to fail unless that module fails to compile with exactly
15-- one TypesDoNotUnify error.
16--
17-- If a module is expected to produce multiple type errors, then use multiple
18-- @shouldFailWith lines; for example:
19--
20-- -- @shouldFailWith TypesDoNotUnify
21-- -- @shouldFailWith TypesDoNotUnify
22-- -- @shouldFailWith TransitiveExportError
24import Prelude ()
25import Prelude.Compat
27import qualified Language.PureScript as P
29import Data.Char (isSpace)
30import Data.Function (on)
31import Data.List (sort, stripPrefix, intercalate, groupBy, sortBy, minimumBy)
32import Data.Maybe (mapMaybe)
33import Data.Time.Clock (UTCTime())
34import qualified Data.Text as T
35import Data.Tuple (swap)
37import qualified Data.Map as M
39import Control.Monad
40import Control.Arrow ((***), (>>>))
42import Control.Monad.Reader
43import Control.Monad.Writer.Strict
44import Control.Monad.Trans.Except
46import System.Exit
47import System.Process hiding (cwd)
48import System.FilePath
49import System.Directory
50import System.IO
51import System.IO.UTF8
52import System.IO.Silently
53import qualified System.FilePath.Glob as Glob
55import TestUtils
56import Test.Hspec
58main :: IO ()
59main = hspec spec
61spec :: Spec
62spec = do
64 (supportExterns, supportForeigns, passingTestCases, warningTestCases, failingTestCases) <- runIO $ do
65 cwd <- getCurrentDirectory
66 let passing = cwd </> "examples" </> "passing"
67 let warning = cwd </> "examples" </> "warning"
68 let failing = cwd </> "examples" </> "failing"
69 let supportDir = cwd </> "tests" </> "support" </> "bower_components"
70 let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/src/**/*." ++ ext)) supportDir
71 passingFiles <- getTestFiles passing <$> testGlob passing
72 warningFiles <- getTestFiles warning <$> testGlob warning
73 failingFiles <- getTestFiles failing <$> testGlob failing
74 supportPurs <- supportFiles "purs"
75 supportPursFiles <- readInput supportPurs
76 supportExterns <- runExceptT $ do
77 modules <- ExceptT . return $ P.parseModulesFromFiles id supportPursFiles
78 foreigns <- inferForeignModules modules
79 externs <- ExceptT . fmap fst . runTest $ P.make (makeActions foreigns) (map snd modules)
80 return (zip (map snd modules) externs, foreigns)
81 case supportExterns of
82 Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs)
83 Right (externs, foreigns) -> return (externs, foreigns, passingFiles, warningFiles, failingFiles)
85 outputFile <- runIO $ do
86 tmp <- getTemporaryDirectory
87 createDirectoryIfMissing False (tmp </> logpath)
88 openFile (tmp </> logpath </> logfile) WriteMode
90 context "Passing examples" $
91 forM_ passingTestCases $ \testPurs ->
92 it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $
93 assertCompiles supportExterns supportForeigns testPurs outputFile
95 context "Warning examples" $
96 forM_ warningTestCases $ \testPurs -> do
97 let mainPath = getTestMain testPurs
98 expectedWarnings <- runIO $ getShouldWarnWith mainPath
99 it ("'" <> takeFileName mainPath <> "' should compile with warning(s) '" <> intercalate "', '" expectedWarnings <> "'") $
100 assertCompilesWithWarnings supportExterns supportForeigns testPurs expectedWarnings
102 context "Failing examples" $
103 forM_ failingTestCases $ \testPurs -> do
104 let mainPath = getTestMain testPurs
105 expectedFailures <- runIO $ getShouldFailWith mainPath
106 it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $
107 assertDoesNotCompile supportExterns supportForeigns testPurs expectedFailures
109 where
111 -- A glob for all purs and js files within a test directory
112 testGlob :: FilePath -> IO [FilePath]
113 testGlob = Glob.globDir1 (Glob.compile "**/*.purs")
115 -- Groups the test files so that a top-level file can have dependencies in a
116 -- subdirectory of the same name. The inner tuple contains a list of the
117 -- .purs files and the .js files for the test case.
118 getTestFiles :: FilePath -> [FilePath] -> [[FilePath]]
119 getTestFiles baseDir
120 = map (filter ((== ".purs") . takeExtensions) . map (baseDir </>))
121 . groupBy ((==) `on` extractPrefix)
122 . sortBy (compare `on` extractPrefix)
123 . map (makeRelative baseDir)
125 -- Takes the test entry point from a group of purs files - this is determined
126 -- by the file with the shortest path name, as everything but the main file
127 -- will be under a subdirectory.
128 getTestMain :: [FilePath] -> FilePath
129 getTestMain = minimumBy (compare `on` length)
131 -- Extracts the filename part of a .purs file, or if the file is in a
132 -- subdirectory, the first part of that directory path.
133 extractPrefix :: FilePath -> FilePath
134 extractPrefix fp =
135 let dir = takeDirectory fp
136 ext = reverse ".purs"
137 in if dir == "."
138 then maybe fp reverse $ stripPrefix ext $ reverse fp
139 else dir
141 -- Scans a file for @shouldFailWith directives in the comments, used to
142 -- determine expected failures
143 getShouldFailWith :: FilePath -> IO [String]
144 getShouldFailWith = extractPragma "shouldFailWith"
146 -- Scans a file for @shouldWarnWith directives in the comments, used to
147 -- determine expected warnings
148 getShouldWarnWith :: FilePath -> IO [String]
149 getShouldWarnWith = extractPragma "shouldWarnWith"
151 extractPragma :: String -> FilePath -> IO [String]
152 extractPragma pragma = fmap go . readUTF8File
153 where
154 go = lines >>> mapMaybe (stripPrefix ("-- @" ++ pragma ++ " ")) >>> map trim
156inferForeignModules
157 :: MonadIO m
158 => [(FilePath, P.Module)]
159 -> m (M.Map P.ModuleName FilePath)
160inferForeignModules = P.inferForeignModules . fromList
161 where
162 fromList :: [(FilePath, P.Module)] -> M.Map P.ModuleName (Either P.RebuildPolicy FilePath)
163 fromList = M.fromList . map ((P.getModuleName *** Right) . swap)
165trim :: String -> String
166trim = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
168modulesDir :: FilePath
169modulesDir = ".test_modules" </> "node_modules"
171makeActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make
172makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False)
173 { P.getInputTimestamp = getInputTimestamp
174 , P.getOutputTimestamp = getOutputTimestamp
175 }
176 where
177 getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime))
178 getInputTimestamp mn
179 | isSupportModule (T.unpack (P.runModuleName mn)) = return (Left P.RebuildNever)
180 | otherwise = return (Left P.RebuildAlways)
181 where
182 isSupportModule = flip elem supportModules
184 getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime)
185 getOutputTimestamp mn = do
186 let filePath = modulesDir </> T.unpack (P.runModuleName mn)
187 exists <- liftIO $ doesDirectoryExist filePath
188 return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing)
190readInput :: [FilePath] -> IO [(FilePath, T.Text)]
191readInput inputFiles = forM inputFiles $ \inputFile -> do
192 text <- readUTF8FileT inputFile
193 return (inputFile, text)
195runTest :: P.Make a -> IO (Either P.MultipleErrors a, P.MultipleErrors)
196runTest = P.runMake P.defaultOptions
198compile
199 :: [(P.Module, P.ExternsFile)]
200 -> M.Map P.ModuleName FilePath
201 -> [FilePath]
202 -> ([P.Module] -> IO ())
203 -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors)
204compile supportExterns supportForeigns inputFiles check = silence $ runTest $ do
205 fs <- liftIO $ readInput inputFiles
206 ms <- P.parseModulesFromFiles id fs
207 foreigns <- inferForeignModules ms
208 liftIO (check (map snd ms))
209 let actions = makeActions (foreigns `M.union` supportForeigns)
210 case ms of
211 [singleModule] -> pure <$> P.rebuildModule actions (map snd supportExterns) (snd singleModule)
212 _ -> P.make actions (map fst supportExterns ++ map snd ms)
214assert
215 :: [(P.Module, P.ExternsFile)]
216 -> M.Map P.ModuleName FilePath
217 -> [FilePath]
218 -> ([P.Module] -> IO ())
219 -> (Either P.MultipleErrors P.MultipleErrors -> IO (Maybe String))
220 -> Expectation
221assert supportExterns supportForeigns inputFiles check f = do
222 (e, w) <- compile supportExterns supportForeigns inputFiles check
223 maybeErr <- f (const w <$> e)
224 maybe (return ()) expectationFailure maybeErr
226checkMain :: [P.Module] -> IO ()
227checkMain ms =
228 unless (any ((== P.moduleNameFromString "Main") . P.getModuleName) ms)
229 (fail "Main module missing")
231checkShouldFailWith :: [String] -> P.MultipleErrors -> Maybe String
232checkShouldFailWith expected errs =
233 let actual = map P.errorCode $ P.runMultipleErrors errs
234 in if sort expected == sort (map T.unpack actual)
235 then Nothing
236 else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual
238assertCompiles
239 :: [(P.Module, P.ExternsFile)]
240 -> M.Map P.ModuleName FilePath
241 -> [FilePath]
242 -> Handle
243 -> Expectation
244assertCompiles supportExterns supportForeigns inputFiles outputFile =
245 assert supportExterns supportForeigns inputFiles checkMain $ \e ->
246 case e of
247 Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs
248 Right _ -> do
249 process <- findNodeProcess
250 let entryPoint = modulesDir </> "index.js"
251 writeFile entryPoint "require('Main').main()"
252 result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process
253 hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":"
254 case result of
255 Just (ExitSuccess, out, err)
256 | not (null err) -> return $ Just $ "Test wrote to stderr:\n\n" <> err
257 | not (null out) && trim (last (lines out)) == "Done" -> do
258 hPutStr outputFile out
259 return Nothing
260 | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out
261 Just (ExitFailure _, _, err) -> return $ Just err
262 Nothing -> return $ Just "Couldn't find node.js executable"
264assertCompilesWithWarnings
265 :: [(P.Module, P.ExternsFile)]
266 -> M.Map P.ModuleName FilePath
267 -> [FilePath]
268 -> [String]
269 -> Expectation
270assertCompilesWithWarnings supportExterns supportForeigns inputFiles shouldWarnWith =
271 assert supportExterns supportForeigns inputFiles checkMain $ \e ->
272 case e of
273 Left errs ->
274 return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs
275 Right warnings ->
276 return
277 . fmap (printAllWarnings warnings)
278 $ checkShouldFailWith shouldWarnWith warnings
280 where
281 printAllWarnings warnings =
282 (<> "\n\n" <> P.prettyPrintMultipleErrors P.defaultPPEOptions warnings)
284assertDoesNotCompile
285 :: [(P.Module, P.ExternsFile)]
286 -> M.Map P.ModuleName FilePath
287 -> [FilePath]
288 -> [String]
289 -> Expectation
290assertDoesNotCompile supportExterns supportForeigns inputFiles shouldFailWith =
291 assert supportExterns supportForeigns inputFiles noPreCheck $ \e ->
292 case e of
293 Left errs ->
294 return $ if null shouldFailWith
295 then Just $ "shouldFailWith declaration is missing (errors were: "
296 ++ show (map P.errorCode (P.runMultipleErrors errs))
297 ++ ")"
298 else checkShouldFailWith shouldFailWith errs
299 Right _ ->
300 return $ Just "Should not have compiled"
302 where
303 noPreCheck = const (return ())
305logpath :: FilePath
306logpath = "purescript-output"
308logfile :: FilePath
309logfile = "psc-tests.out"