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