X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsGRHSs.lhs;h=b36632699daa4914d1480ca806ccfefc8ce367df;hb=f714e6b642fd614a9971717045ae47c3d871275e;hp=b22c6fa4131cc5528b90dbe98644615ceb182d58;hpb=38db229302890403037c5de7453299b3538bb404;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs index b22c6fa..b366326 100644 --- a/ghc/compiler/deSugar/DsGRHSs.lhs +++ b/ghc/compiler/deSugar/DsGRHSs.lhs @@ -1,45 +1,30 @@ % -% (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. @@ -51,65 +36,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 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 * @@ -117,34 +75,44 @@ dsGRHS ty kind pats (GRHS guard expr locn) %************************************************************************ \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}