git.iko.soy/rowtype-yoga/purescript-native
on 20dbda1 help sign in
rowtype-yoga/purescript-native/tests/TestCompiler.hs
253 lines 9.7 kB history raw
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DoAndIfThenElse #-}
3{-# LANGUAGE TupleSections #-}
4{-# LANGUAGE FlexibleInstances #-}
6module TestCompiler where
8-- Failing tests can specify the kind of error that should be thrown with a
9-- @shouldFailWith declaration. For example:
10--
11-- "-- @shouldFailWith TypesDoNotUnify"
12--
13-- will cause the test to fail unless that module fails to compile with exactly
14-- one TypesDoNotUnify error.
15--
16-- If a module is expected to produce multiple type errors, then use multiple
17-- @shouldFailWith lines; for example:
18--
19-- -- @shouldFailWith TypesDoNotUnify
20-- -- @shouldFailWith TypesDoNotUnify
21-- -- @shouldFailWith TransitiveExportError
23import Prelude ()
24import Prelude.Compat
26import qualified Language.PureScript as P
28import Data.Char (isSpace)
29import Data.Function (on)
30import Data.List (sort, stripPrefix, intercalate, groupBy, sortBy, partition)
31import Data.Maybe (mapMaybe)
32import Data.Time.Clock (UTCTime())
34import qualified Data.Map as M
36import Control.Monad
37import Control.Arrow ((>>>))
39import Control.Monad.Reader
40import Control.Monad.Writer.Strict
41import Control.Monad.Trans.Except
43import System.Exit
44import System.Process hiding (cwd)
45import System.FilePath
46import System.Directory
47import System.IO.UTF8
48import System.IO.Silently
49import qualified System.FilePath.Glob as Glob
51import TestUtils
52import Test.Hspec
54main :: IO ()
55main = hspec spec
57spec :: Spec
58spec = do
60 (supportExterns, supportForeigns, passingTestCases, failingTestCases) <- runIO $ do
61 cwd <- getCurrentDirectory
62 let passing = cwd </> "examples" </> "passing"
63 let failing = cwd </> "examples" </> "failing"
64 let supportDir = cwd </> "tests" </> "support" </> "bower_components"
65 let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir
66 passingFiles <- getTestFiles passing <$> testGlob passing
67 failingFiles <- getTestFiles failing <$> testGlob failing
68 supportPurs <- supportFiles "purs"
69 supportForeigns <- loadForeigns =<< supportFiles "js"
70 supportPursFiles <- readInput supportPurs
71 supportExterns <- runExceptT $ do
72 modules <- ExceptT . return $ P.parseModulesFromFiles id supportPursFiles
73 externs <- ExceptT . runTest $ P.make (makeActions supportForeigns) (map snd modules)
74 return (zip (map snd modules) externs)
75 case supportExterns of
76 Left errs -> fail (P.prettyPrintMultipleErrors False errs)
77 Right externs -> return (externs, supportForeigns, passingFiles, failingFiles)
79 context ("Passing examples") $ do
80 forM_ passingTestCases $ \(testPurs, testJS) ->
81 it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $ do
82 testForeigns <- loadForeigns testJS
83 assertCompiles supportExterns testPurs (supportForeigns <> testForeigns)
85 context ("Failing examples") $ do
86 forM_ failingTestCases $ \(testPurs, testJS) -> do
87 let mainPath = getTestMain testPurs
88 expectedFailures <- runIO $ getShouldFailWith mainPath
89 it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $ do
90 testForeigns <- loadForeigns testJS
91 assertDoesNotCompile supportExterns testPurs (supportForeigns <> testForeigns) expectedFailures
93 where
95 -- A glob for all purs and js files within a test directory
96 testGlob :: FilePath -> IO [FilePath]
97 testGlob dir = join . fst <$> Glob.globDir (map Glob.compile ["**/*.purs", "**/*.js"]) dir
99 -- Loads foreign modules from source files
100 loadForeigns :: [FilePath] -> IO (M.Map P.ModuleName FilePath)
101 loadForeigns paths = do
102 files <- forM paths (\f -> (f,) <$> readUTF8File f)
103 Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles files
104 return foreigns
106 -- Groups the test files so that a top-level file can have dependencies in a
107 -- subdirectory of the same name. The inner tuple contains a list of the
108 -- .purs files and the .js files for the test case.
109 getTestFiles :: FilePath -> [FilePath] -> [([FilePath], [FilePath])]
110 getTestFiles baseDir
111 = map (partition ((== ".purs") . takeExtensions))
112 . map (map (baseDir </>))
113 . groupBy ((==) `on` extractPrefix)
114 . sortBy (compare `on` extractPrefix)
115 . map (makeRelative baseDir)
117 -- Takes the test entry point from a group of purs files - this is determined
118 -- by the file with the shortest path name, as everything but the main file
119 -- will be under a subdirectory.
120 getTestMain :: [FilePath] -> FilePath
121 getTestMain = head . sortBy (compare `on` length)
123 -- Extracts the filename part of a .purs file, or if the file is in a
124 -- subdirectory, the first part of that directory path.
125 extractPrefix :: FilePath -> FilePath
126 extractPrefix fp =
127 let dir = takeDirectory fp
128 ext = reverse ".purs"
129 in if dir == "."
130 then maybe fp reverse $ stripPrefix ext $ reverse fp
131 else dir
133 -- Scans a file for @shouldFailWith directives in the comments, used to
134 -- determine expected failures
135 getShouldFailWith :: FilePath -> IO [String]
136 getShouldFailWith = fmap extractFailWiths . readUTF8File
137 where
138 extractFailWiths = lines >>> mapMaybe (stripPrefix "-- @shouldFailWith ") >>> map trim
140trim :: String -> String
141trim = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
143modulesDir :: FilePath
144modulesDir = ".test_modules" </> "node_modules"
146makeActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make
147makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False)
148 { P.getInputTimestamp = getInputTimestamp
149 , P.getOutputTimestamp = getOutputTimestamp
150 }
151 where
152 getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime))
153 getInputTimestamp mn
154 | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever)
155 | otherwise = return (Left P.RebuildAlways)
156 where
157 isSupportModule = flip elem supportModules
159 getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime)
160 getOutputTimestamp mn = do
161 let filePath = modulesDir </> P.runModuleName mn
162 exists <- liftIO $ doesDirectoryExist filePath
163 return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing)
165readInput :: [FilePath] -> IO [(FilePath, String)]
166readInput inputFiles = forM inputFiles $ \inputFile -> do
167 text <- readUTF8File inputFile
168 return (inputFile, text)
170type TestM = WriterT [(FilePath, String)] IO
172runTest :: P.Make a -> IO (Either P.MultipleErrors a)
173runTest = fmap fst . P.runMake P.defaultOptions
175compile
176 :: [(P.Module, P.ExternsFile)]
177 -> [FilePath]
178 -> M.Map P.ModuleName FilePath
179 -> ([P.Module] -> IO ())
180 -> IO (Either P.MultipleErrors [P.ExternsFile])
181compile supportExterns inputFiles foreigns check = silence $ runTest $ do
182 fs <- liftIO $ readInput inputFiles
183 ms <- P.parseModulesFromFiles id fs
184 liftIO (check (map snd ms))
185 let actions = makeActions foreigns
186 case ms of
187 [singleModule] -> pure <$> P.rebuildModule actions (map snd supportExterns) (snd singleModule)
188 _ -> P.make actions (map fst supportExterns ++ map snd ms)
190assert
191 :: [(P.Module, P.ExternsFile)]
192 -> [FilePath]
193 -> M.Map P.ModuleName FilePath
194 -> ([P.Module] -> IO ())
195 -> (Either P.MultipleErrors [P.ExternsFile] -> IO (Maybe String))
196 -> Expectation
197assert supportExterns inputFiles foreigns check f = do
198 e <- compile supportExterns inputFiles foreigns check
199 maybeErr <- f e
200 maybe (return ()) expectationFailure maybeErr
202assertCompiles
203 :: [(P.Module, P.ExternsFile)]
204 -> [FilePath]
205 -> M.Map P.ModuleName FilePath
206 -> Expectation
207assertCompiles supportExterns inputFiles foreigns =
208 assert supportExterns inputFiles foreigns checkMain $ \e ->
209 case e of
210 Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs
211 Right _ -> do
212 process <- findNodeProcess
213 let entryPoint = modulesDir </> "index.js"
214 writeFile entryPoint "require('Main').main()"
215 result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process
216 case result of
217 Just (ExitSuccess, out, err)
218 | not (null err) -> return $ Just $ "Test wrote to stderr:\n\n" <> err
219 | not (null out) && trim (last (lines out)) == "Done" -> return Nothing
220 | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out
221 Just (ExitFailure _, _, err) -> return $ Just err
222 Nothing -> return $ Just "Couldn't find node.js executable"
223 where
224 checkMain ms =
225 unless (any ((== P.moduleNameFromString "Main") . P.getModuleName) ms)
226 (fail "Main module missing")
228assertDoesNotCompile
229 :: [(P.Module, P.ExternsFile)]
230 -> [FilePath]
231 -> M.Map P.ModuleName FilePath
232 -> [String]
233 -> Expectation
234assertDoesNotCompile supportExterns inputFiles foreigns shouldFailWith =
235 assert supportExterns inputFiles foreigns noPreCheck $ \e ->
236 case e of
237 Left errs ->
238 return $ if null shouldFailWith
239 then Just $ "shouldFailWith declaration is missing (errors were: "
240 ++ show (map P.errorCode (P.runMultipleErrors errs))
241 ++ ")"
242 else checkShouldFailWith shouldFailWith errs
243 Right _ ->
244 return $ Just "Should not have compiled"
246 where
247 noPreCheck = const (return ())
249 checkShouldFailWith expected errs =
250 let actual = map P.errorCode $ P.runMultipleErrors errs
251 in if sort expected == sort actual
252 then Nothing
253 else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual