From d0ff97d871ea4a7cf5abef980c164dbcf1d669e5 Mon Sep 17 00:00:00 2001
From: quintela <unknown>
Date: Tue, 2 Dec 1997 18:22:47 +0000
Subject: [PATCH] [project @ 1997-12-02 18:22:47 by quintela] change match by
matchExport and changes related with the new type of MAtchResult
---
ghc/compiler/deSugar/DsGRHSs.lhs | 40 ++++++++++++++++++--------------
1 file changed, 22 insertions(+), 18 deletions(-)
diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs
index b22c6fa4131c..2ba429ef0fb5 100644
--- a/ghc/compiler/deSugar/DsGRHSs.lhs
+++ b/ghc/compiler/deSugar/DsGRHSs.lhs
@@ -14,7 +14,7 @@ IMPORT_DELOOPER(DsLoop) -- break dsExpr/dsBinds-ish loop
#else
import {-# SOURCE #-} DsExpr ( dsExpr )
import {-# SOURCE #-} DsBinds ( dsBinds )
-import {-# SOURCE #-} Match ( match )
+import {-# SOURCE #-} Match ( matchExport )
#endif
import HsSyn ( GRHSsAndBinds(..), GRHS(..),
@@ -38,7 +38,7 @@ import PrelVals ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
import Outputable ( PprStyle(..) )
import SrcLoc ( SrcLoc{-instance-} )
import Type ( SYN_IE(Type) )
-import Unique ( Unique, otherwiseIdKey, Uniquable(..) )
+import Unique ( Unique, otherwiseIdKey, trueDataConKey, Uniquable(..) )
import Util ( panic )
\end{code}
@@ -59,7 +59,7 @@ dsGuarded :: TypecheckedGRHSsAndBinds
dsGuarded (GRHSsAndBindsOut grhss binds err_ty)
= dsBinds False{-don't auto scc-} binds `thenDs` \ core_binds ->
- dsGRHSs err_ty PatBindMatch [] grhss `thenDs` \ (MatchResult can_it_fail _ core_grhss_fn _) ->
+ dsGRHSs err_ty PatBindMatch [] grhss `thenDs` \ (MatchResult can_it_fail _ core_grhss_fn) ->
case can_it_fail of
CantFail -> returnDs (mkCoLetsAny core_binds (core_grhss_fn (panic "It can't fail")))
CanFail -> mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID err_ty "" `thenDs` \ error_expr ->
@@ -96,7 +96,7 @@ dsGRHS ty kind pats (OtherwiseGRHS expr locn)
let
expr_fn = \ ignore -> core_expr
in
- returnDs (MatchResult CantFail ty expr_fn (DsMatchContext kind pats locn))
+ returnDs (MatchResult CantFail ty expr_fn ) --(DsMatchContext kind pats locn))
dsGRHS ty kind pats (GRHS guard expr locn)
= putSrcLocDs locn $
@@ -104,7 +104,7 @@ dsGRHS ty kind pats (GRHS guard expr locn)
let
expr_fn = \ ignore -> core_expr
in
- matchGuard guard (MatchResult CantFail ty expr_fn (DsMatchContext kind pats locn))
+ matchGuard guard (DsMatchContext kind pats locn) (MatchResult CantFail ty expr_fn)
\end{code}
@@ -118,33 +118,37 @@ dsGRHS ty kind pats (GRHS guard expr locn)
\begin{code}
matchGuard :: [TypecheckedStmt] -- Guard
+ -> DsMatchContext -- Context
-> MatchResult -- What to do if the guard succeeds
-> DsM MatchResult
-matchGuard [] body_result = returnDs body_result
+matchGuard [] ctx body_result = returnDs body_result
-- Turn an "otherwise" guard is a no-op
-matchGuard (GuardStmt (HsVar v) _ : stmts) body_result
- | uniqueOf v == otherwiseIdKey
- = matchGuard stmts body_result
-
-matchGuard (GuardStmt expr _ : stmts) body_result
- = matchGuard stmts body_result `thenDs` \ (MatchResult _ ty body_fn cxt) ->
+matchGuard (GuardStmt (HsVar v) _ : stmts) ctx body_result
+ | uniq == otherwiseIdKey
+ || uniq == trueDataConKey
+ = matchGuard stmts ctx body_result
+ where
+ uniq = uniqueOf v
+
+matchGuard (GuardStmt expr _ : stmts) ctx body_result
+ = matchGuard stmts ctx body_result `thenDs` \ (MatchResult _ ty body_fn) ->
dsExpr expr `thenDs` \ core_expr ->
let
expr_fn = \ fail -> mkCoreIfThenElse core_expr (body_fn fail) fail
in
- returnDs (MatchResult CanFail ty expr_fn cxt)
+ returnDs (MatchResult CanFail ty expr_fn)
-matchGuard (LetStmt binds : stmts) body_result
- = matchGuard stmts body_result `thenDs` \ match_result ->
+matchGuard (LetStmt binds : stmts) ctx body_result
+ = matchGuard stmts ctx body_result `thenDs` \ match_result ->
dsBinds False{-don't auto scc-} binds `thenDs` \ core_binds ->
returnDs (mkCoLetsMatchResult core_binds match_result)
-matchGuard (BindStmt pat rhs _ : stmts) body_result
- = matchGuard stmts body_result `thenDs` \ match_result ->
+matchGuard (BindStmt pat rhs _ : stmts) ctx body_result
+ = matchGuard stmts ctx body_result `thenDs` \ match_result ->
dsExpr rhs `thenDs` \ core_rhs ->
newSysLocalDs (coreExprType core_rhs) `thenDs` \ scrut_var ->
- match [scrut_var] [EqnInfo [pat] match_result] [] `thenDs` \ match_result' ->
+ matchExport [scrut_var] [EqnInfo 1 ctx [pat] match_result] `thenDs` \ match_result' ->
returnDs (mkCoLetsMatchResult [NonRec scrut_var core_rhs] match_result')
\end{code}
--
GitLab