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,
- 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' ->
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 {tcdName = cls, tcdTyVars = tyvars}) -- Everything else is here
-- There are some default-method bindings (abeit possibly empty) so
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)]
projects / ghc-hetmet.git / blobdiff