2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[DsUtils]{Utilities for desugaring}
6 This module exports some utility functions of no great interest.
9 #include "HsVersions.h"
12 CanItFail(..), EquationInfo(..), MatchResult(..),
14 combineGRHSMatchResults,
16 dsExprToAtom, SYN_IE(DsCoreArg),
17 mkCoAlgCaseMatchResult,
18 mkAppDs, mkConDs, mkPrimDs, mkErrorAppDs,
20 mkCoPrimCaseMatchResult,
31 IMPORT_DELOOPER(DsLoop) ( match, matchSimply )
33 import HsSyn ( HsExpr(..), OutPat(..), HsLit(..), Fixity,
34 Match, HsBinds, Stmt, Qualifier, HsType, ArithSeqInfo )
35 import TcHsSyn ( SYN_IE(TypecheckedPat) )
36 import DsHsSyn ( outPatType )
41 import CoreUtils ( coreExprType, mkCoreIfThenElse )
42 import PprStyle ( PprStyle(..) )
43 import PrelVals ( iRREFUT_PAT_ERROR_ID, voidId )
44 import Pretty ( ppShow, ppBesides, ppStr )
45 import Id ( idType, dataConArgTys,
47 SYN_IE(DataCon), SYN_IE(DictVar), SYN_IE(Id), GenId )
48 import Literal ( Literal(..) )
49 import TyCon ( isNewTyCon, tyConDataCons )
50 import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTy,
51 mkTheta, isUnboxedType, applyTyCon, getAppTyCon
53 import TysPrim ( voidTy )
54 import TysWiredIn ( tupleTyCon, unitDataCon, tupleCon )
55 import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, SYN_IE(UniqSet) )
56 import Util ( panic, assertPanic{-, pprTrace ToDo:rm-} )
57 import Usage ( SYN_IE(UVar) )
58 import SrcLoc ( SrcLoc {- instance Outputable -} )
59 --import PprCore{-ToDo:rm-}
60 --import PprType--ToDo:rm
61 --import Pretty--ToDo:rm
62 --import TyVar--ToDo:rm
63 --import Unique--ToDo:rm
66 %************************************************************************
68 %* type synonym EquationInfo and access functions for its pieces *
70 %************************************************************************
71 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
73 The ``equation info'' used by @match@ is relatively complicated and
74 worthy of a type synonym and a few handy functions.
79 [TypecheckedPat] -- the patterns for an eqn
80 MatchResult -- Encapsulates the guards and bindings
87 Type -- Type of argument expression
89 (CoreExpr -> CoreExpr)
90 -- Takes a expression to plug in at the
91 -- failure point(s). The expression should
94 DsMatchContext -- The context info is used when producing warnings
95 -- about shadowed patterns. It's the context
96 -- of the *first* thing matched in this group.
97 -- Should perhaps be a list of them all!
99 data CanItFail = CanFail | CantFail
101 orFail CantFail CantFail = CantFail
105 mkCoLetsMatchResult :: [CoreBinding] -> MatchResult -> MatchResult
106 mkCoLetsMatchResult binds (MatchResult can_it_fail ty body_fn cxt)
107 = MatchResult can_it_fail ty (\body -> mkCoLetsAny binds (body_fn body)) cxt
109 mkGuardedMatchResult :: CoreExpr -> MatchResult -> DsM MatchResult
110 mkGuardedMatchResult pred_expr (MatchResult can_it_fail ty body_fn cxt)
111 = returnDs (MatchResult CanFail
113 (\fail -> mkCoreIfThenElse pred_expr (body_fn fail) fail)
117 mkCoPrimCaseMatchResult :: Id -- Scrutinee
118 -> [(Literal, MatchResult)] -- Alternatives
120 mkCoPrimCaseMatchResult var alts
121 = newSysLocalDs (idType var) `thenDs` \ wild ->
122 returnDs (MatchResult CanFail
127 ((_,MatchResult _ ty1 _ cxt1) : _) = alts
129 mk_case alts wild fail_expr
130 = Case (Var var) (PrimAlts final_alts (BindDefault wild fail_expr))
132 final_alts = [ (lit, body_fn fail_expr)
133 | (lit, MatchResult _ _ body_fn _) <- alts
137 mkCoAlgCaseMatchResult :: Id -- Scrutinee
138 -> [(DataCon, [Id], MatchResult)] -- Alternatives
141 mkCoAlgCaseMatchResult var alts
142 | isNewTyCon tycon -- newtype case; use a let
143 = ASSERT( newtype_sanity )
144 returnDs (mkCoLetsMatchResult [coercion_bind] match_result)
146 | otherwise -- datatype case
147 = -- Find all the constructors in the type which aren't
148 -- explicitly mentioned in the alternatives:
149 case un_mentioned_constructors of
150 [] -> -- All constructors mentioned, so no default needed
151 returnDs (MatchResult can_any_alt_fail
153 (mk_case alts (\ignore -> NoDefault))
156 [con] -> -- Just one constructor missing, so add a case for it
157 -- We need to build new locals for the args of the constructor,
158 -- and figuring out their types is somewhat tiresome.
160 arg_tys = dataConArgTys con tycon_arg_tys
162 newSysLocalsDs arg_tys `thenDs` \ arg_ids ->
164 -- Now we are ready to construct the new alternative
166 new_alt = (con, arg_ids, MatchResult CanFail ty1 id NoMatchContext)
168 returnDs (MatchResult CanFail
170 (mk_case (new_alt:alts) (\ignore -> NoDefault))
173 other -> -- Many constructors missing, so use a default case
174 newSysLocalDs scrut_ty `thenDs` \ wild ->
175 returnDs (MatchResult CanFail
177 (mk_case alts (\fail_expr -> BindDefault wild fail_expr))
181 scrut_ty = idType var
182 (tycon, tycon_arg_tys) = --pprTrace "CoAlgCase:" (pprType PprDebug scrut_ty) $
186 (con_id, arg_ids, match_result) = head alts
187 arg_id = head arg_ids
188 coercion_bind = NonRec arg_id (Coerce (CoerceOut con_id)
191 newtype_sanity = null (tail alts) && null (tail arg_ids)
193 -- Stuff for data types
194 data_cons = tyConDataCons tycon
196 un_mentioned_constructors
197 = uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- alts] )
199 match_results = [match_result | (_,_,match_result) <- alts]
200 (MatchResult _ ty1 _ cxt1 : _) = match_results
201 can_any_alt_fail = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ _ _ <- match_results]
203 mk_case alts deflt_fn fail_expr
204 = Case (Var var) (AlgAlts final_alts (deflt_fn fail_expr))
206 final_alts = [ (con, args, body_fn fail_expr)
207 | (con, args, MatchResult _ _ body_fn _) <- alts
211 combineMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
212 combineMatchResults (MatchResult CanFail ty1 body_fn1 cxt1)
213 (MatchResult can_it_fail2 ty2 body_fn2 cxt2)
214 = mkFailurePair ty1 `thenDs` \ (bind_fn, duplicatable_expr) ->
216 new_body_fn1 = \body1 -> Let (bind_fn body1) (body_fn1 duplicatable_expr)
217 new_body_fn2 = \body2 -> new_body_fn1 (body_fn2 body2)
219 returnDs (MatchResult can_it_fail2 ty1 new_body_fn2 cxt1)
221 combineMatchResults match_result1@(MatchResult CantFail ty body_fn1 cxt1)
223 = returnDs match_result1
226 -- The difference in combineGRHSMatchResults is that there is no
227 -- need to let-bind to avoid code duplication
228 combineGRHSMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
229 combineGRHSMatchResults (MatchResult CanFail ty1 body_fn1 cxt1)
230 (MatchResult can_it_fail ty2 body_fn2 cxt2)
231 = returnDs (MatchResult can_it_fail ty1 (\ body -> body_fn1 (body_fn2 body)) cxt1)
233 combineGRHSMatchResults match_result1 match_result2
234 = -- Delegate to avoid duplication of code
235 combineMatchResults match_result1 match_result2
238 %************************************************************************
240 \subsection[dsExprToAtom]{Take an expression and produce an atom}
242 %************************************************************************
245 dsExprToAtom :: DsCoreArg -- The argument expression
246 -> (CoreArg -> DsM CoreExpr) -- Something taking the argument *atom*,
247 -- and delivering an expression E
248 -> DsM CoreExpr -- Either E or let x=arg-expr in E
250 dsExprToAtom (UsageArg u) continue_with = continue_with (UsageArg u)
251 dsExprToAtom (TyArg t) continue_with = continue_with (TyArg t)
252 dsExprToAtom (LitArg l) continue_with = continue_with (LitArg l)
254 dsExprToAtom (VarArg (Var v)) continue_with = continue_with (VarArg v)
255 dsExprToAtom (VarArg (Lit v)) continue_with = continue_with (LitArg v)
257 dsExprToAtom (VarArg arg_expr) continue_with
259 ty = coreExprType arg_expr
261 newSysLocalDs ty `thenDs` \ arg_id ->
262 continue_with (VarArg arg_id) `thenDs` \ body ->
265 then Case arg_expr (PrimAlts [] (BindDefault arg_id body))
266 else Let (NonRec arg_id arg_expr) body
269 dsExprsToAtoms :: [DsCoreArg]
270 -> ([CoreArg] -> DsM CoreExpr)
273 dsExprsToAtoms [] continue_with = continue_with []
275 dsExprsToAtoms (arg:args) continue_with
276 = dsExprToAtom arg $ \ arg_atom ->
277 dsExprsToAtoms args $ \ arg_atoms ->
278 continue_with (arg_atom:arg_atoms)
281 %************************************************************************
283 \subsection{Desugarer's versions of some Core functions}
285 %************************************************************************
288 type DsCoreArg = GenCoreArg CoreExpr{-NB!-} TyVar UVar
290 mkAppDs :: CoreExpr -> [DsCoreArg] -> DsM CoreExpr
291 mkConDs :: Id -> [DsCoreArg] -> DsM CoreExpr
292 mkPrimDs :: PrimOp -> [DsCoreArg] -> DsM CoreExpr
295 = dsExprsToAtoms args $ \ atoms ->
296 returnDs (mkGenApp fun atoms)
299 = dsExprsToAtoms args $ \ atoms ->
300 returnDs (Con con atoms)
303 = dsExprsToAtoms args $ \ atoms ->
304 returnDs (Prim op atoms)
308 showForErr :: Outputable a => a -> String -- Boring but useful
309 showForErr thing = ppShow 80 (ppr PprForUser thing)
311 mkErrorAppDs :: Id -- The error function
312 -> Type -- Type to which it should be applied
313 -> String -- The error message string to pass
316 mkErrorAppDs err_id ty msg
317 = getSrcLocDs `thenDs` \ src_loc ->
319 full_msg = ppShow 80 (ppBesides [ppr PprForUser src_loc, ppStr ": ", ppStr msg])
320 msg_lit = NoRepStr (_PK_ full_msg)
322 returnDs (mkApp (Var err_id) [] [ty] [LitArg msg_lit])
325 %************************************************************************
327 \subsection[mkSelectorBind]{Make a selector bind}
329 %************************************************************************
331 This is used in various places to do with lazy patterns.
332 For each binder $b$ in the pattern, we create a binding:
334 b = case v of pat' -> b'
336 where pat' is pat with each binder b cloned into b'.
338 ToDo: making these bindings should really depend on whether there's
339 much work to be done per binding. If the pattern is complex, it
340 should be de-mangled once, into a tuple (and then selected from).
341 Otherwise the demangling can be in-line in the bindings (as here).
343 Boring! Boring! One error message per binder. The above ToDo is
344 even more helpful. Something very similar happens for pattern-bound
348 mkSelectorBinds :: [TyVar] -- Variables wrt which the pattern is polymorphic
349 -> TypecheckedPat -- The pattern
350 -> [(Id,Id)] -- Monomorphic and polymorphic binders for
352 -> CoreExpr -- Expression to which the pattern is bound
353 -> DsM [(Id,CoreExpr)]
355 mkSelectorBinds tyvars pat locals_and_globals val_expr
356 = if is_simple_tuple_pat pat then
357 mkTupleBind tyvars [] locals_and_globals val_expr
359 mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty "" `thenDs` \ error_msg ->
360 matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr ->
361 mkTupleBind tyvars [] locals_and_globals tuple_expr
363 locals = [local | (local, _) <- locals_and_globals]
364 local_tuple = mkTupleExpr locals
365 res_ty = coreExprType local_tuple
367 is_simple_tuple_pat (TuplePat ps) = all is_var_pat ps
368 is_simple_tuple_pat other = False
370 is_var_pat (VarPat v) = True
371 is_var_pat other = False -- Even wild-card patterns aren't acceptable
374 We're about to match against some patterns. We want to make some
375 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
376 hand, which should indeed be bound to the pattern as a whole, then use it;
377 otherwise, make one up.
379 selectMatchVars :: [TypecheckedPat] -> DsM [Id]
381 = mapDs var_from_pat_maybe pats
383 var_from_pat_maybe (VarPat var) = returnDs var
384 var_from_pat_maybe (AsPat var pat) = returnDs var
385 var_from_pat_maybe (LazyPat pat) = var_from_pat_maybe pat
386 var_from_pat_maybe other_pat
387 = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
391 mkTupleBind :: [TyVar] -- Abstract wrt these...
392 -> [DictVar] -- ... and these
394 -> [(Id, Id)] -- Local, global pairs, equal in number
395 -- to the size of the tuple. The types
396 -- of the globals is the generalisation of
397 -- the corresp local, wrt the tyvars and dicts
399 -> CoreExpr -- Expr whose value is a tuple; the expression
400 -- may mention the tyvars and dicts
402 -> DsM [(Id, CoreExpr)] -- Bindings for the globals
407 mkTupleBind tyvars dicts [(l1,g1), ..., (ln,gn)] tup_expr
409 If $n=1$, the result is:
411 g1 = /\ tyvars -> \ dicts -> rhs
413 Otherwise, the result is:
415 tup = /\ tyvars -> \ dicts -> tup_expr
416 g1 = /\ tyvars -> \ dicts -> case (tup tyvars dicts) of
422 mkTupleBind tyvars dicts [(local,global)] tuple_expr
423 = returnDs [(global, mkLam tyvars dicts tuple_expr)]
429 mkTupleBind tyvars dicts local_global_prs tuple_expr
430 = --pprTrace "mkTupleBind:\n" (ppAboves [ppCat (map (pprId PprShowAll) locals), ppCat (map (pprId PprShowAll) globals), {-ppr PprDebug local_tuple, pprType PprDebug res_ty,-} ppr PprDebug tuple_expr]) $
432 newSysLocalDs tuple_var_ty `thenDs` \ tuple_var ->
434 zipWithDs (mk_selector (Var tuple_var))
436 [(0::Int) .. (length local_global_prs - 1)]
437 `thenDs` \ tup_selectors ->
439 (tuple_var, mkLam tyvars dicts tuple_expr)
443 locals, globals :: [Id]
444 locals = [local | (local,global) <- local_global_prs]
445 globals = [global | (local,global) <- local_global_prs]
447 no_of_binders = length local_global_prs
448 tyvar_tys = mkTyVarTys tyvars
452 = mkForAllTys tyvars $
454 applyTyCon (tupleTyCon no_of_binders)
457 theta = mkTheta (map idType dicts)
459 mk_selector :: CoreExpr -> (Id, Id) -> Int -> DsM (Id, CoreExpr)
461 mk_selector tuple_var_expr (local, global) which_local
462 = mapDs duplicateLocalDs locals{-the whole bunch-} `thenDs` \ binders ->
464 selected = binders !! which_local
470 (mkValApp (mkTyApp tuple_var_expr tyvar_tys)
477 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
478 has only one element, it is the identity function.
480 mkTupleExpr :: [Id] -> CoreExpr
482 mkTupleExpr [] = Con unitDataCon []
483 mkTupleExpr [id] = Var id
484 mkTupleExpr ids = mkCon (tupleCon (length ids))
487 [ VarArg i | i <- ids ]
491 @mkTupleSelector@ builds a selector which scrutises the given
492 expression and extracts the one name from the list given.
493 If you want the no-shadowing rule to apply, the caller
494 is responsible for making sure that none of these names
497 If there is just one id in the ``tuple'', then the selector is
501 mkTupleSelector :: CoreExpr -- Scrutinee
502 -> [Id] -- The tuple args
503 -> Id -- The selected one
506 mkTupleSelector expr [] the_var = panic "mkTupleSelector"
508 mkTupleSelector expr [var] should_be_the_same_var
509 = ASSERT(var == should_be_the_same_var)
512 mkTupleSelector expr vars the_var
513 = Case expr (AlgAlts [(tupleCon arity, vars, Var the_var)]
520 %************************************************************************
522 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
524 %************************************************************************
526 Generally, we handle pattern matching failure like this: let-bind a
527 fail-variable, and use that variable if the thing fails:
529 let fail.33 = error "Help"
540 If the case can't fail, then there'll be no mention of fail.33, and the
541 simplifier will later discard it.
544 If it can fail in only one way, then the simplifier will inline it.
547 Only if it is used more than once will the let-binding remain.
550 There's a problem when the result of the case expression is of
551 unboxed type. Then the type of fail.33 is unboxed too, and
552 there is every chance that someone will change the let into a case:
558 which is of course utterly wrong. Rather than drop the condition that
559 only boxed types can be let-bound, we just turn the fail into a function
560 for the primitive case:
562 let fail.33 :: Void -> Int#
563 fail.33 = \_ -> error "Help"
572 Now fail.33 is a function, so it can be let-bound.
575 mkFailurePair :: Type -- Result type of the whole case expression
576 -> DsM (CoreExpr -> CoreBinding,
577 -- Binds the newly-created fail variable
578 -- to either the expression or \ _ -> expression
579 CoreExpr) -- Either the fail variable, or fail variable
580 -- applied to unit tuple
583 = newFailLocalDs (voidTy `mkFunTy` ty) `thenDs` \ fail_fun_var ->
584 newSysLocalDs voidTy `thenDs` \ fail_fun_arg ->
586 NonRec fail_fun_var (Lam (ValBinder fail_fun_arg) body),
587 App (Var fail_fun_var) (VarArg voidId))
590 = newFailLocalDs ty `thenDs` \ fail_var ->
591 returnDs (\ body -> NonRec fail_var body, Var fail_var)