2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
4 \section[DsGRHSs]{Matching guarded right-hand-sides (GRHSs)}
7 #include "HsVersions.h"
9 module DsGRHSs ( dsGuarded, dsGRHSs ) where
12 IMPORT_DELOOPER(DsLoop) -- break dsExpr/dsBinds-ish loop
14 import HsSyn ( GRHSsAndBinds(..), GRHS(..),
15 HsExpr(..), HsBinds, Stmt(..),
16 HsLit, Match, Fixity, DoOrListComp, HsType, ArithSeqInfo
18 import TcHsSyn ( SYN_IE(TypecheckedGRHSsAndBinds), SYN_IE(TypecheckedGRHS),
19 SYN_IE(TypecheckedPat), SYN_IE(TypecheckedHsBinds),
20 SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedStmt)
22 import CoreSyn ( SYN_IE(CoreBinding), GenCoreBinding(..), SYN_IE(CoreExpr), mkCoLetsAny )
27 #if __GLASGOW_HASKELL__ < 200
30 import CoreUtils ( coreExprType, mkCoreIfThenElse )
31 import PrelVals ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
32 import Outputable ( PprStyle(..) )
33 import SrcLoc ( SrcLoc{-instance-} )
34 import Type ( SYN_IE(Type) )
35 import Unique ( Unique, otherwiseIdKey )
36 import UniqFM ( Uniquable(..) )
40 @dsGuarded@ is used for both @case@ expressions and pattern bindings.
48 producing an expression with a runtime error in the corner if
49 necessary. The type argument gives the type of the ei.
52 dsGuarded :: TypecheckedGRHSsAndBinds
55 dsGuarded (GRHSsAndBindsOut grhss binds err_ty)
56 = dsBinds binds `thenDs` \ core_binds ->
57 dsGRHSs err_ty PatBindMatch [] grhss `thenDs` \ (MatchResult can_it_fail _ core_grhss_fn _) ->
59 CantFail -> returnDs (mkCoLetsAny core_binds (core_grhss_fn (panic "It can't fail")))
60 CanFail -> mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID err_ty "" `thenDs` \ error_expr ->
61 returnDs (mkCoLetsAny core_binds (core_grhss_fn error_expr))
64 Desugar a list of (grhs, expr) pairs [grhs = guarded
65 right-hand-side], as in:
72 We supply a @CoreExpr@ for the case in which all of
76 dsGRHSs :: Type -- Type of RHSs
77 -> DsMatchKind -> [TypecheckedPat] -- These are to build a MatchContext from
78 -> [TypecheckedGRHS] -- Guarded RHSs
81 dsGRHSs ty kind pats [grhs] = dsGRHS ty kind pats grhs
83 dsGRHSs ty kind pats (grhs:grhss)
84 = dsGRHS ty kind pats grhs `thenDs` \ match_result1 ->
85 dsGRHSs ty kind pats grhss `thenDs` \ match_result2 ->
86 combineGRHSMatchResults match_result1 match_result2
88 dsGRHS ty kind pats (OtherwiseGRHS expr locn)
90 dsExpr expr `thenDs` \ core_expr ->
92 expr_fn = \ ignore -> core_expr
94 returnDs (MatchResult CantFail ty expr_fn (DsMatchContext kind pats locn))
96 dsGRHS ty kind pats (GRHS guard expr locn)
98 dsExpr expr `thenDs` \ core_expr ->
100 expr_fn = \ ignore -> core_expr
102 matchGuard guard (MatchResult CantFail ty expr_fn (DsMatchContext kind pats locn))
108 %************************************************************************
110 %* matchGuard : make a MatchResult from a guarded RHS *
112 %************************************************************************
115 matchGuard :: [TypecheckedStmt] -- Guard
116 -> MatchResult -- What to do if the guard succeeds
119 matchGuard [] body_result = returnDs body_result
121 -- Turn an "otherwise" guard is a no-op
122 matchGuard (GuardStmt (HsVar v) _ : stmts) body_result
123 | uniqueOf v == otherwiseIdKey
124 = matchGuard stmts body_result
126 matchGuard (GuardStmt expr _ : stmts) body_result
127 = matchGuard stmts body_result `thenDs` \ (MatchResult _ ty body_fn cxt) ->
128 dsExpr expr `thenDs` \ core_expr ->
130 expr_fn = \ fail -> mkCoreIfThenElse core_expr (body_fn fail) fail
132 returnDs (MatchResult CanFail ty expr_fn cxt)
134 matchGuard (LetStmt binds : stmts) body_result
135 = matchGuard stmts body_result `thenDs` \ match_result ->
136 dsBinds binds `thenDs` \ core_binds ->
137 returnDs (mkCoLetsMatchResult core_binds match_result)
139 matchGuard (BindStmt pat rhs _ : stmts) body_result
140 = matchGuard stmts body_result `thenDs` \ match_result ->
141 dsExpr rhs `thenDs` \ core_rhs ->
142 newSysLocalDs (coreExprType core_rhs) `thenDs` \ scrut_var ->
143 match [scrut_var] [EqnInfo [pat] match_result] [] `thenDs` \ match_result' ->
144 returnDs (mkCoLetsMatchResult [NonRec scrut_var core_rhs] match_result')