import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, renameSigsFVs )
import RnEnv ( lookupTopBndrRn, lookupOccRn, lookupIfaceName,
- lookupOrigNames, lookupSysBinder, newLocalsRn,
+ lookupSysBinder, newLocalsRn,
bindLocalsFVRn, bindPatSigTyVars,
bindTyVarsRn, extendTyVarEnvFVRn,
bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames,
import RnMonad
import Class ( FunDep, DefMeth (..) )
+import TyCon ( DataConDetails(..), visibleDataCons )
import DataCon ( dataConId )
import Name ( Name, NamedThing(..) )
import NameSet
-import PrelInfo ( derivableClassKeys )
import PrelNames ( deRefStablePtrName, newStablePtrName,
bindIOName, returnIOName
)
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}
-rnHsForeignDecl (ForeignImport name ty spec src_loc)
+rnHsForeignDecl (ForeignImport name ty spec isDeprec src_loc)
= pushSrcLocRn src_loc $
lookupTopBndrRn name `thenRn` \ name' ->
rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs) ->
- returnRn (ForeignImport name' ty' spec src_loc, fvs `plusFV` extras spec)
+ returnRn (ForeignImport name' ty' spec isDeprec src_loc,
+ fvs `plusFV` extras spec)
where
- extras (CDynImport _) = mkFVs [newStablePtrName, deRefStablePtrName, bindIOName, returnIOName]
- extras other = emptyFVs
+ 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', fvs) ->
- returnRn (ForeignExport name' ty' spec src_loc,
+ 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
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,
+ tcdTyVars = tyvars, tcdCons = condecls,
tcdDerivs = derivs, tcdLoc = src_loc, tcdSysNames = sys_names})
= pushSrcLocRn src_loc $
lookupTopBndrRn tycon `thenRn` \ tycon' ->
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,
+ 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')
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 declaration
\end{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 $