X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnSource.lhs;h=b5386a3d1ab543975eaed852020c52c31e23cb12;hb=0299e1a135c5805e09ed8e2271b3b17fc8a04869;hp=4d774dd9f440da854489946712812ce6dae99ab5;hpb=b117679aefcfabd2f8b34a9f495ede8508d7f88d;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 4d774dd..b5386a3 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -1,226 +1,152 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[RnSource]{Main pass of renamer} \begin{code} -module RnSource ( rnDecl, rnHsType, rnHsSigType ) where +module RnSource ( rnTyClDecl, rnIfaceRuleDecl, rnInstDecl, rnSourceDecls, + ) where #include "HsVersions.h" import RnExpr import HsSyn -import HsDecls ( HsIdInfo(..), HsStrictnessInfo(..) ) -import HsPragmas -import HsTypes ( getTyVarName, pprClassAssertion, cmpHsTypes ) -import RdrHsSyn +import HscTypes ( GlobalRdrEnv, AvailEnv ) +import RdrName ( RdrName, isRdrDataCon, elemRdrEnv ) +import RdrHsSyn ( RdrNameConDecl, RdrNameTyClDecl, + extractGenericPatTyVars + ) import RnHsSyn import HsCore -import CmdLineOpts ( opt_IgnoreIfacePragmas ) -import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs ) -import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, lookupImplicitOccRn, bindLocalsRn, - newDfunName, checkDupOrQualNames, checkDupNames, - newLocallyDefinedGlobalName, newImportedGlobalName, ifaceFlavour, - listType_RDR, tupleType_RDR ) +import RnTypes ( rnHsType, rnHsSigType, rnHsTypeFVs, rnContext ) + +import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, renameSigsFVs ) +import RnEnv ( lookupTopBndrRn, lookupOccRn, lookupIfaceName, + lookupOrigNames, lookupSysBinder, newLocalsRn, + bindLocalsFVRn, bindPatSigTyVars, + bindTyVarsRn, extendTyVarEnvFVRn, + bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames, + checkDupOrQualNames, checkDupNames, mapFvRn + ) import RnMonad -import Name ( Name, OccName(..), occNameString, prefixOccName, - ExportFlag(..), Provenance(..), NameSet, mkNameSet, - elemNameSet, nameOccName, NamedThing(..) +import Class ( FunDep, DefMeth (..) ) +import DataCon ( dataConId ) +import Name ( Name, NamedThing(..) ) +import NameSet +import PrelInfo ( derivableClassKeys ) +import PrelNames ( deRefStablePtrName, newStablePtrName, + bindIOName, returnIOName ) -import BasicTypes ( TopLevelFlag(..) ) -import FiniteMap ( lookupFM ) -import Id ( GenId{-instance NamedThing-} ) -import IdInfo ( FBTypeInfo, ArgUsageInfo ) -import Lex ( isLexCon ) -import PrelInfo ( derivingOccurrences, evalClass_RDR, numClass_RDR, allClass_NAME ) -import Maybes ( maybeToBool ) -import Bag ( bagToList ) +import TysWiredIn ( tupleCon ) +import List ( partition ) import Outputable import SrcLoc ( SrcLoc ) -import Unique ( Unique ) -import UniqSet ( UniqSet ) -import UniqFM ( UniqFM, lookupUFM ) -import Util -import List ( partition, nub ) +import CmdLineOpts ( DynFlag(..) ) + -- Warn of unused for-all'd tyvars +import Unique ( Uniquable(..) ) +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} \item Checks that tyvars are used properly. This includes checking for undefined tyvars, and tyvars in contexts that are ambiguous. +(Some of this checking has now been moved to module @TcMonoType@, +since we don't have functional dependency information at this point.) \item Checks that all variable occurences are defined. \item -Checks the (..) etc constraints in the export list. +Checks the @(..)@ etc constraints in the export list. \end{enumerate} %********************************************************* %* * -\subsection{Value declarations} +\subsection{Source code declarations} %* * %********************************************************* \begin{code} -rnDecl :: RdrNameHsDecl -> RnMS s RenamedHsDecl +rnSourceDecls :: GlobalRdrEnv -> AvailEnv -> LocalFixityEnv + -> [RdrNameHsDecl] + -> RnMG ([RenamedHsDecl], FreeVars) + -- The decls get reversed, but that's ok -rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ new_binds -> - returnRn (ValD new_binds) +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) = rnSourceDecl d `thenRn` \(d', fvs') -> + go (fvs `plusFV` fvs') (d':ds') ds -rnDecl (SigD (IfaceSig name ty id_infos loc)) - = pushSrcLocRn loc $ - lookupBndrRn name `thenRn` \ name' -> - rnHsType ty `thenRn` \ ty' -> - - -- Get the pragma info (if any). - getModeRn `thenRn` \ (InterfaceMode _ print_unqual) -> - setModeRn (InterfaceMode Optional print_unqual) $ - -- In all the rest of the signature we read in optional mode, - -- so that (a) we don't die - mapRn rnIdInfo id_infos `thenRn` \ id_infos' -> - returnRn (SigD (IfaceSig name' ty' id_infos' loc)) -\end{code} +rnSourceDecl :: RdrNameHsDecl -> RnMS (RenamedHsDecl, FreeVars) -%********************************************************* -%* * -\subsection{Type declarations} -%* * -%********************************************************* +rnSourceDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) -> + returnRn (ValD new_binds, fvs) -@rnTyDecl@ uses the `global name function' to create a new type -declaration in which local names have been replaced by their original -names, reporting any unknown names. +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') -Renaming type variables is a pain. Because they now contain uniques, -it is necessary to pass in an association list which maps a parsed -tyvar to its Name representation. In some cases (type signatures of -values), it is even necessary to go over the type first in order to -get the set of tyvars used by it, make an assoc list, and then go over -it again to rename the tyvars! However, we can also do some scoping -checks at the same time. +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') -\begin{code} -rnDecl (TyD (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)) - = pushSrcLocRn src_loc $ - lookupBndrRn tycon `thenRn` \ tycon' -> - bindTyVarsRn data_doc tyvars $ \ tyvars' -> - rnContext context `thenRn` \ context' -> - checkDupOrQualNames data_doc con_names `thenRn_` - mapRn rnConDecl condecls `thenRn` \ condecls' -> - rnDerivs derivings `thenRn` \ derivings' -> - ASSERT(isNoDataPragmas pragmas) - returnRn (TyD (TyData new_or_data context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc)) - where - data_doc = text "the data type declaration for" <+> ppr tycon - con_names = map conDeclName condecls +rnSourceDecl (RuleD rule) + = rnHsRuleDecl rule `thenRn` \ (new_rule, fvs) -> + returnRn (RuleD new_rule, fvs) -rnDecl (TyD (TySynonym name tyvars ty 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 $ - lookupBndrRn name `thenRn` \ name' -> - bindTyVarsRn syn_doc tyvars $ \ tyvars' -> - rnHsType ty `thenRn` \ ty' -> - returnRn (TyD (TySynonym name' tyvars' ty' src_loc)) + mapFvRn (rnHsTypeFVs doc_str) tys `thenRn` \ (tys', fvs) -> + returnRn (DefD (DefaultDecl tys' src_loc), fvs) where - syn_doc = text "the declaration for type synonym" <+> ppr name + doc_str = text "In a `default' declaration" \end{code} + %********************************************************* %* * -\subsection{Class declarations} +\subsection{Foreign declarations} %* * %********************************************************* -@rnClassDecl@ uses the `global name function' to create a new -class declaration in which local names have been replaced by their -original names, reporting any unknown names. - \begin{code} -rnDecl (ClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname src_loc)) - = pushSrcLocRn src_loc $ - - lookupBndrRn cname `thenRn` \ cname' -> - lookupBndrRn tname `thenRn` \ tname' -> - lookupBndrRn dname `thenRn` \ dname' -> - - bindTyVarsRn cls_doc tyvars ( \ tyvars' -> - rnContext context `thenRn` \ context' -> - - -- Check the signatures - let - clas_tyvar_names = map getTyVarName tyvars' - in - checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_` - mapRn (rn_op cname' clas_tyvar_names) sigs `thenRn` \ sigs' -> - returnRn (tyvars', context', sigs') - ) `thenRn` \ (tyvars', context', sigs') -> - - -- Check the methods - checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_` - rnMethodBinds mbinds `thenRn` \ mbinds' -> - - -- Typechecker is responsible for checking that we only - -- give default-method bindings for things in this class. - -- The renamer *could* check this for class decls, but can't - -- for instance decls. - - ASSERT(isNoClassPragmas pragmas) - returnRn (ClD (ClassDecl context' cname' tyvars' sigs' mbinds' NoClassPragmas tname' dname' 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 isDeprec src_loc, + fvs `plusFV` extras spec) where - cls_doc = text "the declaration for class" <+> ppr cname - sig_doc = text "the signatures for class" <+> ppr cname - meth_doc = text "the default-methods for class" <+> ppr cname - - sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs] - meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds) - meth_rdr_names = map fst meth_rdr_names_w_locs - - rn_op clas clas_tyvars sig@(ClassOpSig op maybe_dm ty locn) - = pushSrcLocRn locn $ - lookupBndrRn op `thenRn` \ op_name -> - rnHsSigType (quotes (ppr op)) ty `thenRn` \ new_ty -> - - -- Make the default-method name - let - dm_occ = prefixOccName SLIT("$m") (rdrNameOcc op) - in - getModuleRn `thenRn` \ mod_name -> - getModeRn `thenRn` \ mode -> - (case (mode, maybe_dm) of - (SourceMode, _) | op `elem` meth_rdr_names - -> -- There's an explicit method decl - newLocallyDefinedGlobalName mod_name dm_occ - (\_ -> Exported) locn `thenRn` \ dm_name -> - returnRn (Just dm_name) - - (InterfaceMode _ _, Just _) - -> -- Imported class that has a default method decl - newImportedGlobalName mod_name dm_occ (ifaceFlavour clas) `thenRn` \ dm_name -> - addOccurrenceName dm_name `thenRn_` - returnRn (Just dm_name) - - other -> returnRn Nothing - ) `thenRn` \ maybe_dm_name -> - - -- Check that each class tyvar appears in op_ty - let - (ctxt, op_ty) = case new_ty of - HsForAllTy tvs ctxt op_ty -> (ctxt, op_ty) - other -> ([], new_ty) - ctxt_fvs = extractHsCtxtTyNames ctxt -- Includes tycons/classes but we - op_ty_fvs = extractHsTyNames op_ty -- don't care about that - - check_in_op_ty clas_tyvar = checkRn (clas_tyvar `elemNameSet` op_ty_fvs) - (classTyVarNotInOpTyErr clas_tyvar sig) - in - mapRn check_in_op_ty clas_tyvars `thenRn_` - - returnRn (ClassOpSig op_name maybe_dm_name new_ty locn) + 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} @@ -231,151 +157,339 @@ rnDecl (ClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname src_ %********************************************************* \begin{code} -rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc)) +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' -> + (case maybe_dfun_rdr_name of + Nothing -> returnRn Nothing + Just dfun_rdr_name -> lookupIfaceName dfun_rdr_name `thenRn` \ dfun_name -> + returnRn (Just dfun_name) + ) `thenRn` \ maybe_dfun_name -> + + -- The typechecker checks that all the bindings are for the right class. + returnRn (InstDecl inst_ty' EmptyMonoBinds [] 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 + meth_doc = text "In the bindings in an instance declaration" + meth_names = collectLocatedMonoBinders mbinds + (inst_tyvars, (cls,_)) = getHsInstHead inst_ty + -- (Slightly strangely) the forall-d tyvars scope over + -- the method bindings too + in -- Rename the bindings -- NB meth_names can be qualified! checkDupNames meth_doc meth_names `thenRn_` - rnMethodBinds mbinds `thenRn` \ mbinds' -> + extendTyVarEnvFVRn (map hsTyVarName inst_tyvars) ( + rnMethodBinds cls [] mbinds + ) `thenRn` \ (mbinds', meth_fvs) -> let - binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds'))) - in - renameSigs NotTopLevel True binders uprags `thenRn` \ new_uprags -> - - let - -- We use the class name and the name of the first - -- type constructor the class is applied to. - (cl_nm, tycon_nm) = mkDictPrefix inst_ty' - - mkDictPrefix (MonoDictTy cl tys) = - case tys of - [] -> (c_nm, nilOccName ) - (ty:_) -> (c_nm, getInstHeadTy ty) - where - c_nm = nameOccName (getName cl) - - mkDictPrefix (HsPreForAllTy _ ty) = mkDictPrefix ty - mkDictPrefix (HsForAllTy _ _ ty) = mkDictPrefix ty -- can this - mkDictPrefix _ = (nilOccName, nilOccName) - - getInstHeadTy t - = case t of - MonoTyVar tv -> nameOccName (getName tv) - MonoTyApp t _ -> getInstHeadTy t - _ -> nilOccName - -- I cannot see how the rest of HsType constructors - -- can occur, but this isn't really a failure condition, - -- so we return silently. - - nilOccName = (VarOcc _NIL_) -- ToDo: add OccName constructor fun for this. + binders = collectMonoBinders mbinds' + binder_set = mkNameSet binders in - newDfunName cl_nm tycon_nm maybe_dfun src_loc `thenRn` \ dfun_name -> - addOccurrenceName dfun_name `thenRn_` - -- The dfun is not optional, because we use its version number - -- to identify the version of the instance declaration - - -- The typechecker checks that all the bindings are for the right class. - returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags (Just dfun_name) src_loc)) - where - meth_doc = text "the bindings in an instance declaration" - meth_names = bagToList (collectMonoBinders mbinds) + -- Rename the prags and signatures. + -- Note that the type variables are not in scope here, + -- so that instance Eq a => Eq (T a) where + -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-} + -- works OK. + -- + -- But the (unqualified) method names are in scope + bindLocalNames binders ( + renameSigsFVs (okInstDclSig binder_set) uprags + ) `thenRn` \ (uprags', prag_fvs) -> + + returnRn (InstDecl inst_ty mbinds' uprags' maybe_dfun_name src_loc, + meth_fvs `plusFV` prag_fvs) \end{code} %********************************************************* %* * -\subsection{Default declarations} +\subsection{Rules} %* * %********************************************************* \begin{code} -rnDecl (DefD (DefaultDecl tys src_loc)) - = pushSrcLocRn src_loc $ - mapRn rnHsType tys `thenRn` \ tys' -> - lookupImplicitOccRn numClass_RDR `thenRn_` - returnRn (DefD (DefaultDecl tys' 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 act vars' fn' args' rhs' 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) $ + + bindLocalsFVRn doc (map get_var vars) $ \ ids -> + mapFvRn rn_var (vars `zip` ids) `thenRn` \ (vars', fv_vars) -> + + rnExpr lhs `thenRn` \ (lhs', fv_lhs) -> + rnExpr rhs `thenRn` \ (rhs', fv_rhs) -> + checkRn (validRuleLhs ids lhs') + (badRuleLhsErr rule_name lhs') `thenRn_` + let + bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)] + in + mapRn (addErrRn . badRuleVar rule_name) bad_vars `thenRn_` + 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 + + get_var (RuleBndr v) = v + get_var (RuleBndrSig v _) = v + + rn_var (RuleBndr v, id) = returnRn (RuleBndr id, emptyFVs) + rn_var (RuleBndrSig v t, id) = rnHsTypeFVs doc t `thenRn` \ (t', fvs) -> + returnRn (RuleBndrSig id t', fvs) \end{code} + %********************************************************* %* * -\subsection{Support code for type/data declarations} +\subsection{Type, class and iface sig declarations} %* * %********************************************************* +@rnTyDecl@ uses the `global name function' to create a new type +declaration in which local names have been replaced by their original +names, reporting any unknown names. + +Renaming type variables is a pain. Because they now contain uniques, +it is necessary to pass in an association list which maps a parsed +tyvar to its @Name@ representation. +In some cases (type signatures of values), +it is even necessary to go over the type first +in order to get the set of tyvars used by it, make an assoc list, +and then go over it again to rename the tyvars! +However, we can also do some scoping checks at the same time. + \begin{code} -rnDerivs :: Maybe [RdrName] -> RnMS s (Maybe [Name]) +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 {tcdName = name', tcdType = ty', tcdIdInfo = id_infos', tcdLoc = loc}) + where + 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}) -rnDerivs Nothing -- derivs not specified - = lookupImplicitOccRn evalClass_RDR `thenRn_` - returnRn Nothing +rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon, + tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = nconstrs, + 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' -> + returnRn (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon', + tcdTyVars = tyvars', tcdCons = condecls', tcdNCons = nconstrs, + 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 -rnDerivs (Just ds) - = lookupImplicitOccRn evalClass_RDR `thenRn_` - mapRn rn_deriv ds `thenRn` \ derivs -> - returnRn (Just derivs) + 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' -> + bindTyVarsRn syn_doc tyvars $ \ tyvars' -> + rnHsType syn_doc ty `thenRn` \ ty' -> + returnRn (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc}) where - rn_deriv clas - = lookupOccRn clas `thenRn` \ clas_name -> - - -- Now add extra "occurrences" for things that - -- the deriving mechanism will later need in order to - -- generate code for this class. - case lookupUFM derivingOccurrences clas_name of - Nothing -> addErrRn (derivingNonStdClassErr clas_name) `thenRn_` - returnRn clas_name - - Just occs -> mapRn lookupImplicitOccRn occs `thenRn_` - returnRn clas_name + 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' -> + + -- Deal with the implicit tycon and datacon name + -- They aren't in scope (because they aren't visible to the user) + -- and what we want to do is simply look them up in the cache; + -- we jolly well ought to get a 'hit' there! + mapRn lookupSysBinder names `thenRn` \ names' -> + + -- Tyvars scope over bindings and context + bindTyVarsRn cls_doc tyvars $ \ tyvars' -> + + -- Check the superclasses + rnContext cls_doc context `thenRn` \ context' -> + + -- Check the functional dependencies + rnFds cls_doc fds `thenRn` \ fds' -> + + -- Check the signatures + -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). + let + (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' fds') op_sigs `thenRn` \ sigs' -> + let + binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ] + in + renameSigs (okClsDclSig binders) non_op_sigs `thenRn` \ non_ops' -> + + -- Typechecker is responsible for checking that we only + -- give default-method bindings for things in this class. + -- The renamer *could* check this for class decls, but can't + -- for instance decls. + + 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 "In the declaration for class" <+> ppr cname + sig_doc = text "In the signatures for class" <+> ppr cname + +rnClassOp clas clas_fds sig@(ClassOpSig op dm_stuff ty locn) + = pushSrcLocRn locn $ + lookupTopBndrRn op `thenRn` \ op_name -> + + -- Check the signature + rnHsSigType (quotes (ppr op)) ty `thenRn` \ new_ty -> + + -- Make the default-method 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 (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 + + GenDefMeth -> returnRn GenDefMeth + NoDefMeth -> returnRn NoDefMeth + ) `thenRn` \ dm_stuff' -> + + 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 +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 + -- op {| x+y |} (Inl a) = ... + -- op {| x+y |} (Inr b) = ... + -- op {| a*b |} (a*b) = ... + -- 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 + meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds + gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds, + not (tv `elemRdrEnv` name_env)] + in + checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_` + newLocalsRn gen_rdr_tyvars_w_locs `thenRn` \ gen_tyvars -> + rnMethodBinds cls gen_tyvars mbinds `thenRn` \ (mbinds', meth_fvs) -> + returnRn (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs) + where + meth_doc = text "In the default-methods for class" <+> ppr (tcdName rn_cls_decl) + +finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs) + -- Not a class declaration \end{code} + +%********************************************************* +%* * +\subsection{Support code for type/data declarations} +%* * +%********************************************************* + \begin{code} conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc) -conDeclName (ConDecl n _ _ l) = (n,l) +conDeclName (ConDecl n _ _ _ _ l) = (n,l) -rnConDecl :: RdrNameConDecl -> RnMS s RenamedConDecl -rnConDecl (ConDecl name cxt details locn) +rnConDecl :: RdrNameConDecl -> RnMS RenamedConDecl +rnConDecl (ConDecl name wkr tvs cxt details locn) = pushSrcLocRn locn $ - checkConName name `thenRn_` - lookupBndrRn name `thenRn` \ new_name -> - rnConDetails name locn details `thenRn` \ new_details -> - rnContext cxt `thenRn` \ new_context -> - returnRn (ConDecl new_name new_context new_details locn) - -rnConDetails con locn (VanillaCon tys) - = mapRn rnBangTy tys `thenRn` \ new_tys -> + checkConName name `thenRn_` + lookupTopBndrRn name `thenRn` \ new_name -> + + lookupSysBinder wkr `thenRn` \ new_wkr -> + -- See comments with ClassDecl + + bindTyVarsRn doc tvs $ \ new_tyvars -> + rnContext doc cxt `thenRn` \ new_context -> + rnConDetails doc locn details `thenRn` \ new_details -> + returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn) + where + doc = text "In the definition of data constructor" <+> quotes (ppr name) + +rnConDetails doc locn (VanillaCon tys) + = mapRn (rnBangTy doc) tys `thenRn` \ new_tys -> returnRn (VanillaCon new_tys) -rnConDetails con locn (InfixCon ty1 ty2) - = rnBangTy ty1 `thenRn` \ new_ty1 -> - rnBangTy ty2 `thenRn` \ new_ty2 -> +rnConDetails doc locn (InfixCon ty1 ty2) + = rnBangTy doc ty1 `thenRn` \ new_ty1 -> + rnBangTy doc ty2 `thenRn` \ new_ty2 -> returnRn (InfixCon new_ty1 new_ty2) -rnConDetails con locn (NewCon ty) - = rnHsType ty `thenRn` \ new_ty -> - returnRn (NewCon new_ty) - -rnConDetails con locn (RecCon fields) - = checkDupOrQualNames fld_doc field_names `thenRn_` - mapRn rnField fields `thenRn` \ new_fields -> +rnConDetails doc locn (RecCon fields) + = checkDupOrQualNames doc field_names `thenRn_` + mapRn (rnField doc) fields `thenRn` \ new_fields -> returnRn (RecCon new_fields) where - fld_doc = text "the fields of constructor" <> ppr con field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds] -rnField (names, ty) - = mapRn lookupBndrRn names `thenRn` \ new_names -> - rnBangTy ty `thenRn` \ new_ty -> +rnField doc (names, ty) + = mapRn lookupTopBndrRn names `thenRn` \ new_names -> + rnBangTy doc ty `thenRn` \ new_ty -> returnRn (new_names, new_ty) -rnBangTy (Banged ty) - = rnHsType ty `thenRn` \ new_ty -> - returnRn (Banged new_ty) - -rnBangTy (Unbanged ty) - = rnHsType ty `thenRn` \ new_ty -> - returnRn (Unbanged new_ty) +rnBangTy doc (BangType s ty) + = rnHsType doc ty `thenRn` \ new_ty -> + returnRn (BangType s new_ty) -- This data decl will parse OK -- data T = a Int @@ -388,7 +502,7 @@ rnBangTy (Unbanged ty) -- from interface files, which always print in prefix form checkConName name - = checkRn (isLexCon (occNameString (rdrNameOcc name))) + = checkRn (isRdrDataCon name) (badDataCon name) \end{code} @@ -400,217 +514,82 @@ checkConName name %********************************************************* \begin{code} -rnHsSigType :: SDoc -> RdrNameHsType -> RnMS s RenamedHsType - -- rnHsSigType is used for source-language type signatures, - -- which use *implicit* universal quantification. - --- Given the signature C => T we universally quantify over FV(T) \ {in-scope-tyvars} --- --- We insist that the universally quantified type vars is a superset of FV(C) --- It follows that FV(T) is a superset of FV(C), so that the context constrains --- no type variables that don't appear free in the tau-type part. - -rnHsSigType doc_str full_ty@(HsPreForAllTy ctxt ty) -- From source code (no kinds on tyvars) - = getLocalNameEnv `thenRn` \ name_env -> - let - mentioned_tyvars = extractHsTyVars ty - forall_tyvars = filter (not . in_scope) mentioned_tyvars - in_scope tv = maybeToBool (lookupFM name_env tv) - - constrained_tyvars = extractHsCtxtTyVars ctxt - constrained_and_in_scope = filter in_scope constrained_tyvars - constrained_and_not_mentioned = filter (not . (`elem` mentioned_tyvars)) constrained_tyvars +rnFds :: SDoc -> [FunDep RdrName] -> RnMS [FunDep Name] - -- Zap the context if there's a problem, to avoid duplicate error message. - ctxt' | null constrained_and_in_scope && null constrained_and_not_mentioned = ctxt - | otherwise = [] - in - checkRn (null constrained_and_in_scope) - (ctxtErr1 sig_doc constrained_and_in_scope) `thenRn_` - checkRn (null constrained_and_not_mentioned) - (ctxtErr2 sig_doc constrained_and_not_mentioned ty) `thenRn_` - - (bindTyVarsRn sig_doc (map UserTyVar forall_tyvars) $ \ new_tyvars -> - rnContext ctxt' `thenRn` \ new_ctxt -> - rnHsType ty `thenRn` \ new_ty -> - returnRn (HsForAllTy new_tyvars new_ctxt new_ty) - ) +rnFds doc fds + = mapRn rn_fds fds where - sig_doc = text "the type signature for" <+> doc_str - - -rnHsSigType doc_str other_ty = rnHsType other_ty - -rnHsType :: RdrNameHsType -> RnMS s RenamedHsType -rnHsType (HsForAllTy tvs ctxt ty) -- From an interface file (tyvars may be kinded) - = rn_poly_help tvs ctxt ty + rn_fds (tys1, tys2) + = rnHsTyVars doc tys1 `thenRn` \ tys1' -> + rnHsTyVars doc tys2 `thenRn` \ tys2' -> + returnRn (tys1', tys2') -rnHsType full_ty@(HsPreForAllTy ctxt ty) -- A (context => ty) embedded in a type. - -- Universally quantify over tyvars in context - = getLocalNameEnv `thenRn` \ name_env -> - let - forall_tyvars = extractHsCtxtTyVars ctxt - in - rn_poly_help (map UserTyVar forall_tyvars) ctxt ty - -rnHsType (MonoTyVar tyvar) - = lookupOccRn tyvar `thenRn` \ tyvar' -> - returnRn (MonoTyVar tyvar') - -rnHsType (MonoFunTy ty1 ty2) - = andRn MonoFunTy (rnHsType ty1) (rnHsType ty2) - -rnHsType (MonoListTy _ ty) - = lookupImplicitOccRn listType_RDR `thenRn` \ tycon_name -> - rnHsType ty `thenRn` \ ty' -> - returnRn (MonoListTy tycon_name ty') - -rnHsType (MonoTupleTy _ tys) - = lookupImplicitOccRn (tupleType_RDR (length tys)) `thenRn` \ tycon_name -> - mapRn rnHsType tys `thenRn` \ tys' -> - returnRn (MonoTupleTy tycon_name tys') - -rnHsType (MonoTyApp ty1 ty2) - = rnHsType ty1 `thenRn` \ ty1' -> - rnHsType ty2 `thenRn` \ ty2' -> - returnRn (MonoTyApp ty1' ty2') - -rnHsType (MonoDictTy clas tys) - = lookupOccRn clas `thenRn` \ clas' -> - mapRn rnHsType tys `thenRn` \ tys' -> - returnRn (MonoDictTy clas' tys') - -rn_poly_help :: [HsTyVar RdrName] -- Universally quantified tyvars - -> RdrNameContext - -> RdrNameHsType - -> RnMS s RenamedHsType -rn_poly_help tyvars ctxt ty - = bindTyVarsRn sig_doc tyvars $ \ new_tyvars -> - rnContext ctxt `thenRn` \ new_ctxt -> - rnHsType ty `thenRn` \ new_ty -> - returnRn (HsForAllTy new_tyvars new_ctxt new_ty) - where - sig_doc = text "a nested for-all type" +rnHsTyVars doc tvs = mapRn (rnHsTyvar doc) tvs +rnHsTyvar doc tyvar = lookupOccRn tyvar \end{code} - -\begin{code} -rnContext :: RdrNameContext -> RnMS s RenamedContext - -rnContext ctxt - = mapRn rn_ctxt ctxt `thenRn` \ result -> - let - (_, dup_asserts) = removeDups cmp_assert result - (alls, theta) = partition (\(c,_) -> c == allClass_NAME) result - in - - -- Check for duplicate assertions - -- If this isn't an error, then it ought to be: - mapRn (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_` - - -- Check for All constraining a non-type-variable - mapRn check_All alls `thenRn_` - - -- Done. Return a theta omitting all the "All" constraints. - -- They have done done their work by ensuring that we universally - -- quantify over their tyvar. - returnRn theta - where - rn_ctxt (clas, tys) - = -- Mini hack here. If the class is our pseudo-class "All", - -- then we don't want to record it as an occurrence, otherwise - -- we try to slurp it in later and it doesn't really exist at all. - -- Easiest thing is simply not to put it in the occurrence set. - lookupBndrRn clas `thenRn` \ clas_name -> - (if clas_name /= allClass_NAME then - addOccurrenceName clas_name - else - returnRn clas_name - ) `thenRn_` - mapRn rnHsType tys `thenRn` \ tys' -> - returnRn (clas_name, tys') - - - cmp_assert (c1,tys1) (c2,tys2) - = (c1 `compare` c2) `thenCmp` (cmpHsTypes compare tys1 tys2) - - check_All (c, [MonoTyVar _]) = returnRn () -- OK! - check_All assertion = addErrRn (wierdAllErr assertion) -\end{code} - - %********************************************************* -%* * +%* * \subsection{IdInfo} -%* * +%* * %********************************************************* \begin{code} -rnIdInfo (HsStrictness strict) - = rnStrict strict `thenRn` \ strict' -> - returnRn (HsStrictness strict') +rnIdInfo (HsWorker worker arity) + = lookupOccRn worker `thenRn` \ worker' -> + returnRn (HsWorker worker' arity) -rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ expr' -> +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 (HsUpdate update) = returnRn (HsUpdate update) -rnIdInfo (HsFBType fb) = returnRn (HsFBType fb) -rnIdInfo (HsArgUsage au) = returnRn (HsArgUsage au) -rnIdInfo (HsSpecialise tyvars tys expr) - = bindTyVarsRn doc tyvars $ \ tyvars' -> - rnCoreExpr expr `thenRn` \ expr' -> - mapRn rnHsType tys `thenRn` \ tys' -> - returnRn (HsSpecialise tyvars' tys' expr') - where - doc = text "Specialise in interface pragma" - - -rnStrict (HsStrictnessInfo demands (Just (worker,cons))) - -- The sole purpose of the "cons" field is so that we can mark the constructors - -- needed to build the wrapper as "needed", so that their data type decl will be - -- slurped in. After that their usefulness is o'er, so we just put in the empty list. - = lookupOccRn worker `thenRn` \ worker' -> - mapRn lookupOccRn cons `thenRn_` - returnRn (HsStrictnessInfo demands (Just (worker',[]))) - --- Boring, but necessary for the type checker. -rnStrict (HsStrictnessInfo demands Nothing) = returnRn (HsStrictnessInfo demands Nothing) -rnStrict HsBottom = returnRn HsBottom +rnIdInfo HsNoCafRefs = returnRn HsNoCafRefs \end{code} -UfCore expressions. +@UfCore@ expressions. \begin{code} +rnCoreExpr (UfType ty) + = rnHsType (text "unfolding type") ty `thenRn` \ ty' -> + returnRn (UfType ty') + rnCoreExpr (UfVar v) = lookupOccRn v `thenRn` \ v' -> returnRn (UfVar v') -rnCoreExpr (UfLit lit) = returnRn (UfLit lit) +rnCoreExpr (UfLit l) + = returnRn (UfLit l) -rnCoreExpr (UfCon con args) - = lookupOccRn con `thenRn` \ con' -> - mapRn rnCoreArg args `thenRn` \ args' -> - returnRn (UfCon con' args') +rnCoreExpr (UfLitLit l ty) + = rnHsType (text "litlit") ty `thenRn` \ ty' -> + returnRn (UfLitLit l ty') -rnCoreExpr (UfPrim prim args) - = rnCorePrim prim `thenRn` \ prim' -> - mapRn rnCoreArg args `thenRn` \ args' -> - returnRn (UfPrim prim' args') +rnCoreExpr (UfFCall cc ty) + = rnHsType (text "ccall") ty `thenRn` \ ty' -> + returnRn (UfFCall cc ty') + +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' -> - rnCoreArg arg `thenRn` \ arg' -> + rnCoreExpr arg `thenRn` \ arg' -> returnRn (UfApp fun' arg') -rnCoreExpr (UfCase scrut alts) - = rnCoreExpr scrut `thenRn` \ scrut' -> - rnCoreAlts alts `thenRn` \ alts' -> - returnRn (UfCase scrut' alts') +rnCoreExpr (UfCase scrut bndr alts) + = rnCoreExpr scrut `thenRn` \ scrut' -> + bindCoreLocalRn bndr $ \ bndr' -> + mapRn rnCoreAlt alts `thenRn` \ alts' -> + returnRn (UfCase scrut' bndr' alts') rnCoreExpr (UfNote note expr) = rnNote note `thenRn` \ note' -> rnCoreExpr expr `thenRn` \ expr' -> - returnRn (UfNote note' expr') + returnRn (UfNote note' expr') rnCoreExpr (UfLam bndr body) = rnCoreBndr bndr $ \ bndr' -> @@ -634,110 +613,101 @@ rnCoreExpr (UfLet (UfRec pairs) body) \begin{code} rnCoreBndr (UfValBinder name ty) thing_inside - = rnHsType ty `thenRn` \ ty' -> - bindLocalsRn "unfolding value" [name] $ \ [name'] -> + = rnHsType doc ty `thenRn` \ ty' -> + bindCoreLocalRn name $ \ name' -> thing_inside (UfValBinder name' ty') + where + doc = text "unfolding id" rnCoreBndr (UfTyBinder name kind) thing_inside - = bindLocalsRn "unfolding tyvar" [name] $ \ [name'] -> + = bindCoreLocalRn name $ \ name' -> thing_inside (UfTyBinder name' kind) -rnCoreBndrs bndrs thing_inside -- Expect them all to be ValBinders - = mapRn rnHsType tys `thenRn` \ tys' -> - bindLocalsRn "unfolding value" names $ \ names' -> - thing_inside (zipWith UfValBinder names' tys') - where - names = map (\ (UfValBinder name _) -> name) bndrs - tys = map (\ (UfValBinder _ ty) -> ty) bndrs - -rnCoreBndrNamess names thing_inside - = bindLocalsRn "unfolding value" names $ \ names' -> - thing_inside names' +rnCoreBndrs [] thing_inside = thing_inside [] +rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b $ \ name' -> + rnCoreBndrs bs $ \ names' -> + thing_inside (name':names') \end{code} \begin{code} -rnCoreArg (UfVarArg v) = lookupOccRn v `thenRn` \ v' -> returnRn (UfVarArg v') -rnCoreArg (UfTyArg ty) = rnHsType ty `thenRn` \ ty' -> returnRn (UfTyArg ty') -rnCoreArg (UfLitArg lit) = returnRn (UfLitArg lit) - -rnCoreAlts (UfAlgAlts alts deflt) - = mapRn rn_alt alts `thenRn` \ alts' -> - rnCoreDefault deflt `thenRn` \ deflt' -> - returnRn (UfAlgAlts alts' deflt') - where - rn_alt (con, bndrs, rhs) = lookupOccRn con `thenRn` \ con' -> - bindLocalsRn "unfolding alt" bndrs $ \ bndrs' -> - rnCoreExpr rhs `thenRn` \ rhs' -> - returnRn (con', bndrs', rhs') - -rnCoreAlts (UfPrimAlts alts deflt) - = mapRn rn_alt alts `thenRn` \ alts' -> - rnCoreDefault deflt `thenRn` \ deflt' -> - returnRn (UfPrimAlts alts' deflt') - where - rn_alt (lit, rhs) = rnCoreExpr rhs `thenRn` \ rhs' -> - returnRn (lit, rhs') - -rnCoreDefault UfNoDefault = returnRn UfNoDefault -rnCoreDefault (UfBindDefault bndr rhs) = bindLocalsRn "unfolding default" [bndr] $ \ [bndr'] -> - rnCoreExpr rhs `thenRn` \ rhs' -> - returnRn (UfBindDefault bndr' rhs') +rnCoreAlt (con, bndrs, rhs) + = rnUfCon con `thenRn` \ con' -> + bindCoreLocalsRn bndrs $ \ bndrs' -> + rnCoreExpr rhs `thenRn` \ rhs' -> + returnRn (con', bndrs', rhs') rnNote (UfCoerce ty) - = rnHsType ty `thenRn` \ ty' -> + = rnHsType (text "unfolding coerce") ty `thenRn` \ ty' -> returnRn (UfCoerce ty') rnNote (UfSCC cc) = returnRn (UfSCC cc) rnNote UfInlineCall = returnRn UfInlineCall +rnNote UfInlineMe = returnRn UfInlineMe + + +rnUfCon UfDefault + = returnRn UfDefault + +rnUfCon (UfTupleAlt (HsTupCon _ boxity arity)) + = returnRn (UfTupleAlt (HsTupCon tup_name boxity arity)) + where + tup_name = getName (tupleCon boxity arity) -rnCorePrim (UfOtherOp op) - = lookupOccRn op `thenRn` \ op' -> - returnRn (UfOtherOp op') +rnUfCon (UfDataAlt con) + = lookupOccRn con `thenRn` \ con' -> + returnRn (UfDataAlt con') + +rnUfCon (UfLitAlt lit) + = returnRn (UfLitAlt lit) -rnCorePrim (UfCCallOp str casm gc arg_tys res_ty) - = mapRn rnHsType arg_tys `thenRn` \ arg_tys' -> - rnHsType res_ty `thenRn` \ res_ty' -> - returnRn (UfCCallOp str casm gc arg_tys' res_ty') +rnUfCon (UfLitLitAlt lit ty) + = rnHsType (text "litlit") ty `thenRn` \ ty' -> + returnRn (UfLitLitAlt lit ty') \end{code} %********************************************************* -%* * -\subsection{Errors} -%* * +%* * +\subsection{Rule shapes} +%* * %********************************************************* +Check the shape of a transformation rule LHS. Currently +we only allow LHSs of the form @(f e1 .. en)@, where @f@ is +not one of the @forall@'d variables. + \begin{code} -derivingNonStdClassErr clas - = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")] +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 +\end{code} -classTyVarNotInOpTyErr clas_tyvar sig - = hang (hsep [ptext SLIT("Class type variable"), - quotes (ppr clas_tyvar), - ptext SLIT("does not appear in method signature")]) - 4 (ppr sig) -dupClassAssertWarn ctxt (assertion : dups) - = sep [hsep [ptext SLIT("Duplicate class assertion"), - quotes (pprClassAssertion assertion), - ptext SLIT("in the context:")], - nest 4 (pprContext ctxt)] +%********************************************************* +%* * +\subsection{Errors} +%* * +%********************************************************* +\begin{code} badDataCon name = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] -wierdAllErr assertion - = ptext SLIT("Mal-formed use of `All':") <+> pprClassAssertion assertion - -ctxtErr1 doc tyvars - = hsep [ptext SLIT("Context constrains in-scope type variable(s)"), - pprQuotedList tyvars] +badRuleLhsErr name lhs + = sep [ptext SLIT("Rule") <+> ptext name <> colon, + nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)] $$ - nest 4 (ptext SLIT("in") <+> doc) + ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd") -ctxtErr2 doc tyvars ty - = (ptext SLIT("Context constrains type variable(s)") - <+> pprQuotedList tyvars) - $$ - nest 4 (vcat [ptext SLIT("that do not appear in") <+> quotes (ppr ty), - ptext SLIT("in") <+> doc]) +badRuleVar name var + = 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")] + +emptyConDeclsErr tycon + = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"), + nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))] \end{code}