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