git.iko.soy/rowtype-yoga/purescript-native
on 55b797d help sign in
rowtype-yoga/purescript-native/tests/TestCompiler.hs
251 lines 9.3 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)
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, failingTestCases) <- runIO $ do
62 cwd <- getCurrentDirectory
63 let passing = cwd </> "examples" </> "passing"
64 let failing = cwd </> "examples" </> "failing"
65 let supportDir = cwd </> "tests" </> "support" </> "bower_components"
66 let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir
67 passingFiles <- getTestFiles passing <$> testGlob passing
68 failingFiles <- getTestFiles failing <$> testGlob failing
69 supportPurs <- supportFiles "purs"
70 supportPursFiles <- readInput supportPurs
71 supportExterns <- runExceptT $ do
72 modules <- ExceptT . return $ P.parseModulesFromFiles id supportPursFiles
73 foreigns <- inferForeignModules modules
74 externs <- ExceptT . runTest $ P.make (makeActions foreigns) (map snd modules)
75 return (zip (map snd modules) externs)
76 case supportExterns of
77 Left errs -> fail (P.prettyPrintMultipleErrors False errs)
78 Right externs -> return (externs, passingFiles, failingFiles)
80 context ("Passing examples") $ do
81 forM_ passingTestCases $ \testPurs ->
82 it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $
83 assertCompiles supportExterns testPurs
85 context ("Failing examples") $ do
86 forM_ failingTestCases $ \testPurs -> do
87 let mainPath = getTestMain testPurs
88 expectedFailures <- runIO $ getShouldFailWith mainPath
89 it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $
90 assertDoesNotCompile supportExterns testPurs expectedFailures
92 where
94 -- A glob for all purs and js files within a test directory
95 testGlob :: FilePath -> IO [FilePath]
96 testGlob = Glob.globDir1 (Glob.compile "**/*.purs")
98 -- Groups the test files so that a top-level file can have dependencies in a
99 -- subdirectory of the same name. The inner tuple contains a list of the
100 -- .purs files and the .js files for the test case.
101 getTestFiles :: FilePath -> [FilePath] -> [[FilePath]]
102 getTestFiles baseDir
103 = map (filter ((== ".purs") . takeExtensions))
104 . map (map (baseDir </>))
105 . groupBy ((==) `on` extractPrefix)
106 . sortBy (compare `on` extractPrefix)
107 . map (makeRelative baseDir)
109 -- Takes the test entry point from a group of purs files - this is determined
110 -- by the file with the shortest path name, as everything but the main file
111 -- will be under a subdirectory.
112 getTestMain :: [FilePath] -> FilePath
113 getTestMain = head . sortBy (compare `on` length)
115 -- Extracts the filename part of a .purs file, or if the file is in a
116 -- subdirectory, the first part of that directory path.
117 extractPrefix :: FilePath -> FilePath
118 extractPrefix fp =
119 let dir = takeDirectory fp
120 ext = reverse ".purs"
121 in if dir == "."
122 then maybe fp reverse $ stripPrefix ext $ reverse fp
123 else dir
125 -- Scans a file for @shouldFailWith directives in the comments, used to
126 -- determine expected failures
127 getShouldFailWith :: FilePath -> IO [String]
128 getShouldFailWith = fmap extractFailWiths . readUTF8File
129 where
130 extractFailWiths = lines >>> mapMaybe (stripPrefix "-- @shouldFailWith ") >>> map trim
132inferForeignModules
133 :: MonadIO m
134 => [(FilePath, P.Module)]
135 -> m (M.Map P.ModuleName FilePath)
136inferForeignModules = P.inferForeignModules . fromList
137 where
138 fromList :: [(FilePath, P.Module)] -> M.Map P.ModuleName (Either P.RebuildPolicy FilePath)
139 fromList = M.fromList . map ((P.getModuleName *** Right) . swap)
141trim :: String -> String
142trim = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
144modulesDir :: FilePath
145modulesDir = ".test_modules" </> "node_modules"
147makeActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make
148makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False)
149 { P.getInputTimestamp = getInputTimestamp
150 , P.getOutputTimestamp = getOutputTimestamp
151 }
152 where
153 getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime))
154 getInputTimestamp mn
155 | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever)
156 | otherwise = return (Left P.RebuildAlways)
157 where
158 isSupportModule = flip elem supportModules
160 getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime)
161 getOutputTimestamp mn = do
162 let filePath = modulesDir </> P.runModuleName mn
163 exists <- liftIO $ doesDirectoryExist filePath
164 return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing)
166readInput :: [FilePath] -> IO [(FilePath, String)]
167readInput inputFiles = forM inputFiles $ \inputFile -> do
168 text <- readUTF8File inputFile
169 return (inputFile, text)
171type TestM = WriterT [(FilePath, String)] IO
173runTest :: P.Make a -> IO (Either P.MultipleErrors a)
174runTest = fmap fst . P.runMake P.defaultOptions
176compile
177 :: [(P.Module, P.ExternsFile)]
178 -> [FilePath]
179 -> ([P.Module] -> IO ())
180 -> IO (Either P.MultipleErrors [P.ExternsFile])
181compile supportExterns inputFiles check = silence $ runTest $ do
182 fs <- liftIO $ readInput inputFiles
183 ms <- P.parseModulesFromFiles id fs
184 foreigns <- inferForeignModules ms
185 liftIO (check (map snd ms))
186 let actions = makeActions foreigns
187 case ms of
188 [singleModule] -> pure <$> P.rebuildModule actions (map snd supportExterns) (snd singleModule)
189 _ -> P.make actions (map fst supportExterns ++ map snd ms)
191assert
192 :: [(P.Module, P.ExternsFile)]
193 -> [FilePath]
194 -> ([P.Module] -> IO ())
195 -> (Either P.MultipleErrors [P.ExternsFile] -> IO (Maybe String))
196 -> Expectation
197assert supportExterns inputFiles check f = do
198 e <- compile supportExterns inputFiles check
199 maybeErr <- f e
200 maybe (return ()) expectationFailure maybeErr
202assertCompiles
203 :: [(P.Module, P.ExternsFile)]
204 -> [FilePath]
205 -> Expectation
206assertCompiles supportExterns inputFiles = do
207 assert supportExterns inputFiles checkMain $ \e ->
208 case e of
209 Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs
210 Right _ -> do
211 process <- findNodeProcess
212 let entryPoint = modulesDir </> "index.js"
213 writeFile entryPoint "require('Main').main()"
214 result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process
215 case result of
216 Just (ExitSuccess, out, err)
217 | not (null err) -> return $ Just $ "Test wrote to stderr:\n\n" <> err
218 | not (null out) && trim (last (lines out)) == "Done" -> return Nothing
219 | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out
220 Just (ExitFailure _, _, err) -> return $ Just err
221 Nothing -> return $ Just "Couldn't find node.js executable"
222 where
223 checkMain ms =
224 unless (any ((== P.moduleNameFromString "Main") . P.getModuleName) ms)
225 (fail "Main module missing")
227assertDoesNotCompile
228 :: [(P.Module, P.ExternsFile)]
229 -> [FilePath]
230 -> [String]
231 -> Expectation
232assertDoesNotCompile supportExterns inputFiles shouldFailWith = do
233 assert supportExterns inputFiles noPreCheck $ \e ->
234 case e of
235 Left errs ->
236 return $ if null shouldFailWith
237 then Just $ "shouldFailWith declaration is missing (errors were: "
238 ++ show (map P.errorCode (P.runMultipleErrors errs))
239 ++ ")"
240 else checkShouldFailWith shouldFailWith errs
241 Right _ ->
242 return $ Just "Should not have compiled"
244 where
245 noPreCheck = const (return ())
247 checkShouldFailWith expected errs =
248 let actual = map P.errorCode $ P.runMultipleErrors errs
249 in if sort expected == sort actual
250 then Nothing
251 else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual