Check that AT instance is in a class

Mon Sep 18 19:16:40 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Check that AT instance is in a class
  Sat Aug 26 21:49:56 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * Check that AT instance is in a class

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

compiler/typecheck/TcTyClsDecls.lhs

@@ -51,7 +51,7 @@ import TyCon		( TyCon, AlgTyConRhs( AbstractTyCon, OpenDataTyCon,
 			  tyConDataCons, mkForeignTyCon, isProductTyCon,
 			  isRecursiveTyCon, isOpenTyCon,
 			  tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName,
-                          isNewTyCon, tyConKind )
+                          isNewTyCon, tyConKind, makeTyConAssoc, isAssocTyCon )
 import DataCon		( DataCon, dataConUserType, dataConName, 
 			  dataConFieldLabels, dataConTyCon, dataConAllTyVars,
 			  dataConFieldType, dataConResTys )
@@ -620,7 +620,7 @@ tcTyClDecl1 _calc_isrec
 	-- Check that we don't use kind signatures without Glasgow extensions
   ; checkTc gla_exts $ badSigTyDecl tc_name
 
-  ; return [ATyCon (buildSynTyCon tc_name tvs' (OpenSynTyCon kind))]
+  ; return [ATyCon $ buildSynTyCon tc_name tvs' (OpenSynTyCon kind)]
   }
 
   -- kind signature for an indexed data type
@@ -707,7 +707,7 @@ tcTyClDecl1 calc_isrec
   { ctxt' <- tcHsKindedContext ctxt
   ; fds' <- mappM (addLocM tc_fundep) fundeps
   ; atss <- mappM (addLocM (tcTyClDecl1 (const Recursive))) ats
-  ; let ats' = concat atss
+  ; let ats' = map makeTyThingAssoc . concat $ atss
   ; sig_stuff <- tcClassSigs class_name sigs meths
   ; clas <- fixM (\ clas ->
 		let 	-- This little knot is just so we can get
@@ -726,6 +726,8 @@ tcTyClDecl1 calc_isrec
     tc_fundep (tvs1, tvs2) = do { tvs1' <- mappM tcLookupTyVar tvs1 ;
 				; tvs2' <- mappM tcLookupTyVar tvs2 ;
 				; return (tvs1', tvs2') }
+    makeTyThingAssoc (ATyCon tycon) = ATyCon (makeTyConAssoc tycon)
+    makeTyThingAssoc _		    = panic "makeTyThingAssoc"
 
 
 tcTyClDecl1 calc_isrec 

compiler/types/TyCon.lhs

@@ -15,7 +15,8 @@ module TyCon(
 
 	isFunTyCon, isUnLiftedTyCon, isProductTyCon, 
 	isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
-	isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon,
+	isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon, isAssocTyCon,
+	makeTyConAssoc,
 	isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
 	isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo,
 	isHiBootTyCon, isSuperKindTyCon,
@@ -94,11 +95,14 @@ data TyCon
 	tyConName   :: Name,
 	tyConKind   :: Kind,
 	tyConArity  :: Arity,
-	
+
 	tyConTyVars :: [TyVar],		-- Scopes over (a) the algTcStupidTheta
 					--	       (b) the cached types in
 					--		   algTyConRhs.NewTyCon
 					-- But not over the data constructors
+
+        tyConIsAssoc :: Bool,           -- for families: declared in a class?
+	
 	algTcSelIds :: [Id],  		-- Its record selectors (empty if none)
 
 	algTcGadtSyntax  :: Bool,	-- True <=> the data type was declared using GADT syntax
@@ -133,13 +137,14 @@ data TyCon
     }
 
   | SynTyCon {
-	tyConUnique :: Unique,
-	tyConName   :: Name,
-	tyConKind   :: Kind,
-	tyConArity  :: Arity,
-
-	tyConTyVars :: [TyVar],		-- Bound tyvars
-	synTcRhs    :: SynTyConRhs	-- Expanded type in here
+	tyConUnique  :: Unique,
+	tyConName    :: Name,
+	tyConKind    :: Kind,
+	tyConArity   :: Arity,
+
+	tyConTyVars  :: [TyVar],	-- Bound tyvars
+        tyConIsAssoc :: Bool,           -- for families: declared in a class?
+	synTcRhs     :: SynTyConRhs	-- Expanded type in here
     }
 
   | PrimTyCon {			-- Primitive types; cannot be defined in Haskell
@@ -399,6 +404,7 @@ mkAlgTyCon name kind tyvars stupid rhs sel_ids parent is_rec gen_info gadt_syn
 	tyConKind	 = kind,
 	tyConArity	 = length tyvars,
 	tyConTyVars	 = tyvars,
+	tyConIsAssoc	 = False,
 	algTcStupidTheta = stupid,
 	algTcRhs         = rhs,
 	algTcSelIds	 = sel_ids,
@@ -468,6 +474,7 @@ mkSynTyCon name kind tyvars rhs
 	tyConKind = kind,
 	tyConArity = length tyvars,
 	tyConTyVars = tyvars,
+	tyConIsAssoc = False,
 	synTcRhs = rhs
     }
 
@@ -573,6 +580,16 @@ isOpenTyCon (AlgTyCon {algTcRhs = OpenDataTyCon }) = True
 isOpenTyCon (AlgTyCon {algTcRhs = OpenNewTyCon  }) = True
 isOpenTyCon _					   = False
 
+isAssocTyCon :: TyCon -> Bool
+isAssocTyCon (AlgTyCon { tyConIsAssoc = isAssoc }) = isAssoc
+isAssocTyCon (SynTyCon { tyConIsAssoc = isAssoc }) = isAssoc
+isAssocTyCon _                                     = False
+
+makeTyConAssoc :: TyCon -> TyCon
+makeTyConAssoc tc@(AlgTyCon {}) = tc { tyConIsAssoc = True }
+makeTyConAssoc tc@(SynTyCon {}) = tc { tyConIsAssoc = True }
+makeTyConAssoc tc = pprPanic "makeTyConAssoc" (ppr tc)
+
 isTupleTyCon :: TyCon -> Bool
 -- The unit tycon didn't used to be classed as a tuple tycon
 -- but I thought that was silly so I've undone it