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 import TcHsSyn          ( SYN_IE(TypecheckedGRHSsAndBinds), SYN_IE(TypecheckedGRHS),
  17                           SYN_IE(TypecheckedPat), SYN_IE(TypecheckedHsBinds),
  18                           SYN_IE(TypecheckedHsExpr)     )
  19 import CoreSyn          ( SYN_IE(CoreBinding), SYN_IE(CoreExpr), mkCoLetsAny )
  20
  21 import DsMonad
  22 import DsUtils
  23
  24 import CoreUtils        ( mkCoreIfThenElse )
  25 import PrelVals         ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
  26 import PprStyle         ( PprStyle(..) )
  27 import Pretty           ( ppShow )
  28 import SrcLoc           ( SrcLoc{-instance-} )
  29 import Util             ( panic )
  30 \end{code}
  31
  32 @dsGuarded@ is used for both @case@ expressions and pattern bindings.
  33 It desugars:
  34 \begin{verbatim}
  35         | g1 -> e1
  36         ...
  37         | gn -> en
  38         where binds
  39 \end{verbatim}
  40 producing an expression with a runtime error in the corner if
  41 necessary.  The type argument gives the type of the ei.
  42
  43 \begin{code}
  44 dsGuarded :: TypecheckedGRHSsAndBinds
  45           -> DsM CoreExpr
  46
  47 dsGuarded (GRHSsAndBindsOut grhss binds err_ty)
  48   = dsBinds False binds                         `thenDs` \ core_binds ->
  49     dsGRHSs err_ty PatBindMatch [] grhss        `thenDs` \ (MatchResult can_it_fail _ core_grhss_fn _) ->
  50     case can_it_fail of
  51         CantFail -> returnDs (mkCoLetsAny core_binds (core_grhss_fn (panic "It can't fail")))
  52         CanFail  -> mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID err_ty "" `thenDs` \ error_expr ->
  53                     returnDs (mkCoLetsAny core_binds (core_grhss_fn error_expr))
  54 \end{code}
  55
  56 Desugar a list of (grhs, expr) pairs [grhs = guarded
  57 right-hand-side], as in:
  58 \begin{verbatim}
  59 p | g1 = e1
  60   | g2 = e2
  61   ...
  62   | gm = em
  63 \end{verbatim}
  64 We supply a @CoreExpr@ for the case in which all of
  65 the guards fail.
  66
  67 \begin{code}
  68 dsGRHSs :: Type                         -- Type of RHSs
  69         -> DsMatchKind -> [TypecheckedPat]      -- These are to build a MatchContext from
  70         -> [TypecheckedGRHS]                    -- Guarded RHSs
  71         -> DsM MatchResult
  72
  73 dsGRHSs ty kind pats [grhs] = dsGRHS ty kind pats grhs
  74
  75 dsGRHSs ty kind pats (grhs:grhss)
  76   = dsGRHS ty kind pats grhs    `thenDs` \ match_result1 ->
  77     dsGRHSs ty kind pats grhss  `thenDs` \ match_result2 ->
  78     combineGRHSMatchResults match_result1 match_result2
  79
  80 dsGRHS ty kind pats (OtherwiseGRHS expr locn)
  81   = putSrcLocDs locn $
  82     dsExpr expr         `thenDs` \ core_expr ->
  83     let
  84         expr_fn = \ ignore -> core_expr
  85     in
  86     returnDs (MatchResult CantFail ty expr_fn (DsMatchContext kind pats locn))
  87
  88 dsGRHS ty kind pats (GRHS guard expr locn)
  89   = putSrcLocDs locn $
  90     dsExpr guard        `thenDs` \ core_guard ->
  91     dsExpr expr         `thenDs` \ core_expr  ->
  92     let
  93         expr_fn = \ fail -> mkCoreIfThenElse core_guard core_expr fail
  94     in
  95     returnDs (MatchResult CanFail ty expr_fn (DsMatchContext kind pats locn))
  96 \end{code}
  97
  98