X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=b4d34983680bd4b8c80b155c8ddc3a91a5cee5f7;hb=e3dd39bf230380f02d73efc287226117bb2eb47f;hp=10bfed75a84563f9a73d428ba9474b3b170714b7;hpb=f4510d27c5883fe7e8570f4dd49d45a8b0122f2c;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 10bfed7..b4d3498 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -147,9 +147,8 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
 		-- (they recover, so that we get more than one error each
 		-- round) 
 
-		-- (1) Do class instance declarations and instances of indexed
-		--     types 
-       ; let { idxty_decls = filter (isIdxTyDecl . unLoc) tycl_decls }
+		-- (1) Do class and family instance declarations
+       ; let { idxty_decls = filter (isFamInstDecl . unLoc) tycl_decls }
        ; local_info_tycons <- mappM tcLocalInstDecl1  inst_decls
        ; idx_tycons        <- mappM tcIdxTyInstDeclTL idxty_decls
 
@@ -193,7 +192,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
     -- !!!TODO: Need to perform this check for the TyThing of type functions,
     --		too.
     tcIdxTyInstDeclTL ldecl@(L loc decl) =
-      do { tything <- tcIdxTyInstDecl ldecl
+      do { tything <- tcFamInstDecl ldecl
 	 ; setSrcSpan loc $
 	     when (isAssocFamily tything) $
 	       addErr $ assocInClassErr (tcdName decl)
@@ -221,7 +220,7 @@ addFamInsts tycons thing_inside
     mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
     mkLocalFamInstTyThing tything	 = pprPanic "TcInstDcls.addFamInsts"
 						    (ppr tything)
-\end{code} 
+\end{code}
 
 \begin{code}
 tcLocalInstDecl1 :: LInstDecl Name 
@@ -240,14 +239,10 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
 	; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
 		  badBootDeclErr
 
-	-- Typecheck the instance type itself.  We can't use 
-	-- tcHsSigType, because it's not a valid user type.
-	; kinded_ty <- kcHsSigType poly_ty
-	; poly_ty'  <- tcHsKindedType kinded_ty
-	; let (tyvars, theta, tau) = tcSplitSigmaTy poly_ty'
+	; (tyvars, theta, tau) <- tcHsInstHead poly_ty
 	
 	-- Next, process any associated types.
-	; idx_tycons <- mappM tcIdxTyInstDecl ats
+	; idx_tycons <- mappM tcFamInstDecl ats
 
 	-- Now, check the validity of the instance.
 	; (clas, inst_tys) <- checkValidInstHead tau
@@ -278,11 +273,11 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
     checkValidAndMissingATs clas inst_tys ats
       = do { -- Issue a warning for each class AT that is not defined in this
 	     -- instance.
-	   ; let classDefATs = listToNameSet . map tyConName . classATs $ clas
-                 definedATs  = listToNameSet . map (tcdName.unLoc.fst)  $ ats
-		 omitted     = classDefATs `minusNameSet` definedATs
+	   ; let class_ats   = map tyConName (classATs clas)
+                 defined_ats = listToNameSet . map (tcdName.unLoc.fst)  $ ats
+		 omitted     = filterOut (`elemNameSet` defined_ats) class_ats
 	   ; warn <- doptM Opt_WarnMissingMethods
-	   ; mapM_ (warnTc warn . omittedATWarn) (nameSetToList omitted)
+	   ; mapM_ (warnTc warn . omittedATWarn) omitted
 	   
 	     -- Ensure that all AT indexes that correspond to class parameters
 	     -- coincide with the types in the instance head.  All remaining
@@ -611,7 +606,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
     newDictBndrs sc_loc sc_theta'			`thenM` \ sc_dicts ->
     getInstLoc origin					`thenM` \ inst_loc -> 
     newDictBndrs inst_loc dfun_theta'			`thenM` \ dfun_arg_dicts ->
-    newDictBndr inst_loc (mkClassPred clas inst_tys') 	`thenM` \ this_dict ->
+    newDictBndr inst_loc (mkClassPred clas inst_tys')   `thenM` \ this_dict ->
 		-- Default-method Ids may be mentioned in synthesised RHSs,
 		-- but they'll already be in the environment.