X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnSource.lhs;h=6bb8bc0fe6fe1d813b8633eab8e1461f2835fe7f;hb=47108330f6f832dd82aba3d125a1ad114f4a45e7;hp=c60d850105495a64fb76b021e369f39bf0b03a39;hpb=f23ba2b294429ccbdeb80f0344ec08f6abf61bb7;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index c60d850..6bb8bc0 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -4,7 +4,7 @@ \section[RnSource]{Main pass of renamer} \begin{code} -module RnSource ( rnDecl, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl, rnSourceDecls, +module RnSource ( rnTyClDecl, rnIfaceRuleDecl, rnInstDecl, rnSourceDecls, rnHsType, rnHsSigType, rnHsTypeFVs, rnHsSigTypeFVs ) where @@ -14,7 +14,7 @@ import RnExpr import HsSyn import HscTypes ( GlobalRdrEnv ) import HsTypes ( hsTyVarNames, pprHsContext ) -import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, mkRdrNameWkr, elemRdrEnv ) +import RdrName ( RdrName, isRdrDataCon, elemRdrEnv ) import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, RdrNameTyClDecl, extractRuleBndrsTyVars, extractHsTyRdrTyVars, extractHsCtxtRdrTyVars, extractGenericPatTyVars @@ -34,24 +34,25 @@ import RnEnv ( lookupTopBndrRn, lookupOccRn, newIPName, lookupIfaceName, 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 TysWiredIn ( tupleCon ) import List ( partition, nub ) 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 Maybes ( maybeToBool ) import ListSetOps ( removeDupsEq ) \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} @@ -69,7 +70,7 @@ Checks the @(..)@ etc constraints in the export list. %********************************************************* %* * -\subsection{Value declarations} +\subsection{Source code declarations} %* * %********************************************************* @@ -80,81 +81,73 @@ rnSourceDecls :: GlobalRdrEnv -> LocalFixityEnv -- 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) + = initRnMS gbl_env 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" + doc_str = text "In a `default' declaration" +\end{code} -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_` - extra_fvs imp_exp `thenRn` \ fvs1 -> +%********************************************************* +%* * +\subsection{Foreign declarations} +%* * +%********************************************************* + +\begin{code} +rnHsForeignDecl (ForeignImport name ty spec src_loc) + = pushSrcLocRn src_loc $ + lookupOccRn name `thenRn` \ name' -> + rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs1) -> + lookupOrigNames (extras spec) `thenRn` \ fvs2 -> + returnRn (ForeignImport name' ty' spec src_loc, fvs1 `plusFV` fvs2) + where + extras (CDynImport _) = [newStablePtr_RDR, deRefStablePtr_RDR, bindIO_RDR, returnIO_RDR] + extras other = [] - 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 +rnHsForeignDecl (ForeignExport name ty spec src_loc) + = pushSrcLocRn src_loc $ + lookupOccRn name `thenRn` \ name' -> + rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs1) -> + lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs2 -> + returnRn (ForeignExport name' ty' spec src_loc, fvs1 `plusFV` fvs2) - ok_ext_nm Dynamic = True - ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb - ok_ext_nm (ExtName nm Nothing) = isCLabelString nm +fo_decl_msg name = ptext SLIT("The foreign declaration for") <+> ppr name \end{code} @@ -166,6 +159,7 @@ rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc)) \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' -> @@ -178,11 +172,13 @@ rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc) -- 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 @@ -212,7 +208,7 @@ rnInstBinds (InstDecl _ mbinds uprags _ _ ) 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} @@ -250,7 +246,7 @@ rnHsRuleDecl (HsRule rule_name tvs vars lhs rhs src_loc) returnRn (HsRule rule_name sig_tvs' vars' lhs' rhs' src_loc, fv_vars `plusFV` fv_lhs `plusFV` fv_rhs) where - doc = text "the transformation rule" <+> ptext rule_name + doc = text "In the transformation rule" <+> ptext rule_name sig_tvs = extractRuleBndrsTyVars vars get_var (RuleBndr v) = v @@ -282,47 +278,68 @@ and then go over it again to rename the tyvars! However, we can also do some scoping checks at the same time. \begin{code} -rnTyClDecl (IfaceSig name ty id_infos loc) +rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc = loc}) = pushSrcLocRn loc $ lookupTopBndrRn name `thenRn` \ name' -> rnHsType doc_str ty `thenRn` \ ty' -> mapRn rnIdInfo id_infos `thenRn` \ id_infos' -> - returnRn (IfaceSig name' ty' id_infos' loc) + 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 = spec, tcdLoc = loc}) + = pushSrcLocRn loc $ + lookupTopBndrRn name `thenRn` \ name' -> + returnRn (ForeignType {tcdName = name', tcdFoType = spec, tcdLoc = loc}) -rnTyClDecl (TyData new_or_data context tycon tyvars condecls nconstrs derivings src_loc gen_name1 gen_name2) +rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon, + tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = nconstrs, + tcdLoc = src_loc, tcdSysNames = sys_names}) = pushSrcLocRn src_loc $ lookupTopBndrRn tycon `thenRn` \ tycon' -> bindTyVarsRn data_doc tyvars $ \ tyvars' -> rnContext data_doc context `thenRn` \ context' -> 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' -> - lookupSysBinder gen_name1 `thenRn` \ name1' -> - lookupSysBinder gen_name2 `thenRn` \ name2' -> - rnDerivs derivings `thenRn` \ derivings' -> - returnRn (TyData new_or_data context' tycon' tyvars' condecls' nconstrs - derivings' src_loc name1' name2') + 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'}) 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 -rnTyClDecl (TySynonym name tyvars ty src_loc) +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' -> - returnRn (TySynonym name' tyvars' ty' src_loc) + returnRn (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc}) where - syn_doc = text "the declaration for type synonym" <+> quotes (ppr name) + syn_doc = text "In 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 + -- 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 context cname tyvars fds sigs mbinds names src_loc) +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' -> @@ -360,12 +377,14 @@ rnTyClDecl (ClassDecl context cname tyvars fds sigs mbinds names src_loc) -- The renamer *could* check this for class decls, but can't -- for instance decls. - returnRn (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') EmptyMonoBinds names' src_loc) + returnRn (ClassDecl { tcdCtxt = context', tcdName = cname', tcdTyVars = tyvars', + 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 maybe_dm_stuff ty locn) +rnClassOp clas clas_tyvars clas_fds sig@(ClassOpSig op dm_stuff ty locn) = pushSrcLocRn locn $ lookupTopBndrRn op `thenRn` \ op_name -> @@ -373,28 +392,36 @@ rnClassOp clas clas_tyvars clas_fds sig@(ClassOpSig op maybe_dm_stuff ty locn) rnHsSigType (quotes (ppr op)) ty `thenRn` \ new_ty -> -- Make the default-method name - (case maybe_dm_stuff of - Nothing -> returnRn Nothing -- Source-file class decl - - Just (DefMeth dm_rdr_name) + (case dm_stuff of + DefMeth dm_rdr_name -> -- Imported class that has a default method decl -- See comments with tname, snames, above lookupSysBinder dm_rdr_name `thenRn` \ dm_name -> - returnRn (Just (DefMeth dm_name)) + returnRn (DefMeth dm_name) -- An imported class decl for a class decl that had an explicit default -- method, mentions, rather than defines, -- the default method, so we must arrange to pull it in - Just GenDefMeth -> returnRn (Just GenDefMeth) - Just NoDefMeth -> returnRn (Just NoDefMeth) - ) `thenRn` \ maybe_dm_stuff' -> + GenDefMeth -> returnRn GenDefMeth + NoDefMeth -> returnRn NoDefMeth + ) `thenRn` \ dm_stuff' -> - returnRn (ClassOpSig op_name maybe_dm_stuff' new_ty locn) - -rnClassBinds :: RdrNameTyClDecl -> RenamedTyClDecl -> RnMS (RenamedTyClDecl, FreeVars) - -- Rename the mbinds only; the rest is done already -rnClassBinds (ClassDecl _ _ _ _ _ mbinds _ _ ) -- Get mbinds from here - (ClassDecl context cname tyvars fds sigs _ names src_loc) -- Everything else is here + returnRn (ClassOpSig op_name dm_stuff' new_ty locn) + +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 {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 @@ -404,6 +431,7 @@ rnClassBinds (ClassDecl _ _ _ _ _ mbinds _ _ ) -- G -- 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 @@ -414,12 +442,12 @@ rnClassBinds (ClassDecl _ _ _ _ _ mbinds _ _ ) -- G 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) -> - returnRn (ClassDecl context cname tyvars fds sigs mbinds' names src_loc, meth_fvs) + returnRn (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs) where - meth_doc = text "the default-methods for class" <+> ppr cname + meth_doc = text "In the default-methods for class" <+> ppr (tcdName rn_cls_decl) -rnClassBinds _ tycl_decl = returnRn (tycl_decl, emptyFVs) - -- Not a class declaration +finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs) + -- Not a class or data type declaration \end{code} @@ -430,19 +458,12 @@ rnClassBinds _ tycl_decl = returnRn (tycl_decl, emptyFVs) %********************************************************* \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} @@ -463,7 +484,7 @@ rnConDecl (ConDecl name wkr tvs cxt details locn) 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 -> @@ -486,17 +507,9 @@ rnField doc (names, ty) 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 @@ -535,7 +548,7 @@ 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 (text "In the type signature for" <+> doc_str) ty --------------------------------------- rnHsType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType @@ -598,13 +611,13 @@ rnHsType doc (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) +rnHsType doc (HsTupleTy (HsTupCon _ boxity arity) 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') + returnRn (HsTupleTy (HsTupCon tup_name boxity arity) tys') where - n' = tupleTyCon_name boxity (length tys) + tup_name = tupleTyCon_name boxity arity rnHsType doc (HsAppTy ty1 ty2) @@ -620,20 +633,6 @@ 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 -> @@ -645,13 +644,17 @@ rnForAll doc forall_tyvars ctxt ty 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@ @@ -664,19 +667,19 @@ rnContext doc ctxt (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} @@ -701,9 +704,9 @@ rnHsTyvar doc tyvar = lookupOccRn tyvar %********************************************************* \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') @@ -731,14 +734,16 @@ rnCoreExpr (UfLitLit l ty) = 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' -> @@ -796,7 +801,7 @@ rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b $ \ name' -> \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') @@ -810,22 +815,22 @@ rnNote UfInlineCall = returnRn UfInlineCall 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} @@ -844,6 +849,7 @@ not one of the @forall@'d variables. 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 @@ -864,11 +870,9 @@ 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 { + = 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 @@ -879,7 +883,7 @@ forAllWarn doc ty tyvar 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) + doc ) } @@ -890,21 +894,20 @@ badRuleLhsErr name 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 _) +naughtyCCallContextErr (HsClassP 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}