compiler/typecheck/TcRules.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The AQUA Project, Glasgow University, 1993-1998
   4 %
   5
   6 TcRules: Typechecking transformation rules
   7
   8 \begin{code}
   9 module TcRules ( tcRules ) where
  10
  11 #include "HsVersions.h"
  12
  13 import HsSyn
  14 import TcRnMonad
  15 import TcSimplify
  16 import TcMType
  17 import TcType
  18 import TcHsType
  19 import TcExpr
  20 import TcEnv
  21 import Inst
  22 import Id
  23 import Name
  24 import SrcLoc
  25 import Outputable
  26 \end{code}
  27
  28 \begin{code}
  29 tcRules :: [LRuleDecl Name] -> TcM [LRuleDecl TcId]
  30 tcRules decls = mappM (wrapLocM tcRule) decls
  31
  32 tcRule :: RuleDecl Name -> TcM (RuleDecl TcId)
  33 tcRule (HsRule name act vars lhs fv_lhs rhs fv_rhs)
  34   = addErrCtxt (ruleCtxt name)                  $
  35     traceTc (ptext SLIT("---- Rule ------")
  36                  <+> ppr name)                  `thenM_`
  37     newFlexiTyVarTy openTypeKind                `thenM` \ rule_ty ->
  38
  39         -- Deal with the tyvars mentioned in signatures
  40     tcRuleBndrs vars (\ ids ->
  41                 -- Now LHS and RHS
  42         getLIE (tcMonoExpr lhs rule_ty) `thenM` \ (lhs', lhs_lie) ->
  43         getLIE (tcMonoExpr rhs rule_ty) `thenM` \ (rhs', rhs_lie) ->
  44         returnM (ids, lhs', rhs', lhs_lie, rhs_lie)
  45     )                           `thenM` \ (ids, lhs', rhs', lhs_lie, rhs_lie) ->
  46
  47                 -- Check that LHS has no overloading at all
  48     tcSimplifyRuleLhs lhs_lie   `thenM` \ (lhs_dicts, lhs_binds) ->
  49
  50         -- Gather the template variables and tyvars
  51     let
  52         tpl_ids = map instToId lhs_dicts ++ ids
  53
  54         -- IMPORTANT!  We *quantify* over any dicts that appear in the LHS
  55         -- Reason:
  56         --      a) The particular dictionary isn't important, because its value
  57         --         depends only on the type
  58         --              e.g     gcd Int $fIntegralInt
  59         --         Here we'd like to match against (gcd Int any_d) for any 'any_d'
  60         --
  61         --      b) We'd like to make available the dictionaries bound
  62         --         on the LHS in the RHS, so quantifying over them is good
  63         --         See the 'lhs_dicts' in tcSimplifyAndCheck for the RHS
  64
  65         -- We initially quantify over any tyvars free in *either* the rule
  66         --  *or* the bound variables.  The latter is important.  Consider
  67         --      ss (x,(y,z)) = (x,z)
  68         --      RULE:  forall v. fst (ss v) = fst v
  69         -- The type of the rhs of the rule is just a, but v::(a,(b,c))
  70         --
  71         -- We also need to get the free tyvars of the LHS; but we do that
  72         -- during zonking (see TcHsSyn.zonkRule)
  73         --
  74         forall_tvs = tyVarsOfTypes (rule_ty : map idType tpl_ids)
  75     in
  76         -- RHS can be a bit more lenient.  In particular,
  77         -- we let constant dictionaries etc float outwards
  78         --
  79         -- NB: tcSimplifyInferCheck zonks the forall_tvs, and
  80         --     knocks out any that are constrained by the environment
  81     tcSimplifyInferCheck (text "tcRule")
  82                          forall_tvs
  83                          lhs_dicts rhs_lie      `thenM` \ (forall_tvs1, rhs_binds) ->
  84     mappM zonkQuantifiedTyVar forall_tvs1       `thenM` \ forall_tvs2 ->
  85         -- This zonk is exactly the same as the one in TcBinds.tcBindWithSigs
  86
  87     returnM (HsRule name act
  88                     (map (RuleBndr . noLoc) (forall_tvs2 ++ tpl_ids))   -- yuk
  89                     (mkHsDictLet lhs_binds lhs') fv_lhs
  90                     (mkHsDictLet rhs_binds rhs') fv_rhs)
  91
  92
  93 tcRuleBndrs [] thing_inside = thing_inside []
  94 tcRuleBndrs (RuleBndr var : vars) thing_inside
  95   = do  { ty <- newFlexiTyVarTy openTypeKind
  96         ; let id = mkLocalId (unLoc var) ty
  97         ; tcExtendIdEnv [id] $
  98           tcRuleBndrs vars (\ids -> thing_inside (id:ids)) }
  99 tcRuleBndrs (RuleBndrSig var rn_ty : vars) thing_inside
 100 --  e.g         x :: a->a
 101 --  The tyvar 'a' is brought into scope first, just as if you'd written
 102 --              a::*, x :: a->a
 103   = do  { let ctxt = RuleSigCtxt (unLoc var)
 104         ; (tyvars, ty) <- tcHsPatSigType ctxt rn_ty
 105         ; let skol_tvs = tcSkolSigTyVars (SigSkol ctxt) tyvars
 106               id_ty = substTyWith tyvars (mkTyVarTys skol_tvs) ty
 107               id = mkLocalId (unLoc var) id_ty
 108         ; tcExtendTyVarEnv skol_tvs $
 109           tcExtendIdEnv [id] $
 110           tcRuleBndrs vars (\ids -> thing_inside (id:ids)) }
 111
 112 ruleCtxt name = ptext SLIT("When checking the transformation rule") <+>
 113                 doubleQuotes (ftext name)
 114 \end{code}
 115
 116
 117
 118