compiler/deSugar/DsGRHSs.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 Matching guarded right-hand-sides (GRHSs)
   7
   8 \begin{code}
   9 module DsGRHSs ( dsGuarded, dsGRHSs ) where
  10
  11 #include "HsVersions.h"
  12
  13 import {-# SOURCE #-} DsExpr  ( dsLExpr, dsLocalBinds )
  14 import {-# SOURCE #-} Match   ( matchSinglePat )
  15
  16 import HsSyn
  17 import HsUtils
  18 import CoreSyn
  19 import Var
  20 import Type
  21
  22 import DsMonad
  23 import DsUtils
  24 import Unique
  25 import PrelInfo
  26 import TysWiredIn
  27 import PrelNames
  28 import Name
  29 import SrcLoc
  30
  31 \end{code}
  32
  33 @dsGuarded@ is used for both @case@ expressions and pattern bindings.
  34 It desugars:
  35 \begin{verbatim}
  36         | g1 -> e1
  37         ...
  38         | gn -> en
  39         where binds
  40 \end{verbatim}
  41 producing an expression with a runtime error in the corner if
  42 necessary.  The type argument gives the type of the @ei@.
  43
  44 \begin{code}
  45 dsGuarded :: GRHSs Id -> Type -> DsM CoreExpr
  46
  47 dsGuarded grhss rhs_ty
  48   = dsGRHSs PatBindRhs [] grhss rhs_ty                          `thenDs` \ match_result ->
  49     mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty ""       `thenDs` \ error_expr ->
  50     extractMatchResult match_result error_expr
  51 \end{code}
  52
  53 In contrast, @dsGRHSs@ produces a @MatchResult@.
  54
  55 \begin{code}
  56 dsGRHSs :: HsMatchContext Name -> [Pat Id]      -- These are to build a MatchContext from
  57         -> GRHSs Id                             -- Guarded RHSs
  58         -> Type                                 -- Type of RHS
  59         -> DsM MatchResult
  60 dsGRHSs hs_ctx pats (GRHSs grhss binds) rhs_ty =
  61    bindLocalsDs (bindsBinders ++ patsBinders) $
  62     mappM (dsGRHS hs_ctx pats rhs_ty) grhss     `thenDs` \ match_results ->
  63     let
  64         match_result1 = foldr1 combineMatchResults match_results
  65         match_result2 = adjustMatchResultDs
  66                                  (\e -> bindLocalsDs patsBinders $ dsLocalBinds binds e)
  67                                  match_result1
  68                 -- NB: nested dsLet inside matchResult
  69     in
  70     returnDs match_result2
  71         where bindsBinders = map unLoc (collectLocalBinders binds)
  72               patsBinders  = collectPatsBinders (map (L undefined) pats)
  73
  74 dsGRHS hs_ctx pats rhs_ty (L loc (GRHS guards rhs))
  75   = matchGuards (map unLoc guards) hs_ctx rhs rhs_ty
  76 \end{code}
  77
  78
  79 %************************************************************************
  80 %*                                                                      *
  81 %*  matchGuard : make a MatchResult from a guarded RHS                  *
  82 %*                                                                      *
  83 %************************************************************************
  84
  85 \begin{code}
  86 matchGuards :: [Stmt Id]                -- Guard
  87             -> HsMatchContext Name      -- Context
  88             -> LHsExpr Id               -- RHS
  89             -> Type                     -- Type of RHS of guard
  90             -> DsM MatchResult
  91
  92 -- See comments with HsExpr.Stmt re what an ExprStmt means
  93 -- Here we must be in a guard context (not do-expression, nor list-comp)
  94
  95 matchGuards [] ctx rhs rhs_ty
  96   = do  { core_rhs <- dsLExpr rhs
  97         ; return (cantFailMatchResult core_rhs) }
  98
  99         -- ExprStmts must be guards
 100         -- Turn an "otherwise" guard is a no-op.  This ensures that
 101         -- you don't get a "non-exhaustive eqns" message when the guards
 102         -- finish in "otherwise".
 103         -- NB:  The success of this clause depends on the typechecker not
 104         --      wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors
 105         --      If it does, you'll get bogus overlap warnings
 106 matchGuards (ExprStmt (L _ (HsVar v)) _ _ : stmts) ctx rhs rhs_ty
 107   |  v `hasKey` otherwiseIdKey
 108   || v `hasKey` getUnique trueDataConId
 109         -- trueDataConId doesn't have the same unique as trueDataCon
 110   = matchGuards stmts ctx rhs rhs_ty
 111
 112 matchGuards (ExprStmt expr _ _ : stmts) ctx rhs rhs_ty
 113   = matchGuards stmts ctx rhs rhs_ty    `thenDs` \ match_result ->
 114     dsLExpr expr                        `thenDs` \ pred_expr ->
 115     returnDs (mkGuardedMatchResult pred_expr match_result)
 116
 117 matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty
 118   = bindLocalsDs (map unLoc $ collectLocalBinders binds) $
 119     matchGuards stmts ctx rhs rhs_ty    `thenDs` \ match_result ->
 120     returnDs (adjustMatchResultDs (dsLocalBinds binds) match_result)
 121         -- NB the dsLet occurs inside the match_result
 122         -- Reason: dsLet takes the body expression as its argument
 123         --         so we can't desugar the bindings without the
 124         --         body expression in hand
 125
 126 matchGuards (BindStmt pat bind_rhs _ _ : stmts) ctx rhs rhs_ty
 127   = bindLocalsDs (collectPatBinders pat) $
 128     matchGuards stmts ctx rhs rhs_ty    `thenDs` \ match_result ->
 129     dsLExpr bind_rhs                    `thenDs` \ core_rhs ->
 130     matchSinglePat core_rhs ctx pat rhs_ty match_result
 131 \end{code}
 132
 133 Should {\em fail} if @e@ returns @D@
 134 \begin{verbatim}
 135 f x | p <- e', let C y# = e, f y# = r1
 136     | otherwise          = r2
 137 \end{verbatim}