2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[UniTyFuns]{Utility functions for @UniTypes@}
6 This is one of the modules whose functions know about the internal
7 representation of @UniTypes@ (and @TyCons@ and ... ?).
10 #include "HsVersions.h"
15 applyTy, applyTyCon, applySynTyCon, applyNonSynTyCon,
16 {-mkSigmaTy,-} glueTyArgs, mkSuperDictSelType, --UNUSED: mkDictFunType,
20 --not exported: expandTySyns,
22 getTyVar, getTyVarMaybe, getTyVarTemplateMaybe,
23 splitType, splitForalls, getTauType, splitTyArgs,
24 splitTypeWithDictsAsArgs,
25 --not exported/unused: sourceTypes, targetType,
29 getUniDataTyCon, getUniDataTyCon_maybe,
30 getUniDataSpecTyCon, getUniDataSpecTyCon_maybe,
33 #ifdef USE_SEMANTIQUE_STRANAL
35 #endif {- Semantique strictness analyser -}
36 getMentionedTyConsAndClassesFromUniType,
37 getMentionedTyConsAndClassesFromTyCon,
38 getMentionedTyConsAndClassesFromClass,
41 -- FREE-VARIABLE EXTRACTION
42 extractTyVarsFromTy, extractTyVarsFromTys,
43 extractTyVarTemplatesFromTy,
46 isTyVarTy, isTyVarTemplateTy,
47 maybeUnpackFunTy, isFunType,
48 isPrimType, isUnboxedDataType, -- UNUSED: isDataConType,
51 --UNUSED: hasHigherOrderArg,
52 isDictTy, isGroundTy, isGroundOrTyVarTy,
54 -- UNUSED: isSynTarget,
56 maybePurelyLocalTyCon, maybePurelyLocalClass, maybePurelyLocalType,
57 returnsRealWorld, -- HACK courtesy of SLPJ
60 runtimeUnpodizableType,
61 #endif {- Data Parallel Haskell -}
64 applyTypeEnvToTy, applyTypeEnvToThetaTy,
65 --not exported : applyTypeEnvToTauTy,
67 -- moved to Subst: applySubstToTauTy, applySubstToTy, applySubstToThetaTy,
68 -- genInstantiateTyUS, -- ToDo: ???
70 -- PRETTY PRINTING AND FORCING
71 pprUniType, pprParendUniType, pprMaybeTy,
72 pprTyCon, pprIfaceClass, pprClassOp,
79 -- MATCHING and COMPARISON
80 matchTy, -- UNUSED: matchTys,
83 -- to make this interface self-sufficient....
84 TyVar, TyVarTemplate, TyCon, Class, UniType, UniqueSupply,
85 IdEnv(..), UniqFM, UnfoldingDetails, PrimKind, TyVarEnv(..),
86 TypeEnv(..), Maybe, PprStyle, PrettyRep, Bag
89 IMPORT_Trace -- ToDo:rm (debugging)
91 -- internal modules; allowed to see constructors for type things
97 import AbsPrel ( listTyCon, integerTyCon, charPrimTyCon,
98 intPrimTyCon, wordPrimTyCon, addrPrimTyCon,
99 floatPrimTyCon, doublePrimTyCon,
103 #endif {- Data Parallel Haskell -}
106 import CLabelInfo ( identToC )
107 import CmdLineOpts ( GlobalSwitch(..) )
108 import Id ( Id, getIdInfo,
109 getMentionedTyConsAndClassesFromId,
110 getInstantiatedDataConSig,
111 getDataConSig, mkSameSpecCon,
114 import IdEnv -- ( lookupIdEnv, IdEnv )
115 import IdInfo ( ppIdInfo, boringIdInfo, IdInfo, UnfoldingDetails )
116 import InstEnv ( ClassInstEnv(..), MatchEnv(..) )
117 import ListSetOps ( unionLists )
118 import NameTypes ( FullName )
122 import PrimKind ( PrimKind(..) )
123 import SpecTyFuns ( specialiseConstrTys )
125 import Unique -- used UniqueSupply monadery
129 %************************************************************************
131 \subsection[UniTyFuns-construction]{Putting types together}
133 %************************************************************************
136 applyTy :: SigmaType -> SigmaType -> SigmaType
138 applyTy (UniSyn _ _ fun_ty) arg_ty = applyTy fun_ty arg_ty
139 applyTy fun_ty@(UniForall tyvar ty) arg_ty
140 = instantiateTy [(tyvar,arg_ty)] ty
142 applyTy bad_fun_ty arg_ty
143 = pprPanic "applyTy: not a forall type:" (ppAbove (ppr PprDebug bad_fun_ty) (ppr PprDebug arg_ty))
147 @applyTyCon@ applies a type constructor to a list of tau-types to give
148 a type. @applySynTyCon@ and @applyNonSynTyCon@ are similar, but they
149 ``know'' what sort the type constructor is, so they are a bit lazier.
150 This is important in @TcMonoType.lhs@.
153 applyTyCon, applySynTyCon, applyNonSynTyCon :: TyCon -> [TauType] -> TauType
156 = ASSERT (if (getTyConArity tc == length tys) then True else pprTrace "applyTyCon" (ppCat [ppr PprDebug tc, ppr PprDebug tys]) False)
157 --false:ASSERT (all isTauTy tys) TauType?? 94/06
159 result = apply_tycon tc tys
161 --false:ASSERT (isTauTy result) TauType?? 94/06
164 apply_tycon tc@(SynonymTyCon _ _ _ _ _ _) tys = applySynTyCon tc tys
165 apply_tycon tc@(DataTyCon _ _ _ _ _ _ _) tys = applyNonSynTyCon tc tys
167 apply_tycon tc@(PrimTyCon _ _ _ _) tys = UniData tc tys
169 apply_tycon tc@(TupleTyCon _) tys = UniData tc tys
170 -- The arg types here aren't necessarily tau-types, because we
171 -- may have polymorphic methods in a dictionary.
173 -- Original tycon used in type of SpecTyCon
174 apply_tycon tc_spec@(SpecTyCon tc spec_tys) tys
175 = apply_tycon tc (fill_nothings spec_tys tys)
177 fill_nothings (Just ty:maybes) fills = ty : fill_nothings maybes fills
178 fill_nothings (Nothing:maybes) (ty:fills) = ty : fill_nothings maybes fills
179 fill_nothings [] [] = []
182 apply_tycon tc@(ProcessorTyCon _) tys = UniData tc tys
183 #endif {- Data Parallel Haskell -}
188 applySynTyCon tycon tys
189 = UniSyn tycon ok_tys (instantiateTauTy (tyvars `zip` ok_tys) template)
190 -- Memo the result of substituting for the tyvars in the template
192 SynonymTyCon _ _ _ tyvars template _ = tycon
193 -- NB: Matched lazily
196 ok_tys = map (verifyTauTy "applyTyConLazily[syn]") tys
203 applyNonSynTyCon tycon tys -- We don't expect function tycons;
204 -- but it must be lazy, so we can't check that here!
206 = UniData tycon (map (verifyTauTy "applyTyConLazily[data]") tys)
212 @glueTyArgs [ty1,...,tyn] ty@ returns the type
213 @ty1 -> ... -> tyn -> ty@. This is the exact reverse of @splitTyArgs@.
216 -- ToDo: DEBUG: say what's true about these types
217 glueTyArgs :: [UniType] -> UniType -> UniType
219 glueTyArgs tys ty = foldr UniFun ty tys
223 mkSuperDictSelType :: Class -- The input class
224 -> Class -- The superclass
225 -> UniType -- The type of the selector function
227 mkSuperDictSelType clas@(MkClass _ _ tyvar _ _ _ _ _ _ _) super
228 = UniForall tyvar (UniFun (UniDict clas (UniTyVarTemplate tyvar))
229 (UniDict super (UniTyVarTemplate tyvar)))
232 UNUSED: @mkDictFunType@ creates the type of a dictionary function, given:
233 the polymorphic type variables, the types of the dict args, the class and
234 tautype of the result.
238 mkDictFunType :: [TyVarTemplate] -> ThetaType -> Class -> TauType -> UniType
240 mkDictFunType tyvars theta clas tau_ty
242 = mkForallTy tyvars (foldr f (UniDict clas tau_ty) theta)
244 = mkForallTy tyvars (foldr f (UniDict clas (verifyTauTy "mkDictFunType" tau_ty)) theta)
247 f (clas,tau_ty) sofar = UniFun (UniDict clas tau_ty) sofar
252 specialiseTy :: UniType -- The type of the Id of which the SpecId
253 -- is a specialised version
254 -> [Maybe UniType] -- The types at which it is specialised
255 -> Int -- Number of leading dictionary args to ignore
258 specialiseTy main_ty maybe_tys dicts_to_ignore
259 = --false:ASSERT(isTauTy tau) TauType??
260 mkSigmaTy remaining_tyvars
261 (instantiateThetaTy inst_env remaining_theta)
262 (instantiateTauTy inst_env tau)
264 (tyvars, theta, tau) = splitType main_ty -- A prefix of, but usually all,
265 -- the theta is discarded!
266 remaining_theta = drop dicts_to_ignore theta
267 tyvars_and_maybe_tys = tyvars `zip` maybe_tys
268 remaining_tyvars = [tyvar | (tyvar, Nothing) <- tyvars_and_maybe_tys]
269 inst_env = [(tyvar,ty) | (tyvar, Just ty) <- tyvars_and_maybe_tys]
272 %************************************************************************
274 \subsection[UniTyFuns-destruction]{Taking types apart}
276 %************************************************************************
278 @expandVisibleTySyn@ removes any visible type-synonym from the top level of a
279 @TauType@. Note that the expansion is recursive.
281 @expandTySyns@ removes all type-synonyms from a @TauType@.
284 expandVisibleTySyn, expandTySyns :: TauType -> TauType
286 expandVisibleTySyn (UniSyn con _ tau)
287 | isVisibleSynTyCon con
288 = ASSERT(isTauTy tau)
289 expandVisibleTySyn tau
290 expandVisibleTySyn tau
291 = ASSERT(isTauTy tau)
294 expandTySyns (UniSyn _ _ tau) = expandTySyns tau
295 expandTySyns (UniFun a b) = UniFun (expandTySyns a) (expandTySyns b)
296 expandTySyns (UniData c tys) = UniData c (map expandTySyns tys)
297 expandTySyns tau = -- FALSE:WDP 95/03: ASSERT(isTauTy tau)
301 @getTyVar@ extracts a type variable from a @UniType@ if the latter is
302 just a type variable, failing otherwise. @getTyVarMaybe@ is similar,
303 except that it returns a @Maybe@ type.
306 getTyVar :: String -> UniType -> TyVar
307 getTyVar panic_msg (UniTyVar tyvar) = tyvar
308 getTyVar panic_msg other = panic ("getTyVar: " ++ panic_msg)
310 getTyVarMaybe :: UniType -> Maybe TyVar
311 getTyVarMaybe (UniTyVar tyvar) = Just tyvar
312 getTyVarMaybe (UniSyn _ _ exp) = getTyVarMaybe exp
313 getTyVarMaybe other = Nothing
315 getTyVarTemplateMaybe :: UniType -> Maybe TyVarTemplate
316 getTyVarTemplateMaybe (UniTyVarTemplate tyvar) = Just tyvar
317 getTyVarTemplateMaybe (UniSyn _ _ exp) = getTyVarTemplateMaybe exp
318 getTyVarTemplateMaybe other = Nothing
321 @splitType@ splits a type into three components. The first is the
322 bound type variables, the second is the context and the third is the
323 tau type. I'll produce specific functions which access particular pieces
324 of the type when we see where they are needed.
327 splitType :: UniType -> ([TyVarTemplate], ThetaType, TauType)
329 = case (split_foralls uni_ty) of { (tyvars, rho_ty) ->
330 case (split_rho_ty rho_ty) of { (theta_ty, tau_ty) ->
331 --false:ASSERT(isTauTy tau_ty) TauType
332 (tyvars, theta_ty, tau_ty)
335 split_foralls (UniForall tyvar uni_ty)
336 = case (split_foralls uni_ty) of { (tyvars,new_ty) ->
337 (tyvar:tyvars, new_ty) }
339 split_foralls other_ty = ([], other_ty)
341 split_rho_ty (UniFun (UniDict clas ty) ty_body)
342 = case (split_rho_ty ty_body) of { (context,ty_body') ->
343 ((clas, ty) :context, ty_body') }
345 split_rho_ty other_ty = ([], other_ty)
348 Sometimes we want the dictionaries counted as arguments. We guarantee
349 to return {\em some} arguments if there are any, but not necessarily
350 {\em all}. In particular, the ``result type'' might be a @UniDict@,
351 which might (in the case of a single-classop class) be a function. In
352 that case, we strongly avoid returning a @UniDict@ ``in the corner''
353 (by @unDictify@ing that type, too).
355 This seems like a bit of a fudge, frankly, but it does the job.
358 splitTypeWithDictsAsArgs
361 [UniType], -- arg types
362 TauType) -- result type
364 splitTypeWithDictsAsArgs ty
365 = case (splitType ty) of { (tvs, theta, tau_ty) ->
366 case (splitTyArgs tau_ty) of { (tau_arg_tys, res_ty) ->
368 result extra_arg_tys res_ty
369 = --false: ASSERT(isTauTy res_ty) TauType
371 [ mkDictTy c t | (c,t) <- theta ] ++ tau_arg_tys ++ extra_arg_tys,
374 if not (isDictTy res_ty) then
378 undicted_res_ty = unDictifyTy res_ty
379 (tau_arg_tys', res_ty') = splitTyArgs undicted_res_ty
381 if (null theta && null tau_arg_tys)
382 || isFunType undicted_res_ty then
384 -- (a) The input ty was just a "dictionary" for a
385 -- single-method class with no super-dicts; the
386 -- "dictionary" is just the one method itself; we'd really
387 -- rather give info about that method...
389 -- (b) The input ty gave back a "dictionary" for a
390 -- single-method class; if the method itself is a
391 -- function, then we'd jolly well better add its arguments
392 -- onto the whole "arg_tys" list.
394 -- There may be excessive paranoia going on here (WDP).
396 result tau_arg_tys' res_ty'
398 else -- do nothing special...
403 @splitForalls@ is similar, but only splits off the forall'd type
407 splitForalls :: UniType -> ([TyVarTemplate], RhoType)
409 splitForalls (UniForall tyvar ty)
410 = case (splitForalls ty) of
411 (tyvars, new_ty) -> (tyvar:tyvars, new_ty)
412 splitForalls (UniSyn _ _ ty) = splitForalls ty
413 splitForalls other_ty = ([], other_ty)
416 And a terribly convenient way to access @splitType@:
419 getTauType :: UniType -> TauType
421 = case (splitType uni_ty) of { (_,_,tau_ty) ->
422 --false:ASSERT(isTauTy tau_ty) TauType??? (triggered in ProfMassage)
426 @splitTyArgs@ does the same for the arguments of a function type.
429 splitTyArgs :: TauType -> ([TauType], TauType)
432 = --false: ASSERT(isTauTy ty) TauType???
435 split (UniSyn _ _ expand) = split expand
437 split (UniFun arg result)
438 = case (split result) of { (args, result') ->
439 (arg:args, result') }
443 funResultTy :: RhoType -- Function type
444 -> Int -- Number of args to which applied
445 -> RhoType -- Result type
447 funResultTy ty 0 = ty
448 funResultTy (UniSyn _ _ expand) n_args = funResultTy expand n_args
449 funResultTy ty@(UniDict _ _) n_args = funResultTy (unDictifyTy ty) n_args
450 funResultTy (UniFun _ result_ty) n_args = funResultTy result_ty (n_args - 1)
452 funResultTy other_ty n_args = panic ("funResultTy:not a fun:"++(ppShow 80 (ppr PprDebug other_ty)))
456 The type-destructor functions above return dictionary information in
457 terms of @UniDict@, a relatively abstract construct. What really
458 happens ``under the hood'' is that {\em tuples} (usually) are passed
459 around as ordinary arguments. Sometimes we want this ``what's really
460 happening'' information.
462 The interesting case for @getUniDataTyCon_maybe@ is if the argument is
463 a dictionary type. Dictionaries are represented by tuples (except for
464 size-one dictionaries which are represented by the method itself), so
465 @getUniDataTyCon_maybe@ has to figure out which tuple. This is a bit
466 unsatisfactory; the information about how dictionaries are represented
467 is rather thinly distributed.
469 @unDictify@ only removes a {\em top-level} @UniDict@. There may be
470 buried @UniDicts@ in what is returned.
473 unDictifyTy :: UniType -- Might be a UniDict
474 -> UniType -- Can't be a UniDict
476 unDictifyTy (UniSyn _ _ expansion) = unDictifyTy expansion
478 unDictifyTy (UniDict clas ty)
479 = ASSERT(dict_size >= 0)
480 if dict_size == 1 then
481 unDictifyTy (head all_arg_tys) -- just the <whatever> itself
482 -- The extra unDictify is to make sure that
483 -- the result isn't still a dict, which it might be
484 -- if the original guy was a dict with one superdict and
487 UniData (mkTupleTyCon dict_size) all_arg_tys -- a tuple of 'em
488 -- NB: dict_size can be 0 if the class is
489 -- _CCallable, _CReturnable (and anything else
490 -- *really weird* that the user writes).
492 (tyvar, super_classes, ops) = getClassSig clas
493 dict_size = length super_classes + length ops
495 super_dict_tys = map mk_super_ty super_classes
496 class_op_tys = map mk_op_ty ops
498 all_arg_tys = super_dict_tys ++ class_op_tys
500 mk_super_ty sc = mkDictTy sc ty
501 mk_op_ty op = instantiateTy [(tyvar,ty)] (getClassOpLocalType op)
503 unDictifyTy other_ty = other_ty
508 sourceTypes :: TauType -> [TauType]
510 = --false:ASSERT(isTauTy ty)
511 (fst . splitTyArgs) ty
513 targetType :: TauType -> TauType
515 = --false: ASSERT(isTauTy ty) TauType??
516 (snd . splitTyArgs) ty
520 Here is a function that tell you if a type has as its target a Synonym.
521 If so it returns the relevant constructor and its argument type.
525 isSynTarget :: UniType -> Maybe (TyCon,Int)
527 isSynTarget (UniFun _ arg) = case isSynTarget arg of
528 Just (tycon,x) -> Just (tycon,x + 1)
530 isSynTarget (UniSyn tycon _ _) = Just (tycon,0)
531 isSynTarget (UniForall _ e) = isSynTarget e
532 isSynTarget _ = Nothing
533 --isSynTarget (UniTyVarTemplate e) = panic "isSynTarget: got a UniTyVarTemplate!"
538 splitDictType :: UniType -> (Class, UniType)
539 splitDictType (UniDict clas ty) = (clas, ty)
540 splitDictType (UniSyn _ _ ty) = splitDictType ty
541 splitDictType other = panic "splitDictTy"
544 In @kindFromType@ it can happen that we come across a @TyVarTemplate@,
545 for example when figuring out the kinds of the argument of a data
546 constructor; inside the @DataCon@ the argument types are in template form.
549 kindFromType :: UniType -> PrimKind
550 kindFromType (UniSyn tycon tys expand) = kindFromType expand
551 kindFromType (UniData tycon tys) = getTyConKind tycon (map kindFromType tys)
552 kindFromType other = PtrKind -- the "default"
554 isPrimType :: UniType -> Bool
556 isPrimType (UniSyn tycon tys expand) = isPrimType expand
558 isPrimType (UniData tycon tys) | isPodizedPodTyCon tycon
560 #endif {- Data Parallel Haskell}
561 isPrimType (UniData tycon tys) = isPrimTyCon tycon
562 isPrimType other = False -- the "default"
564 maybeBoxedPrimType :: UniType -> Maybe (Id{-DataCon-}, UniType)
566 maybeBoxedPrimType ty
567 = case (getUniDataTyCon_maybe ty) of -- Data type,
568 Just (tycon, tys_applied, [data_con]) -- with exactly one constructor
569 -> case (getInstantiatedDataConSig data_con tys_applied) of
570 (_, [data_con_arg_ty], _) -- Applied to exactly one type,
571 | isPrimType data_con_arg_ty -- which is primitive
572 -> Just (data_con, data_con_arg_ty)
573 other_cases -> Nothing
574 other_cases -> Nothing
577 At present there are no unboxed non-primitive types, so
578 isUnboxedDataType is the same as isPrimType.
581 isUnboxedDataType :: UniType -> Bool
583 isUnboxedDataType (UniSyn _ _ expand) = isUnboxedDataType expand
584 isUnboxedDataType (UniData tycon _) = not (isBoxedTyCon tycon)
585 isUnboxedDataType other = False
588 If you want to run @getUniDataTyCon...@ or @UniDataArgTys@ over a
589 dictionary-full type, then put the type through @unDictifyTy@ first.
592 getUniDataTyCon_maybe
594 -> Maybe (TyCon, -- the type constructor
595 [TauType], -- types to which it is applied
596 [Id]) -- its family of data-constructors
598 getUniDataTyCon_maybe ty
599 = --false:ASSERT(isTauTy ty) TauType?
602 get (UniSyn _ _ expand) = get expand
603 get ty@(UniDict _ _) = get (unDictifyTy ty)
605 get (UniData tycon arg_tys)
606 = Just (tycon, arg_tys, getTyConDataCons tycon)
607 -- does not returned specialised data constructors
609 get other_ty = Nothing
612 @getUniDataTyCon@ is just a version which fails noisily.
615 = case getUniDataTyCon_maybe ty of
618 Nothing -> pprPanic "getUniDataTyCon:" (ppr PprShowAll ty)
622 @getUniDataSpecTyCon_maybe@ returns an appropriate specialised tycon,
623 any remaining (boxed) type arguments, and specialsied constructors.
625 getUniDataSpecTyCon_maybe
627 -> Maybe (TyCon, -- the type constructor
628 [TauType], -- types to which it is applied
629 [Id]) -- its family of data-constructors
631 getUniDataSpecTyCon_maybe ty
632 = case getUniDataTyCon_maybe ty of
634 Just unspec@(tycon, tycon_arg_tys, datacons) ->
635 let spec_tys = specialiseConstrTys tycon_arg_tys
636 spec_reqd = maybeToBool (firstJust spec_tys)
638 data_cons = getTyConDataCons tycon
639 spec_datacons = map (mkSameSpecCon spec_tys) data_cons
640 spec_tycon = mkSpecTyCon tycon spec_tys
642 tys_left = [ty | (spec, ty) <- spec_tys `zip` tycon_arg_tys,
643 not (maybeToBool spec) ]
646 then Just (spec_tycon, tys_left, spec_datacons)
650 @getUniDataSpecTyCon@ is just a version which fails noisily.
652 getUniDataSpecTyCon ty
653 = case getUniDataSpecTyCon_maybe ty of
655 Nothing -> panic ("getUniDataSpecTyCon:"++ (ppShow 80 (ppr PprShowAll ty)))
658 @getMentionedTyCons@ maps a type constructor to a list of type
659 constructors. If the type constructor is built-in or a @data@ type
660 constructor, the list is empty. In the case of synonyms, list
661 contains all the type {\em synonym} constructors {\em directly}
662 mentioned in the definition of the synonym.
664 getMentionedTyCons :: TyCon -> [TyCon]
666 getMentionedTyCons (SynonymTyCon _ _ _ _ expansion _) = get_ty_cons expansion
668 get_ty_cons (UniTyVar _) = []
669 get_ty_cons (UniTyVarTemplate _)= []
670 get_ty_cons (UniData _ tys) = concat (map get_ty_cons tys)
671 get_ty_cons (UniFun ty1 ty2) = get_ty_cons ty1 ++ get_ty_cons ty2
672 get_ty_cons (UniSyn tycon _ _) = [tycon]
673 get_ty_cons _ = panic "get_ty_cons: unexpected UniType"
675 getMentionedTyCons other_tycon = []
678 Here's a similar thing used in the Semantique strictness analyser:
680 #ifdef USE_SEMANTIQUE_STRANAL
681 getReferredToTyCons :: TauType -> [TyCon]
682 getReferredToTyCons (UniTyVar v) = []
683 getReferredToTyCons (UniTyVarTemplate v) = []
684 getReferredToTyCons (UniData t ts) = t : concat (map getReferredToTyCons ts)
685 getReferredToTyCons (UniFun s t) = getReferredToTyCons s ++ getReferredToTyCons t
686 getReferredToTyCons (UniSyn _ _ t) = getReferredToTyCons (getTauType t)
687 getReferredToTyCons other = panic "getReferredToTyCons: not TauType"
688 #endif {- Semantique strictness analyser -}
691 This @getMentioned*@ code is for doing interfaces. Tricky point: we
692 {\em always} expand synonyms in interfaces, so note the handling of
695 getMentionedTyConsAndClassesFromUniType :: UniType -> (Bag TyCon, Bag Class)
697 getMentionedTyConsAndClassesFromUniType (UniTyVar _) = (emptyBag, emptyBag)
698 getMentionedTyConsAndClassesFromUniType (UniTyVarTemplate _) = (emptyBag, emptyBag)
700 getMentionedTyConsAndClassesFromUniType (UniData tycon arg_tys)
701 = foldr do_arg_ty (unitBag tycon, emptyBag) arg_tys
703 do_arg_ty ty (ts_sofar, cs_sofar)
704 = case (getMentionedTyConsAndClassesFromUniType ty) of { (ts, cs) ->
705 (ts `unionBags` ts_sofar, cs `unionBags` cs_sofar) }
707 getMentionedTyConsAndClassesFromUniType (UniFun ty1 ty2)
708 = case (getMentionedTyConsAndClassesFromUniType ty1) of { (ts1, cs1) ->
709 case (getMentionedTyConsAndClassesFromUniType ty2) of { (ts2, cs2) ->
710 (ts1 `unionBags` ts2, cs1 `unionBags` cs2) }}
712 getMentionedTyConsAndClassesFromUniType (UniSyn tycon _ expansion)
713 = getMentionedTyConsAndClassesFromUniType expansion
714 -- if synonyms were not expanded: (unitBag tycon, emptyBag)
716 getMentionedTyConsAndClassesFromUniType (UniDict clas ty)
717 = case (getMentionedTyConsAndClassesFromUniType ty) of { (ts, cs) ->
718 (ts, cs `snocBag` clas) }
720 getMentionedTyConsAndClassesFromUniType (UniForall _ ty)
721 = getMentionedTyConsAndClassesFromUniType ty
724 This code could go in @TyCon@, but it's better to keep all the
725 ``getMentioning'' together.
727 getMentionedTyConsAndClassesFromTyCon :: TyCon -> (Bag TyCon, Bag Class)
729 getMentionedTyConsAndClassesFromTyCon tycon@(SynonymTyCon _ _ _ _ ty _)
730 = case (getMentionedTyConsAndClassesFromUniType ty) of { (ts, cs) ->
731 (ts `snocBag` tycon, cs) }
733 getMentionedTyConsAndClassesFromTyCon tycon@(DataTyCon _ _ _ _ constructors _ _)
734 = foldr do_con (unitBag tycon, emptyBag) constructors
735 -- We don't worry whether this TyCon is exported abstractly
736 -- or not, because even if so, the pragmas probably need
737 -- to know this info.
739 do_con con (ts_sofar, cs_sofar)
740 = case (getMentionedTyConsAndClassesFromId con) of { (ts, cs) ->
741 (ts `unionBags` ts_sofar, cs `unionBags` cs_sofar) }
743 getMentionedTyConsAndClassesFromTyCon other
744 = panic "tried to get mentioned tycons and classes from funny tycon"
748 getMentionedTyConsAndClassesFromClass :: Class -> (Bag TyCon, Bag Class)
750 getMentionedTyConsAndClassesFromClass clas@(MkClass _ _ _ super_classes _ ops _ _ _ _)
752 (emptyBag, unitBag clas `unionBags` listToBag super_classes)
755 do_op (MkClassOp _ _ ty) (ts_sofar, cs_sofar)
756 = case (getMentionedTyConsAndClassesFromUniType ty) of { (ts, cs) ->
757 (ts `unionBags` ts_sofar, cs `unionBags` cs_sofar) }
760 Grab a name for the type. This is used to determine the type
761 description for profiling.
763 getUniTyDescription :: UniType -> String
764 getUniTyDescription ty
765 = case (getTauType ty) of
766 UniFun arg res -> '-' : '>' : fun_result res
767 UniData tycon _ -> _UNPK_ (getOccurrenceName tycon)
768 UniSyn tycon _ _ -> _UNPK_ (getOccurrenceName tycon)
769 UniDict cls uni -> "dict" -- Or from unitype ?
770 UniTyVar _ -> "*" -- Distinguish ?
771 UniTyVarTemplate _-> "*"
772 _ -> panic "getUniTyName: other"
775 fun_result (UniFun _ res) = '>' : fun_result res
776 fun_result other = getUniTyDescription other
780 %************************************************************************
782 \subsection[UniTyFuns-fvs]{Extracting free type variables}
784 %************************************************************************
786 @extractTyVarsFromTy@ gets the free type variables from a @UniType@.
787 The list returned has no duplicates.
790 extractTyVarsFromTys :: [UniType] -> [TyVar]
791 extractTyVarsFromTys = foldr (unionLists . extractTyVarsFromTy) []
793 extractTyVarsFromTy :: UniType -> [TyVar]
794 extractTyVarsFromTy ty
797 -- weird arg order so we can foldr easily
798 get (UniTyVar tyvar) free
799 | tyvar `is_elem` free = free
800 | otherwise = tyvar:free
801 get (UniTyVarTemplate _) free = free
802 get (UniFun ty1 ty2) free = get ty1 (get ty2 free)
803 get (UniData tycon tys) free = foldr get free tys
804 get (UniSyn tycon tys ty) free = foldr get free tys
805 get (UniDict clas ty) free = get ty free
806 get (UniForall tyvar ty) free = get ty free
808 is_elem = isIn "extractTyVarsFromTy"
812 extractTyVarTemplatesFromTy :: UniType -> [TyVarTemplate]
813 extractTyVarTemplatesFromTy ty
816 get (UniTyVarTemplate tyvar) free
817 | tyvar `is_elem` free = free
818 | otherwise = tyvar:free
819 get (UniTyVar tyvar) free = free
820 get (UniFun ty1 ty2) free = get ty1 (get ty2 free)
821 get (UniData tycon tys) free = foldr get free tys
822 get (UniSyn tycon tys ty) free = foldr get free tys
823 get (UniDict clas ty) free = get ty free
824 get (UniForall tyvar ty) free = get ty free
826 is_elem = isIn "extractTyVarTemplatesFromTy"
829 %************************************************************************
831 \subsection[UniTyFuns-predicates]{Predicates (and such) on @UniTypes@}
833 %************************************************************************
835 We include functions that return @Maybe@ thingies as ``predicates.''
838 isTyVarTy :: UniType -> Bool
839 isTyVarTy (UniTyVar _) = True
840 isTyVarTy (UniSyn _ _ expand) = isTyVarTy expand
841 isTyVarTy other = False
843 -- isTyVarTemplateTy only used in Renamer for error checking
844 isTyVarTemplateTy :: UniType -> Bool
845 isTyVarTemplateTy (UniTyVarTemplate tv) = True
846 isTyVarTemplateTy (UniSyn _ _ expand) = isTyVarTemplateTy expand
847 isTyVarTemplateTy other = False
849 maybeUnpackFunTy :: TauType -> Maybe (TauType, TauType)
852 = --false: ASSERT(isTauTy ty) TauType??
855 maybe (UniSyn _ _ expand) = maybe expand
856 maybe (UniFun arg result) = Just (arg, result)
857 maybe ty@(UniDict _ _) = maybe (unDictifyTy ty)
858 maybe other = Nothing
860 isFunType :: TauType -> Bool
862 = --false: ASSERT(isTauTy ty) TauType???
863 maybeToBool (maybeUnpackFunTy ty)
868 isDataConType :: TauType -> Bool
874 is_con_ty (UniData _ _) = True
875 is_con_ty (UniSyn _ _ expand) = is_con_ty expand
882 leakFree (UniData (DataTyCon ...) tys)
883 = nonrecursive type &&
884 all leakFree (apply constructors to tys)
886 leakFree (PrimTyCon...) = True
888 leakFree (TyVar _) = False
889 leakFree (UniFun _ _) = False
891 non-recursive: enumeration types, tuples, primitive types...
895 The list of @TyCons@ is ones we have already seen (and mustn't see
899 isLeakFreeType :: [TyCon] -> UniType -> Bool
901 isLeakFreeType seen (UniSyn _ _ expand) = isLeakFreeType seen expand
903 isLeakFreeType _ (UniTyVar _) = False -- Utterly unknown
904 isLeakFreeType _ (UniTyVarTemplate _) = False
906 isLeakFreeType _ (UniFun _ _) = False -- Could have leaky free variables
908 isLeakFreeType _ ty@(UniDict _ _) = True -- I'm prepared to bet that
909 -- we'll never get a space leak
910 -- from a dictionary. But I could
913 isLeakFreeType seen (UniForall _ ty) = isLeakFreeType seen ty
915 -- For a data type we must look at all the argument types of all
916 -- the constructors. It isn't enough to look merely at the
917 -- types to which the type constructor is applied. For example
919 -- data Foo a = MkFoo [a]
921 -- Is (Foo Int) leak free? No!
923 isLeakFreeType seen (UniData tycon tycon_arg_tys)
924 | tycon `is_elem` seen = False -- Recursive type! Bale out!
926 | isDataTyCon tycon = all data_con_args_leak_free (getTyConDataCons tycon)
928 | otherwise = isPrimTyCon tycon && -- was an assert; now just paranoia
929 -- We should have a leak-free-ness predicate on PrimTyCons,
930 -- but that's too big a change for today, so we hack it.
931 -- Return true iff it's one of the tycons we know are leak-free
932 -- 94/10: I hope I don't live to regret taking out
933 -- the first check...
935 charPrimTyCon, intPrimTyCon, wordPrimTyCon,
936 addrPrimTyCon, floatPrimTyCon, doublePrimTyCon,
937 byteArrayPrimTyCon, arrayPrimTyCon,
938 mallocPtrPrimTyCon, stablePtrPrimTyCon
939 -- List almost surely incomplete!
941 &&-} (all (isLeakFreeType (tycon:seen)) tycon_arg_tys)
943 data_con_args_leak_free data_con
944 = case (getInstantiatedDataConSig data_con tycon_arg_tys) of { (_,arg_tys,_) ->
945 all (isLeakFreeType (tycon:seen)) arg_tys }
947 is_elem = isIn "isLeakFreeType"
952 hasHigherOrderArg :: UniType -> Bool
954 = case (splitType ty) of { (_, _, tau_ty) ->
955 case (splitTyArgs tau_ty) of { (arg_tys, _) ->
957 foldr ((||) . isFunType . expandTySyns) False arg_tys
963 isDictTy :: UniType -> Bool
965 isDictTy (UniDict _ _) = True
966 isDictTy (UniSyn _ _ expand) = isDictTy expand
969 isTauTy :: UniType -> Bool
971 isTauTy (UniTyVar v) = True
972 isTauTy (UniFun a b) = isTauTy a && isTauTy b
973 isTauTy (UniData _ tys) = all isTauTy tys
974 isTauTy (UniSyn _ _ ty) = isTauTy ty
975 isTauTy (UniDict _ ty) = False
976 isTauTy (UniTyVarTemplate _) = False
977 isTauTy (UniForall _ _) = False
979 isForAllTy :: UniType -> Bool
980 isForAllTy (UniForall _ _) = True
981 isForAllTy (UniSyn _ _ ty) = isForAllTy ty
985 NOTE: I haven't thought about this much (ToDo: check).
987 isGroundOrTyVarTy, isGroundTy :: UniType -> Bool
989 isGroundOrTyVarTy ty = isGroundTy ty || isTyVarTy ty
991 isGroundTy (UniTyVar tyvar) = False
992 isGroundTy (UniTyVarTemplate _) = False
993 isGroundTy (UniFun ty1 ty2) = isGroundTy ty1 && isGroundTy ty2
994 isGroundTy (UniData tycon tys) = all isGroundTy tys
995 isGroundTy (UniSyn _ _ exp) = isGroundTy exp
996 isGroundTy (UniDict clas ty) = isGroundTy ty
997 isGroundTy (UniForall tyvar ty) = False -- Safe for the moment
1000 Broadly speaking, instances are exported (a)~if {\em either} the class
1001 or {\em OUTERMOST} tycon [arbitrary...] is exported; or (b)~{\em both}
1002 class and tycon are from PreludeCore [non-std, but convenient] {\em
1003 and} the instance was defined in this module. BUT: if either the
1004 class or tycon was defined in this module, but not exported, then
1005 there is no point exporting the instance.
1009 :: Class -> TauType -- class/"tycon" defining instance
1010 -> Bool -- True <=> instance decl in this module
1013 instanceIsExported clas ty from_here
1014 = --false:ASSERT(isTauTy ty) TauType?? failed compiling IArray
1015 if is_core_class then
1016 if is_fun_tycon || is_core_tycon then
1020 || (is_imported_tycon && from_here) -- V NAUGHTY BY HASKELL RULES
1022 else if is_fun_tycon || is_core_tycon then
1023 -- non-Core class; depends on its export flag
1025 || (is_imported_class && from_here) -- V NAUGHTY BY HASKELL RULES
1027 else -- non-Core class & non-Core tycon:
1028 -- exported if one of them is, but not if either of them
1029 -- is locally-defined *and* not exported
1030 if (isLocallyDefined clas && not is_exported_class)
1031 || (isLocallyDefined tycon && not is_exported_tycon) then
1034 is_exported_class || is_exported_tycon
1036 tycon = case getUniDataTyCon_maybe ty of
1038 Nothing -> panic "instanceIsExported:no tycon"
1040 is_core_class = fromPreludeCore clas
1041 is_core_tycon = fromPreludeCore tycon
1043 is_fun_tycon = isFunType ty
1045 is_exported_class = case (getExportFlag clas) of
1046 NotExported -> False
1049 is_exported_tycon = case (getExportFlag tycon) of
1050 NotExported -> False
1053 is_imported_class = not (isLocallyDefined clas)
1054 is_imported_tycon = not (isLocallyDefined tycon)
1058 maybePurelyLocalTyCon :: TyCon -> Maybe [Pretty]
1059 maybePurelyLocalClass :: Class -> Maybe [Pretty]
1060 maybePurelyLocalType :: UniType -> Maybe [Pretty]
1062 purely_local tc -- overloaded
1063 = if (isLocallyDefined tc && not (isExported tc))
1064 then Just (ppr PprForUser tc)
1067 --overloaded: merge_maybes :: (a -> Maybe b) -> [a] -> Maybe [b]
1070 = case (catMaybes (map f xs)) of
1071 [] -> Nothing -- no hit anywhere along the list
1074 maybePurelyLocalTyCon tycon
1076 mentioned_tycons = fst (getMentionedTyConsAndClassesFromTyCon tycon)
1077 -- will include tycon itself
1079 merge_maybes purely_local (bagToList mentioned_tycons)
1081 maybePurelyLocalClass clas
1083 (mentioned_classes, mentioned_tycons)
1084 = getMentionedTyConsAndClassesFromClass clas
1085 -- will include clas itself
1087 tc_stuff = merge_maybes purely_local (bagToList mentioned_tycons)
1088 cl_stuff = merge_maybes purely_local (bagToList mentioned_classes)
1090 case (tc_stuff, cl_stuff) of
1091 (Nothing, Nothing) -> Nothing
1092 (Nothing, Just xs) -> Just xs
1093 (Just xs, Nothing) -> Just xs
1094 (Just xs, Just ys) -> Just (xs ++ ys)
1096 maybePurelyLocalType ty
1098 (mentioned_classes, mentioned_tycons)
1099 = getMentionedTyConsAndClassesFromUniType ty
1100 -- will include ty itself
1102 tc_stuff = merge_maybes purely_local (bagToList mentioned_tycons)
1103 cl_stuff = merge_maybes purely_local (bagToList mentioned_classes)
1105 case (tc_stuff, cl_stuff) of
1106 (Nothing, Nothing) -> Nothing
1107 (Nothing, Just xs) -> Just xs
1108 (Just xs, Nothing) -> Just xs
1109 (Just xs, Just ys) -> Just (xs ++ ys)
1112 A gigantic HACK due to Simon (95/05)
1114 returnsRealWorld :: UniType -> Bool
1116 returnsRealWorld (UniTyVar _) = False
1117 returnsRealWorld (UniTyVarTemplate _) = False
1118 returnsRealWorld (UniSyn _ _ exp) = returnsRealWorld exp
1119 returnsRealWorld (UniDict _ ty) = returnsRealWorld ty
1120 returnsRealWorld (UniForall _ ty) = returnsRealWorld ty
1121 returnsRealWorld (UniFun ty1 ty2) = returnsRealWorld ty2
1123 returnsRealWorld (UniData tycon []) = tycon == realWorldTyCon
1124 returnsRealWorld (UniData tycon tys) = any returnsRealWorld tys
1129 isProcessorTy :: UniType -> Bool
1130 isProcessorTy (UniData tycon _) = isProcessorTyCon tycon
1131 isProcessorTy _ = False
1132 #endif {- Data Parallel Haskell -}
1135 Podization of a function @f@ is the compile time specialisation of @f@
1136 to a form that is equivalent to (map.f) . We can podize {\em some}
1137 functions at runtime because of the laws concerning map and functional
1140 map (f . g) == (map f) . (map g) etc...
1142 i.e If we compose two functions, to create a {\em new} function, then
1143 we can compose the podized versions in just the same way. There is a
1144 problem however (as always :-(; We cannot convert between an vanilla
1145 function, and the podized form (and visa versa) at run-time. The
1146 predicate below describes the set of all objects that cannot be
1147 podized at runtime (i.e anything that has a function in it).
1150 runtimeUnpodizableType:: UniType -> Bool
1151 runtimeUnpodizableType (UniDict _ _) = True
1152 runtimeUnpodizableType (UniFun _ _) = True
1153 runtimeUnpodizableType (UniData _ tys) = any runtimeUnpodizableType tys
1154 runtimeUnpodizableType (UniSyn _ _ ty) = runtimeUnpodizableType ty
1155 runtimeUnpodizableType other = False
1156 #endif {- Data Parallel Haskell -}
1159 %************************************************************************
1161 \subsection[UniTyFuns-subst]{Substitute in a type}
1163 %************************************************************************
1165 The idea here is to substitute for the TyVars in a type. Note, not
1166 the TyVarTemplates---that's the job of instantiateTy.
1168 There is a single general function, and two interfaces.
1170 \subsubsection{Interface 1: substitutions}
1171 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1173 NOTE: This has been moved to @Subst@ (mostly for speed reasons).
1175 \subsubsection{Interface 2: Envs}
1176 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1179 applyTypeEnvToTy :: TypeEnv -> SigmaType -> SigmaType
1180 applyTypeEnvToTy tenv ty
1181 = mapOverTyVars v_fn ty
1183 v_fn v = case (lookupTyVarEnv tenv v) of
1185 Nothing -> UniTyVar v
1187 applyTypeEnvToTauTy :: TypeEnv -> TauType -> TauType
1188 applyTypeEnvToTauTy e ty
1189 = ASSERT(isTauTy ty)
1190 applyTypeEnvToTy e ty
1192 applyTypeEnvToThetaTy tenv theta
1195 applyTypeEnvToTauTy tenv ty) | (clas, ty) <- theta]
1198 \subsubsection{@mapOverTyVars@: does the real work}
1199 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1201 @mapOverTyVars@ is a local function which actually does the work. It does
1202 no cloning or other checks for shadowing, so be careful when calling
1203 this on types with Foralls in them.
1206 mapOverTyVars :: (TyVar -> UniType) -> UniType -> UniType
1207 mapOverTyVars v_fn (UniTyVar v) = v_fn v
1208 mapOverTyVars v_fn (UniFun t1 t2) = UniFun (mapOverTyVars v_fn t1) (mapOverTyVars v_fn t2)
1209 mapOverTyVars v_fn (UniData con args) = UniData con (map (mapOverTyVars v_fn) args)
1210 mapOverTyVars v_fn (UniSyn con args ty) = UniSyn con (map (mapOverTyVars v_fn) args) (mapOverTyVars v_fn ty)
1211 mapOverTyVars v_fn (UniDict clas ty) = UniDict clas (mapOverTyVars v_fn ty)
1212 mapOverTyVars v_fn (UniForall v ty) = UniForall v (mapOverTyVars v_fn ty)
1213 mapOverTyVars v_fn (UniTyVarTemplate v) = UniTyVarTemplate v
1216 %************************************************************************
1218 \subsection[UniTyFuns-ppr]{Pretty-printing @UniTypes@}
1220 %************************************************************************
1222 @pprUniType@ is the std @UniType@ printer; the overloaded @ppr@
1223 function is defined to use this. @pprParendUniType@ is the same,
1224 except it puts parens around the type, except for the atomic cases.
1225 @pprParendUniType@ works just by setting the initial context
1226 precedence very high. ToDo: what if not a @TauType@?
1228 pprUniType, pprParendUniType :: PprStyle -> UniType -> Pretty
1230 pprUniType sty ty = ppr_ty_init sty tOP_PREC ty
1231 pprParendUniType sty ty = ppr_ty_init sty tYCON_PREC ty
1233 pprMaybeTy :: PprStyle -> Maybe UniType -> Pretty
1234 pprMaybeTy PprDebug Nothing = ppStr "*"
1235 pprMaybeTy PprDebug (Just ty) = pprParendUniType PprDebug ty
1237 getTypeString :: UniType -> [FAST_STRING]
1238 -- shallowly magical; converts a type into something
1239 -- vaguely close to what can be used in C identifier.
1240 -- Don't forget to include the module name!!!
1244 ppr_t = ppr_ty PprForUser (\t -> ppStr "*") tOP_PREC (expandTySyns ty)
1246 string = _PK_ (tidy (ppShow 1000 ppr_t))
1252 (is_prelude_ty, mod)
1253 = case getUniDataTyCon_maybe ty of
1254 Nothing -> true_bottom
1256 if fromPreludeCore tycon
1258 else (False, fst (getOrigName tycon))
1260 true_bottom = (True, panic "getTypeString")
1262 --------------------------------------------------
1263 -- tidy: very ad-hoc
1264 tidy [] = [] -- done
1268 ' ' : _ -> tidy more
1269 '-' : '>' : xs -> '-' : '>' : tidy (no_leading_sps xs)
1270 other -> ' ' : tidy more
1272 tidy (',' : more) = ',' : tidy (no_leading_sps more)
1274 tidy (x : xs) = x : tidy xs -- catch all
1276 no_leading_sps [] = []
1277 no_leading_sps (' ':xs) = no_leading_sps xs
1278 no_leading_sps other = other
1280 typeMaybeString :: Maybe UniType -> [FAST_STRING]
1281 typeMaybeString Nothing = [SLIT("!")]
1282 typeMaybeString (Just t) = getTypeString t
1284 specMaybeTysSuffix :: [Maybe UniType] -> FAST_STRING
1285 specMaybeTysSuffix ty_maybes
1287 ty_strs = concat (map typeMaybeString ty_maybes)
1288 dotted_tys = [ _CONS_ '.' str | str <- ty_strs ]
1293 Nota Bene: we must assign print-names to the forall'd type variables
1294 alphabetically, with the first forall'd variable having the alphabetically
1295 first name. Reason: so anyone reading the type signature printed without
1296 explicit forall's will be able to reconstruct them in the right order.
1299 ppr_ty_init :: PprStyle -> Int -> UniType -> Pretty
1301 ppr_ty_init sty init_prec ty
1302 = let (tyvars, _, _) = splitType ty
1303 lookup_fn = mk_lookup_tyvar_fn sty tyvars
1305 ppr_ty sty lookup_fn init_prec ty
1307 mk_lookup_tyvar_fn :: PprStyle -> [TyVarTemplate] -> (TyVarTemplate -> Pretty)
1309 mk_lookup_tyvar_fn sty tyvars
1312 tv_lookup_fn :: TyVarTemplate -> Pretty
1315 pp_tyvar_styish = ppr sty tyvar
1317 assocs = [ pp | (tv, pp) <- tvs_n_pprs, tv == tyvar ]
1321 [] -> pprPanic "pprUniType: bad tyvar lookup:" (ppr sty tyvar)
1322 -- sometimes, in printing monomorphic types,
1323 -- (usually in debugging), we won't have the tyvar
1324 -- in our list; so we just ppr it anyway...
1328 PprInterface _ -> pp_tyvar_canonical
1329 PprForC _ -> ppChar '*'
1330 PprUnfolding _ -> case assocs of
1331 x:_ -> ppBeside x (ppPStr SLIT("$z1"))
1332 _ -> ppPStr SLIT("z$z1")
1333 PprForUser -> case assocs of
1335 _ -> pp_tyvar_styish
1336 debuggish -> pp_tyvar_styish
1338 tvs_n_pprs = tyvars `zip` tyvar_pretties
1340 tyvar_pretties = letter_pprs {- a..y -} ++ number_pprs {- z0 ... zN -}
1342 letter_pprs = map (\ c -> ppChar c ) ['a' .. 'y']
1343 number_pprs = map (\ n -> ppBeside (ppChar 'z') (ppInt n))
1348 ppr_ty :: PprStyle -> (TyVarTemplate -> Pretty) -> Int -> UniType -> Pretty
1350 ppr_ty sty lookup_fn ctxt_prec (UniTyVarTemplate tyvar) = lookup_fn tyvar
1352 ppr_ty sty lookup_fn ctxt_prec (UniTyVar tyvar) = ppr sty tyvar
1354 ppr_ty sty lookup_fn ctxt_prec ty
1356 PprForUser -> context_onward
1357 PprInterface _ -> context_onward
1359 (if null tyvars then id else ppBeside (ppr_forall sty tyvars))
1362 (tyvars, context, tau_ty) = splitType ty
1365 if (null pretty_context_pieces) then
1366 ppr_tau_ty sty lookup_fn ctxt_prec tau_ty
1368 ppCat (pretty_context_pieces
1369 ++ [connector sty, ppr_tau_ty sty lookup_fn ctxt_prec tau_ty]) -- ToDo: dubious
1371 pretty_context_pieces = ppr_context sty context
1373 ppr_forall :: PprStyle -> [TyVarTemplate] -> Pretty
1375 ppr_forall _ [] = ppNil
1376 ppr_forall sty tyvars
1377 = ppBesides [ppPStr SLIT("_forall_ "), ppIntersperse pp'SP{-'-} pp_tyvars,
1380 pp_tyvars = map lookup_fn tyvars
1382 ppr_context :: PprStyle -> [(Class, UniType)] -> [Pretty]
1384 ppr_context _ [] = []
1385 ppr_context sty context@(c:cs)
1387 PprForUser -> userish
1388 PprInterface _ -> userish
1392 = [if (context `lengthExceeds` (1::Int)) then
1393 ppBesides [ ppLparen,
1394 ppIntersperse pp'SP{-'-} (map (ppr_kappa_tau PprForUser) context),
1397 ppr_kappa_tau PprForUser (head context)
1400 = (ppr_kappa_tau sty c) : (map ( pin_on_arrow . (ppr_kappa_tau sty) ) cs)
1402 connector PprForUser = ppPStr SLIT("=>")
1403 connector (PprInterface _) = ppPStr SLIT("=>")
1404 connector other_sty = ppPStr SLIT("->")
1406 ppr_kappa_tau :: PprStyle -> (Class, UniType) -> Pretty
1408 ppr_kappa_tau sty (clas, ty)
1410 pp_ty = ppr_tau_ty sty lookup_fn ctxt_prec ty
1411 user_ish = ppCat [ppr PprForUser clas, pp_ty]
1412 hack_ish = ppBesides [ppStr "{{", ppr sty clas, ppSP, pp_ty, ppStr "}}"]
1415 PprForUser -> user_ish
1416 PprInterface _ -> user_ish
1419 pin_on_arrow p = ppBeside (ppPStr SLIT("-> ")) p
1422 @ppr_tau_ty@ takes an @Int@ that is the precedence of the context.
1423 The precedence levels are:
1425 \item[0:] What we start with.
1426 \item[1:] Function application (@UniFuns@).
1427 \item[2:] Type constructors.
1430 A non-exported help function that really does the printing:
1432 tOP_PREC = (0 :: Int)
1433 fUN_PREC = (1 :: Int)
1434 tYCON_PREC = (2 :: Int)
1436 ppr_tau_ty :: PprStyle -> (TyVarTemplate -> Pretty) -> Int -> UniType -> Pretty
1438 -- a quite special case, for printing instance decls in interfaces:
1439 ppr_tau_ty sty@(PprInterface _) lookup_fn ctxt_prec (UniDict clas ty)
1440 = ppCat [ppr PprForUser clas, ppr_ty sty lookup_fn tYCON_PREC ty]
1442 ppr_tau_ty sty lookup_fn ctxt_prec (UniSyn _ _ expansion)
1443 -- Expand type synonyms unless PprForUser
1444 -- NB: it is important that synonyms are expanded with PprInterface
1445 | case sty of { PprForUser -> False; _ -> True }
1446 = ppr_tau_ty sty lookup_fn ctxt_prec expansion
1448 ppr_tau_ty sty lookup_fn ctxt_prec (UniTyVarTemplate tyvar) = lookup_fn tyvar
1450 ppr_tau_ty sty lookup_fn ctxt_prec (UniTyVar tyvar) = ppr sty tyvar
1452 ppr_tau_ty sty lookup_fn ctxt_prec (UniFun ty1 ty2)
1453 -- we fiddle the precedences passed to left/right branches,
1454 -- so that right associativity comes out nicely...
1456 = let p1 = ppr_tau_ty sty lookup_fn fUN_PREC ty1
1457 p2 = ppr_tau_ty sty lookup_fn tOP_PREC ty2
1459 if ctxt_prec < fUN_PREC then -- no parens needed
1460 ppCat [p1, ppBeside (ppPStr SLIT("-> ")) p2]
1462 ppCat [ppBeside ppLparen p1, ppBesides [ppPStr SLIT("-> "), p2, ppRparen]]
1464 -- Special printing for list and tuple types.
1465 -- we can re-set the precedence to tOP_PREC
1467 ppr_tau_ty sty lookup_fn ctxt_prec (UniData tycon tys)
1468 = if tycon == listTyCon then
1469 ppBesides [ppLbrack, ppr_tau_ty sty lookup_fn tOP_PREC (head tys), ppRbrack]
1471 else if (tycon == (TupleTyCon (length tys))) then
1472 ppBesides [ppLparen, ppIntersperse pp'SP{-'-} (map (ppr_tau_ty sty lookup_fn tOP_PREC) tys), ppRparen]
1474 else if (tycon == podTyCon) then
1475 pprPodshort sty lookup_fn tOP_PREC (head tys)
1477 else if (tycon == (ProcessorTyCon ((length tys)-1))) then
1478 ppBesides [ppStr "(|",
1479 ppIntersperse pp'SP{-'-}
1480 (map (ppr_tau_ty sty lookup_fn tOP_PREC) (init tys)),
1482 ppr_tau_ty sty lookup_fn tOP_PREC (last tys),
1484 #endif {- Data Parallel Haskell -}
1486 ppr_tycon_and_tys sty lookup_fn ctxt_prec tycon tys
1488 ppr_tau_ty sty lookup_fn ctxt_prec (UniSyn tycon tys expansion)
1490 (ppr_tycon_and_tys sty lookup_fn ctxt_prec tycon tys)
1491 (ifPprShowAll sty (ppCat [ppStr " {- expansion:", ppr_ty sty lookup_fn ctxt_prec expansion, ppStr "-}"]))
1493 -- For SPECIALIZE instance error messages ...
1494 ppr_tau_ty sty@PprForUser lookup_fn ctxt_prec (UniDict clas ty)
1495 = if ctxt_prec < tYCON_PREC then
1496 ppCat [ppr sty clas, ppr_ty sty lookup_fn tYCON_PREC ty]
1498 ppBesides [ppStr "(", ppr sty clas, ppSP, ppr_ty sty lookup_fn tYCON_PREC ty, ppStr ")"]
1500 ppr_tau_ty sty lookup_fn ctxt_prec (UniDict clas ty)
1501 = ppBesides [ppStr "{{", ppr sty clas, ppSP, ppr_ty sty lookup_fn tYCON_PREC ty, ppStr "}}"]
1503 ppr_tau_ty sty lookup_fn ctxt_prec other_ty -- must a be UniForall (ToDo: something?)
1504 = ppBesides [ppLparen, ppr_ty sty lookup_fn ctxt_prec other_ty, ppRparen]
1506 -- code shared for UniDatas and UniSyns
1507 ppr_tycon_and_tys :: PprStyle -> (TyVarTemplate -> Pretty) -> Int -> TyCon -> [UniType] -> Pretty
1509 ppr_tycon_and_tys sty lookup_fn ctxt_prec tycon tys
1510 = let pp_tycon = ppr (case sty of PprInterface _ -> PprForUser; _ -> sty) tycon
1514 else if ctxt_prec < tYCON_PREC then -- no parens needed
1515 ppCat [pp_tycon, ppIntersperse ppSP (map (ppr_tau_ty sty lookup_fn tYCON_PREC) tys) ]
1517 ppBesides [ ppLparen, pp_tycon, ppSP,
1518 ppIntersperse ppSP (map (ppr_tau_ty sty lookup_fn tYCON_PREC) tys), ppRparen ]
1523 pprPodshort :: PprStyle -> (TyVarTemplate-> Pretty) -> Int -> UniType -> Pretty
1524 pprPodshort sty lookup_fn ctxt_prec (UniData tycon tys)
1525 | (tycon == (ProcessorTyCon ((length tys)-1)))
1526 = ppBesides [ppStr "<<",
1527 ppIntersperse pp'SP{-'-}
1528 (map (ppr_tau_ty sty lookup_fn tOP_PREC) (init tys)),
1530 ppr_tau_ty sty lookup_fn tOP_PREC (last tys),
1532 pprPodshort sty lookup_fn ctxt_prec ty
1533 = ppBesides [ppStr "<<",
1534 ppr_tau_ty sty lookup_fn tOP_PREC ty,
1536 #endif {- Data Parallel Haskell -}
1540 showTyCon :: PprStyle -> TyCon -> String
1542 = ppShow 80 (pprTyCon sty tycon [])
1544 pprTyCon :: PprStyle -> TyCon -> [[Maybe UniType]] -> Pretty
1545 -- with "PprInterface", we print out for interfaces
1547 pprTyCon sty@(PprInterface sw_chkr) (SynonymTyCon k n a vs exp unabstract) specs
1548 = ASSERT (null specs)
1550 lookup_fn = mk_lookup_tyvar_fn sty vs
1551 pp_tyvars = map lookup_fn vs
1552 pp_abstract = if unabstract || (sw_chkr OmitInterfacePragmas)
1554 else ppStr "{-# GHC_PRAGMA _ABSTRACT_ #-}"
1556 ppCat [ppPStr SLIT("type"), ppr sty n, ppIntersperse ppSP pp_tyvars,
1557 ppEquals, ppr_ty sty lookup_fn tOP_PREC exp, pp_abstract]
1559 pprTyCon sty@(PprInterface sw_chkr) this_tycon@(DataTyCon k n a vs cons derivings unabstract) specs
1560 = ppHang (ppCat [ppPStr SLIT("data"),
1561 -- pprContext sty context,
1563 ppIntersperse ppSP (map lookup_fn vs)])
1565 (ppCat [pp_unabstract_condecls,
1567 -- NB: we do not print deriving info in interfaces
1569 lookup_fn = mk_lookup_tyvar_fn sty vs
1571 yes_we_print_condecls
1573 && not (null cons) -- we know what they are
1574 && (case (getExportFlag n) of
1578 yes_we_print_pragma_condecls
1579 = not yes_we_print_condecls
1580 && not (sw_chkr OmitInterfacePragmas)
1582 && not (maybeToBool (maybePurelyLocalTyCon this_tycon))
1583 {- && not (any (dataConMentionsNonPreludeTyCon this_tycon) cons) -}
1585 yes_we_print_pragma_specs
1588 pp_unabstract_condecls
1589 = if yes_we_print_condecls
1590 then ppCat [ppSP, ppEquals, pp_condecls]
1594 = if yes_we_print_pragma_condecls
1599 = if yes_we_print_pragma_specs
1604 = if (yes_we_print_pragma_condecls || yes_we_print_pragma_specs)
1605 then ppCat [ppStr "\t{-# GHC_PRAGMA", pp_pragma_condecls, pp_pragma_specs, ppStr "#-}"]
1612 ppCat ((ppr_con c) : (map ppr_next_con cs))
1616 (_, _, con_arg_tys, _) = getDataConSig con
1618 ppCat [pprNonOp PprForUser con, -- the data con's name...
1619 ppIntersperse ppSP (map (ppr_ty sty lookup_fn tYCON_PREC) con_arg_tys)]
1621 ppr_next_con con = ppCat [ppChar '|', ppr_con con]
1624 = ppBesides [ppStr "_SPECIALISE_ ", pp_the_list [
1625 ppCat [ppLbrack, ppInterleave ppComma (map pp_maybe ty_maybes), ppRbrack]
1626 | ty_maybes <- specs ]]
1629 pp_the_list (p:ps) = ppCat [ppBeside p ppComma, pp_the_list ps]
1631 pp_maybe Nothing = pp_NONE
1632 pp_maybe (Just ty) = pprParendUniType sty ty
1634 pp_NONE = ppStr "_N_"
1636 pprTyCon (PprInterface _) (TupleTyCon a) specs
1637 = ASSERT (null specs)
1638 ppCat [ ppStr "{- Tuple", ppInt a, ppStr "-}" ]
1640 pprTyCon (PprInterface _) (PrimTyCon k n a kind_fn) specs
1641 = ASSERT (null specs)
1642 ppCat [ ppStr "{- data", ppr PprForUser n, ppStr " *built-in* -}" ]
1645 pprTyCon (PprInterface _) (ProcessorTyCon a) specs
1646 = ppCat [ ppStr "{- Processor", ppInt a, ppStr "-}" ]
1647 #endif {- Data Parallel Haskell -}
1649 -- regular printing (ToDo: probably update)
1651 pprTyCon sty (SynonymTyCon k n a vs exp unabstract) [{-no specs-}]
1652 = ppBeside (ppr sty n)
1654 (ppCat [ ppStr " {-", ppInt a, interpp'SP sty vs,
1655 pprParendUniType sty exp,
1656 if unabstract then ppNil else ppStr "_ABSTRACT_", ppStr "-}"]))
1658 pprTyCon sty tycon@(DataTyCon k n a vs cons derivings unabstract) [{-no specs-}]
1660 PprDebug -> pp_tycon_and_uniq
1661 PprShowAll -> pp_tycon_and_uniq
1664 pp_tycon_and_uniq = ppBesides [pp_tycon, ppStr "{-", pprUnique k, ppStr "-}"]
1669 if codeStyle sty || tycon /= listTyCon
1671 else ppBesides [ppLbrack, interpp'SP sty vs, ppRbrack]
1673 {-ppBeside-} -- pp_tycon
1676 (ppCat [ ppStr " {-", ppInt a, interppSP sty vs,
1677 interpp'SP PprForUser cons,
1678 ppStr "deriving (", interpp'SP PprForUser derivings,
1682 pprTyCon sty (TupleTyCon a) [{-no specs-}]
1683 = ppBeside (ppPStr SLIT("Tuple")) (ppInt a)
1685 pprTyCon sty (PrimTyCon k n a kind_fn) [{-no specs-}]
1688 pprTyCon sty (SpecTyCon tc ty_maybes) []
1689 = ppBeside (pprTyCon sty tc [])
1691 then identToC tys_stuff
1692 else ppPStr tys_stuff)
1694 tys_stuff = specMaybeTysSuffix ty_maybes
1697 pprTyCon sty (ProcessorTyCon a) [] = ppBeside (ppStr "Processor") (ppInt a)
1699 pprTyCon sty (PodizedPodTyCon dim tc) []
1700 = ppBesides [ ppr sty tc, ppStr "Podized", ppr sty dim]
1701 #endif {- Data Parallel Haskell -}
1705 pprIfaceClass :: (GlobalSwitch -> Bool) -> (Id -> Id) -> IdEnv UnfoldingDetails -> Class -> Pretty
1707 pprIfaceClass sw_chker better_id_fn inline_env
1708 (MkClass k n tyvar super_classes sdsels ops sels defms insts links)
1710 sdsel_infos = map (getIdInfo . better_id_fn) sdsels
1712 ppAboves [ ppCat [ppPStr SLIT("class"), ppr_theta tyvar super_classes,
1713 ppr sty n, lookup_fn tyvar,
1715 || omit_iface_pragmas
1716 || (any boringIdInfo sdsel_infos)
1717 -- ToDo: really should be "all bor..."
1718 -- but then parsing is more tedious,
1719 -- and this is really as good in practice.
1721 else pp_sdsel_pragmas (sdsels `zip` sdsel_infos),
1724 else ppPStr SLIT("where")],
1726 [ ppr_op op (better_id_fn sel) (better_id_fn defm)
1727 | (op,sel,defm) <- zip3 ops sels defms]) ]
1729 sty = PprInterface sw_chker
1730 omit_iface_pragmas = sw_chker OmitInterfacePragmas
1732 lookup_fn = mk_lookup_tyvar_fn sty [tyvar]
1734 ppr_theta :: TyVarTemplate -> [Class] -> Pretty
1735 ppr_theta tv [] = ppNil
1736 ppr_theta tv super_classes
1737 = ppBesides [ppLparen,
1738 ppIntersperse pp'SP{-'-} (map ppr_assert super_classes),
1741 ppr_assert (MkClass _ n _ _ _ _ _ _ _ _) = ppCat [ppr sty n, lookup_fn tv]
1743 pp_sdsel_pragmas sdsels_and_infos
1744 = ppCat [ppStr "{-# GHC_PRAGMA {-superdicts-}",
1745 ppIntersperse pp'SP{-'-}
1746 [ppIdInfo sty sdsel False{-NO specs-} better_id_fn inline_env info
1747 | (sdsel, info) <- sdsels_and_infos ],
1750 ppr_op op opsel_id defm_id
1752 stuff = ppBeside (ppChar '\t') (ppr_class_op sty [tyvar] op)
1754 if omit_iface_pragmas
1757 (ppCat [ppStr "\t {-# GHC_PRAGMA", ppAbove pp_opsel pp_defm, ppStr "#-}"])
1759 pp_opsel = ppCat [ppPStr SLIT("{-meth-}"), ppIdInfo sty opsel_id False{-no specs-} better_id_fn inline_env (getIdInfo opsel_id)]
1760 pp_defm = ppCat [ppPStr SLIT("\t\t{-defm-}"), ppIdInfo sty defm_id False{-no specs-} better_id_fn inline_env (getIdInfo defm_id)]
1764 pprClassOp :: PprStyle -> ClassOp -> Pretty
1766 pprClassOp sty op = ppr_class_op sty [] op
1768 ppr_class_op sty tyvars (MkClassOp op_name i ty)
1771 PprForAsm _ _ _ -> pp_C
1772 PprInterface _ -> ppCat [pp_user, ppPStr SLIT("::"), ppr_ty sty lookup_fn tOP_PREC ty]
1773 PprShowAll -> ppCat [pp_user, ppPStr SLIT("::"), ppr_ty PprDebug lookup_fn tOP_PREC ty]
1776 (local_tyvars,_,_) = splitType ty
1777 lookup_fn = mk_lookup_tyvar_fn sty (tyvars ++ local_tyvars)
1779 pp_C = ppPStr op_name
1780 pp_user = if isAvarop op_name
1781 then ppBesides [ppLparen, pp_C, ppRparen]
1785 %************************************************************************
1787 \subsection[UniTyFuns-matching]{@matchTy@}
1789 %************************************************************************
1791 Matching is a {\em unidirectional} process, matching a type against a
1792 template (which is just a type with type variables in it). The matcher
1793 assumes that there are no repeated type variables in the template, so that
1794 it simply returns a mapping of type variables to types.
1797 matchTy :: UniType -- Template
1798 -> UniType -- Proposed instance of template
1799 -> Maybe [(TyVarTemplate,UniType)] -- Matching substitution
1801 matchTy (UniTyVarTemplate v) ty = Just [(v,ty)]
1802 matchTy (UniTyVar _) ty = panic "matchTy: unexpected TyVar (need TyVarTemplates)"
1804 matchTy (UniFun fun1 arg1) (UniFun fun2 arg2) = matchTys [fun1, arg1] [fun2, arg2]
1806 matchTy ty1@(UniData con1 args1) ty2@(UniData con2 args2) | con1 == con2
1807 = matchTys args1 args2 -- Same constructors, just match the arguments
1809 -- with type synonyms, we have to be careful
1810 -- for the exact same reasons as in the unifier.
1811 -- Please see the considerable commentary there
1812 -- before changing anything here! (WDP 95/05)
1814 -- If just one or the other is a "visible" synonym (they all are at
1815 -- the moment...), just expand it.
1817 matchTy (UniSyn con1 args1 ty1) ty2
1818 | isVisibleSynTyCon con1
1820 matchTy ty1 (UniSyn con2 args2 ty2)
1821 | isVisibleSynTyCon con2
1824 matchTy (UniSyn con1 args1 ty1) (UniSyn con2 args2 ty2)
1825 -- if we get here, both synonyms must be "abstract"
1826 -- (NB: not done yet)
1827 = if (con1 == con2) then
1828 -- Good news! Same synonym constructors, so we can shortcut
1829 -- by unifying their arguments and ignoring their expansions.
1830 matchTys args1 args2
1832 -- Never mind. Just expand them and try again
1836 matchTy templ ty = Nothing
1839 @matchTys@ matches corresponding elements of a list of templates and
1843 matchTys :: [UniType] -> [UniType] -> Maybe [(TyVarTemplate, UniType)]
1845 matchTys [] [] = Just []
1846 matchTys (templ:templs) (ty:tys)
1847 = case (matchTy templ ty) of
1849 Just subst -> case (matchTys templs tys) of
1851 Just subst2 -> Just (subst ++ subst2)
1854 = pprPanic "matchTys: out of templates!; tys:" (ppr PprDebug tys)
1856 = pprPanic "matchTys: out of types!; templates:" (ppr PprDebug tmpls)
1860 %************************************************************************
1862 \subsection[UniTyFuns-misc]{Misc @UniType@ functions}
1864 %************************************************************************
1867 cmpUniTypeMaybeList :: [Maybe UniType] -> [Maybe UniType] -> TAG_
1868 cmpUniTypeMaybeList [] [] = EQ_
1869 cmpUniTypeMaybeList (x:xs) [] = GT_
1870 cmpUniTypeMaybeList [] (y:ys) = LT_
1871 cmpUniTypeMaybeList (x:xs) (y:ys)
1872 = case cmp_maybe_ty x y of { EQ_ -> cmpUniTypeMaybeList xs ys; other -> other }
1874 cmp_maybe_ty Nothing Nothing = EQ_
1875 cmp_maybe_ty (Just x) Nothing = GT_
1876 cmp_maybe_ty Nothing (Just y) = LT_
1877 cmp_maybe_ty (Just x) (Just y) = cmpUniType True{-properly-} x y
1880 Identity function if the type is a @TauType@; panics otherwise.
1883 verifyTauTy :: String -> TauType -> TauType
1885 verifyTauTy caller ty@(UniDict _ _) = pprPanic (caller++":verifyTauTy:dict") (ppr PprShowAll ty)
1886 verifyTauTy caller ty@(UniForall _ _) = pprPanic (caller++":verifyTauTy:forall") (ppr PprShowAll ty)
1887 verifyTauTy caller (UniSyn tycon tys expansion) = UniSyn tycon tys (verifyTauTy caller expansion)
1888 verifyTauTy caller tau_ty = tau_ty
1894 showTypeCategory :: UniType -> Char
1896 {C,I,F,D} char, int, float, double
1898 S other single-constructor type
1899 {c,i,f,d} unboxed ditto
1901 s *unpacked" single-cons...
1907 + dictionary, unless it's a ...
1910 M other (multi-constructor) data-con type
1912 - reserved for others to mark as "uninteresting"
1918 case getUniDataTyCon_maybe ty of
1919 Nothing -> if isFunType ty
1924 if maybeToBool (maybeCharLikeTyCon tycon) then 'C'
1925 else if maybeToBool (maybeIntLikeTyCon tycon) then 'I'
1926 else if maybeToBool (maybeFloatLikeTyCon tycon) then 'F'
1927 else if maybeToBool (maybeDoubleLikeTyCon tycon) then 'D'
1928 else if tycon == integerTyCon then 'J'
1929 else if tycon == charPrimTyCon then 'c'
1930 else if (tycon == intPrimTyCon || tycon == wordPrimTyCon
1931 || tycon == addrPrimTyCon) then 'i'
1932 else if tycon == floatPrimTyCon then 'f'
1933 else if tycon == doublePrimTyCon then 'd'
1934 else if isPrimTyCon tycon {- array, we hope -} then 'A'
1935 else if isEnumerationTyCon tycon then 'E'
1936 else if isTupleTyCon tycon then 'T'
1937 else if maybeToBool (maybeSingleConstructorTyCon tycon) then 'S'
1938 else if tycon == listTyCon then 'L'
1939 else 'M' -- oh, well...