| ... |
... |
@@ -110,7 +110,7 @@ expand_do_stmts doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts) |
|
110
|
110
|
-- -------------------------------------------------------
|
|
111
|
111
|
-- pat <- e ; stmts ~~> (>>=) e f
|
|
112
|
112
|
= do expand_stmts_expr <- expand_do_stmts doFlavour lstmts
|
|
113
|
|
- failable_expr <- mk_failable_expr doFlavour pat expand_stmts_expr fail_op
|
|
|
113
|
+ failable_expr <- mk_failable_expr doFlavour pat stmt expand_stmts_expr fail_op
|
|
114
|
114
|
let expansion = genHsExpApps bind_op -- (>>=)
|
|
115
|
115
|
[ e
|
|
116
|
116
|
, failable_expr ]
|
| ... |
... |
@@ -181,8 +181,9 @@ expand_do_stmts doFlavour |
|
181
|
181
|
expand_do_stmts _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr stmts)
|
|
182
|
182
|
|
|
183
|
183
|
-- checks the pattern `pat` for irrefutability which decides if we need to wrap it with a fail block
|
|
184
|
|
-mk_failable_expr :: HsDoFlavour -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
|
|
185
|
|
-mk_failable_expr doFlav lpat expr@(L _exprloc _) fail_op =
|
|
|
184
|
+mk_failable_expr :: HsDoFlavour -> LPat GhcRn -> ExprLStmt GhcRn -> LHsExpr GhcRn
|
|
|
185
|
+ -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
|
|
|
186
|
+mk_failable_expr doFlav lpat stmt expr fail_op =
|
|
186
|
187
|
do { is_strict <- xoptM LangExt.Strict
|
|
187
|
188
|
; hscEnv <- getTopEnv
|
|
188
|
189
|
; rdrEnv <- getGlobalRdrEnv
|
| ... |
... |
@@ -194,15 +195,16 @@ mk_failable_expr doFlav lpat expr@(L _exprloc _) fail_op = |
|
194
|
195
|
; if irrf_pat -- don't wrap with fail block if
|
|
195
|
196
|
-- the pattern is irrefutable
|
|
196
|
197
|
then return $ genHsLamDoExp doFlav [lpat] expr
|
|
197
|
|
- else wrapGenSpan <$> mk_fail_block doFlav lpat expr fail_op
|
|
|
198
|
+ else wrapGenSpan <$> mk_fail_block doFlav lpat stmt expr fail_op
|
|
198
|
199
|
}
|
|
199
|
200
|
|
|
200
|
201
|
-- | Makes the fail block with a given fail_op
|
|
201
|
202
|
-- mk_fail_block pat rhs fail builds
|
|
202
|
203
|
-- \x. case x of {pat -> rhs; _ -> fail "Pattern match failure..."}
|
|
203
|
204
|
mk_fail_block :: HsDoFlavour
|
|
204
|
|
- -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (HsExpr GhcRn)
|
|
205
|
|
-mk_fail_block doFlav pat e (Just (SyntaxExprRn fail_op)) =
|
|
|
205
|
+ -> LPat GhcRn -> ExprLStmt GhcRn
|
|
|
206
|
+ -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (HsExpr GhcRn)
|
|
|
207
|
+mk_fail_block doFlav pat stmt e (Just (SyntaxExprRn fail_op)) =
|
|
206
|
208
|
do dflags <- getDynFlags
|
|
207
|
209
|
return $ HsLam noAnn LamCases $ mkMatchGroup (doExpansionOrigin doFlav) -- \
|
|
208
|
210
|
(wrapGenSpan [ genHsCaseAltDoExp doFlav pat e -- pat -> expr
|
| ... |
... |
@@ -210,12 +212,12 @@ mk_fail_block doFlav pat e (Just (SyntaxExprRn fail_op)) = |
|
210
|
212
|
])
|
|
211
|
213
|
where
|
|
212
|
214
|
fail_alt_case :: DynFlags -> LPat GhcRn -> HsExpr GhcRn -> LMatch GhcRn (LHsExpr GhcRn)
|
|
213
|
|
- fail_alt_case dflags pat fail_op = genHsCaseAltDoExp doFlav genWildPat $
|
|
214
|
|
- wrapGenSpan (fail_op_expr dflags pat fail_op)
|
|
|
215
|
+ fail_alt_case dflags pat@(L pat_span _) fail_op = genHsCaseAltDoExp doFlav genWildPat $
|
|
|
216
|
+ fail_op_expr dflags pat fail_op
|
|
215
|
217
|
|
|
216
|
|
- fail_op_expr :: DynFlags -> LPat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
|
|
217
|
|
- fail_op_expr dflags pat fail_op
|
|
218
|
|
- = mkExpandedPatRn (unLoc pat) $ genHsApp fail_op (mk_fail_msg_expr dflags pat)
|
|
|
218
|
+ fail_op_expr :: DynFlags -> LPat GhcRn -> HsExpr GhcRn -> LHsExpr GhcRn
|
|
|
219
|
+ fail_op_expr dflags pat@(L pat_lspan _) fail_op
|
|
|
220
|
+ = L pat_lspan $ mkExpandedPatRn (unLoc pat) stmt $ genHsApp fail_op (mk_fail_msg_expr dflags pat)
|
|
219
|
221
|
|
|
220
|
222
|
mk_fail_msg_expr :: DynFlags -> LPat GhcRn -> LHsExpr GhcRn
|
|
221
|
223
|
mk_fail_msg_expr dflags pat
|
| ... |
... |
@@ -223,8 +225,7 @@ mk_fail_block doFlav pat e (Just (SyntaxExprRn fail_op)) = |
|
223
|
225
|
text "Pattern match failure in" <+> pprHsDoFlavour (DoExpr Nothing)
|
|
224
|
226
|
<+> text "at" <+> ppr (getLocA pat)
|
|
225
|
227
|
|
|
226
|
|
-
|
|
227
|
|
-mk_fail_block _ _ _ _ = pprPanic "mk_fail_block: impossible happened" empty
|
|
|
228
|
+mk_fail_block _ _ _ _ _ = pprPanic "mk_fail_block: impossible happened" empty
|
|
228
|
229
|
|
|
229
|
230
|
|
|
230
|
231
|
{- Note [Expanding HsDo with XXExprGhcRn]
|
| ... |
... |
@@ -484,5 +485,5 @@ It stores the original statement (with location) and the expanded expression |
|
484
|
485
|
-}
|
|
485
|
486
|
|
|
486
|
487
|
|
|
487
|
|
-mkExpandedPatRn :: Pat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
|
|
488
|
|
-mkExpandedPatRn pat e = XExpr (ExpandedThingRn (OrigPat pat) e) |
|
|
488
|
+mkExpandedPatRn :: Pat GhcRn -> ExprLStmt GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
|
|
|
489
|
+mkExpandedPatRn pat stmt e = XExpr (ExpandedThingRn (OrigPat stmt pat) e) |