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(..) )
15 import TcHsSyn ( TypecheckedGRHSs, TypecheckedPat, TypecheckedStmt )
16 import CoreSyn ( CoreExpr, Bind(..) )
21 import PrelInfo ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
22 import Unique ( otherwiseIdKey, trueDataConKey, Uniquable(..) )
26 @dsGuarded@ is used for both @case@ expressions and pattern bindings.
34 producing an expression with a runtime error in the corner if
35 necessary. The type argument gives the type of the @ei@.
38 dsGuarded :: TypecheckedGRHSs -> DsM CoreExpr
41 = dsGRHSs PatBindMatch [] grhss `thenDs` \ (err_ty, match_result) ->
42 mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID err_ty "" `thenDs` \ error_expr ->
43 extractMatchResult match_result error_expr
46 In contrast, @dsGRHSs@ produces a @MatchResult@.
49 dsGRHSs :: DsMatchKind -> [TypecheckedPat] -- These are to build a MatchContext from
50 -> TypecheckedGRHSs -- Guarded RHSs
51 -> DsM (Type, MatchResult)
53 dsGRHSs kind pats (GRHSs grhss binds (Just ty))
54 = mapDs (dsGRHS kind pats) grhss `thenDs` \ match_results ->
56 match_result1 = foldr1 combineMatchResults match_results
57 match_result2 = adjustMatchResultDs (dsLet binds) match_result1
58 -- NB: nested dsLet inside matchResult
60 returnDs (ty, match_result2)
62 dsGRHS kind pats (GRHS guard locn)
63 = matchGuard guard (DsMatchContext kind pats locn)
67 %************************************************************************
69 %* matchGuard : make a MatchResult from a guarded RHS *
71 %************************************************************************
74 matchGuard :: [TypecheckedStmt] -- Guard
75 -> DsMatchContext -- Context
78 matchGuard (ExprStmt expr locn : should_be_null) ctx
79 = putSrcLocDs locn (dsExpr expr) `thenDs` \ core_expr ->
80 returnDs (cantFailMatchResult core_expr)
82 -- Turn an "otherwise" guard is a no-op
83 matchGuard (GuardStmt (HsVar v) _ : stmts) ctx
84 | uniq == otherwiseIdKey
85 || uniq == trueDataConKey
86 = matchGuard stmts ctx
90 matchGuard (GuardStmt expr locn : stmts) ctx
91 = matchGuard stmts ctx `thenDs` \ match_result ->
92 putSrcLocDs locn (dsExpr expr) `thenDs` \ pred_expr ->
93 returnDs (mkGuardedMatchResult pred_expr match_result)
95 matchGuard (LetStmt binds : stmts) ctx
96 = matchGuard stmts ctx `thenDs` \ match_result ->
97 returnDs (adjustMatchResultDs (dsLet binds) match_result)
98 -- NB the dsLet occurs inside the match_result
100 matchGuard (BindStmt pat rhs locn : stmts) ctx
101 = matchGuard stmts ctx `thenDs` \ match_result ->
102 putSrcLocDs locn (dsExpr rhs) `thenDs` \ core_rhs ->
103 matchSinglePat core_rhs ctx pat match_result
106 Should {\em fail} if @e@ returns @D@
108 f x | p <- e', let C y# = e, f y# = r1