2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[DsUtils]{Utilities for desugaring}
6 This module exports some utility functions of no great interest.
10 CanItFail(..), EquationInfo(..), MatchResult(..),
13 cantFailMatchResult, extractMatchResult,
15 adjustMatchResult, adjustMatchResultDs,
16 mkCoLetsMatchResult, mkGuardedMatchResult,
17 mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
21 mkSelectorBinds, mkTupleExpr, mkTupleSelector,
26 #include "HsVersions.h"
28 import {-# SOURCE #-} Match ( matchSimply )
30 import HsSyn ( OutPat(..) )
31 import TcHsSyn ( TypecheckedPat )
32 import DsHsSyn ( outPatType, collectTypedPatBinders )
37 import CoreUtils ( coreExprType )
38 import PrelVals ( iRREFUT_PAT_ERROR_ID )
39 import Id ( idType, Id, mkWildId )
40 import Const ( Literal(..), Con(..) )
41 import TyCon ( isNewTyCon, tyConDataCons )
42 import DataCon ( DataCon )
43 import Type ( mkFunTy, isUnLiftedType, splitAlgTyConApp,
46 import TysWiredIn ( unitDataCon, tupleCon, stringTy, unitTy, unitDataCon )
47 import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet )
52 %************************************************************************
54 %* Selecting match variables
56 %************************************************************************
58 We're about to match against some patterns. We want to make some
59 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
60 hand, which should indeed be bound to the pattern as a whole, then use it;
61 otherwise, make one up.
64 selectMatchVar :: TypecheckedPat -> DsM Id
65 selectMatchVar (VarPat var) = returnDs var
66 selectMatchVar (AsPat var pat) = returnDs var
67 selectMatchVar (LazyPat pat) = selectMatchVar pat
68 selectMatchVar other_pat = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
72 %************************************************************************
74 %* type synonym EquationInfo and access functions for its pieces *
76 %************************************************************************
77 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
79 The ``equation info'' used by @match@ is relatively complicated and
80 worthy of a type synonym and a few handy functions.
85 type EqnSet = UniqSet EqnNo
89 EqnNo -- The number of the equation
91 DsMatchContext -- The context info is used when producing warnings
92 -- about shadowed patterns. It's the context
93 -- of the *first* thing matched in this group.
94 -- Should perhaps be a list of them all!
96 [TypecheckedPat] -- The patterns for an eqn
98 MatchResult -- Encapsulates the guards and bindings
104 CanItFail -- Tells whether the failure expression is used
105 (CoreExpr -> DsM CoreExpr)
106 -- Takes a expression to plug in at the
107 -- failure point(s). The expression should
110 data CanItFail = CanFail | CantFail
112 orFail CantFail CantFail = CantFail
116 Functions on MatchResults
119 cantFailMatchResult :: CoreExpr -> MatchResult
120 cantFailMatchResult expr = MatchResult CantFail (\ ignore -> returnDs expr)
122 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
123 extractMatchResult (MatchResult CantFail match_fn) fail_expr
124 = match_fn (error "It can't fail!")
126 extractMatchResult (MatchResult CanFail match_fn) fail_expr
127 = mkFailurePair fail_expr `thenDs` \ (fail_bind, if_it_fails) ->
128 match_fn if_it_fails `thenDs` \ body ->
129 returnDs (Let fail_bind body)
132 combineMatchResults :: MatchResult -> MatchResult -> MatchResult
133 combineMatchResults (MatchResult CanFail body_fn1)
134 (MatchResult can_it_fail2 body_fn2)
135 = MatchResult can_it_fail2 body_fn
137 body_fn fail = body_fn2 fail `thenDs` \ body2 ->
138 mkFailurePair body2 `thenDs` \ (fail_bind, duplicatable_expr) ->
139 body_fn1 duplicatable_expr `thenDs` \ body1 ->
140 returnDs (Let fail_bind body1)
142 combineMatchResults match_result1@(MatchResult CantFail body_fn1) match_result2
146 adjustMatchResult :: (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
147 adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
148 = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
149 returnDs (encl_fn body))
151 adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
152 adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
153 = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
157 mkCoLetsMatchResult :: [CoreBind] -> MatchResult -> MatchResult
158 mkCoLetsMatchResult binds match_result
159 = adjustMatchResult (mkLets binds) match_result
162 mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
163 mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn)
164 = MatchResult CanFail (\fail -> body_fn fail `thenDs` \ body ->
165 returnDs (mkIfThenElse pred_expr body fail))
167 mkCoPrimCaseMatchResult :: Id -- Scrutinee
168 -> [(Literal, MatchResult)] -- Alternatives
170 mkCoPrimCaseMatchResult var match_alts
171 = MatchResult CanFail mk_case
174 = mapDs (mk_alt fail) match_alts `thenDs` \ alts ->
175 returnDs (Case (Var var) var (alts ++ [(DEFAULT, [], fail)]))
177 mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail `thenDs` \ body ->
178 returnDs (Literal lit, [], body)
181 mkCoAlgCaseMatchResult :: Id -- Scrutinee
182 -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives
185 mkCoAlgCaseMatchResult var match_alts
186 | isNewTyCon tycon -- Newtype case; use a let
187 = ASSERT( newtype_sanity )
188 mkCoLetsMatchResult [coercion_bind] match_result
190 | otherwise -- Datatype case; use a case
191 = MatchResult fail_flag mk_case
194 scrut_ty = idType var
195 (tycon, tycon_arg_tys, _) = splitAlgTyConApp scrut_ty
198 (con_id, arg_ids, match_result) = head match_alts
199 arg_id = head arg_ids
200 coercion_bind = NonRec arg_id (Note (Coerce (idType arg_id) scrut_ty) (Var var))
201 newtype_sanity = null (tail match_alts) && null (tail arg_ids)
203 -- Stuff for data types
204 data_cons = tyConDataCons tycon
206 match_results = [match_result | (_,_,match_result) <- match_alts]
208 fail_flag | exhaustive_case
209 = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
213 wild_var = mkWildId (idType var)
214 mk_case fail = mapDs (mk_alt fail) match_alts `thenDs` \ alts ->
215 returnDs (Case (Var var) wild_var (alts ++ mk_default fail))
217 mk_alt fail (con, args, MatchResult _ body_fn)
218 = body_fn fail `thenDs` \ body ->
219 returnDs (DataCon con, args, body)
221 mk_default fail | exhaustive_case = []
222 | otherwise = [(DEFAULT, [], fail)]
224 un_mentioned_constructors
225 = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
226 exhaustive_case = isEmptyUniqSet un_mentioned_constructors
231 %************************************************************************
233 \subsection{Desugarer's versions of some Core functions}
235 %************************************************************************
238 mkErrorAppDs :: Id -- The error function
239 -> Type -- Type to which it should be applied
240 -> String -- The error message string to pass
243 mkErrorAppDs err_id ty msg
244 = getSrcLocDs `thenDs` \ src_loc ->
246 full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
248 returnDs (mkApps (Var err_id) [Type ty, mkStringLit full_msg])
251 %************************************************************************
253 \subsection[mkSelectorBind]{Make a selector bind}
255 %************************************************************************
257 This is used in various places to do with lazy patterns.
258 For each binder $b$ in the pattern, we create a binding:
260 b = case v of pat' -> b'
262 where pat' is pat with each binder b cloned into b'.
264 ToDo: making these bindings should really depend on whether there's
265 much work to be done per binding. If the pattern is complex, it
266 should be de-mangled once, into a tuple (and then selected from).
267 Otherwise the demangling can be in-line in the bindings (as here).
269 Boring! Boring! One error message per binder. The above ToDo is
270 even more helpful. Something very similar happens for pattern-bound
274 mkSelectorBinds :: TypecheckedPat -- The pattern
275 -> CoreExpr -- Expression to which the pattern is bound
276 -> DsM [(Id,CoreExpr)]
278 mkSelectorBinds (VarPat v) val_expr
279 = returnDs [(v, val_expr)]
281 mkSelectorBinds pat val_expr
282 | length binders == 1 || is_simple_pat pat
283 = newSysLocalDs (coreExprType val_expr) `thenDs` \ val_var ->
285 -- For the error message we don't use mkErrorAppDs to avoid
286 -- duplicating the string literal each time
287 newSysLocalDs stringTy `thenDs` \ msg_var ->
288 getSrcLocDs `thenDs` \ src_loc ->
290 full_msg = showSDoc (hcat [ppr src_loc, text "|", ppr pat])
292 mapDs (mk_bind val_var msg_var) binders `thenDs` \ binds ->
293 returnDs ( (val_var, val_expr) :
294 (msg_var, mkStringLit full_msg) :
299 = mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat)) `thenDs` \ error_expr ->
300 matchSimply val_expr LetMatch pat local_tuple error_expr `thenDs` \ tuple_expr ->
301 newSysLocalDs tuple_ty `thenDs` \ tuple_var ->
303 mk_tup_bind binder = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
305 returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
307 binders = collectTypedPatBinders pat
308 local_tuple = mkTupleExpr binders
309 tuple_ty = coreExprType local_tuple
311 mk_bind scrut_var msg_var bndr_var
312 -- (mk_bind sv bv) generates
313 -- bv = case sv of { pat -> bv; other -> error-msg }
314 -- Remember, pat binds bv
315 = matchSimply (Var scrut_var) LetMatch pat
316 (Var bndr_var) error_expr `thenDs` \ rhs_expr ->
317 returnDs (bndr_var, rhs_expr)
319 binder_ty = idType bndr_var
320 error_expr = mkApps (Var iRREFUT_PAT_ERROR_ID) [Type binder_ty, Var msg_var]
322 is_simple_pat (TuplePat ps True{-boxed-}) = all is_triv_pat ps
323 is_simple_pat (ConPat _ _ _ _ ps) = all is_triv_pat ps
324 is_simple_pat (VarPat _) = True
325 is_simple_pat (RecPat _ _ _ _ ps) = and [is_triv_pat p | (_,p,_) <- ps]
326 is_simple_pat other = False
328 is_triv_pat (VarPat v) = True
329 is_triv_pat (WildPat _) = True
330 is_triv_pat other = False
334 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
335 has only one element, it is the identity function.
338 mkTupleExpr :: [Id] -> CoreExpr
340 mkTupleExpr [] = mkConApp unitDataCon []
341 mkTupleExpr [id] = Var id
342 mkTupleExpr ids = mkConApp (tupleCon (length ids))
343 (map (Type . idType) ids ++ [ Var i | i <- ids ])
347 @mkTupleSelector@ builds a selector which scrutises the given
348 expression and extracts the one name from the list given.
349 If you want the no-shadowing rule to apply, the caller
350 is responsible for making sure that none of these names
353 If there is just one id in the ``tuple'', then the selector is
357 mkTupleSelector :: [Id] -- The tuple args
358 -> Id -- The selected one
359 -> Id -- A variable of the same type as the scrutinee
360 -> CoreExpr -- Scrutinee
363 mkTupleSelector [var] should_be_the_same_var scrut_var scrut
364 = ASSERT(var == should_be_the_same_var)
367 mkTupleSelector vars the_var scrut_var scrut
368 = ASSERT( not (null vars) )
369 Case scrut scrut_var [(DataCon (tupleCon (length vars)), vars, Var the_var)]
373 %************************************************************************
375 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
377 %************************************************************************
379 Generally, we handle pattern matching failure like this: let-bind a
380 fail-variable, and use that variable if the thing fails:
382 let fail.33 = error "Help"
393 If the case can't fail, then there'll be no mention of fail.33, and the
394 simplifier will later discard it.
397 If it can fail in only one way, then the simplifier will inline it.
400 Only if it is used more than once will the let-binding remain.
403 There's a problem when the result of the case expression is of
404 unboxed type. Then the type of fail.33 is unboxed too, and
405 there is every chance that someone will change the let into a case:
411 which is of course utterly wrong. Rather than drop the condition that
412 only boxed types can be let-bound, we just turn the fail into a function
413 for the primitive case:
415 let fail.33 :: Void -> Int#
416 fail.33 = \_ -> error "Help"
425 Now fail.33 is a function, so it can be let-bound.
428 mkFailurePair :: CoreExpr -- Result type of the whole case expression
429 -> DsM (CoreBind, -- Binds the newly-created fail variable
430 -- to either the expression or \ _ -> expression
431 CoreExpr) -- Either the fail variable, or fail variable
432 -- applied to unit tuple
435 = newFailLocalDs (unitTy `mkFunTy` ty) `thenDs` \ fail_fun_var ->
436 newSysLocalDs unitTy `thenDs` \ fail_fun_arg ->
437 returnDs (NonRec fail_fun_var (Lam fail_fun_arg expr),
438 App (Var fail_fun_var) (mkConApp unitDataCon []))
441 = newFailLocalDs ty `thenDs` \ fail_var ->
442 returnDs (NonRec fail_var expr, Var fail_var)
444 ty = coreExprType expr