ghc/compiler/deSugar/DsGRHSs.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
   3 %
   4 \section[DsGRHSs]{Matching guarded right-hand-sides (GRHSs)}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module DsGRHSs ( dsGuarded, dsGRHSs ) where
  10
  11 IMP_Ubiq()
  12 IMPORT_DELOOPER(DsLoop)         -- break dsExpr/dsBinds-ish loop
  13
  14 import HsSyn            ( GRHSsAndBinds(..), GRHS(..),
  15                           HsExpr, HsBinds
  16                          )
  17 import TcHsSyn          ( SYN_IE(TypecheckedGRHSsAndBinds), SYN_IE(TypecheckedGRHS),
  18                           SYN_IE(TypecheckedPat), SYN_IE(TypecheckedHsBinds),
  19                           SYN_IE(TypecheckedHsExpr)     )
  20 import CoreSyn          ( SYN_IE(CoreBinding), SYN_IE(CoreExpr), mkCoLetsAny )
  21
  22 import DsMonad
  23 import DsUtils
  24
  25 import CoreUtils        ( mkCoreIfThenElse )
  26 import PrelVals         ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
  27 import PprStyle         ( PprStyle(..) )
  28 import Pretty           ( ppShow )
  29 import SrcLoc           ( SrcLoc{-instance-} )
  30 import Util             ( panic )
  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 :: TypecheckedGRHSsAndBinds
  46           -> DsM CoreExpr
  47
  48 dsGuarded (GRHSsAndBindsOut grhss binds err_ty)
  49   = dsBinds binds                               `thenDs` \ core_binds ->
  50     dsGRHSs err_ty PatBindMatch [] grhss        `thenDs` \ (MatchResult can_it_fail _ core_grhss_fn _) ->
  51     case can_it_fail of
  52         CantFail -> returnDs (mkCoLetsAny core_binds (core_grhss_fn (panic "It can't fail")))
  53         CanFail  -> mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID err_ty "" `thenDs` \ error_expr ->
  54                     returnDs (mkCoLetsAny core_binds (core_grhss_fn error_expr))
  55 \end{code}
  56
  57 Desugar a list of (grhs, expr) pairs [grhs = guarded
  58 right-hand-side], as in:
  59 \begin{verbatim}
  60 p | g1 = e1
  61   | g2 = e2
  62   ...
  63   | gm = em
  64 \end{verbatim}
  65 We supply a @CoreExpr@ for the case in which all of
  66 the guards fail.
  67
  68 \begin{code}
  69 dsGRHSs :: Type                         -- Type of RHSs
  70         -> DsMatchKind -> [TypecheckedPat]      -- These are to build a MatchContext from
  71         -> [TypecheckedGRHS]                    -- Guarded RHSs
  72         -> DsM MatchResult
  73
  74 dsGRHSs ty kind pats [grhs] = dsGRHS ty kind pats grhs
  75
  76 dsGRHSs ty kind pats (grhs:grhss)
  77   = dsGRHS ty kind pats grhs    `thenDs` \ match_result1 ->
  78     dsGRHSs ty kind pats grhss  `thenDs` \ match_result2 ->
  79     combineGRHSMatchResults match_result1 match_result2
  80
  81 dsGRHS ty kind pats (OtherwiseGRHS expr locn)
  82   = putSrcLocDs locn $
  83     dsExpr expr         `thenDs` \ core_expr ->
  84     let
  85         expr_fn = \ ignore -> core_expr
  86     in
  87     returnDs (MatchResult CantFail ty expr_fn (DsMatchContext kind pats locn))
  88
  89 dsGRHS ty kind pats (GRHS guard expr locn)
  90   = putSrcLocDs locn $
  91     dsExpr guard        `thenDs` \ core_guard ->
  92     dsExpr expr         `thenDs` \ core_expr  ->
  93     let
  94         expr_fn = \ fail -> mkCoreIfThenElse core_guard core_expr fail
  95     in
  96     returnDs (MatchResult CanFail ty expr_fn (DsMatchContext kind pats locn))
  97 \end{code}
  98
  99
 100