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   ( matchExport )
  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, trueDataConKey, Uniquable(..) )
  42 import Util             ( panic )
  43 \end{code}
  44
  45 @dsGuarded@ is used for both @case@ expressions and pattern bindings.
  46 It desugars:
  47 \begin{verbatim}
  48         | g1 -> e1
  49         ...
  50         | gn -> en
  51         where binds
  52 \end{verbatim}
  53 producing an expression with a runtime error in the corner if
  54 necessary.  The type argument gives the type of the ei.
  55
  56 \begin{code}
  57 dsGuarded :: TypecheckedGRHSsAndBinds
  58           -> DsM CoreExpr
  59
  60 dsGuarded (GRHSsAndBindsOut grhss binds err_ty)
  61   = dsBinds False{-don't auto scc-} binds       `thenDs` \ core_binds ->
  62     dsGRHSs err_ty PatBindMatch [] grhss        `thenDs` \ (MatchResult can_it_fail _ core_grhss_fn) ->
  63     case can_it_fail of
  64         CantFail -> returnDs (mkCoLetsAny core_binds (core_grhss_fn (panic "It can't fail")))
  65         CanFail  -> mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID err_ty "" `thenDs` \ error_expr ->
  66                     returnDs (mkCoLetsAny core_binds (core_grhss_fn error_expr))
  67 \end{code}
  68
  69 Desugar a list of (grhs, expr) pairs [grhs = guarded
  70 right-hand-side], as in:
  71 \begin{verbatim}
  72 p | g1 = e1
  73   | g2 = e2
  74   ...
  75   | gm = em
  76 \end{verbatim}
  77 We supply a @CoreExpr@ for the case in which all of
  78 the guards fail.
  79
  80 \begin{code}
  81 dsGRHSs :: Type                         -- Type of RHSs
  82         -> DsMatchKind -> [TypecheckedPat]      -- These are to build a MatchContext from
  83         -> [TypecheckedGRHS]                    -- Guarded RHSs
  84         -> DsM MatchResult
  85
  86 dsGRHSs ty kind pats [grhs] = dsGRHS ty kind pats grhs
  87
  88 dsGRHSs ty kind pats (grhs:grhss)
  89   = dsGRHS ty kind pats grhs    `thenDs` \ match_result1 ->
  90     dsGRHSs ty kind pats grhss  `thenDs` \ match_result2 ->
  91     combineGRHSMatchResults match_result1 match_result2
  92
  93 dsGRHS ty kind pats (OtherwiseGRHS expr locn)
  94   = putSrcLocDs locn $
  95     dsExpr expr         `thenDs` \ core_expr ->
  96     let
  97         expr_fn = \ ignore -> core_expr
  98     in
  99     returnDs (MatchResult CantFail ty expr_fn ) --(DsMatchContext kind pats locn))
 100
 101 dsGRHS ty kind pats (GRHS guard expr locn)
 102   = putSrcLocDs locn $
 103     dsExpr expr         `thenDs` \ core_expr ->
 104     let
 105         expr_fn = \ ignore -> core_expr
 106     in
 107     matchGuard guard (DsMatchContext kind pats locn) (MatchResult CantFail ty expr_fn)
 108 \end{code}
 109
 110
 111
 112
 113 %************************************************************************
 114 %*                                                                      *
 115 %*  matchGuard : make a MatchResult from a guarded RHS                  *
 116 %*                                                                      *
 117 %************************************************************************
 118
 119 \begin{code}
 120 matchGuard :: [TypecheckedStmt]         -- Guard
 121            -> DsMatchContext            -- Context
 122            -> MatchResult               -- What to do if the guard succeeds
 123            -> DsM MatchResult
 124
 125 matchGuard [] ctx body_result = returnDs body_result
 126
 127         -- Turn an "otherwise" guard is a no-op
 128 matchGuard (GuardStmt (HsVar v) _ : stmts) ctx body_result
 129   |  uniq == otherwiseIdKey
 130   || uniq == trueDataConKey
 131   = matchGuard stmts ctx body_result
 132   where
 133     uniq = uniqueOf v
 134
 135 matchGuard (GuardStmt expr _ : stmts) ctx body_result
 136   = matchGuard stmts ctx body_result    `thenDs` \ (MatchResult _ ty body_fn) ->
 137     dsExpr expr                         `thenDs` \ core_expr ->
 138     let
 139         expr_fn = \ fail -> mkCoreIfThenElse core_expr (body_fn fail) fail
 140     in
 141     returnDs (MatchResult CanFail ty expr_fn)
 142
 143 matchGuard (LetStmt binds : stmts) ctx body_result
 144   = matchGuard stmts ctx body_result      `thenDs` \ match_result ->
 145     dsBinds False{-don't auto scc-} binds `thenDs` \ core_binds ->
 146     returnDs (mkCoLetsMatchResult core_binds match_result)
 147
 148 matchGuard (BindStmt pat rhs _ : stmts) ctx body_result
 149   = matchGuard stmts ctx body_result                    `thenDs` \ match_result ->
 150     dsExpr rhs                                          `thenDs` \ core_rhs ->
 151     newSysLocalDs (coreExprType core_rhs)               `thenDs` \ scrut_var ->
 152     matchExport [scrut_var] [EqnInfo 1 ctx [pat] match_result]  `thenDs` \ match_result' ->
 153     returnDs (mkCoLetsMatchResult [NonRec scrut_var core_rhs] match_result')
 154 \end{code}