@@ -18,13 +18,30 @@
18{-# LANGUAGE GeneralizedNewtypeDeriving #-}
18{-# LANGUAGE GeneralizedNewtypeDeriving #-}
19{-# LANGUAGE FlexibleInstances #-}
19{-# LANGUAGE FlexibleInstances #-}
21+-- Failing tests can specify the kind of error that should be thrown with a
22+-- @shouldFailWith declaration. For example:
24+-- "-- @shouldFailWith TypesDoNotUnify"
26+-- will cause the test to fail unless that module fails to compile with exactly
27+-- one TypesDoNotUnify error.
29+-- If a module is expected to produce multiple type errors, then use multiple
30+-- @shouldFailWith lines; for example:
32+-- -- @shouldFailWith TypesDoNotUnify
33+-- -- @shouldFailWith TypesDoNotUnify
34+-- -- @shouldFailWith TransitiveExportError
21module Main (main) where
36module Main (main) where
23import qualified Language.PureScript as P
38import qualified Language.PureScript as P
24import qualified Language.PureScript.CodeGen.JS as J
39import qualified Language.PureScript.CodeGen.JS as J
25import qualified Language.PureScript.CoreFn as CF
40import qualified Language.PureScript.CoreFn as CF
27−import Data.List (isSuffixOf)
42+import Data.Char (isSpace)
43+import Data.Maybe (mapMaybe, fromMaybe)
44+import Data.List (isSuffixOf, sort, stripPrefix)
28import Data.Traversable (traverse)
45import Data.Traversable (traverse)
29import Data.Time.Clock (UTCTime())
46import Data.Time.Clock (UTCTime())
@@ -33,6 +50,7 @@ import qualified Data.Map as M
33import Control.Monad
50import Control.Monad
34import Control.Monad.IO.Class (liftIO)
51import Control.Monad.IO.Class (liftIO)
35import Control.Applicative
52import Control.Applicative
53+import Control.Arrow ((>>>))
37import Control.Monad.Reader
55import Control.Monad.Reader
38import Control.Monad.Writer
56import Control.Monad.Writer
@@ -111,6 +129,8 @@ readInput inputFiles = forM inputFiles $ \inputFile -> do
111 text <- readFile inputFile
129 text <- readFile inputFile
112 return (inputFile, text)
130 return (inputFile, text)
132+type TestM = WriterT [(FilePath, String)] IO
114compile :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO (Either P.MultipleErrors P.Environment)
134compile :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO (Either P.MultipleErrors P.Environment)
115compile inputFiles foreigns = runTest $ do
135compile inputFiles foreigns = runTest $ do
116 fs <- liftIO $ readInput inputFiles
136 fs <- liftIO $ readInput inputFiles
@@ -120,17 +140,17 @@ compile inputFiles foreigns = runTest $ do
120assert :: [FilePath] ->
140assert :: [FilePath] ->
121 M.Map P.ModuleName (FilePath, P.ForeignJS) ->
141 M.Map P.ModuleName (FilePath, P.ForeignJS) ->
122 (Either P.MultipleErrors P.Environment -> IO (Maybe String)) ->
142 (Either P.MultipleErrors P.Environment -> IO (Maybe String)) ->
124assert inputFiles foreigns f = do
144assert inputFiles foreigns f = do
125− e <- compile inputFiles foreigns
145+ e <- liftIO $ compile inputFiles foreigns
126− maybeErr <- f e
146+ maybeErr <- liftIO $ f e
127 case maybeErr of
147 case maybeErr of
128− Just err -> putStrLn err >> exitFailure
148+ Just err -> tell [(last inputFiles, err)]
129 Nothing -> return ()
149 Nothing -> return ()
131−assertCompiles :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO ()
151+assertCompiles :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> TestM ()
132assertCompiles inputFiles foreigns = do
152assertCompiles inputFiles foreigns = do
133− putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully"
153+ liftIO . putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully"
134 assert inputFiles foreigns $ \e ->
154 assert inputFiles foreigns $ \e ->
135 case e of
155 case e of
136 Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs
156 Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs
@@ -144,13 +164,40 @@ assertCompiles inputFiles foreigns = do
144 Just (ExitFailure _, _, err) -> return $ Just err
164 Just (ExitFailure _, _, err) -> return $ Just err
145 Nothing -> return $ Just "Couldn't find node.js executable"
165 Nothing -> return $ Just "Couldn't find node.js executable"
147−assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO ()
167+assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> TestM ()
148assertDoesNotCompile inputFiles foreigns = do
168assertDoesNotCompile inputFiles foreigns = do
169+ let testFile = last inputFiles
149− putStrLn $ "Assert " ++ last inputFiles ++ " does not compile"
170+ liftIO . putStrLn $ "Assert " ++ testFile ++ " does not compile"
171+ shouldFailWith <- getShouldFailWith testFile
150 assert inputFiles foreigns $ \e ->
172 assert inputFiles foreigns $ \e ->
151 case e of
173 case e of
152− Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> return Nothing
175+ putStrLn (P.prettyPrintMultipleErrors False errs)
176+ return $ if null shouldFailWith
177+ then Just $ "shouldFailWith declaration is missing (errors were: "
178+ ++ show (map P.errorCode (P.runMultipleErrors errs))
180+ else checkShouldFailWith shouldFailWith errs
153− Right _ -> return $ Just "Should not have compiled"
182+ return $ Just "Should not have compiled"
189+ >>> mapMaybe (stripPrefix "-- @shouldFailWith ")
193+ checkShouldFailWith expected errs =
194+ let actual = map P.errorCode $ P.runMultipleErrors errs
195+ in if sort expected == sort actual
197+ else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual
200+ dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
155findNodeProcess :: IO (Maybe String)
202findNodeProcess :: IO (Maybe String)
156findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
203findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
@@ -172,14 +219,24 @@ main = do
172 Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles
219 Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles
174 let passing = cwd </> "examples" </> "passing"
221 let passing = cwd </> "examples" </> "passing"
175− passingTestCases <- getDirectoryContents passing
222+ passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passing
176− forM_ passingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
177− assertCompiles (supportPurs ++ [passing </> inputFile]) foreigns
178 let failing = cwd </> "examples" </> "failing"
223 let failing = cwd </> "examples" </> "failing"
179− failingTestCases <- getDirectoryContents failing
224+ failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing
180− forM_ failingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
225+
226+ failures <- execWriterT $ do
227+ forM_ passingTestCases $ \inputFile ->
228+ assertCompiles (supportPurs ++ [passing </> inputFile]) foreigns
229+ forM_ failingTestCases $ \inputFile ->
181− assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns
230+ assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns
182− exitSuccess
233+ then exitSuccess
235+ putStrLn "Failures:"
236+ forM_ failures $ \(fp, err) ->
237+ let fp' = fromMaybe fp $ stripPrefix (failing ++ [pathSeparator]) fp
238+ in putStrLn $ fp' ++ ": " ++ err
184fetchSupportCode :: IO ()
241fetchSupportCode :: IO ()
185fetchSupportCode = do
242fetchSupportCode = do