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