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  ( dsLExpr, dsLet )
  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 kind pats (GRHSs grhss binds) rhs_ty
  59   = mappM (dsGRHS kind pats rhs_ty) grhss       `thenDs` \ match_results ->
  60     let
  61         match_result1 = foldr1 combineMatchResults match_results
  62         match_result2 = adjustMatchResultDs (dsLet binds) match_result1
  63                 -- NB: nested dsLet inside matchResult
  64     in
  65     returnDs match_result2
  66
  67 dsGRHS kind pats rhs_ty (L loc (GRHS guards rhs))
  68   = matchGuard (map unLoc guards) (DsMatchContext kind pats loc)
  69                rhs rhs_ty
  70 \end{code}
  71
  72
  73 %************************************************************************
  74 %*                                                                      *
  75 %*  matchGuard : make a MatchResult from a guarded RHS                  *
  76 %*                                                                      *
  77 %************************************************************************
  78
  79 \begin{code}
  80 matchGuard :: [Stmt Id]         -- Guard
  81            -> DsMatchContext    -- Context
  82            -> LHsExpr Id        -- RHS
  83            -> Type              -- Type of RHS of guard
  84            -> DsM MatchResult
  85
  86 -- See comments with HsExpr.Stmt re what an ExprStmt means
  87 -- Here we must be in a guard context (not do-expression, nor list-comp)
  88
  89 matchGuard [] ctx rhs rhs_ty
  90   = do  { core_rhs <- dsLExpr rhs
  91         ; return (cantFailMatchResult core_rhs) }
  92
  93         -- ExprStmts must be guards
  94         -- Turn an "otherwise" guard is a no-op
  95 matchGuard (ExprStmt (L _ (HsVar v)) _ _ : stmts) ctx rhs rhs_ty
  96   |  v `hasKey` otherwiseIdKey
  97   || v `hasKey` getUnique trueDataConId
  98         -- trueDataConId doesn't have the same
  99         -- unique as trueDataCon
 100   = matchGuard stmts ctx rhs rhs_ty
 101
 102 matchGuard (ExprStmt expr _ _ : stmts) ctx rhs rhs_ty
 103   = matchGuard stmts ctx rhs rhs_ty     `thenDs` \ match_result ->
 104     dsLExpr expr                        `thenDs` \ pred_expr ->
 105     returnDs (mkGuardedMatchResult pred_expr match_result)
 106
 107 matchGuard (LetStmt binds : stmts) ctx rhs rhs_ty
 108   = matchGuard stmts ctx rhs rhs_ty     `thenDs` \ match_result ->
 109     returnDs (adjustMatchResultDs (dsLet binds) match_result)
 110         -- NB the dsLet occurs inside the match_result
 111         -- Reason: dsLet takes the body expression as its argument
 112         --         so we can't desugar the bindings without the
 113         --         body expression in hand
 114
 115 matchGuard (BindStmt pat bind_rhs _ _ : stmts) ctx rhs rhs_ty
 116   = matchGuard stmts ctx rhs rhs_ty     `thenDs` \ match_result ->
 117     dsLExpr bind_rhs                    `thenDs` \ core_rhs ->
 118     matchSinglePat core_rhs ctx pat rhs_ty match_result
 119 \end{code}
 120
 121 Should {\em fail} if @e@ returns @D@
 122 \begin{verbatim}
 123 f x | p <- e', let C y# = e, f y# = r1
 124     | otherwise          = r2
 125 \end{verbatim}