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 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
13 IMPORT_DELOOPER(DsLoop) -- break dsExpr/dsBinds-ish loop
15 import {-# SOURCE #-} DsExpr ( dsExpr )
16 import {-# SOURCE #-} DsBinds ( dsBinds )
17 import {-# SOURCE #-} Match ( matchExport )
20 import HsSyn ( GRHSsAndBinds(..), GRHS(..),
21 HsExpr(..), HsBinds, Stmt(..),
22 HsLit, Match, Fixity, DoOrListComp, HsType, ArithSeqInfo
24 import TcHsSyn ( SYN_IE(TypecheckedGRHSsAndBinds), SYN_IE(TypecheckedGRHS),
25 SYN_IE(TypecheckedPat), SYN_IE(TypecheckedHsBinds),
26 SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedStmt)
28 import CoreSyn ( SYN_IE(CoreBinding), GenCoreBinding(..), SYN_IE(CoreExpr), mkCoLetsAny )
33 #if __GLASGOW_HASKELL__ < 200
36 import CoreUtils ( coreExprType, mkCoreIfThenElse )
37 import PrelVals ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
38 import Outputable ( PprStyle(..) )
39 import SrcLoc ( SrcLoc{-instance-} )
40 import Type ( SYN_IE(Type) )
41 import Unique ( Unique, otherwiseIdKey, trueDataConKey, Uniquable(..) )
45 @dsGuarded@ is used for both @case@ expressions and pattern bindings.
53 producing an expression with a runtime error in the corner if
54 necessary. The type argument gives the type of the ei.
57 dsGuarded :: TypecheckedGRHSsAndBinds
60 dsGuarded (GRHSsAndBindsOut grhss binds err_ty)
61 = dsBinds False{-don't auto scc-} binds `thenDs` \ core_binds ->
62 dsGRHSs err_ty PatBindMatch [] grhss `thenDs` \ (MatchResult can_it_fail _ core_grhss_fn) ->
64 CantFail -> returnDs (mkCoLetsAny core_binds (core_grhss_fn (panic "It can't fail")))
65 CanFail -> mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID err_ty "" `thenDs` \ error_expr ->
66 returnDs (mkCoLetsAny core_binds (core_grhss_fn error_expr))
69 Desugar a list of (grhs, expr) pairs [grhs = guarded
70 right-hand-side], as in:
77 We supply a @CoreExpr@ for the case in which all of
81 dsGRHSs :: Type -- Type of RHSs
82 -> DsMatchKind -> [TypecheckedPat] -- These are to build a MatchContext from
83 -> [TypecheckedGRHS] -- Guarded RHSs
86 dsGRHSs ty kind pats [grhs] = dsGRHS ty kind pats grhs
88 dsGRHSs ty kind pats (grhs:grhss)
89 = dsGRHS ty kind pats grhs `thenDs` \ match_result1 ->
90 dsGRHSs ty kind pats grhss `thenDs` \ match_result2 ->
91 combineGRHSMatchResults match_result1 match_result2
93 dsGRHS ty kind pats (OtherwiseGRHS expr locn)
95 dsExpr expr `thenDs` \ core_expr ->
97 expr_fn = \ ignore -> core_expr
99 returnDs (MatchResult CantFail ty expr_fn ) --(DsMatchContext kind pats locn))
101 dsGRHS ty kind pats (GRHS guard expr locn)
103 dsExpr expr `thenDs` \ core_expr ->
105 expr_fn = \ ignore -> core_expr
107 matchGuard guard (DsMatchContext kind pats locn) (MatchResult CantFail ty expr_fn)
113 %************************************************************************
115 %* matchGuard : make a MatchResult from a guarded RHS *
117 %************************************************************************
120 matchGuard :: [TypecheckedStmt] -- Guard
121 -> DsMatchContext -- Context
122 -> MatchResult -- What to do if the guard succeeds
125 matchGuard [] ctx body_result = returnDs body_result
127 -- Turn an "otherwise" guard is a no-op
128 matchGuard (GuardStmt (HsVar v) _ : stmts) ctx body_result
129 | uniq == otherwiseIdKey
130 || uniq == trueDataConKey
131 = matchGuard stmts ctx body_result
135 matchGuard (GuardStmt expr _ : stmts) ctx body_result
136 = matchGuard stmts ctx body_result `thenDs` \ (MatchResult _ ty body_fn) ->
137 dsExpr expr `thenDs` \ core_expr ->
139 expr_fn = \ fail -> mkCoreIfThenElse core_expr (body_fn fail) fail
141 returnDs (MatchResult CanFail ty expr_fn)
143 matchGuard (LetStmt binds : stmts) ctx body_result
144 = matchGuard stmts ctx body_result `thenDs` \ match_result ->
145 dsBinds False{-don't auto scc-} binds `thenDs` \ core_binds ->
146 returnDs (mkCoLetsMatchResult core_binds match_result)
148 matchGuard (BindStmt pat rhs _ : stmts) ctx body_result
149 = matchGuard stmts ctx body_result `thenDs` \ match_result ->
150 dsExpr rhs `thenDs` \ core_rhs ->
151 newSysLocalDs (coreExprType core_rhs) `thenDs` \ scrut_var ->
152 matchExport [scrut_var] [EqnInfo 1 ctx [pat] match_result] `thenDs` \ match_result' ->
153 returnDs (mkCoLetsMatchResult [NonRec scrut_var core_rhs] match_result')