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 AbsSyn -- the stuff being desugared
13 import PlainCore -- the output of desugaring;
14 -- importing this module also gets all the
15 -- CoreSyn utility functions
16 import DsMonad -- the monadery used in the desugarer
18 import AbsPrel ( stringTy
19 IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy)
21 import DsBinds ( dsBinds )
22 import DsExpr ( dsExpr )
28 @dsGuarded@ is used for both @case@ expressions and pattern bindings.
36 producing an expression with a runtime error in the corner if
37 necessary. The type argument gives the type of the ei.
40 dsGuarded :: TypecheckedGRHSsAndBinds
44 dsGuarded (GRHSsAndBindsOut grhss binds err_ty) err_loc
45 = dsBinds binds `thenDs` \ core_binds ->
46 dsGRHSs err_ty PatBindMatch [] grhss `thenDs` \ (MatchResult can_it_fail _ core_grhss_fn _) ->
48 CantFail -> returnDs (mkCoLetsAny core_binds (core_grhss_fn (panic "It can't fail")))
49 CanFail -> newSysLocalDs stringTy `thenDs` \ str_var -> -- to hold the String
50 returnDs (mkCoLetsAny core_binds (core_grhss_fn (error_expr str_var)))
52 unencoded_part_of_msg = escErrorMsg (ppShow 80 (ppr PprForUser err_loc))
54 error_expr :: Id -> PlainCoreExpr
55 error_expr str_var = mkErrorCoApp err_ty str_var
56 (unencoded_part_of_msg
57 ++ "%N") --> ": non-exhaustive guards"
60 Desugar a list of (grhs, expr) pairs [grhs = guarded
61 right-hand-side], as in:
68 We supply a @PlainCoreExpr@ for the case in which all of
72 dsGRHSs :: UniType -- Type of RHSs
73 -> DsMatchKind -> [TypecheckedPat] -- These are to build a MatchContext from
74 -> [TypecheckedGRHS] -- Guarded RHSs
77 dsGRHSs ty kind pats [grhs] = dsGRHS ty kind pats grhs
79 dsGRHSs ty kind pats (grhs:grhss)
80 = dsGRHS ty kind pats grhs `thenDs` \ match_result1 ->
81 dsGRHSs ty kind pats grhss `thenDs` \ match_result2 ->
82 combineGRHSMatchResults match_result1 match_result2
84 dsGRHS ty kind pats (OtherwiseGRHS expr locn)
86 dsExpr expr `thenDs` \ core_expr ->
88 expr_fn = \ ignore -> core_expr
90 returnDs (MatchResult CantFail ty expr_fn (DsMatchContext kind pats locn))
93 dsGRHS ty kind pats (GRHS guard expr locn)
95 dsExpr guard `thenDs` \ core_guard ->
96 dsExpr expr `thenDs` \ core_expr ->
98 expr_fn = \ fail -> mkCoreIfThenElse core_guard core_expr fail
100 returnDs (MatchResult CanFail ty expr_fn (DsMatchContext kind pats locn))