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 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
  13 IMPORT_DELOOPER(DsLoop)         -- break dsExpr/dsBinds-ish loop
  14 #else
  15 import {-# SOURCE #-} DsExpr  ( dsExpr )
  16 import {-# SOURCE #-} DsBinds ( dsBinds )
  17 import {-# SOURCE #-} Match   ( match )
  18 #endif
  19
  20 import HsSyn            ( GRHSsAndBinds(..), GRHS(..),
  21                           HsExpr(..), HsBinds, Stmt(..),
  22                           HsLit, Match, Fixity, DoOrListComp, HsType, ArithSeqInfo
  23                          )
  24 import TcHsSyn          ( SYN_IE(TypecheckedGRHSsAndBinds), SYN_IE(TypecheckedGRHS),
  25                           SYN_IE(TypecheckedPat), SYN_IE(TypecheckedHsBinds),
  26                           SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedStmt)
  27                         )
  28 import CoreSyn          ( SYN_IE(CoreBinding), GenCoreBinding(..), SYN_IE(CoreExpr), mkCoLetsAny )
  29
  30 import DsMonad
  31 import DsUtils
  32
  33 #if __GLASGOW_HASKELL__ < 200
  34 import Id               ( GenId )
  35 #endif
  36 import CoreUtils        ( coreExprType, mkCoreIfThenElse )
  37 import PrelVals         ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
  38 import Outputable       ( PprStyle(..) )
  39 import SrcLoc           ( SrcLoc{-instance-} )
  40 import Type             ( SYN_IE(Type) )
  41 import Unique           ( Unique, otherwiseIdKey )
  42 import UniqFM           ( Uniquable(..) )
  43 import Util             ( panic )
  44 \end{code}
  45
  46 @dsGuarded@ is used for both @case@ expressions and pattern bindings.
  47 It desugars:
  48 \begin{verbatim}
  49         | g1 -> e1
  50         ...
  51         | gn -> en
  52         where binds
  53 \end{verbatim}
  54 producing an expression with a runtime error in the corner if
  55 necessary.  The type argument gives the type of the ei.
  56
  57 \begin{code}
  58 dsGuarded :: TypecheckedGRHSsAndBinds
  59           -> DsM CoreExpr
  60
  61 dsGuarded (GRHSsAndBindsOut grhss binds err_ty)
  62   = dsBinds False{-don't auto scc-} binds       `thenDs` \ core_binds ->
  63     dsGRHSs err_ty PatBindMatch [] grhss        `thenDs` \ (MatchResult can_it_fail _ core_grhss_fn _) ->
  64     case can_it_fail of
  65         CantFail -> returnDs (mkCoLetsAny core_binds (core_grhss_fn (panic "It can't fail")))
  66         CanFail  -> mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID err_ty "" `thenDs` \ error_expr ->
  67                     returnDs (mkCoLetsAny core_binds (core_grhss_fn error_expr))
  68 \end{code}
  69
  70 Desugar a list of (grhs, expr) pairs [grhs = guarded
  71 right-hand-side], as in:
  72 \begin{verbatim}
  73 p | g1 = e1
  74   | g2 = e2
  75   ...
  76   | gm = em
  77 \end{verbatim}
  78 We supply a @CoreExpr@ for the case in which all of
  79 the guards fail.
  80
  81 \begin{code}
  82 dsGRHSs :: Type                         -- Type of RHSs
  83         -> DsMatchKind -> [TypecheckedPat]      -- These are to build a MatchContext from
  84         -> [TypecheckedGRHS]                    -- Guarded RHSs
  85         -> DsM MatchResult
  86
  87 dsGRHSs ty kind pats [grhs] = dsGRHS ty kind pats grhs
  88
  89 dsGRHSs ty kind pats (grhs:grhss)
  90   = dsGRHS ty kind pats grhs    `thenDs` \ match_result1 ->
  91     dsGRHSs ty kind pats grhss  `thenDs` \ match_result2 ->
  92     combineGRHSMatchResults match_result1 match_result2
  93
  94 dsGRHS ty kind pats (OtherwiseGRHS expr locn)
  95   = putSrcLocDs locn $
  96     dsExpr expr         `thenDs` \ core_expr ->
  97     let
  98         expr_fn = \ ignore -> core_expr
  99     in
 100     returnDs (MatchResult CantFail ty expr_fn (DsMatchContext kind pats locn))
 101
 102 dsGRHS ty kind pats (GRHS guard expr locn)
 103   = putSrcLocDs locn $
 104     dsExpr expr         `thenDs` \ core_expr ->
 105     let
 106         expr_fn = \ ignore -> core_expr
 107     in
 108     matchGuard guard (MatchResult CantFail ty expr_fn (DsMatchContext kind pats locn))
 109 \end{code}
 110
 111
 112
 113
 114 %************************************************************************
 115 %*                                                                      *
 116 %*  matchGuard : make a MatchResult from a guarded RHS                  *
 117 %*                                                                      *
 118 %************************************************************************
 119
 120 \begin{code}
 121 matchGuard :: [TypecheckedStmt]         -- Guard
 122            -> MatchResult               -- What to do if the guard succeeds
 123            -> DsM MatchResult
 124
 125 matchGuard [] body_result = returnDs body_result
 126
 127         -- Turn an "otherwise" guard is a no-op
 128 matchGuard (GuardStmt (HsVar v) _ : stmts) body_result
 129   | uniqueOf v == otherwiseIdKey
 130   = matchGuard stmts body_result
 131
 132 matchGuard (GuardStmt expr _ : stmts) body_result
 133   = matchGuard stmts body_result        `thenDs` \ (MatchResult _ ty body_fn cxt) ->
 134     dsExpr expr                         `thenDs` \ core_expr ->
 135     let
 136         expr_fn = \ fail -> mkCoreIfThenElse core_expr (body_fn fail) fail
 137     in
 138     returnDs (MatchResult CanFail ty expr_fn cxt)
 139
 140 matchGuard (LetStmt binds : stmts) body_result
 141   = matchGuard stmts body_result          `thenDs` \ match_result ->
 142     dsBinds False{-don't auto scc-} binds `thenDs` \ core_binds ->
 143     returnDs (mkCoLetsMatchResult core_binds match_result)
 144
 145 matchGuard (BindStmt pat rhs _ : stmts) body_result
 146   = matchGuard stmts body_result                        `thenDs` \ match_result ->
 147     dsExpr rhs                                          `thenDs` \ core_rhs ->
 148     newSysLocalDs (coreExprType core_rhs)               `thenDs` \ scrut_var ->
 149     match [scrut_var] [EqnInfo [pat] match_result] []   `thenDs` \ match_result' ->
 150     returnDs (mkCoLetsMatchResult [NonRec scrut_var core_rhs] match_result')
 151 \end{code}