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 #include "HsVersions.h"
  10
  11 import HsSyn            ( HsBinds(..), GRHSsAndBinds(..), GRHS(..), DoOrListComp(..) )
  12 import RnHsSyn          ( RenamedGRHSsAndBinds, RenamedGRHS )
  13 import TcHsSyn          ( TcGRHSsAndBinds, TcGRHS )
  14
  15 import TcMonad
  16 import Inst             ( Inst, LIE, plusLIE )
  17 import TcBinds          ( tcBindsAndThen )
  18 import TcExpr           ( tcExpr, tcStmt )
  19 import TcType           ( TcType, newTyVarTy )
  20 import TcEnv            ( TcIdOcc(..) )
  21
  22 import TysWiredIn       ( boolTy )
  23 \end{code}
  24
  25 \begin{code}
  26 tcGRHSs :: TcType s -> [RenamedGRHS] -> TcM s ([TcGRHS s], LIE s)
  27
  28 tcGRHSs expected_ty [grhs]
  29   = tcGRHS expected_ty grhs             `thenTc` \ (grhs', lie) ->
  30     returnTc ([grhs'], lie)
  31
  32 tcGRHSs expected_ty (grhs:grhss)
  33   = tcGRHS  expected_ty grhs    `thenTc` \ (grhs',  lie1) ->
  34     tcGRHSs expected_ty grhss   `thenTc` \ (grhss', lie2) ->
  35     returnTc (grhs' : grhss', lie1 `plusLIE` lie2)
  36
  37 tcGRHS expected_ty (GRHS guard expr locn)
  38   = tcAddSrcLoc locn            $
  39     tcStmts guard               `thenTc` \ ((guard', expr'), lie) ->
  40     returnTc (GRHS guard' expr' locn, lie)
  41   where
  42     tcStmts []           = tcExpr expr expected_ty        `thenTc`    \ (expr2, expr_lie) ->
  43                            returnTc (([], expr2), expr_lie)
  44     tcStmts (stmt:stmts) = tcStmt tcExpr Guard (\x->x) combine stmt $
  45                            tcStmts stmts
  46
  47     combine stmt _ (stmts, expr) = (stmt:stmts, expr)
  48 \end{code}
  49
  50
  51 @tcGRHSsAndBinds@ typechecks (grhss where binds), returning suitable
  52 pieces.
  53
  54 \begin{code}
  55 tcGRHSsAndBinds :: TcType s                     -- Expected type of RHSs
  56                 -> RenamedGRHSsAndBinds
  57                 -> TcM s (TcGRHSsAndBinds s, LIE s)
  58
  59 -- Shortcut for common case
  60 tcGRHSsAndBinds expected_ty (GRHSsAndBindsIn grhss EmptyBinds)
  61   = tcGRHSs expected_ty grhss          `thenTc` \ (grhss', lie) ->
  62     returnTc (GRHSsAndBindsOut grhss' EmptyBinds expected_ty, lie)
  63
  64 tcGRHSsAndBinds expected_ty (GRHSsAndBindsIn grhss binds)
  65   = tcBindsAndThen
  66          combiner binds
  67          (tcGRHSs expected_ty grhss)
  68   where
  69     combiner is_rec binds grhss
  70         = GRHSsAndBindsOut grhss (MonoBind binds [] is_rec) expected_ty
  71 \end{code}