ghc/compiler/deSugar/DsGRHSs.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[DsGRHSs]{Matching guarded right-hand-sides (GRHSs)}
   5
   6 \begin{code}
   7 module DsGRHSs ( dsGuarded, dsGRHSs ) where
   8
   9 #include "HsVersions.h"
  10
  11 import {-# SOURCE #-} DsExpr  ( dsExpr, dsLet )
  12 import {-# SOURCE #-} Match   ( matchSinglePat )
  13
  14 import HsSyn            ( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..), HsMatchContext(..) )
  15 import TcHsSyn          ( TypecheckedGRHSs, TypecheckedPat, TypecheckedStmt, TypecheckedMatchContext )
  16 import CoreSyn          ( CoreExpr )
  17 import Type             ( Type )
  18
  19 import DsMonad
  20 import DsUtils
  21 import PrelInfo         ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
  22 import PrelNames        ( otherwiseIdKey, trueDataConKey, hasKey )
  23 \end{code}
  24
  25 @dsGuarded@ is used for both @case@ expressions and pattern bindings.
  26 It desugars:
  27 \begin{verbatim}
  28         | g1 -> e1
  29         ...
  30         | gn -> en
  31         where binds
  32 \end{verbatim}
  33 producing an expression with a runtime error in the corner if
  34 necessary.  The type argument gives the type of the @ei@.
  35
  36 \begin{code}
  37 dsGuarded :: TypecheckedGRHSs -> DsM CoreExpr
  38
  39 dsGuarded grhss
  40   = dsGRHSs PatBindRhs [] grhss                                 `thenDs` \ (err_ty, match_result) ->
  41     mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID err_ty ""       `thenDs` \ error_expr ->
  42     extractMatchResult match_result error_expr
  43 \end{code}
  44
  45 In contrast, @dsGRHSs@ produces a @MatchResult@.
  46
  47 \begin{code}
  48 dsGRHSs :: TypecheckedMatchContext -> [TypecheckedPat]  -- These are to build a MatchContext from
  49         -> TypecheckedGRHSs                             -- Guarded RHSs
  50         -> DsM (Type, MatchResult)
  51
  52 dsGRHSs kind pats (GRHSs grhss binds (Just ty))
  53   = mapDs (dsGRHS kind pats) grhss              `thenDs` \ match_results ->
  54     let
  55         match_result1 = foldr1 combineMatchResults match_results
  56         match_result2 = adjustMatchResultDs (dsLet binds) match_result1
  57                 -- NB: nested dsLet inside matchResult
  58     in
  59     returnDs (ty, match_result2)
  60
  61 dsGRHS kind pats (GRHS guard locn)
  62   = matchGuard guard (DsMatchContext kind pats locn)
  63 \end{code}
  64
  65
  66 %************************************************************************
  67 %*                                                                      *
  68 %*  matchGuard : make a MatchResult from a guarded RHS                  *
  69 %*                                                                      *
  70 %************************************************************************
  71
  72 \begin{code}
  73 matchGuard :: [TypecheckedStmt]         -- Guard
  74            -> DsMatchContext            -- Context
  75            -> DsM MatchResult
  76
  77 -- See comments with HsExpr.HsStmt re what an ExprStmt means
  78 -- Here we must be in a guard context (not do-expression, nor list-comp)
  79
  80 matchGuard [ResultStmt expr locn] ctx
  81   = putSrcLocDs locn (dsExpr expr)      `thenDs` \ core_expr ->
  82     returnDs (cantFailMatchResult core_expr)
  83
  84         -- ExprStmts must be guards
  85         -- Turn an "otherwise" guard is a no-op
  86 matchGuard (ExprStmt (HsVar v) _ : stmts) ctx
  87   |  v `hasKey` otherwiseIdKey
  88   || v `hasKey` trueDataConKey
  89   = matchGuard stmts ctx
  90
  91 matchGuard (ExprStmt expr locn : stmts) ctx
  92   = matchGuard stmts ctx                `thenDs` \ match_result ->
  93     putSrcLocDs locn (dsExpr expr)      `thenDs` \ pred_expr ->
  94     returnDs (mkGuardedMatchResult pred_expr match_result)
  95
  96 matchGuard (LetStmt binds : stmts) ctx
  97   = matchGuard stmts ctx        `thenDs` \ match_result ->
  98     returnDs (adjustMatchResultDs (dsLet binds) match_result)
  99         -- NB the dsLet occurs inside the match_result
 100
 101 matchGuard (BindStmt pat rhs locn : stmts) ctx
 102   = matchGuard stmts ctx                `thenDs` \ match_result ->
 103     putSrcLocDs locn (dsExpr rhs)       `thenDs` \ core_rhs ->
 104     matchSinglePat core_rhs ctx pat match_result
 105 \end{code}
 106
 107 Should {\em fail} if @e@ returns @D@
 108 \begin{verbatim}
 109 f x | p <- e', let C y# = e, f y# = r1
 110     | otherwise          = r2
 111 \end{verbatim}