2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
4 \section[DsGRHSs]{Matching guarded right-hand-sides (GRHSs)}
7 module DsGRHSs ( dsGuarded, dsGRHSs ) where
9 #include "HsVersions.h"
11 import {-# SOURCE #-} DsExpr ( dsExpr )
12 import {-# SOURCE #-} DsBinds ( dsBinds )
13 import {-# SOURCE #-} Match ( matchExport )
15 import HsSyn ( GRHSsAndBinds(..), GRHS(..),
16 HsExpr(..), HsBinds, Stmt(..),
17 HsLit, Match, Fixity, DoOrListComp, HsType, ArithSeqInfo
19 import TcHsSyn ( TypecheckedGRHSsAndBinds, TypecheckedGRHS,
20 TypecheckedPat, TypecheckedHsBinds,
21 TypecheckedHsExpr, TypecheckedStmt
23 import CoreSyn ( CoreBinding, GenCoreBinding(..), CoreExpr, mkCoLetsAny )
27 import CoreUtils ( coreExprType, mkCoreIfThenElse )
28 import PrelVals ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
29 import SrcLoc ( SrcLoc{-instance-} )
31 import Unique ( Unique, otherwiseIdKey, trueDataConKey, Uniquable(..) )
35 @dsGuarded@ is used for both @case@ expressions and pattern bindings.
43 producing an expression with a runtime error in the corner if
44 necessary. The type argument gives the type of the ei.
47 dsGuarded :: TypecheckedGRHSsAndBinds
50 dsGuarded (GRHSsAndBindsOut grhss binds err_ty)
51 = dsBinds False{-don't auto scc-} binds `thenDs` \ core_binds ->
52 dsGRHSs err_ty PatBindMatch [] grhss `thenDs` \ (MatchResult can_it_fail _ core_grhss_fn) ->
54 CantFail -> returnDs (mkCoLetsAny core_binds (core_grhss_fn (panic "It can't fail")))
55 CanFail -> mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID err_ty "" `thenDs` \ error_expr ->
56 returnDs (mkCoLetsAny core_binds (core_grhss_fn error_expr))
59 Desugar a list of (grhs, expr) pairs [grhs = guarded
60 right-hand-side], as in:
67 We supply a @CoreExpr@ for the case in which all of
71 dsGRHSs :: Type -- Type of RHSs
72 -> DsMatchKind -> [TypecheckedPat] -- These are to build a MatchContext from
73 -> [TypecheckedGRHS] -- Guarded RHSs
76 dsGRHSs ty kind pats [grhs] = dsGRHS ty kind pats grhs
78 dsGRHSs ty kind pats (grhs:grhss)
79 = dsGRHS ty kind pats grhs `thenDs` \ match_result1 ->
80 dsGRHSs ty kind pats grhss `thenDs` \ match_result2 ->
81 combineGRHSMatchResults match_result1 match_result2
83 dsGRHS ty kind pats (GRHS guard expr locn)
85 dsExpr expr `thenDs` \ core_expr ->
87 expr_fn = \ ignore -> core_expr
89 matchGuard guard (DsMatchContext kind pats locn) (MatchResult CantFail ty expr_fn)
95 %************************************************************************
97 %* matchGuard : make a MatchResult from a guarded RHS *
99 %************************************************************************
102 matchGuard :: [TypecheckedStmt] -- Guard
103 -> DsMatchContext -- Context
104 -> MatchResult -- What to do if the guard succeeds
107 matchGuard [] ctx body_result = returnDs body_result
109 -- Turn an "otherwise" guard is a no-op
110 matchGuard (GuardStmt (HsVar v) _ : stmts) ctx body_result
111 | uniq == otherwiseIdKey
112 || uniq == trueDataConKey
113 = matchGuard stmts ctx body_result
117 matchGuard (GuardStmt expr _ : stmts) ctx body_result
118 = matchGuard stmts ctx body_result `thenDs` \ (MatchResult _ ty body_fn) ->
119 dsExpr expr `thenDs` \ core_expr ->
121 expr_fn = \ fail -> mkCoreIfThenElse core_expr (body_fn fail) fail
123 returnDs (MatchResult CanFail ty expr_fn)
125 matchGuard (LetStmt binds : stmts) ctx body_result
126 = matchGuard stmts ctx body_result `thenDs` \ match_result ->
127 dsBinds False{-don't auto scc-} binds `thenDs` \ core_binds ->
128 returnDs (mkCoLetsMatchResult core_binds match_result)
130 matchGuard (BindStmt pat rhs _ : stmts) ctx body_result
131 = matchGuard stmts ctx body_result `thenDs` \ match_result ->
132 dsExpr rhs `thenDs` \ core_rhs ->
133 newSysLocalDs (coreExprType core_rhs) `thenDs` \ scrut_var ->
134 matchExport [scrut_var] [EqnInfo 1 ctx [pat] match_result] `thenDs` \ match_result' ->
135 returnDs (mkCoLetsMatchResult [NonRec scrut_var core_rhs] match_result')