git.iko.soy/rowtype-yoga/purescript-native
on 03bc072 help sign in
rowtype-yoga/purescript-native/tests/TestCompiler.hs
287 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)
34import qualified Data.Text as T
36import qualified Data.Map as M
38import Control.Monad
39import Control.Arrow ((***), (>>>))
41import Control.Monad.Reader
42import Control.Monad.Writer.Strict
43import Control.Monad.Trans.Except
45import System.Exit
46import System.Process hiding (cwd)
47import System.FilePath
48import System.Directory
49import System.IO.UTF8
50import System.IO.Silently
51import qualified System.FilePath.Glob as Glob
53import TestUtils
54import Test.Hspec
56main :: IO ()
57main = hspec spec
59spec :: Spec
60spec = do
62 (supportExterns, passingTestCases, warningTestCases, failingTestCases) <- runIO $ do
63 cwd <- getCurrentDirectory
64 let passing = cwd </> "examples" </> "passing"
65 let warning = cwd </> "examples" </> "warning"
66 let failing = cwd </> "examples" </> "failing"
67 let supportDir = cwd </> "tests" </> "support" </> "bower_components"
68 let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir
69 passingFiles <- getTestFiles passing <$> testGlob passing
70 warningFiles <- getTestFiles warning <$> testGlob warning
71 failingFiles <- getTestFiles failing <$> testGlob failing
72 supportPurs <- supportFiles "purs"
73 supportPursFiles <- readInput supportPurs
74 supportExterns <- runExceptT $ do
75 modules <- ExceptT . return $ P.parseModulesFromFiles id (map (fmap T.pack) supportPursFiles)
76 foreigns <- inferForeignModules modules
77 externs <- ExceptT . fmap fst . runTest $ P.make (makeActions foreigns) (map snd modules)
78 return (zip (map snd modules) externs)
79 case supportExterns of
80 Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs)
81 Right externs -> return (externs, passingFiles, warningFiles, failingFiles)
83 context "Passing examples" $
84 forM_ passingTestCases $ \testPurs ->
85 it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $
86 assertCompiles supportExterns testPurs
88 context "Warning examples" $
89 forM_ warningTestCases $ \testPurs -> do
90 let mainPath = getTestMain testPurs
91 expectedWarnings <- runIO $ getShouldWarnWith mainPath
92 it ("'" <> takeFileName mainPath <> "' should compile with warning(s) '" <> intercalate "', '" expectedWarnings <> "'") $
93 assertCompilesWithWarnings supportExterns testPurs expectedWarnings
95 context "Failing examples" $
96 forM_ failingTestCases $ \testPurs -> do
97 let mainPath = getTestMain testPurs
98 expectedFailures <- runIO $ getShouldFailWith mainPath
99 it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $
100 assertDoesNotCompile supportExterns testPurs expectedFailures
102 where
104 -- A glob for all purs and js files within a test directory
105 testGlob :: FilePath -> IO [FilePath]
106 testGlob = Glob.globDir1 (Glob.compile "**/*.purs")
108 -- Groups the test files so that a top-level file can have dependencies in a
109 -- subdirectory of the same name. The inner tuple contains a list of the
110 -- .purs files and the .js files for the test case.
111 getTestFiles :: FilePath -> [FilePath] -> [[FilePath]]
112 getTestFiles baseDir
113 = map (filter ((== ".purs") . takeExtensions) . map (baseDir </>))
114 . groupBy ((==) `on` extractPrefix)
115 . sortBy (compare `on` extractPrefix)
116 . map (makeRelative baseDir)
118 -- Takes the test entry point from a group of purs files - this is determined
119 -- by the file with the shortest path name, as everything but the main file
120 -- will be under a subdirectory.
121 getTestMain :: [FilePath] -> FilePath
122 getTestMain = minimumBy (compare `on` length)
124 -- Extracts the filename part of a .purs file, or if the file is in a
125 -- subdirectory, the first part of that directory path.
126 extractPrefix :: FilePath -> FilePath
127 extractPrefix fp =
128 let dir = takeDirectory fp
129 ext = reverse ".purs"
130 in if dir == "."
131 then maybe fp reverse $ stripPrefix ext $ reverse fp
132 else dir
134 -- Scans a file for @shouldFailWith directives in the comments, used to
135 -- determine expected failures
136 getShouldFailWith :: FilePath -> IO [String]
137 getShouldFailWith = extractPragma "shouldFailWith"
139 -- Scans a file for @shouldWarnWith directives in the comments, used to
140 -- determine expected warnings
141 getShouldWarnWith :: FilePath -> IO [String]
142 getShouldWarnWith = extractPragma "shouldWarnWith"
144 extractPragma :: String -> FilePath -> IO [String]
145 extractPragma pragma = fmap go . readUTF8File
146 where
147 go = lines >>> mapMaybe (stripPrefix ("-- @" ++ pragma ++ " ")) >>> map trim
149inferForeignModules
150 :: MonadIO m
151 => [(FilePath, P.Module)]
152 -> m (M.Map P.ModuleName FilePath)
153inferForeignModules = P.inferForeignModules . fromList
154 where
155 fromList :: [(FilePath, P.Module)] -> M.Map P.ModuleName (Either P.RebuildPolicy FilePath)
156 fromList = M.fromList . map ((P.getModuleName *** Right) . swap)
158trim :: String -> String
159trim = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
161modulesDir :: FilePath
162modulesDir = ".test_modules" </> "node_modules"
164makeActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make
165makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False)
166 { P.getInputTimestamp = getInputTimestamp
167 , P.getOutputTimestamp = getOutputTimestamp
168 }
169 where
170 getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime))
171 getInputTimestamp mn
172 | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever)
173 | otherwise = return (Left P.RebuildAlways)
174 where
175 isSupportModule = flip elem supportModules
177 getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime)
178 getOutputTimestamp mn = do
179 let filePath = modulesDir </> P.runModuleName mn
180 exists <- liftIO $ doesDirectoryExist filePath
181 return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing)
183readInput :: [FilePath] -> IO [(FilePath, String)]
184readInput inputFiles = forM inputFiles $ \inputFile -> do
185 text <- readUTF8File inputFile
186 return (inputFile, text)
188runTest :: P.Make a -> IO (Either P.MultipleErrors a, P.MultipleErrors)
189runTest = P.runMake P.defaultOptions
191compile
192 :: [(P.Module, P.ExternsFile)]
193 -> [FilePath]
194 -> ([P.Module] -> IO ())
195 -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors)
196compile supportExterns inputFiles check = silence $ runTest $ do
197 fs <- liftIO $ readInput inputFiles
198 ms <- P.parseModulesFromFiles id (map (fmap T.pack) fs)
199 foreigns <- inferForeignModules ms
200 liftIO (check (map snd ms))
201 let actions = makeActions foreigns
202 case ms of
203 [singleModule] -> pure <$> P.rebuildModule actions (map snd supportExterns) (snd singleModule)
204 _ -> P.make actions (map fst supportExterns ++ map snd ms)
206assert
207 :: [(P.Module, P.ExternsFile)]
208 -> [FilePath]
209 -> ([P.Module] -> IO ())
210 -> (Either P.MultipleErrors P.MultipleErrors -> IO (Maybe String))
211 -> Expectation
212assert supportExterns inputFiles check f = do
213 (e, w) <- compile supportExterns inputFiles check
214 maybeErr <- f (const w <$> e)
215 maybe (return ()) expectationFailure maybeErr
217checkMain :: [P.Module] -> IO ()
218checkMain ms =
219 unless (any ((== P.moduleNameFromString "Main") . P.getModuleName) ms)
220 (fail "Main module missing")
222checkShouldFailWith :: [String] -> P.MultipleErrors -> Maybe String
223checkShouldFailWith expected errs =
224 let actual = map P.errorCode $ P.runMultipleErrors errs
225 in if sort expected == sort actual
226 then Nothing
227 else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual
229assertCompiles
230 :: [(P.Module, P.ExternsFile)]
231 -> [FilePath]
232 -> Expectation
233assertCompiles supportExterns inputFiles =
234 assert supportExterns inputFiles checkMain $ \e ->
235 case e of
236 Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs
237 Right _ -> do
238 process <- findNodeProcess
239 let entryPoint = modulesDir </> "index.js"
240 writeFile entryPoint "require('Main').main()"
241 result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process
242 case result of
243 Just (ExitSuccess, out, err)
244 | not (null err) -> return $ Just $ "Test wrote to stderr:\n\n" <> err
245 | not (null out) && trim (last (lines out)) == "Done" -> return Nothing
246 | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out
247 Just (ExitFailure _, _, err) -> return $ Just err
248 Nothing -> return $ Just "Couldn't find node.js executable"
250assertCompilesWithWarnings
251 :: [(P.Module, P.ExternsFile)]
252 -> [FilePath]
253 -> [String]
254 -> Expectation
255assertCompilesWithWarnings supportExterns inputFiles shouldWarnWith =
256 assert supportExterns inputFiles checkMain $ \e ->
257 case e of
258 Left errs ->
259 return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs
260 Right warnings ->
261 return
262 . fmap (printAllWarnings warnings)
263 $ checkShouldFailWith shouldWarnWith warnings
265 where
266 printAllWarnings warnings =
267 (<> "\n\n" <> P.prettyPrintMultipleErrors P.defaultPPEOptions warnings)
269assertDoesNotCompile
270 :: [(P.Module, P.ExternsFile)]
271 -> [FilePath]
272 -> [String]
273 -> Expectation
274assertDoesNotCompile supportExterns inputFiles shouldFailWith =
275 assert supportExterns inputFiles noPreCheck $ \e ->
276 case e of
277 Left errs ->
278 return $ if null shouldFailWith
279 then Just $ "shouldFailWith declaration is missing (errors were: "
280 ++ show (map P.errorCode (P.runMultipleErrors errs))
281 ++ ")"
282 else checkShouldFailWith shouldFailWith errs
283 Right _ ->
284 return $ Just "Should not have compiled"
286 where
287 noPreCheck = const (return ())