Fix Trac #3017: ensure that we quantify over enough type variables when equalities...

[ghc-hetmet.git] / compiler / typecheck / TcTyClsDecls.lhs

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 4f6e7bd..158eb64 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -25,7 +25,6 @@ import TcHsType
 import TcMType
 import TcType
 import TysWiredIn      ( unitTy )
-import FunDeps
 import Type
 import Generics
 import Class
@@ -328,6 +327,10 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
          --         foralls earlier)
        ; mapM_ checkTyFamFreeness t_typats
 
+        -- Check that we don't use GADT syntax in H98 world
+       ; gadt_ok <- doptM Opt_GADTs
+       ; checkTc (gadt_ok || consUseH98Syntax cons) (badGadtDecl tc_name)
+
         --     (b) a newtype has exactly one constructor
        ; checkTc (new_or_data == DataType || isSingleton k_cons) $
                 newtypeConError tc_name (length k_cons)
@@ -770,9 +773,7 @@ tcTyClDecl1 calc_isrec
   }
   where
     is_rec   = calc_isrec tc_name
-    h98_syntax = case cons of  -- All constructors have same shape
-                       L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
-                       _ -> True
+    h98_syntax = consUseH98Syntax cons
 
 tcTyClDecl1 calc_isrec 
   (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs, 
@@ -919,6 +920,11 @@ tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty)
                 name = tyVarName tv
                 (env', occ') = tidyOccName env (getOccName name) 
 
+consUseH98Syntax :: [LConDecl a] -> Bool
+consUseH98Syntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = False
+consUseH98Syntax _                                             = True
+                -- All constructors have same shape
+
 -------------------
 tcConArg :: Bool               -- True <=> -funbox-strict_fields
           -> LHsType Name
@@ -1165,7 +1171,7 @@ checkValidClass cls
                --   class Error e => Game b mv e | b -> mv e where
                --      newBoard :: MonadState b m => m ()
                -- Here, MonadState has a fundep m->b, so newBoard is fine
-       ; let grown_tyvars = grow theta (mkVarSet tyvars)
+       ; let grown_tyvars = growThetaTyVars theta (mkVarSet tyvars)
        ; checkTc (tyVarsOfType tau `intersectsVarSet` grown_tyvars)
                  (noClassTyVarErr cls sel_id)