Enable -Wcompat=error in the testsuite

Enabling -Werror=compat in the testsuite allows us to easily see the
impact that a new warning has on code. It also means that in the period
between adding the warning and making the actual breaking change, all
new test cases that are being added to the testsuite will be
forwards-compatible. This is good because it will make the actual
breaking change contain less irrelevant testsuite updates.

Things that -Wcompat warns about are things that are going to break in
the future, so we can be proactive and keep our testsuite
forwards-compatible.

This patch consists of two main changes:

* Add `TEST_HC_OPTS += -Werror=compat` to the testsuite configuration.
* Fix all broken test cases.

Test Plan: Validate

Reviewers: hvr, goldfire, bgamari, simonpj, RyanGlScott

Reviewed By: goldfire, RyanGlScott

Subscribers: rwbarton, carter

GHC Trac Issues: #15278

Differential Revision: https://phabricator.haskell.org/D5200

10 files changed, 46 insertions, 30 deletions

diff --git a/testsuite/tests/simplCore/should_compile/T11562.hs b/testsuite/tests/simplCore/should_compile/T11562.hs
index 873e1afc0f..e273f6002e 100644
--- a/testsuite/tests/simplCore/should_compile/T11562.hs
+++ b/testsuite/tests/simplCore/should_compile/T11562.hs
@@ -9,13 +9,14 @@
 -- with a compiler built with -DDEBUG
 
 module T11562 where
-import qualified GHC.Types as C (Constraint)
 
-class Category (cat :: k -> k -> *) where
+import Data.Kind
+
+class Category (cat :: k -> k -> Type) where
   id :: cat a a
   (.) :: cat b c -> cat a b -> cat a c
 
-data Dict :: C.Constraint -> * where
+data Dict :: Constraint -> Type where
   Dict :: a => Dict a
 
 newtype C2D a b = Sub (a => Dict b)
diff --git a/testsuite/tests/simplCore/should_compile/T11644.hs b/testsuite/tests/simplCore/should_compile/T11644.hs
index e0d020dcf9..d3ab5b58eb 100644
--- a/testsuite/tests/simplCore/should_compile/T11644.hs
+++ b/testsuite/tests/simplCore/should_compile/T11644.hs
@@ -2,8 +2,10 @@
 
 module T11644 where
 
+import Data.Kind (Type)
+
 class Foo m where
-    type Bar m :: *
+    type Bar m :: Type
     action :: m -> Bar m -> m
 
 right x m = action m (Right x)
diff --git a/testsuite/tests/simplCore/should_compile/T13410.hs b/testsuite/tests/simplCore/should_compile/T13410.hs
index 9db017d777..91444f47fa 100644
--- a/testsuite/tests/simplCore/should_compile/T13410.hs
+++ b/testsuite/tests/simplCore/should_compile/T13410.hs
@@ -13,6 +13,7 @@ import Control.Monad (liftM2)
 import Data.Functor.Identity (Identity(..))
 import GHC.ST (ST, runST)
 import Text.Read (ReadPrec, readPrec)
+import Data.Kind (Type)
 
 -----
 
@@ -28,7 +29,7 @@ class GMVector v a where
   gmbasicUnsafeNew   :: PrimMonad m => Int -> m (v (PrimState m) a)
   gmbasicUnsafeWrite :: PrimMonad m => v (PrimState m) a -> Int -> a -> m ()
 
-type family GMutable (v :: * -> *) :: * -> * -> *
+type family GMutable (v :: Type -> Type) :: Type -> Type -> Type
 
 class GMVector (GMutable v) a => GVector v a where
   gbasicUnsafeFreeze :: PrimMonad m => GMutable v (PrimState m) a -> m (v a)
@@ -126,7 +127,9 @@ greadPrec = do
 
 -----
 
