X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsGRHSs.lhs;h=0aef3a6e4ded048a09524efaecb5f13c373d82e3;hb=4cdc197978cf22419b2f4344a19c87c474c8fc1c;hp=b6a1c905069e6a467579f85c1e063c8d696da18a;hpb=dcef38bab91d45b56f7cf3ceeec96303d93728bb;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs index b6a1c90..0aef3a6 100644 --- a/ghc/compiler/deSugar/DsGRHSs.lhs +++ b/ghc/compiler/deSugar/DsGRHSs.lhs @@ -1,40 +1,27 @@ % -% (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} -#include "HsVersions.h" - module DsGRHSs ( dsGuarded, dsGRHSs ) where -IMP_Ubiq() -IMPORT_DELOOPER(DsLoop) -- break dsExpr/dsBinds-ish loop +#include "HsVersions.h" + +import {-# SOURCE #-} DsExpr ( dsExpr, dsLet ) +import {-# SOURCE #-} Match ( matchSinglePat ) -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(..) ) +import TcHsSyn ( TypecheckedGRHSs, TypecheckedPat, TypecheckedStmt, TypecheckedMatchContext ) +import CoreSyn ( CoreExpr ) +import Type ( Type ) import DsMonad import DsUtils - -#if __GLASGOW_HASKELL__ < 200 -import Id ( GenId ) -#endif -import CoreUtils ( coreExprType, mkCoreIfThenElse ) -import PrelVals ( nON_EXHAUSTIVE_GUARDS_ERROR_ID ) -import PprStyle ( PprStyle(..) ) -import SrcLoc ( SrcLoc{-instance-} ) -import Type ( SYN_IE(Type) ) -import Unique ( Unique, otherwiseIdKey ) -import UniqFM ( Uniquable(..) ) -import Util ( panic ) +import Unique ( Uniquable(..) ) +import PrelInfo ( nON_EXHAUSTIVE_GUARDS_ERROR_ID ) +import TysWiredIn ( trueDataConId ) +import PrelNames ( otherwiseIdKey, hasKey ) \end{code} @dsGuarded@ is used for both @case@ expressions and pattern bindings. @@ -46,65 +33,38 @@ It desugars: 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 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 :: TypecheckedGRHSs -> 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 :: TypecheckedMatchContext -> [TypecheckedPat] -- These are to build a MatchContext from + -> TypecheckedGRHSs -- Guarded RHSs + -> DsM (Type, MatchResult) + +dsGRHSs kind pats (GRHSs grhss binds ty) + = mapDs (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 (GRHS guard locn) + = matchGuard guard (DsMatchContext kind pats locn) \end{code} - - %************************************************************************ %* * %* matchGuard : make a MatchResult from a guarded RHS * @@ -113,33 +73,43 @@ dsGRHS ty kind pats (GRHS guard expr locn) \begin{code} matchGuard :: [TypecheckedStmt] -- Guard - -> MatchResult -- What to do if the guard succeeds + -> 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 locn] ctx + = putSrcLocDs locn (dsExpr 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 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 (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 _ locn : stmts) ctx + = matchGuard stmts ctx `thenDs` \ match_result -> + putSrcLocDs locn (dsExpr 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 locn : stmts) ctx + = matchGuard stmts ctx `thenDs` \ match_result -> + putSrcLocDs locn (dsExpr 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}