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 #include "HsVersions.h"
   8
   9 module TcGRHSs ( tcGRHSsAndBinds ) where
  10
  11 IMP_Ubiq(){-uitous-}
  12 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
  13 IMPORT_DELOOPER(TcLoop) -- for paranoia checking
  14 #endif
  15
  16 import HsSyn            ( GRHSsAndBinds(..), GRHS(..), MonoBinds, Stmt, DoOrListComp(..),
  17                           HsExpr, HsBinds(..), InPat, OutPat, Sig, Fake )
  18 import RnHsSyn          ( SYN_IE(RenamedGRHSsAndBinds), SYN_IE(RenamedGRHS) )
  19 import TcHsSyn          ( SYN_IE(TcGRHSsAndBinds), SYN_IE(TcGRHS), TcIdOcc(..) )
  20
  21 import TcMonad
  22 import Inst             ( Inst, SYN_IE(LIE), plusLIE )
  23 import TcBinds          ( tcBindsAndThen )
  24 import TcExpr           ( tcExpr, tcStmt )
  25 import TcType           ( SYN_IE(TcType) )
  26 import Unify            ( unifyTauTy )
  27
  28 import TysWiredIn       ( boolTy )
  29 \end{code}
  30
  31 \begin{code}
  32 tcGRHSs :: [RenamedGRHS] -> TcM s ([TcGRHS s], LIE s, TcType s)
  33
  34 tcGRHSs [grhs]
  35   = tcGRHS grhs         `thenTc` \ (grhs', lie, ty) ->
  36     returnTc ([grhs'], lie, ty)
  37
  38 tcGRHSs (grhs:grhss)
  39   = tcGRHS  grhs        `thenTc` \ (grhs',  lie1, ty1) ->
  40     tcGRHSs grhss       `thenTc` \ (grhss', lie2, ty2) ->
  41     unifyTauTy ty1 ty2  `thenTc_`
  42     returnTc (grhs' : grhss', lie1 `plusLIE` lie2, ty1)
  43
  44
  45 tcGRHS (OtherwiseGRHS expr locn)
  46   = tcAddSrcLoc locn     $
  47     tcExpr expr `thenTc` \ (expr, lie, ty) ->
  48     returnTc (OtherwiseGRHS expr locn, lie, ty)
  49
  50 tcGRHS (GRHS guard expr locn)
  51   = tcAddSrcLoc locn            $
  52     tc_stmts  guard     `thenTc` \ ((guard', expr', ty), lie) ->
  53     returnTc (GRHS guard' expr' locn, lie, ty)
  54   where
  55     tc_stmts []           = tcExpr expr         `thenTc` \ (expr2, expr_lie, expr_ty) ->
  56                             returnTc (([], expr2, expr_ty), expr_lie)
  57     tc_stmts (stmt:stmts) = tcStmt tcExpr ListComp (\x->x) combine stmt $
  58                             tc_stmts stmts
  59
  60     combine stmt _ (stmts, expr, ty) = (stmt:stmts, expr, ty)
  61 \end{code}
  62
  63
  64 @tcGRHSsAndBinds@ typechecks (grhss where binds), returning suitable
  65 pieces.
  66
  67 \begin{code}
  68 tcGRHSsAndBinds :: RenamedGRHSsAndBinds
  69                 -> TcM s (TcGRHSsAndBinds s, LIE s, TcType s)
  70
  71 tcGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
  72   = tcBindsAndThen
  73          combiner binds
  74          (tcGRHSs grhss         `thenTc` \ (grhss', lie, ty) ->
  75           returnTc (GRHSsAndBindsOut grhss' EmptyBinds ty, lie)
  76          )                      `thenTc` \ (grhss_and_binds'@(GRHSsAndBindsOut _ _ result_ty), lie) ->
  77     returnTc (grhss_and_binds', lie, result_ty)
  78   where
  79     combiner binds1 (GRHSsAndBindsOut grhss binds2 ty)
  80         = GRHSsAndBindsOut grhss (binds1 `ThenBinds` binds2) ty
  81 \end{code}