-data MVector :: (* -> * -> *) -> (* -> * -> *) -> * -> * -> * where
+data MVector :: (Type -> Type -> Type) ->
+                (Type -> Type -> Type) ->
+                (Type -> Type -> Type) where
   MV :: !(u s a) -> !(v s b) -> MVector u v s (a, b)
 
 instance (GMVector u a, GMVector v b) => GMVector (MVector u v) (a, b) where
@@ -141,7 +144,7 @@ instance (GMVector u a, GMVector v b) => GMVector (MVector u v) (a, b) where
     gmbasicUnsafeWrite ks n k
     gmbasicUnsafeWrite vs n v
 
-data Vector :: (* -> *) -> (* -> *) -> * -> *
+data Vector :: (Type -> Type) -> (Type -> Type) -> Type -> Type
 
 type instance GMutable (Vector u v) = MVector (GMutable u) (GMutable v)
 
diff --git a/testsuite/tests/simplCore/should_compile/T14270a.hs b/testsuite/tests/simplCore/should_compile/T14270a.hs
index 5054b43a2c..d8cc497f62 100644
--- a/testsuite/tests/simplCore/should_compile/T14270a.hs
+++ b/testsuite/tests/simplCore/should_compile/T14270a.hs
@@ -17,7 +17,7 @@ f :: T (a :: Type) -> Bool
 f (T1 x) = f x
 f T2     = True
 
-g :: forall (a :: k). K a -> T a -> Bool
+g :: forall k (a :: k). K a -> T a -> Bool
 g kv x = case kv of
             K1 -> f @a T2   -- f @a (T1 x) gives a different crash
             k2 -> True
diff --git a/testsuite/tests/simplCore/should_compile/T15186.hs b/testsuite/tests/simplCore/should_compile/T15186.hs
index c04de6adfa..0ebd3a038c 100644
--- a/testsuite/tests/simplCore/should_compile/T15186.hs
+++ b/testsuite/tests/simplCore/should_compile/T15186.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE PatternSynonyms #-}
 module Bar (pattern PointerExpr) where
 
+import Data.Kind (Type)
 import T15186A
 
 -------------------------------------------------------------------------------
@@ -21,7 +22,7 @@ data TypeRepr (tp :: CrucibleType) where
   BVRepr :: TypeRepr tp
   TypeReprDummy :: TypeRepr tp
 
