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