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 (file)
--- 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 (file)
--- 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}