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 )
  20 \end{code}
  21
  22 \begin{code}
  23 tcGRHSs :: TcType s -> [RenamedGRHS] -> TcM s ([TcGRHS s], LIE s)
  24
  25 tcGRHSs expected_ty [grhs]
  26   = tcGRHS expected_ty grhs             `thenTc` \ (grhs', lie) ->
  27     returnTc ([grhs'], lie)
  28
  29 tcGRHSs expected_ty (grhs:grhss)
  30   = tcGRHS  expected_ty grhs    `thenTc` \ (grhs',  lie1) ->
  31     tcGRHSs expected_ty grhss   `thenTc` \ (grhss', lie2) ->
  32     returnTc (grhs' : grhss', lie1 `plusLIE` lie2)
  33
  34 tcGRHS expected_ty (GRHS guard expr locn)
  35   = tcAddSrcLoc locn            $
  36     tcStmts guard               `thenTc` \ ((guard', expr'), lie) ->
  37     returnTc (GRHS guard' expr' locn, lie)
  38   where
  39     tcStmts []           = tcExpr expr expected_ty        `thenTc`    \ (expr2, expr_lie) ->
  40                            returnTc (([], expr2), expr_lie)
  41     tcStmts (stmt:stmts) = tcStmt tcExpr Guard (\x->x) combine stmt $
  42                            tcStmts stmts
  43
  44     combine stmt _ (stmts, expr) = (stmt:stmts, expr)
  45 \end{code}
  46
  47
  48 @tcGRHSsAndBinds@ typechecks (grhss where binds), returning suitable
  49 pieces.
  50
  51 \begin{code}
  52 tcGRHSsAndBinds :: TcType s                     -- Expected type of RHSs
  53                 -> RenamedGRHSsAndBinds
  54                 -> TcM s (TcGRHSsAndBinds s, LIE s)
  55
  56 -- Shortcut for common case
  57 tcGRHSsAndBinds expected_ty (GRHSsAndBindsIn grhss EmptyBinds)
  58   = tcGRHSs expected_ty grhss          `thenTc` \ (grhss', lie) ->
  59     returnTc (GRHSsAndBindsOut grhss' EmptyBinds expected_ty, lie)
  60
  61 tcGRHSsAndBinds expected_ty (GRHSsAndBindsIn grhss binds)
  62   = tcBindsAndThen
  63          combiner binds
  64          (tcGRHSs expected_ty grhss)
  65   where
  66     combiner is_rec binds grhss
  67         = GRHSsAndBindsOut grhss (MonoBind binds [] is_rec) expected_ty
  68 \end{code}