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 dsExprToAtomGivenTy, SYN_IE(DsCoreArg),
17 mkCoAlgCaseMatchResult,
18 mkAppDs, mkConDs, mkPrimDs, mkErrorAppDs,
20 mkCoPrimCaseMatchResult,
32 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
33 IMPORT_DELOOPER(DsLoop) ( match, matchSimply )
35 import {-# SOURCE #-} Match (match, matchSimply )
38 import HsSyn ( HsExpr(..), OutPat(..), HsLit(..), Fixity,
39 Match, HsBinds, Stmt, DoOrListComp, HsType, ArithSeqInfo )
40 import TcHsSyn ( SYN_IE(TypecheckedPat) )
41 import DsHsSyn ( outPatType, collectTypedPatBinders )
42 import CmdLineOpts ( opt_PprUserLength )
47 import CoreUtils ( coreExprType, mkCoreIfThenElse )
48 import PrelVals ( iRREFUT_PAT_ERROR_ID, voidId )
49 import Pretty ( Doc, hcat, text )
50 import Id ( idType, dataConArgTys,
52 SYN_IE(DataCon), SYN_IE(DictVar), SYN_IE(Id), GenId )
53 import Literal ( Literal(..) )
54 import PprType ( GenType, GenTyVar )
55 import PrimOp ( PrimOp )
56 import TyCon ( isNewTyCon, tyConDataCons )
57 import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTy,
58 mkTheta, isUnboxedType, applyTyCon, getAppTyCon,
59 GenType {- instances -}, SYN_IE(Type)
61 import TyVar ( GenTyVar {- instances -}, SYN_IE(TyVar) )
62 import TysPrim ( voidTy )
63 import TysWiredIn ( tupleTyCon, unitDataCon, tupleCon )
64 import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, SYN_IE(UniqSet) )
65 import Util ( panic, assertPanic{-, pprTrace ToDo:rm-} )
66 import Unique ( Unique )
67 import Usage ( SYN_IE(UVar) )
68 import SrcLoc ( SrcLoc {- instance Outputable -} )
75 %************************************************************************
77 %* Selecting match variables
79 %************************************************************************
81 We're about to match against some patterns. We want to make some
82 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
83 hand, which should indeed be bound to the pattern as a whole, then use it;
84 otherwise, make one up.
87 selectMatchVars :: [TypecheckedPat] -> DsM [Id]
89 = mapDs var_from_pat_maybe pats
91 var_from_pat_maybe (VarPat var) = returnDs var
92 var_from_pat_maybe (AsPat var pat) = returnDs var
93 var_from_pat_maybe (LazyPat pat) = var_from_pat_maybe pat
94 var_from_pat_maybe other_pat
95 = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
99 %************************************************************************
101 %* type synonym EquationInfo and access functions for its pieces *
103 %************************************************************************
104 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
106 The ``equation info'' used by @match@ is relatively complicated and
107 worthy of a type synonym and a few handy functions.
112 [TypecheckedPat] -- the patterns for an eqn
113 MatchResult -- Encapsulates the guards and bindings
120 Type -- Type of argument expression
122 (CoreExpr -> CoreExpr)
123 -- Takes a expression to plug in at the
124 -- failure point(s). The expression should
127 DsMatchContext -- The context info is used when producing warnings
128 -- about shadowed patterns. It's the context
129 -- of the *first* thing matched in this group.
130 -- Should perhaps be a list of them all!
132 data CanItFail = CanFail | CantFail
134 orFail CantFail CantFail = CantFail
138 mkCoLetsMatchResult :: [CoreBinding] -> MatchResult -> MatchResult
139 mkCoLetsMatchResult binds (MatchResult can_it_fail ty body_fn cxt)
140 = MatchResult can_it_fail ty (\body -> mkCoLetsAny binds (body_fn body)) cxt
142 mkGuardedMatchResult :: CoreExpr -> MatchResult -> DsM MatchResult
143 mkGuardedMatchResult pred_expr (MatchResult can_it_fail ty body_fn cxt)
144 = returnDs (MatchResult CanFail
146 (\fail -> mkCoreIfThenElse pred_expr (body_fn fail) fail)
150 mkCoPrimCaseMatchResult :: Id -- Scrutinee
151 -> [(Literal, MatchResult)] -- Alternatives
153 mkCoPrimCaseMatchResult var alts
154 = newSysLocalDs (idType var) `thenDs` \ wild ->
155 returnDs (MatchResult CanFail
160 ((_,MatchResult _ ty1 _ cxt1) : _) = alts
162 mk_case alts wild fail_expr
163 = Case (Var var) (PrimAlts final_alts (BindDefault wild fail_expr))
165 final_alts = [ (lit, body_fn fail_expr)
166 | (lit, MatchResult _ _ body_fn _) <- alts
170 mkCoAlgCaseMatchResult :: Id -- Scrutinee
171 -> [(DataCon, [Id], MatchResult)] -- Alternatives
174 mkCoAlgCaseMatchResult var alts
175 | isNewTyCon tycon -- newtype case; use a let
176 = ASSERT( newtype_sanity )
177 returnDs (mkCoLetsMatchResult [coercion_bind] match_result)
179 | otherwise -- datatype case
180 = -- Find all the constructors in the type which aren't
181 -- explicitly mentioned in the alternatives:
182 case un_mentioned_constructors of
183 [] -> -- All constructors mentioned, so no default needed
184 returnDs (MatchResult can_any_alt_fail
186 (mk_case alts (\ignore -> NoDefault))
189 [con] -> -- Just one constructor missing, so add a case for it
190 -- We need to build new locals for the args of the constructor,
191 -- and figuring out their types is somewhat tiresome.
193 arg_tys = dataConArgTys con tycon_arg_tys
195 newSysLocalsDs arg_tys `thenDs` \ arg_ids ->
197 -- Now we are ready to construct the new alternative
199 new_alt = (con, arg_ids, MatchResult CanFail ty1 id NoMatchContext)
201 returnDs (MatchResult CanFail
203 (mk_case (new_alt:alts) (\ignore -> NoDefault))
206 other -> -- Many constructors missing, so use a default case
207 newSysLocalDs scrut_ty `thenDs` \ wild ->
208 returnDs (MatchResult CanFail
210 (mk_case alts (\fail_expr -> BindDefault wild fail_expr))
214 scrut_ty = idType var
215 (tycon, tycon_arg_tys) = --pprTrace "CoAlgCase:" (pprType PprDebug scrut_ty) $
219 (con_id, arg_ids, match_result) = head alts
220 arg_id = head arg_ids
221 coercion_bind = NonRec arg_id (Coerce (CoerceOut con_id)
224 newtype_sanity = null (tail alts) && null (tail arg_ids)
226 -- Stuff for data types
227 data_cons = tyConDataCons tycon
229 un_mentioned_constructors
230 = uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- alts] )
232 match_results = [match_result | (_,_,match_result) <- alts]
233 (MatchResult _ ty1 _ cxt1 : _) = match_results
234 can_any_alt_fail = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ _ _ <- match_results]
236 mk_case alts deflt_fn fail_expr
237 = Case (Var var) (AlgAlts final_alts (deflt_fn fail_expr))
239 final_alts = [ (con, args, body_fn fail_expr)
240 | (con, args, MatchResult _ _ body_fn _) <- alts
244 combineMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
245 combineMatchResults (MatchResult CanFail ty1 body_fn1 cxt1)
246 (MatchResult can_it_fail2 ty2 body_fn2 cxt2)
247 = mkFailurePair ty1 `thenDs` \ (bind_fn, duplicatable_expr) ->
249 new_body_fn1 = \body1 -> Let (bind_fn body1) (body_fn1 duplicatable_expr)
250 new_body_fn2 = \body2 -> new_body_fn1 (body_fn2 body2)
252 returnDs (MatchResult can_it_fail2 ty1 new_body_fn2 cxt1)
254 combineMatchResults match_result1@(MatchResult CantFail ty body_fn1 cxt1)
256 = returnDs match_result1
259 -- The difference in combineGRHSMatchResults is that there is no
260 -- need to let-bind to avoid code duplication
261 combineGRHSMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
262 combineGRHSMatchResults (MatchResult CanFail ty1 body_fn1 cxt1)
263 (MatchResult can_it_fail ty2 body_fn2 cxt2)
264 = returnDs (MatchResult can_it_fail ty1 (\ body -> body_fn1 (body_fn2 body)) cxt1)
266 combineGRHSMatchResults match_result1 match_result2
267 = -- Delegate to avoid duplication of code
268 combineMatchResults match_result1 match_result2
271 %************************************************************************
273 \subsection[dsExprToAtom]{Take an expression and produce an atom}
275 %************************************************************************
278 dsArgToAtom :: DsCoreArg -- The argument expression
279 -> (CoreArg -> DsM CoreExpr) -- Something taking the argument *atom*,
280 -- and delivering an expression E
281 -> DsM CoreExpr -- Either E or let x=arg-expr in E
283 dsArgToAtom (UsageArg u) continue_with = continue_with (UsageArg u)
284 dsArgToAtom (TyArg t) continue_with = continue_with (TyArg t)
285 dsArgToAtom (LitArg l) continue_with = continue_with (LitArg l)
286 dsArgToAtom (VarArg arg) continue_with = dsExprToAtomGivenTy arg (coreExprType arg) continue_with
289 :: CoreExpr -- The argument expression
290 -> Type -- Type of the argument
291 -> (CoreArg -> DsM CoreExpr) -- Something taking the argument *atom*,
292 -- and delivering an expression E
293 -> DsM CoreExpr -- Either E or let x=arg-expr in E
295 dsExprToAtomGivenTy (Var v) arg_ty continue_with = continue_with (VarArg v)
296 dsExprToAtomGivenTy (Lit v) arg_ty continue_with = continue_with (LitArg v)
297 dsExprToAtomGivenTy arg_expr arg_ty continue_with
298 = newSysLocalDs arg_ty `thenDs` \ arg_id ->
299 continue_with (VarArg arg_id) `thenDs` \ body ->
301 if isUnboxedType arg_ty
302 then Case arg_expr (PrimAlts [] (BindDefault arg_id body))
303 else Let (NonRec arg_id arg_expr) body
306 dsArgsToAtoms :: [DsCoreArg]
307 -> ([CoreArg] -> DsM CoreExpr)
310 dsArgsToAtoms [] continue_with = continue_with []
312 dsArgsToAtoms (arg:args) continue_with
313 = dsArgToAtom arg $ \ arg_atom ->
314 dsArgsToAtoms args $ \ arg_atoms ->
315 continue_with (arg_atom:arg_atoms)
318 %************************************************************************
320 \subsection{Desugarer's versions of some Core functions}
322 %************************************************************************
325 type DsCoreArg = GenCoreArg CoreExpr{-NB!-} TyVar UVar
327 mkAppDs :: CoreExpr -> [DsCoreArg] -> DsM CoreExpr
328 mkConDs :: Id -> [DsCoreArg] -> DsM CoreExpr
329 mkPrimDs :: PrimOp -> [DsCoreArg] -> DsM CoreExpr
332 = dsArgsToAtoms args $ \ atoms ->
333 returnDs (mkGenApp fun atoms)
336 = dsArgsToAtoms args $ \ atoms ->
337 returnDs (Con con atoms)
340 = dsArgsToAtoms args $ \ atoms ->
341 returnDs (Prim op atoms)
345 showForErr :: Outputable a => a -> String -- Boring but useful
346 showForErr thing = show (ppr PprQuote thing)
348 mkErrorAppDs :: Id -- The error function
349 -> Type -- Type to which it should be applied
350 -> String -- The error message string to pass
353 mkErrorAppDs err_id ty msg
354 = getSrcLocDs `thenDs` \ src_loc ->
356 full_msg = show (hcat [ppr (PprForUser opt_PprUserLength) src_loc, text "|", text msg])
357 msg_lit = NoRepStr (_PK_ full_msg)
359 returnDs (mkApp (Var err_id) [] [ty] [LitArg msg_lit])
362 %************************************************************************
364 \subsection[mkSelectorBind]{Make a selector bind}
366 %************************************************************************
368 This is used in various places to do with lazy patterns.
369 For each binder $b$ in the pattern, we create a binding:
371 b = case v of pat' -> b'
373 where pat' is pat with each binder b cloned into b'.
375 ToDo: making these bindings should really depend on whether there's
376 much work to be done per binding. If the pattern is complex, it
377 should be de-mangled once, into a tuple (and then selected from).
378 Otherwise the demangling can be in-line in the bindings (as here).
380 Boring! Boring! One error message per binder. The above ToDo is
381 even more helpful. Something very similar happens for pattern-bound
385 mkSelectorBinds :: TypecheckedPat -- The pattern
386 -> CoreExpr -- Expression to which the pattern is bound
387 -> DsM [(Id,CoreExpr)]
389 mkSelectorBinds (VarPat v) val_expr
390 = returnDs [(v, val_expr)]
392 mkSelectorBinds pat val_expr
393 | is_simple_tuple_pat pat
394 = mkTupleBind binders val_expr
397 = mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty pat_string `thenDs` \ error_msg ->
398 matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr ->
399 mkTupleBind binders tuple_expr
402 binders = collectTypedPatBinders pat
403 local_tuple = mkTupleExpr binders
404 res_ty = coreExprType local_tuple
406 is_simple_tuple_pat (TuplePat ps) = all is_var_pat ps
407 is_simple_tuple_pat other = False
409 is_var_pat (VarPat v) = True
410 is_var_pat other = False -- Even wild-card patterns aren't acceptable
412 pat_string = show (ppr (PprForUser opt_PprUserLength) pat)
417 mkTupleBind :: [Id] -- Names of tuple components
418 -> CoreExpr -- Expr whose value is a tuple of correct type
419 -> DsM [(Id, CoreExpr)] -- Bindings for the globals
422 mkTupleBind [local] tuple_expr
423 = returnDs [(local, tuple_expr)]
425 mkTupleBind locals tuple_expr
426 = newSysLocalDs (coreExprType tuple_expr) `thenDs` \ tuple_var ->
428 mk_bind local = (local, mkTupleSelector locals local (Var tuple_var))
430 returnDs ( (tuple_var, tuple_expr) :
435 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
436 has only one element, it is the identity function.
438 mkTupleExpr :: [Id] -> CoreExpr
440 mkTupleExpr [] = Con unitDataCon []
441 mkTupleExpr [id] = Var id
442 mkTupleExpr ids = mkCon (tupleCon (length ids))
445 [ VarArg i | i <- ids ]
449 @mkTupleSelector@ builds a selector which scrutises the given
450 expression and extracts the one name from the list given.
451 If you want the no-shadowing rule to apply, the caller
452 is responsible for making sure that none of these names
455 If there is just one id in the ``tuple'', then the selector is
459 mkTupleSelector :: [Id] -- The tuple args
460 -> Id -- The selected one
461 -> CoreExpr -- Scrutinee
464 mkTupleSelector [] the_var scrut = panic "mkTupleSelector"
466 mkTupleSelector [var] should_be_the_same_var scrut
467 = ASSERT(var == should_be_the_same_var)
470 mkTupleSelector vars the_var scrut
471 = Case scrut (AlgAlts [(tupleCon arity, vars, Var the_var)]
478 %************************************************************************
480 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
482 %************************************************************************
484 Generally, we handle pattern matching failure like this: let-bind a
485 fail-variable, and use that variable if the thing fails:
487 let fail.33 = error "Help"
498 If the case can't fail, then there'll be no mention of fail.33, and the
499 simplifier will later discard it.
502 If it can fail in only one way, then the simplifier will inline it.
505 Only if it is used more than once will the let-binding remain.
508 There's a problem when the result of the case expression is of
509 unboxed type. Then the type of fail.33 is unboxed too, and
510 there is every chance that someone will change the let into a case:
516 which is of course utterly wrong. Rather than drop the condition that
517 only boxed types can be let-bound, we just turn the fail into a function
518 for the primitive case:
520 let fail.33 :: Void -> Int#
521 fail.33 = \_ -> error "Help"
530 Now fail.33 is a function, so it can be let-bound.
533 mkFailurePair :: Type -- Result type of the whole case expression
534 -> DsM (CoreExpr -> CoreBinding,
535 -- Binds the newly-created fail variable
536 -- to either the expression or \ _ -> expression
537 CoreExpr) -- Either the fail variable, or fail variable
538 -- applied to unit tuple
541 = newFailLocalDs (voidTy `mkFunTy` ty) `thenDs` \ fail_fun_var ->
542 newSysLocalDs voidTy `thenDs` \ fail_fun_arg ->
544 NonRec fail_fun_var (Lam (ValBinder fail_fun_arg) body),
545 App (Var fail_fun_var) (VarArg voidId))
548 = newFailLocalDs ty `thenDs` \ fail_var ->
549 returnDs (\ body -> NonRec fail_var body, Var fail_var)