@@ -18,13 +18,30 @@
1818{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1919{-# LANGUAGE FlexibleInstances #-}
2020
21+-- Failing tests can specify the kind of error that should be thrown with a
22+-- @shouldFailWith declaration. For example:
23+--
24+-- "-- @shouldFailWith TypesDoNotUnify"
25+--
26+-- will cause the test to fail unless that module fails to compile with exactly
27+-- one TypesDoNotUnify error.
28+--
29+-- If a module is expected to produce multiple type errors, then use multiple
30+-- @shouldFailWith lines; for example:
31+--
32+-- -- @shouldFailWith TypesDoNotUnify
33+-- -- @shouldFailWith TypesDoNotUnify
34+-- -- @shouldFailWith TransitiveExportError
35+
2136module Main (main) where
2237
2338import qualified Language.PureScript as P
2439import qualified Language.PureScript.CodeGen.JS as J
2540import qualified Language.PureScript.CoreFn as CF
2641
27−import Data.List (isSuffixOf)
42+import Data.Char (isSpace)
43+import Data.Maybe (mapMaybe, fromMaybe)
44+import Data.List (isSuffixOf, sort, stripPrefix)
2845import Data.Traversable (traverse)
2946import Data.Time.Clock (UTCTime())
3047
@@ -33,6 +50,7 @@ import qualified Data.Map as M
3350import Control.Monad
3451import Control.Monad.IO.Class (liftIO)
3552import Control.Applicative
53+import Control.Arrow ((>>>))
3654
3755import Control.Monad.Reader
3856import Control.Monad.Writer
@@ -111,6 +129,8 @@ readInput inputFiles = forM inputFiles $ \inputFile -> do
111129 text <- readFile inputFile
112130 return (inputFile, text)
113131
132+type TestM = WriterT [(FilePath, String)] IO
133+
114134compile :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO (Either P.MultipleErrors P.Environment)
115135compile inputFiles foreigns = runTest $ do
116136 fs <- liftIO $ readInput inputFiles
@@ -120,17 +140,17 @@ compile inputFiles foreigns = runTest $ do
120140assert :: [FilePath] ->
121141 M.Map P.ModuleName (FilePath, P.ForeignJS) ->
122142 (Either P.MultipleErrors P.Environment -> IO (Maybe String)) ->
123− IO ()
143+ TestM ()
124144assert inputFiles foreigns f = do
125− e <- compile inputFiles foreigns
126− maybeErr <- f e
145+ e <- liftIO $ compile inputFiles foreigns
146+ maybeErr <- liftIO $ f e
127147 case maybeErr of
128− Just err -> putStrLn err >> exitFailure
148+ Just err -> tell [(last inputFiles, err)]
129149 Nothing -> return ()
130150
131−assertCompiles :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO ()
151+assertCompiles :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> TestM ()
132152assertCompiles inputFiles foreigns = do
133− putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully"
153+ liftIO . putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully"
134154 assert inputFiles foreigns $ \e ->
135155 case e of
136156 Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs
@@ -144,13 +164,40 @@ assertCompiles inputFiles foreigns = do
144164 Just (ExitFailure _, _, err) -> return $ Just err
145165 Nothing -> return $ Just "Couldn't find node.js executable"
146166
147−assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO ()
167+assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> TestM ()
148168assertDoesNotCompile inputFiles foreigns = do
149− putStrLn $ "Assert " ++ last inputFiles ++ " does not compile"
169+ let testFile = last inputFiles
170+ liftIO . putStrLn $ "Assert " ++ testFile ++ " does not compile"
171+ shouldFailWith <- getShouldFailWith testFile
150172 assert inputFiles foreigns $ \e ->
151173 case e of
152− Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> return Nothing
153− Right _ -> return $ Just "Should not have compiled"
174+ Left errs -> do
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))
179+ ++ ")"
180+ else checkShouldFailWith shouldFailWith errs
181+ Right _ ->
182+ return $ Just "Should not have compiled"
183+
184+ where
185+ getShouldFailWith =
186+ readFile
187+ >>> liftIO
188+ >>> fmap ( lines
189+ >>> mapMaybe (stripPrefix "-- @shouldFailWith ")
190+ >>> map trim
191+ )
192+
193+ checkShouldFailWith expected errs =
194+ let actual = map P.errorCode $ P.runMultipleErrors errs
195+ in if sort expected == sort actual
196+ then Nothing
197+ else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual
198+
199+ trim =
200+ dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
154201
155202findNodeProcess :: IO (Maybe String)
156203findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
@@ -172,14 +219,24 @@ main = do
172219 Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles
173220
174221 let passing = cwd </> "examples" </> "passing"
175− passingTestCases <- getDirectoryContents passing
176− forM_ passingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
177− assertCompiles (supportPurs ++ [passing </> inputFile]) foreigns
222+ passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passing
178223 let failing = cwd </> "examples" </> "failing"
179− failingTestCases <- getDirectoryContents failing
180− forM_ failingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
181− assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns
182− exitSuccess
224+ failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing
225+
226+ failures <- execWriterT $ do
227+ forM_ passingTestCases $ \inputFile ->
228+ assertCompiles (supportPurs ++ [passing </> inputFile]) foreigns
229+ forM_ failingTestCases $ \inputFile ->
230+ assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns
231+
232+ if null failures
233+ then exitSuccess
234+ else do
235+ putStrLn "Failures:"
236+ forM_ failures $ \(fp, err) ->
237+ let fp' = fromMaybe fp $ stripPrefix (failing ++ [pathSeparator]) fp
238+ in putStrLn $ fp' ++ ": " ++ err
239+ exitFailure
183240
184241fetchSupportCode :: IO ()
185242fetchSupportCode = do