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