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  ( dsExpr, dsLet )
  12 import {-# SOURCE #-} Match   ( matchSinglePat )
  13
  14 import HsSyn            ( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..) )
  15 import TcHsSyn          ( TypecheckedGRHSs, TypecheckedPat, TypecheckedStmt )
  16 import CoreSyn          ( CoreExpr, Bind(..) )
  17 import Type             ( Type )
  18
  19 import DsMonad
  20 import DsUtils
  21 import PrelInfo         ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
  22 import Unique           ( otherwiseIdKey, trueDataConKey, Uniquable(..) )
  23 import Outputable
  24 \end{code}
  25
  26 @dsGuarded@ is used for both @case@ expressions and pattern bindings.
  27 It desugars:
  28 \begin{verbatim}
  29         | g1 -> e1
  30         ...
  31         | gn -> en
  32         where binds
  33 \end{verbatim}
  34 producing an expression with a runtime error in the corner if
  35 necessary.  The type argument gives the type of the ei.
  36
  37 \begin{code}
  38 dsGuarded :: TypecheckedGRHSs -> DsM CoreExpr
  39
  40 dsGuarded grhss
  41   = dsGRHSs PatBindMatch [] grhss                               `thenDs` \ (err_ty, match_result) ->
  42     mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID err_ty ""       `thenDs` \ error_expr ->
  43     extractMatchResult match_result error_expr
  44 \end{code}
  45
  46 In contrast, @dsGRHSs@ produces a @MatchResult@.
  47
  48 \begin{code}
  49 dsGRHSs :: DsMatchKind -> [TypecheckedPat]      -- These are to build a MatchContext from
  50         -> TypecheckedGRHSs                     -- Guarded RHSs
  51         -> DsM (Type, MatchResult)
  52
  53 dsGRHSs kind pats (GRHSs grhss binds (Just ty))
  54   = mapDs (dsGRHS kind pats) grhss              `thenDs` \ match_results ->
  55     let
  56         match_result1 = foldr1 combineMatchResults match_results
  57         match_result2 = adjustMatchResultDs (dsLet binds) match_result1
  58                 -- NB: nested dsLet inside matchResult
  59     in
  60     returnDs (ty, match_result2)
  61
  62 dsGRHS kind pats (GRHS guard locn)
  63   = matchGuard guard (DsMatchContext kind pats locn)
  64 \end{code}
  65
  66
  67 %************************************************************************
  68 %*                                                                      *
  69 %*  matchGuard : make a MatchResult from a guarded RHS                  *
  70 %*                                                                      *
  71 %************************************************************************
  72
  73 \begin{code}
  74 matchGuard :: [TypecheckedStmt]         -- Guard
  75            -> DsMatchContext            -- Context
  76            -> DsM MatchResult
  77
  78 matchGuard (ExprStmt expr locn : should_be_null) ctx
  79   = putSrcLocDs locn (dsExpr expr)      `thenDs` \ core_expr ->
  80     returnDs (cantFailMatchResult core_expr)
  81
  82         -- Turn an "otherwise" guard is a no-op
  83 matchGuard (GuardStmt (HsVar v) _ : stmts) ctx
  84   |  uniq == otherwiseIdKey
  85   || uniq == trueDataConKey
  86   = matchGuard stmts ctx
  87   where
  88     uniq = getUnique v
  89
  90 matchGuard (GuardStmt expr locn : stmts) ctx
  91   = matchGuard stmts ctx                `thenDs` \ match_result ->
  92     putSrcLocDs locn (dsExpr expr)      `thenDs` \ pred_expr ->
  93     returnDs (mkGuardedMatchResult pred_expr match_result)
  94
  95 matchGuard (LetStmt binds : stmts) ctx
  96   = matchGuard stmts ctx        `thenDs` \ match_result ->
  97     returnDs (adjustMatchResultDs (dsLet binds) match_result)
  98         -- NB the dsLet occurs inside the match_result
  99
 100 matchGuard (BindStmt pat rhs locn : stmts) ctx
 101   = matchGuard stmts ctx                `thenDs` \ match_result ->
 102     putSrcLocDs locn (dsExpr rhs)       `thenDs` \ core_rhs ->
 103     matchSinglePat core_rhs ctx pat match_result
 104 \end{code}
 105
 106 -- Should *fail* if e returns D
 107
 108 f x | p <- e', let C y# = e, f y# = r1
 109     | otherwise          = r2