%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[DsGRHSs]{Matching guarded right-hand-sides (GRHSs)}
\begin{code}
+module DsGRHSs ( dsGuarded, dsGRHSs ) where
+
#include "HsVersions.h"
-module DsGRHSs ( dsGuarded, dsGRHSs ) where
+import {-# SOURCE #-} DsExpr ( dsLExpr, dsLet )
+import {-# SOURCE #-} Match ( matchSinglePat )
-IMP_Ubiq()
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
-IMPORT_DELOOPER(DsLoop) -- break dsExpr/dsBinds-ish loop
-#else
-import {-# SOURCE #-} DsExpr ( dsExpr )
-import {-# SOURCE #-} DsBinds ( dsBinds )
-import {-# SOURCE #-} Match ( match )
-#endif
-
-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 CoreSyn ( SYN_IE(CoreBinding), GenCoreBinding(..), SYN_IE(CoreExpr), mkCoLetsAny )
+import HsSyn ( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..),
+ HsMatchContext(..), Pat(..) )
+import CoreSyn ( CoreExpr )
+import Type ( Type )
+import Var ( Id )
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, Uniquable(..) )
-import Util ( panic )
+import Unique ( Uniquable(..) )
+import PrelInfo ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
+import TysWiredIn ( trueDataConId )
+import PrelNames ( otherwiseIdKey, hasKey )
+import Name ( Name )
+import SrcLoc ( unLoc, Located(..) )
\end{code}
@dsGuarded@ is used for both @case@ expressions and pattern bindings.
where binds
\end{verbatim}
producing an expression with a runtime error in the corner if
-necessary. The type argument gives the type of the ei.
+necessary. The type argument gives the type of the @ei@.
\begin{code}
-dsGuarded :: TypecheckedGRHSsAndBinds
- -> DsM CoreExpr
-
-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 _) ->
- 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 ->
- returnDs (mkCoLetsAny core_binds (core_grhss_fn error_expr))
+dsGuarded :: GRHSs Id -> DsM CoreExpr
+
+dsGuarded grhss
+ = dsGRHSs PatBindRhs [] grhss `thenDs` \ (err_ty, match_result) ->
+ mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID err_ty "" `thenDs` \ error_expr ->
+ extractMatchResult match_result error_expr
\end{code}
-Desugar a list of (grhs, expr) pairs [grhs = guarded
-right-hand-side], as in:
-\begin{verbatim}
-p | g1 = e1
- | g2 = e2
- ...
- | gm = em
-\end{verbatim}
-We supply a @CoreExpr@ for the case in which all of
-the guards fail.
+In contrast, @dsGRHSs@ produces a @MatchResult@.
\begin{code}
-dsGRHSs :: Type -- Type of RHSs
- -> DsMatchKind -> [TypecheckedPat] -- These are to build a MatchContext from
- -> [TypecheckedGRHS] -- Guarded RHSs
- -> DsM MatchResult
-
-dsGRHSs ty kind pats [grhs] = dsGRHS ty kind pats grhs
-
-dsGRHSs ty kind pats (grhs:grhss)
- = dsGRHS ty kind pats grhs `thenDs` \ match_result1 ->
- 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
+dsGRHSs :: HsMatchContext Name -> [Pat Id] -- These are to build a MatchContext from
+ -> GRHSs Id -- Guarded RHSs
+ -> DsM (Type, MatchResult)
+
+dsGRHSs kind pats (GRHSs grhss binds ty)
+ = mappM (dsGRHS kind pats) grhss `thenDs` \ match_results ->
+ let
+ match_result1 = foldr1 combineMatchResults match_results
+ match_result2 = adjustMatchResultDs (dsLet binds) match_result1
+ -- NB: nested dsLet inside matchResult
in
- returnDs (MatchResult CantFail ty expr_fn (DsMatchContext kind pats locn))
+ returnDs (ty, match_result2)
-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))
+dsGRHS kind pats (L loc (GRHS guard))
+ = matchGuard (map unLoc guard) (DsMatchContext kind pats loc)
\end{code}
-
-
%************************************************************************
%* *
%* matchGuard : make a MatchResult from a guarded RHS *
%************************************************************************
\begin{code}
-matchGuard :: [TypecheckedStmt] -- Guard
- -> MatchResult -- What to do if the guard succeeds
+matchGuard :: [Stmt Id] -- Guard
+ -> DsMatchContext -- Context
-> DsM MatchResult
-matchGuard [] body_result = returnDs body_result
+-- See comments with HsExpr.Stmt re what an ExprStmt means
+-- Here we must be in a guard context (not do-expression, nor list-comp)
+matchGuard [ResultStmt expr] ctx
+ = dsLExpr expr `thenDs` \ core_expr ->
+ returnDs (cantFailMatchResult core_expr)
+
+ -- ExprStmts must be guards
-- 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) ->
- dsExpr expr `thenDs` \ core_expr ->
- let
- expr_fn = \ fail -> mkCoreIfThenElse core_expr (body_fn fail) fail
- in
- returnDs (MatchResult CanFail ty expr_fn cxt)
-
-matchGuard (LetStmt binds : stmts) body_result
- = matchGuard stmts 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 ->
- dsExpr rhs `thenDs` \ core_rhs ->
- newSysLocalDs (coreExprType core_rhs) `thenDs` \ scrut_var ->
- match [scrut_var] [EqnInfo [pat] match_result] [] `thenDs` \ match_result' ->
- returnDs (mkCoLetsMatchResult [NonRec scrut_var core_rhs] match_result')
+matchGuard (ExprStmt (L _ (HsVar v)) _ : stmts) ctx
+ | v `hasKey` otherwiseIdKey
+ || v `hasKey` getUnique trueDataConId
+ -- trueDataConId doesn't have the same
+ -- unique as trueDataCon
+ = matchGuard stmts ctx
+
+matchGuard (ExprStmt expr _ : stmts) ctx
+ = matchGuard stmts ctx `thenDs` \ match_result ->
+ dsLExpr expr `thenDs` \ pred_expr ->
+ returnDs (mkGuardedMatchResult pred_expr match_result)
+
+matchGuard (LetStmt binds : stmts) ctx
+ = matchGuard stmts ctx `thenDs` \ match_result ->
+ returnDs (adjustMatchResultDs (dsLet binds) match_result)
+ -- NB the dsLet occurs inside the match_result
+
+matchGuard (BindStmt pat rhs : stmts) ctx
+ = matchGuard stmts ctx `thenDs` \ match_result ->
+ dsLExpr rhs `thenDs` \ core_rhs ->
+ matchSinglePat core_rhs ctx pat match_result
\end{code}
+
+Should {\em fail} if @e@ returns @D@
+\begin{verbatim}
+f x | p <- e', let C y# = e, f y# = r1
+ | otherwise = r2
+\end{verbatim}
projects / ghc-hetmet.git / blobdiff