X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FBuildTyCl.lhs;h=05f5f4bc22e7e69d6f6ff21ae73c552367677503;hp=bf71ca843ce8fa5158f27b326197aa2aa42341cb;hb=80c89b80c355b2aaebcd53330e6c6170c3f05aca;hpb=a4572b40a9668d949b906c000e40d65ca9dc2798

diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index bf71ca8..05f5f4b 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -23,15 +23,16 @@ import VarSet		( isEmptyVarSet, intersectVarSet, elemVarSet )
 import TysWiredIn  	( unitTy )
 import BasicTypes	( RecFlag, StrictnessMark(..) )
 import Name		( Name )
-import OccName		( mkDataConWrapperOcc, mkDataConWorkerOcc, mkClassTyConOcc,
-			  mkClassDataConOcc, mkSuperDictSelOcc, mkNewTyCoOcc )
+import OccName		( mkDataConWrapperOcc, mkDataConWorkerOcc,
+			  mkClassTyConOcc, mkClassDataConOcc,
+			  mkSuperDictSelOcc, mkNewTyCoOcc, mkLocalOcc ) 
 import MkId		( mkDataConIds, mkRecordSelId, mkDictSelId )
 import Class		( mkClass, Class( classTyCon), FunDep, DefMeth(..) )
 import TyCon		( mkSynTyCon, mkAlgTyCon, visibleDataCons,
 			  tyConStupidTheta, tyConDataCons, isNewTyCon,
 			  mkClassTyCon, TyCon( tyConTyVars ),
 			  isRecursiveTyCon, tyConArity, AlgTyConRhs(..),
-			  SynTyConRhs(..), newTyConRhs )
+			  SynTyConRhs(..), newTyConRhs, AlgTyConParent(..) )
 import Type		( mkArrowKinds, liftedTypeKind, typeKind, 
 			  tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
 			  splitTyConApp_maybe, splitAppTy_maybe,
@@ -67,11 +68,23 @@ buildAlgTyCon :: Name -> [TyVar]
 	      -> RecFlag
 	      -> Bool			-- True <=> want generics functions
 	      -> Bool			-- True <=> was declared in GADT syntax
+	      -> Maybe TyCon		-- Just family <=> instance of `family'
 	      -> TcRnIf m n TyCon
 
 buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
-  = do	{ let { tycon = mkAlgTyCon tc_name kind tvs stupid_theta
-				   rhs fields is_rec want_generics gadt_syn
+	      mb_family
+  = do	{ -- In case of a type instance, we need to invent a new name for the
+	  -- instance type, as `tc_name' is the family name.
+	; uniq <- newUnique
+	; (final_name, parent) <- 
+	    case mb_family of
+	      Nothing     -> return (tc_name, NoParentTyCon)
+	      Just family -> 
+	        do { final_name <- newImplicitBinder tc_name (mkLocalOcc uniq)
+		   ; return (final_name, FamilyTyCon family)
+		   }
+	; let { tycon = mkAlgTyCon final_name kind tvs stupid_theta rhs
+				   fields parent is_rec want_generics gadt_syn
 	      ; kind    = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
 	      ; fields  = mkTyConSelIds tycon rhs
 	  }
@@ -177,13 +190,14 @@ buildDataCon :: Name -> Bool
 	    -> ThetaType		-- Does not include the "stupid theta"
 					-- or the GADT equalities
 	    -> [Type] -> TyCon
+	    -> Maybe [Type]		-- Just ts <=> type pats of inst type
 	    -> TcRnIf m n DataCon
 -- A wrapper for DataCon.mkDataCon that
 --   a) makes the worker Id
 --   b) makes the wrapper Id if necessary, including
 --	allocating its unique (hence monadic)
 buildDataCon src_name declared_infix arg_stricts field_lbls
-	     univ_tvs ex_tvs eq_spec ctxt arg_tys tycon
+	     univ_tvs ex_tvs eq_spec ctxt arg_tys tycon mb_typats
   = do	{ wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
 	; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
 	-- This last one takes the name of the data constructor in the source
@@ -195,7 +209,8 @@ buildDataCon src_name declared_infix arg_stricts field_lbls
 		data_con = mkDataCon src_name declared_infix
 				     arg_stricts field_lbls
 				     univ_tvs ex_tvs eq_spec ctxt
-				     arg_tys tycon stupid_ctxt dc_ids
+				     arg_tys tycon mb_typats
+				     stupid_ctxt dc_ids
 		dc_ids = mkDataConIds wrap_name work_name data_con
 
 	; returnM data_con }
@@ -271,7 +286,7 @@ buildClass class_name tvs sc_theta fds ats sig_stuff tc_isrec
 				   tvs [{- no existentials -}]
                                    [{- No equalities -}] [{-No context-}] 
                                    dict_component_tys 
-				   rec_tycon
+				   rec_tycon Nothing
 
 	; rhs <- case dict_component_tys of
 			    [rep_ty] -> mkNewTyConRhs tycon_name rec_tycon dict_con