1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
Matching guarded right-hand-sides (GRHSs)
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ViewPatterns #-}
module GHC.HsToCore.GuardedRHSs ( dsGuarded, dsGRHSs, isTrueLHsExpr ) where
#include "HsVersions.h"
import GHC.Prelude
import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr, dsLocalBinds )
import {-# SOURCE #-} GHC.HsToCore.Match ( matchSinglePatVar )
import GHC.Hs
import GHC.Core.Make
import GHC.Core
import GHC.Core.Utils (bindNonRec)
import GHC.HsToCore.Monad
import GHC.HsToCore.Utils
import GHC.HsToCore.Pmc.Types ( Nablas )
import GHC.Core.Type ( Type )
import GHC.Utils.Misc
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Core.Multiplicity
import Control.Monad ( zipWithM )
import Data.List.NonEmpty ( NonEmpty, toList )
import GHC.Types.Name
{-
@dsGuarded@ is used for GRHSs.
It desugars:
\begin{verbatim}
| g1 -> e1
...
| gn -> en
where binds
\end{verbatim}
producing an expression with a runtime error in the corner case if
necessary. The type argument gives the type of the @ei@.
-}
dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> NonEmpty Nablas -> DsM CoreExpr
dsGuarded grhss rhs_ty rhss_nablas = do
match_result <- dsGRHSs PatBindRhs grhss rhs_ty rhss_nablas
error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty
extractMatchResult match_result error_expr
-- In contrast, @dsGRHSs@ produces a @MatchResult CoreExpr@.
dsGRHSs :: HsMatchContext Name
-> GRHSs GhcTc (LHsExpr GhcTc) -- ^ Guarded RHSs
-> Type -- ^ Type of RHS
-> NonEmpty Nablas -- ^ Refined pattern match checking
-- models, one for the pattern part and
-- one for each GRHS.
-> DsM (MatchResult CoreExpr)
dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty rhss_nablas
= ASSERT( notNull grhss )
do { match_results <- ASSERT( length grhss == length rhss_nablas )
zipWithM (dsGRHS hs_ctx rhs_ty) (toList rhss_nablas) grhss
; nablas <- getPmNablas
-- We need to remember the Nablas from the particular match context we
-- are in, which might be different to when dsLocalBinds is actually
-- called.
; let ds_binds = updPmNablas nablas . dsLocalBinds binds
match_result1 = foldr1 combineMatchResults match_results
match_result2 = adjustMatchResultDs ds_binds match_result1
-- NB: nested dsLet inside matchResult
; return match_result2 }
dsGRHS :: HsMatchContext Name -> Type -> Nablas -> LGRHS GhcTc (LHsExpr GhcTc)
-> DsM (MatchResult CoreExpr)
dsGRHS hs_ctx rhs_ty rhs_nablas (L _ (GRHS _ guards rhs))
= matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs_nablas rhs rhs_ty
{-
************************************************************************
* *
* matchGuard : make a MatchResult CoreExpr CoreExpr from a guarded RHS *
* *
************************************************************************
-}
matchGuards :: [GuardStmt GhcTc] -- Guard
-> HsStmtContext Name -- Context
-> Nablas -- The RHS's covered set for PmCheck
-> LHsExpr GhcTc -- RHS
-> Type -- Type of RHS of guard
-> DsM (MatchResult CoreExpr)
-- See comments with HsExpr.Stmt re what a BodyStmt means
-- Here we must be in a guard context (not do-expression, nor list-comp)
matchGuards [] _ nablas rhs _
= do { core_rhs <- updPmNablas nablas (dsLExpr rhs)
; return (cantFailMatchResult core_rhs) }
-- BodyStmts must be guards
-- Turn an "otherwise" guard is a no-op. This ensures that
-- you don't get a "non-exhaustive eqns" message when the guards
-- finish in "otherwise".
-- NB: The success of this clause depends on the typechecker not
-- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors
-- If it does, you'll get bogus overlap warnings
matchGuards (BodyStmt _ e _ _ : stmts) ctx nablas rhs rhs_ty
| Just addTicks <- isTrueLHsExpr e = do
match_result <- matchGuards stmts ctx nablas rhs rhs_ty
return (adjustMatchResultDs addTicks match_result)
matchGuards (BodyStmt _ expr _ _ : stmts) ctx nablas rhs rhs_ty = do
match_result <- matchGuards stmts ctx nablas rhs rhs_ty
pred_expr <- dsLExpr expr
return (mkGuardedMatchResult pred_expr match_result)
matchGuards (LetStmt _ binds : stmts) ctx nablas rhs rhs_ty = do
match_result <- matchGuards stmts ctx nablas rhs rhs_ty
return (adjustMatchResultDs (dsLocalBinds binds) match_result)
-- NB the dsLet occurs inside the match_result
-- Reason: dsLet takes the body expression as its argument
-- so we can't desugar the bindings without the
-- body expression in hand
matchGuards (BindStmt _ pat bind_rhs : stmts) ctx nablas rhs rhs_ty = do
let upat = unLoc pat
match_var <- selectMatchVar Many upat
-- We only allow unrestricted patterns in guard, hence the `Many`
-- above. It isn't clear what linear patterns would mean, maybe we will
-- figure it out in the future.
match_result <- matchGuards stmts ctx nablas rhs rhs_ty
core_rhs <- dsLExpr bind_rhs
match_result' <- matchSinglePatVar match_var (Just core_rhs) (StmtCtxt ctx)
pat rhs_ty match_result
pure $ bindNonRec match_var core_rhs <$> match_result'
matchGuards (LastStmt {} : _) _ _ _ _ = panic "matchGuards LastStmt"
matchGuards (ParStmt {} : _) _ _ _ _ = panic "matchGuards ParStmt"
matchGuards (TransStmt {} : _) _ _ _ _ = panic "matchGuards TransStmt"
matchGuards (RecStmt {} : _) _ _ _ _ = panic "matchGuards RecStmt"
matchGuards (ApplicativeStmt {} : _) _ _ _ _ =
panic "matchGuards ApplicativeLastStmt"
{-
Should {\em fail} if @e@ returns @D@
\begin{verbatim}
f x | p <- e', let C y# = e, f y# = r1
| otherwise = r2
\end{verbatim}
-}
|
