returnRn (ValD new_binds, fvs)
rnSourceDecl (TyClD tycl_decl)
- = rnTyClDecl tycl_decl `thenRn` \ new_decl ->
- rnClassBinds tycl_decl new_decl `thenRn` \ (new_decl', fvs) ->
+ = rnTyClDecl tycl_decl `thenRn` \ new_decl ->
+ finishSourceTyClDecl tycl_decl new_decl `thenRn` \ (new_decl', fvs) ->
returnRn (TyClD new_decl', fvs `plusFV` tyClDeclFVs new_decl')
rnSourceDecl (InstD inst)
- = rnInstDecl inst `thenRn` \ new_inst ->
- rnInstBinds inst new_inst `thenRn` \ (new_inst', fvs) ->
+ = rnInstDecl inst `thenRn` \ new_inst ->
+ finishSourceInstDecl inst new_inst `thenRn` \ (new_inst', fvs) ->
returnRn (InstD new_inst', fvs `plusFV` instDeclFVs new_inst')
rnSourceDecl (RuleD rule)
-- The typechecker checks that all the bindings are for the right class.
returnRn (InstDecl inst_ty' EmptyMonoBinds [] maybe_dfun_name src_loc)
--- Compare rnClassBinds
-rnInstBinds (InstDecl _ mbinds uprags _ _ )
- (InstDecl inst_ty _ _ maybe_dfun_name src_loc)
+-- Compare finishSourceTyClDecl
+finishSourceInstDecl (InstDecl _ mbinds uprags _ _ )
+ (InstDecl inst_ty _ _ maybe_dfun_name src_loc)
-- Used for both source decls only
= ASSERT( not (maybeToBool maybe_dfun_name) ) -- Source decl!
let
rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = nconstrs,
- tcdDerivs = derivings, tcdLoc = src_loc, tcdSysNames = sys_names})
+ tcdLoc = src_loc, tcdSysNames = sys_names})
= pushSrcLocRn src_loc $
lookupTopBndrRn tycon `thenRn` \ tycon' ->
bindTyVarsRn data_doc tyvars $ \ tyvars' ->
checkDupOrQualNames data_doc con_names `thenRn_`
mapRn rnConDecl condecls `thenRn` \ condecls' ->
mapRn lookupSysBinder sys_names `thenRn` \ sys_names' ->
- rnDerivs derivings `thenRn` \ derivings' ->
returnRn (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon',
tcdTyVars = tyvars', tcdCons = condecls', tcdNCons = nconstrs,
- tcdDerivs = derivings', tcdLoc = src_loc, tcdSysNames = sys_names'})
+ tcdDerivs = Nothing, tcdLoc = src_loc, tcdSysNames = sys_names'})
where
data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
con_names = map conDeclName condecls
-- Silently discard context... but the tyvars in the rest won't be in scope
-- In interface files all types are quantified, so this is a no-op
unquantify glaExts (HsForAllTy Nothing ctxt ty) | glaExts = ty
- unquantify glaExys ty = ty
+ unquantify glaExts ty = ty
rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname,
tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
returnRn (ClassOpSig op_name dm_stuff' new_ty locn)
-rnClassBinds :: RdrNameTyClDecl -> RenamedTyClDecl -> RnMS (RenamedTyClDecl, FreeVars)
+finishSourceTyClDecl :: RdrNameTyClDecl -> RenamedTyClDecl -> RnMS (RenamedTyClDecl, FreeVars)
-- Used for source file decls only
-rnClassBinds (ClassDecl {tcdMeths = Just mbinds}) -- Get mbinds from here
- rn_cls_decl@(ClassDecl {tcdTyVars = tyvars, tcdLoc = src_loc}) -- Everything else is here
+ -- 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
-- 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
-- we want to name both "x" tyvars with the same unique, so that they are
-- easy to group together in the typechecker.
-- Hence the
+ pushSrcLocRn src_loc $
extendTyVarEnvFVRn (map hsTyVarName tyvars) $
getLocalNameEnv `thenRn` \ name_env ->
let
where
meth_doc = text "the default-methods for class" <+> ppr (tcdName rn_cls_decl)
-rnClassBinds _ tycl_decl = returnRn (tycl_decl, emptyFVs)
+finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs)
-- Not a class declaration
\end{code}
%*********************************************************
\begin{code}
-rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name])
-
-rnDerivs Nothing -- derivs not specified
- = returnRn Nothing
-
-rnDerivs (Just clss)
- = mapRn do_one clss `thenRn` \ clss' ->
- returnRn (Just clss')
- where
- do_one cls = lookupOccRn cls `thenRn` \ clas_name ->
- checkRn (getUnique clas_name `elem` derivableClassKeys)
- (derivingNonStdClassErr clas_name) `thenRn_`
- returnRn clas_name
+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}
rnContext :: SDoc -> RdrNameContext -> RnMS RenamedContext
rnContext doc ctxt
= mapRn rn_pred ctxt `thenRn` \ theta ->
- let
- (_, dups) = removeDupsEq theta
- -- We only have equality, not ordering
- in
+
-- Check for duplicate assertions
-- If this isn't an error, then it ought to be:
- mapRn (addWarnRn . dupClassAssertWarn theta) dups `thenRn_`
+ ifOptRn Opt_WarnMisc (
+ let
+ (_, dups) = removeDupsEq theta
+ -- We only have equality, not ordering
+ in
+ mapRn (addWarnRn . dupClassAssertWarn theta) dups
+ ) `thenRn_`
+
returnRn theta
where
--Someone discovered that @CCallable@ and @CReturnable@
(naughtyCCallContextErr pred') `thenRn_`
returnRn pred'
- bad_pred (HsPClass clas _) = getUnique clas `elem` cCallishClassKeys
+ bad_pred (HsClassP clas _) = getUnique clas `elem` cCallishClassKeys
bad_pred other = False
-rnPred doc (HsPClass clas tys)
+rnPred doc (HsClassP clas tys)
= lookupOccRn clas `thenRn` \ clas_name ->
rnHsTypes doc tys `thenRn` \ tys' ->
- returnRn (HsPClass clas_name tys')
+ returnRn (HsClassP clas_name tys')
-rnPred doc (HsPIParam n ty)
+rnPred doc (HsIParam n ty)
= newIPName n `thenRn` \ name ->
rnHsType doc ty `thenRn` \ ty' ->
- returnRn (HsPIParam name ty')
+ returnRn (HsIParam name ty')
\end{code}
\begin{code}
= hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
forAllWarn doc ty tyvar
- = doptRn Opt_WarnUnusedMatches `thenRn` \ warn_unused -> case () of
- () | not warn_unused -> returnRn ()
- | otherwise
- -> getModeRn `thenRn` \ mode ->
- case mode of {
+ = ifOptRn Opt_WarnUnusedMatches $
+ getModeRn `thenRn` \ mode ->
+ case mode of {
#ifndef DEBUG
InterfaceMode -> returnRn () ; -- Don't warn of unused tyvars in interface files
-- unless DEBUG is on, in which case it is slightly
ptext SLIT("in the context:")],
nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
-naughtyCCallContextErr (HsPClass clas _)
+naughtyCCallContextErr (HsClassP clas _)
= sep [ptext SLIT("Can't use class") <+> quotes (ppr clas),
ptext SLIT("in a context")]
\end{code}
projects / ghc-hetmet.git / blobdiff