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