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  ( dsLExpr, dsLet )
  12 import {-# SOURCE #-} Match   ( matchSinglePat )
  13
  14 import HsSyn            ( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..),
  15                           HsMatchContext(..), Pat(..) )
  16 import CoreSyn          ( CoreExpr )
  17 import Type             ( Type )
  18 import Var              ( Id )
  19
  20 import DsMonad
  21 import DsUtils
  22 import Unique           ( Uniquable(..) )
  23 import PrelInfo         ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
  24 import TysWiredIn       ( trueDataConId )
  25 import PrelNames        ( otherwiseIdKey, hasKey )
  26 import Name             ( Name )
  27 import SrcLoc           ( unLoc, Located(..) )
  28 \end{code}
  29
  30 @dsGuarded@ is used for both @case@ expressions and pattern bindings.
  31 It desugars:
  32 \begin{verbatim}
  33         | g1 -> e1
  34         ...
  35         | gn -> en
  36         where binds
  37 \end{verbatim}
  38 producing an expression with a runtime error in the corner if
  39 necessary.  The type argument gives the type of the @ei@.
  40
  41 \begin{code}
  42 dsGuarded :: GRHSs Id -> DsM CoreExpr
  43
  44 dsGuarded grhss
  45   = dsGRHSs PatBindRhs [] grhss                                 `thenDs` \ (err_ty, match_result) ->
  46     mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID err_ty ""       `thenDs` \ error_expr ->
  47     extractMatchResult match_result error_expr
  48 \end{code}
  49
  50 In contrast, @dsGRHSs@ produces a @MatchResult@.
  51
  52 \begin{code}
  53 dsGRHSs :: HsMatchContext Name -> [Pat Id]      -- These are to build a MatchContext from
  54         -> GRHSs Id                             -- Guarded RHSs
  55         -> DsM (Type, MatchResult)
  56
  57 dsGRHSs kind pats (GRHSs grhss binds ty)
  58   = mappM (dsGRHS kind pats) grhss              `thenDs` \ match_results ->
  59     let
  60         match_result1 = foldr1 combineMatchResults match_results
  61         match_result2 = adjustMatchResultDs (dsLet binds) match_result1
  62                 -- NB: nested dsLet inside matchResult
  63     in
  64     returnDs (ty, match_result2)
  65
  66 dsGRHS kind pats (L loc (GRHS guard))
  67   = matchGuard (map unLoc guard) (DsMatchContext kind pats loc)
  68 \end{code}
  69
  70
  71 %************************************************************************
  72 %*                                                                      *
  73 %*  matchGuard : make a MatchResult from a guarded RHS                  *
  74 %*                                                                      *
  75 %************************************************************************
  76
  77 \begin{code}
  78 matchGuard :: [Stmt Id]         -- Guard
  79            -> DsMatchContext            -- Context
  80            -> DsM MatchResult
  81
  82 -- See comments with HsExpr.Stmt re what an ExprStmt means
  83 -- Here we must be in a guard context (not do-expression, nor list-comp)
  84
  85 matchGuard [ResultStmt expr] ctx
  86   = dsLExpr expr        `thenDs` \ core_expr ->
  87     returnDs (cantFailMatchResult core_expr)
  88
  89         -- ExprStmts must be guards
  90         -- Turn an "otherwise" guard is a no-op
  91 matchGuard (ExprStmt (L _ (HsVar v)) _ : stmts) ctx
  92   |  v `hasKey` otherwiseIdKey
  93   || v `hasKey` getUnique trueDataConId
  94         -- trueDataConId doesn't have the same
  95         -- unique as trueDataCon
  96   = matchGuard stmts ctx
  97
  98 matchGuard (ExprStmt expr _ : stmts) ctx
  99   = matchGuard stmts ctx        `thenDs` \ match_result ->
 100     dsLExpr expr                `thenDs` \ pred_expr ->
 101     returnDs (mkGuardedMatchResult pred_expr match_result)
 102
 103 matchGuard (LetStmt binds : stmts) ctx
 104   = matchGuard stmts ctx        `thenDs` \ match_result ->
 105     returnDs (adjustMatchResultDs (dsLet binds) match_result)
 106         -- NB the dsLet occurs inside the match_result
 107
 108 matchGuard (BindStmt pat rhs : stmts) ctx
 109   = matchGuard stmts ctx                `thenDs` \ match_result ->
 110     dsLExpr rhs                         `thenDs` \ core_rhs ->
 111     matchSinglePat core_rhs ctx pat match_result
 112 \end{code}
 113
 114 Should {\em fail} if @e@ returns @D@
 115 \begin{verbatim}
 116 f x | p <- e', let C y# = e, f y# = r1
 117     | otherwise          = r2
 118 \end{verbatim}