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