diff options
Diffstat (limited to 'compiler/rename')
| -rw-r--r-- | compiler/rename/RnBinds.lhs | 2 | ||||
| -rw-r--r-- | compiler/rename/RnEnv.lhs | 27 | ||||
| -rw-r--r-- | compiler/rename/RnNames.lhs | 208 | ||||
| -rw-r--r-- | compiler/rename/RnSource.lhs | 205 |
4 files changed, 223 insertions, 219 deletions
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index a833c83b01..36fcfdbe09 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -624,7 +624,7 @@ rnMethodBind cls sig_fn (L loc bind@(FunBind { fun_id = name, fun_infix = is_infix , fun_matches = MatchGroup matches _ })) = setSrcSpan loc $ do - sel_name <- wrapLocM (lookupInstDeclBndr cls) name + sel_name <- wrapLocM (lookupInstDeclBndr cls (ptext (sLit "method"))) name let plain_name = unLoc sel_name -- We use the selector name as the binder diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 09890181a5..7d4c2b6527 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -236,7 +236,7 @@ lookupExactOcc name _ -> pprPanic "lookupExactOcc" (ppr name $$ ppr gres) } ----------------------------------------------- -lookupInstDeclBndr :: Name -> RdrName -> RnM Name +lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name -- This is called on the method name on the left-hand side of an -- instance declaration binding. eg. instance Functor T where -- fmap = ... @@ -248,7 +248,10 @@ lookupInstDeclBndr :: Name -> RdrName -> RnM Name -- name is only in scope qualified. I.e. even if method op is -- in scope as M.op, we still allow plain 'op' on the LHS of -- an instance decl -lookupInstDeclBndr cls rdr +-- +-- The "what" parameter says "method" or "associated type", +-- depending on what we are looking up +lookupInstDeclBndr cls what rdr = do { when (isQual rdr) (addErr (badQualBndrErr rdr)) -- In an instance decl you aren't allowed @@ -256,7 +259,7 @@ lookupInstDeclBndr cls rdr -- (Although it'd make perfect sense.) ; lookupSubBndr (ParentIs cls) doc rdr } where - doc = ptext (sLit "method of class") <+> quotes (ppr cls) + doc = what <+> ptext (sLit "of class") <+> quotes (ppr cls) ----------------------------------------------- lookupConstructorFields :: Name -> RnM [Name] @@ -443,7 +446,8 @@ lookupOccRn rdr_name -- and only happens for failed lookups ; if isQual rdr_name && allow_qual && is_ghci then lookupQualifiedName rdr_name - else unboundName WL_Any rdr_name } } } } } + else do { traceRn (text "lookupOccRn" <+> ppr rdr_name) + ; unboundName WL_Any rdr_name } } } } } } lookupGlobalOccRn :: RdrName -> RnM Name @@ -453,7 +457,8 @@ lookupGlobalOccRn rdr_name = do { mb_name <- lookupGlobalOccRn_maybe rdr_name ; case mb_name of Just n -> return n - Nothing -> unboundName WL_Global rdr_name } + Nothing -> do { traceRn (text "lookupGlobalOccRn" <+> ppr rdr_name) + ; unboundName WL_Global rdr_name } } lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name) -- No filter function; does not report an error on failure @@ -489,7 +494,8 @@ lookupGreRn rdr_name ; case mb_gre of { Just gre -> return gre ; Nothing -> do - { name <- unboundName WL_Global rdr_name + { traceRn (text "lookupGreRn" <+> ppr rdr_name) + ; name <- unboundName WL_Global rdr_name ; return (GRE { gre_name = name, gre_par = NoParent, gre_prov = LocalDef }) }}} @@ -549,7 +555,8 @@ lookupQualifiedName rdr_name name <- availNames avail, nameOccName name == occ ] of (n:ns) -> ASSERT (null ns) return n - _ -> unboundName WL_Any rdr_name + _ -> do { traceRn (text "lookupQualified" <+> ppr rdr_name) + ; unboundName WL_Any rdr_name } | otherwise = pprPanic "RnEnv.lookupQualifiedName" (ppr rdr_name) @@ -644,14 +651,14 @@ lookupBindGroupOcc mb_bound_names what rdr_name --------------- lookupLocalDataTcNames :: NameSet -> SDoc -> RdrName -> RnM [Name] -- GHC extension: look up both the tycon and data con --- for con-like things +-- for con-like things. Used for top-level fixity signatures -- Complain if neither is in scope -lookupLocalDataTcNames bound_names what rdr_name +lookupLocalDataTcNames bndr_set what rdr_name | Just n <- isExact_maybe rdr_name -- Special case for (:), which doesn't get into the GlobalRdrEnv = do { n' <- lookupExactOcc n; return [n'] } -- For this we don't need to try the tycon too | otherwise - = do { mb_gres <- mapM (lookupBindGroupOcc (Just bound_names) what) + = do { mb_gres <- mapM (lookupBindGroupOcc (Just bndr_set) what) (dataTcOccs rdr_name) ; let (errs, names) = splitEithers mb_gres ; when (null names) (addErr (head errs)) -- Bleat about one only diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 5b603cf6f9..dc8b46c0a9 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -7,7 +7,7 @@ module RnNames ( rnImports, getLocalNonValBinders, rnExports, extendGlobalRdrEnvRn, - gresFromAvails, + gresFromAvails, lookupTcdName, reportUnusedNames, finishWarnings, ) where @@ -469,53 +469,9 @@ used for source code. *** See "THE NAMING STORY" in HsDecls **** -Instances of type families -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Family instances contain data constructors that we need to collect and we also -need to descend into the type instances of associated families in class -instances. The type constructor of a family instance is a usage occurence. -Hence, we don't return it as a subname in 'AvailInfo'; otherwise, we would get -a duplicate declaration error. - -Note [Looking up family names in family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - module M where - type family T a :: * - type instance M.T Int = Bool - -We might think that we can simply use 'lookupOccRn' when processing the type -instance to look up 'M.T'. Alas, we can't! The type family declaration is in -the *same* HsGroup as the type instance declaration. Hence, as we are -currently collecting the binders declared in that HsGroup, these binders will -not have been added to the global environment yet. - -In the case of type classes, this problem does not arise, as a class instance -does not define any binders of its own. So, we simply don't attempt to look -up the class names of class instances in 'get_local_binders' below. - -If we don't look up class instances, can't we get away without looking up type -instances, too? No, we can't. Data type instances define data constructors -and we need to - - (1) collect those in 'get_local_binders' and - (2) we need to get their parent name in 'get_local_binders', too, to - produce an appropriate 'AvailTC'. - -This parent name is exactly the family name of the type instance that is so -difficult to look up. - -We solve this problem as follows: - - (a) We process all type declarations *other* than type instances first. - (b) Then, we compute an 'OccEnv' from the result of the first step. - (c) Finally, we process all type instances (both those on the toplevel and - those nested in class instances) and check for the family names in the - 'GlobalRdrEnv' produced in the previous step before using 'lookupOccRn'. - \begin{code} -getLocalNonValBinders :: HsGroup RdrName -> RnM [AvailInfo] +getLocalNonValBinders :: MiniFixityEnv -> HsGroup RdrName + -> RnM ((TcGblEnv, TcLclEnv), NameSet) -- Get all the top-level binders bound the group *except* -- for value bindings, which are treated separately -- Specificaly we return AvailInfo for @@ -525,52 +481,48 @@ getLocalNonValBinders :: HsGroup RdrName -> RnM [AvailInfo] -- foreign imports -- (in hs-boot files) value signatures -getLocalNonValBinders group - = do { gbl_env <- getGblEnv - ; get_local_binders gbl_env group } - -get_local_binders :: TcGblEnv -> HsGroup RdrName -> RnM [AvailInfo] -get_local_binders gbl_env (HsGroup {hs_valds = ValBindsIn _ val_sigs, - hs_tyclds = tycl_decls, - hs_instds = inst_decls, - hs_fords = foreign_decls }) - = do { -- separate out the family instance declarations - let (tyinst_decls1, tycl_decls_noinsts) - = partition (isFamInstDecl . unLoc) (concat tycl_decls) - tyinst_decls = tyinst_decls1 ++ instDeclATs inst_decls - - -- process all type/class decls except family instances - ; tc_avails <- mapM new_tc tycl_decls_noinsts - - -- Create a temporary env of the type binders - -- See Note [Looking up family names in family instances] - -- NB: associated types may be a sub-bndr of a class - -- AvailTC C [C,T,op] - -- Hence availNames, not availName - ; let local_tc_env :: OccEnv Name - local_tc_env = mkOccEnv [ (occ, n) - | a <- tc_avails - , n <- availNames a - , let occ = nameOccName n - , isTcOcc occ ] +getLocalNonValBinders fixity_env + (HsGroup { hs_valds = val_binds, + 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 + ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env + ; setEnvs envs $ do { + -- Bring these things into scope first + -- See Note [Looking up family names in family instances] -- Process all family instances - ; ti_avails <- mapM (new_ti local_tc_env) tyinst_decls - - -- finish off with value binder in case of a hs-boot file + -- 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: + -- foreign decls for an ordinary module + -- type sigs in case of a hs-boot file only + ; is_boot <- tcIsHsBoot + ; let val_bndrs | is_boot = hs_boot_sig_bndrs + | otherwise = for_hs_bndrs ; val_avails <- mapM new_simple val_bndrs - ; return (val_avails ++ tc_avails ++ ti_avails) } - where - is_hs_boot = isHsBoot (tcg_src gbl_env) ; + ; let avails = ti_avails ++ nti_avails ++ val_avails + new_bndrs = availsToNameSet avails `unionNameSets` + availsToNameSet tc_avails + ; envs <- extendGlobalRdrEnvRn avails fixity_env + ; return (envs, new_bndrs) } } + where for_hs_bndrs :: [Located RdrName] for_hs_bndrs = [nm | L _ (ForeignImport nm _ _) <- foreign_decls] -- In a hs-boot file, the value binders come from the -- *signatures*, and there should be no foreign binders - val_bndrs :: [Located RdrName] - val_bndrs | is_hs_boot = [n | L _ (TypeSig ns _) <- val_sigs, n <- ns] - | otherwise = for_hs_bndrs + hs_boot_sig_bndrs = [n | L _ (TypeSig ns _) <- val_sigs, n <- ns] + ValBindsIn _ val_sigs = val_binds new_simple :: Located RdrName -> RnM AvailInfo new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name @@ -580,21 +532,89 @@ get_local_binders gbl_env (HsGroup {hs_valds = ValBindsIn _ val_sigs, = do { names@(main_name : _) <- mapM newTopSrcBinder (hsTyClDeclBinders tc_decl) ; return (AvailTC main_name names) } - new_ti local_tc_env ti_decl -- ONLY for type/data instances - = do { let L loc tc_rdr = tcdLName (unLoc ti_decl) - ; main_name <- setSrcSpan loc $ - case lookupOccEnv local_tc_env (rdrNameOcc tc_rdr) of - Nothing -> lookupGlobalOccRn tc_rdr - Just n -> return n - -- See Note [Looking up family names in family instances] - + new_ti :: Maybe Name -> LTyClDecl RdrName -> RnM AvailInfo + new_ti mb_cls ti_decl -- ONLY for type/data instances + = do { main_name <- lookupTcdName mb_cls (unLoc ti_decl) ; sub_names <- mapM newTopSrcBinder (hsTyClDeclBinders ti_decl) - ; return (AvailTC main_name sub_names) } + ; return (AvailTC (unLoc main_name) sub_names) } -- main_name is not bound here! -get_local_binders _ g = pprPanic "get_local_binders" (ppr g) + new_assoc :: LInstDecl RdrName -> RnM [AvailInfo] + new_assoc (L _ (InstDecl inst_ty _ _ ats)) + = do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr + ; mapM (new_ti (Just cls_nm)) ats } + where + (_, _, L loc cls_rdr, _) = splitHsInstDeclTy inst_ty + +lookupTcdName :: Maybe Name -> TyClDecl RdrName -> RnM (Located Name) +-- Used for TyData and TySynonym only +-- See Note [Family instance binders] +lookupTcdName mb_cls tc_decl + | not (isFamInstDecl tc_decl) -- The normal case + = ASSERT2( isNothing mb_cls, ppr tc_rdr ) -- Parser prevents this + lookupLocatedTopBndrRn tc_rdr + + | Just cls <- mb_cls -- Associated type; c.f RnBinds.rnMethodBind + = wrapLocM (lookupInstDeclBndr cls (ptext (sLit "associated type"))) tc_rdr + + | otherwise -- Family instance; tc_rdr is an *occurrence* + = lookupLocatedOccRn tc_rdr + where + tc_rdr = tcdLName tc_decl \end{code} +Note [Looking up family names in family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + module M where + type family T a :: * + type instance M.T Int = Bool + +We might think that we can simply use 'lookupOccRn' when processing the type +instance to look up 'M.T'. Alas, we can't! The type family declaration is in +the *same* HsGroup as the type instance declaration. Hence, as we are +currently collecting the binders declared in that HsGroup, these binders will +not have been added to the global environment yet. + +Solution is simple: process the type family declarations first, extend +the environment, and then process the type instances. + + +Note [Family instance binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family F a + data instance F T = X1 | X2 + +The 'data instance' decl has an *occurrence* of F (and T), and *binds* +X1 and X2. (This is unlike a normal data type declaration which would +bind F too.) So we want an AvailTC F [X1,X2]. + +Now consider a similar pair: + class C a where + data G a + instance C S where + data G S = Y1 | Y2 + +The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G. + +But there is a small complication: in an instance decl, we don't use +qualified names on the LHS; instead we use the class to disambiguate. +Thus: + module M where + import Blib( G ) + class C a where + data G a + instance C S where + data G S = Y1 | Y2 +Even though there are two G's in scope (M.G and Blib.G), the occurence +of 'G' in the 'instance C S' decl is unambiguous, becuase C has only +one associated type called G. This is exactly what happens for methods, +and it is only consistent to do the same thing for types. That's the +role of the function lookupTcdName; the (Maybe Name) give the class of +the encloseing instance decl, if any. + %************************************************************************ %* * diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 64feaed8e4..b21b24e5f6 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -20,17 +20,11 @@ import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc ) import RdrHsSyn ( extractHsRhoRdrTyVars ) import RnHsSyn import RnTypes -import RnBinds ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn, - makeMiniFixityEnv) -import RnEnv ( lookupLocalDataTcNames, lookupLocatedOccRn, - lookupTopBndrRn, lookupLocatedTopBndrRn, - lookupOccRn, bindLocalNamesFV, - bindLocatedLocalsFV, bindPatSigTyVarsFV, - bindTyVarsRn, bindTyVarsFV, extendTyVarEnvFVRn, - bindLocalNames, checkDupRdrNames, mapFvRn - ) -import RnNames ( getLocalNonValBinders, extendGlobalRdrEnvRn ) -import HscTypes ( AvailInfo(..), availsToNameSet ) +import RnBinds ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, + renameSigs, mkSigTvFn, makeMiniFixityEnv ) +import RnEnv +import RnNames ( getLocalNonValBinders, extendGlobalRdrEnvRn, lookupTcdName ) +import HscTypes ( AvailInfo(..) ) import RnHsDoc ( rnHsDoc, rnMbLHsDoc ) import TcRnMonad @@ -57,15 +51,6 @@ import Maybes( orElse ) import Data.Maybe \end{code} -\begin{code} --- XXX -thenM :: Monad a => a b -> (b -> a c) -> a c -thenM = (>>=) - -thenM_ :: Monad a => a b -> a c -> a c -thenM_ = (>>) -\end{code} - @rnSourceDecl@ `renames' declarations. It simultaneously performs dependency analysis and precedence parsing. It also does the following error checks: @@ -103,14 +88,13 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, -- (A) Process the fixity declarations, creating a mapping from -- FastStrings to FixItems. -- Also checks for duplcates. - local_fix_env <- makeMiniFixityEnv fix_decls; + local_fix_env <- makeMiniFixityEnv fix_decls ; -- (B) Bring top level binders (and their fixities) into scope, -- *except* for the value bindings, which get brought in below. -- However *do* include class ops, data constructors -- And for hs-boot files *do* include the value signatures - tc_avails <- getLocalNonValBinders group ; - tc_envs <- extendGlobalRdrEnvRn tc_avails local_fix_env ; + (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ; setEnvs tc_envs $ do { failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations @@ -127,11 +111,9 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, -- It uses the fixity env from (A) to bind fixities for view patterns. new_lhs <- rnTopBindsLHS local_fix_env val_decls ; -- bind the LHSes (and their fixities) in the global rdr environment - let { val_binders = collectHsValBinders new_lhs ; - val_bndr_set = mkNameSet val_binders ; - all_bndr_set = val_bndr_set `unionNameSets` availsToNameSet tc_avails ; - val_avails = map Avail val_binders - } ; + let { val_binders = collectHsValBinders new_lhs ; + all_bndr_set = addListToNameSet tc_bndrs val_binders ; + val_avails = map Avail val_binders } ; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ; traceRn (ptext (sLit "Val binders") <+> (ppr val_binders)) ; setEnvs (tcg_env, tcl_env) $ do { @@ -270,7 +252,7 @@ rnSrcFixityDecls :: NameSet -> [LFixitySig RdrName] -> RnM [LFixitySig Name] -- -- The returned FixitySigs are not actually used for anything, -- except perhaps the GHCi API -rnSrcFixityDecls bound_names fix_decls +rnSrcFixityDecls bndr_set fix_decls = do fix_decls <- mapM rn_decl fix_decls return (concat fix_decls) where @@ -282,7 +264,7 @@ rnSrcFixityDecls bound_names fix_decls rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity)) = setSrcSpan name_loc $ -- this lookup will fail if the definition isn't local - do names <- lookupLocalDataTcNames bound_names what rdr_name + do names <- lookupLocalDataTcNames bndr_set what rdr_name return [ L loc (FixitySig (L name_loc name) fixity) | name <- names ] what = ptext (sLit "fixity signature") @@ -304,10 +286,10 @@ gather them together. \begin{code} -- checks that the deprecations are defined locally, and that there are no duplicates rnSrcWarnDecls :: NameSet -> [LWarnDecl RdrName] -> RnM Warnings -rnSrcWarnDecls _bound_names [] +rnSrcWarnDecls _ [] = return NoWarnings -rnSrcWarnDecls bound_names decls +rnSrcWarnDecls bndr_set decls = do { -- check for duplicates ; mapM_ (\ dups -> let (L loc rdr:lrdr':_) = dups in addErrAt loc (dupWarnDecl lrdr' rdr)) @@ -317,8 +299,8 @@ rnSrcWarnDecls bound_names decls where rn_deprec (Warning rdr_name txt) -- ensures that the names are defined locally - = lookupLocalDataTcNames bound_names what rdr_name `thenM` \ names -> - return [(nameOccName name, txt) | name <- names] + = do { names <- lookupLocalDataTcNames bndr_set what rdr_name + ; return [(nameOccName name, txt) | name <- names] } what = ptext (sLit "deprecation") @@ -364,8 +346,8 @@ rnAnnProvenance provenance = do \begin{code} rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars) rnDefaultDecl (DefaultDecl tys) - = mapFvRn (rnHsTypeFVs doc_str) tys `thenM` \ (tys', fvs) -> - return (DefaultDecl tys', fvs) + = do { (tys', fvs) <- mapFvRn (rnHsTypeFVs doc_str) tys + ; return (DefaultDecl tys', fvs) } where doc_str = text "In a `default' declaration" \end{code} @@ -379,20 +361,20 @@ rnDefaultDecl (DefaultDecl tys) \begin{code} rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars) rnHsForeignDecl (ForeignImport name ty spec) - = getTopEnv `thenM` \ (topEnv :: HscEnv) -> - lookupLocatedTopBndrRn name `thenM` \ name' -> - rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) -> + = do { topEnv :: HscEnv <- getTopEnv + ; name' <- lookupLocatedTopBndrRn name + ; (ty', fvs) <- rnHsTypeFVs (fo_decl_msg name) ty - -- Mark any PackageTarget style imports as coming from the current package - let packageId = thisPackage $ hsc_dflags topEnv - spec' = patchForeignImport packageId spec + -- Mark any PackageTarget style imports as coming from the current package + ; let packageId = thisPackage $ hsc_dflags topEnv + spec' = patchForeignImport packageId spec - in return (ForeignImport name' ty' spec', fvs) + ; return (ForeignImport name' ty' spec', fvs) } rnHsForeignDecl (ForeignExport name ty spec) - = lookupLocatedOccRn name `thenM` \ name' -> - rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) -> - return (ForeignExport name' ty' spec, fvs `addOneFV` unLoc name') + = do { name' <- lookupLocatedOccRn name + ; (ty', fvs) <- rnHsTypeFVs (fo_decl_msg name) ty + ; return (ForeignExport name' ty' spec, fvs `addOneFV` unLoc name') } -- NB: a foreign export is an *occurrence site* for name, so -- we add it to the free-variable list. It might, for example, -- be imported from another module @@ -438,30 +420,28 @@ patchCCallTarget packageId callTarget rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars) rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- Used for both source and interface file decls - = rnHsSigType (text "an instance decl") inst_ty `thenM` \ inst_ty' -> + = do { inst_ty' <- rnHsSigType (text "an instance decl") inst_ty -- Rename the bindings -- The typechecker (not the renamer) checks that all -- the bindings are for the right class - let - (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty') - in - extendTyVarEnvForMethodBinds inst_tyvars ( - -- (Slightly strangely) the forall-d tyvars scope over - -- the method bindings too - rnMethodBinds cls (\_ -> []) -- No scoped tyvars - mbinds - ) `thenM` \ (mbinds', meth_fvs) -> + ; let (inst_tyvars, _, L _ cls, _) = splitHsInstDeclTy inst_ty' + + ; (mbinds', meth_fvs) <- extendTyVarEnvForMethodBinds inst_tyvars $ + rnMethodBinds cls (\_ -> []) -- No scoped tyvars + mbinds + -- (Slightly strangely) the forall-d tyvars + -- scope over the method bindings too + -- Rename the associated types -- The typechecker (not the renamer) checks that all -- the declarations are for the right class - let - at_names = map (tcdLName . unLoc) ats -- The names of the associated types - in - checkDupRdrNames at_names `thenM_` + ; let at_names = map (tcdLName . unLoc) ats -- The names of the associated types + ; checkDupRdrNames at_names -- See notes with checkDupRdrNames for methods, above - rnATInsts ats `thenM` \ (ats', at_fvs) -> + ; traceRn (text "rnATInsts" <+> ppr ats) + ; (ats', at_fvs) <- rnATInsts cls ats -- Rename the prags and signatures. -- Note that the type variables are not in scope here, @@ -470,17 +450,15 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- works OK. -- -- But the (unqualified) method names are in scope - let - binders = collectHsBindsBinders mbinds' - bndr_set = mkNameSet binders - in - bindLocalNames binders - (renameSigs (Just bndr_set) okInstDclSig uprags) `thenM` \ uprags' -> - - return (InstDecl inst_ty' mbinds' uprags' ats', - meth_fvs `plusFV` at_fvs - `plusFV` hsSigsFVs uprags' - `plusFV` extractHsTyNames inst_ty') + ; let binders = collectHsBindsBinders mbinds' + bndr_set = mkNameSet binders + ; uprags' <- bindLocalNames binders $ + renameSigs (Just bndr_set) okInstDclSig uprags + + ; return (InstDecl inst_ty' mbinds' uprags' ats', + meth_fvs `plusFV` at_fvs + `plusFV` hsSigsFVs uprags' + `plusFV` extractHsTyNames inst_ty') } -- We return the renamed associated data type declarations so -- that they can be entered into the list of type declarations -- for the binding group, but we also keep a copy in the instance. @@ -496,14 +474,13 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) Renaming of the associated types in instances. \begin{code} -rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars) -rnATInsts atDecls = rnList rnATInst atDecls +rnATInsts :: Name -> [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars) +rnATInsts cls atDecls = rnList rnATInst atDecls where - rnATInst tydecl@TyData {} = rnTyClDecl tydecl - rnATInst tydecl@TySynonym {} = rnTyClDecl tydecl - rnATInst tydecl = - pprPanic "RnSource.rnATInsts: invalid AT instance" - (ppr (tcdName tydecl)) + rnATInst tydecl@TyData {} = rnTyClDecl (Just cls) tydecl + rnATInst tydecl@TySynonym {} = rnTyClDecl (Just cls) tydecl + rnATInst tydecl = pprPanic "RnSource.rnATInsts: invalid AT instance" + (ppr (tcdName tydecl)) \end{code} For the method bindings in class and instance decls, we extend the @@ -573,8 +550,8 @@ rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs) rn_var (RuleBndr (L loc _), id) = return (RuleBndr (L loc id), emptyFVs) rn_var (RuleBndrSig (L loc _) t, id) - = rnHsTypeFVs doc t `thenM` \ (t', fvs) -> - return (RuleBndrSig (L loc id) t', fvs) + = do { (t', fvs) <- rnHsTypeFVs doc t + ; return (RuleBndrSig (L loc id) t', fvs) } badRuleVar :: FastString -> Name -> SDoc badRuleVar name var @@ -709,7 +686,7 @@ However, we can also do some scoping checks at the same time. rnTyClDecls :: [[LTyClDecl RdrName]] -> RnM ([[LTyClDecl Name]], FreeVars) -- Renamed the declarations and do depedency analysis on them rnTyClDecls tycl_ds - = do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (concat tycl_ds) + = do { ds_w_fvs <- mapM (wrapLocFstM (rnTyClDecl Nothing)) (concat tycl_ds) ; let sccs :: [SCC (LTyClDecl Name)] sccs = depAnalTyClDecls ds_w_fvs @@ -718,24 +695,26 @@ rnTyClDecls tycl_ds ; return (map flattenSCC sccs, all_fvs) } -rnTyClDecl :: TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars) -rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name}) - = lookupLocatedTopBndrRn name `thenM` \ name' -> - return (ForeignType {tcdLName = name', tcdExtName = ext_name}, - emptyFVs) +rnTyClDecl :: Maybe Name -- Just cls => this TyClDecl is nested + -- inside an *instance decl* for cls + -- used for associated types + -> TyClDecl RdrName + -> RnM (TyClDecl Name, FreeVars) +rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name}) + = do { name' <- lookupLocatedTopBndrRn name + ; return (ForeignType {tcdLName = name', tcdExtName = ext_name}, + emptyFVs) } -- all flavours of type family declarations ("type family", "newtype family", -- and "data family") -rnTyClDecl tydecl@TyFamily {} = rnFamily tydecl bindTyVarsFV +rnTyClDecl _ tydecl@TyFamily {} = rnFamily tydecl bindTyVarsFV -- "data", "newtype", "data instance, and "newtype instance" declarations -rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, - tcdLName = tycon, tcdTyVars = tyvars, - tcdTyPats = typats, tcdCons = condecls, - tcdKindSig = sig, tcdDerivs = derivs} - = do { tycon' <- if isFamInstDecl tydecl - then lookupLocatedOccRn tycon -- may be imported family - else lookupLocatedTopBndrRn tycon +rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, + tcdLName = tycon, tcdTyVars = tyvars, + tcdTyPats = typats, tcdCons = condecls, + tcdKindSig = sig, tcdDerivs = derivs} + = do { tycon' <- lookupTcdName mb_cls tydecl ; checkTc (h98_style || null (unLoc context)) (badGadtStupidTheta tycon) ; ((tyvars', context', typats', derivs'), stuff_fvs) @@ -774,17 +753,15 @@ rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, data_doc = text "In the data type declaration for" <+> quotes (ppr tycon) rn_derivs Nothing = return (Nothing, emptyFVs) - rn_derivs (Just ds) = rnLHsTypes data_doc ds `thenM` \ ds' -> - return (Just ds', extractHsTyNames_s ds') + rn_derivs (Just ds) = do { ds' <- rnLHsTypes data_doc ds + ; return (Just ds', extractHsTyNames_s ds') } -- "type" and "type instance" declarations -rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars, - tcdTyPats = typats, tcdSynRhs = ty}) +rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars, tcdLName = name, + tcdTyPats = typats, tcdSynRhs = ty}) = bindTyVarsFV tyvars $ \ tyvars' -> do { -- Checks for distinct tyvars - name' <- if isFamInstDecl tydecl - then lookupLocatedOccRn name -- may be imported family - else lookupLocatedTopBndrRn name + name' <- lookupTcdName mb_cls tydecl ; (typats',fvs1) <- rnTyPats syn_doc name' typats ; (ty', fvs2) <- rnHsTypeFVs syn_doc ty ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars' @@ -793,9 +770,9 @@ rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars, where syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name) -rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, - tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, - tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs}) +rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = cname, + tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, + tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs}) = do { cname' <- lookupLocatedTopBndrRn cname -- Tyvars scope over superclass context and method signatures @@ -983,13 +960,13 @@ rnConDeclDetails :: SDoc -> HsConDetails (LHsType RdrName) [ConDeclField RdrName] -> RnM (HsConDetails (LHsType Name) [ConDeclField Name]) rnConDeclDetails doc (PrefixCon tys) - = mapM (rnLHsType doc) tys `thenM` \ new_tys -> - return (PrefixCon new_tys) + = do { new_tys <- mapM (rnLHsType doc) tys + ; return (PrefixCon new_tys) } rnConDeclDetails doc (InfixCon ty1 ty2) - = rnLHsType doc ty1 `thenM` \ new_ty1 -> - rnLHsType doc ty2 `thenM` \ new_ty2 -> - return (InfixCon new_ty1 new_ty2) + = do { new_ty1 <- rnLHsType doc ty1 + ; new_ty2 <- rnLHsType doc ty2 + ; return (InfixCon new_ty1 new_ty2) } rnConDeclDetails doc (RecCon fields) = do { new_fields <- rnConDeclFields doc fields @@ -1031,7 +1008,7 @@ rnATs ats = mapFvRn (wrapLocFstM rn_at) ats rn_at (tydecl@TySynonym {}) = do unless (isNothing (tcdTyPats tydecl)) $ addErr noPatterns - rnTyClDecl tydecl + rnTyClDecl Nothing tydecl rn_at _ = panic "RnSource.rnATs: invalid TyClDecl" lookupIdxVars tyvars cont = @@ -1151,9 +1128,9 @@ rnFds doc fds = mapM (wrapLocM rn_fds) fds where rn_fds (tys1, tys2) - = rnHsTyVars doc tys1 `thenM` \ tys1' -> - rnHsTyVars doc tys2 `thenM` \ tys2' -> - return (tys1', tys2') + = do { tys1' <- rnHsTyVars doc tys1 + ; tys2' <- rnHsTyVars doc tys2 + ; return (tys1', tys2') } rnHsTyVars :: SDoc -> [RdrName] -> RnM [Name] rnHsTyVars doc tvs = mapM (rnHsTyVar doc) tvs |