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 {-# OPTIONS -w #-}
  10 -- The above warning supression flag is a temporary kludge.
  11 -- While working on this module you are encouraged to remove it and fix
  12 -- any warnings in the module. See
  13 --     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
  14 -- for details
  15
  16 module DsGRHSs ( dsGuarded, dsGRHSs ) where
  17
  18 #include "HsVersions.h"
  19
  20 import {-# SOURCE #-} DsExpr  ( dsLExpr, dsLocalBinds )
  21 import {-# SOURCE #-} Match   ( matchSinglePat )
  22
  23 import HsSyn
  24 import CoreSyn
  25 import Var
  26 import Type
  27
  28 import DsMonad
  29 import DsUtils
  30 import PrelInfo
  31 import TysWiredIn
  32 import PrelNames
  33 import Name
  34 import SrcLoc
  35
  36 \end{code}
  37
  38 @dsGuarded@ is used for both @case@ expressions and pattern bindings.
  39 It desugars:
  40 \begin{verbatim}
  41         | g1 -> e1
  42         ...
  43         | gn -> en
  44         where binds
  45 \end{verbatim}
  46 producing an expression with a runtime error in the corner if
  47 necessary.  The type argument gives the type of the @ei@.
  48
  49 \begin{code}
  50 dsGuarded :: GRHSs Id -> Type -> DsM CoreExpr
  51
  52 dsGuarded grhss rhs_ty
  53   = dsGRHSs PatBindRhs [] grhss rhs_ty                          `thenDs` \ match_result ->
  54     mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty ""       `thenDs` \ error_expr ->
  55     extractMatchResult match_result error_expr
  56 \end{code}
  57
  58 In contrast, @dsGRHSs@ produces a @MatchResult@.
  59
  60 \begin{code}
  61 dsGRHSs :: HsMatchContext Name -> [Pat Id]      -- These are to build a MatchContext from
  62         -> GRHSs Id                             -- Guarded RHSs
  63         -> Type                                 -- Type of RHS
  64         -> DsM MatchResult
  65 dsGRHSs hs_ctx pats grhssa@(GRHSs grhss binds) rhs_ty = do
  66     match_results <- mappM (dsGRHS hs_ctx pats rhs_ty) grhss
  67     let
  68         match_result1 = foldr1 combineMatchResults match_results
  69         match_result2 = adjustMatchResultDs
  70                                  (\e -> dsLocalBinds binds e)
  71                                  match_result1
  72                 -- NB: nested dsLet inside matchResult
  73     --
  74     returnDs match_result2
  75
  76 dsGRHS hs_ctx pats rhs_ty (L loc (GRHS guards rhs))
  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   = matchGuards stmts ctx rhs rhs_ty    `thenDs` \ match_result ->
 121     returnDs (adjustMatchResultDs (dsLocalBinds binds) match_result)
 122         -- NB the dsLet occurs inside the match_result
 123         -- Reason: dsLet takes the body expression as its argument
 124         --         so we can't desugar the bindings without the
 125         --         body expression in hand
 126
 127 matchGuards (BindStmt pat bind_rhs _ _ : stmts) ctx rhs rhs_ty
 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}