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     getInstLoc (SigOrigin (RuleSkol name))      `thenM` \ loc ->
  82     tcSimplifyInferCheck loc
  83                          forall_tvs
  84                          lhs_dicts rhs_lie      `thenM` \ (forall_tvs1, rhs_binds) ->
  85     mappM zonkQuantifiedTyVar forall_tvs1       `thenM` \ forall_tvs2 ->
  86         -- This zonk is exactly the same as the one in TcBinds.tcBindWithSigs
  87
  88     returnM (HsRule name act
  89                     (map (RuleBndr . noLoc) (forall_tvs2 ++ tpl_ids))   -- yuk
  90                     (mkHsDictLet lhs_binds lhs') fv_lhs
  91                     (mkHsDictLet rhs_binds rhs') fv_rhs)
  92
  93
  94 tcRuleBndrs [] thing_inside = thing_inside []
  95 tcRuleBndrs (RuleBndr var : vars) thing_inside
  96   = do  { ty <- newFlexiTyVarTy openTypeKind
  97         ; let id = mkLocalId (unLoc var) ty
  98         ; tcExtendIdEnv [id] $
  99           tcRuleBndrs vars (\ids -> thing_inside (id:ids)) }
 100 tcRuleBndrs (RuleBndrSig var rn_ty : vars) thing_inside
 101 --  e.g         x :: a->a
 102 --  The tyvar 'a' is brought into scope first, just as if you'd written
 103 --              a::*, x :: a->a
 104   = do  { let ctxt = FunSigCtxt (unLoc var)
 105         ; (tyvars, ty) <- tcHsPatSigType ctxt rn_ty
 106         ; let skol_tvs = tcSkolSigTyVars (SigSkol ctxt) tyvars
 107               id_ty = substTyWith tyvars (mkTyVarTys skol_tvs) ty
 108               id = mkLocalId (unLoc var) id_ty
 109         ; tcExtendTyVarEnv skol_tvs $
 110           tcExtendIdEnv [id] $
 111           tcRuleBndrs vars (\ids -> thing_inside (id:ids)) }
 112
 113 ruleCtxt name = ptext SLIT("When checking the transformation rule") <+>
 114                 doubleQuotes (ftext name)
 115 \end{code}
 116
 117
 118
 119