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, dsLocalBinds )
  12 import {-# SOURCE #-} Match   ( matchSinglePat )
  13
  14 import HsSyn            ( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..),
  15                           LHsExpr, 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 hs_ctx pats (GRHSs grhss binds) rhs_ty
  59   = mappM (dsGRHS hs_ctx pats rhs_ty) grhss     `thenDs` \ match_results ->
  60     let
  61         match_result1 = foldr1 combineMatchResults match_results
  62         match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1
  63                 -- NB: nested dsLet inside matchResult
  64     in
  65     returnDs match_result2
  66
  67 dsGRHS hs_ctx pats rhs_ty (L loc (GRHS guards rhs))
  68   = matchGuards (map unLoc guards) hs_ctx rhs 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 matchGuards :: [Stmt Id]                -- Guard
  80             -> HsMatchContext Name      -- Context
  81             -> LHsExpr Id               -- RHS
  82             -> Type                     -- Type of RHS of guard
  83             -> DsM MatchResult
  84
  85 -- See comments with HsExpr.Stmt re what an ExprStmt means
  86 -- Here we must be in a guard context (not do-expression, nor list-comp)
  87
  88 matchGuards [] ctx rhs rhs_ty
  89   = do  { core_rhs <- dsLExpr rhs
  90         ; return (cantFailMatchResult core_rhs) }
  91
  92         -- ExprStmts must be guards
  93         -- Turn an "otherwise" guard is a no-op.  This ensures that
  94         -- you don't get a "non-exhaustive eqns" message when the guards
  95         -- finish in "otherwise".
  96         -- NB:  The success of this clause depends on the typechecker not
  97         --      wrapping the 'otherwise' in empty HsTyApp or HsCoerce constructors
  98         --      If it does, you'll get bogus overlap warnings
  99 matchGuards (ExprStmt (L _ (HsVar v)) _ _ : stmts) ctx rhs rhs_ty
 100   |  v `hasKey` otherwiseIdKey
 101   || v `hasKey` getUnique trueDataConId
 102         -- trueDataConId doesn't have the same unique as trueDataCon
 103   = matchGuards stmts ctx rhs rhs_ty
 104
 105 matchGuards (ExprStmt expr _ _ : stmts) ctx rhs rhs_ty
 106   = matchGuards stmts ctx rhs rhs_ty    `thenDs` \ match_result ->
 107     dsLExpr expr                        `thenDs` \ pred_expr ->
 108     returnDs (mkGuardedMatchResult pred_expr match_result)
 109
 110 matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty
 111   = matchGuards stmts ctx rhs rhs_ty    `thenDs` \ match_result ->
 112     returnDs (adjustMatchResultDs (dsLocalBinds binds) match_result)
 113         -- NB the dsLet occurs inside the match_result
 114         -- Reason: dsLet takes the body expression as its argument
 115         --         so we can't desugar the bindings without the
 116         --         body expression in hand
 117
 118 matchGuards (BindStmt pat bind_rhs _ _ : stmts) ctx rhs rhs_ty
 119   = matchGuards stmts ctx rhs rhs_ty    `thenDs` \ match_result ->
 120     dsLExpr bind_rhs                    `thenDs` \ core_rhs ->
 121     matchSinglePat core_rhs ctx pat rhs_ty match_result
 122 \end{code}
 123
 124 Should {\em fail} if @e@ returns @D@
 125 \begin{verbatim}
 126 f x | p <- e', let C y# = e, f y# = r1
 127     | otherwise          = r2
 128 \end{verbatim}