@@ -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)
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
@@ -146,11 +164,35 @@ assertCompiles inputFiles foreigns = do
146164
147165assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO ()
148166assertDoesNotCompile inputFiles foreigns = do
149− putStrLn $ "Assert " ++ last inputFiles ++ " does not compile"
167+ let testFile = last inputFiles
168+ putStrLn $ "Assert " ++ testFile ++ " does not compile"
169+ shouldFailWith <- getShouldFailWith testFile
150170 assert inputFiles foreigns $ \e ->
151171 case e of
152− Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> return Nothing
153− Right _ -> return $ Just "Should not have compiled"
172+ Left errs -> do
173+ putStrLn (P.prettyPrintMultipleErrors False errs)
174+ if null shouldFailWith
175+ then return Nothing
176+ else return $ checkShouldFailWith shouldFailWith errs
177+ Right _ ->
178+ return $ Just "Should not have compiled"
179+
180+ where
181+ getShouldFailWith =
182+ readFile
183+ >>> fmap ( lines
184+ >>> mapMaybe (stripPrefix "-- @shouldFailWith ")
185+ >>> map trim
186+ )
187+
188+ checkShouldFailWith expected errs =
189+ let actual = map P.errorCode $ P.runMultipleErrors errs
190+ in if sort expected == sort actual
191+ then Nothing
192+ else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual
193+
194+ trim =
195+ dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
154196
155197findNodeProcess :: IO (Maybe String)
156198findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names