%
-% (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
-import Ubiq
-import DsLoop -- break dsExpr/dsBinds-ish loop
+#include "HsVersions.h"
-import HsSyn ( GRHSsAndBinds(..), GRHS(..),
- HsExpr, HsBinds )
-import TcHsSyn ( TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..),
- TypecheckedPat(..), TypecheckedHsBinds(..),
- TypecheckedHsExpr(..) )
-import CoreSyn ( CoreBinding(..), CoreExpr(..) )
+import {-# SOURCE #-} DsExpr ( dsExpr, dsLet )
+import {-# SOURCE #-} Match ( matchSinglePat )
+
+import HsSyn ( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..), HsMatchContext(..) )
+import TcHsSyn ( TypecheckedGRHSs, TypecheckedPat, TypecheckedStmt, TypecheckedMatchContext )
+import CoreSyn ( CoreExpr )
+import Type ( Type )
import DsMonad
import DsUtils
-
-import CoreUtils ( escErrorMsg, mkErrorApp )
-import PrelInfo ( stringTy )
-import PprStyle ( PprStyle(..) )
-import Pretty ( ppShow )
-import SrcLoc ( SrcLoc{-instance-} )
-import Util ( panic )
-
-mkCoLetsAny = panic "DsGRHSs.mkCoLetsAny"
-mkCoreIfThenElse = panic "DsGRHSs.mkCoreIfThenElse"
+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.
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
- -> SrcLoc
- -> DsM CoreExpr
-
-dsGuarded (GRHSsAndBindsOut grhss binds err_ty) err_loc
- = 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 -> newSysLocalDs stringTy `thenDs` \ str_var -> -- to hold the String
- returnDs (mkCoLetsAny core_binds (core_grhss_fn (error_expr str_var)))
- where
- unencoded_part_of_msg = escErrorMsg (ppShow 80 (ppr PprForUser err_loc))
-
- error_expr :: Id -> CoreExpr
- error_expr str_var = mkErrorApp err_ty str_var
- (unencoded_part_of_msg
- ++ "%N") --> ": non-exhaustive guards"
+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)
+ = 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))
- )
-
-dsGRHS ty kind pats (GRHS guard expr locn)
- = putSrcLocDs locn (
- dsExpr guard `thenDs` \ core_guard ->
- dsExpr expr `thenDs` \ core_expr ->
- let
- expr_fn = \ fail -> mkCoreIfThenElse core_guard core_expr fail
- in
- returnDs (MatchResult CanFail ty expr_fn (DsMatchContext kind pats locn))
- )
+ returnDs (ty, match_result2)
+
+dsGRHS kind pats (GRHS guard locn)
+ = matchGuard guard (DsMatchContext kind pats locn)
\end{code}
+%************************************************************************
+%* *
+%* matchGuard : make a MatchResult from a guarded RHS *
+%* *
+%************************************************************************
+
+\begin{code}
+matchGuard :: [TypecheckedStmt] -- Guard
+ -> DsMatchContext -- Context
+ -> DsM MatchResult
+
+-- 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 (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}
projects / ghc-hetmet.git / blobdiff