\section[DsGRHSs]{Matching guarded right-hand-sides (GRHSs)}
\begin{code}
-#include "HsVersions.h"
-
module DsGRHSs ( dsGuarded, dsGRHSs ) where
+#include "HsVersions.h"
-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 AbsPrel ( stringTy
- IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy)
+import {-# SOURCE #-} DsExpr ( dsExpr )
+import {-# SOURCE #-} DsBinds ( dsBinds )
+import {-# SOURCE #-} Match ( matchExport )
+
+import HsSyn ( GRHSsAndBinds(..), GRHS(..),
+ HsExpr(..), HsBinds, Stmt(..),
+ HsLit, Match, Fixity, DoOrListComp, HsType, ArithSeqInfo
+ )
+import TcHsSyn ( TypecheckedGRHSsAndBinds, TypecheckedGRHS,
+ TypecheckedPat, TypecheckedHsBinds,
+ TypecheckedHsExpr, TypecheckedStmt
)
-import DsBinds ( dsBinds )
-import DsExpr ( dsExpr )
+import CoreSyn ( CoreBinding, GenCoreBinding(..), CoreExpr, mkCoLetsAny )
+
+import DsMonad
import DsUtils
-import Pretty
-import Util
+import CoreUtils ( coreExprType, mkCoreIfThenElse )
+import PrelVals ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
+import SrcLoc ( SrcLoc{-instance-} )
+import Type ( Type )
+import Unique ( Unique, otherwiseIdKey, trueDataConKey, Uniquable(..) )
+import Outputable
\end{code}
@dsGuarded@ is used for both @case@ expressions and pattern bindings.
\begin{code}
dsGuarded :: TypecheckedGRHSsAndBinds
- -> SrcLoc
- -> DsM PlainCoreExpr
+ -> 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 _) ->
+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 -> 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"
+ CanFail -> mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID err_ty "" `thenDs` \ error_expr ->
+ returnDs (mkCoLetsAny core_binds (core_grhss_fn error_expr))
\end{code}
Desugar a list of (grhs, expr) pairs [grhs = guarded
...
| gm = em
\end{verbatim}
-We supply a @PlainCoreExpr@ for the case in which all of
+We supply a @CoreExpr@ for the case in which all of
the guards fail.
\begin{code}
-dsGRHSs :: UniType -- Type of RHSs
+dsGRHSs :: Type -- Type of RHSs
-> DsMatchKind -> [TypecheckedPat] -- These are to build a MatchContext from
-> [TypecheckedGRHS] -- Guarded RHSs
-> DsM MatchResult
dsGRHSs ty kind pats grhss `thenDs` \ match_result2 ->
combineGRHSMatchResults match_result1 match_result2
-dsGRHS ty kind pats (OtherwiseGRHS expr locn)
- = putSrcLocDs locn (
+dsGRHS ty kind pats (GRHS guard 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))
- )
+ matchGuard guard (DsMatchContext kind pats locn) (MatchResult CantFail ty expr_fn)
+\end{code}
-dsGRHS ty kind pats (GRHS guard expr locn)
- = putSrcLocDs locn (
- dsExpr guard `thenDs` \ core_guard ->
- dsExpr expr `thenDs` \ core_expr ->
+
+
+
+%************************************************************************
+%* *
+%* matchGuard : make a MatchResult from a guarded RHS *
+%* *
+%************************************************************************
+
+\begin{code}
+matchGuard :: [TypecheckedStmt] -- Guard
+ -> DsMatchContext -- Context
+ -> MatchResult -- What to do if the guard succeeds
+ -> DsM MatchResult
+
+matchGuard [] ctx body_result = returnDs body_result
+
+ -- Turn an "otherwise" guard is a no-op
+matchGuard (GuardStmt (HsVar v) _ : stmts) ctx body_result
+ | uniq == otherwiseIdKey
+ || uniq == trueDataConKey
+ = matchGuard stmts ctx body_result
+ where
+ uniq = uniqueOf v
+
+matchGuard (GuardStmt expr _ : stmts) ctx body_result
+ = matchGuard stmts ctx body_result `thenDs` \ (MatchResult _ ty body_fn) ->
+ dsExpr expr `thenDs` \ core_expr ->
let
- expr_fn = \ fail -> mkCoreIfThenElse core_guard core_expr fail
+ expr_fn = \ fail -> mkCoreIfThenElse core_expr (body_fn fail) fail
in
- returnDs (MatchResult CanFail ty expr_fn (DsMatchContext kind pats locn))
- )
+ returnDs (MatchResult CanFail ty expr_fn)
+
+matchGuard (LetStmt binds : stmts) ctx body_result
+ = matchGuard stmts ctx 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) ctx body_result
+ = matchGuard stmts ctx body_result `thenDs` \ match_result ->
+ dsExpr rhs `thenDs` \ core_rhs ->
+ newSysLocalDs (coreExprType core_rhs) `thenDs` \ scrut_var ->
+ matchExport [scrut_var] [EqnInfo 1 ctx [pat] match_result] `thenDs` \ match_result' ->
+ returnDs (mkCoLetsMatchResult [NonRec scrut_var core_rhs] match_result')
\end{code}
-
-
projects / ghc-hetmet.git / blobdiff