\section[RnSource]{Main pass of renamer}
\begin{code}
-module RnSource ( rnDecl, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl, rnSourceDecls,
- rnHsType, rnHsSigType, rnHsTypeFVs, rnHsSigTypeFVs
+module RnSource ( rnTyClDecl, rnIfaceRuleDecl, rnInstDecl, rnSourceDecls,
) where
#include "HsVersions.h"
import RnExpr
import HsSyn
-import HscTypes ( GlobalRdrEnv )
-import HsTypes ( hsTyVarNames, pprHsContext )
-import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, mkRdrNameWkr, elemRdrEnv )
-import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, RdrNameTyClDecl,
- extractRuleBndrsTyVars, extractHsTyRdrTyVars,
- extractHsCtxtRdrTyVars, extractGenericPatTyVars
+import HscTypes ( GlobalRdrEnv, AvailEnv )
+import RdrName ( RdrName, isRdrDataCon, elemRdrEnv )
+import RdrHsSyn ( RdrNameConDecl, RdrNameTyClDecl,
+ extractGenericPatTyVars
)
import RnHsSyn
import HsCore
+import RnTypes ( rnHsType, rnHsSigType, rnHsTypeFVs, rnContext )
+
import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, renameSigsFVs )
-import RnEnv ( lookupTopBndrRn, lookupOccRn, newIPName, lookupIfaceName,
+import RnEnv ( lookupTopBndrRn, lookupOccRn, lookupIfaceName,
lookupOrigNames, lookupSysBinder, newLocalsRn,
- bindLocalsFVRn,
- bindTyVarsRn, bindTyVars2Rn,
- bindTyVarsFV2Rn, extendTyVarEnvFVRn,
+ bindLocalsFVRn, bindPatSigTyVars,
+ bindTyVarsRn, extendTyVarEnvFVRn,
bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames,
checkDupOrQualNames, checkDupNames, mapFvRn
)
import RnMonad
import Class ( FunDep, DefMeth (..) )
-import Name ( Name, OccName, nameOccName, NamedThing(..) )
+import DataCon ( dataConId )
+import Name ( Name, NamedThing(..) )
import NameSet
-import PrelInfo ( derivableClassKeys, cCallishClassKeys )
-import PrelNames ( deRefStablePtr_RDR, newStablePtr_RDR,
- bindIO_RDR, returnIO_RDR
+import PrelInfo ( derivableClassKeys )
+import PrelNames ( deRefStablePtrName, newStablePtrName,
+ bindIOName, returnIOName
)
-import List ( partition, nub )
+import TysWiredIn ( tupleCon )
+import List ( partition )
import Outputable
import SrcLoc ( SrcLoc )
import CmdLineOpts ( DynFlag(..) )
-- Warn of unused for-all'd tyvars
import Unique ( Uniquable(..) )
-import ErrUtils ( Message )
-import CStrings ( isCLabelString )
-import ListSetOps ( removeDupsEq )
+import Maybes ( maybeToBool )
\end{code}
-@rnDecl@ `renames' declarations.
+@rnSourceDecl@ `renames' declarations.
It simultaneously performs dependency analysis and precedence parsing.
It also does the following error checks:
\begin{enumerate}
%*********************************************************
%* *
-\subsection{Value declarations}
+\subsection{Source code 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 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)
go fvs ds' (FixD _:ds) = go fvs ds' ds
go fvs ds' (DeprecD _:ds) = go fvs ds' ds
- go fvs ds' (d:ds) = rnDecl d `thenRn` \(d', fvs') ->
+ go fvs ds' (d:ds) = rnSourceDecl d `thenRn` \(d', fvs') ->
go (fvs `plusFV` fvs') (d':ds') ds
-\end{code}
-%*********************************************************
-%* *
-\subsection{Value declarations}
-%* *
-%*********************************************************
-
-\begin{code}
--- rnDecl does all the work
-rnDecl :: RdrNameHsDecl -> RnMS (RenamedHsDecl, FreeVars)
+rnSourceDecl :: RdrNameHsDecl -> RnMS (RenamedHsDecl, FreeVars)
-rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) ->
- returnRn (ValD new_binds, fvs)
+rnSourceDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) ->
+ returnRn (ValD new_binds, fvs)
-rnDecl (TyClD tycl_decl)
- = rnTyClDecl tycl_decl `thenRn` \ new_decl ->
- rnClassBinds tycl_decl new_decl `thenRn` \ (new_decl', fvs) ->
+rnSourceDecl (TyClD tycl_decl)
+ = rnTyClDecl tycl_decl `thenRn` \ new_decl ->
+ finishSourceTyClDecl tycl_decl new_decl `thenRn` \ (new_decl', fvs) ->
returnRn (TyClD new_decl', fvs `plusFV` tyClDeclFVs new_decl')
-rnDecl (InstD inst)
- = rnInstDecl inst `thenRn` \ new_inst ->
- rnInstBinds inst new_inst `thenRn` \ (new_inst', fvs) ->
+rnSourceDecl (InstD inst)
+ = rnInstDecl inst `thenRn` \ new_inst ->
+ finishSourceInstDecl inst new_inst `thenRn` \ (new_inst', fvs) ->
returnRn (InstD new_inst', fvs `plusFV` instDeclFVs new_inst')
-rnDecl (RuleD rule)
- | isIfaceRuleDecl rule
- = rnIfaceRuleDecl rule `thenRn` \ new_rule ->
- returnRn (RuleD new_rule, ruleDeclFVs new_rule)
- | otherwise
+rnSourceDecl (RuleD rule)
= rnHsRuleDecl rule `thenRn` \ (new_rule, fvs) ->
returnRn (RuleD new_rule, fvs)
-rnDecl (DefD (DefaultDecl tys src_loc))
+rnSourceDecl (ForD ford)
+ = rnHsForeignDecl ford `thenRn` \ (new_ford, fvs) ->
+ returnRn (ForD new_ford, fvs)
+
+rnSourceDecl (DefD (DefaultDecl tys src_loc))
= pushSrcLocRn src_loc $
mapFvRn (rnHsTypeFVs doc_str) tys `thenRn` \ (tys', fvs) ->
returnRn (DefD (DefaultDecl tys' src_loc), fvs)
where
- doc_str = text "a `default' declaration"
-
-rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
- = pushSrcLocRn src_loc $
- lookupOccRn name `thenRn` \ name' ->
- let
- extra_fvs FoExport
- | isDyn = lookupOrigNames [newStablePtr_RDR, deRefStablePtr_RDR,
- bindIO_RDR, returnIO_RDR]
- | otherwise =
- lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs ->
- returnRn (addOneFV fvs name')
- extra_fvs other = returnRn emptyFVs
- in
- checkRn (ok_ext_nm ext_nm) (badExtName ext_nm) `thenRn_`
+ doc_str = text "In a `default' declaration"
+\end{code}
- extra_fvs imp_exp `thenRn` \ fvs1 ->
- rnHsTypeFVs fo_decl_msg ty `thenRn` \ (ty', fvs2) ->
- returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc),
- fvs1 `plusFV` fvs2)
- where
- fo_decl_msg = ptext SLIT("The foreign declaration for") <+> ppr name
- isDyn = isDynamicExtName ext_nm
+%*********************************************************
+%* *
+\subsection{Foreign declarations}
+%* *
+%*********************************************************
- ok_ext_nm Dynamic = True
- ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb
- ok_ext_nm (ExtName nm Nothing) = isCLabelString nm
+\begin{code}
+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 isDeprec src_loc,
+ fvs `plusFV` extras spec)
+ where
+ extras (CImport _ _ _ _ CWrapper) = mkFVs [newStablePtrName,
+ deRefStablePtrName,
+ bindIOName, returnIOName]
+ extras _ = emptyFVs
+
+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 isDeprec src_loc,
+ mkFVs [bindIOName, returnIOName] `plusFV` fvs)
+
+fo_decl_msg name = ptext SLIT("The foreign declaration for") <+> ppr name
\end{code}
\begin{code}
rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc)
+ -- Used for both source and interface file decls
= pushSrcLocRn src_loc $
rnHsSigType (text "an instance decl") inst_ty `thenRn` \ inst_ty' ->
-- 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_rdr_name src_loc)
- = let
- meth_doc = text "the bindings in an instance declaration"
+-- 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
+ 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'
renameSigsFVs (okInstDclSig binder_set) uprags
) `thenRn` \ (uprags', prag_fvs) ->
- returnRn (InstDecl inst_ty mbinds' uprags' maybe_dfun_rdr_name src_loc,
+ returnRn (InstDecl inst_ty mbinds' uprags' maybe_dfun_name src_loc,
meth_fvs `plusFV` prag_fvs)
\end{code}
%*********************************************************
\begin{code}
-rnIfaceRuleDecl (IfaceRule rule_name vars fn args rhs src_loc)
+rnIfaceRuleDecl (IfaceRule rule_name act vars fn args rhs src_loc)
= pushSrcLocRn src_loc $
lookupOccRn fn `thenRn` \ fn' ->
rnCoreBndrs vars $ \ vars' ->
mapRn rnCoreExpr args `thenRn` \ args' ->
rnCoreExpr rhs `thenRn` \ rhs' ->
- returnRn (IfaceRule rule_name vars' fn' args' rhs' src_loc)
+ returnRn (IfaceRule rule_name act vars' fn' args' rhs' src_loc)
-rnHsRuleDecl (HsRule rule_name tvs vars lhs rhs src_loc)
- = ASSERT( null tvs )
- pushSrcLocRn src_loc $
+rnIfaceRuleDecl (IfaceRuleOut fn rule) -- Builtin rules come this way
+ = lookupOccRn fn `thenRn` \ fn' ->
+ returnRn (IfaceRuleOut fn' rule)
+
+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 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 "the transformation rule" <+> ptext rule_name
- sig_tvs = extractRuleBndrsTyVars vars
+ doc = text "In the transformation rule" <+> ptext rule_name
get_var (RuleBndr v) = v
get_var (RuleBndrSig v _) = v
mapRn rnIdInfo id_infos `thenRn` \ id_infos' ->
returnRn (IfaceSig {tcdName = name', tcdType = ty', tcdIdInfo = id_infos', tcdLoc = loc})
where
- doc_str = text "the interface signature for" <+> quotes (ppr name)
+ doc_str = text "In the interface signature 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,
- tcdDerivs = derivings, tcdLoc = src_loc, tcdSysNames = sys_names})
+ 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' ->
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 = derivs', tcdLoc = src_loc, tcdSysNames = sys_names'})
where
- data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
+ data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
con_names = map conDeclName 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 $
- doptRn Opt_GlasgowExts `thenRn` \ glaExts ->
lookupTopBndrRn name `thenRn` \ name' ->
bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
- rnHsType syn_doc (unquantify glaExts ty) `thenRn` \ ty' ->
+ rnHsType syn_doc ty `thenRn` \ ty' ->
returnRn (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc})
where
- syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
-
- -- For H98 we do *not* universally quantify on the RHS of a synonym
- -- Silently discard context... but the tyvars in the rest won't be in scope
- unquantify glaExts (HsForAllTy Nothing ctxt ty) | glaExts = ty
- unquantify glaExys ty = ty
+ syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname,
tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
tcdSysNames = names, tcdLoc = src_loc})
+ -- Used for both source and interface file decls
= pushSrcLocRn src_loc $
lookupTopBndrRn cname `thenRn` \ cname' ->
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
tcdFDs = fds', tcdSigs = non_ops' ++ sigs', tcdMeths = Nothing,
tcdSysNames = names', tcdLoc = src_loc})
where
- cls_doc = text "the declaration for class" <+> ppr cname
- sig_doc = text "the signatures for class" <+> ppr cname
+ 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 ->
returnRn (ClassOpSig op_name dm_stuff' new_ty locn)
-rnClassBinds :: RdrNameTyClDecl -> RenamedTyClDecl -> RnMS (RenamedTyClDecl, FreeVars)
- -- Rename the mbinds only; the rest is done already
-rnClassBinds (ClassDecl {tcdMeths = Nothing}) rn_cls_decl
- = returnRn (rn_cls_decl, emptyFVs) -- No meth binds; decl came from interface file
-
-rnClassBinds (ClassDecl {tcdMeths = Just mbinds}) -- Get mbinds from here
- rn_cls_decl@(ClassDecl {tcdTyVars = tyvars, tcdLoc = src_loc}) -- Everything else is here
+finishSourceTyClDecl :: RdrNameTyClDecl -> RenamedTyClDecl -> RnMS (RenamedTyClDecl, FreeVars)
+ -- Used for source file decls only
+ -- Renames the default-bindings of a class decl
+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
+ -- this is a source-code class declaration
= -- The newLocals call is tiresome: given a generic class decl
-- class C a where
-- op :: a -> a
-- 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
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 "the default-methods for class" <+> ppr (tcdName rn_cls_decl)
+ meth_doc = text "In 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
-\end{code}
-
-\begin{code}
conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
conDeclName (ConDecl n _ _ _ _ l) = (n,l)
rnConDetails doc locn details `thenRn` \ new_details ->
returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn)
where
- doc = text "the definition of data constructor" <+> quotes (ppr name)
+ doc = text "In the definition of data constructor" <+> quotes (ppr name)
rnConDetails doc locn (VanillaCon tys)
= mapRn (rnBangTy doc) tys `thenRn` \ new_tys ->
rnBangTy doc ty `thenRn` \ new_ty ->
returnRn (new_names, new_ty)
-rnBangTy doc (Banged ty)
+rnBangTy doc (BangType s ty)
= rnHsType doc ty `thenRn` \ new_ty ->
- returnRn (Banged new_ty)
-
-rnBangTy doc (Unbanged ty)
- = rnHsType doc ty `thenRn` \ new_ty ->
- returnRn (Unbanged new_ty)
-
-rnBangTy doc (Unpacked ty)
- = rnHsType doc ty `thenRn` \ new_ty ->
- returnRn (Unpacked new_ty)
+ returnRn (BangType s new_ty)
-- This data decl will parse OK
-- data T = a Int
%*********************************************************
\begin{code}
-rnHsTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
-rnHsTypeFVs doc_str ty
- = rnHsType doc_str ty `thenRn` \ ty' ->
- returnRn (ty', extractHsTyNames ty')
-
-rnHsSigTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
-rnHsSigTypeFVs doc_str ty
- = rnHsSigType doc_str ty `thenRn` \ ty' ->
- returnRn (ty', extractHsTyNames ty')
-
-rnHsSigType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType
- -- rnHsSigType is used for source-language type signatures,
- -- which use *implicit* universal quantification.
-rnHsSigType doc_str ty
- = rnHsType (text "the type signature for" <+> doc_str) ty
-
----------------------------------------
-rnHsType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType
-
-rnHsType doc (HsForAllTy Nothing ctxt ty)
- -- Implicit quantifiction in source code (no kinds on tyvars)
- -- Given the signature C => T we universally quantify
- -- over FV(T) \ {in-scope-tyvars}
- = getLocalNameEnv `thenRn` \ name_env ->
- let
- mentioned_in_tau = extractHsTyRdrTyVars ty
- mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
- mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt)
- forall_tyvars = filter (not . (`elemRdrEnv` name_env)) mentioned
- in
- rnForAll doc (map UserTyVar forall_tyvars) ctxt ty
-
-rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
- -- Explicit quantification.
- -- Check that the forall'd tyvars are actually
- -- mentioned in the type, and produce a warning if not
- = let
- mentioned_in_tau = extractHsTyRdrTyVars tau
- mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
- mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt)
- forall_tyvar_names = hsTyVarNames forall_tyvars
-
- -- Explicitly quantified but not mentioned in ctxt or tau
- warn_guys = filter (`notElem` mentioned) forall_tyvar_names
- in
- mapRn_ (forAllWarn doc tau) warn_guys `thenRn_`
- rnForAll doc forall_tyvars ctxt tau
-
-rnHsType doc (HsTyVar tyvar)
- = lookupOccRn tyvar `thenRn` \ tyvar' ->
- returnRn (HsTyVar tyvar')
-
-rnHsType doc (HsOpTy ty1 opname ty2)
- = lookupOccRn opname `thenRn` \ name' ->
- rnHsType doc ty1 `thenRn` \ ty1' ->
- rnHsType doc ty2 `thenRn` \ ty2' ->
- returnRn (HsOpTy ty1' name' ty2')
-
-rnHsType doc (HsNumTy i)
- | i == 1 = returnRn (HsNumTy i)
- | otherwise = failWithRn (HsNumTy i)
- (ptext SLIT("Only unit numeric type pattern is valid"))
-
-rnHsType doc (HsFunTy ty1 ty2)
- = rnHsType doc ty1 `thenRn` \ ty1' ->
- -- Might find a for-all as the arg of a function type
- rnHsType doc ty2 `thenRn` \ ty2' ->
- -- Or as the result. This happens when reading Prelude.hi
- -- when we find return :: forall m. Monad m -> forall a. a -> m a
- returnRn (HsFunTy ty1' ty2')
-
-rnHsType doc (HsListTy ty)
- = rnHsType doc ty `thenRn` \ ty' ->
- returnRn (HsListTy ty')
-
--- Unboxed tuples are allowed to have poly-typed arguments. These
--- sometimes crop up as a result of CPR worker-wrappering dictionaries.
-rnHsType doc (HsTupleTy (HsTupCon _ boxity) tys)
- -- Don't do lookupOccRn, because this is built-in syntax
- -- so it doesn't need to be in scope
- = mapRn (rnHsType doc) tys `thenRn` \ tys' ->
- returnRn (HsTupleTy (HsTupCon n' boxity) tys')
- where
- n' = tupleTyCon_name boxity (length tys)
-
-
-rnHsType doc (HsAppTy ty1 ty2)
- = rnHsType doc ty1 `thenRn` \ ty1' ->
- rnHsType doc ty2 `thenRn` \ ty2' ->
- returnRn (HsAppTy ty1' ty2')
-
-rnHsType doc (HsPredTy pred)
- = rnPred doc pred `thenRn` \ pred' ->
- returnRn (HsPredTy pred')
-
-rnHsTypes doc tys = mapRn (rnHsType doc) tys
-\end{code}
-
-\begin{code}
--- We use lookupOcc here because this is interface file only stuff
--- and we need the workers...
-rnHsTupCon (HsTupCon n boxity)
- = lookupOccRn n `thenRn` \ n' ->
- returnRn (HsTupCon n' boxity)
-
-rnHsTupConWkr (HsTupCon n boxity)
- -- Tuple construtors are for the *worker* of the tuple
- -- Going direct saves needless messing about
- = lookupOccRn (mkRdrNameWkr n) `thenRn` \ n' ->
- returnRn (HsTupCon n' boxity)
-\end{code}
-
-\begin{code}
-rnForAll doc forall_tyvars ctxt ty
- = bindTyVarsRn doc forall_tyvars $ \ new_tyvars ->
- rnContext doc ctxt `thenRn` \ new_ctxt ->
- rnHsType doc ty `thenRn` \ new_ty ->
- returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty)
-\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_`
- returnRn theta
- where
- --Someone discovered that @CCallable@ and @CReturnable@
- -- could be used in contexts such as:
- -- foo :: CCallable a => a -> PrimIO Int
- -- Doing this utterly wrecks the whole point of introducing these
- -- classes so we specifically check that this isn't being done.
- rn_pred pred = rnPred doc pred `thenRn` \ pred'->
- checkRn (not (bad_pred pred'))
- (naughtyCCallContextErr pred') `thenRn_`
- returnRn pred'
-
- bad_pred (HsPClass clas _) = getUnique clas `elem` cCallishClassKeys
- bad_pred other = False
-
-
-rnPred doc (HsPClass clas tys)
- = lookupOccRn clas `thenRn` \ clas_name ->
- rnHsTypes doc tys `thenRn` \ tys' ->
- returnRn (HsPClass clas_name tys')
-
-rnPred doc (HsPIParam n ty)
- = newIPName n `thenRn` \ name ->
- rnHsType doc ty `thenRn` \ ty' ->
- returnRn (HsPIParam name ty')
-\end{code}
-
-\begin{code}
rnFds :: SDoc -> [FunDep RdrName] -> RnMS [FunDep Name]
rnFds doc fds
%*********************************************************
\begin{code}
-rnIdInfo (HsWorker worker)
+rnIdInfo (HsWorker worker arity)
= lookupOccRn worker `thenRn` \ worker' ->
- returnRn (HsWorker worker')
+ returnRn (HsWorker worker' arity)
rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ expr' ->
returnRn (HsUnfold inline expr')
rnIdInfo (HsStrictness str) = returnRn (HsStrictness str)
rnIdInfo (HsArity arity) = returnRn (HsArity arity)
rnIdInfo HsNoCafRefs = returnRn HsNoCafRefs
-rnIdInfo HsCprInfo = returnRn HsCprInfo
\end{code}
@UfCore@ expressions.
= rnHsType (text "litlit") ty `thenRn` \ ty' ->
returnRn (UfLitLit l ty')
-rnCoreExpr (UfCCall cc ty)
+rnCoreExpr (UfFCall cc ty)
= rnHsType (text "ccall") ty `thenRn` \ ty' ->
- returnRn (UfCCall cc ty')
+ returnRn (UfFCall cc ty')
-rnCoreExpr (UfTuple con args)
- = rnHsTupConWkr con `thenRn` \ con' ->
- mapRn rnCoreExpr args `thenRn` \ args' ->
- returnRn (UfTuple con' args')
+rnCoreExpr (UfTuple (HsTupCon _ boxity arity) args)
+ = mapRn rnCoreExpr args `thenRn` \ args' ->
+ returnRn (UfTuple (HsTupCon tup_name boxity arity) args')
+ where
+ tup_name = getName (dataConId (tupleCon boxity arity))
+ -- Get the *worker* name and use that
rnCoreExpr (UfApp fun arg)
= rnCoreExpr fun `thenRn` \ fun' ->
\begin{code}
rnCoreAlt (con, bndrs, rhs)
- = rnUfCon con bndrs `thenRn` \ con' ->
+ = rnUfCon con `thenRn` \ con' ->
bindCoreLocalsRn bndrs $ \ bndrs' ->
rnCoreExpr rhs `thenRn` \ rhs' ->
returnRn (con', bndrs', rhs')
rnNote UfInlineMe = returnRn UfInlineMe
-rnUfCon UfDefault _
+rnUfCon UfDefault
= returnRn UfDefault
-rnUfCon (UfTupleAlt tup_con) bndrs
- = rnHsTupCon tup_con `thenRn` \ (HsTupCon con' _) ->
- returnRn (UfDataAlt con')
- -- Makes the type checker a little easier
+rnUfCon (UfTupleAlt (HsTupCon _ boxity arity))
+ = returnRn (UfTupleAlt (HsTupCon tup_name boxity arity))
+ where
+ tup_name = getName (tupleCon boxity arity)
-rnUfCon (UfDataAlt con) _
+rnUfCon (UfDataAlt con)
= lookupOccRn con `thenRn` \ con' ->
returnRn (UfDataAlt con')
-rnUfCon (UfLitAlt lit) _
+rnUfCon (UfLitAlt lit)
= returnRn (UfLitAlt lit)
-rnUfCon (UfLitLitAlt lit ty) _
+rnUfCon (UfLitLitAlt lit ty)
= rnHsType (text "litlit") ty `thenRn` \ ty' ->
returnRn (UfLitLitAlt lit ty')
\end{code}
validRuleLhs foralls lhs
= check lhs
where
+ check (OpApp _ op _ _) = check op
check (HsApp e1 e2) = check e1
check (HsVar v) | v `notElem` foralls = True
check other = False
%*********************************************************
\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)]
-forAllWarn doc ty tyvar
- = doptRn Opt_WarnUnusedMatches `thenRn` \ warn_unused -> case () of
- () | not warn_unused -> returnRn ()
- | otherwise
- -> 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
- -- informative. They can arise from mkRhsTyLam,
-#endif -- leading to (say) f :: forall a b. [b] -> [b]
- other ->
- addWarnRn (
- sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
- nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
- $$
- (ptext SLIT("In") <+> doc)
- )
- }
-
badRuleLhsErr name lhs
= sep [ptext SLIT("Rule") <+> ptext 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") <+> ptext name <> colon,
+ = sep [ptext SLIT("Rule") <+> doubleQuotes (ptext name) <> colon,
ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
ptext SLIT("does not appear on left hand side")]
-badExtName :: ExtName -> Message
-badExtName ext_nm
- = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")]
-
-dupClassAssertWarn ctxt (assertion : dups)
- = sep [hsep [ptext SLIT("Duplicate class assertion"),
- quotes (ppr assertion),
- ptext SLIT("in the context:")],
- nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
-
-naughtyCCallContextErr (HsPClass clas _)
- = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas),
- ptext SLIT("in a context")]
+emptyConDeclsErr tycon
+ = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
+ nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))]
\end{code}
projects / ghc-hetmet.git / blobdiff