Check the right kind of error is thrown in tests

hdgarrood · hdgarrood · commit 6ea99ca38451 · 2015-08-02T12:22:21.000+01:00
Add a basic mechanism for declaring what kind of errors a test should
throw, and add a few of these declarations to failing examples.
diff --git a/examples/failing/365.purs b/examples/failing/365.purs
@@ -1,3 +1,4 @@
+-- @shouldFailWith CycleInDeclaration
 module Main where
 
 import Prelude
diff --git a/examples/failing/Object.purs b/examples/failing/Object.purs
@@ -1,3 +1,4 @@
+-- @shouldFailWith PropertyIsMissing
 module Main where
 
 import Prelude
diff --git a/examples/failing/OverlappingInstances2.purs b/examples/failing/OverlappingInstances2.purs
@@ -1,18 +1,17 @@
+-- @shouldFailWith OverlappingInstances
 module OverlappingInstances where
 
 import Prelude
 
 data A = A | B
 
 instance eqA1 :: Eq A where
-  (==) A A = true
-  (==) B B = true
-  (==) _ _ = false
-  (/=) x y = not (x == y)
+  eq A A = true
+  eq B B = true
+  eq _ _ = false
 
 instance eqA2 :: Eq A where
-  (==) _ _ = true
-  (/=) _ _ = false
+  eq _ _ = true
 
 instance ordA :: Ord A where
   compare A B = LT
diff --git a/tests/Main.hs b/tests/Main.hs
@@ -18,13 +18,30 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE FlexibleInstances #-}
 
+-- Failing tests can specify the kind of error that should be thrown with a
+-- @shouldFailWith declaration. For example:
+--
+--   "-- @shouldFailWith TypesDoNotUnify"
+--
+-- will cause the test to fail unless that module fails to compile with exactly
+-- one TypesDoNotUnify error.
+--
+-- If a module is expected to produce multiple type errors, then use multiple
+-- @shouldFailWith lines; for example:
+--
+--   -- @shouldFailWith TypesDoNotUnify
+--   -- @shouldFailWith TypesDoNotUnify
+--   -- @shouldFailWith TransitiveExportError
+
 module Main (main) where
 
 import qualified Language.PureScript as P
 import qualified Language.PureScript.CodeGen.JS as J
 import qualified Language.PureScript.CoreFn as CF
 
-import Data.List (isSuffixOf)
+import Data.Char (isSpace)
+import Data.Maybe (mapMaybe)
+import Data.List (isSuffixOf, sort, stripPrefix)
 import Data.Traversable (traverse)
 import Data.Time.Clock (UTCTime())
 
@@ -33,6 +50,7 @@ import qualified Data.Map as M
 import Control.Monad
 import Control.Monad.IO.Class (liftIO)
 import Control.Applicative
+import Control.Arrow ((>>>))
 
 import Control.Monad.Reader
 import Control.Monad.Writer
@@ -146,11 +164,35 @@ assertCompiles inputFiles foreigns = do
 
 assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO ()
 assertDoesNotCompile inputFiles foreigns = do
-  putStrLn $ "Assert " ++ last inputFiles ++ " does not compile"
+  let testFile = last inputFiles
+  putStrLn $ "Assert " ++ testFile ++ " does not compile"
+  shouldFailWith <- getShouldFailWith testFile
   assert inputFiles foreigns $ \e ->
     case e of
-      Left errs -> putStrLn  (P.prettyPrintMultipleErrors False errs) >> return Nothing
-      Right _ -> return $ Just "Should not have compiled"
+      Left errs -> do
+        putStrLn (P.prettyPrintMultipleErrors False errs)
+        if null shouldFailWith
+          then return Nothing
+          else return $ checkShouldFailWith shouldFailWith errs
+      Right _ ->
+        return $ Just "Should not have compiled"
+
+  where
+  getShouldFailWith =
+    readFile
+    >>> fmap (   lines
+             >>> mapMaybe (stripPrefix "-- @shouldFailWith ")
+             >>> map trim
+             )
+
+  checkShouldFailWith expected errs =
+    let actual = map P.errorCode $ P.runMultipleErrors errs
+    in if sort expected == sort actual
+      then Nothing
+      else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual
+
+  trim =
+    dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
 
 findNodeProcess :: IO (Maybe String)
 findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names

Original file line number	Diff line number	Diff line change
`@@ -1,3 +1,4 @@`
	`1`	`+-- @shouldFailWith CycleInDeclaration`
`1`	`2`	`module Main where`
`2`	`3`
`3`	`4`	`import Prelude`
Original file line number	Diff line number	Diff line change
`@@ -1,3 +1,4 @@`
	`1`	`+-- @shouldFailWith PropertyIsMissing`
`1`	`2`	`module Main where`
`2`	`3`
`3`	`4`	`import Prelude`