X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=e12f2346ac6daaa0a3755e3c8bd4c832cbb97387;hb=feb584b7ffd49827ff2b6e716965cfdcd344570e;hp=2a516618fefbacb3a01a483c53fefa5c85b99f31;hpb=7ab880e6cbce4e095d8316d4289066aa2d50419b;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 2a51661..e12f234 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -28,9 +28,10 @@ import TcHsType		( kcHsSigType, tcHsKindedType )
 import TcUnify		( checkSigTyVars )
 import TcSimplify	( tcSimplifySuperClasses )
 import Type		( zipOpenTvSubst, substTheta, mkTyConApp, mkTyVarTy,
-                          splitFunTys, TyThing )
+                          splitFunTys, TyThing(ATyCon) )
 import Coercion         ( mkSymCoercion )
-import TyCon            ( TyCon, newTyConCo, tyConTyVars )
+import TyCon            ( TyCon, tyConName, newTyConCo, tyConTyVars,
+			  isAssocTyCon, tyConFamInst_maybe )
 import DataCon		( classDataCon, dataConTyCon, dataConInstArgTys )
 import Class		( classBigSig )
 import Var		( TyVar, Id, idName, idType, tyVarKind )
@@ -38,7 +39,8 @@ import Id               ( mkSysLocal )
 import UniqSupply       ( uniqsFromSupply, splitUniqSupply )
 import MkId		( mkDictFunId )
 import Name		( Name, getSrcLoc )
-import Maybe		( catMaybes )
+import Maybe		( isNothing, fromJust, catMaybes )
+import Monad		( when )
 import SrcLoc		( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart )
 import ListSetOps	( minusList )
 import Outputable
@@ -147,8 +149,8 @@ tcInstDecls1 tycl_decls inst_decls
 		-- (1) Do the ordinary instance declarations and instances of
 		--     indexed types
        ; let { idxty_decls = filter (isIdxTyDecl . unLoc) tycl_decls }
-       ; local_info_tycons <- mappM tcLocalInstDecl1 inst_decls
-       ; idxty_info_tycons <- mappM tcIdxTyInstDecl idxty_decls
+       ; local_info_tycons <- mappM tcLocalInstDecl1  inst_decls
+       ; idxty_info_tycons <- mappM tcIdxTyInstDeclTL idxty_decls
 
        ; let { (local_infos,
 	        local_tycons)    = unzip local_info_tycons
@@ -186,6 +188,27 @@ tcInstDecls1 tycl_decls inst_decls
 		  generic_inst_info ++ deriv_inst_info ++ local_idxty_info,
 		  deriv_binds) 
     }}}}}
+  where
+    -- Make sure that toplevel type instance are not for associated types.
+    -- !!!TODO: Need to perform this check for the InstInfo structures of type
+    --		functions, too.
+    tcIdxTyInstDeclTL ldecl@(L loc decl) =
+      do { (info, tything) <- tcIdxTyInstDecl ldecl
+	 ; setSrcSpan loc $
+	     when (isAssocFamily tything) $
+	       addErr $ assocInClassErr (tcdName decl)
+	 ; return (info, tything)
+	 }
+    isAssocFamily (Just (ATyCon tycon)) =
+      case tyConFamInst_maybe tycon of
+        Nothing       -> panic "isAssocFamily: no family?!?"
+	Just (fam, _) -> isAssocTyCon fam
+    isAssocFamily (Just _	      ) = panic "isAssocFamily: no tycon?!?"
+    isAssocFamily Nothing               = False
+
+assocInClassErr name = 
+  ptext SLIT("Associated type must be inside class instance") <+> 
+  quotes (ppr name)
 
 addInsts :: [InstInfo] -> TcM a -> TcM a
 addInsts infos thing_inside