bindLocalNames, checkDupRdrNames, mapFvRn,
)
import RnNames ( getLocalNonValBinders, extendGlobalRdrEnvRn )
-import HscTypes ( GenAvailInfo(..) )
+import HscTypes ( GenAvailInfo(..), availsToNameSet )
import RnHsDoc ( rnHsDoc, rnMbLHsDoc )
import TcRnMonad
\begin{code}
-- Brings the binders of the group into scope in the appropriate places;
-- does NOT assume that anything is in scope already
---
--- The Bool determines whether (True) names in the group shadow existing
--- Unquals in the global environment (used in Template Haskell) or
--- (False) whether duplicates are reported as an error
-rnSrcDecls :: Bool -> HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
-
-rnSrcDecls shadowP group@(HsGroup {hs_valds = val_decls,
+rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
+-- Rename a HsGroup; used for normal source files *and* hs-boot files
+rnSrcDecls group@(HsGroup {hs_valds = val_decls,
hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_derivds = deriv_decls,
-- (B) Bring top level binders (and their fixities) into scope,
-- *except* for the value bindings, which get brought in below.
- avails <- getLocalNonValBinders group ;
- tc_envs <- extendGlobalRdrEnvRn shadowP avails local_fix_env ;
+ -- 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 ;
setEnvs tc_envs $ do {
failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
-- 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 { lhs_binders = map unLoc $ collectHsValBinders new_lhs;
- lhs_avails = map Avail lhs_binders
+ let { val_binders = map unLoc $ 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
} ;
- (tcg_env, tcl_env) <- extendGlobalRdrEnvRn shadowP lhs_avails local_fix_env ;
+ (tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ;
setEnvs (tcg_env, tcl_env) $ do {
-- Now everything is in scope, as the remaining renaming assumes.
-- (F) Rename Value declarations right-hand sides
traceRn (text "Start rnmono") ;
- (rn_val_decls, bind_dus) <- rnTopBindsRHS lhs_binders new_lhs ;
+ (rn_val_decls, bind_dus) <- rnTopBindsRHS val_bndr_set new_lhs ;
traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
-- (G) Rename Fixity and deprecations
- -- rename fixity declarations and error if we try to
+ -- Rename fixity declarations and error if we try to
-- fix something from another module (duplicates were checked in (A))
- rn_fix_decls <- rnSrcFixityDecls fix_decls ;
- -- rename deprec decls;
+ rn_fix_decls <- rnSrcFixityDecls all_bndr_set fix_decls ;
+
+ -- Rename deprec decls;
-- check for duplicates and ensure that deprecated things are defined locally
-- at the moment, we don't keep these around past renaming
- rn_warns <- rnSrcWarnDecls warn_decls ;
+ rn_warns <- rnSrcWarnDecls all_bndr_set warn_decls ;
-- (H) Rename Everything else
%*********************************************************
\begin{code}
-rnSrcFixityDecls :: [LFixitySig RdrName] -> RnM [LFixitySig Name]
+rnSrcFixityDecls :: NameSet -> [LFixitySig RdrName] -> RnM [LFixitySig Name]
-- Rename the fixity decls, so we can put
-- the renamed decls in the renamed syntax tree
-- Errors if the thing being fixed is not defined locally.
--
-- The returned FixitySigs are not actually used for anything,
-- except perhaps the GHCi API
-rnSrcFixityDecls fix_decls
+rnSrcFixityDecls bound_names fix_decls
= do fix_decls <- mapM rn_decl fix_decls
return (concat fix_decls)
where
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 rdr_name
+ do names <- lookupLocalDataTcNames bound_names what rdr_name
return [ L loc (FixitySig (L name_loc name) fixity)
- | name <- names ]
+ | name <- names ]
+ what = ptext (sLit "fixity signature")
\end{code}
\begin{code}
-- checks that the deprecations are defined locally, and that there are no duplicates
-rnSrcWarnDecls :: [LWarnDecl RdrName] -> RnM Warnings
-rnSrcWarnDecls []
+rnSrcWarnDecls :: NameSet -> [LWarnDecl RdrName] -> RnM Warnings
+rnSrcWarnDecls _bound_names []
= returnM NoWarnings
-rnSrcWarnDecls decls
+rnSrcWarnDecls bound_names decls
= do { -- check for duplicates
; mappM_ (\ (lrdr:lrdr':_) -> addLocErr lrdr (dupWarnDecl lrdr')) warn_rdr_dups
; mappM (addLocM rn_deprec) decls `thenM` \ pairs_s ->
where
rn_deprec (Warning rdr_name txt)
-- ensures that the names are defined locally
- = lookupLocalDataTcNames rdr_name `thenM` \ names ->
+ = lookupLocalDataTcNames bound_names what rdr_name `thenM` \ names ->
returnM [(nameOccName name, txt) | name <- names]
+ what = ptext (sLit "deprecation")
+
-- look for duplicates among the OccNames;
-- we check that the names are defined above
-- invt: the lists returned by findDupsEq always have at least two elements
} }
| otherwise -- GADT
- = ASSERT( none typatsMaybe ) -- GADTs cannot have type patterns for now
- do { tycon' <- if isFamInstDecl tydecl
+ = do { tycon' <- if isFamInstDecl tydecl
then lookupLocatedOccRn tycon -- may be imported family
else lookupLocatedTopBndrRn tycon
; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
- ; tyvars' <- bindTyVarsRn data_doc tyvars
- (\ tyvars' -> return tyvars')
+ ; (tyvars', typats')
+ <- bindTyVarsRn data_doc tyvars $ \ tyvars' -> do
+ { typats' <- rnTyPats data_doc typatsMaybe
+ ; return (tyvars', typats') }
-- For GADTs, the type variables in the declaration
-- do not scope over the constructor signatures
-- data T a where { T1 :: forall b. b-> b }
+
; (derivs', deriv_fvs) <- rn_derivs derivs
; condecls' <- rnConDecls (unLoc tycon') condecls
-- No need to check for duplicate constructor decls
-- since that is done by RnNames.extendGlobalRdrEnvRn
+
; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [],
tcdLName = tycon', tcdTyVars = tyvars',
- tcdTyPats = Nothing, tcdKindSig = sig,
+ tcdTyPats = typats', tcdKindSig = sig,
tcdCons = condecls', tcdDerivs = derivs'},
plusFVs (map conDeclFVs condecls') `plusFV`
deriv_fvs `plusFV`
L _ (ConDecl { con_res = ResTyH98 }) : _ -> True
_ -> False
- none Nothing = True
- none (Just []) = True
- none _ = False
-
data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
rn_derivs Nothing = returnM (Nothing, emptyFVs)
; return $ unLoc x'}
get (L _ (TyData { tcdCons = cons })) env = foldrM get_con env cons
- get _ env = return env
+ get _ env = return env
- get_con (L _ (ConDecl { con_name = con, con_details = RecCon flds })) env
+ get_con (L _ (ConDecl { con_name = con, con_details = RecCon flds }))
+ (RecFields env fld_set)
= do { con' <- lookup con
- ; flds' <- mappM lookup (map cd_fld_name flds)
- ; return $ extendNameEnv env con' flds' }
- get_con _ env
- = return env
+ ; flds' <- mappM lookup (map cd_fld_name flds)
+ ; let env' = extendNameEnv env con' flds'
+ fld_set' = addListToNameSet fld_set flds'
+ ; return $ (RecFields env' fld_set') }
+ get_con _ env = return env
\end{code}
%*********************************************************
projects / ghc-hetmet.git / blobdiff