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