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