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