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