X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=eccd498b3260aba0551ed99d9d10ef2e1835398d;hp=4f6e7bdfc145cde68a679dc87da1435bdb72584d;hb=21eea25f1212ec306aac806233a2ec048212d529;hpb=bd0bd647062bad646dd8b2d0f85cce67c2079907

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 4f6e7bd..eccd498 100644
--- 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
@@ -272,8 +271,8 @@ tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon
 tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
   = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
     do { -- check that the family declaration is for a synonym
-	 unless (isSynTyCon family) $
-	   addErr (wrongKindOfFamily family)
+         checkTc (isOpenTyCon family) (notFamily family)
+       ; checkTc (isSynTyCon family) (wrongKindOfFamily family)
 
        ; -- (1) kind check the right-hand side of the type equation
        ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) resKind
@@ -303,8 +302,8 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
 			     tcdCons = cons})
   = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon ->
     do { -- check that the family declaration is for the right kind
-	 unless (isAlgTyCon fam_tycon) $
-	   addErr (wrongKindOfFamily fam_tycon)
+         checkTc (isOpenTyCon fam_tycon) (notFamily fam_tycon)
+       ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon)
 
        ; -- (1) kind check the data declaration as usual
        ; k_decl <- kcDataDecl decl k_tvs
@@ -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
@@ -1089,7 +1095,8 @@ checkValidDataCon :: TyCon -> DataCon -> TcM ()
 checkValidDataCon tc con
   = setSrcSpan (srcLocSpan (getSrcLoc con))	$
     addErrCtxt (dataConCtxt con)		$ 
-    do	{ let tc_tvs = tyConTyVars tc
+    do	{ traceTc (ptext (sLit "Validity of data con") <+> ppr con)
+        ; let tc_tvs = tyConTyVars tc
 	      res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)
 	      actual_res_ty = dataConOrigResTy con
 	; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs)
@@ -1165,7 +1172,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)
 
@@ -1507,13 +1514,18 @@ wrongNumberOfParmsErr exp_arity
     <+> ppr exp_arity
 
 badBootFamInstDeclErr :: SDoc
-badBootFamInstDeclErr = 
-  ptext (sLit "Illegal family instance in hs-boot file")
-
+badBootFamInstDeclErr
+  = ptext (sLit "Illegal family instance in hs-boot file")
+
+notFamily :: TyCon -> SDoc
+notFamily tycon
+  = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon)
+         , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))]
+  
 wrongKindOfFamily :: TyCon -> SDoc
-wrongKindOfFamily family =
-  ptext (sLit "Wrong category of family instance; declaration was for a") <+>
-  kindOfFamily
+wrongKindOfFamily family
+  = ptext (sLit "Wrong category of family instance; declaration was for a")
+    <+> kindOfFamily
   where
     kindOfFamily | isSynTyCon family = ptext (sLit "type synonym")
 		 | isAlgTyCon family = ptext (sLit "data type")