ghc/compiler/typecheck/TcGRHSs.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[TcGRHSs]{Typecheck guarded right-hand-sides}
   5
   6 \begin{code}
   7 module TcGRHSs ( tcGRHSsAndBinds ) where
   8
   9 import TcMonad          -- typechecking monad machinery
  10 import AbsSyn           -- the stuff being typechecked
  11
  12 import AbsPrel          ( boolTy )
  13 import E                ( growE_LVE, E, LVE(..), TCE(..), UniqFM, CE(..) )
  14                         -- TCE and CE for pragmas only
  15 import Errors           ( UnifyErrContext(..) )
  16 import LIE              ( plusLIE, LIE )
  17 import TcBinds          ( tcLocalBindsAndThen )
  18 import TcExpr           ( tcExpr )
  19 import Unify            ( unifyTauTy )
  20 import Util             -- pragmas only
  21 \end{code}
  22
  23 \begin{code}
  24 tcGRHSs :: E -> [RenamedGRHS] -> TcM ([TypecheckedGRHS], LIE, UniType)
  25
  26 tcGRHSs e [grhs]
  27   = tcGRHS e grhs       `thenTc` \ (grhs', lie, ty) ->
  28     returnTc ([grhs'], lie, ty)
  29
  30 tcGRHSs e gs@(grhs:grhss)
  31   = tcGRHS  e grhs      `thenTc` \ (grhs',  lie1, ty1) ->
  32     tcGRHSs e grhss     `thenTc` \ (grhss', lie2, ty2) ->
  33
  34     unifyTauTy ty1 ty2 (GRHSsBranchCtxt gs) `thenTc_`
  35
  36     returnTc (grhs' : grhss', lie1 `plusLIE` lie2, ty1)
  37
  38
  39 tcGRHS e (OtherwiseGRHS expr locn)
  40   = addSrcLocTc locn     (
  41     tcExpr e expr       `thenTc` \ (expr, lie, ty) ->
  42     returnTc (OtherwiseGRHS expr locn, lie, ty)
  43     )
  44
  45 tcGRHS e (GRHS guard expr locn)
  46   = addSrcLocTc locn             (
  47     tcExpr e guard              `thenTc` \ (guard2, guard_lie, guard_ty) ->
  48
  49     unifyTauTy guard_ty boolTy (GRHSsGuardCtxt guard) `thenTc_`
  50
  51     tcExpr e expr               `thenTc` \ (expr2, expr_lie, expr_ty) ->
  52
  53     returnTc (GRHS guard2 expr2 locn, plusLIE guard_lie expr_lie, expr_ty)
  54     )
  55 \end{code}
  56
  57
  58 @tcGRHSsAndBinds@ typechecks (grhss where binds), returning suitable
  59 pieces.
  60
  61 \begin{code}
  62 tcGRHSsAndBinds :: E
  63                 -> RenamedGRHSsAndBinds
  64                 -> TcM (TypecheckedGRHSsAndBinds, LIE, UniType)
  65
  66 tcGRHSsAndBinds e (GRHSsAndBindsIn grhss binds)
  67   = tcLocalBindsAndThen e
  68          combiner binds
  69          (\e -> tcGRHSs e grhss         `thenTc` (\ (grhss', lie, ty) ->
  70                 returnTc (GRHSsAndBindsOut grhss' EmptyBinds ty, lie, ty)
  71                 )
  72          )
  73   where
  74     combiner binds1 (GRHSsAndBindsOut grhss binds2 ty)
  75         = GRHSsAndBindsOut grhss (binds1 `ThenBinds` binds2) ty
  76 \end{code}