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) )
  20
  21 import TcMonad
  22 import Inst             ( Inst, SYN_IE(LIE), plusLIE )
  23 import Kind             ( mkTypeKind )
  24 import TcBinds          ( tcBindsAndThen )
  25 import TcExpr           ( tcExpr, tcStmt )
  26 import TcType           ( SYN_IE(TcType), TcIdOcc(..), newTyVarTy )
  27
  28 import TysWiredIn       ( boolTy )
  29 \end{code}
  30
  31 \begin{code}
  32 tcGRHSs :: TcType s -> [RenamedGRHS] -> TcM s ([TcGRHS s], LIE s)
  33
  34 tcGRHSs expected_ty [grhs]
  35   = tcGRHS expected_ty grhs             `thenTc` \ (grhs', lie) ->
  36     returnTc ([grhs'], lie)
  37
  38 tcGRHSs expected_ty (grhs:grhss)
  39   = tcGRHS  expected_ty grhs    `thenTc` \ (grhs',  lie1) ->
  40     tcGRHSs expected_ty grhss   `thenTc` \ (grhss', lie2) ->
  41     returnTc (grhs' : grhss', lie1 `plusLIE` lie2)
  42
  43
  44 tcGRHS expected_ty (OtherwiseGRHS expr locn)
  45   = tcAddSrcLoc locn     $
  46     tcExpr expr expected_ty        `thenTc`    \ (expr, lie) ->
  47     returnTc (OtherwiseGRHS expr locn, lie)
  48
  49 tcGRHS expected_ty (GRHS guard expr locn)
  50   = tcAddSrcLoc locn            $
  51     tc_stmts  guard     `thenTc` \ ((guard', expr'), lie) ->
  52     returnTc (GRHS guard' expr' locn, lie)
  53   where
  54     tc_stmts []           = tcExpr expr expected_ty       `thenTc`    \ (expr2, expr_lie) ->
  55                             returnTc (([], expr2), expr_lie)
  56     tc_stmts (stmt:stmts) = tcStmt tcExpr ListComp (\x->x) combine stmt $
  57                             tc_stmts stmts
  58
  59     combine stmt _ (stmts, expr) = (stmt:stmts, expr)
  60 \end{code}
  61
  62
  63 @tcGRHSsAndBinds@ typechecks (grhss where binds), returning suitable
  64 pieces.
  65
  66 \begin{code}
  67 tcGRHSsAndBinds :: TcType s                     -- Expected type of RHSs
  68                 -> RenamedGRHSsAndBinds
  69                 -> TcM s (TcGRHSsAndBinds s, LIE s)
  70
  71 tcGRHSsAndBinds expected_ty (GRHSsAndBindsIn grhss binds)
  72   = tcBindsAndThen
  73          combiner binds
  74          (tcGRHSs expected_ty grhss     `thenTc` \ (grhss', lie) ->
  75           returnTc (GRHSsAndBindsOut grhss' EmptyBinds expected_ty, lie)
  76          )
  77   where
  78     combiner is_rec binds1 (GRHSsAndBindsOut grhss binds2 ty)
  79         = GRHSsAndBindsOut grhss ((MonoBind binds1 [] is_rec) `ThenBinds` binds2) ty
  80 \end{code}