import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
import RnBinds ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn,
makeMiniFixityEnv)
-import RnEnv ( lookupLocalDataTcNames,
- lookupLocatedTopBndrRn, lookupLocatedOccRn,
+import RnEnv ( lookupLocalDataTcNames, lookupLocatedOccRn,
+ lookupTopBndrRn, lookupLocatedTopBndrRn,
lookupOccRn, newLocalsRn,
bindLocatedLocalsFV, bindPatSigTyVarsFV,
bindTyVarsRn, extendTyVarEnvFVRn,
bindLocalNames, checkDupRdrNames, mapFvRn,
)
import RnNames ( getLocalNonValBinders, extendGlobalRdrEnvRn )
-import HscTypes ( GenAvailInfo(..) )
+import HscTypes ( GenAvailInfo(..), availsToNameSet )
import RnHsDoc ( rnHsDoc, rnMbLHsDoc )
import TcRnMonad
-import HscTypes ( Deprecations(..), plusDeprecs )
+import HscTypes ( Warnings(..), plusWarns )
import Class ( FunDep )
import Name ( Name, nameOccName )
import NameSet
import Outputable
import Bag
import FastString
-import SrcLoc ( Located(..), unLoc, noLoc )
+import SrcLoc
import DynFlags ( DynFlag(..) )
import Maybe ( isNothing )
import BasicTypes ( Boxity(..) )
import ListSetOps (findDupsEq)
+import List
import Control.Monad
\end{code}
\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,
hs_fixds = fix_decls,
- hs_depds = deprec_decls,
+ hs_warnds = warn_decls,
+ hs_annds = ann_decls,
hs_fords = foreign_decls,
hs_defds = default_decls,
hs_ruleds = rule_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
-- extend the record field env.
-- This depends on the data constructors and field names being in
-- scope from (B) above
- inNewEnv (extendRecordFieldEnv tycl_decls) $ \ _ -> do {
+ inNewEnv (extendRecordFieldEnv tycl_decls inst_decls) $ \ _ -> do {
-- (D) Rename the left-hand sides of the value bindings.
-- This depends on everything from (B) being in scope,
-- 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_deprecs <- rnSrcDeprecDecls deprec_decls ;
+ rn_warns <- rnSrcWarnDecls all_bndr_set warn_decls ;
-- (H) Rename Everything else
(rn_inst_decls, src_fvs2) <- rnList rnSrcInstDecl inst_decls ;
- (rn_rule_decls, src_fvs3) <- rnList rnHsRuleDecl rule_decls ;
+ (rn_rule_decls, src_fvs3) <- setOptM Opt_ScopedTypeVariables $
+ rnList rnHsRuleDecl rule_decls ;
+ -- Inside RULES, scoped type variables are on
(rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ;
- (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl default_decls ;
- (rn_deriv_decls, src_fvs6) <- rnList rnSrcDerivDecl deriv_decls ;
+ (rn_ann_decls, src_fvs5) <- rnList rnAnnDecl ann_decls ;
+ (rn_default_decls, src_fvs6) <- rnList rnDefaultDecl default_decls ;
+ (rn_deriv_decls, src_fvs7) <- rnList rnSrcDerivDecl deriv_decls ;
-- Haddock docs; no free vars
rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
hs_instds = rn_inst_decls,
hs_derivds = rn_deriv_decls,
hs_fixds = rn_fix_decls,
- hs_depds = [], -- deprecs are returned in the tcg_env
+ hs_warnds = [], -- warns are returned in the tcg_env
-- (see below) not in the HsGroup
hs_fords = rn_foreign_decls,
+ hs_annds = rn_ann_decls,
hs_defds = rn_default_decls,
hs_ruleds = rn_rule_decls,
hs_docs = rn_docs } ;
- other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs6, src_fvs3,
- src_fvs4, src_fvs5] ;
+ other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
+ src_fvs5, src_fvs6, src_fvs7] ;
src_dus = bind_dus `plusDU` usesOnly other_fvs;
-- Note: src_dus will contain *uses* for locally-defined types
-- and classes, but no *defs* for them. (Because rnTyClDecl
final_tcg_env = let tcg_env' = (tcg_env `addTcgDUs` src_dus)
in -- we return the deprecs in the env, not in the HsGroup above
- tcg_env' { tcg_deprecs = tcg_deprecs tcg_env' `plusDeprecs` rn_deprecs };
+ tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
} ;
traceRn (text "finish rnSrc" <+> ppr rn_group) ;
%*********************************************************
\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
-rnSrcDeprecDecls :: [LDeprecDecl RdrName] -> RnM Deprecations
-rnSrcDeprecDecls []
- = returnM NoDeprecs
+rnSrcWarnDecls :: NameSet -> [LWarnDecl RdrName] -> RnM Warnings
+rnSrcWarnDecls _bound_names []
+ = returnM NoWarnings
-rnSrcDeprecDecls decls
+rnSrcWarnDecls bound_names decls
= do { -- check for duplicates
- ; mappM_ (\ (lrdr:lrdr':_) -> addLocErr lrdr (dupDeprecDecl lrdr')) deprec_rdr_dups
+ ; mappM_ (\ (lrdr:lrdr':_) -> addLocErr lrdr (dupWarnDecl lrdr')) warn_rdr_dups
; mappM (addLocM rn_deprec) decls `thenM` \ pairs_s ->
- returnM (DeprecSome ((concat pairs_s))) }
+ returnM (WarnSome ((concat pairs_s))) }
where
- rn_deprec (Deprecation rdr_name txt)
+ 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
- deprec_rdr_dups = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
- (map (\ (L loc (Deprecation rdr_name _)) -> L loc rdr_name) decls)
+ warn_rdr_dups = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
+ (map (\ (L loc (Warning rdr_name _)) -> L loc rdr_name) decls)
-dupDeprecDecl :: Located RdrName -> RdrName -> SDoc
+dupWarnDecl :: Located RdrName -> RdrName -> SDoc
-- Located RdrName -> DeprecDecl RdrName -> SDoc
-dupDeprecDecl (L loc _) rdr_name
- = vcat [ptext (sLit "Multiple deprecation declarations for") <+> quotes (ppr rdr_name),
+dupWarnDecl (L loc _) rdr_name
+ = vcat [ptext (sLit "Multiple warning declarations for") <+> quotes (ppr rdr_name),
ptext (sLit "also at ") <+> ppr loc]
\end{code}
%*********************************************************
%* *
-\subsection{Source code declarations}
+\subsection{Annotation declarations}
+%* *
+%*********************************************************
+
+\begin{code}
+rnAnnDecl :: AnnDecl RdrName -> RnM (AnnDecl Name, FreeVars)
+rnAnnDecl (HsAnnotation provenance expr) = do
+ (provenance', provenance_fvs) <- rnAnnProvenance provenance
+ (expr', expr_fvs) <- rnLExpr expr
+ return (HsAnnotation provenance' expr', provenance_fvs `plusFV` expr_fvs)
+
+rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars)
+rnAnnProvenance provenance = do
+ provenance' <- modifyAnnProvenanceNameM lookupTopBndrRn provenance
+ return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Default declarations}
%* *
%*********************************************************
-- But the (unqualified) method names are in scope
let
binders = collectHsBindBinders mbinds'
- ok_sig = okInstDclSig (mkNameSet binders)
+ bndr_set = mkNameSet binders
in
- bindLocalNames binders (renameSigs ok_sig uprags) `thenM` \ uprags' ->
+ bindLocalNames binders
+ (renameSigs (Just bndr_set) okInstDclSig uprags) `thenM` \ uprags' ->
returnM (InstDecl inst_ty' mbinds' uprags' ats',
meth_fvs `plusFV` at_fvs
rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
= bindPatSigTyVarsFV (collectRuleBndrSigTys vars) $
-
bindLocatedLocalsFV doc (map get_var vars) $ \ ids ->
- mapFvRn rn_var (vars `zip` ids) `thenM` \ (vars', fv_vars) ->
+ do { (vars', fv_vars) <- mapFvRn rn_var (vars `zip` ids)
+ -- NB: The binders in a rule are always Ids
+ -- We don't (yet) support type variables
- rnLExpr lhs `thenM` \ (lhs', fv_lhs') ->
- rnLExpr rhs `thenM` \ (rhs', fv_rhs') ->
+ ; (lhs', fv_lhs') <- rnLExpr lhs
+ ; (rhs', fv_rhs') <- rnLExpr rhs
- checkValidRule rule_name ids lhs' fv_lhs' `thenM_`
+ ; checkValidRule rule_name ids lhs' fv_lhs'
- returnM (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
- fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs')
+ ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
+ fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') }
where
doc = text "In the transformation rule" <+> ftext rule_name
check_e is commented out.
\begin{code}
-checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM [()]
+checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM ()
checkValidRule rule_name ids lhs' fv_lhs'
= do { -- Check for the form of the LHS
case (validRuleLhs ids lhs') of
-- Check that LHS vars are all bound
; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
- ; mappM (addErr . badRuleVar rule_name) bad_vars }
+ ; mapM_ (addErr . badRuleVar rule_name) bad_vars }
validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
-- Nothing => OK
| is_vanilla -- Normal Haskell data type decl
= ASSERT( isNothing sig ) -- In normal H98 form, kind signature on the
-- data type is syntactically illegal
- bindTyVarsRn data_doc tyvars $ \ tyvars' ->
- do { tycon' <- if isFamInstDecl tydecl
+ do { tyvars <- pruneTyVars tydecl
+ ; bindTyVarsRn data_doc tyvars $ \ tyvars' -> do
+ { tycon' <- if isFamInstDecl tydecl
then lookupLocatedOccRn tycon -- may be imported family
else lookupLocatedTopBndrRn tycon
; context' <- rnContext data_doc context
(if isFamInstDecl tydecl
then unitFV (unLoc tycon') -- type instance => use
else emptyFVs))
- }
+ } }
| 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)
returnM (Just ds', extractHsTyNames_s ds')
-- "type" and "type instance" declarations
-rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
+rnTyClDecl tydecl@(TySynonym {tcdLName = name,
tcdTyPats = typatsMaybe, tcdSynRhs = ty})
- = bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
- do { name' <- if isFamInstDecl tydecl
+ = do { tyvars <- pruneTyVars tydecl
+ ; bindTyVarsRn syn_doc tyvars $ \ tyvars' -> do
+ { name' <- if isFamInstDecl tydecl
then lookupLocatedOccRn name -- may be imported family
else lookupLocatedTopBndrRn name
; typats' <- rnTyPats syn_doc typatsMaybe
(if isFamInstDecl tydecl
then unitFV (unLoc name') -- type instance => use
else emptyFVs))
- }
+ } }
where
syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
{ context' <- rnContext cls_doc context
; fds' <- rnFds cls_doc fds
; (ats', ats_fvs) <- rnATs ats
- ; sigs' <- renameSigs okClsDclSig sigs
+ ; sigs' <- renameSigs Nothing okClsDclSig sigs
; return (tyvars', context', fds', ats', ats_fvs, sigs') }
-- No need to check for duplicate associated type decls
%*********************************************************
\begin{code}
+-- Remove any duplicate type variables in family instances may have non-linear
+-- left-hand sides. Complain if any, but the first occurence of a type
+-- variable has a user-supplied kind signature.
+--
+pruneTyVars :: TyClDecl RdrName -> RnM [LHsTyVarBndr RdrName]
+pruneTyVars tydecl
+ | isFamInstDecl tydecl
+ = do { let pruned_tyvars = nubBy eqLTyVar tyvars
+ ; assertNoSigsInRepeats tyvars
+ ; return pruned_tyvars
+ }
+ | otherwise
+ = return tyvars
+ where
+ tyvars = tcdTyVars tydecl
+
+ assertNoSigsInRepeats [] = return ()
+ assertNoSigsInRepeats (tv:tvs)
+ = do { let offending_tvs = [ tv' | tv'@(L _ (KindedTyVar _ _)) <- tvs
+ , tv' `eqLTyVar` tv]
+ ; checkErr (null offending_tvs) $
+ illegalKindSig (head offending_tvs)
+ ; assertNoSigsInRepeats tvs
+ }
+
+ illegalKindSig tv
+ = hsep [ptext (sLit "Repeat variable occurrence may not have a"),
+ ptext (sLit "kind signature:"), quotes (ppr tv)]
+
+ tv1 `eqLTyVar` tv2 = hsLTyVarLocName tv1 `eqLocated` hsLTyVarLocName tv2
+
-- Although, we are processing type patterns here, all type variables will
-- already be in scope (they are the same as in the 'tcdTyVars' field of the
-- type declaration to which these patterns belong)
tcdLName = tycon, tcdTyVars = tyvars})
bindIdxVars =
do { checkM (isDataFlavour flavour -- for synonyms,
- || not (null tyvars)) $ addErr needOneIdx -- #indexes >= 1
+ || not (null tyvars)) $ addErr needOneIdx -- no. of indexes >= 1
; bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do {
; tycon' <- lookupLocatedTopBndrRn tycon
; returnM (TyFamily {tcdFlavour = flavour, tcdLName = tycon',
Get the mapping from constructors to fields for this module.
It's convenient to do this after the data type decls have been renamed
\begin{code}
-extendRecordFieldEnv :: [LTyClDecl RdrName] -> TcM TcGblEnv
-extendRecordFieldEnv decls
+extendRecordFieldEnv :: [LTyClDecl RdrName] -> [LInstDecl RdrName] -> TcM TcGblEnv
+extendRecordFieldEnv tycl_decls inst_decls
= do { tcg_env <- getGblEnv
- ; field_env' <- foldrM get (tcg_field_env tcg_env) decls
+ ; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons
; return (tcg_env { tcg_field_env = field_env' }) }
where
-- we want to lookup:
lookup x = do { x' <- lookupLocatedTopBndrRn x
; return $ unLoc x'}
- get (L _ (TyData { tcdCons = cons })) env = foldrM get_con env cons
- get _ env = return env
+ all_data_cons :: [ConDecl RdrName]
+ all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls
+ , L _ con <- cons ]
+ all_tycl_decls = at_tycl_decls ++ tycl_decls
+ at_tycl_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats]
+ -- Do not forget associated types!
- get_con (L _ (ConDecl { con_name = con, con_details = RecCon flds })) env
+ get_con (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}
%*********************************************************