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