git.iko.soy/rowtype-yoga/purescript-native
on cd4c708 help sign in
rowtype-yoga/purescript-native/tests/TestCompiler.hs
286 lines 11 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, minimumBy)
31import Data.Maybe (mapMaybe)
32import Data.Time.Clock (UTCTime())
33import Data.Tuple (swap)
35import qualified Data.Map as M
37import Control.Monad
38import Control.Arrow ((***), (>>>))
40import Control.Monad.Reader
41import Control.Monad.Writer.Strict
42import Control.Monad.Trans.Except
44import System.Exit
45import System.Process hiding (cwd)
46import System.FilePath
47import System.Directory
48import System.IO.UTF8
49import System.IO.Silently
50import qualified System.FilePath.Glob as Glob
52import TestUtils
53import Test.Hspec
55main :: IO ()
56main = hspec spec
58spec :: Spec
59spec = do
61 (supportExterns, passingTestCases, warningTestCases, failingTestCases) <- runIO $ do
62 cwd <- getCurrentDirectory
63 let passing = cwd </> "examples" </> "passing"
64 let warning = cwd </> "examples" </> "warning"
65 let failing = cwd </> "examples" </> "failing"
66 let supportDir = cwd </> "tests" </> "support" </> "bower_components"
67 let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir
68 passingFiles <- getTestFiles passing <$> testGlob passing
69 warningFiles <- getTestFiles warning <$> testGlob warning
70 failingFiles <- getTestFiles failing <$> testGlob failing
71 supportPurs <- supportFiles "purs"
72 supportPursFiles <- readInput supportPurs
73 supportExterns <- runExceptT $ do
74 modules <- ExceptT . return $ P.parseModulesFromFiles id supportPursFiles
75 foreigns <- inferForeignModules modules
76 externs <- ExceptT . fmap fst . runTest $ P.make (makeActions foreigns) (map snd modules)
77 return (zip (map snd modules) externs)
78 case supportExterns of
79 Left errs -> fail (P.prettyPrintMultipleErrors False errs)
80 Right externs -> return (externs, passingFiles, warningFiles, failingFiles)
82 context "Passing examples" $
83 forM_ passingTestCases $ \testPurs ->
84 it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $
85 assertCompiles supportExterns testPurs
87 context "Warning examples" $
88 forM_ warningTestCases $ \testPurs -> do
89 let mainPath = getTestMain testPurs
90 expectedWarnings <- runIO $ getShouldWarnWith mainPath
91 it ("'" <> takeFileName mainPath <> "' should compile with warning(s) '" <> intercalate "', '" expectedWarnings <> "'") $
92 assertCompilesWithWarnings supportExterns testPurs expectedWarnings
94 context "Failing examples" $
95 forM_ failingTestCases $ \testPurs -> do
96 let mainPath = getTestMain testPurs
97 expectedFailures <- runIO $ getShouldFailWith mainPath
98 it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $
99 assertDoesNotCompile supportExterns testPurs expectedFailures
101 where
103 -- A glob for all purs and js files within a test directory
104 testGlob :: FilePath -> IO [FilePath]
105 testGlob = Glob.globDir1 (Glob.compile "**/*.purs")
107 -- Groups the test files so that a top-level file can have dependencies in a
108 -- subdirectory of the same name. The inner tuple contains a list of the
109 -- .purs files and the .js files for the test case.
110 getTestFiles :: FilePath -> [FilePath] -> [[FilePath]]
111 getTestFiles baseDir
112 = map (filter ((== ".purs") . takeExtensions) . 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 = minimumBy (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 = extractPragma "shouldFailWith"
138 -- Scans a file for @shouldWarnWith directives in the comments, used to
139 -- determine expected warnings
140 getShouldWarnWith :: FilePath -> IO [String]
141 getShouldWarnWith = extractPragma "shouldWarnWith"
143 extractPragma :: String -> FilePath -> IO [String]
144 extractPragma pragma = fmap go . readUTF8File
145 where
146 go = lines >>> mapMaybe (stripPrefix ("-- @" ++ pragma ++ " ")) >>> map trim
148inferForeignModules
149 :: MonadIO m
150 => [(FilePath, P.Module)]
151 -> m (M.Map P.ModuleName FilePath)
152inferForeignModules = P.inferForeignModules . fromList
153 where
154 fromList :: [(FilePath, P.Module)] -> M.Map P.ModuleName (Either P.RebuildPolicy FilePath)
155 fromList = M.fromList . map ((P.getModuleName *** Right) . swap)
157trim :: String -> String
158trim = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
160modulesDir :: FilePath
161modulesDir = ".test_modules" </> "node_modules"
163makeActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make
164makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False)
165 { P.getInputTimestamp = getInputTimestamp
166 , P.getOutputTimestamp = getOutputTimestamp
167 }
168 where
169 getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime))
170 getInputTimestamp mn
171 | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever)
172 | otherwise = return (Left P.RebuildAlways)
173 where
174 isSupportModule = flip elem supportModules
176 getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime)
177 getOutputTimestamp mn = do
178 let filePath = modulesDir </> P.runModuleName mn
179 exists <- liftIO $ doesDirectoryExist filePath
180 return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing)
182readInput :: [FilePath] -> IO [(FilePath, String)]
183readInput inputFiles = forM inputFiles $ \inputFile -> do
184 text <- readUTF8File inputFile
185 return (inputFile, text)
187runTest :: P.Make a -> IO (Either P.MultipleErrors a, P.MultipleErrors)
188runTest = P.runMake P.defaultOptions
190compile
191 :: [(P.Module, P.ExternsFile)]
192 -> [FilePath]
193 -> ([P.Module] -> IO ())
194 -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors)
195compile supportExterns inputFiles check = silence $ runTest $ do
196 fs <- liftIO $ readInput inputFiles
197 ms <- P.parseModulesFromFiles id fs
198 foreigns <- inferForeignModules ms
199 liftIO (check (map snd ms))
200 let actions = makeActions foreigns
201 case ms of
202 [singleModule] -> pure <$> P.rebuildModule actions (map snd supportExterns) (snd singleModule)
203 _ -> P.make actions (map fst supportExterns ++ map snd ms)
205assert
206 :: [(P.Module, P.ExternsFile)]
207 -> [FilePath]
208 -> ([P.Module] -> IO ())
209 -> (Either P.MultipleErrors P.MultipleErrors -> IO (Maybe String))
210 -> Expectation
211assert supportExterns inputFiles check f = do
212 (e, w) <- compile supportExterns inputFiles check
213 maybeErr <- f (const w <$> e)
214 maybe (return ()) expectationFailure maybeErr
216checkMain :: [P.Module] -> IO ()
217checkMain ms =
218 unless (any ((== P.moduleNameFromString "Main") . P.getModuleName) ms)
219 (fail "Main module missing")
221checkShouldFailWith :: [String] -> P.MultipleErrors -> Maybe String
222checkShouldFailWith expected errs =
223 let actual = map P.errorCode $ P.runMultipleErrors errs
224 in if sort expected == sort actual
225 then Nothing
226 else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual
228assertCompiles
229 :: [(P.Module, P.ExternsFile)]
230 -> [FilePath]
231 -> Expectation
232assertCompiles supportExterns inputFiles =
233 assert supportExterns inputFiles checkMain $ \e ->
234 case e of
235 Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs
236 Right _ -> do
237 process <- findNodeProcess
238 let entryPoint = modulesDir </> "index.js"
239 writeFile entryPoint "require('Main').main()"
240 result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process
241 case result of
242 Just (ExitSuccess, out, err)
243 | not (null err) -> return $ Just $ "Test wrote to stderr:\n\n" <> err
244 | not (null out) && trim (last (lines out)) == "Done" -> return Nothing
245 | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out
246 Just (ExitFailure _, _, err) -> return $ Just err
247 Nothing -> return $ Just "Couldn't find node.js executable"
249assertCompilesWithWarnings
250 :: [(P.Module, P.ExternsFile)]
251 -> [FilePath]
252 -> [String]
253 -> Expectation
254assertCompilesWithWarnings supportExterns inputFiles shouldWarnWith =
255 assert supportExterns inputFiles checkMain $ \e ->
256 case e of
257 Left errs ->
258 return . Just . P.prettyPrintMultipleErrors False $ errs
259 Right warnings ->
260 return
261 . fmap (printAllWarnings warnings)
262 $ checkShouldFailWith shouldWarnWith warnings
264 where
265 printAllWarnings warnings =
266 (<> "\n\n" <> P.prettyPrintMultipleErrors False warnings)
268assertDoesNotCompile
269 :: [(P.Module, P.ExternsFile)]
270 -> [FilePath]
271 -> [String]
272 -> Expectation
273assertDoesNotCompile supportExterns inputFiles shouldFailWith =
274 assert supportExterns inputFiles noPreCheck $ \e ->
275 case e of
276 Left errs ->
277 return $ if null shouldFailWith
278 then Just $ "shouldFailWith declaration is missing (errors were: "
279 ++ show (map P.errorCode (P.runMultipleErrors errs))
280 ++ ")"
281 else checkShouldFailWith shouldFailWith errs
282 Right _ ->
283 return $ Just "Should not have compiled"
285 where
286 noPreCheck = const (return ())