2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[DsGRHSs]{Matching guarded right-hand-sides (GRHSs)}
7 module DsGRHSs ( dsGuarded, dsGRHSs ) where
9 #include "HsVersions.h"
11 import {-# SOURCE #-} DsExpr ( dsExpr, dsLet )
12 import {-# SOURCE #-} Match ( matchSinglePat )
14 import HsSyn ( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..), HsMatchContext(..) )
15 import TcHsSyn ( TypecheckedGRHSs, TypecheckedPat, TypecheckedStmt )
16 import CoreSyn ( CoreExpr )
21 import PrelInfo ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
22 import PrelNames ( otherwiseIdKey, trueDataConKey, hasKey )
25 @dsGuarded@ is used for both @case@ expressions and pattern bindings.
33 producing an expression with a runtime error in the corner if
34 necessary. The type argument gives the type of the @ei@.
37 dsGuarded :: TypecheckedGRHSs -> DsM CoreExpr
40 = dsGRHSs PatBindRhs [] grhss `thenDs` \ (err_ty, match_result) ->
41 mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID err_ty "" `thenDs` \ error_expr ->
42 extractMatchResult match_result error_expr
45 In contrast, @dsGRHSs@ produces a @MatchResult@.
48 dsGRHSs :: HsMatchContext -> [TypecheckedPat] -- These are to build a MatchContext from
49 -> TypecheckedGRHSs -- Guarded RHSs
50 -> DsM (Type, MatchResult)
52 dsGRHSs kind pats (GRHSs grhss binds (Just ty))
53 = mapDs (dsGRHS kind pats) grhss `thenDs` \ match_results ->
55 match_result1 = foldr1 combineMatchResults match_results
56 match_result2 = adjustMatchResultDs (dsLet binds) match_result1
57 -- NB: nested dsLet inside matchResult
59 returnDs (ty, match_result2)
61 dsGRHS kind pats (GRHS guard locn)
62 = matchGuard guard (DsMatchContext kind pats locn)
66 %************************************************************************
68 %* matchGuard : make a MatchResult from a guarded RHS *
70 %************************************************************************
73 matchGuard :: [TypecheckedStmt] -- Guard
74 -> DsMatchContext -- Context
77 -- See comments with HsExpr.HsStmt re what an ExprStmt means
78 -- Here we must be in a guard context (not do-expression, nor list-comp)
80 matchGuard [ResultStmt expr locn] ctx
81 = putSrcLocDs locn (dsExpr expr) `thenDs` \ core_expr ->
82 returnDs (cantFailMatchResult core_expr)
84 -- ExprStmts must be guards
85 -- Turn an "otherwise" guard is a no-op
86 matchGuard (ExprStmt (HsVar v) _ : stmts) ctx
87 | v `hasKey` otherwiseIdKey
88 || v `hasKey` trueDataConKey
89 = matchGuard stmts ctx
91 matchGuard (ExprStmt expr locn : stmts) ctx
92 = matchGuard stmts ctx `thenDs` \ match_result ->
93 putSrcLocDs locn (dsExpr expr) `thenDs` \ pred_expr ->
94 returnDs (mkGuardedMatchResult pred_expr match_result)
96 matchGuard (LetStmt binds : stmts) ctx
97 = matchGuard stmts ctx `thenDs` \ match_result ->
98 returnDs (adjustMatchResultDs (dsLet binds) match_result)
99 -- NB the dsLet occurs inside the match_result
101 matchGuard (BindStmt pat rhs locn : stmts) ctx
102 = matchGuard stmts ctx `thenDs` \ match_result ->
103 putSrcLocDs locn (dsExpr rhs) `thenDs` \ core_rhs ->
104 matchSinglePat core_rhs ctx pat match_result
107 Should {\em fail} if @e@ returns @D@
109 f x | p <- e', let C y# = e, f y# = r1