-data App (f :: CrucibleType -> *) (tp :: CrucibleType) where
+data App (f :: CrucibleType -> Type) (tp :: CrucibleType) where
   RollRecursive :: !(Assignment TypeRepr ctx)
                 -> !(Expr tp)
                 -> App f ('RecursiveType ctx)
diff --git a/testsuite/tests/simplCore/should_compile/T15517a.hs b/testsuite/tests/simplCore/should_compile/T15517a.hs
index 28ca664969..2c8f6c4b32 100644
--- a/testsuite/tests/simplCore/should_compile/T15517a.hs
+++ b/testsuite/tests/simplCore/should_compile/T15517a.hs
@@ -9,16 +9,17 @@
 {-# LANGUAGE TypeOperators           #-}
 module T15517a () where
 
+import Data.Kind (Type)
 import Data.Proxy
 
-newtype Rep (ki :: kon -> *) (phi :: Nat -> *) (code :: [[Atom kon]])
+newtype Rep (ki :: kon -> Type) (phi :: Nat -> Type) (code :: [[Atom kon]])
   = Rep (NS (PoA ki phi) code)
 
-data NA  :: (kon -> *) -> (Nat -> *) -> Atom kon -> * where
+data NA  :: (kon -> Type) -> (Nat -> Type) -> Atom kon -> Type where
   NA_I :: (IsNat k) => phi k -> NA ki phi (I k)
   NA_K ::              ki  k -> NA ki phi (K k)
 
-data NP :: (k -> *) -> [k] -> * where
+data NP :: (k -> Type) -> [k] -> Type where
   NP0  :: NP p '[]
   (:*) :: p x -> NP p xs -> NP p (x : xs)
 
@@ -32,33 +33,33 @@ instance IsNat n => IsNat (S n) where
 proxyUnsuc :: Proxy (S n) -> Proxy n
 proxyUnsuc _ = Proxy
 
-type PoA (ki :: kon -> *) (phi :: Nat -> *) = NP (NA ki phi)
+type PoA (ki :: kon -> Type) (phi :: Nat -> Type) = NP (NA ki phi)
 
 data Atom kon
   = K kon
   | I Nat
 
 data Nat = S Nat | Z
-data SNat :: Nat -> * where
+data SNat :: Nat -> Type where
   SZ ::           SNat Z
   SS :: SNat n -> SNat (S n)
 
 data Kon = KInt
-data Singl (kon :: Kon) :: * where
+data Singl (kon :: Kon) :: Type where
   SInt :: Int -> Singl KInt
 
 type family Lkup (n :: Nat) (ks :: [k]) :: k where
   Lkup Z     (k : ks) = k
   Lkup (S n) (k : ks) = Lkup n ks
 
-data El :: [*] -> Nat -> * where
+data El :: [Type] -> Nat -> Type where
   El :: IsNat ix => Lkup ix fam -> El fam ix
 
-data NS :: (k -> *) -> [k] -> * where
+data NS :: (k -> Type) -> [k] -> Type where
   There :: NS p xs -> NS p (x : xs)
   Here  :: p x     -> NS p (x : xs)
 
-class Family (ki :: kon -> *) (fam :: [*]) (codes :: [[[Atom kon]]])
+class Family (ki :: kon -> Type) (fam :: [Type]) (codes :: [[[Atom kon]]])
       | fam -> ki codes , ki codes -> fam where
     sfrom' :: SNat ix -> El fam ix -> Rep ki (El fam) (Lkup ix codes)
 
diff --git a/testsuite/tests/simplCore/should_compile/T5303.hs b/testsuite/tests/simplCore/should_compile/T5303.hs
index 18a4f982c0..e17bff9a49 100644
--- a/testsuite/tests/simplCore/should_compile/T5303.hs
+++ b/testsuite/tests/simplCore/should_compile/T5303.hs
@@ -3,22 +3,23 @@ module T5303( showContextSeries ) where
 
 import Control.Monad.State.Strict( StateT )  
 import Control.Monad.Trans ( lift )
+import Data.Kind (Type)
 
-data Tree (m :: * -> *) = Tree {}
+data Tree (m :: Type -> Type) = Tree {}
 
-data FL (a :: * -> * -> *) x z where
+data FL (a :: Type -> Type -> Type) x z where
     (:>:) :: a x y -> FL a y z -> FL a x z
     NilFL :: FL a x x
 
-class (Functor m, Monad m) => ApplyMonad m (state :: (* -> *) -> *)
+class (Functor m, Monad m) => ApplyMonad m (state :: (Type -> Type) -> Type)
 
-class Apply (p :: * -> * -> *) where
-    type ApplyState p :: (* -> *) -> *
+class Apply (p :: Type -> Type -> Type) where
+    type ApplyState p :: (Type -> Type) -> Type
     apply :: ApplyMonad m (ApplyState p) => p x y -> m ()
 
 class (Functor m, Monad m, ApplyMonad (ApplyMonadOver m state) state)
-      => ApplyMonadTrans m (state :: (* -> *) -> *) where
-  type ApplyMonadOver m state :: * -> *
+      => ApplyMonadTrans m (state :: (Type -> Type) -> Type) where
+  type ApplyMonadOver m state :: Type -> Type
   runApplyMonad :: (ApplyMonadOver m state) x -> state m -> m (x, state m)
 
 instance (Functor m, Monad m) => ApplyMonadTrans m Tree where
diff --git a/testsuite/tests/simplCore/should_compile/T7785.hs b/testsuite/tests/simplCore/should_compile/T7785.hs
index ecde1ff020..21fba28589 100644
--- a/testsuite/tests/simplCore/should_compile/T7785.hs
+++ b/testsuite/tests/simplCore/should_compile/T7785.hs
@@ -3,7 +3,7 @@
 module Foo( shared, foo, bar) where
 -- module Foo where
 
-import GHC.Exts
+import Data.Kind
 
 {-
 foo :: [Int] -> [Int]
@@ -16,7 +16,7 @@ foo = let f = map negate
 
 -}
 
-type family Domain (f :: * -> *) a :: Constraint
+type family Domain (f :: Type -> Type) a :: Constraint
 
 type instance Domain [] a = ()
 
diff --git a/testsuite/tests/simplCore/should_compile/simpl011.hs b/testsuite/tests/simplCore/should_compile/simpl011.hs
index b31ea0a6b3..81022f9e8c 100644
--- a/testsuite/tests/simplCore/should_compile/simpl011.hs
+++ b/testsuite/tests/simplCore/should_compile/simpl011.hs
@@ -6,6 +6,7 @@
 
 module MHashTable (STHashTable, new, update) where
 
+import Data.Kind            (Type)
 import Data.Int             (Int32)
 import Control.Monad.ST     (ST)
 import Data.STRef           (STRef)
@@ -35,7 +36,8 @@ type STHashTable s key val = HashTable key val (STArray s) (STRef s) (ST s)
 
 newtype HashTable key val arr ref m = HashTable (ref (HT key val arr ref m))
 
-data HT key val arr (ref :: * -> *) (m :: * -> *) = HT { dir :: (arr Int32 (arr Int32 [(key,val)])) }
+data HT key val arr (ref :: Type -> Type) (m :: Type -> Type) =
+  HT { dir :: (arr Int32 (arr Int32 [(key,val)])) }
 
 new :: forall arr ref m key val. (MutHash arr ref m) => m (HashTable key val arr ref m)
 new = do
diff --git a/testsuite/tests/simplCore/should_run/T3591.hs b/testsuite/tests/simplCore/should_run/T3591.hs
index 27bb52432e..6b2b23b2ba 100644
--- a/testsuite/tests/simplCore/should_run/T3591.hs
+++ b/testsuite/tests/simplCore/should_run/T3591.hs
@@ -43,7 +43,9 @@
 
 module Main where
 
+import Data.Kind (Type)
 import Control.Monad (liftM, liftM2, when, ap)
+import Control.Monad.Fail (MonadFail(fail))
 -- import Control.Monad.Identity
 
 import Debug.Trace (trace)
@@ -96,6 +98,9 @@ instance (Monad m, Functor s) => Monad (Trampoline m s) where
       where apply f (Done x) = bounce (f x)
             apply f (Suspend s) = return (Suspend (fmap (>>= f) s))
 
+instance (Monad m, Functor s) => MonadFail (Trampoline m s) where
+  fail = error
+
 data Yield x y = Yield! x y
 instance Functor (Yield x) where
    fmap f (Yield x y) = trace "fmap yield" $ Yield x (f y)
@@ -176,10 +181,10 @@ liftOut (Trampoline ma) = trace "liftOut" $ Trampoline (liftM inject ma)
          inject (Suspend a) = trace "inject suspend" $ Suspend (liftFunctor $ trace "calling fmap" $ 
                               fmap liftOut (trace "poking a" a))
 
-data Sink (m :: * -> *) a x =
+data Sink (m :: Type -> Type) a x =
    Sink   {put :: forall d. (AncestorFunctor (EitherFunctor a (TryYield x)) d) => x -> Trampoline m d Bool,
            canPut :: forall d. (AncestorFunctor (EitherFunctor a (TryYield x)) d) => Trampoline m d Bool}
-newtype Source (m :: * -> *) a x =
+newtype Source (m :: Type -> Type) a x =
    Source {get :: forall d. (AncestorFunctor (EitherFunctor a (Await (Maybe x))) d) => Trampoline m d (Maybe x)}
 
 pipe :: forall m a x r1 r2. (Monad m, Functor a) =>