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