diff options
Diffstat (limited to 'compiler/rename')
| -rw-r--r-- | compiler/rename/RnNames.lhs | 29 | ||||
| -rw-r--r-- | compiler/rename/RnSource.lhs | 23 |
2 files changed, 31 insertions, 21 deletions
diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 68e6d027e6..b3a3f8347a 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -486,12 +486,8 @@ getLocalNonValBinders fixity_env hs_tyclds = tycl_decls, hs_instds = inst_decls, hs_fords = foreign_decls }) - = do { -- Separate out the family instance declarations - let (tyinst_decls, tycl_decls_noinsts) - = partition (isFamInstDecl . unLoc) (concat tycl_decls) - - -- Process all type/class decls *except* family instances - ; tc_avails <- mapM new_tc tycl_decls_noinsts + = do { -- Process all type/class decls *except* family instances + ; tc_avails <- mapM new_tc (concat tycl_decls) ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env ; setEnvs envs $ do { -- Bring these things into scope first @@ -499,7 +495,6 @@ getLocalNonValBinders fixity_env -- Process all family instances -- to bring new data constructors into scope - ; ti_avails <- mapM (new_ti Nothing) tyinst_decls ; nti_avails <- concatMapM new_assoc inst_decls -- Finish off with value binders: @@ -510,7 +505,7 @@ getLocalNonValBinders fixity_env | otherwise = for_hs_bndrs ; val_avails <- mapM new_simple val_bndrs - ; let avails = ti_avails ++ nti_avails ++ val_avails + ; let avails = nti_avails ++ val_avails new_bndrs = availsToNameSet avails `unionNameSets` availsToNameSet tc_avails ; envs <- extendGlobalRdrEnvRn avails fixity_env @@ -529,20 +524,25 @@ getLocalNonValBinders fixity_env ; return (Avail nm) } new_tc tc_decl -- NOT for type/data instances - = do { names@(main_name : _) <- mapM newTopSrcBinder (hsTyClDeclBinders tc_decl) + = do { let bndrs = hsTyClDeclBinders (unLoc tc_decl) + ; names@(main_name : _) <- mapM newTopSrcBinder bndrs ; return (AvailTC main_name names) } - new_ti :: Maybe Name -> LTyClDecl RdrName -> RnM AvailInfo + new_ti :: Maybe Name -> FamInstDecl RdrName -> RnM AvailInfo new_ti mb_cls ti_decl -- ONLY for type/data instances - = do { main_name <- lookupTcdName mb_cls (unLoc ti_decl) + = ASSERT( isFamInstDecl ti_decl ) + do { main_name <- lookupTcdName mb_cls ti_decl ; sub_names <- mapM newTopSrcBinder (hsTyClDeclBinders ti_decl) ; return (AvailTC (unLoc main_name) sub_names) } -- main_name is not bound here! new_assoc :: LInstDecl RdrName -> RnM [AvailInfo] - new_assoc (L _ (InstDecl inst_ty _ _ ats)) + new_assoc (L _ (FamInstDecl d)) + = do { avail <- new_ti Nothing d + ; return [avail] } + new_assoc (L _ (ClsInstDecl inst_ty _ _ ats)) = do { mb_cls_nm <- get_cls_parent inst_ty - ; mapM (new_ti mb_cls_nm) ats } + ; mapM (new_ti mb_cls_nm . unLoc) ats } where get_cls_parent inst_ty | Just (_, _, L loc cls_rdr, _) <- splitLHsInstDeclTy_maybe inst_ty @@ -551,7 +551,8 @@ getLocalNonValBinders fixity_env = return Nothing lookupTcdName :: Maybe Name -> TyClDecl RdrName -> RnM (Located Name) --- Used for TyData and TySynonym only +-- Used for TyData and TySynonym only, +-- both ordinary ones and family instances -- See Note [Family instance binders] lookupTcdName mb_cls tc_decl | not (isFamInstDecl tc_decl) -- The normal case diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 175b9a7ba4..54f95016c7 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -424,7 +424,11 @@ patchCCallTarget packageId callTarget \begin{code} rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars) -rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) +rnSrcInstDecl (FamInstDecl ty_decl) + = do { (ty_decl', fvs) <- rnTyClDecl Nothing ty_decl + ; return (FamInstDecl ty_decl', fvs) } + +rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats) -- Used for both source and interface file decls = do { inst_ty' <- rnLHsInstType (text "In an instance declaration") inst_ty ; let Just (inst_tyvars, _, L _ cls,_) = splitLHsInstDeclTy_maybe inst_ty' @@ -460,7 +464,7 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) renameSigs (InstDeclCtxt cls) spec_inst_prags ; let uprags' = spec_inst_prags' ++ other_sigs' - ; return (InstDecl inst_ty' mbinds' uprags' ats', + ; return (ClsInstDecl inst_ty' mbinds' uprags' ats', meth_fvs `plusFV` more_fvs `plusFV` hsSigsFVs spec_inst_prags' `plusFV` extractHsTyNames inst_ty') } @@ -764,6 +768,7 @@ rnTyClDecls extra_deps tycl_ds all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs' + ; traceRn (text "rnTycl" <+> (ppr ds_w_fvs $$ ppr sccs)) ; return (map flattenSCC sccs, all_fvs) } @@ -995,12 +1000,16 @@ depAnalTyClDecls :: [(LTyClDecl Name, FreeVars)] -> [SCC (LTyClDecl Name)] depAnalTyClDecls ds_w_fvs = stronglyConnCompFromEdgedVertices edges where - edges = [ (d, tcdName (unLoc d), map get_assoc (nameSetToList fvs)) + edges = [ (d, tcdName (unLoc d), map get_parent (nameSetToList fvs)) | (d, fvs) <- ds_w_fvs ] - get_assoc n = lookupNameEnv assoc_env n `orElse` n + + -- We also need to consider data constructor names since + -- they may appear in types because of promotion. + get_parent n = lookupNameEnv assoc_env n `orElse` n + + assoc_env :: NameEnv Name -- Maps a data constructor back + -- to its parent type constructor assoc_env = mkNameEnv assoc_env_list - -- We also need to consider data constructor names since they may - -- appear in types because of promotion. assoc_env_list = do (L _ d, _) <- ds_w_fvs case d of @@ -1210,7 +1219,7 @@ extendRecordFieldEnv tycl_decls inst_decls all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls , L _ con <- cons ] all_tycl_decls = at_tycl_decls ++ concat tycl_decls - at_tycl_decls = instDeclATs inst_decls -- Do not forget associated types! + at_tycl_decls = instDeclFamInsts inst_decls -- Do not forget associated types! get_con (ConDecl { con_name = con, con_details = RecCon flds }) (RecFields env fld_set) |