%
% (c) The University of Glasgow 2006
% (c) The AQUA Project, Glasgow University, 1993-1998
%
TcRules: Typechecking transformation rules
\begin{code}
module TcRules ( tcRules ) where
import HsSyn
import TcRnMonad
import TcSimplify
import TcMType
import TcType
import TcHsType
import TcExpr
import TcEnv
import Id
import Var ( Var )
import Name
import VarSet
import SrcLoc
import Outputable
import FastString
import Data.List( partition )
\end{code}
Note [Typechecking rules]
~~~~~~~~~~~~~~~~~~~~~~~~~
We *infer* the typ of the LHS, and use that type to *check* the type of
the RHS. That means that higher-rank rules work reasonably well. Here's
an example (test simplCore/should_compile/rule2.hs) produced by Roman:
foo :: (forall m. m a -> m b) -> m a -> m b
foo f = ...
bar :: (forall m. m a -> m a) -> m a -> m a
bar f = ...
{-# RULES "foo/bar" foo = bar #-}
He wanted the rule to typecheck.
\begin{code}
tcRules :: [LRuleDecl Name] -> TcM [LRuleDecl TcId]
tcRules decls = mapM (wrapLocM tcRule) decls
tcRule :: RuleDecl Name -> TcM (RuleDecl TcId)
tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
= addErrCtxt (ruleCtxt name) $
do { traceTc "---- Rule ------" (ppr name)
; vars <- tcRuleBndrs hs_bndrs
; let (id_bndrs, tv_bndrs) = partition isId vars
; (lhs', lhs_lie, rhs', rhs_lie, rule_ty)
<- tcExtendTyVarEnv tv_bndrs $
tcExtendIdEnv id_bndrs $
do { ((lhs', rule_ty), lhs_lie) <- captureConstraints (tcInferRho lhs)
; (rhs', rhs_lie) <- captureConstraints (tcMonoExpr rhs rule_ty)
; return (lhs', lhs_lie, rhs', rhs_lie, rule_ty) }
; (lhs_dicts, lhs_ev_binds, rhs_ev_binds)
<- simplifyRule name tv_bndrs lhs_lie rhs_lie
; let tpl_ids = lhs_dicts ++ id_bndrs
forall_tvs = tyVarsOfTypes (rule_ty : map idType tpl_ids)
; zonked_forall_tvs <- zonkTcTyVarsAndFV forall_tvs
; gbl_tvs <- tcGetGlobalTyVars
; qtvs <- zonkQuantifiedTyVars $
varSetElems (zonked_forall_tvs `minusVarSet` gbl_tvs)
; return (HsRule name act
(map (RuleBndr . noLoc) (qtvs ++ tpl_ids))
(mkHsDictLet lhs_ev_binds lhs') fv_lhs
(mkHsDictLet rhs_ev_binds rhs') fv_rhs) }
tcRuleBndrs :: [RuleBndr Name] -> TcM [Var]
tcRuleBndrs []
= return []
tcRuleBndrs (RuleBndr var : rule_bndrs)
= do { ty <- newFlexiTyVarTy openTypeKind
; vars <- tcRuleBndrs rule_bndrs
; return (mkLocalId (unLoc var) ty : vars) }
tcRuleBndrs (RuleBndrSig var rn_ty : rule_bndrs)
= do { let ctxt = FunSigCtxt (unLoc var)
; (tyvars, ty) <- tcHsPatSigType ctxt rn_ty
; let skol_tvs = tcSuperSkolTyVars tyvars
id_ty = substTyWith tyvars (mkTyVarTys skol_tvs) ty
id = mkLocalId (unLoc var) id_ty
; vars <- tcExtendTyVarEnv skol_tvs $
tcRuleBndrs rule_bndrs
; return (skol_tvs ++ id : vars) }
ruleCtxt :: FastString -> SDoc
ruleCtxt name = ptext (sLit "When checking the transformation rule") <+>
doubleQuotes (ftext name)
\end{code}