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 PrelInfo
  24 import TysWiredIn
  25 import PrelNames
  26 import Name
  27 import SrcLoc
  28
  29 \end{code}
  30
  31 @dsGuarded@ is used for both @case@ expressions and pattern bindings.
  32 It desugars:
  33 \begin{verbatim}
  34         | g1 -> e1
  35         ...
  36         | gn -> en
  37         where binds
  38 \end{verbatim}
  39 producing an expression with a runtime error in the corner if
  40 necessary.  The type argument gives the type of the @ei@.
  41
  42 \begin{code}
  43 dsGuarded :: GRHSs Id -> Type -> DsM CoreExpr
  44
  45 dsGuarded grhss rhs_ty
  46   = dsGRHSs PatBindRhs [] grhss rhs_ty                          `thenDs` \ match_result ->
  47     mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty ""       `thenDs` \ error_expr ->
  48     extractMatchResult match_result error_expr
  49 \end{code}
  50
  51 In contrast, @dsGRHSs@ produces a @MatchResult@.
  52
  53 \begin{code}
  54 dsGRHSs :: HsMatchContext Name -> [Pat Id]      -- These are to build a MatchContext from
  55         -> GRHSs Id                             -- Guarded RHSs
  56         -> Type                                 -- Type of RHS
  57         -> DsM MatchResult
  58 dsGRHSs hs_ctx pats grhssa@(GRHSs grhss binds) rhs_ty = do
  59     match_results <- mappM (dsGRHS hs_ctx pats rhs_ty) grhss
  60     let
  61         match_result1 = foldr1 combineMatchResults match_results
  62         match_result2 = adjustMatchResultDs
  63                                  (\e -> dsLocalBinds binds e)
  64                                  match_result1
  65                 -- NB: nested dsLet inside matchResult
  66     --
  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}