git.iko.soy/rowtype-yoga/purescript-native
on efc697d help sign in
rowtype-yoga/purescript-native/tests/TestCompiler.hs
194 lines 6.8 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.Maybe (mapMaybe, fromMaybe)
30import Data.List (isSuffixOf, sort, stripPrefix)
31import Data.Time.Clock (UTCTime())
33import qualified Data.Map as M
35import Control.Monad
36import Control.Arrow ((>>>))
38import Control.Monad.Reader
39import Control.Monad.Writer.Strict
40import Control.Monad.Trans.Except
42import System.Exit
43import System.Process hiding (cwd)
44import System.FilePath
45import System.Directory
46import System.IO.UTF8
47import qualified System.FilePath.Glob as Glob
49import TestUtils
51main :: IO ()
52main = do
53 cwd <- getCurrentDirectory
55 let supportDir = cwd </> "tests" </> "support" </> "flattened"
56 let supportFiles ext = Glob.globDir1 (Glob.compile ("*." ++ ext)) supportDir
58 supportPurs <- supportFiles "purs"
59 supportJS <- supportFiles "js"
61 foreignFiles <- forM supportJS (\f -> (f,) <$> readUTF8File f)
62 Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles
64 let passing = cwd </> "examples" </> "passing"
65 passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passing
66 let failing = cwd </> "examples" </> "failing"
67 failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing
69 failures <- execWriterT $ do
70 forM_ passingTestCases $ \inputFile ->
71 assertCompiles (supportPurs ++ [passing </> inputFile]) foreigns
72 forM_ failingTestCases $ \inputFile ->
73 assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns
75 if null failures
76 then pure ()
77 else do
78 putStrLn "Failures:"
79 forM_ failures $ \(fp, err) ->
80 let fp' = fromMaybe fp $ stripPrefix (failing ++ [pathSeparator]) fp
81 in putStrLn $ fp' ++ ": " ++ err
82 exitFailure
84modulesDir :: FilePath
85modulesDir = ".test_modules" </> "node_modules"
87makeActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make
88makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False)
89 { P.getInputTimestamp = getInputTimestamp
90 , P.getOutputTimestamp = getOutputTimestamp
91 }
92 where
93 getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime))
94 getInputTimestamp mn
95 | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever)
96 | otherwise = return (Left P.RebuildAlways)
97 where
98 isSupportModule = flip elem supportModules
100 getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime)
101 getOutputTimestamp mn = do
102 let filePath = modulesDir </> P.runModuleName mn
103 exists <- liftIO $ doesDirectoryExist filePath
104 return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing)
106readInput :: [FilePath] -> IO [(FilePath, String)]
107readInput inputFiles = forM inputFiles $ \inputFile -> do
108 text <- readUTF8File inputFile
109 return (inputFile, text)
111type TestM = WriterT [(FilePath, String)] IO
113runTest :: P.Make a -> IO (Either P.MultipleErrors a)
114runTest = fmap fst . P.runMake P.defaultOptions
116compile :: [FilePath] -> M.Map P.ModuleName FilePath -> IO (Either P.MultipleErrors P.Environment)
117compile inputFiles foreigns = runTest $ do
118 fs <- liftIO $ readInput inputFiles
119 ms <- P.parseModulesFromFiles id fs
120 P.make (makeActions foreigns) (map snd ms)
122assert :: [FilePath] ->
123 M.Map P.ModuleName FilePath ->
124 (Either P.MultipleErrors P.Environment -> IO (Maybe String)) ->
125 TestM ()
126assert inputFiles foreigns f = do
127 e <- liftIO $ compile inputFiles foreigns
128 maybeErr <- liftIO $ f e
129 case maybeErr of
130 Just err -> tell [(last inputFiles, err)]
131 Nothing -> return ()
133assertCompiles :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()
134assertCompiles inputFiles foreigns = do
135 liftIO . putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully"
136 assert inputFiles foreigns $ \e ->
137 case e of
138 Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs
139 Right _ -> do
140 process <- findNodeProcess
141 let entryPoint = modulesDir </> "index.js"
142 writeFile entryPoint "require('Main').main()"
143 result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process
144 case result of
145 Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing
146 Just (ExitFailure _, _, err) -> return $ Just err
147 Nothing -> return $ Just "Couldn't find node.js executable"
149assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()
150assertDoesNotCompile inputFiles foreigns = do
151 let testFile = last inputFiles
152 liftIO . putStrLn $ "Assert " ++ testFile ++ " does not compile"
153 shouldFailWith <- getShouldFailWith testFile
154 assert inputFiles foreigns $ \e ->
155 case e of
156 Left errs -> do
157 putStrLn (P.prettyPrintMultipleErrors False errs)
158 return $ if null shouldFailWith
159 then Just $ "shouldFailWith declaration is missing (errors were: "
160 ++ show (map P.errorCode (P.runMultipleErrors errs))
161 ++ ")"
162 else checkShouldFailWith shouldFailWith errs
163 Right _ ->
164 return $ Just "Should not have compiled"
166 where
167 getShouldFailWith =
168 readUTF8File
169 >>> liftIO
170 >>> fmap ( lines
171 >>> mapMaybe (stripPrefix "-- @shouldFailWith ")
172 >>> map trim
173 )
175 checkShouldFailWith expected errs =
176 let actual = map P.errorCode $ P.runMultipleErrors errs
177 in if sort expected == sort actual
178 then Nothing
179 else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual
181 trim =
182 dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
184supportModules :: [String]
185supportModules =
186 [ "Control.Monad.Eff.Class"
187 , "Control.Monad.Eff.Console"
188 , "Control.Monad.Eff"
189 , "Control.Monad.Eff.Unsafe"
190 , "Control.Monad.ST"
191 , "Data.Function"
192 , "Prelude"
193 , "Test.Assert"
194 ]