%
-% (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
+#include "HsVersions.h"
+
+import {-# SOURCE #-} DsExpr ( dsExpr, dsLet )
+import {-# SOURCE #-} Match ( matchSinglePat )
-import AbsSyn -- the stuff being desugared
-import PlainCore -- the output of desugaring;
- -- importing this module also gets all the
- -- CoreSyn utility functions
-import DsMonad -- the monadery used in the desugarer
+import HsSyn ( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..), HsMatchContext(..) )
+import TcHsSyn ( TypecheckedGRHSs, TypecheckedPat, TypecheckedStmt )
+import CoreSyn ( CoreExpr )
+import Type ( Type )
-import AbsPrel ( stringTy
- IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy)
- )
-import DsBinds ( dsBinds )
-import DsExpr ( dsExpr )
+import DsMonad
import DsUtils
-import Pretty
-import Util
+import PrelInfo ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
+import PrelNames ( otherwiseIdKey, trueDataConKey, 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 PlainCoreExpr
-
-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 -> PlainCoreExpr
- error_expr str_var = mkErrorCoApp 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 @PlainCoreExpr@ for the case in which all of
-the guards fail.
+In contrast, @dsGRHSs@ produces a @MatchResult@.
\begin{code}
-dsGRHSs :: UniType -- 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
- 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
+dsGRHSs :: HsMatchContext -> [TypecheckedPat] -- These are to build a MatchContext from
+ -> TypecheckedGRHSs -- Guarded RHSs
+ -> DsM (Type, MatchResult)
+
+dsGRHSs kind pats (GRHSs grhss binds (Just 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 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.HsStmt re what an ExprStmt means
+-- Here we must be in a guard context (not do-expression, nor list-comp)
+
+matchGuard [ExprStmt expr locn] ctx
+ = putSrcLocDs locn (dsExpr expr) `thenDs` \ core_expr ->
+ returnDs (cantFailMatchResult core_expr)
+
+ -- Other ExprStmts must be guards
+ -- Turn an "otherwise" guard is a no-op
+matchGuard (ExprStmt (HsVar v) _ : stmts) ctx
+ | v `hasKey` otherwiseIdKey
+ || v `hasKey` trueDataConKey
+ = 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}