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, Stmt(..),
  16                           HsLit, Match, Fixity, DoOrListComp, HsType, ArithSeqInfo
  17                          )
  18 import TcHsSyn          ( SYN_IE(TypecheckedGRHSsAndBinds), SYN_IE(TypecheckedGRHS),
  19                           SYN_IE(TypecheckedPat), SYN_IE(TypecheckedHsBinds),
  20                           SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedStmt)
  21                         )
  22 import CoreSyn          ( SYN_IE(CoreBinding), GenCoreBinding(..), SYN_IE(CoreExpr), mkCoLetsAny )
  23
  24 import DsMonad
  25 import DsUtils
  26
  27 #if __GLASGOW_HASKELL__ < 200
  28 import Id               ( GenId )
  29 #endif
  30 import CoreUtils        ( coreExprType, mkCoreIfThenElse )
  31 import PrelVals         ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
  32 import Outputable       ( PprStyle(..) )
  33 import SrcLoc           ( SrcLoc{-instance-} )
  34 import Type             ( SYN_IE(Type) )
  35 import Unique           ( Unique, otherwiseIdKey )
  36 import UniqFM           ( Uniquable(..) )
  37 import Util             ( panic )
  38 \end{code}
  39
  40 @dsGuarded@ is used for both @case@ expressions and pattern bindings.
  41 It desugars:
  42 \begin{verbatim}
  43         | g1 -> e1
  44         ...
  45         | gn -> en
  46         where binds
  47 \end{verbatim}
  48 producing an expression with a runtime error in the corner if
  49 necessary.  The type argument gives the type of the ei.
  50
  51 \begin{code}
  52 dsGuarded :: TypecheckedGRHSsAndBinds
  53           -> DsM CoreExpr
  54
  55 dsGuarded (GRHSsAndBindsOut grhss binds err_ty)
  56   = dsBinds binds                               `thenDs` \ core_binds ->
  57     dsGRHSs err_ty PatBindMatch [] grhss        `thenDs` \ (MatchResult can_it_fail _ core_grhss_fn _) ->
  58     case can_it_fail of
  59         CantFail -> returnDs (mkCoLetsAny core_binds (core_grhss_fn (panic "It can't fail")))
  60         CanFail  -> mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID err_ty "" `thenDs` \ error_expr ->
  61                     returnDs (mkCoLetsAny core_binds (core_grhss_fn error_expr))
  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 dsGRHS ty kind pats (GRHS guard expr locn)
  97   = putSrcLocDs locn $
  98     dsExpr expr         `thenDs` \ core_expr ->
  99     let
 100         expr_fn = \ ignore -> core_expr
 101     in
 102     matchGuard guard (MatchResult CantFail ty expr_fn (DsMatchContext kind pats locn))
 103 \end{code}
 104
 105
 106
 107
 108 %************************************************************************
 109 %*                                                                      *
 110 %*  matchGuard : make a MatchResult from a guarded RHS                  *
 111 %*                                                                      *
 112 %************************************************************************
 113
 114 \begin{code}
 115 matchGuard :: [TypecheckedStmt]         -- Guard
 116            -> MatchResult               -- What to do if the guard succeeds
 117            -> DsM MatchResult
 118
 119 matchGuard [] body_result = returnDs body_result
 120
 121         -- Turn an "otherwise" guard is a no-op
 122 matchGuard (GuardStmt (HsVar v) _ : stmts) body_result
 123   | uniqueOf v == otherwiseIdKey
 124   = matchGuard stmts body_result
 125
 126 matchGuard (GuardStmt expr _ : stmts) body_result
 127   = matchGuard stmts body_result        `thenDs` \ (MatchResult _ ty body_fn cxt) ->
 128     dsExpr expr                         `thenDs` \ core_expr ->
 129     let
 130         expr_fn = \ fail -> mkCoreIfThenElse core_expr (body_fn fail) fail
 131     in
 132     returnDs (MatchResult CanFail ty expr_fn cxt)
 133
 134 matchGuard (LetStmt binds : stmts) body_result
 135   = matchGuard stmts body_result        `thenDs` \ match_result ->
 136     dsBinds binds                       `thenDs` \ core_binds ->
 137     returnDs (mkCoLetsMatchResult core_binds match_result)
 138
 139 matchGuard (BindStmt pat rhs _ : stmts) body_result
 140   = matchGuard stmts body_result                        `thenDs` \ match_result ->
 141     dsExpr rhs                                          `thenDs` \ core_rhs ->
 142     newSysLocalDs (coreExprType core_rhs)               `thenDs` \ scrut_var ->
 143     match [scrut_var] [EqnInfo [pat] match_result] []   `thenDs` \ match_result' ->
 144     returnDs (mkCoLetsMatchResult [NonRec scrut_var core_rhs] match_result')
 145 \end{code}