compiler/deSugar/DsGRHSs.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 Matching guarded right-hand-sides (GRHSs)
   7
   8 \begin{code}
   9 module DsGRHSs ( dsGuarded, dsGRHSs ) where
  10
  11 #include "HsVersions.h"
  12
  13 import {-# SOURCE #-} DsExpr  ( dsLExpr, dsLocalBinds )
  14 import {-# SOURCE #-} Match   ( matchSinglePat )
  15
  16 import HsSyn
  17 import CoreSyn
  18 import Var
  19 import Type
  20
  21 import DsMonad
  22 import DsUtils
  23 import DsBreakpoint
  24 import Unique
  25 import PrelInfo
  26 import TysWiredIn
  27 import PrelNames
  28 import Name
  29 import SrcLoc
  30 \end{code}
  31
  32 @dsGuarded@ is used for both @case@ expressions and pattern bindings.
  33 It desugars:
  34 \begin{verbatim}
  35         | g1 -> e1
  36         ...
  37         | gn -> en
  38         where binds
  39 \end{verbatim}
  40 producing an expression with a runtime error in the corner if
  41 necessary.  The type argument gives the type of the @ei@.
  42
  43 \begin{code}
  44 dsGuarded :: GRHSs Id -> Type -> DsM CoreExpr
  45
  46 dsGuarded grhss rhs_ty
  47   = dsGRHSs PatBindRhs [] grhss rhs_ty                          `thenDs` \ match_result ->
  48     mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty ""       `thenDs` \ error_expr ->
  49     extractMatchResult match_result error_expr
  50 \end{code}
  51
  52 In contrast, @dsGRHSs@ produces a @MatchResult@.
  53
  54 \begin{code}
  55 dsGRHSs :: HsMatchContext Name -> [Pat Id]      -- These are to build a MatchContext from
  56         -> GRHSs Id                             -- Guarded RHSs
  57         -> Type                                 -- Type of RHS
  58         -> DsM MatchResult
  59
  60 dsGRHSs hs_ctx pats (GRHSs grhss binds) rhs_ty
  61   = mappM (dsGRHS hs_ctx pats rhs_ty) grhss     `thenDs` \ match_results ->
  62     let
  63         match_result1 = foldr1 combineMatchResults match_results
  64         match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1
  65                 -- NB: nested dsLet inside matchResult
  66     in
  67     returnDs match_result2
  68
  69 dsGRHS hs_ctx pats rhs_ty (L loc (GRHS guards rhs))
  70   = matchGuards (map unLoc guards) hs_ctx rhs rhs_ty
  71 \end{code}
  72
  73
  74 %************************************************************************
  75 %*                                                                      *
  76 %*  matchGuard : make a MatchResult from a guarded RHS                  *
  77 %*                                                                      *
  78 %************************************************************************
  79
  80 \begin{code}
  81 matchGuards :: [Stmt Id]                -- Guard
  82             -> HsMatchContext Name      -- Context
  83             -> LHsExpr Id               -- RHS
  84             -> Type                     -- Type of RHS of guard
  85             -> DsM MatchResult
  86
  87 -- See comments with HsExpr.Stmt re what an ExprStmt means
  88 -- Here we must be in a guard context (not do-expression, nor list-comp)
  89
  90 matchGuards [] ctx rhs rhs_ty
  91   = do  { core_rhs <- dsLExpr rhs
  92         ; return (cantFailMatchResult core_rhs) }
  93
  94         -- ExprStmts must be guards
  95         -- Turn an "otherwise" guard is a no-op.  This ensures that
  96         -- you don't get a "non-exhaustive eqns" message when the guards
  97         -- finish in "otherwise".
  98         -- NB:  The success of this clause depends on the typechecker not
  99         --      wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors
 100         --      If it does, you'll get bogus overlap warnings
 101 matchGuards (ExprStmt (L _ (HsVar v)) _ _ : stmts) ctx rhs rhs_ty
 102   |  v `hasKey` otherwiseIdKey
 103   || v `hasKey` getUnique trueDataConId
 104         -- trueDataConId doesn't have the same unique as trueDataCon
 105   = matchGuards stmts ctx rhs rhs_ty
 106
 107 matchGuards (ExprStmt expr _ _ : stmts) ctx rhs rhs_ty
 108   = matchGuards stmts ctx rhs rhs_ty    `thenDs` \ match_result ->
 109     dsLExpr expr                        `thenDs` \ pred_expr ->
 110     returnDs (mkGuardedMatchResult pred_expr match_result)
 111
 112 matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty
 113   = matchGuards stmts ctx rhs rhs_ty    `thenDs` \ match_result ->
 114     returnDs (adjustMatchResultDs (dsLocalBinds binds) match_result)
 115         -- NB the dsLet occurs inside the match_result
 116         -- Reason: dsLet takes the body expression as its argument
 117         --         so we can't desugar the bindings without the
 118         --         body expression in hand
 119
 120 matchGuards (BindStmt pat bind_rhs _ _ : stmts) ctx rhs rhs_ty
 121   = matchGuards stmts ctx rhs rhs_ty    `thenDs` \ match_result ->
 122     dsLExpr bind_rhs                    `thenDs` \ core_rhs ->
 123     matchSinglePat core_rhs ctx pat rhs_ty match_result
 124 \end{code}
 125
 126 Should {\em fail} if @e@ returns @D@
 127 \begin{verbatim}
 128 f x | p <- e', let C y# = e, f y# = r1
 129     | otherwise          = r2
 130 \end{verbatim}