From b55a5d5d522bb70a5a3e309fef4bb62eca8a4e6b Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 24 Oct 2000 17:09:44 +0000 Subject: [PATCH] [project @ 2000-10-24 17:09:44 by simonpj] Stuff to do with Rules; may not compile --- ghc/compiler/deSugar/Desugar.lhs | 5 +-- ghc/compiler/main/HscTypes.lhs | 21 +++++++----- ghc/compiler/main/MkIface.lhs | 4 +-- ghc/compiler/prelude/TysWiredIn.lhs | 4 +-- ghc/compiler/rename/RnSource.lhs | 7 ---- ghc/compiler/specialise/Rules.lhs | 40 +++++++++++++---------- ghc/compiler/typecheck/TcInstDcls.lhs | 20 ++++++------ ghc/compiler/typecheck/TcModule.lhs | 58 +++++++++++++++++++-------------- ghc/compiler/typecheck/TcMonad.lhs | 2 +- ghc/compiler/typecheck/TcRules.lhs | 40 ++++++++++++++++------- 10 files changed, 113 insertions(+), 88 deletions(-) diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 5090a9e..1d95438 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -48,7 +48,7 @@ deSugar :: DynFlags -> UniqSupply -> HomeSymbolTable -> TcResults - -> IO ([CoreBind], [ProtoCoreRule], SDoc, SDoc, [CoreBndr]) + -> IO ([CoreBind], RuleEnv, SDoc, SDoc, [CoreBndr]) deSugar dflags mod_name us hst (TcResults {tc_env = global_val_env, @@ -110,9 +110,6 @@ ppr_ds_rules rules \begin{code} dsRule :: IdSet -> TypecheckedRuleDecl -> DsM ProtoCoreRule -dsRule in_scope (IfaceRuleOut fn rule) - = returnDs (ProtoCoreRule False {- non-local -} fn rule) - dsRule in_scope (HsRule name sig_tvs vars lhs rhs loc) = putSrcLocDs loc $ ds_lhs all_vars lhs `thenDs` \ (fn, args) -> diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index f2e10d9..02da223 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -30,6 +30,7 @@ module HscTypes ( Deprecations(..), lookupDeprec, InstEnv, ClsInstEnv, DFunId, + PackageInstEnv, PackageRuleBase, GlobalRdrEnv, RdrAvailInfo, @@ -148,7 +149,7 @@ data ModDetails -- The next three fields are created by the typechecker md_types :: TypeEnv, md_insts :: [DFunId], -- Dfun-ids for the instances in this module - md_rules :: RuleEnv -- Domain may include Ids from other modules + md_rules :: RuleBase -- Domain may include Ids from other modules } \end{code} @@ -157,7 +158,7 @@ emptyModDetails :: ModDetails emptyModDetails = ModDetails { md_types = emptyTypeEnv, md_insts = [], - md_rules = emptyRuleEnv + md_rules = emptyRuleBase } emptyModIface :: Module -> ModIface @@ -299,12 +300,9 @@ lookupDeprec iface name DeprecSome env -> lookupNameEnv env name type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class + type ClsInstEnv = [(TyVarSet, [Type], DFunId)] -- The instances for a particular class type DFunId = Id - -type RuleEnv = NameEnv [CoreRule] - -emptyRuleEnv = emptyVarEnv \end{code} @@ -381,14 +379,18 @@ data PersistentCompilerState = PCS { pcs_PIT :: PackageIfaceTable, -- Domain = non-home-package modules -- the mi_decls component is empty + pcs_PST :: PackageSymbolTable, -- Domain = non-home-package modules -- except that the InstEnv components is empty - pcs_insts :: InstEnv, -- The total InstEnv accumulated from all + + pcs_insts :: PackageInstEnv, -- The total InstEnv accumulated from all -- the non-home-package modules - pcs_rules :: RuleEnv, -- Ditto RuleEnv + + pcs_rules :: PackageRuleEnv, -- Ditto RuleEnv pcs_PRS :: PersistentRenamerState } + \end{code} The @PersistentRenamerState@ persists across successive calls to the @@ -411,6 +413,9 @@ It contains: interface files but not yet sucked in, renamed, and typechecked \begin{code} +type PackageRuleBase = RuleBase +type PackageInstEnv = InstEnv + data PersistentRenamerState = PRS { prsOrig :: OrigNameEnv, prsDecls :: DeclsMap, diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index d08264f..601cf98 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -69,8 +69,8 @@ import List ( partition ) \begin{code} completeModDetails :: ModDetails -> [CoreBind] -> [Id] -- Final bindings, plus the top-level Ids from the - -- code generator; they have authoritative arity info - -> [ProtoCoreRule] -- Tidy orphan rules + -- code generator; they have authoritative arity info + -> [ProtoCoreRule] -- Tidy orphan rules -> ModDetails completeIface :: Maybe ModIface -- The old interface, if we have it diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 9699b61..85b7c30 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -102,9 +102,9 @@ import TyCon ( TyCon, AlgTyConFlavour(..), tyConDataCons, mkTupleTyCon, isUnLiftedTyCon, mkAlgTyConRep ) -import BasicTypes ( Arity, RecFlag(..), EP(..), Boxity(..), isBoxed ) +import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed ) -import Type ( Type, mkTyConTy, mkTyConApp, mkSigmaTy, mkTyVarTys, +import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTys, mkArrowKinds, boxedTypeKind, unboxedTypeKind, splitTyConApp_maybe, repType, TauType, ClassContext ) diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 1557d39..e3ceb96 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -221,13 +221,6 @@ rnRuleDecl (IfaceRule rule_name vars fn args rhs src_loc) returnRn (IfaceRule rule_name vars' fn' args' rhs' src_loc, (fvs1 `plusFV` fvs2) `addOneFV` fn') -rnRuleDecl (IfaceRuleOut fn rule) - -- This one is used for BuiltInRules - -- The rule itself is already done, but the thing - -- to attach it to is not. - = lookupOccRn fn `thenRn` \ fn' -> - returnRn (IfaceRuleOut fn' rule, unitFV fn') - rnRuleDecl (HsRule rule_name tvs vars lhs rhs src_loc) = ASSERT( null tvs ) pushSrcLocRn src_loc $ diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index aa47275..ab1436b 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -5,7 +5,8 @@ \begin{code} module Rules ( - RuleBase, prepareLocalRuleBase, prepareOrphanRuleBase, + RuleBase, emptyRuleBase, extendRuleBase, extendRuleBaseList, + prepareLocalRuleBase, prepareOrphanRuleBase, unionRuleBase, lookupRule, addRule, addIdSpecialisations, ProtoCoreRule(..), pprProtoCoreRule, pprRuleBase, localRule, orphanRule @@ -476,9 +477,26 @@ orphanRule (ProtoCoreRule local fn _) %************************************************************************ \begin{code} -type RuleBase = (IdSet, -- Imported Ids that have rules attached - IdSet) -- Ids (whether local or imported) mentioned on - -- LHS of some rule; these should be black listed +data RuleBase = RuleBase (IdEnv CoreRules) -- Maps an Id to its rules + IdSet -- Ids (whether local or imported) mentioned on + -- LHS of some rule; these should be black listed + +emptyRuleBase = RuleBase emptyVarEnv emptyVarSet + +extendRuleBaseList :: RuleBase -> [(Name,CoreRule)] -> RuleBase +extendRuleBaseList rule_base new_guys + = foldr extendRuleBase rule_base new_guys + +extendRuleBase :: RuleBase -> (Name,CoreRule) -> RuleBase +extendRuleBase (RuleBase rule_env rule_fvs) (id, rule) + = RuleBase (extendVarEnv rule_env id (addRule id rules_for_id rule)) + (rule_fvs `unionVarSet` extendVarSet lhs_fvs id) + where + rules_for_id = case lookupWithDefaultVarEnv rule_env emptyCoreRules id + + lhs_fvs = ruleSomeLhsFreeVars isId rule + -- Find *all* the free Ids of the LHS, not just + -- locally defined ones!! unionRuleBase (rule_ids1, black_ids1) (rule_ids2, black_ids2) = (plusUFM_C merge_rules rule_ids1 rule_ids2, @@ -507,7 +525,7 @@ prepareLocalRuleBase :: [CoreBind] -> [ProtoCoreRule] -> ([CoreBind], RuleBase) prepareLocalRuleBase binds local_rules = (map zap_bind binds, (imported_id_rule_ids, rule_lhs_fvs)) where - (rule_ids, rule_lhs_fvs) = foldr add_rule (emptyVarSet, emptyVarSet) local_rules + (rule_ids, rule_lhs_fvs) = foldr add_rule emptyRuleBase local_rules imported_id_rule_ids = filterVarSet (not . isLocallyDefined) rule_ids -- rule_fvs is the set of all variables mentioned in this module's rules @@ -535,18 +553,6 @@ prepareLocalRuleBase binds local_rules Just bndr' -> setIdNoDiscard bndr' Nothing | bndr `elemVarSet` rule_fvs -> setIdNoDiscard bndr | otherwise -> bndr - -add_rule (ProtoCoreRule _ id rule) - (rule_id_set, rule_fvs) - = (rule_id_set `extendVarSet` new_id, - rule_fvs `unionVarSet` extendVarSet lhs_fvs id) - where - new_id = case lookupVarSet rule_id_set id of - Just id' -> addRuleToId id' rule - Nothing -> addRuleToId id rule - lhs_fvs = ruleSomeLhsFreeVars isId rule - -- Find *all* the free Ids of the LHS, not just - -- locally defined ones!! addRuleToId id rule = setIdSpecialisation id (addRule id (idSpecialisation id) rule) diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 12e853d..b2298bf 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -39,7 +39,8 @@ import TcMonoType ( tcTyVars, tcHsSigType, kcHsSigType ) import TcSimplify ( tcSimplifyAndCheck ) import TcType ( zonkTcSigTyVars ) import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, DFunId, - ModDetails(..) ) + ModDetails(..), PackageInstEnv, PersistentRenamerState + ) import Bag ( unionManyBags ) import Class ( Class, DefMeth(..), classBigSig ) @@ -160,16 +161,17 @@ and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm. Gather up the instance declarations from their various sources \begin{code} -tcInstDecls1 :: PersistentCompilerState +tcInstDecls1 :: PackageInstEnv + -> PersistentRenamerState -> HomeSymbolTable -- Contains instances -> TcEnv -- Contains IdInfo for dfun ids -> (Name -> Maybe Fixity) -- for deriving Show and Read -> Module -- Module for deriving -> [TyCon] -> [RenamedHsDecl] - -> TcM (PersistentCompilerState, InstEnv, [InstInfo], RenamedHsBinds) + -> TcM (PackageInstEnv, InstEnv, [InstInfo], RenamedHsBinds) -tcInstDecls1 pcs hst unf_env get_fixity mod local_tycons decls +tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod local_tycons decls = let inst_decls = [inst_decl | InstD inst_decl <- decls] clas_decls = [clas_decl | TyClD clas_decl <- decls, isClassDecl clas_decl] @@ -195,7 +197,7 @@ tcInstDecls1 pcs hst unf_env get_fixity mod local_tycons decls imported_inst_info hst_dfuns = foldModuleEnv ((++) . md_insts) [] hst in - addInstDFuns (pcs_insts pcs) imported_dfuns `thenNF_Tc` \ inst_env1 -> + addInstDFuns inst_env0 imported_dfuns `thenNF_Tc` \ inst_env1 -> addInstDFuns inst_env1 hst_dfuns `thenNF_Tc` \ inst_env2 -> addInstInfos inst_env2 local_inst_info `thenNF_Tc` \ inst_env3 -> addInstInfos inst_env3 generic_inst_info `thenNF_Tc` \ inst_env4 -> @@ -205,12 +207,10 @@ tcInstDecls1 pcs hst unf_env get_fixity mod local_tycons decls -- we ignore deriving decls from interfaces! -- This stuff computes a context for the derived instance decl, so it -- needs to know about all the instances possible; hecne inst_env4 - tcDeriving (pcs_PRS pcs) mod inst_env4 get_fixity local_tycons - `thenTc` \ (deriv_inst_info, deriv_binds) -> - addInstInfos inst_env4 deriv_inst_info - `thenNF_Tc` \ final_inst_env -> + tcDeriving prs mod inst_env4 get_fixity local_tycons `thenTc` \ (deriv_inst_info, deriv_binds) -> + addInstInfos inst_env4 deriv_inst_info `thenNF_Tc` \ final_inst_env -> - returnTc (pcs { pcs_insts = inst_env1 }, + returnTc (inst_env1, final_inst_env, generic_inst_info ++ deriv_inst_info ++ local_inst_info, deriv_binds) diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index ab16194..585f8af 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -12,9 +12,9 @@ module TcModule ( #include "HsVersions.h" import CmdLineOpts ( DynFlag(..), DynFlags, opt_PprStyle_Debug ) -import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..) ) +import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..) ) import HsTypes ( toHsType ) -import RnHsSyn ( RenamedHsModule, RenamedHsDecl ) +import RnHsSyn ( RenamedHsDecl ) import TcHsSyn ( TypecheckedMonoBinds, TypecheckedForeignDecl, TypecheckedRuleDecl, zonkTopBinds, zonkForeignExports, zonkRules @@ -70,9 +70,11 @@ data TcResults = TcResults { tc_pcs :: PersistentCompilerState, -- Augmented with imported information, -- (but not stuff from this module) - tc_env :: TypeEnv, -- The TypeEnv just for the stuff from this module - tc_insts :: [DFunId], -- Instances, just for this module - tc_binds :: TypecheckedMonoBinds, + + -- All these fields have info *just for this module* + tc_env :: TypeEnv, -- The top level TypeEnv + tc_insts :: [DFunId], -- Instances + tc_binds :: TypecheckedMonoBinds, -- Bindings tc_fords :: [TypecheckedForeignDecl], -- Foreign import & exports. tc_rules :: [TypecheckedRuleDecl] -- Transformation rules } @@ -82,33 +84,35 @@ typecheckModule :: DynFlags -> Module -> PersistentCompilerState - -> HomeSymbolTable - -> HomeIfaceTable - -> PackageIfaceTable + -> HomeSymbolTable -> HomeIfaceTable -> [RenamedHsDecl] -> IO (Maybe TcResults) -typecheckModule dflags this_mod pcs hst hit pit decls +typecheckModule dflags this_mod pcs hst hit decls = do env <- initTcEnv global_symbol_table (maybe_result, (errs,warns)) <- initTc dflags env tc_module - let maybe_tc_result :: Maybe TcResults - maybe_tc_result = mapMaybe snd maybe_result + let { maybe_tc_result :: Maybe TcResults ; + maybe_tc_result = case maybe_result of + Nothing -> Nothing + Just (_,r) -> Just r } - printErrorsAndWarnings (errs,warns) - printTcDump dflags maybe_tc_result + printErrorsAndWarnings (errs,warns) + printTcDump dflags maybe_tc_result - if isEmptyBag errs then - return Nothing - else - return maybe_tc_result + if isEmptyBag errs then + return Nothing + else + return maybe_tc_result where global_symbol_table = pcs_PST pcs `plusModuleEnv` hst tc_module :: TcM (TcEnv, TcResults) tc_module = fixTc (\ ~(unf_env ,_) -> tcModule pcs hst get_fixity this_mod decls unf_env) + pit = pcs_PIT pcs + get_fixity :: Name -> Maybe Fixity get_fixity nm = lookupTable hit pit nm `thenMaybe` \ iface -> lookupNameEnv (mi_fixities iface) nm @@ -147,8 +151,9 @@ tcModule pcs hst get_fixity this_mod decls unf_env in -- Typecheck the instance decls, includes deriving - tcInstDecls1 pcs hst unf_env get_fixity this_mod - local_tycons decls `thenTc` \ (pcs_with_insts, inst_env, inst_info, deriv_binds) -> + tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs) + hst unf_env get_fixity this_mod + local_tycons decls `thenTc` \ (new_pcs_insts, inst_env, local_inst_info, deriv_binds) -> tcSetInstEnv inst_env $ -- Default declarations @@ -199,9 +204,9 @@ tcModule pcs hst get_fixity this_mod decls unf_env -- Second pass over class and instance declarations, -- to compile the bindings themselves. - tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) -> + tcInstDecls2 local_inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) -> tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) -> - tcRules decls `thenNF_Tc` \ (lie_rules, rules) -> + tcRules (pcs_rules pcs) decls `thenNF_Tc` \ (new_pcs_rules, lie_rules, local_rules) -> -- Deal with constant or ambiguous InstIds. How could -- there be ambiguous ones? They can only arise if a @@ -236,7 +241,7 @@ tcModule pcs hst get_fixity this_mod decls unf_env tcSetEnv final_env $ -- zonkTopBinds puts all the top-level Ids into the tcGEnv zonkForeignExports foe_decls `thenNF_Tc` \ foe_decls' -> - zonkRules rules `thenNF_Tc` \ rules' -> + zonkRules local_rules `thenNF_Tc` \ local_rules' -> let groups :: FiniteMap Module TypeEnv @@ -249,13 +254,16 @@ tcModule pcs hst get_fixity this_mod decls unf_env new_pst = extendTypeEnv (pcs_PST pcs) (delFromFM groups this_mod) final_pcs :: PersistentCompilerState - final_pcs = pcs_with_insts {pcs_PST = new_pst} + final_pcs = pcs { pcs_PST = new_pst, + pcs_insts = new_pcs_insts, + pcs_rules = new_pcs_rules + } in - returnTc (final_env, -- WAS: really_final_env, + returnTc (final_env, TcResults { tc_pcs = final_pcs, tc_env = local_type_env, tc_binds = all_binds', - tc_insts = map iDFunId inst_info, + tc_insts = map iDFunId local_inst_info, tc_fords = foi_decls ++ foe_decls', tc_rules = rules' }) diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index 2a15234..7432dc7 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -62,7 +62,7 @@ import VarSet ( TyVarSet ) import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply, splitUniqSupply, mkSplitUniqSupply, UniqSM, initUs_ ) -import SrcLoc ( SrcLoc ) +import SrcLoc ( SrcLoc, noSrcLoc ) import FiniteMap ( FiniteMap, lookupFM, addToFM, emptyFM ) import UniqFM ( emptyUFM ) import Unique ( Unique ) diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index fa48203..3e3e90f 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -10,7 +10,8 @@ module TcRules ( tcRules ) where import HsSyn ( HsDecl(..), RuleDecl(..), RuleBndr(..) ) import CoreSyn ( CoreRule(..) ) -import RnHsSyn ( RenamedHsDecl ) +import RnHsSyn ( RenamedHsDecl, RenamedRuleDecl ) +import HscTypes ( PackageRuleEnv ) import TcHsSyn ( TypecheckedRuleDecl, mkHsLet ) import TcMonad import TcSimplify ( tcSimplifyToDicts, tcSimplifyAndCheck ) @@ -19,33 +20,44 @@ import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar ) import TcMonoType ( kcHsSigType, tcHsSigType, tcTyVars, checkSigTyVars ) import TcExpr ( tcExpr ) import TcEnv ( tcExtendLocalValEnv, tcExtendTyVarEnv ) -import Inst ( LIE, emptyLIE, plusLIEs, instToId ) +import Rules ( extendRuleBase ) +import Inst ( LIE, plusLIEs, instToId ) import Id ( idType, idName, mkVanillaId ) +import Name ( Name, extendNameEnvList ) import VarSet import Type ( tyVarsOfTypes, openTypeKind ) import Bag ( bagToList ) +import List ( partition ) import Outputable \end{code} \begin{code} -tcRules :: [RenamedHsDecl] -> TcM (LIE, [TypecheckedRuleDecl]) -tcRules decls = mapAndUnzipTc tcRule [rule | RuleD rule <- decls] `thenTc` \ (lies, rules) -> - returnTc (plusLIEs lies, rules) +tcRules :: PackageRuleEnv -> [RenamedHsDecl] -> TcM (PackageRuleEnv, LIE, [TypecheckedRuleDecl]) +tcRules pkg_rule_env decls + = mapAndUnzipTc tcLocalRule local_rules `thenTc` \ (lies, new_local_rules) -> + mapTc tcIfaceRule imported_rules `thenTc` \ new_imported_rules -> + returnTc (extendRuleBaseList pkg_rule_env new_imported_rules, + plusLIEs lies, new_local_rules) + where + rule_decls = [rule | RuleD rule <- decls] + (imported_rules, local_rules) = partition is_iface_rule rule_decls + + is_iface_rule (IfaceRule _ _ _ _ _ _) = True + is_iface_rule other = False -tcRule (IfaceRule name vars fun args rhs src_loc) +tcIfaceRule :: RenamedRuleDecl -> TcM (Id, CoreRule) + -- No zonking necessary! +tcIfaceRule (IfaceRule name vars fun args rhs src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (ruleCtxt name) $ tcVar fun `thenTc` \ fun' -> tcCoreLamBndrs vars $ \ vars' -> mapTc tcCoreExpr args `thenTc` \ args' -> tcCoreExpr rhs `thenTc` \ rhs' -> - returnTc (emptyLIE, IfaceRuleOut fun' (Rule name vars' args' rhs')) + returnTc (fun', Rule name vars' args' rhs') -tcRule (IfaceRuleOut fun rule) - = tcVar fun `thenTc` \ fun' -> - returnTc (emptyLIE, IfaceRuleOut fun' rule) - -tcRule (HsRule name sig_tvs vars lhs rhs src_loc) +tcLocalRule :: RenamedRuleDecl -> TcM (LIE, TypecheckedRuleDecl) +tcLocalRule (HsRule name sig_tvs vars lhs rhs src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (ruleCtxt name) $ newTyVarTy openTypeKind `thenNF_Tc` \ rule_ty -> @@ -111,3 +123,7 @@ tcRule (HsRule name sig_tvs vars lhs rhs src_loc) ruleCtxt name = ptext SLIT("When checking the transformation rule") <+> doubleQuotes (ptext name) \end{code} + + + + -- 1.7.10.4