X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=521d71541ce3c2a826648977073907c2b5cf5027;hp=ca237ddfe1603fcec94678bb4353738a83c1afa9;hb=61bcd16d4f3d4cf84b26bf7bb92f16f0440b7071;hpb=ec0b859902e717c24addff49f9a83efb927fb669 diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index ca237dd..521d715 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -16,34 +16,63 @@ import {-# SOURCE #-} RnExpr( rnLExpr ) import HsSyn import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, - globalRdrEnvElts, GlobalRdrElt(..), isLocalGRE ) + globalRdrEnvElts, GlobalRdrElt(..), isLocalGRE, rdrNameOcc ) import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars ) import RnHsSyn import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext ) -import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, mkSigTvFn ) +import RnBinds ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn, + makeMiniFixityEnv) import RnEnv ( lookupLocalDataTcNames, lookupLocatedTopBndrRn, lookupLocatedOccRn, lookupOccRn, newLocalsRn, bindLocatedLocalsFV, bindPatSigTyVarsFV, bindTyVarsRn, extendTyVarEnvFVRn, - bindLocalNames, checkDupNames, mapFvRn + bindLocalNames, checkDupRdrNames, mapFvRn, ) +import RnNames ( getLocalNonValBinders, extendGlobalRdrEnvRn ) +import HscTypes ( GenAvailInfo(..), availsToNameSet ) import RnHsDoc ( rnHsDoc, rnMbLHsDoc ) import TcRnMonad -import HscTypes ( FixityEnv, FixItem(..), Deprecations, Deprecs(..), plusDeprecs ) +import HscTypes ( Warnings(..), plusWarns ) import Class ( FunDep ) import Name ( Name, nameOccName ) import NameSet import NameEnv -import OccName ( occEnvElts ) +import OccName import Outputable -import SrcLoc ( Located(..), unLoc, noLoc ) +import Bag +import FastString +import SrcLoc import DynFlags ( DynFlag(..) ) -import Maybes ( seqMaybe ) import Maybe ( isNothing ) -import Monad ( liftM, when ) import BasicTypes ( Boxity(..) ) + +import ListSetOps (findDupsEq) +import List + +import Control.Monad +\end{code} + +\begin{code} +-- XXX +thenM :: Monad a => a b -> (b -> a c) -> a c +thenM = (>>=) + +thenM_ :: Monad a => a b -> a c -> a c +thenM_ = (>>) + +returnM :: Monad m => a -> m a +returnM = return + +mappM :: (Monad m) => (a -> m b) -> [a] -> m [b] +mappM = mapM + +mappM_ :: (Monad m) => (a -> m b) -> [a] -> m () +mappM_ = mapM_ + +checkM :: Monad m => Bool -> m () -> m () +checkM = unless \end{code} @rnSourceDecl@ `renames' declarations. @@ -63,95 +92,146 @@ Checks the @(..)@ etc constraints in the export list. \begin{code} +-- Brings the binders of the group into scope in the appropriate places; +-- does NOT assume that anything is in scope already rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name) - -rnSrcDecls (HsGroup { hs_valds = val_decls, - hs_tyclds = tycl_decls, - hs_instds = inst_decls, - hs_derivds = deriv_decls, - hs_fixds = fix_decls, - hs_depds = deprec_decls, - hs_fords = foreign_decls, - hs_defds = default_decls, - hs_ruleds = rule_decls, - hs_docs = docs }) - - = do { -- Deal with deprecations (returns only the extra deprecations) - deprecs <- rnSrcDeprecDecls deprec_decls ; - updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` deprecs }) - $ do { - - -- Deal with top-level fixity decls - -- (returns the total new fixity env) - rn_fix_decls <- rnSrcFixityDecls fix_decls ; - fix_env <- rnSrcFixityDeclsEnv rn_fix_decls ; - updGblEnv (\gbl -> gbl { tcg_fix_env = fix_env }) - $ do { - - -- Rename other declarations - traceRn (text "Start rnmono") ; - (rn_val_decls, bind_dus) <- rnTopBinds val_decls ; - traceRn (text "finish rnmono" <+> ppr rn_val_decls) ; - - -- You might think that we could build proper def/use information - -- for type and class declarations, but they can be involved - -- in mutual recursion across modules, and we only do the SCC - -- analysis for them in the type checker. - -- So we content ourselves with gathering uses only; that - -- means we'll only report a declaration as unused if it isn't - -- mentioned at all. Ah well. - traceRn (text "Start rnTyClDecls") ; - (rn_tycl_decls, src_fvs1) - <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls ; - traceRn (text "finish rnTyClDecls") ; - (rn_inst_decls, src_fvs2) - <- mapFvRn (wrapLocFstM rnSrcInstDecl) inst_decls ; - (rn_deriv_decls, src_fvs_deriv) - <- mapFvRn (wrapLocFstM rnSrcDerivDecl) deriv_decls ; - (rn_rule_decls, src_fvs3) - <- mapFvRn (wrapLocFstM rnHsRuleDecl) rule_decls ; - (rn_foreign_decls, src_fvs4) - <- mapFvRn (wrapLocFstM rnHsForeignDecl) foreign_decls ; - (rn_default_decls, src_fvs5) - <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ; - - -- Haddock docs - rn_docs <- mapM (wrapLocM rnDocDecl) docs ; - - let { - rn_group = HsGroup { hs_valds = rn_val_decls, - hs_tyclds = rn_tycl_decls, - hs_instds = rn_inst_decls, - hs_derivds = rn_deriv_decls, - hs_fixds = rn_fix_decls, - hs_depds = [], - hs_fords = rn_foreign_decls, - hs_defds = rn_default_decls, - hs_ruleds = rn_rule_decls, - hs_docs = rn_docs } ; - - other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs_deriv, src_fvs3, - src_fvs4, src_fvs5] ; - src_dus = bind_dus `plusDU` usesOnly other_fvs +-- Rename a HsGroup; used for normal source files *and* hs-boot files +rnSrcDecls group@(HsGroup {hs_valds = val_decls, + hs_tyclds = tycl_decls, + hs_instds = inst_decls, + hs_derivds = deriv_decls, + hs_fixds = fix_decls, + hs_warnds = warn_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_ruleds = rule_decls, + hs_docs = docs }) + = do { + -- (A) Process the fixity declarations, creating a mapping from + -- FastStrings to FixItems. + -- Also checks for duplcates. + local_fix_env <- makeMiniFixityEnv fix_decls; + + -- (B) Bring top level binders (and their fixities) into scope, + -- *except* for the value bindings, which get brought in below. + -- However *do* include class ops, data constructors + -- And for hs-boot files *do* include the value signatures + tc_avails <- getLocalNonValBinders group ; + tc_envs <- extendGlobalRdrEnvRn tc_avails local_fix_env ; + setEnvs tc_envs $ do { + + failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations + + -- (C) Extract the mapping from data constructors to field names and + -- extend the record field env. + -- This depends on the data constructors and field names being in + -- scope from (B) above + inNewEnv (extendRecordFieldEnv tycl_decls) $ \ _ -> do { + + -- (D) Rename the left-hand sides of the value bindings. + -- This depends on everything from (B) being in scope, + -- and on (C) for resolving record wild cards. + -- It uses the fixity env from (A) to bind fixities for view patterns. + new_lhs <- rnTopBindsLHS local_fix_env val_decls ; + -- bind the LHSes (and their fixities) in the global rdr environment + let { val_binders = map unLoc $ collectHsValBinders new_lhs ; + val_bndr_set = mkNameSet val_binders ; + all_bndr_set = val_bndr_set `unionNameSets` availsToNameSet tc_avails ; + val_avails = map Avail val_binders + } ; + (tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ; + setEnvs (tcg_env, tcl_env) $ do { + + -- Now everything is in scope, as the remaining renaming assumes. + + -- (E) Rename type and class decls + -- (note that value LHSes need to be in scope for default methods) + -- + -- You might think that we could build proper def/use information + -- for type and class declarations, but they can be involved + -- in mutual recursion across modules, and we only do the SCC + -- analysis for them in the type checker. + -- So we content ourselves with gathering uses only; that + -- means we'll only report a declaration as unused if it isn't + -- mentioned at all. Ah well. + traceRn (text "Start rnTyClDecls") ; + (rn_tycl_decls, src_fvs1) <- rnList rnTyClDecl tycl_decls ; + + -- (F) Rename Value declarations right-hand sides + traceRn (text "Start rnmono") ; + (rn_val_decls, bind_dus) <- rnTopBindsRHS val_bndr_set new_lhs ; + traceRn (text "finish rnmono" <+> ppr rn_val_decls) ; + + -- (G) Rename Fixity and deprecations + + -- Rename fixity declarations and error if we try to + -- fix something from another module (duplicates were checked in (A)) + rn_fix_decls <- rnSrcFixityDecls all_bndr_set fix_decls ; + + -- Rename deprec decls; + -- check for duplicates and ensure that deprecated things are defined locally + -- at the moment, we don't keep these around past renaming + rn_warns <- rnSrcWarnDecls all_bndr_set warn_decls ; + + -- (H) Rename Everything else + + (rn_inst_decls, src_fvs2) <- rnList rnSrcInstDecl inst_decls ; + (rn_rule_decls, src_fvs3) <- setOptM Opt_ScopedTypeVariables $ + rnList rnHsRuleDecl rule_decls ; + -- Inside RULES, scoped type variables are on + (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ; + (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl default_decls ; + (rn_deriv_decls, src_fvs6) <- rnList rnSrcDerivDecl deriv_decls ; + -- Haddock docs; no free vars + rn_docs <- mapM (wrapLocM rnDocDecl) docs ; + + -- (I) Compute the results and return + let {rn_group = HsGroup { hs_valds = rn_val_decls, + hs_tyclds = rn_tycl_decls, + hs_instds = rn_inst_decls, + hs_derivds = rn_deriv_decls, + hs_fixds = rn_fix_decls, + hs_warnds = [], -- warns are returned in the tcg_env + -- (see below) not in the HsGroup + hs_fords = rn_foreign_decls, + hs_defds = rn_default_decls, + hs_ruleds = rn_rule_decls, + hs_docs = rn_docs } ; + + other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs6, src_fvs3, + src_fvs4, src_fvs5] ; + src_dus = bind_dus `plusDU` usesOnly other_fvs; -- Note: src_dus will contain *uses* for locally-defined types -- and classes, but no *defs* for them. (Because rnTyClDecl -- returns only the uses.) This is a little -- surprising but it doesn't actually matter at all. - } ; - traceRn (text "finish rnSrc" <+> ppr rn_group) ; - traceRn (text "finish Dus" <+> ppr src_dus ) ; - tcg_env <- getGblEnv ; - return (tcg_env `addTcgDUs` src_dus, rn_group) - }}} + final_tcg_env = let tcg_env' = (tcg_env `addTcgDUs` src_dus) + in -- we return the deprecs in the env, not in the HsGroup above + tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns }; + } ; + + traceRn (text "finish rnSrc" <+> ppr rn_group) ; + traceRn (text "finish Dus" <+> ppr src_dus ) ; + return (final_tcg_env , rn_group) + }}}} + +-- some utils because we do this a bunch above +-- compute and install the new env +inNewEnv :: TcM TcGblEnv -> (TcGblEnv -> TcM a) -> TcM a +inNewEnv env cont = do e <- env + setGblEnv e $ cont e rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name] -rnTyClDecls tycl_decls = do - (decls', fvs) <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls - return decls' +-- Used for external core +rnTyClDecls tycl_decls = do (decls', _fvs) <- rnList rnTyClDecl tycl_decls + return decls' addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus } + +rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars) +rnList f xs = mapFvRn (wrapLocFstM f) xs \end{code} @@ -185,49 +265,29 @@ rnDocDecl (DocGroup lev doc) = do %********************************************************* \begin{code} -rnSrcFixityDecls :: [LFixitySig RdrName] -> RnM [LFixitySig Name] -rnSrcFixityDecls fix_decls - = do fix_decls <- mapM rnFixityDecl fix_decls - return (concat fix_decls) - -rnFixityDecl :: LFixitySig RdrName -> RnM [LFixitySig Name] -rnFixityDecl (L loc (FixitySig (L nameLoc rdr_name) fixity)) - = setSrcSpan nameLoc $ +rnSrcFixityDecls :: NameSet -> [LFixitySig RdrName] -> RnM [LFixitySig Name] +-- Rename the fixity decls, so we can put +-- the renamed decls in the renamed syntax tree +-- Errors if the thing being fixed is not defined locally. +-- +-- The returned FixitySigs are not actually used for anything, +-- except perhaps the GHCi API +rnSrcFixityDecls bound_names fix_decls + = do fix_decls <- mapM rn_decl fix_decls + return (concat fix_decls) + where + rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name] -- GHC extension: look up both the tycon and data con - -- for con-like things + -- for con-like things; hence returning a list -- If neither are in scope, report an error; otherwise - -- add both to the fixity env - do names <- lookupLocalDataTcNames rdr_name - return [ L loc (FixitySig (L nameLoc name) fixity) - | name <- names ] - -rnSrcFixityDeclsEnv :: [LFixitySig Name] -> RnM FixityEnv -rnSrcFixityDeclsEnv fix_decls - = getGblEnv `thenM` \ gbl_env -> - foldlM rnFixityDeclEnv (tcg_fix_env gbl_env) - fix_decls `thenM` \ fix_env -> - traceRn (text "fixity env" <+> pprFixEnv fix_env) `thenM_` - returnM fix_env - -rnFixityDeclEnv :: FixityEnv -> LFixitySig Name -> RnM FixityEnv -rnFixityDeclEnv fix_env (L loc (FixitySig (L nameLoc name) fixity)) - = case lookupNameEnv fix_env name of - Just (FixItem _ _ loc') - -> do addLocErr (L nameLoc name) (dupFixityDecl loc') - return fix_env - Nothing - -> return (extendNameEnv fix_env name fix_item) - where fix_item = FixItem (nameOccName name) fixity nameLoc - -pprFixEnv :: FixityEnv -> SDoc -pprFixEnv env - = pprWithCommas (\ (FixItem n f _) -> ppr f <+> ppr n) - (nameEnvElts env) - -dupFixityDecl loc rdr_name - = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name), - ptext SLIT("also at ") <+> ppr loc - ] + -- return a fixity sig for each (slightly odd) + rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity)) + = setSrcSpan name_loc $ + -- this lookup will fail if the definition isn't local + do names <- lookupLocalDataTcNames bound_names what rdr_name + return [ L loc (FixitySig (L name_loc name) fixity) + | name <- names ] + what = ptext (sLit "fixity signature") \end{code} @@ -237,22 +297,43 @@ dupFixityDecl loc rdr_name %* * %********************************************************* -For deprecations, all we do is check that the names are in scope. +Check that the deprecated names are defined, are defined locally, and +that there are no duplicate deprecations. + It's only imported deprecations, dealt with in RnIfaces, that we gather them together. \begin{code} -rnSrcDeprecDecls :: [LDeprecDecl RdrName] -> RnM Deprecations -rnSrcDeprecDecls [] - = returnM NoDeprecs - -rnSrcDeprecDecls decls - = mappM (addLocM rn_deprec) decls `thenM` \ pairs_s -> - returnM (DeprecSome (mkNameEnv (concat pairs_s))) +-- checks that the deprecations are defined locally, and that there are no duplicates +rnSrcWarnDecls :: NameSet -> [LWarnDecl RdrName] -> RnM Warnings +rnSrcWarnDecls _bound_names [] + = returnM NoWarnings + +rnSrcWarnDecls bound_names decls + = do { -- check for duplicates + ; mappM_ (\ (lrdr:lrdr':_) -> addLocErr lrdr (dupWarnDecl lrdr')) warn_rdr_dups + ; mappM (addLocM rn_deprec) decls `thenM` \ pairs_s -> + returnM (WarnSome ((concat pairs_s))) } where - rn_deprec (Deprecation rdr_name txt) - = lookupLocalDataTcNames rdr_name `thenM` \ names -> - returnM [(name, (nameOccName name, txt)) | name <- names] + rn_deprec (Warning rdr_name txt) + -- ensures that the names are defined locally + = lookupLocalDataTcNames bound_names what rdr_name `thenM` \ names -> + returnM [(nameOccName name, txt) | name <- names] + + what = ptext (sLit "deprecation") + + -- look for duplicates among the OccNames; + -- we check that the names are defined above + -- invt: the lists returned by findDupsEq always have at least two elements + warn_rdr_dups = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) + (map (\ (L loc (Warning rdr_name _)) -> L loc rdr_name) decls) + +dupWarnDecl :: Located RdrName -> RdrName -> SDoc +-- Located RdrName -> DeprecDecl RdrName -> SDoc +dupWarnDecl (L loc _) rdr_name + = vcat [ptext (sLit "Multiple warning declarations for") <+> quotes (ppr rdr_name), + ptext (sLit "also at ") <+> ppr loc] + \end{code} %********************************************************* @@ -262,6 +343,7 @@ rnSrcDeprecDecls decls %********************************************************* \begin{code} +rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars) rnDefaultDecl (DefaultDecl tys) = mapFvRn (rnHsTypeFVs doc_str) tys `thenM` \ (tys', fvs) -> returnM (DefaultDecl tys', fvs) @@ -276,6 +358,7 @@ rnDefaultDecl (DefaultDecl tys) %********************************************************* \begin{code} +rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars) rnHsForeignDecl (ForeignImport name ty spec) = lookupLocatedTopBndrRn name `thenM` \ name' -> rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) -> @@ -284,12 +367,13 @@ rnHsForeignDecl (ForeignImport name ty spec) rnHsForeignDecl (ForeignExport name ty spec) = lookupLocatedOccRn name `thenM` \ name' -> rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) -> - returnM (ForeignExport name' ty' spec, fvs ) + returnM (ForeignExport name' ty' spec, fvs `addOneFV` unLoc name') -- NB: a foreign export is an *occurrence site* for name, so -- we add it to the free-variable list. It might, for example, -- be imported from another module -fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name +fo_decl_msg :: Located RdrName -> SDoc +fo_decl_msg name = ptext (sLit "In the foreign declaration for") <+> ppr name \end{code} @@ -300,20 +384,11 @@ fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name %********************************************************* \begin{code} +rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars) rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- Used for both source and interface file decls = rnHsSigType (text "an instance decl") inst_ty `thenM` \ inst_ty' -> - -- Rename the associated types - -- The typechecker (not the renamer) checks that all - -- the declarations are for the right class - let - at_doc = text "In the associated types of an instance declaration" - at_names = map (head . tyClDeclNames . unLoc) ats - in - checkDupNames at_doc at_names `thenM_` - rnATInsts ats `thenM` \ (ats', at_fvs) -> - -- Rename the bindings -- The typechecker (not the renamer) checks that all -- the bindings are for the right class @@ -322,13 +397,34 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) meth_names = collectHsBindLocatedBinders mbinds (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty') in - checkDupNames meth_doc meth_names `thenM_` + checkDupRdrNames meth_doc meth_names `thenM_` + -- Check that the same method is not given twice in the + -- same instance decl instance C T where + -- f x = ... + -- g y = ... + -- f x = ... + -- We must use checkDupRdrNames because the Name of the + -- method is the Name of the class selector, whose SrcSpan + -- points to the class declaration + extendTyVarEnvForMethodBinds inst_tyvars ( -- (Slightly strangely) the forall-d tyvars scope over -- the method bindings too - rnMethodBinds cls (\n->[]) -- No scoped tyvars + rnMethodBinds cls (\_ -> []) -- No scoped tyvars [] mbinds ) `thenM` \ (mbinds', meth_fvs) -> + -- Rename the associated types + -- The typechecker (not the renamer) checks that all + -- the declarations are for the right class + let + at_doc = text "In the associated types of an instance declaration" + at_names = map (head . tyClDeclNames . unLoc) ats + in + checkDupRdrNames at_doc at_names `thenM_` + -- See notes with checkDupRdrNames for methods, above + + rnATInsts ats `thenM` \ (ats', at_fvs) -> + -- Rename the prags and signatures. -- Note that the type variables are not in scope here, -- so that instance Eq a => Eq (T a) where @@ -338,9 +434,10 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- But the (unqualified) method names are in scope let binders = collectHsBindBinders mbinds' - ok_sig = okInstDclSig (mkNameSet binders) + bndr_set = mkNameSet binders in - bindLocalNames binders (renameSigs ok_sig uprags) `thenM` \ uprags' -> + bindLocalNames binders + (renameSigs (Just bndr_set) okInstDclSig uprags) `thenM` \ uprags' -> returnM (InstDecl inst_ty' mbinds' uprags' ats', meth_fvs `plusFV` at_fvs @@ -362,8 +459,7 @@ Renaming of the associated types in instances. \begin{code} rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars) -rnATInsts atDecls = - mapFvRn (wrapLocFstM rnATInst) atDecls +rnATInsts atDecls = rnList rnATInst atDecls where rnATInst tydecl@TyData {} = rnTyClDecl tydecl rnATInst tydecl@TySynonym {} = rnTyClDecl tydecl @@ -376,12 +472,15 @@ For the method bindings in class and instance decls, we extend the type variable environment iff -fglasgow-exts \begin{code} +extendTyVarEnvForMethodBinds :: [LHsTyVarBndr Name] + -> RnM (Bag (LHsBind Name), FreeVars) + -> RnM (Bag (LHsBind Name), FreeVars) extendTyVarEnvForMethodBinds tyvars thing_inside - = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> - if opt_GlasgowExts then - extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside - else - thing_inside + = do { scoped_tvs <- doptM Opt_ScopedTypeVariables + ; if scoped_tvs then + extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside + else + thing_inside } \end{code} %********************************************************* @@ -405,35 +504,38 @@ rnSrcDerivDecl (DerivDecl ty) %********************************************************* \begin{code} -rnHsRuleDecl (HsRule rule_name act vars lhs fv_lhs rhs fv_rhs) +rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars) +rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs) = bindPatSigTyVarsFV (collectRuleBndrSigTys vars) $ - bindLocatedLocalsFV doc (map get_var vars) $ \ ids -> - mapFvRn rn_var (vars `zip` ids) `thenM` \ (vars', fv_vars) -> + do { (vars', fv_vars) <- mapFvRn rn_var (vars `zip` ids) + -- NB: The binders in a rule are always Ids + -- We don't (yet) support type variables - rnLExpr lhs `thenM` \ (lhs', fv_lhs') -> - rnLExpr rhs `thenM` \ (rhs', fv_rhs') -> + ; (lhs', fv_lhs') <- rnLExpr lhs + ; (rhs', fv_rhs') <- rnLExpr rhs - checkValidRule rule_name ids lhs' fv_lhs' `thenM_` + ; checkValidRule rule_name ids lhs' fv_lhs' - returnM (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs', - fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') + ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs', + fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') } where doc = text "In the transformation rule" <+> ftext rule_name get_var (RuleBndr v) = v get_var (RuleBndrSig v _) = v - rn_var (RuleBndr (L loc v), id) + rn_var (RuleBndr (L loc _), id) = returnM (RuleBndr (L loc id), emptyFVs) - rn_var (RuleBndrSig (L loc v) t, id) + rn_var (RuleBndrSig (L loc _) t, id) = rnHsTypeFVs doc t `thenM` \ (t', fvs) -> returnM (RuleBndrSig (L loc id) t', fvs) +badRuleVar :: FastString -> Name -> SDoc badRuleVar name var - = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon, - ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> - ptext SLIT("does not appear on left hand side")] + = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon, + ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+> + ptext (sLit "does not appear on left hand side")] \end{code} Note [Rule LHS validity checking] @@ -451,6 +553,7 @@ lambdas. So it seems simmpler not to check at all, and that is why check_e is commented out. \begin{code} +checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM () checkValidRule rule_name ids lhs' fv_lhs' = do { -- Check for the form of the LHS case (validRuleLhs ids lhs') of @@ -459,7 +562,7 @@ checkValidRule rule_name ids lhs' fv_lhs' -- Check that LHS vars are all bound ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')] - ; mappM (addErr . badRuleVar rule_name) bad_vars } + ; mapM_ (addErr . badRuleVar rule_name) bad_vars } validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name) -- Nothing => OK @@ -467,15 +570,15 @@ validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name) validRuleLhs foralls lhs = checkl lhs where - checkl (L loc e) = check e + checkl (L _ e) = check e - check (OpApp e1 op _ e2) = checkl op `seqMaybe` checkl_e e1 `seqMaybe` checkl_e e2 - check (HsApp e1 e2) = checkl e1 `seqMaybe` checkl_e e2 + check (OpApp e1 op _ e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2 + check (HsApp e1 e2) = checkl e1 `mplus` checkl_e e2 check (HsVar v) | v `notElem` foralls = Nothing check other = Just other -- Failure -- Check an argument - checkl_e (L loc e) = Nothing -- Was (check_e e); see Note [Rule LHS validity checking] + checkl_e (L _ _e) = Nothing -- Was (check_e e); see Note [Rule LHS validity checking] {- Commented out; see Note [Rule LHS validity checking] above check_e (HsVar v) = Nothing @@ -483,22 +586,23 @@ validRuleLhs foralls lhs check_e (HsLit e) = Nothing check_e (HsOverLit e) = Nothing - check_e (OpApp e1 op _ e2) = checkl_e e1 `seqMaybe` checkl_e op `seqMaybe` checkl_e e2 - check_e (HsApp e1 e2) = checkl_e e1 `seqMaybe` checkl_e e2 + check_e (OpApp e1 op _ e2) = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2 + check_e (HsApp e1 e2) = checkl_e e1 `mplus` checkl_e e2 check_e (NegApp e _) = checkl_e e check_e (ExplicitList _ es) = checkl_es es check_e (ExplicitTuple es _) = checkl_es es check_e other = Just other -- Fails - checkl_es es = foldr (seqMaybe . checkl_e) Nothing es + checkl_es es = foldr (mplus . checkl_e) Nothing es -} +badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc badRuleLhsErr name lhs bad_e - = sep [ptext SLIT("Rule") <+> ftext name <> colon, - nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e, - ptext SLIT("in left-hand side:") <+> ppr lhs])] + = sep [ptext (sLit "Rule") <+> ftext name <> colon, + nest 4 (vcat [ptext (sLit "Illegal expression:") <+> ppr bad_e, + ptext (sLit "in left-hand side:") <+> ppr lhs])] $$ - ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd") + ptext (sLit "LHS must be of form (f e1 .. en) where f is not forall'd") \end{code} @@ -522,6 +626,7 @@ 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 :: TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars) rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name}) = lookupLocatedTopBndrRn name `thenM` \ name' -> returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name}, @@ -540,15 +645,17 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, | is_vanilla -- Normal Haskell data type decl = ASSERT( isNothing sig ) -- In normal H98 form, kind signature on the -- data type is syntactically illegal - bindTyVarsRn data_doc tyvars $ \ tyvars' -> - do { tycon' <- if isFamInstDecl tydecl + do { tyvars <- pruneTyVars tydecl + ; bindTyVarsRn data_doc tyvars $ \ tyvars' -> do + { tycon' <- if isFamInstDecl tydecl then lookupLocatedOccRn tycon -- may be imported family else lookupLocatedTopBndrRn tycon ; context' <- rnContext data_doc context ; typats' <- rnTyPats data_doc typatsMaybe ; (derivs', deriv_fvs) <- rn_derivs derivs - ; checkDupNames data_doc con_names ; condecls' <- rnConDecls (unLoc tycon') condecls + -- No need to check for duplicate constructor decls + -- since that is done by RnNames.extendGlobalRdrEnvRn ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon', tcdTyVars = tyvars', tcdTyPats = typats', tcdKindSig = Nothing, @@ -560,25 +667,29 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, (if isFamInstDecl tydecl then unitFV (unLoc tycon') -- type instance => use else emptyFVs)) - } + } } | otherwise -- GADT - = ASSERT( none typatsMaybe ) -- GADTs cannot have type patterns for now - do { tycon' <- if isFamInstDecl tydecl + = do { tycon' <- if isFamInstDecl tydecl then lookupLocatedOccRn tycon -- may be imported family else lookupLocatedTopBndrRn tycon ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon) - ; tyvars' <- bindTyVarsRn data_doc tyvars - (\ tyvars' -> return tyvars') + ; (tyvars', typats') + <- bindTyVarsRn data_doc tyvars $ \ tyvars' -> do + { typats' <- rnTyPats data_doc typatsMaybe + ; return (tyvars', typats') } -- For GADTs, the type variables in the declaration -- do not scope over the constructor signatures -- data T a where { T1 :: forall b. b-> b } + ; (derivs', deriv_fvs) <- rn_derivs derivs - ; checkDupNames data_doc con_names ; condecls' <- rnConDecls (unLoc tycon') condecls + -- No need to check for duplicate constructor decls + -- since that is done by RnNames.extendGlobalRdrEnvRn + ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], tcdLName = tycon', tcdTyVars = tyvars', - tcdTyPats = Nothing, tcdKindSig = sig, + tcdTyPats = typats', tcdKindSig = sig, tcdCons = condecls', tcdDerivs = derivs'}, plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs `plusFV` @@ -590,26 +701,20 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, is_vanilla = case condecls of -- Yuk [] -> True L _ (ConDecl { con_res = ResTyH98 }) : _ -> True - other -> False - - none Nothing = True - none (Just []) = True - none _ = False + _ -> False data_doc = text "In the data type declaration for" <+> quotes (ppr tycon) - con_names = map con_names_helper condecls - - con_names_helper (L _ c) = con_name c rn_derivs Nothing = returnM (Nothing, emptyFVs) rn_derivs (Just ds) = rnLHsTypes data_doc ds `thenM` \ ds' -> returnM (Just ds', extractHsTyNames_s ds') -- "type" and "type instance" declarations -rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars, +rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyPats = typatsMaybe, tcdSynRhs = ty}) - = bindTyVarsRn syn_doc tyvars $ \ tyvars' -> - do { name' <- if isFamInstDecl tydecl + = do { tyvars <- pruneTyVars tydecl + ; bindTyVarsRn syn_doc tyvars $ \ tyvars' -> do + { name' <- if isFamInstDecl tydecl then lookupLocatedOccRn name -- may be imported family else lookupLocatedTopBndrRn name ; typats' <- rnTyPats syn_doc typatsMaybe @@ -621,7 +726,7 @@ rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars, (if isFamInstDecl tydecl then unitFV (unLoc name') -- type instance => use else emptyFVs)) - } + } } where syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name) @@ -636,17 +741,16 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, { context' <- rnContext cls_doc context ; fds' <- rnFds cls_doc fds ; (ats', ats_fvs) <- rnATs ats - ; sigs' <- renameSigs okClsDclSig sigs + ; sigs' <- renameSigs Nothing okClsDclSig sigs ; return (tyvars', context', fds', ats', ats_fvs, sigs') } - -- Check for duplicates among the associated types - ; let at_rdr_names_w_locs = [tcdLName ty | L _ ty <- ats] - ; checkDupNames at_doc at_rdr_names_w_locs + -- No need to check for duplicate associated type decls + -- since that is done by RnNames.extendGlobalRdrEnvRn -- Check the signatures -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). ; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs] - ; checkDupNames sig_doc sig_rdr_names_w_locs + ; checkDupRdrNames sig_doc sig_rdr_names_w_locs -- 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 @@ -663,10 +767,11 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, ; (mbinds', meth_fvs) <- extendTyVarEnvForMethodBinds tyvars' $ do { name_env <- getLocalRdrEnv - ; let meth_rdr_names_w_locs = collectHsBindLocatedBinders mbinds - gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds, + ; let gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds, not (unLoc tv `elemLocalRdrEnv` name_env) ] - ; checkDupNames meth_doc meth_rdr_names_w_locs + -- No need to check for duplicate method signatures + -- since that is done by RnNames.extendGlobalRdrEnvRn + -- and the methods are already in scope ; gen_tyvars <- newLocalsRn gen_rdr_tyvars_w_locs ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds } @@ -684,14 +789,13 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, meth_fvs `plusFV` ats_fvs) } where - meth_doc = text "In the default-methods for class" <+> ppr cname cls_doc = text "In the declaration for class" <+> ppr cname sig_doc = text "In the signatures for class" <+> ppr cname - at_doc = text "In the associated types for class" <+> ppr cname -badGadtStupidTheta tycon - = vcat [ptext SLIT("No context is allowed on a GADT-style data declaration"), - ptext SLIT("(You can put a context on each contructor, though.)")] +badGadtStupidTheta :: Located RdrName -> SDoc +badGadtStupidTheta _ + = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"), + ptext (sLit "(You can put a context on each contructor, though.)")] \end{code} %********************************************************* @@ -701,6 +805,37 @@ badGadtStupidTheta tycon %********************************************************* \begin{code} +-- Remove any duplicate type variables in family instances may have non-linear +-- left-hand sides. Complain if any, but the first occurence of a type +-- variable has a user-supplied kind signature. +-- +pruneTyVars :: TyClDecl RdrName -> RnM [LHsTyVarBndr RdrName] +pruneTyVars tydecl + | isFamInstDecl tydecl + = do { let pruned_tyvars = nubBy eqLTyVar tyvars + ; assertNoSigsInRepeats tyvars + ; return pruned_tyvars + } + | otherwise + = return tyvars + where + tyvars = tcdTyVars tydecl + + assertNoSigsInRepeats [] = return () + assertNoSigsInRepeats (tv:tvs) + = do { let offending_tvs = [ tv' | tv'@(L _ (KindedTyVar _ _)) <- tvs + , tv' `eqLTyVar` tv] + ; checkErr (null offending_tvs) $ + illegalKindSig (head offending_tvs) + ; assertNoSigsInRepeats tvs + } + + illegalKindSig tv + = hsep [ptext (sLit "Repeat variable occurrence may not have a"), + ptext (sLit "kind signature:"), quotes (ppr tv)] + + tv1 `eqLTyVar` tv2 = hsLTyVarLocName tv1 `eqLocated` hsLTyVarLocName tv2 + -- Although, we are processing type patterns here, all type variables will -- already be in scope (they are the same as in the 'tcdTyVars' field of the -- type declaration to which these patterns belong) @@ -710,7 +845,7 @@ rnTyPats _ Nothing = return Nothing rnTyPats doc (Just typats) = liftM Just $ rnLHsTypes doc typats rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name] -rnConDecls tycon condecls +rnConDecls _tycon condecls = mappM (wrapLocM rnConDecl) condecls rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name) @@ -724,7 +859,7 @@ rnConDecl (ConDecl name expl tvs cxt details res_ty mb_doc) -- For GADT syntax, the tvs are all the quantified tyvars -- Hence the 'filter' in the ResTyH98 case only ; let not_in_scope = not . (`elemLocalRdrEnv` name_env) . unLoc - arg_tys = hsConArgs details + arg_tys = hsConDeclArgTys details implicit_tvs = case res_ty of ResTyH98 -> filter not_in_scope $ get_rdr_tvs arg_tys @@ -737,13 +872,18 @@ rnConDecl (ConDecl name expl tvs cxt details res_ty mb_doc) ; bindTyVarsRn doc tvs' $ \new_tyvars -> do { new_context <- rnContext doc cxt - ; new_details <- rnConDetails doc details + ; new_details <- rnConDeclDetails doc details ; (new_details', new_res_ty) <- rnConResult doc new_details res_ty ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty mb_doc') }} where doc = text "In the definition of data constructor" <+> quotes (ppr name) get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys)) +rnConResult :: SDoc + -> HsConDetails (LHsType Name) [ConDeclField Name] + -> ResType RdrName + -> RnM (HsConDetails (LHsType Name) [ConDeclField Name], + ResType Name) rnConResult _ details ResTyH98 = return (details, ResTyH98) rnConResult doc details (ResTyGADT ty) = do @@ -752,31 +892,33 @@ rnConResult doc details (ResTyGADT ty) = do -- We can split it up, now the renamer has dealt with fixities case details of PrefixCon _xs -> ASSERT( null _xs ) return (PrefixCon arg_tys, ResTyGADT res_ty) - RecCon fields -> return (details, ResTyGADT ty') + RecCon _ -> return (details, ResTyGADT ty') InfixCon {} -> panic "rnConResult" -rnConDetails doc (PrefixCon tys) +rnConDeclDetails :: SDoc + -> HsConDetails (LHsType RdrName) [ConDeclField RdrName] + -> RnM (HsConDetails (LHsType Name) [ConDeclField Name]) +rnConDeclDetails doc (PrefixCon tys) = mappM (rnLHsType doc) tys `thenM` \ new_tys -> returnM (PrefixCon new_tys) -rnConDetails doc (InfixCon ty1 ty2) +rnConDeclDetails doc (InfixCon ty1 ty2) = rnLHsType doc ty1 `thenM` \ new_ty1 -> rnLHsType doc ty2 `thenM` \ new_ty2 -> returnM (InfixCon new_ty1 new_ty2) -rnConDetails doc (RecCon fields) - = checkDupNames doc field_names `thenM_` - mappM (rnField doc) fields `thenM` \ new_fields -> - returnM (RecCon new_fields) - where - field_names = [ name | HsRecField name _ _ <- fields ] +rnConDeclDetails doc (RecCon fields) + = do { new_fields <- mappM (rnField doc) fields + -- No need to check for duplicate fields + -- since that is done by RnNames.extendGlobalRdrEnvRn + ; return (RecCon new_fields) } --- Document comments are renamed to Nothing here -rnField doc (HsRecField name ty haddock_doc) +rnField :: SDoc -> ConDeclField RdrName -> RnM (ConDeclField Name) +rnField doc (ConDeclField name ty haddock_doc) = lookupLocatedTopBndrRn name `thenM` \ new_name -> rnLHsType doc ty `thenM` \ new_ty -> rnMbLHsDoc haddock_doc `thenM` \ new_haddock_doc -> - returnM (HsRecField new_name new_ty new_haddock_doc) + returnM (ConDeclField new_name new_ty new_haddock_doc) -- Rename family declarations -- @@ -794,7 +936,7 @@ rnFamily (tydecl@TyFamily {tcdFlavour = flavour, tcdLName = tycon, tcdTyVars = tyvars}) bindIdxVars = do { checkM (isDataFlavour flavour -- for synonyms, - || not (null tyvars)) $ addErr needOneIdx -- #indexes >= 1 + || not (null tyvars)) $ addErr needOneIdx -- no. of indexes >= 1 ; bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do { ; tycon' <- lookupLocatedTopBndrRn tycon ; returnM (TyFamily {tcdFlavour = flavour, tcdLName = tycon', @@ -802,10 +944,14 @@ rnFamily (tydecl@TyFamily {tcdFlavour = flavour, emptyFVs) } } where - isDataFlavour (DataFamily _) = True - isDataFlavour _ = False + isDataFlavour DataFamily = True + isDataFlavour _ = False +rnFamily d _ = pprPanic "rnFamily" (ppr d) +family_doc :: Located RdrName -> SDoc family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon) + +needOneIdx :: SDoc needOneIdx = text "Type family declarations requires at least one type index" -- Rename associated type declarations (in classes) @@ -844,15 +990,17 @@ rnATs ats = mapFvRn (wrapLocFstM rn_at) ats ; checkForDups ltvs } - rdrName `ltvElem` [] = False + _ `ltvElem` [] = False rdrName `ltvElem` (L _ tv:ltvs) | rdrName == hsTyVarName tv = True | otherwise = rdrName `ltvElem` ltvs +noPatterns :: SDoc noPatterns = text "Default definition for an associated synonym cannot have" <+> text "type pattern" -repeatedTyVar tv = ptext SLIT("Illegal repeated type variable") <+> +repeatedTyVar :: HsTyVarBndr RdrName -> SDoc +repeatedTyVar tv = ptext (sLit "Illegal repeated type variable") <+> quotes (ppr tv) -- This data decl will parse OK @@ -865,15 +1013,54 @@ repeatedTyVar tv = ptext SLIT("Illegal repeated type variable") <+> -- data T = :% Int Int -- from interface files, which always print in prefix form +checkConName :: RdrName -> TcRn () checkConName name = checkErr (isRdrDataCon name) (badDataCon name) +badDataCon :: RdrName -> SDoc badDataCon name - = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] + = hsep [ptext (sLit "Illegal data constructor name"), quotes (ppr name)] \end{code} %********************************************************* %* * +\subsection{Support code for type/data declarations} +%* * +%********************************************************* + +Get the mapping from constructors to fields for this module. +It's convenient to do this after the data type decls have been renamed +\begin{code} +extendRecordFieldEnv :: [LTyClDecl RdrName] -> TcM TcGblEnv +extendRecordFieldEnv decls + = do { tcg_env <- getGblEnv + ; field_env' <- foldrM get (tcg_field_env tcg_env) decls + ; return (tcg_env { tcg_field_env = field_env' }) } + where + -- we want to lookup: + -- (a) a datatype constructor + -- (b) a record field + -- knowing that they're from this module. + -- lookupLocatedTopBndrRn does this, because it does a lookupGreLocalRn, + -- which keeps only the local ones. + lookup x = do { x' <- lookupLocatedTopBndrRn x + ; return $ unLoc x'} + + get (L _ (TyData { tcdCons = cons })) env = foldrM get_con env cons + get _ env = return env + + get_con (L _ (ConDecl { con_name = con, con_details = RecCon flds })) + (RecFields env fld_set) + = do { con' <- lookup con + ; flds' <- mappM lookup (map cd_fld_name flds) + ; let env' = extendNameEnv env con' flds' + fld_set' = addListToNameSet fld_set flds' + ; return $ (RecFields env' fld_set') } + get_con _ env = return env +\end{code} + +%********************************************************* +%* * \subsection{Support code to rename types} %* * %********************************************************* @@ -889,8 +1076,11 @@ rnFds doc fds rnHsTyVars doc tys2 `thenM` \ tys2' -> returnM (tys1', tys2') -rnHsTyVars doc tvs = mappM (rnHsTyvar doc) tvs -rnHsTyvar doc tyvar = lookupOccRn tyvar +rnHsTyVars :: SDoc -> [RdrName] -> RnM [Name] +rnHsTyVars doc tvs = mappM (rnHsTyVar doc) tvs + +rnHsTyVar :: SDoc -> RdrName -> RnM Name +rnHsTyVar _doc tyvar = lookupOccRn tyvar \end{code} @@ -936,12 +1126,13 @@ rnSplice (HsSplice n expr) ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) } +checkTH :: Outputable a => a -> String -> RnM () #ifdef GHCI -checkTH e what = returnM () -- OK +checkTH _ _ = returnM () -- OK #else checkTH e what -- Raise an error in a stage-1 compiler - = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+> - ptext SLIT("illegal in a stage-1 compiler"), + = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+> + ptext (sLit "illegal in a stage-1 compiler"), nest 2 (ppr e)]) #endif \end{code}