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 Var              ( Id )
  18 import Type             ( Type )
  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 -> Type -> DsM CoreExpr
  43
  44 dsGuarded grhss rhs_ty
  45   = dsGRHSs PatBindRhs [] grhss rhs_ty                          `thenDs` \ match_result ->
  46     mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_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         -> Type                                 -- Type of RHS
  56         -> DsM MatchResult
  57
  58 dsGRHSs kind pats (GRHSs grhss binds) rhs_ty
  59   = mappM (dsGRHS kind pats rhs_ty) grhss       `thenDs` \ match_results ->
  60     let
  61         match_result1 = foldr1 combineMatchResults match_results
  62         match_result2 = adjustMatchResultDs (dsLet binds) match_result1
  63                 -- NB: nested dsLet inside matchResult
  64     in
  65     returnDs match_result2
  66
  67 dsGRHS kind pats rhs_ty (L loc (GRHS guard))
  68   = matchGuard (map unLoc guard) (DsMatchContext kind pats loc) rhs_ty
  69 \end{code}
  70
  71
  72 %************************************************************************
  73 %*                                                                      *
  74 %*  matchGuard : make a MatchResult from a guarded RHS                  *
  75 %*                                                                      *
  76 %************************************************************************
  77
  78 \begin{code}
  79 matchGuard :: [Stmt Id]         -- Guard
  80            -> DsMatchContext    -- Context
  81            -> Type              -- Type of RHS of guard
  82            -> DsM MatchResult
  83
  84 -- See comments with HsExpr.Stmt re what an ExprStmt means
  85 -- Here we must be in a guard context (not do-expression, nor list-comp)
  86
  87 matchGuard [ResultStmt expr] ctx rhs_ty
  88   = do  { core_expr <- dsLExpr expr
  89         ; return (cantFailMatchResult core_expr) }
  90
  91         -- ExprStmts must be guards
  92         -- Turn an "otherwise" guard is a no-op
  93 matchGuard (ExprStmt (L _ (HsVar v)) _ : stmts) ctx rhs_ty
  94   |  v `hasKey` otherwiseIdKey
  95   || v `hasKey` getUnique trueDataConId
  96         -- trueDataConId doesn't have the same
  97         -- unique as trueDataCon
  98   = matchGuard stmts ctx rhs_ty
  99
 100 matchGuard (ExprStmt expr _ : stmts) ctx rhs_ty
 101   = matchGuard stmts ctx rhs_ty `thenDs` \ match_result ->
 102     dsLExpr expr                `thenDs` \ pred_expr ->
 103     returnDs (mkGuardedMatchResult pred_expr match_result)
 104
 105 matchGuard (LetStmt binds : stmts) ctx rhs_ty
 106   = matchGuard stmts ctx rhs_ty `thenDs` \ match_result ->
 107     returnDs (adjustMatchResultDs (dsLet binds) match_result)
 108         -- NB the dsLet occurs inside the match_result
 109         -- Reason: dsLet takes the body expression as its argument
 110         --         so we can't desugar the bindings without the
 111         --         body expression in hand
 112
 113 matchGuard (BindStmt pat bind_rhs : stmts) ctx rhs_ty
 114   = matchGuard stmts ctx rhs_ty `thenDs` \ match_result ->
 115     dsLExpr bind_rhs            `thenDs` \ core_rhs ->
 116     matchSinglePat core_rhs ctx pat rhs_ty match_result
 117 \end{code}
 118
 119 Should {\em fail} if @e@ returns @D@
 120 \begin{verbatim}
 121 f x | p <- e', let C y# = e, f y# = r1
 122     | otherwise          = r2
 123 \end{verbatim}