import RnExpr
import HsSyn
-import HscTypes ( GlobalRdrEnv )
+import HscTypes ( GlobalRdrEnv, AvailEnv )
import RdrName ( RdrName, isRdrDataCon, elemRdrEnv )
import RdrHsSyn ( RdrNameConDecl, RdrNameTyClDecl,
- extractRuleBndrsTyVars, extractGenericPatTyVars
+ extractGenericPatTyVars
)
import RnHsSyn
import HsCore
import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, renameSigsFVs )
import RnEnv ( lookupTopBndrRn, lookupOccRn, lookupIfaceName,
- lookupOrigNames, lookupSysBinder, newLocalsRn,
- bindLocalsFVRn,
- bindTyVarsRn, bindTyVars2Rn,
- bindTyVarsFV2Rn, extendTyVarEnvFVRn,
+ lookupSysBinder, newLocalsRn,
+ bindLocalsFVRn, bindPatSigTyVars,
+ bindTyVarsRn, extendTyVarEnvFVRn,
bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames,
checkDupOrQualNames, checkDupNames, mapFvRn
)
import RnMonad
import Class ( FunDep, DefMeth (..) )
+import TyCon ( DataConDetails(..), visibleDataCons )
import DataCon ( dataConId )
import Name ( Name, NamedThing(..) )
import NameSet
-import PrelInfo ( derivableClassKeys )
-import PrelNames ( deRefStablePtr_RDR, newStablePtr_RDR,
- bindIO_RDR, returnIO_RDR
+import PrelNames ( deRefStablePtrName, newStablePtrName,
+ bindIOName, returnIOName
)
import TysWiredIn ( tupleCon )
import List ( partition )
import SrcLoc ( SrcLoc )
import CmdLineOpts ( DynFlag(..) )
-- Warn of unused for-all'd tyvars
-import Unique ( Uniquable(..) )
import Maybes ( maybeToBool )
+import Maybe ( maybe )
\end{code}
@rnSourceDecl@ `renames' declarations.
%*********************************************************
\begin{code}
-rnSourceDecls :: GlobalRdrEnv -> LocalFixityEnv
+rnSourceDecls :: GlobalRdrEnv -> AvailEnv -> LocalFixityEnv
-> [RdrNameHsDecl]
-> RnMG ([RenamedHsDecl], FreeVars)
-- The decls get reversed, but that's ok
-rnSourceDecls gbl_env local_fixity_env decls
- = initRnMS gbl_env emptyRdrEnv local_fixity_env SourceMode (go emptyFVs [] decls)
+rnSourceDecls gbl_env avails local_fixity_env decls
+ = initRnMS gbl_env avails emptyRdrEnv local_fixity_env SourceMode (go emptyFVs [] decls)
where
-- Fixity and deprecations have been dealt with already; ignore them
go fvs ds' [] = returnRn (ds', fvs)
%*********************************************************
\begin{code}
-rnHsForeignDecl (ForeignImport name ty spec src_loc)
+rnHsForeignDecl (ForeignImport name ty spec isDeprec src_loc)
= pushSrcLocRn src_loc $
- lookupOccRn name `thenRn` \ name' ->
- rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs1) ->
- lookupOrigNames (extras spec) `thenRn` \ fvs2 ->
- returnRn (ForeignImport name' ty' spec src_loc, fvs1 `plusFV` fvs2)
+ lookupTopBndrRn name `thenRn` \ name' ->
+ rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs) ->
+ returnRn (ForeignImport name' ty' spec isDeprec src_loc,
+ fvs `plusFV` extras spec)
where
- extras (CDynImport _) = [newStablePtr_RDR, deRefStablePtr_RDR, bindIO_RDR, returnIO_RDR]
- extras other = []
+ extras (CImport _ _ _ _ CWrapper) = mkFVs [newStablePtrName,
+ deRefStablePtrName,
+ bindIOName, returnIOName]
+ extras _ = emptyFVs
-rnHsForeignDecl (ForeignExport name ty spec src_loc)
+rnHsForeignDecl (ForeignExport name ty spec isDeprec src_loc)
= pushSrcLocRn src_loc $
lookupOccRn name `thenRn` \ name' ->
- rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs1) ->
- lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs2 ->
- returnRn (ForeignExport name' ty' spec src_loc, fvs1 `plusFV` fvs2)
+ rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs) ->
+ returnRn (ForeignExport name' ty' spec isDeprec src_loc,
+ mkFVs [bindIOName, returnIOName] `plusFV` fvs)
fo_decl_msg name = ptext SLIT("The foreign declaration for") <+> ppr name
\end{code}
let
meth_doc = text "In the bindings in an instance declaration"
meth_names = collectLocatedMonoBinders mbinds
- inst_tyvars = case inst_ty of
- HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
- other -> []
+ (inst_tyvars, (cls,_)) = getHsInstHead inst_ty
-- (Slightly strangely) the forall-d tyvars scope over
-- the method bindings too
in
-- NB meth_names can be qualified!
checkDupNames meth_doc meth_names `thenRn_`
extendTyVarEnvFVRn (map hsTyVarName inst_tyvars) (
- rnMethodBinds [] mbinds
+ rnMethodBinds cls [] mbinds
) `thenRn` \ (mbinds', meth_fvs) ->
let
binders = collectMonoBinders mbinds'
= lookupOccRn fn `thenRn` \ fn' ->
returnRn (IfaceRuleOut fn' rule)
-rnHsRuleDecl (HsRule rule_name act tvs vars lhs rhs src_loc)
- = ASSERT( null tvs )
- pushSrcLocRn src_loc $
+rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc)
+ = pushSrcLocRn src_loc $
+ bindPatSigTyVars (collectRuleBndrSigTys vars) $
- bindTyVarsFV2Rn doc (map UserTyVar sig_tvs) $ \ sig_tvs' _ ->
bindLocalsFVRn doc (map get_var vars) $ \ ids ->
mapFvRn rn_var (vars `zip` ids) `thenRn` \ (vars', fv_vars) ->
bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
in
mapRn (addErrRn . badRuleVar rule_name) bad_vars `thenRn_`
- returnRn (HsRule rule_name act sig_tvs' vars' lhs' rhs' src_loc,
+ returnRn (HsRule rule_name act vars' lhs' rhs' src_loc,
fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
where
doc = text "In the transformation rule" <+> ptext rule_name
- sig_tvs = extractRuleBndrsTyVars vars
get_var (RuleBndr v) = v
get_var (RuleBndrSig v _) = v
where
doc_str = text "In the interface signature for" <+> quotes (ppr name)
+rnTyClDecl (CoreDecl {tcdName = name, tcdType = ty, tcdRhs = rhs, tcdLoc = loc})
+ = pushSrcLocRn loc $
+ lookupTopBndrRn name `thenRn` \ name' ->
+ rnHsType doc_str ty `thenRn` \ ty' ->
+ rnCoreExpr rhs `thenRn` \ rhs' ->
+ returnRn (CoreDecl {tcdName = name', tcdType = ty', tcdRhs = rhs', tcdLoc = loc})
+ where
+ doc_str = text "In the Core declaration for" <+> quotes (ppr name)
+
rnTyClDecl (ForeignType {tcdName = name, tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
= pushSrcLocRn loc $
lookupTopBndrRn name `thenRn` \ name' ->
returnRn (ForeignType {tcdName = name', tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
- tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = nconstrs,
- tcdLoc = src_loc, tcdSysNames = sys_names})
+ tcdTyVars = tyvars, tcdCons = condecls,
+ tcdDerivs = derivs, tcdLoc = src_loc, tcdSysNames = sys_names})
= pushSrcLocRn src_loc $
lookupTopBndrRn tycon `thenRn` \ tycon' ->
bindTyVarsRn data_doc tyvars $ \ tyvars' ->
rnContext data_doc context `thenRn` \ context' ->
+ rn_derivs derivs `thenRn` \ derivs' ->
checkDupOrQualNames data_doc con_names `thenRn_`
- -- Check that there's at least one condecl,
- -- or else we're reading an interface file, or -fglasgow-exts
- (if null condecls then
- doptRn Opt_GlasgowExts `thenRn` \ glaExts ->
- getModeRn `thenRn` \ mode ->
- checkRn (glaExts || isInterfaceMode mode)
- (emptyConDeclsErr tycon)
- else returnRn ()
- ) `thenRn_`
-
- mapRn rnConDecl condecls `thenRn` \ condecls' ->
+ rnConDecls tycon' condecls `thenRn` \ condecls' ->
mapRn lookupSysBinder sys_names `thenRn` \ sys_names' ->
returnRn (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon',
- tcdTyVars = tyvars', tcdCons = condecls', tcdNCons = nconstrs,
- tcdDerivs = Nothing, tcdLoc = src_loc, tcdSysNames = sys_names'})
+ tcdTyVars = tyvars', tcdCons = condecls',
+ tcdDerivs = derivs', tcdLoc = src_loc, tcdSysNames = sys_names'})
where
data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
- con_names = map conDeclName condecls
+ con_names = map conDeclName (visibleDataCons condecls)
+ rn_derivs Nothing = returnRn Nothing
+ rn_derivs (Just ds) = rnContext data_doc ds `thenRn` \ ds' -> returnRn (Just ds')
+
rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc})
= pushSrcLocRn src_loc $
lookupTopBndrRn name `thenRn` \ name' ->
mapRn lookupSysBinder names `thenRn` \ names' ->
-- Tyvars scope over bindings and context
- bindTyVars2Rn cls_doc tyvars $ \ clas_tyvar_names tyvars' ->
+ bindTyVarsRn cls_doc tyvars $ \ tyvars' ->
-- Check the superclasses
rnContext cls_doc context `thenRn` \ context' ->
(op_sigs, non_op_sigs) = partition isClassOpSig sigs
sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
in
- checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
- mapRn (rnClassOp cname' clas_tyvar_names fds') op_sigs `thenRn` \ sigs' ->
+ checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
+ mapRn (rnClassOp cname' fds') op_sigs `thenRn` \ sigs' ->
let
binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
in
cls_doc = text "In the declaration for class" <+> ppr cname
sig_doc = text "In the signatures for class" <+> ppr cname
-rnClassOp clas clas_tyvars clas_fds sig@(ClassOpSig op dm_stuff ty locn)
+rnClassOp clas clas_fds sig@(ClassOpSig op dm_stuff ty locn)
= pushSrcLocRn locn $
lookupTopBndrRn op `thenRn` \ op_name ->
finishSourceTyClDecl :: RdrNameTyClDecl -> RenamedTyClDecl -> RnMS (RenamedTyClDecl, FreeVars)
-- Used for source file decls only
-- Renames the default-bindings of a class decl
- -- the derivings of a data decl
-finishSourceTyClDecl (TyData {tcdDerivs = Just derivs, tcdLoc = src_loc}) -- Derivings in here
- rn_ty_decl -- Everything else is here
- = pushSrcLocRn src_loc $
- mapRn rnDeriv derivs `thenRn` \ derivs' ->
- returnRn (rn_ty_decl {tcdDerivs = Just derivs'}, mkNameSet derivs')
-
finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc}) -- Get mbinds from here
- rn_cls_decl@(ClassDecl {tcdTyVars = tyvars}) -- Everything else is here
+ rn_cls_decl@(ClassDecl {tcdName = cls, tcdTyVars = tyvars}) -- Everything else is here
-- There are some default-method bindings (abeit possibly empty) so
-- this is a source-code class declaration
= -- The newLocals call is tiresome: given a generic class decl
in
checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
newLocalsRn gen_rdr_tyvars_w_locs `thenRn` \ gen_tyvars ->
- rnMethodBinds gen_tyvars mbinds `thenRn` \ (mbinds', meth_fvs) ->
+ rnMethodBinds cls gen_tyvars mbinds `thenRn` \ (mbinds', meth_fvs) ->
returnRn (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs)
where
meth_doc = text "In the default-methods for class" <+> ppr (tcdName rn_cls_decl)
+finishSourceTyClDecl _ tycl_decl@(TyData {tcdDerivs = derivings})
+ -- Derivings are returned here so that they don't form part of the tyClDeclFVs.
+ -- This is important, because tyClDeclFVs should contain only the
+ -- FVs that are `needed' by the interface file declaration, and
+ -- derivings do not appear in this. It also means that the tcGroups
+ -- are smaller, which turned out to be important for the usage inference. KSW 2002-02.
+ = returnRn (tycl_decl,
+ maybe emptyFVs extractHsCtxtTyNames derivings)
+
finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs)
- -- Not a class or data type declaration
+ -- Not a class declaration
\end{code}
%*********************************************************
\begin{code}
-rnDeriv :: RdrName -> RnMS Name
-rnDeriv cls
- = lookupOccRn cls `thenRn` \ clas_name ->
- checkRn (getUnique clas_name `elem` derivableClassKeys)
- (derivingNonStdClassErr clas_name) `thenRn_`
- returnRn clas_name
-\end{code}
-
-\begin{code}
conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
conDeclName (ConDecl n _ _ _ _ l) = (n,l)
+rnConDecls :: Name -> DataConDetails RdrNameConDecl -> RnMS (DataConDetails RenamedConDecl)
+rnConDecls tycon Unknown = returnRn Unknown
+rnConDecls tycon (HasCons n) = returnRn (HasCons n)
+rnConDecls tycon (DataCons condecls)
+ = -- Check that there's at least one condecl,
+ -- or else we're reading an interface file, or -fglasgow-exts
+ (if null condecls then
+ doptRn Opt_GlasgowExts `thenRn` \ glaExts ->
+ getModeRn `thenRn` \ mode ->
+ checkRn (glaExts || isInterfaceMode mode)
+ (emptyConDeclsErr tycon)
+ else returnRn ()
+ ) `thenRn_`
+
+ mapRn rnConDecl condecls `thenRn` \ condecls' ->
+ returnRn (DataCons condecls')
+
rnConDecl :: RdrNameConDecl -> RnMS RenamedConDecl
rnConDecl (ConDecl name wkr tvs cxt details locn)
= pushSrcLocRn locn $
%*********************************************************
\begin{code}
-derivingNonStdClassErr clas
- = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
-
badDataCon name
= hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
+
badRuleLhsErr name lhs
= sep [ptext SLIT("Rule") <+> ptext name <> colon,
nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]