5adc661388f39c673c48a0099a7a303c438b7758
[ghc.git] / compiler / deSugar / DsGRHSs.hs
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
9 {-# LANGUAGE CPP #-}
10 {-# LANGUAGE ViewPatterns #-}
11
12 module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS, isTrueLHsExpr ) where
13
14 #include "HsVersions.h"
15
16 import GhcPrelude
17
18 import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds )
19 import {-# SOURCE #-} Match ( matchSinglePatVar )
20
21 import HsSyn
22 import MkCore
23 import CoreSyn
24 import CoreUtils (bindNonRec)
25
26 import Check (genCaseTmCs2)
27 import DsMonad
28 import DsUtils
29 import Type ( Type )
30 import Name
31 import Util
32 import SrcLoc
33 import Outputable
34
35 {-
36 @dsGuarded@ is used for pattern bindings.
37 It desugars:
38 \begin{verbatim}
39 | g1 -> e1
40 ...
41 | gn -> en
42 where binds
43 \end{verbatim}
44 producing an expression with a runtime error in the corner if
45 necessary. The type argument gives the type of the @ei@.
46 -}
47
48 dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> DsM CoreExpr
49 dsGuarded grhss rhs_ty = do
50 match_result <- dsGRHSs PatBindRhs grhss rhs_ty
51 error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty
52 extractMatchResult match_result error_expr
53
54 -- In contrast, @dsGRHSs@ produces a @MatchResult@.
55
56 dsGRHSs :: HsMatchContext Name
57 -> GRHSs GhcTc (LHsExpr GhcTc) -- Guarded RHSs
58 -> Type -- Type of RHS
59 -> DsM MatchResult
60 dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty
61 = ASSERT( notNull grhss )
62 do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss
63 ; let match_result1 = foldr1 combineMatchResults match_results
64 match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1
65 -- NB: nested dsLet inside matchResult
66 ; return match_result2 }
67 dsGRHSs _ (XGRHSs nec) _ = noExtCon nec
68
69 dsGRHS :: HsMatchContext Name -> Type -> LGRHS GhcTc (LHsExpr GhcTc)
70 -> DsM MatchResult
71 dsGRHS hs_ctx rhs_ty (dL->L _ (GRHS _ guards rhs))
72 = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty
73 dsGRHS _ _ (dL->L _ (XGRHS nec)) = noExtCon nec
74 dsGRHS _ _ _ = panic "dsGRHS: Impossible Match" -- due to #15884
75
76 {-
77 ************************************************************************
78 * *
79 * matchGuard : make a MatchResult from a guarded RHS *
80 * *
81 ************************************************************************
82 -}
83
84 matchGuards :: [GuardStmt GhcTc] -- Guard
85 -> HsStmtContext Name -- Context
86 -> LHsExpr GhcTc -- RHS
87 -> Type -- Type of RHS of guard
88 -> DsM MatchResult
89
90 -- See comments with HsExpr.Stmt re what a BodyStmt means
91 -- Here we must be in a guard context (not do-expression, nor list-comp)
92
93 matchGuards [] _ rhs _
94 = do { core_rhs <- dsLExpr rhs
95 ; return (cantFailMatchResult core_rhs) }
96
97 -- BodyStmts must be guards
98 -- Turn an "otherwise" guard is a no-op. This ensures that
99 -- you don't get a "non-exhaustive eqns" message when the guards
100 -- finish in "otherwise".
101 -- NB: The success of this clause depends on the typechecker not
102 -- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors
103 -- If it does, you'll get bogus overlap warnings
104 matchGuards (BodyStmt _ e _ _ : stmts) ctx rhs rhs_ty
105 | Just addTicks <- isTrueLHsExpr e = do
106 match_result <- matchGuards stmts ctx rhs rhs_ty
107 return (adjustMatchResultDs addTicks match_result)
108 matchGuards (BodyStmt _ expr _ _ : stmts) ctx rhs rhs_ty = do
109 match_result <- matchGuards stmts ctx rhs rhs_ty
110 pred_expr <- dsLExpr expr
111 return (mkGuardedMatchResult pred_expr match_result)
112
113 matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do
114 match_result <- matchGuards stmts ctx rhs rhs_ty
115 return (adjustMatchResultDs (dsLocalBinds binds) match_result)
116 -- NB the dsLet occurs inside the match_result
117 -- Reason: dsLet takes the body expression as its argument
118 -- so we can't desugar the bindings without the
119 -- body expression in hand
120
121 matchGuards (BindStmt _ pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do
122 let upat = unLoc pat
123 dicts = collectEvVarsPat upat
124 match_var <- selectMatchVar upat
125 tm_cs <- genCaseTmCs2 (Just bind_rhs) [upat] [match_var]
126 match_result <- addDictsDs dicts $
127 addTmCsDs tm_cs $
128 -- See Note [Type and Term Equality Propagation] in Check
129 matchGuards stmts ctx rhs rhs_ty
130 core_rhs <- dsLExpr bind_rhs
131 match_result' <- matchSinglePatVar match_var (StmtCtxt ctx) pat rhs_ty
132 match_result
133 pure $ adjustMatchResult (bindNonRec match_var core_rhs) match_result'
134
135 matchGuards (LastStmt {} : _) _ _ _ = panic "matchGuards LastStmt"
136 matchGuards (ParStmt {} : _) _ _ _ = panic "matchGuards ParStmt"
137 matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt"
138 matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt"
139 matchGuards (ApplicativeStmt {} : _) _ _ _ =
140 panic "matchGuards ApplicativeLastStmt"
141 matchGuards (XStmtLR nec : _) _ _ _ =
142 noExtCon nec
143
144 {-
145 Should {\em fail} if @e@ returns @D@
146 \begin{verbatim}
147 f x | p <- e', let C y# = e, f y# = r1
148 | otherwise = r2
149 \end{verbatim}
150 -}