import RnMonad
import Class ( FunDep, DefMeth (..) )
-import DataCon ( dataConId )
+import TyCon ( DataConDetails(..), visibleDataCons )
+import DataCon ( dataConWorkId )
import Name ( Name, NamedThing(..) )
import NameSet
import PrelNames ( deRefStablePtrName, newStablePtrName,
%*********************************************************
\begin{code}
-rnSourceDecls :: GlobalRdrEnv -> AvailEnv -> LocalFixityEnv
+rnSourceDecls :: GlobalRdrEnv -> AvailEnv -> LocalFixityEnv -> RnMode
-> [RdrNameHsDecl]
-> RnMG ([RenamedHsDecl], FreeVars)
-- The decls get reversed, but that's ok
-rnSourceDecls gbl_env avails local_fixity_env decls
- = initRnMS gbl_env avails emptyRdrEnv local_fixity_env SourceMode (go emptyFVs [] decls)
+rnSourceDecls gbl_env avails local_fixity_env mode decls
+ = initRnMS gbl_env avails emptyRdrEnv local_fixity_env mode (go emptyFVs [] decls)
where
-- Fixity and deprecations have been dealt with already; ignore them
go fvs ds' [] = returnRn (ds', fvs)
-- Rename the bindings
-- NB meth_names can be qualified!
checkDupNames meth_doc meth_names `thenRn_`
- extendTyVarEnvFVRn (map hsTyVarName inst_tyvars) (
+ extendTyVarEnvForMethodBinds inst_tyvars (
rnMethodBinds cls [] mbinds
) `thenRn` \ (mbinds', meth_fvs) ->
let
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
+ doc = text "In the transformation rule" <+> ftext rule_name
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,
+ 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')
-- we jolly well ought to get a 'hit' there!
mapRn lookupSysBinder names `thenRn` \ names' ->
- -- Tyvars scope over bindings and context
+ -- Tyvars scope over superclass context and method signatures
bindTyVarsRn cls_doc tyvars $ \ tyvars' ->
-- Check the superclasses
-- easy to group together in the typechecker.
-- Hence the
pushSrcLocRn src_loc $
- extendTyVarEnvFVRn (map hsTyVarName tyvars) $
+ extendTyVarEnvForMethodBinds tyvars $
getLocalNameEnv `thenRn` \ name_env ->
let
meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds
-- Not a class declaration
\end{code}
+For the method bindings in class and instance decls, we extend the
+type variable environment iff -fglasgow-exts
+
+\begin{code}
+extendTyVarEnvForMethodBinds tyvars thing_inside
+ = doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts ->
+ if opt_GlasgowExts then
+ extendTyVarEnvFVRn (map hsTyVarName tyvars) thing_inside
+ else
+ thing_inside
+\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 $
= mapRn rnCoreExpr args `thenRn` \ args' ->
returnRn (UfTuple (HsTupCon tup_name boxity arity) args')
where
- tup_name = getName (dataConId (tupleCon boxity arity))
+ tup_name = getName (dataConWorkId (tupleCon boxity arity))
-- Get the *worker* name and use that
rnCoreExpr (UfApp fun arg)
= hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
badRuleLhsErr name lhs
- = sep [ptext SLIT("Rule") <+> ptext name <> colon,
+ = sep [ptext SLIT("Rule") <+> ftext name <> colon,
nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
$$
ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
badRuleVar name var
- = sep [ptext SLIT("Rule") <+> doubleQuotes (ptext name) <> colon,
+ = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
ptext SLIT("does not appear on left hand side")]
projects / ghc-hetmet.git / blobdiff