From: simonpj@microsoft.com <unknown>
Date: Tue, 13 Jan 2009 15:32:17 +0000 (+0000)
Subject: Fix Trac #2937: deserialising assoicated type definitions
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=48b625149fdcf14a91422d4dfdb44d096dde5bb0

Fix Trac #2937: deserialising assoicated type definitions

The deserialiser (TcIface) for associated type definitions wasn't
taking into account that the class decl brings into scope some
type variables that scope over the data/type family declaration.

Easy to fix: the new function is TcIface.bindIfaceTyVars_AT
---

diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs
index e09ff41..ab1f905 100644
--- a/compiler/iface/IfaceEnv.lhs
+++ b/compiler/iface/IfaceEnv.lhs
@@ -7,7 +7,7 @@ module IfaceEnv (
 	lookupOrig, lookupOrigNameCache, extendNameCache,
 	newIfaceName, newIfaceNames,
 	extendIfaceIdEnv, extendIfaceTyVarEnv, 
-	tcIfaceLclId,     tcIfaceTyVar, 
+	tcIfaceLclId, tcIfaceTyVar, lookupIfaceTyVar,
 	tcIfaceTick,
 
 	ifaceExportNames,
@@ -282,6 +282,11 @@ tcIfaceTyVar occ
             Nothing     -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
         }
 
+lookupIfaceTyVar :: FastString -> IfL (Maybe TyVar)
+lookupIfaceTyVar occ
+  = do	{ lcl <- getLclEnv
+	; return (lookupUFM (if_tv_env lcl) occ) }
+
 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
 extendIfaceTyVarEnv tyvars thing_inside
   = do	{ env <- getLclEnv
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index af43f97..a9091f2 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -429,36 +429,27 @@ tcIfaceDecl _ (IfaceData {ifName = occ_name,
 			  ifRec = is_rec, 
 			  ifGeneric = want_generic,
 			  ifFamInst = mb_family })
-  = do	{ tc_name <- lookupIfaceTop occ_name
-	; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
-
-	{ tycon <- fixM ( \ tycon -> do
+  = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
+    { tc_name <- lookupIfaceTop occ_name
+    ; tycon <- fixM ( \ tycon -> do
 	    { stupid_theta <- tcIfaceCtxt ctxt
-	    ; famInst <- 
-	        case mb_family of
-		  Nothing         -> return Nothing
-		  Just (fam, tys) -> 
-		    do { famTyCon <- tcIfaceTyCon fam
-		       ; insttys <- mapM tcIfaceType tys
-		       ; return $ Just (famTyCon, insttys)
-		       }
+	    ; mb_fam_inst  <- tcFamInst mb_family
 	    ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
 	    ; buildAlgTyCon tc_name tyvars stupid_theta
-			    cons is_rec want_generic gadt_syn famInst
+			    cons is_rec want_generic gadt_syn mb_fam_inst
 	    })
-        ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
-	; return (ATyCon tycon)
-    }}
+    ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
+    ; return (ATyCon tycon) }
 
 tcIfaceDecl _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, 
 		         ifSynRhs = mb_rhs_ty,
 		         ifSynKind = kind, ifFamInst = mb_family})
-   = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
+   = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
      { tc_name <- lookupIfaceTop occ_name
      ; rhs_kind <- tcIfaceType kind	-- Note [Synonym kind loop]
      ; ~(rhs, fam) <- forkM (mk_doc tc_name) $ 
        	      	      do { rhs <- tc_syn_rhs rhs_kind mb_rhs_ty
-			 ; fam <- tc_syn_fam mb_family
+			 ; fam <- tcFamInst mb_family
 			 ; return (rhs, fam) }
      ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind fam
      ; return $ ATyCon tycon
@@ -468,12 +459,6 @@ tcIfaceDecl _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
      tc_syn_rhs kind Nothing   = return (OpenSynTyCon kind Nothing)
      tc_syn_rhs _    (Just ty) = do { rhs_ty <- tcIfaceType ty
 		   		    ; return (SynonymTyCon rhs_ty) }
-     tc_syn_fam Nothing 
-       = return Nothing
-     tc_syn_fam (Just (fam, tys)) 
-       = do { famTyCon <- tcIfaceTyCon fam
-      	    ; insttys <- mapM tcIfaceType tys
-       	    ; return $ Just (famTyCon, insttys) }
 
 tcIfaceDecl ignore_prags
 	    (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, 
@@ -511,6 +496,12 @@ tcIfaceDecl _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
 	; return (ATyCon (mkForeignTyCon name ext_name 
 					 liftedTypeKind 0)) }
 
+tcFamInst :: Maybe (IfaceTyCon, [IfaceType]) -> IfL (Maybe (TyCon, [Type]))
+tcFamInst Nothing           = return Nothing
+tcFamInst (Just (fam, tys)) = do { famTyCon <- tcIfaceTyCon fam
+      	    			 ; insttys <- mapM tcIfaceType tys
+       	    			 ; return $ Just (famTyCon, insttys) }
+
 tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs
 tcIfaceDataCons tycon_name tycon _ if_cons
   = case if_cons of
@@ -1200,6 +1191,7 @@ bindIfaceBndrs (b:bs) thing_inside
     bindIfaceBndrs bs	$ \ bs' ->
     thing_inside (b':bs')
 
+
 -----------------------
 tcIfaceLetBndr :: IfaceLetBndr -> IfL Id
 tcIfaceLetBndr (IfLetBndr fs ty info)
@@ -1247,5 +1239,20 @@ mk_iface_tyvar name ifKind
 		return (Var.mkCoVar name kind)
 	  else
 		return (Var.mkTyVar name kind) }
-\end{code}
+
+bindIfaceTyVars_AT :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
+-- Used for type variable in nested associated data/type declarations
+-- where some of the type variables are already in scope
+--    class C a where { data T a b }
+-- Here 'a' is in scope when we look at the 'data T'
+bindIfaceTyVars_AT [] thing_inside
+  = thing_inside []
+bindIfaceTyVars_AT (b@(tv_occ,_) : bs) thing_inside 
+  = bindIfaceTyVars_AT bs $ \ bs' ->
+    do { mb_tv <- lookupIfaceTyVar tv_occ
+       ; case mb_tv of
+      	   Just b' -> thing_inside (b':bs')
+	   Nothing -> bindIfaceTyVar b $ \ b' -> 
+	   	      thing_inside (b':bs') }
+\end{code}