git.iko.soy/rowtype-yoga/purescript-native
on d4c9de2 help sign in
rowtype-yoga/purescript-native/tests/TestCompiler.hs
227 lines 8.6 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 (supportPurs, 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 return (supportPurs, supportForeigns, passingFiles, failingFiles)
72 context ("Passing examples") $ do
73 forM_ passingTestCases $ \(testPurs, testJS) ->
74 it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $ do
75 testForeigns <- loadForeigns testJS
76 assertCompiles (supportPurs ++ testPurs) (supportForeigns <> testForeigns)
78 context ("Failing examples") $ do
79 forM_ failingTestCases $ \(testPurs, testJS) -> do
80 let mainPath = getTestMain testPurs
81 expectedFailures <- runIO $ getShouldFailWith mainPath
82 it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $ do
83 testForeigns <- loadForeigns testJS
84 assertDoesNotCompile (supportPurs ++ testPurs) (supportForeigns <> testForeigns) expectedFailures
86 where
88 -- A glob for all purs and js files within a test directory
89 testGlob :: FilePath -> IO [FilePath]
90 testGlob dir = join . fst <$> Glob.globDir (map Glob.compile ["**/*.purs", "**/*.js"]) dir
92 -- Loads foreign modules from source files
93 loadForeigns :: [FilePath] -> IO (M.Map P.ModuleName FilePath)
94 loadForeigns paths = do
95 files <- forM paths (\f -> (f,) <$> readUTF8File f)
96 Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles files
97 return foreigns
99 -- Groups the test files so that a top-level file can have dependencies in a
100 -- subdirectory of the same name. The inner tuple contains a list of the
101 -- .purs files and the .js files for the test case.
102 getTestFiles :: FilePath -> [FilePath] -> [([FilePath], [FilePath])]
103 getTestFiles baseDir
104 = map (partition ((== ".purs") . takeExtensions))
105 . map (map (baseDir </>))
106 . groupBy ((==) `on` extractPrefix)
107 . sortBy (compare `on` extractPrefix)
108 . map (makeRelative baseDir)
110 -- Takes the test entry point from a group of purs files - this is determined
111 -- by the file with the shortest path name, as everything but the main file
112 -- will be under a subdirectory.
113 getTestMain :: [FilePath] -> FilePath
114 getTestMain = head . sortBy (compare `on` length)
116 -- Extracts the filename part of a .purs file, or if the file is in a
117 -- subdirectory, the first part of that directory path.
118 extractPrefix :: FilePath -> FilePath
119 extractPrefix fp =
120 let dir = takeDirectory fp
121 ext = reverse ".purs"
122 in if dir == "."
123 then maybe fp reverse $ stripPrefix ext $ reverse fp
124 else dir
126 -- Scans a file for @shouldFailWith directives in the comments, used to
127 -- determine expected failures
128 getShouldFailWith :: FilePath -> IO [String]
129 getShouldFailWith = fmap extractFailWiths . readUTF8File
130 where
131 extractFailWiths = lines >>> mapMaybe (stripPrefix "-- @shouldFailWith ") >>> map trim
133trim :: String -> String
134trim = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
136modulesDir :: FilePath
137modulesDir = ".test_modules" </> "node_modules"
139makeActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make
140makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False)
141 { P.getInputTimestamp = getInputTimestamp
142 , P.getOutputTimestamp = getOutputTimestamp
143 }
144 where
145 getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime))
146 getInputTimestamp mn
147 | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever)
148 | otherwise = return (Left P.RebuildAlways)
149 where
150 isSupportModule = flip elem supportModules
152 getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime)
153 getOutputTimestamp mn = do
154 let filePath = modulesDir </> P.runModuleName mn
155 exists <- liftIO $ doesDirectoryExist filePath
156 return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing)
158readInput :: [FilePath] -> IO [(FilePath, String)]
159readInput inputFiles = forM inputFiles $ \inputFile -> do
160 text <- readUTF8File inputFile
161 return (inputFile, text)
163type TestM = WriterT [(FilePath, String)] IO
165runTest :: P.Make a -> IO (Either P.MultipleErrors a)
166runTest = fmap fst . P.runMake P.defaultOptions
168compile
169 :: [FilePath]
170 -> M.Map P.ModuleName FilePath
171 -> IO (Either P.MultipleErrors P.Environment)
172compile inputFiles foreigns = silence $ runTest $ do
173 fs <- liftIO $ readInput inputFiles
174 ms <- P.parseModulesFromFiles id fs
175 P.make (makeActions foreigns) (map snd ms)
177assert
178 :: [FilePath]
179 -> M.Map P.ModuleName FilePath
180 -> (Either P.MultipleErrors P.Environment -> IO (Maybe String))
181 -> Expectation
182assert inputFiles foreigns f = do
183 e <- compile inputFiles foreigns
184 maybeErr <- f e
185 maybe (return ()) expectationFailure maybeErr
187assertCompiles :: [FilePath] -> M.Map P.ModuleName FilePath -> Expectation
188assertCompiles inputFiles foreigns = do
189 assert inputFiles foreigns $ \e ->
190 case e of
191 Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs
192 Right _ -> do
193 process <- findNodeProcess
194 let entryPoint = modulesDir </> "index.js"
195 writeFile entryPoint "require('Main').main()"
196 result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process
197 case result of
198 Just (ExitSuccess, out, err)
199 | not (null err) -> return $ Just $ "Test wrote to stderr:\n\n" <> err
200 | not (null out) && trim (last (lines out)) == "Done" -> return Nothing
201 | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out
202 Just (ExitFailure _, _, err) -> return $ Just err
203 Nothing -> return $ Just "Couldn't find node.js executable"
205assertDoesNotCompile
206 :: [FilePath]
207 -> M.Map P.ModuleName FilePath
208 -> [String]
209 -> Expectation
210assertDoesNotCompile inputFiles foreigns shouldFailWith = do
211 assert inputFiles foreigns $ \e ->
212 case e of
213 Left errs -> do
214 return $ if null shouldFailWith
215 then Just $ "shouldFailWith declaration is missing (errors were: "
216 ++ show (map P.errorCode (P.runMultipleErrors errs))
217 ++ ")"
218 else checkShouldFailWith shouldFailWith errs
219 Right _ ->
220 return $ Just "Should not have compiled"
222 where
223 checkShouldFailWith 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