Encode shape information in `PmOracle`
[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 BasicTypes (Origin(FromSource))
27 import DynFlags
28 import Check (needToRunPmCheck, addTyCsDs, addPatTmCs, addScrutTmCs)
29 import DsMonad
30 import DsUtils
31 import Type ( Type )
32 import Name
33 import Util
34 import SrcLoc
35 import Outputable
36
37 {-
38 @dsGuarded@ is used for 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
50 dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> DsM CoreExpr
51 dsGuarded grhss rhs_ty = do
52 match_result <- dsGRHSs PatBindRhs grhss rhs_ty
53 error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty
54 extractMatchResult match_result error_expr
55
56 -- In contrast, @dsGRHSs@ produces a @MatchResult@.
57
58 dsGRHSs :: HsMatchContext Name
59 -> GRHSs GhcTc (LHsExpr GhcTc) -- Guarded RHSs
60 -> Type -- Type of RHS
61 -> DsM MatchResult
62 dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty
63 = ASSERT( notNull grhss )
64 do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss
65 ; let match_result1 = foldr1 combineMatchResults match_results
66 match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1
67 -- NB: nested dsLet inside matchResult
68 ; return match_result2 }
69 dsGRHSs _ (XGRHSs nec) _ = noExtCon nec
70
71 dsGRHS :: HsMatchContext Name -> Type -> LGRHS GhcTc (LHsExpr GhcTc)
72 -> DsM MatchResult
73 dsGRHS hs_ctx rhs_ty (dL->L _ (GRHS _ guards rhs))
74 = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty
75 dsGRHS _ _ (dL->L _ (XGRHS nec)) = noExtCon nec
76 dsGRHS _ _ _ = panic "dsGRHS: Impossible Match" -- due to #15884
77
78 {-
79 ************************************************************************
80 * *
81 * matchGuard : make a MatchResult from a guarded RHS *
82 * *
83 ************************************************************************
84 -}
85
86 matchGuards :: [GuardStmt GhcTc] -- Guard
87 -> HsStmtContext Name -- Context
88 -> LHsExpr GhcTc -- RHS
89 -> Type -- Type of RHS of guard
90 -> DsM MatchResult
91
92 -- See comments with HsExpr.Stmt re what a BodyStmt means
93 -- Here we must be in a guard context (not do-expression, nor list-comp)
94
95 matchGuards [] _ rhs _
96 = do { core_rhs <- dsLExpr rhs
97 ; return (cantFailMatchResult core_rhs) }
98
99 -- BodyStmts must be guards
100 -- Turn an "otherwise" guard is a no-op. This ensures that
101 -- you don't get a "non-exhaustive eqns" message when the guards
102 -- finish in "otherwise".
103 -- NB: The success of this clause depends on the typechecker not
104 -- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors
105 -- If it does, you'll get bogus overlap warnings
106 matchGuards (BodyStmt _ e _ _ : stmts) ctx rhs rhs_ty
107 | Just addTicks <- isTrueLHsExpr e = do
108 match_result <- matchGuards stmts ctx rhs rhs_ty
109 return (adjustMatchResultDs addTicks match_result)
110 matchGuards (BodyStmt _ expr _ _ : stmts) ctx rhs rhs_ty = do
111 match_result <- matchGuards stmts ctx rhs rhs_ty
112 pred_expr <- dsLExpr expr
113 return (mkGuardedMatchResult pred_expr match_result)
114
115 matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do
116 match_result <- matchGuards stmts ctx rhs rhs_ty
117 return (adjustMatchResultDs (dsLocalBinds binds) match_result)
118 -- NB the dsLet occurs inside the match_result
119 -- Reason: dsLet takes the body expression as its argument
120 -- so we can't desugar the bindings without the
121 -- body expression in hand
122
123 matchGuards (BindStmt _ pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do
124 let upat = unLoc pat
125 dicts = collectEvVarsPat upat
126 match_var <- selectMatchVar upat
127
128 dflags <- getDynFlags
129 match_result <-
130 -- See Note [Type and Term Equality Propagation] in Check
131 applyWhen (needToRunPmCheck dflags FromSource)
132 -- FromSource might not be accurate, but at worst
133 -- we do superfluous calls to the pattern match
134 -- oracle.
135 (addTyCsDs dicts . addScrutTmCs (Just bind_rhs) [match_var] . addPatTmCs [upat] [match_var])
136 (matchGuards stmts ctx rhs rhs_ty)
137 core_rhs <- dsLExpr bind_rhs
138 match_result' <- matchSinglePatVar match_var (StmtCtxt ctx) pat rhs_ty
139 match_result
140 pure $ adjustMatchResult (bindNonRec match_var core_rhs) match_result'
141
142 matchGuards (LastStmt {} : _) _ _ _ = panic "matchGuards LastStmt"
143 matchGuards (ParStmt {} : _) _ _ _ = panic "matchGuards ParStmt"
144 matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt"
145 matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt"
146 matchGuards (ApplicativeStmt {} : _) _ _ _ =
147 panic "matchGuards ApplicativeLastStmt"
148 matchGuards (XStmtLR nec : _) _ _ _ =
149 noExtCon nec
150
151 {-
152 Should {\em fail} if @e@ returns @D@
153 \begin{verbatim}
154 f x | p <- e', let C y# = e, f y# = r1
155 | otherwise = r2
156 \end{verbatim}
157 -}