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(..), mkCoLetsAny )
  20
  21 import DsMonad
  22 import DsUtils
  23
  24 import CoreUtils        ( escErrorMsg, mkErrorApp, mkCoreIfThenElse )
  25 import PrelInfo         ( stringTy )
  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           -> SrcLoc
  46           -> DsM CoreExpr
  47
  48 dsGuarded (GRHSsAndBindsOut grhss binds err_ty) err_loc
  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  -> newSysLocalDs stringTy      `thenDs` \ str_var -> -- to hold the String
  54                     returnDs (mkCoLetsAny core_binds (core_grhss_fn (error_expr str_var)))
  55   where
  56     unencoded_part_of_msg = escErrorMsg (ppShow 80 (ppr PprForUser err_loc))
  57
  58     error_expr :: Id -> CoreExpr
  59     error_expr str_var = mkErrorApp err_ty str_var
  60                           (unencoded_part_of_msg
  61                           ++ "%N") --> ": non-exhaustive guards"
  62 \end{code}
  63
  64 Desugar a list of (grhs, expr) pairs [grhs = guarded
  65 right-hand-side], as in:
  66 \begin{verbatim}
  67 p | g1 = e1
  68   | g2 = e2
  69   ...
  70   | gm = em
  71 \end{verbatim}
  72 We supply a @CoreExpr@ for the case in which all of
  73 the guards fail.
  74
  75 \begin{code}
  76 dsGRHSs :: Type                         -- Type of RHSs
  77         -> DsMatchKind -> [TypecheckedPat]      -- These are to build a MatchContext from
  78         -> [TypecheckedGRHS]                    -- Guarded RHSs
  79         -> DsM MatchResult
  80
  81 dsGRHSs ty kind pats [grhs] = dsGRHS ty kind pats grhs
  82
  83 dsGRHSs ty kind pats (grhs:grhss)
  84   = dsGRHS ty kind pats grhs    `thenDs` \ match_result1 ->
  85     dsGRHSs ty kind pats grhss  `thenDs` \ match_result2 ->
  86     combineGRHSMatchResults match_result1 match_result2
  87
  88 dsGRHS ty kind pats (OtherwiseGRHS expr locn)
  89   = putSrcLocDs locn             (
  90     dsExpr expr         `thenDs` \ core_expr ->
  91     let
  92         expr_fn = \ ignore -> core_expr
  93     in
  94     returnDs (MatchResult CantFail ty expr_fn (DsMatchContext kind pats locn))
  95     )
  96
  97 dsGRHS ty kind pats (GRHS guard expr locn)
  98   = putSrcLocDs locn             (
  99     dsExpr guard        `thenDs` \ core_guard ->
 100     dsExpr expr         `thenDs` \ core_expr  ->
 101     let
 102         expr_fn = \ fail -> mkCoreIfThenElse core_guard core_expr fail
 103     in
 104     returnDs (MatchResult CanFail ty expr_fn (DsMatchContext kind pats locn))
 105     )
 106 \end{code}
 107
 108