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