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, tcStmt ) where
   8
   9 #include "HsVersions.h"
  10
  11 import {-# SOURCE #-}   TcExpr( tcExpr )
  12
  13 import HsSyn            ( HsBinds(..), GRHSsAndBinds(..), GRHS(..), DoOrListComp(..),
  14                           Stmt(..),
  15                           collectPatBinders
  16                         )
  17 import RnHsSyn          ( RenamedGRHSsAndBinds, RenamedGRHS, RenamedStmt )
  18 import TcHsSyn          ( TcGRHSsAndBinds, TcGRHS, TcStmt )
  19
  20 import TcMonad
  21 import Inst             ( Inst, LIE, plusLIE )
  22 import TcBinds          ( tcBindsAndThen )
  23 import TcPat            ( tcPat )
  24 import TcType           ( TcType, newTyVarTy )
  25 import TcEnv            ( newMonoIds )
  26 import TysWiredIn       ( boolTy )
  27 import Kind             ( mkTypeKind, mkBoxedTypeKind )
  28 import Outputable
  29 \end{code}
  30
  31
  32 %************************************************************************
  33 %*                                                                      *
  34 \subsection{GRHSs}
  35 %*                                                                      *
  36 %************************************************************************
  37
  38 \begin{code}
  39 tcGRHSs :: TcType s -> [RenamedGRHS] -> TcM s ([TcGRHS s], LIE s)
  40
  41 tcGRHSs expected_ty [grhs]
  42   = tcGRHS expected_ty grhs             `thenTc` \ (grhs', lie) ->
  43     returnTc ([grhs'], lie)
  44
  45 tcGRHSs expected_ty (grhs:grhss)
  46   = tcGRHS  expected_ty grhs    `thenTc` \ (grhs',  lie1) ->
  47     tcGRHSs expected_ty grhss   `thenTc` \ (grhss', lie2) ->
  48     returnTc (grhs' : grhss', lie1 `plusLIE` lie2)
  49
  50 tcGRHS expected_ty (GRHS guard expr locn)
  51   = tcAddSrcLoc locn            $
  52     tcStmts guard               `thenTc` \ ((guard', expr'), lie) ->
  53     returnTc (GRHS guard' expr' locn, lie)
  54   where
  55     tcStmts []           = tcExpr expr expected_ty        `thenTc`    \ (expr2, expr_lie) ->
  56                            returnTc (([], expr2), expr_lie)
  57     tcStmts (stmt:stmts) = tcStmt Guard (\x->x) combine stmt $
  58                            tcStmts stmts
  59
  60     combine stmt _ (stmts, expr) = (stmt:stmts, expr)
  61 \end{code}
  62
  63
  64 %************************************************************************
  65 %*                                                                      *
  66 \subsection{GRHSsAndBinds}
  67 %*                                                                      *
  68 %************************************************************************
  69
  70 @tcGRHSsAndBinds@ typechecks (grhss where binds), returning suitable
  71 pieces.
  72
  73 \begin{code}
  74 tcGRHSsAndBinds :: TcType s                     -- Expected type of RHSs
  75                 -> RenamedGRHSsAndBinds
  76                 -> TcM s (TcGRHSsAndBinds s, LIE s)
  77
  78 -- Shortcut for common case
  79 tcGRHSsAndBinds expected_ty (GRHSsAndBindsIn grhss EmptyBinds)
  80   = tcGRHSs expected_ty grhss          `thenTc` \ (grhss', lie) ->
  81     returnTc (GRHSsAndBindsOut grhss' EmptyBinds expected_ty, lie)
  82
  83 tcGRHSsAndBinds expected_ty (GRHSsAndBindsIn grhss binds)
  84   = tcBindsAndThen
  85          combiner binds
  86          (tcGRHSs expected_ty grhss)
  87   where
  88     combiner is_rec binds grhss
  89         = GRHSsAndBindsOut grhss (MonoBind binds [] is_rec) expected_ty
  90 \end{code}
  91
  92
  93 %************************************************************************
  94 %*                                                                      *
  95 \subsection{Record bindings}
  96 %*                                                                      *
  97 %************************************************************************
  98
  99
 100 \begin{code}
 101 tcStmt :: DoOrListComp
 102        -> (TcType s -> TcType s)                -- Relationship type of pat and rhs in pat <- rhs
 103        -> (TcStmt s -> Maybe (TcType s) -> thing -> thing)
 104        -> RenamedStmt
 105        -> TcM s (thing, LIE s)
 106        -> TcM s (thing, LIE s)
 107
 108 tcStmt do_or_lc m combine stmt@(ReturnStmt exp) do_next
 109   = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True; Guard -> True } )
 110     tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
 111         newTyVarTy mkTypeKind                `thenNF_Tc` \ exp_ty ->
 112         tcExpr exp exp_ty                    `thenTc`    \ (exp', exp_lie) ->
 113         returnTc (ReturnStmt exp', exp_lie, m exp_ty)
 114     )                                   `thenTc` \ (stmt', stmt_lie, stmt_ty) ->
 115     do_next                             `thenTc` \ (thing', thing_lie) ->
 116     returnTc (combine stmt' (Just stmt_ty) thing',
 117               stmt_lie `plusLIE` thing_lie)
 118
 119 tcStmt do_or_lc m combine stmt@(GuardStmt exp src_loc) do_next
 120   = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True; Guard -> True } )
 121     newTyVarTy mkTypeKind                    `thenNF_Tc` \ exp_ty ->
 122     tcAddSrcLoc src_loc                 (
 123     tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
 124         tcExpr exp boolTy               `thenTc`    \ (exp', exp_lie) ->
 125         returnTc (GuardStmt exp' src_loc, exp_lie)
 126     ))                                  `thenTc` \ (stmt', stmt_lie) ->
 127     do_next                             `thenTc` \ (thing', thing_lie) ->
 128     returnTc (combine stmt' Nothing thing',
 129               stmt_lie `plusLIE` thing_lie)
 130
 131 tcStmt do_or_lc m combine stmt@(ExprStmt exp src_loc) do_next
 132   = ASSERT( case do_or_lc of { DoStmt -> True; ListComp -> False; Guard -> False } )
 133     newTyVarTy mkTypeKind                    `thenNF_Tc` \ exp_ty ->
 134     tcAddSrcLoc src_loc                 (
 135     tcSetErrCtxt (stmtCtxt do_or_lc stmt)       (
 136         newTyVarTy mkTypeKind           `thenNF_Tc` \ tau ->
 137         let
 138             -- exp has type (m tau) for some tau (doesn't matter what)
 139             exp_ty = m tau
 140         in
 141         tcExpr exp exp_ty               `thenTc`    \ (exp', exp_lie) ->
 142         returnTc (ExprStmt exp' src_loc, exp_lie, exp_ty)
 143     ))                                  `thenTc` \ (stmt',  stmt_lie, stmt_ty) ->
 144     do_next                             `thenTc` \ (thing', thing_lie) ->
 145     returnTc (combine stmt' (Just stmt_ty) thing',
 146               stmt_lie `plusLIE` thing_lie)
 147
 148 tcStmt do_or_lc m combine stmt@(BindStmt pat exp src_loc) do_next
 149   = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ ->
 150     tcAddSrcLoc src_loc         (
 151     tcSetErrCtxt (stmtCtxt do_or_lc stmt)       (
 152         tcPat pat                       `thenTc`    \ (pat', pat_lie, pat_ty) ->
 153         tcExpr exp (m pat_ty)           `thenTc`    \ (exp', exp_lie) ->
 154
 155         -- NB: the environment has been extended with the new binders
 156         -- which the rhs can't "see", but the renamer should have made
 157         -- sure that everything is distinct by now, so there's no problem.
 158         -- Putting the tcExpr before the newMonoIds messes up the nesting
 159         -- of error contexts, so I didn't  bother
 160
 161         returnTc (BindStmt pat' exp' src_loc, pat_lie `plusLIE` exp_lie)
 162     ))                                  `thenTc` \ (stmt', stmt_lie) ->
 163     do_next                             `thenTc` \ (thing', thing_lie) ->
 164     returnTc (combine stmt' Nothing thing',
 165               stmt_lie `plusLIE` thing_lie)
 166
 167 tcStmt do_or_lc m combine (LetStmt binds) do_next
 168      = tcBindsAndThen           -- No error context, but a binding group is
 169         combine'                -- rather a large thing for an error context anyway
 170         binds
 171         do_next
 172      where
 173         combine' is_rec binds' thing' = combine (LetStmt (MonoBind binds' [] is_rec)) Nothing thing'
 174
 175
 176 stmtCtxt do_or_lc stmt
 177   = hang (ptext SLIT("In a") <+> whatever <> colon)
 178          4 (ppr stmt)
 179   where
 180     whatever = case do_or_lc of
 181                  ListComp -> ptext SLIT("list-comprehension qualifier")
 182                  DoStmt   -> ptext SLIT("do statement")
 183                  Guard    -> ptext SLIT("guard")
 184 \end{code}