\section[DsGRHSs]{Matching guarded right-hand-sides (GRHSs)}
\begin{code}
-#include "HsVersions.h"
-
module DsGRHSs ( dsGuarded, dsGRHSs ) where
-IMP_Ubiq()
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
-IMPORT_DELOOPER(DsLoop) -- break dsExpr/dsBinds-ish loop
-#else
+#include "HsVersions.h"
+
import {-# SOURCE #-} DsExpr ( dsExpr )
import {-# SOURCE #-} DsBinds ( dsBinds )
-import {-# SOURCE #-} Match ( match )
-#endif
+import {-# SOURCE #-} Match ( matchExport )
import HsSyn ( GRHSsAndBinds(..), GRHS(..),
HsExpr(..), HsBinds, Stmt(..),
HsLit, Match, Fixity, DoOrListComp, HsType, ArithSeqInfo
)
-import TcHsSyn ( SYN_IE(TypecheckedGRHSsAndBinds), SYN_IE(TypecheckedGRHS),
- SYN_IE(TypecheckedPat), SYN_IE(TypecheckedHsBinds),
- SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedStmt)
+import TcHsSyn ( TypecheckedGRHSsAndBinds, TypecheckedGRHS,
+ TypecheckedPat, TypecheckedHsBinds,
+ TypecheckedHsExpr, TypecheckedStmt
)
-import CoreSyn ( SYN_IE(CoreBinding), GenCoreBinding(..), SYN_IE(CoreExpr), mkCoLetsAny )
+import CoreSyn ( CoreBinding, GenCoreBinding(..), CoreExpr, mkCoLetsAny )
import DsMonad
import DsUtils
-
-#if __GLASGOW_HASKELL__ < 200
-import Id ( GenId )
-#endif
import CoreUtils ( coreExprType, mkCoreIfThenElse )
import PrelVals ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
-import Outputable ( PprStyle(..) )
import SrcLoc ( SrcLoc{-instance-} )
-import Type ( SYN_IE(Type) )
-import Unique ( Unique, otherwiseIdKey )
-import UniqFM ( Uniquable(..) )
-import Util ( panic )
+import Type ( Type )
+import Unique ( Unique, otherwiseIdKey, trueDataConKey, Uniquable(..) )
+import Outputable
\end{code}
@dsGuarded@ is used for both @case@ expressions and pattern bindings.
-> DsM CoreExpr
dsGuarded (GRHSsAndBindsOut grhss binds err_ty)
- = dsBinds Nothing binds `thenDs` \ core_binds ->
- dsGRHSs err_ty PatBindMatch [] grhss `thenDs` \ (MatchResult can_it_fail _ core_grhss_fn _) ->
+ = dsBinds False{-don't auto scc-} binds `thenDs` \ core_binds ->
+ 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 ->
dsGRHSs ty kind pats grhss `thenDs` \ match_result2 ->
combineGRHSMatchResults match_result1 match_result2
-dsGRHS ty kind pats (OtherwiseGRHS expr locn)
- = putSrcLocDs locn $
- dsExpr expr `thenDs` \ core_expr ->
- let
- expr_fn = \ ignore -> core_expr
- in
- returnDs (MatchResult CantFail ty expr_fn (DsMatchContext kind pats locn))
-
dsGRHS ty kind pats (GRHS guard expr locn)
= putSrcLocDs locn $
dsExpr expr `thenDs` \ core_expr ->
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}
\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 ->
- dsBinds Nothing binds `thenDs` \ core_binds ->
+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}