git.iko.soy/rowtype-yoga/purescript-native
on aaa6990 help sign in
rowtype-yoga/purescript-native/tests/TestCompiler.hs
304 lines 11 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, 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-*/**/*." ++ 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)
81 case supportExterns of
82 Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs)
83 Right externs -> return (externs, 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 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 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 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 -> [FilePath]
201 -> ([P.Module] -> IO ())
202 -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors)
203compile supportExterns inputFiles check = silence $ runTest $ do
204 fs <- liftIO $ readInput inputFiles
205 ms <- P.parseModulesFromFiles id fs
206 foreigns <- inferForeignModules ms
207 liftIO (check (map snd ms))
208 let actions = makeActions foreigns
209 case ms of
210 [singleModule] -> pure <$> P.rebuildModule actions (map snd supportExterns) (snd singleModule)
211 _ -> P.make actions (map fst supportExterns ++ map snd ms)
213assert
214 :: [(P.Module, P.ExternsFile)]
215 -> [FilePath]
216 -> ([P.Module] -> IO ())
217 -> (Either P.MultipleErrors P.MultipleErrors -> IO (Maybe String))
218 -> Expectation
219assert supportExterns inputFiles check f = do
220 (e, w) <- compile supportExterns inputFiles check
221 maybeErr <- f (const w <$> e)
222 maybe (return ()) expectationFailure maybeErr
224checkMain :: [P.Module] -> IO ()
225checkMain ms =
226 unless (any ((== P.moduleNameFromString "Main") . P.getModuleName) ms)
227 (fail "Main module missing")
229checkShouldFailWith :: [String] -> P.MultipleErrors -> Maybe String
230checkShouldFailWith expected errs =
231 let actual = map P.errorCode $ P.runMultipleErrors errs
232 in if sort expected == sort (map T.unpack actual)
233 then Nothing
234 else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual
236assertCompiles
237 :: [(P.Module, P.ExternsFile)]
238 -> [FilePath]
239 -> Handle
240 -> Expectation
241assertCompiles supportExterns inputFiles outputFile =
242 assert supportExterns inputFiles checkMain $ \e ->
243 case e of
244 Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs
245 Right _ -> do
246 process <- findNodeProcess
247 let entryPoint = modulesDir </> "index.js"
248 writeFile entryPoint "require('Main').main()"
249 result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process
250 hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":"
251 case result of
252 Just (ExitSuccess, out, err)
253 | not (null err) -> return $ Just $ "Test wrote to stderr:\n\n" <> err
254 | not (null out) && trim (last (lines out)) == "Done" -> do
255 hPutStr outputFile out
256 return Nothing
257 | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out
258 Just (ExitFailure _, _, err) -> return $ Just err
259 Nothing -> return $ Just "Couldn't find node.js executable"
261assertCompilesWithWarnings
262 :: [(P.Module, P.ExternsFile)]
263 -> [FilePath]
264 -> [String]
265 -> Expectation
266assertCompilesWithWarnings supportExterns inputFiles shouldWarnWith =
267 assert supportExterns inputFiles checkMain $ \e ->
268 case e of
269 Left errs ->
270 return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs
271 Right warnings ->
272 return
273 . fmap (printAllWarnings warnings)
274 $ checkShouldFailWith shouldWarnWith warnings
276 where
277 printAllWarnings warnings =
278 (<> "\n\n" <> P.prettyPrintMultipleErrors P.defaultPPEOptions warnings)
280assertDoesNotCompile
281 :: [(P.Module, P.ExternsFile)]
282 -> [FilePath]
283 -> [String]
284 -> Expectation
285assertDoesNotCompile supportExterns inputFiles shouldFailWith =
286 assert supportExterns inputFiles noPreCheck $ \e ->
287 case e of
288 Left errs ->
289 return $ if null shouldFailWith
290 then Just $ "shouldFailWith declaration is missing (errors were: "
291 ++ show (map P.errorCode (P.runMultipleErrors errs))
292 ++ ")"
293 else checkShouldFailWith shouldFailWith errs
294 Right _ ->
295 return $ Just "Should not have compiled"
297 where
298 noPreCheck = const (return ())
300logpath :: FilePath
301logpath = "purescript-output"
303logfile :: FilePath
304logfile = "psc-tests.out"