[project @ 1996-01-08 20:28:12 by partain]
[ghc.git] / ghc / compiler / uniType / UniTyFuns.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
3 %
4 \section[UniTyFuns]{Utility functions for @UniTypes@}
5
6 This is one of the modules whose functions know about the internal
7 representation of @UniTypes@ (and @TyCons@ and ... ?).
8
9 \begin{code}
10 #include "HsVersions.h"
11
12 module UniTyFuns (
13
14         -- CONSTRUCTION
15         applyTy, applyTyCon, applySynTyCon, applyNonSynTyCon,
16         {-mkSigmaTy,-} glueTyArgs, mkSuperDictSelType, --UNUSED: mkDictFunType,
17         specialiseTy,
18
19         -- DESTRUCTION
20 --not exported: expandTySyns,
21         expandVisibleTySyn,
22         getTyVar, getTyVarMaybe, getTyVarTemplateMaybe,
23         splitType, splitForalls, getTauType, splitTyArgs,
24         splitTypeWithDictsAsArgs,
25 --not exported/unused:  sourceTypes, targetType,
26         funResultTy,
27         splitDictType,
28         kindFromType,
29         getUniDataTyCon, getUniDataTyCon_maybe,
30         getUniDataSpecTyCon, getUniDataSpecTyCon_maybe,
31         unDictifyTy,
32         getMentionedTyCons,
33 #ifdef USE_SEMANTIQUE_STRANAL
34         getReferredToTyCons,
35 #endif {- Semantique strictness analyser -}
36         getMentionedTyConsAndClassesFromUniType,
37         getMentionedTyConsAndClassesFromTyCon,
38         getMentionedTyConsAndClassesFromClass,
39         getUniTyDescription,
40
41         -- FREE-VARIABLE EXTRACTION
42         extractTyVarsFromTy, extractTyVarsFromTys,
43         extractTyVarTemplatesFromTy,
44
45         -- PREDICATES
46         isTyVarTy, isTyVarTemplateTy,
47         maybeUnpackFunTy, isFunType,
48         isPrimType, isUnboxedDataType, -- UNUSED: isDataConType,
49         isLeakFreeType,
50         maybeBoxedPrimType,
51 --UNUSED:       hasHigherOrderArg,
52         isDictTy, isGroundTy, isGroundOrTyVarTy,
53         instanceIsExported,
54 -- UNUSED:      isSynTarget,
55         isTauTy, isForAllTy,
56         maybePurelyLocalTyCon, maybePurelyLocalClass, maybePurelyLocalType,
57         returnsRealWorld, -- HACK courtesy of SLPJ
58 #ifdef DPH
59         isProcessorTy,
60         runtimeUnpodizableType,
61 #endif {- Data Parallel Haskell -}
62
63         -- SUBSTITUTION
64         applyTypeEnvToTy, applyTypeEnvToThetaTy,
65 --not exported : applyTypeEnvToTauTy,
66         mapOverTyVars,
67         -- moved to Subst: applySubstToTauTy, applySubstToTy, applySubstToThetaTy,
68         -- genInstantiateTyUS, -- ToDo: ???
69
70         -- PRETTY PRINTING AND FORCING
71         pprUniType, pprParendUniType, pprMaybeTy,
72         pprTyCon, pprIfaceClass, pprClassOp,
73         getTypeString,
74         typeMaybeString,
75         specMaybeTysSuffix,
76         showTyCon,
77         showTypeCategory,
78
79         -- MATCHING and COMPARISON
80         matchTy, -- UNUSED: matchTys,
81         cmpUniTypeMaybeList,
82
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
87    ) where
88
89 IMPORT_Trace            -- ToDo:rm (debugging)
90
91 -- internal modules; allowed to see constructors for type things
92 import Class
93 import TyVar
94 import TyCon
95 import UniType
96
97 import AbsPrel          ( listTyCon, integerTyCon, charPrimTyCon,
98                           intPrimTyCon, wordPrimTyCon, addrPrimTyCon,
99                           floatPrimTyCon, doublePrimTyCon,
100                           realWorldTyCon
101 #ifdef DPH
102                           , podTyCon
103 #endif {- Data Parallel Haskell -}
104                         )
105 import Bag
106 import CLabelInfo       ( identToC )
107 import CmdLineOpts      ( GlobalSwitch(..) )
108 import Id               ( Id, getIdInfo,
109                           getMentionedTyConsAndClassesFromId,
110                           getInstantiatedDataConSig,
111                           getDataConSig, mkSameSpecCon,
112                           DataCon(..)
113                         )
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 )
119 import Maybes
120 import Outputable
121 import Pretty
122 import PrimKind         ( PrimKind(..) )
123 import SpecTyFuns       ( specialiseConstrTys )
124 import TyVarEnv
125 import Unique           -- used UniqueSupply monadery
126 import Util
127 \end{code}
128
129 %************************************************************************
130 %*                                                                      *
131 \subsection[UniTyFuns-construction]{Putting types together}
132 %*                                                                      *
133 %************************************************************************
134
135 \begin{code}
136 applyTy :: SigmaType -> SigmaType -> SigmaType
137
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
141 #ifdef DEBUG
142 applyTy bad_fun_ty arg_ty
143   = pprPanic "applyTy: not a forall type:" (ppAbove (ppr PprDebug bad_fun_ty) (ppr PprDebug arg_ty))
144 #endif
145 \end{code}
146
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@.
151
152 \begin{code}
153 applyTyCon, applySynTyCon, applyNonSynTyCon :: TyCon -> [TauType] -> TauType
154
155 applyTyCon tc tys
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
158     let
159         result = apply_tycon tc tys
160     in
161     --false:ASSERT (isTauTy result)  TauType?? 94/06
162     result
163  where
164     apply_tycon tc@(SynonymTyCon _ _ _ _ _ _) tys = applySynTyCon tc tys
165     apply_tycon tc@(DataTyCon _ _ _ _ _ _ _)  tys = applyNonSynTyCon tc tys
166
167     apply_tycon tc@(PrimTyCon _ _ _ _) tys        = UniData tc tys
168
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.
172
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)
176       where
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 [] [] = []
180    
181 #ifdef DPH
182     apply_tycon tc@(ProcessorTyCon _) tys = UniData tc tys
183 #endif {- Data Parallel Haskell -}
184
185
186 -----------------
187
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
191   where
192     SynonymTyCon _ _ _ tyvars template _ = tycon
193         -- NB: Matched lazily
194
195 #ifdef DEBUG
196     ok_tys = map (verifyTauTy "applyTyConLazily[syn]") tys
197 #else
198     ok_tys = tys
199 #endif
200
201 -----------------
202
203 applyNonSynTyCon tycon tys      -- We don't expect function tycons;
204                                 -- but it must be lazy, so we can't check that here!
205 #ifdef DEBUG
206   = UniData tycon (map (verifyTauTy "applyTyConLazily[data]") tys)
207 #else
208   = UniData tycon tys
209 #endif
210 \end{code}
211
212 @glueTyArgs [ty1,...,tyn] ty@ returns the type
213 @ty1 -> ... -> tyn -> ty@.  This is the exact reverse of @splitTyArgs@.
214
215 \begin{code}
216 -- ToDo: DEBUG: say what's true about these types
217 glueTyArgs :: [UniType] -> UniType -> UniType
218
219 glueTyArgs tys ty = foldr UniFun ty tys
220 \end{code}
221
222 \begin{code}
223 mkSuperDictSelType :: Class     -- The input class
224                    -> Class     -- The superclass
225                    -> UniType   -- The type of the selector function
226
227 mkSuperDictSelType clas@(MkClass _ _ tyvar _ _ _ _ _ _ _) super
228   = UniForall tyvar (UniFun (UniDict clas  (UniTyVarTemplate tyvar))
229                             (UniDict super (UniTyVarTemplate tyvar)))
230 \end{code}
231
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.
235
236 \begin{code}
237 {- UNUSED:
238 mkDictFunType :: [TyVarTemplate] -> ThetaType -> Class -> TauType -> UniType
239
240 mkDictFunType tyvars theta clas tau_ty
241 #ifndef DEBUG
242  = mkForallTy tyvars (foldr f (UniDict clas tau_ty) theta)
243 #else
244  = mkForallTy tyvars (foldr f (UniDict clas (verifyTauTy "mkDictFunType" tau_ty)) theta)
245 #endif
246    where
247      f (clas,tau_ty) sofar = UniFun (UniDict clas tau_ty) sofar
248 -}
249 \end{code}
250
251 \begin{code}
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
256              -> UniType
257
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)
263   where
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]
270 \end{code}
271
272 %************************************************************************
273 %*                                                                      *
274 \subsection[UniTyFuns-destruction]{Taking types apart}
275 %*                                                                      *
276 %************************************************************************
277
278 @expandVisibleTySyn@ removes any visible type-synonym from the top level of a
279 @TauType@. Note that the expansion is recursive.
280
281 @expandTySyns@ removes all type-synonyms from a @TauType@.
282
283 \begin{code}
284 expandVisibleTySyn, expandTySyns :: TauType -> TauType
285
286 expandVisibleTySyn (UniSyn con _ tau)
287   | isVisibleSynTyCon con
288   = ASSERT(isTauTy tau)
289     expandVisibleTySyn tau
290 expandVisibleTySyn tau
291   = ASSERT(isTauTy tau)
292     tau
293
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)
298                                 tau
299 \end{code}
300
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.
304
305 \begin{code}
306 getTyVar :: String -> UniType -> TyVar
307 getTyVar panic_msg (UniTyVar tyvar) = tyvar
308 getTyVar panic_msg other            = panic ("getTyVar: " ++ panic_msg)
309
310 getTyVarMaybe :: UniType -> Maybe TyVar
311 getTyVarMaybe (UniTyVar tyvar)  = Just tyvar
312 getTyVarMaybe (UniSyn _ _ exp)  = getTyVarMaybe exp
313 getTyVarMaybe other             = Nothing
314
315 getTyVarTemplateMaybe :: UniType -> Maybe TyVarTemplate
316 getTyVarTemplateMaybe (UniTyVarTemplate tyvar)  = Just tyvar
317 getTyVarTemplateMaybe (UniSyn _ _ exp)          = getTyVarTemplateMaybe exp
318 getTyVarTemplateMaybe other                     = Nothing
319 \end{code}
320
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.
325
326 \begin{code}
327 splitType :: UniType -> ([TyVarTemplate], ThetaType, TauType)
328 splitType uni_ty
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)
333     }}
334   where
335     split_foralls (UniForall tyvar uni_ty)
336       = case (split_foralls uni_ty) of { (tyvars,new_ty) ->
337         (tyvar:tyvars, new_ty) }
338
339     split_foralls other_ty = ([], other_ty)
340
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') }
344
345     split_rho_ty other_ty = ([], other_ty)
346 \end{code}
347
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).
354
355 This seems like a bit of a fudge, frankly, but it does the job.
356
357 \begin{code}
358 splitTypeWithDictsAsArgs
359         :: UniType              -- input
360         -> ([TyVarTemplate],
361             [UniType],          -- arg types
362             TauType)            -- result type
363
364 splitTypeWithDictsAsArgs ty
365   = case (splitType ty)         of { (tvs, theta, tau_ty) ->
366     case (splitTyArgs tau_ty)   of { (tau_arg_tys, res_ty) ->
367     let
368         result extra_arg_tys res_ty
369           = --false: ASSERT(isTauTy res_ty) TauType
370             (tvs,
371              [ mkDictTy c t | (c,t) <- theta ] ++ tau_arg_tys ++ extra_arg_tys,
372              res_ty)
373     in
374     if not (isDictTy res_ty) then
375         result [] res_ty
376     else
377         let
378             undicted_res_ty         = unDictifyTy res_ty
379             (tau_arg_tys', res_ty') = splitTyArgs undicted_res_ty
380         in
381         if (null theta && null tau_arg_tys)
382         || isFunType undicted_res_ty then
383
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...
388
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.
393             
394             -- There may be excessive paranoia going on here (WDP).
395
396             result tau_arg_tys' res_ty'
397
398         else -- do nothing special...
399             result [] res_ty
400     }}
401 \end{code}
402
403 @splitForalls@ is similar, but only splits off the forall'd type
404 variables.
405   
406 \begin{code}
407 splitForalls :: UniType -> ([TyVarTemplate], RhoType)
408
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)
414 \end{code}
415
416 And a terribly convenient way to access @splitType@:
417
418 \begin{code}
419 getTauType :: UniType -> TauType
420 getTauType uni_ty
421   = case (splitType uni_ty) of { (_,_,tau_ty) ->
422     --false:ASSERT(isTauTy tau_ty) TauType??? (triggered in ProfMassage)
423     tau_ty }
424 \end{code}
425
426 @splitTyArgs@ does the same for the arguments of a function type.
427
428 \begin{code}
429 splitTyArgs :: TauType -> ([TauType], TauType)
430
431 splitTyArgs ty
432   = --false: ASSERT(isTauTy ty) TauType???
433     split ty
434   where
435     split (UniSyn _ _ expand) = split expand
436
437     split (UniFun arg result)
438      = case (split result) of { (args, result') ->
439        (arg:args, result') }
440
441     split ty = ([], ty)
442
443 funResultTy :: RhoType          -- Function type
444             -> Int              -- Number of args to which applied
445             -> RhoType          -- Result type
446
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)
451 #ifdef DEBUG
452 funResultTy other_ty             n_args = panic ("funResultTy:not a fun:"++(ppShow 80 (ppr PprDebug other_ty)))
453 #endif
454 \end{code}
455
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.
461
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.
468
469 @unDictify@ only removes a {\em top-level} @UniDict@.  There may be
470 buried @UniDicts@ in what is returned.
471
472 \begin{code}
473 unDictifyTy :: UniType          -- Might be a UniDict
474             -> UniType          -- Can't be a UniDict
475
476 unDictifyTy (UniSyn _ _ expansion)  = unDictifyTy expansion
477
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
485                 -- no methods!
486     else
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).
491   where
492     (tyvar, super_classes, ops) = getClassSig clas
493     dict_size = length super_classes + length ops
494
495     super_dict_tys      = map mk_super_ty super_classes
496     class_op_tys        = map mk_op_ty    ops
497
498     all_arg_tys         = super_dict_tys ++ class_op_tys
499
500     mk_super_ty sc = mkDictTy sc ty
501     mk_op_ty    op = instantiateTy [(tyvar,ty)] (getClassOpLocalType op)
502
503 unDictifyTy other_ty = other_ty
504 \end{code}
505
506 \begin{code}
507 {- UNUSED:
508 sourceTypes :: TauType -> [TauType]
509 sourceTypes ty
510   = --false:ASSERT(isTauTy ty)
511     (fst . splitTyArgs) ty
512
513 targetType :: TauType -> TauType
514 targetType ty
515   = --false: ASSERT(isTauTy ty) TauType??
516     (snd . splitTyArgs) ty
517 -}
518 \end{code}
519
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.
522
523 \begin{code}
524 {- UNUSED:
525 isSynTarget :: UniType -> Maybe (TyCon,Int)
526
527 isSynTarget (UniFun _ arg)       = case isSynTarget arg of
528                                      Just (tycon,x) -> Just (tycon,x + 1)
529                                      Nothing -> Nothing
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!"
534 -}
535 \end{code}
536
537 \begin{code}
538 splitDictType :: UniType -> (Class, UniType)
539 splitDictType (UniDict clas ty) = (clas, ty)
540 splitDictType (UniSyn _ _ ty)   = splitDictType ty
541 splitDictType other             = panic "splitDictTy"
542 \end{code}
543
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.
547
548 \begin{code}
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"
553
554 isPrimType :: UniType -> Bool
555
556 isPrimType (UniSyn tycon tys expand)  = isPrimType expand
557 #ifdef DPH
558 isPrimType (UniData tycon tys) | isPodizedPodTyCon tycon       
559   = all isPrimType tys
560 #endif {- Data Parallel Haskell}
561 isPrimType (UniData tycon tys)        = isPrimTyCon tycon
562 isPrimType other                      = False           -- the "default"
563
564 maybeBoxedPrimType :: UniType -> Maybe (Id{-DataCon-}, UniType)
565
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
575 \end{code}
576
577 At present there are no unboxed non-primitive types, so
578 isUnboxedDataType is the same as isPrimType.
579
580 \begin{code}
581 isUnboxedDataType :: UniType -> Bool
582
583 isUnboxedDataType (UniSyn _ _ expand) = isUnboxedDataType expand
584 isUnboxedDataType (UniData tycon _)   = not (isBoxedTyCon tycon)
585 isUnboxedDataType other               = False
586 \end{code}
587
588 If you want to run @getUniDataTyCon...@ or @UniDataArgTys@ over a
589 dictionary-full type, then put the type through @unDictifyTy@ first.
590
591 \begin{code}
592 getUniDataTyCon_maybe
593         :: TauType
594         -> Maybe (TyCon,        -- the type constructor
595                   [TauType],    -- types to which it is applied
596                   [Id])         -- its family of data-constructors
597
598 getUniDataTyCon_maybe ty
599   = --false:ASSERT(isTauTy ty) TauType?
600     get ty
601   where
602     get (UniSyn _ _ expand) = get expand
603     get ty@(UniDict _ _)    = get (unDictifyTy ty)
604
605     get (UniData tycon arg_tys)
606       = Just (tycon, arg_tys, getTyConDataCons tycon)
607         -- does not returned specialised data constructors
608
609     get other_ty = Nothing
610 \end{code}
611
612 @getUniDataTyCon@ is just a version which fails noisily.
613 \begin{code}
614 getUniDataTyCon ty
615   = case getUniDataTyCon_maybe ty of
616       Just stuff -> stuff
617 #ifdef DEBUG
618       Nothing    -> pprPanic "getUniDataTyCon:" (ppr PprShowAll ty)
619 #endif
620 \end{code}
621
622 @getUniDataSpecTyCon_maybe@ returns an appropriate specialised tycon,
623 any remaining (boxed) type arguments, and specialsied constructors.
624 \begin{code}
625 getUniDataSpecTyCon_maybe
626         :: TauType
627         -> Maybe (TyCon,        -- the type constructor
628                   [TauType],    -- types to which it is applied
629                   [Id])         -- its family of data-constructors
630
631 getUniDataSpecTyCon_maybe ty
632   = case getUniDataTyCon_maybe ty of
633       Nothing -> Nothing
634       Just unspec@(tycon, tycon_arg_tys, datacons) ->
635         let spec_tys  = specialiseConstrTys tycon_arg_tys
636             spec_reqd = maybeToBool (firstJust spec_tys)
637
638             data_cons = getTyConDataCons tycon
639             spec_datacons = map (mkSameSpecCon spec_tys) data_cons
640             spec_tycon = mkSpecTyCon tycon spec_tys
641
642             tys_left = [ty | (spec, ty) <- spec_tys `zip` tycon_arg_tys,
643                              not (maybeToBool spec) ]
644         in
645             if spec_reqd
646             then Just (spec_tycon, tys_left, spec_datacons)
647             else Just unspec
648 \end{code}
649
650 @getUniDataSpecTyCon@ is just a version which fails noisily.
651 \begin{code}
652 getUniDataSpecTyCon ty
653   = case getUniDataSpecTyCon_maybe ty of
654       Just stuff -> stuff
655       Nothing    -> panic ("getUniDataSpecTyCon:"++ (ppShow 80 (ppr PprShowAll ty)))
656 \end{code}
657
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.
663 \begin{code}
664 getMentionedTyCons :: TyCon -> [TyCon]
665
666 getMentionedTyCons (SynonymTyCon _ _ _ _ expansion _) = get_ty_cons expansion
667   where
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"
674
675 getMentionedTyCons other_tycon = []
676 \end{code}
677
678 Here's a similar thing used in the Semantique strictness analyser:
679 \begin{code}
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 -}
689 \end{code}
690
691 This @getMentioned*@ code is for doing interfaces.  Tricky point: we
692 {\em always} expand synonyms in interfaces, so note the handling of
693 @UniSyns@.
694 \begin{code}
695 getMentionedTyConsAndClassesFromUniType :: UniType -> (Bag TyCon, Bag Class)
696
697 getMentionedTyConsAndClassesFromUniType (UniTyVar _)         = (emptyBag, emptyBag)
698 getMentionedTyConsAndClassesFromUniType (UniTyVarTemplate _) = (emptyBag, emptyBag)
699
700 getMentionedTyConsAndClassesFromUniType (UniData tycon arg_tys)
701   = foldr do_arg_ty (unitBag tycon, emptyBag) arg_tys
702   where
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) }
706
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) }}
711    
712 getMentionedTyConsAndClassesFromUniType (UniSyn tycon _ expansion) 
713  = getMentionedTyConsAndClassesFromUniType expansion
714    -- if synonyms were not expanded: (unitBag tycon, emptyBag)
715
716 getMentionedTyConsAndClassesFromUniType (UniDict clas ty)
717   = case (getMentionedTyConsAndClassesFromUniType ty) of { (ts, cs) ->
718     (ts, cs `snocBag` clas) }
719
720 getMentionedTyConsAndClassesFromUniType (UniForall _ ty)
721   = getMentionedTyConsAndClassesFromUniType ty
722 \end{code}
723
724 This code could go in @TyCon@, but it's better to keep all the
725 ``getMentioning'' together.
726 \begin{code}
727 getMentionedTyConsAndClassesFromTyCon :: TyCon -> (Bag TyCon, Bag Class)
728
729 getMentionedTyConsAndClassesFromTyCon tycon@(SynonymTyCon _ _ _ _ ty _)
730   = case (getMentionedTyConsAndClassesFromUniType ty) of { (ts, cs) ->
731     (ts `snocBag` tycon, cs) }
732
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.
738   where
739     do_con con (ts_sofar, cs_sofar)
740       = case (getMentionedTyConsAndClassesFromId con) of { (ts, cs) ->
741         (ts `unionBags` ts_sofar, cs `unionBags` cs_sofar) }
742
743 getMentionedTyConsAndClassesFromTyCon other
744  = panic "tried to get mentioned tycons and classes from funny tycon"
745 \end{code}
746
747 \begin{code}
748 getMentionedTyConsAndClassesFromClass :: Class -> (Bag TyCon, Bag Class)
749
750 getMentionedTyConsAndClassesFromClass clas@(MkClass _ _ _ super_classes _ ops _ _ _ _)
751   = foldr do_op
752           (emptyBag, unitBag clas `unionBags` listToBag super_classes)
753           ops
754   where
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) }
758 \end{code}
759
760 Grab a name for the type. This is used to determine the type
761 description for profiling.
762 \begin{code}
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"
773
774   where
775     fun_result (UniFun _ res) = '>' : fun_result res
776     fun_result other          = getUniTyDescription other
777
778 \end{code}
779   
780 %************************************************************************
781 %*                                                                      *
782 \subsection[UniTyFuns-fvs]{Extracting free type variables}
783 %*                                                                      *
784 %************************************************************************
785
786 @extractTyVarsFromTy@ gets the free type variables from a @UniType@.
787 The list returned has no duplicates.
788
789 \begin{code}
790 extractTyVarsFromTys :: [UniType] -> [TyVar]
791 extractTyVarsFromTys = foldr (unionLists . extractTyVarsFromTy) []
792
793 extractTyVarsFromTy :: UniType -> [TyVar]
794 extractTyVarsFromTy ty
795   = get ty []
796   where
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
807
808     is_elem = isIn "extractTyVarsFromTy"
809 \end{code}
810
811 \begin{code}
812 extractTyVarTemplatesFromTy :: UniType -> [TyVarTemplate]
813 extractTyVarTemplatesFromTy ty
814   = get ty []
815   where
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
825
826     is_elem = isIn "extractTyVarTemplatesFromTy"
827 \end{code}
828
829 %************************************************************************
830 %*                                                                      *
831 \subsection[UniTyFuns-predicates]{Predicates (and such) on @UniTypes@}
832 %*                                                                      *
833 %************************************************************************
834
835 We include functions that return @Maybe@ thingies as ``predicates.''
836
837 \begin{code}
838 isTyVarTy :: UniType -> Bool
839 isTyVarTy (UniTyVar _)        = True
840 isTyVarTy (UniSyn _ _ expand) = isTyVarTy expand
841 isTyVarTy other               = False
842
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
848
849 maybeUnpackFunTy :: TauType -> Maybe (TauType, TauType)
850
851 maybeUnpackFunTy ty
852   = --false: ASSERT(isTauTy ty) TauType??
853     maybe ty
854   where
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
859
860 isFunType :: TauType -> Bool
861 isFunType ty
862   = --false: ASSERT(isTauTy ty) TauType???
863     maybeToBool (maybeUnpackFunTy ty)
864 \end{code}
865
866 \begin{code}
867 {- UNUSED:
868 isDataConType :: TauType -> Bool
869
870 isDataConType ty
871   = ASSERT(isTauTy ty)
872     is_con_ty ty
873   where
874     is_con_ty (UniData _ _)       = True
875     is_con_ty (UniSyn _ _ expand) = is_con_ty expand
876     is_con_ty _                   = False
877 -}
878 \end{code}
879
880 SIMON'S NOTES:
881
882 leakFree (UniData (DataTyCon ...) tys) 
883   = nonrecursive type &&
884     all leakFree (apply constructors to tys)
885
886 leakFree (PrimTyCon...) = True
887
888 leakFree (TyVar _) = False
889 leakFree (UniFun _ _) = False
890
891 non-recursive: enumeration types, tuples, primitive types...
892
893 END NOTES
894
895 The list of @TyCons@ is ones we have already seen (and mustn't see
896 again).
897
898 \begin{code}
899 isLeakFreeType :: [TyCon] -> UniType -> Bool
900
901 isLeakFreeType seen (UniSyn _ _ expand) = isLeakFreeType seen expand
902
903 isLeakFreeType _ (UniTyVar _)         = False   -- Utterly unknown
904 isLeakFreeType _ (UniTyVarTemplate _) = False
905
906 isLeakFreeType _ (UniFun _ _) = False   -- Could have leaky free variables
907
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 
911                                         -- be wrong... SLPJ
912
913 isLeakFreeType seen (UniForall _ ty) = isLeakFreeType seen ty
914
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
918 --
919 --      data Foo a = MkFoo [a]
920 --
921 -- Is (Foo Int) leak free?  No!
922
923 isLeakFreeType seen (UniData tycon tycon_arg_tys)
924   | tycon `is_elem` seen = False        -- Recursive type!  Bale out!
925
926   | isDataTyCon tycon = all data_con_args_leak_free (getTyConDataCons tycon)
927
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...
934                         {-(tycon `elem` [
935                             charPrimTyCon, intPrimTyCon, wordPrimTyCon,
936                             addrPrimTyCon, floatPrimTyCon, doublePrimTyCon,
937                             byteArrayPrimTyCon, arrayPrimTyCon,
938                             mallocPtrPrimTyCon, stablePtrPrimTyCon
939                             -- List almost surely incomplete!
940                            ])
941                         &&-} (all (isLeakFreeType (tycon:seen)) tycon_arg_tys)
942   where
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 }
946
947     is_elem = isIn "isLeakFreeType"
948 \end{code}
949
950 \begin{code}
951 {- UNUSED:
952 hasHigherOrderArg :: UniType -> Bool
953 hasHigherOrderArg ty
954   = case (splitType   ty)       of { (_, _, tau_ty) ->
955     case (splitTyArgs tau_ty)   of { (arg_tys, _) ->
956
957     foldr ((||) . isFunType . expandTySyns) False arg_tys
958     }}
959 -}
960 \end{code}
961
962 \begin{code}
963 isDictTy :: UniType -> Bool
964
965 isDictTy (UniDict _ _)       = True
966 isDictTy (UniSyn _ _ expand) = isDictTy expand
967 isDictTy _                   = False
968
969 isTauTy :: UniType -> Bool
970
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
978
979 isForAllTy :: UniType -> Bool
980 isForAllTy (UniForall _ _) = True
981 isForAllTy (UniSyn _ _ ty) = isForAllTy ty
982 isForAllTy _               = False
983 \end{code}
984
985 NOTE: I haven't thought about this much (ToDo: check).
986 \begin{code}
987 isGroundOrTyVarTy, isGroundTy :: UniType -> Bool
988
989 isGroundOrTyVarTy ty = isGroundTy ty || isTyVarTy ty
990
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
998 \end{code}
999
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.
1006
1007 \begin{code}
1008 instanceIsExported
1009         :: Class -> TauType     -- class/"tycon" defining instance
1010         -> Bool                 -- True <=> instance decl in this module
1011         -> Bool
1012
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
1017            {-if-} from_here
1018         else
1019            is_exported_tycon
1020            || (is_imported_tycon && from_here) -- V NAUGHTY BY HASKELL RULES
1021
1022     else if is_fun_tycon || is_core_tycon then
1023         -- non-Core class; depends on its export flag
1024         is_exported_class
1025         || (is_imported_class && from_here) -- V NAUGHTY BY HASKELL RULES
1026
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
1032             False
1033         else
1034             is_exported_class || is_exported_tycon
1035   where
1036     tycon = case getUniDataTyCon_maybe ty of
1037               Just (xx,_,_) -> xx
1038               Nothing       -> panic "instanceIsExported:no tycon"
1039
1040     is_core_class = fromPreludeCore clas
1041     is_core_tycon = fromPreludeCore tycon
1042
1043     is_fun_tycon = isFunType ty
1044
1045     is_exported_class = case (getExportFlag clas) of
1046                           NotExported -> False
1047                           _           -> True
1048
1049     is_exported_tycon = case (getExportFlag tycon) of
1050                           NotExported -> False
1051                           _           -> True
1052
1053     is_imported_class = not (isLocallyDefined clas)
1054     is_imported_tycon = not (isLocallyDefined tycon)
1055 \end{code}
1056
1057 \begin{code}
1058 maybePurelyLocalTyCon :: TyCon   -> Maybe [Pretty]
1059 maybePurelyLocalClass :: Class   -> Maybe [Pretty]
1060 maybePurelyLocalType  :: UniType -> Maybe [Pretty]
1061
1062 purely_local tc -- overloaded
1063   = if (isLocallyDefined tc && not (isExported tc))
1064     then Just (ppr PprForUser tc)
1065     else Nothing
1066
1067 --overloaded: merge_maybes :: (a -> Maybe b) -> [a] -> Maybe [b]
1068
1069 merge_maybes f xs
1070   = case (catMaybes (map f xs)) of
1071       [] -> Nothing   -- no hit anywhere along the list
1072       xs -> Just xs
1073
1074 maybePurelyLocalTyCon tycon
1075   = let
1076         mentioned_tycons = fst (getMentionedTyConsAndClassesFromTyCon tycon)
1077         -- will include tycon itself
1078     in
1079     merge_maybes purely_local (bagToList mentioned_tycons)
1080
1081 maybePurelyLocalClass clas
1082   = let
1083         (mentioned_classes, mentioned_tycons)
1084           = getMentionedTyConsAndClassesFromClass clas
1085           -- will include clas itself
1086
1087         tc_stuff = merge_maybes purely_local (bagToList mentioned_tycons)
1088         cl_stuff = merge_maybes purely_local (bagToList mentioned_classes)
1089     in
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)
1095
1096 maybePurelyLocalType ty
1097   = let
1098         (mentioned_classes, mentioned_tycons)
1099           = getMentionedTyConsAndClassesFromUniType ty
1100           -- will include ty itself
1101
1102         tc_stuff = merge_maybes purely_local (bagToList mentioned_tycons)
1103         cl_stuff = merge_maybes purely_local (bagToList mentioned_classes)
1104     in
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)
1110 \end{code}
1111
1112 A gigantic HACK due to Simon (95/05)
1113 \begin{code}
1114 returnsRealWorld :: UniType -> Bool
1115
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
1122
1123 returnsRealWorld (UniData tycon [])   = tycon == realWorldTyCon
1124 returnsRealWorld (UniData tycon tys)  = any returnsRealWorld tys
1125 \end{code}
1126
1127 \begin{code}
1128 #ifdef DPH
1129 isProcessorTy :: UniType -> Bool
1130 isProcessorTy (UniData tycon _) = isProcessorTyCon tycon
1131 isProcessorTy _                 = False
1132 #endif {- Data Parallel Haskell -}
1133 \end{code}
1134
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
1138 composition:
1139 \begin{verbatim}
1140         map (f . g) == (map f) . (map g) etc...
1141 \end{verbatim}
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).
1148 \begin{code}
1149 #ifdef DPH
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 -}
1157 \end{code}
1158
1159 %************************************************************************
1160 %*                                                                      *
1161 \subsection[UniTyFuns-subst]{Substitute in a type}
1162 %*                                                                      *
1163 %************************************************************************
1164
1165 The idea here is to substitute for the TyVars in a type.  Note, not
1166 the TyVarTemplates---that's the job of instantiateTy.
1167   
1168 There is a single general function, and two interfaces.
1169
1170 \subsubsection{Interface 1: substitutions}
1171 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1172
1173 NOTE: This has been moved to @Subst@ (mostly for speed reasons).
1174
1175 \subsubsection{Interface 2: Envs}
1176 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1177
1178 \begin{code}
1179 applyTypeEnvToTy :: TypeEnv -> SigmaType -> SigmaType
1180 applyTypeEnvToTy tenv ty 
1181   = mapOverTyVars v_fn ty
1182   where
1183     v_fn v = case (lookupTyVarEnv tenv v) of
1184                 Just ty -> ty
1185                 Nothing -> UniTyVar v
1186
1187 applyTypeEnvToTauTy :: TypeEnv -> TauType -> TauType
1188 applyTypeEnvToTauTy e ty
1189   = ASSERT(isTauTy ty)
1190     applyTypeEnvToTy e ty
1191
1192 applyTypeEnvToThetaTy tenv theta
1193   = [(clas,
1194       ASSERT(isTauTy ty)
1195       applyTypeEnvToTauTy tenv ty) | (clas, ty) <- theta]
1196 \end{code}
1197
1198 \subsubsection{@mapOverTyVars@: does the real work}
1199 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1200
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.
1204
1205 \begin{code}
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
1214 \end{code}
1215
1216 %************************************************************************
1217 %*                                                                      *
1218 \subsection[UniTyFuns-ppr]{Pretty-printing @UniTypes@}
1219 %*                                                                      *
1220 %************************************************************************
1221
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@?
1227 \begin{code}
1228 pprUniType, pprParendUniType :: PprStyle -> UniType -> Pretty
1229
1230 pprUniType       sty ty = ppr_ty_init sty tOP_PREC   ty
1231 pprParendUniType sty ty = ppr_ty_init sty tYCON_PREC ty
1232
1233 pprMaybeTy :: PprStyle -> Maybe UniType -> Pretty
1234 pprMaybeTy PprDebug Nothing   = ppStr "*"
1235 pprMaybeTy PprDebug (Just ty) = pprParendUniType PprDebug ty
1236
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!!!
1241
1242 getTypeString ty
1243   = let
1244         ppr_t  = ppr_ty PprForUser (\t -> ppStr "*") tOP_PREC (expandTySyns ty)
1245
1246         string = _PK_ (tidy (ppShow 1000 ppr_t))
1247     in
1248     if is_prelude_ty
1249     then [string]
1250     else [mod, string]
1251   where
1252     (is_prelude_ty, mod)
1253       = case getUniDataTyCon_maybe ty of
1254           Nothing -> true_bottom
1255           Just (tycon,_,_) ->
1256             if fromPreludeCore tycon
1257             then true_bottom
1258             else (False, fst (getOrigName tycon))
1259     
1260     true_bottom = (True, panic "getTypeString")
1261
1262     --------------------------------------------------
1263     -- tidy: very ad-hoc
1264     tidy [] = [] -- done
1265
1266     tidy (' ' : more)
1267       = case more of
1268           ' ' : _        -> tidy more
1269           '-' : '>' : xs -> '-' : '>' : tidy (no_leading_sps xs)
1270           other          -> ' ' : tidy more
1271
1272     tidy (',' : more) = ',' : tidy (no_leading_sps more)
1273
1274     tidy (x : xs) = x : tidy xs  -- catch all
1275
1276     no_leading_sps [] = []
1277     no_leading_sps (' ':xs) = no_leading_sps xs
1278     no_leading_sps other = other
1279
1280 typeMaybeString :: Maybe UniType -> [FAST_STRING]
1281 typeMaybeString Nothing  = [SLIT("!")]
1282 typeMaybeString (Just t) = getTypeString t
1283
1284 specMaybeTysSuffix :: [Maybe UniType] -> FAST_STRING
1285 specMaybeTysSuffix ty_maybes
1286   = let
1287         ty_strs  = concat (map typeMaybeString ty_maybes)
1288         dotted_tys = [ _CONS_ '.' str | str <- ty_strs ] 
1289     in
1290     _CONCAT_ dotted_tys
1291 \end{code}
1292
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.
1297
1298 \begin{code}
1299 ppr_ty_init :: PprStyle -> Int -> UniType -> Pretty
1300
1301 ppr_ty_init sty init_prec ty
1302   = let (tyvars, _, _)  = splitType ty
1303         lookup_fn       = mk_lookup_tyvar_fn sty tyvars
1304     in
1305         ppr_ty sty lookup_fn init_prec ty
1306
1307 mk_lookup_tyvar_fn :: PprStyle -> [TyVarTemplate] -> (TyVarTemplate -> Pretty)
1308
1309 mk_lookup_tyvar_fn sty tyvars
1310   = tv_lookup_fn
1311   where
1312     tv_lookup_fn :: TyVarTemplate -> Pretty
1313     tv_lookup_fn tyvar
1314       = let
1315             pp_tyvar_styish = ppr sty tyvar
1316
1317             assocs = [ pp | (tv, pp) <- tvs_n_pprs, tv == tyvar ]
1318
1319             pp_tyvar_canonical
1320               = case assocs of
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...
1325                   x:_ -> x
1326         in
1327         case sty of
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
1334                               x:_ -> x
1335                               _   -> pp_tyvar_styish
1336           debuggish      -> pp_tyvar_styish
1337
1338     tvs_n_pprs = tyvars `zip` tyvar_pretties
1339
1340     tyvar_pretties = letter_pprs {- a..y -} ++ number_pprs {- z0 ... zN -}
1341
1342     letter_pprs = map (\ c -> ppChar c )    ['a' .. 'y']
1343     number_pprs = map (\ n -> ppBeside (ppChar 'z') (ppInt n))
1344                       ([0 .. ] :: [Int])
1345 \end{code}
1346
1347 \begin{code}
1348 ppr_ty :: PprStyle -> (TyVarTemplate -> Pretty) -> Int -> UniType -> Pretty
1349
1350 ppr_ty sty lookup_fn ctxt_prec (UniTyVarTemplate tyvar) = lookup_fn tyvar
1351
1352 ppr_ty sty lookup_fn ctxt_prec (UniTyVar tyvar) = ppr sty tyvar
1353
1354 ppr_ty sty lookup_fn ctxt_prec ty
1355   = case sty of
1356       PprForUser     -> context_onward
1357       PprInterface _ -> context_onward
1358       _              ->
1359         (if null tyvars then id else ppBeside (ppr_forall sty tyvars))
1360         context_onward
1361   where
1362     (tyvars, context, tau_ty) = splitType ty
1363
1364     context_onward =
1365       if (null pretty_context_pieces) then
1366         ppr_tau_ty sty lookup_fn ctxt_prec tau_ty
1367       else
1368         ppCat (pretty_context_pieces
1369               ++ [connector sty, ppr_tau_ty sty lookup_fn ctxt_prec tau_ty]) -- ToDo: dubious
1370
1371     pretty_context_pieces = ppr_context sty context
1372
1373     ppr_forall :: PprStyle -> [TyVarTemplate] -> Pretty
1374
1375     ppr_forall _   []    = ppNil
1376     ppr_forall sty tyvars
1377       = ppBesides [ppPStr SLIT("_forall_ "), ppIntersperse pp'SP{-'-} pp_tyvars,
1378                    ppPStr SLIT(" =>")]
1379       where
1380         pp_tyvars = map lookup_fn tyvars
1381
1382     ppr_context :: PprStyle -> [(Class, UniType)] -> [Pretty]
1383
1384     ppr_context _   []              = []
1385     ppr_context sty context@(c:cs)
1386       = case sty of
1387           PprForUser     -> userish
1388           PprInterface _ -> userish
1389           _              -> hackerish
1390       where
1391         userish 
1392           = [if (context `lengthExceeds` (1::Int)) then
1393                 ppBesides [ ppLparen,
1394                     ppIntersperse pp'SP{-'-} (map (ppr_kappa_tau PprForUser) context),
1395                     ppRparen]
1396              else
1397                 ppr_kappa_tau PprForUser (head context)
1398             ]
1399         hackerish
1400           = (ppr_kappa_tau sty c) : (map ( pin_on_arrow . (ppr_kappa_tau sty) ) cs)
1401
1402     connector PprForUser       = ppPStr SLIT("=>")
1403     connector (PprInterface _) = ppPStr SLIT("=>")
1404     connector other_sty        = ppPStr SLIT("->")
1405
1406     ppr_kappa_tau :: PprStyle -> (Class, UniType) -> Pretty
1407
1408     ppr_kappa_tau sty (clas, ty)
1409       = let
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 "}}"]
1413         in
1414         case sty of
1415           PprForUser     -> user_ish
1416           PprInterface _ -> user_ish
1417           _              -> hack_ish
1418
1419     pin_on_arrow p = ppBeside (ppPStr SLIT("-> ")) p
1420 \end{code}
1421
1422 @ppr_tau_ty@ takes an @Int@ that is the precedence of the context.
1423 The precedence levels are:
1424 \begin{description}
1425 \item[0:] What we start with.
1426 \item[1:] Function application (@UniFuns@).
1427 \item[2:] Type constructors.
1428 \end{description}
1429
1430 A non-exported help function that really does the printing:
1431 \begin{code}
1432 tOP_PREC    = (0 :: Int)
1433 fUN_PREC    = (1 :: Int)
1434 tYCON_PREC  = (2 :: Int)
1435
1436 ppr_tau_ty :: PprStyle -> (TyVarTemplate -> Pretty) -> Int -> UniType -> Pretty
1437
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]
1441
1442 ppr_tau_ty sty lookup_fn ctxt_prec (UniSyn _ _ expansion)
1443   | case sty of { PprForUser -> False; _ -> True }
1444  = ppr_tau_ty sty lookup_fn ctxt_prec expansion -- always expand types in an interface
1445
1446 -- .....................
1447
1448 ppr_tau_ty sty lookup_fn ctxt_prec (UniTyVarTemplate tyvar) = lookup_fn tyvar
1449
1450 ppr_tau_ty sty lookup_fn ctxt_prec (UniTyVar tyvar) = ppr sty tyvar
1451
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...
1455
1456     = let p1 = ppr_tau_ty sty lookup_fn fUN_PREC ty1
1457           p2 = ppr_tau_ty sty lookup_fn tOP_PREC ty2
1458       in
1459       if ctxt_prec < fUN_PREC then -- no parens needed
1460          ppCat [p1, ppBeside (ppPStr SLIT("-> ")) p2]
1461       else
1462          ppCat [ppBeside ppLparen p1, ppBesides [ppPStr SLIT("-> "), p2, ppRparen]]
1463
1464 -- Special printing for list and tuple types.
1465 -- we can re-set the precedence to tOP_PREC
1466
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]
1470
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]
1473 #ifdef DPH
1474     else if (tycon == podTyCon) then
1475        pprPodshort sty lookup_fn tOP_PREC (head tys)
1476
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)),
1481                   ppSemi ,
1482                   ppr_tau_ty sty lookup_fn tOP_PREC (last tys),
1483                   ppStr "|)"]
1484 #endif {- Data Parallel Haskell -}
1485     else
1486         ppr_tycon_and_tys sty lookup_fn ctxt_prec tycon tys
1487
1488 ppr_tau_ty sty lookup_fn ctxt_prec (UniSyn tycon tys expansion)
1489  = ppBeside
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 "-}"]))
1492
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]
1497    else
1498         ppBesides [ppStr "(", ppr sty clas, ppSP, ppr_ty sty lookup_fn tYCON_PREC ty, ppStr ")"]
1499
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 "}}"]
1502
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]
1505
1506 -- code shared for UniDatas and UniSyns
1507 ppr_tycon_and_tys :: PprStyle -> (TyVarTemplate -> Pretty) -> Int -> TyCon -> [UniType] -> Pretty
1508
1509 ppr_tycon_and_tys sty lookup_fn ctxt_prec tycon tys
1510   = let pp_tycon = ppr (case sty of PprInterface _ -> PprForUser; _ -> sty) tycon
1511     in
1512     if null tys then
1513         pp_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) ]
1516     else
1517         ppBesides [ ppLparen, pp_tycon, ppSP,
1518                ppIntersperse ppSP (map (ppr_tau_ty sty lookup_fn tYCON_PREC) tys), ppRparen ]
1519 \end{code}
1520
1521 \begin{code}
1522 #ifdef DPH
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)), 
1529                   ppSemi ,
1530                   ppr_tau_ty sty lookup_fn tOP_PREC (last tys), 
1531                   ppStr ">>"]
1532 pprPodshort sty lookup_fn ctxt_prec ty
1533     =  ppBesides [ppStr "<<",
1534                   ppr_tau_ty sty lookup_fn tOP_PREC ty,
1535                   ppStr ">>"]
1536 #endif {- Data Parallel Haskell -}
1537 \end{code}
1538
1539 \begin{code}
1540 showTyCon :: PprStyle -> TyCon -> String
1541 showTyCon sty tycon
1542   = ppShow 80 (pprTyCon sty tycon [])
1543
1544 pprTyCon :: PprStyle -> TyCon -> [[Maybe UniType]] -> Pretty
1545 -- with "PprInterface", we print out for interfaces
1546
1547 pprTyCon sty@(PprInterface sw_chkr) (SynonymTyCon k n a vs exp unabstract) specs
1548   = ASSERT (null specs)
1549     let
1550         lookup_fn   = mk_lookup_tyvar_fn sty vs
1551         pp_tyvars   = map lookup_fn vs
1552         pp_abstract = if unabstract || (sw_chkr OmitInterfacePragmas)
1553                       then ppNil
1554                       else ppStr "{-# GHC_PRAGMA _ABSTRACT_ #-}"
1555     in
1556     ppCat [ppPStr SLIT("type"), ppr sty n, ppIntersperse ppSP pp_tyvars,
1557            ppEquals, ppr_ty sty lookup_fn tOP_PREC exp, pp_abstract]
1558
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,
1562                    ppr sty n,
1563                    ppIntersperse ppSP (map lookup_fn vs)])
1564            4
1565            (ppCat [pp_unabstract_condecls,
1566                    pp_pragma])
1567            -- NB: we do not print deriving info in interfaces
1568   where
1569     lookup_fn = mk_lookup_tyvar_fn sty vs
1570
1571     yes_we_print_condecls
1572       = unabstract
1573         && not (null cons)      -- we know what they are
1574         && (case (getExportFlag n) of
1575               ExportAbs -> False
1576               other     -> True)
1577
1578     yes_we_print_pragma_condecls
1579       = not yes_we_print_condecls
1580         && not (sw_chkr OmitInterfacePragmas)
1581         && not (null cons)
1582         && not (maybeToBool (maybePurelyLocalTyCon this_tycon))
1583         {- && not (any (dataConMentionsNonPreludeTyCon this_tycon) cons) -}
1584
1585     yes_we_print_pragma_specs
1586       = not (null specs)
1587
1588     pp_unabstract_condecls
1589       = if yes_we_print_condecls
1590         then ppCat [ppSP, ppEquals, pp_condecls]
1591         else ppNil
1592             
1593     pp_pragma_condecls
1594       = if yes_we_print_pragma_condecls
1595         then pp_condecls
1596         else ppNil
1597
1598     pp_pragma_specs
1599       = if yes_we_print_pragma_specs
1600         then pp_specs
1601         else ppNil
1602
1603     pp_pragma
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 "#-}"]
1606         else ppNil
1607
1608     pp_condecls
1609       = let
1610             (c:cs) = cons
1611         in
1612         ppCat ((ppr_con c) : (map ppr_next_con cs))
1613       where
1614         ppr_con con
1615           = let
1616                 (_, _, con_arg_tys, _) = getDataConSig con
1617             in
1618             ppCat [pprNonOp PprForUser con, -- the data con's name...
1619                    ppIntersperse ppSP (map (ppr_ty sty lookup_fn tYCON_PREC) con_arg_tys)]
1620
1621         ppr_next_con con = ppCat [ppChar '|', ppr_con con]
1622
1623     pp_specs
1624       = ppBesides [ppStr "_SPECIALISE_ ", pp_the_list [
1625           ppCat [ppLbrack, ppInterleave ppComma (map pp_maybe ty_maybes), ppRbrack]
1626           | ty_maybes <- specs ]]
1627          
1628     pp_the_list [p]    = p
1629     pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
1630
1631     pp_maybe Nothing   = pp_NONE
1632     pp_maybe (Just ty) = pprParendUniType sty ty
1633
1634     pp_NONE = ppStr "_N_"
1635
1636 pprTyCon (PprInterface _) (TupleTyCon a) specs
1637   = ASSERT (null specs)
1638     ppCat [ ppStr "{- Tuple", ppInt a, ppStr "-}" ]
1639
1640 pprTyCon (PprInterface _) (PrimTyCon k n a kind_fn) specs
1641   = ASSERT (null specs)
1642     ppCat [ ppStr "{- data", ppr PprForUser n, ppStr " *built-in* -}" ]
1643
1644 #ifdef DPH
1645 pprTyCon (PprInterface _) (ProcessorTyCon a) specs
1646       = ppCat [ ppStr "{- Processor", ppInt a, ppStr "-}" ]
1647 #endif {- Data Parallel Haskell -}
1648
1649 -- regular printing (ToDo: probably update)
1650
1651 pprTyCon sty (SynonymTyCon k n a vs exp unabstract) [{-no specs-}]
1652   = ppBeside (ppr sty n)
1653              (ifPprShowAll sty
1654                 (ppCat [ ppStr " {-", ppInt a, interpp'SP sty vs,
1655                          pprParendUniType sty exp,
1656                          if unabstract then ppNil else ppStr "_ABSTRACT_", ppStr "-}"]))
1657
1658 pprTyCon sty tycon@(DataTyCon k n a vs cons derivings unabstract) [{-no specs-}]
1659   = case sty of
1660       PprDebug   -> pp_tycon_and_uniq
1661       PprShowAll -> pp_tycon_and_uniq
1662       _          -> pp_tycon
1663   where
1664     pp_tycon_and_uniq = ppBesides [pp_tycon, ppStr "{-", pprUnique k, ppStr "-}"]
1665     pp_tycon
1666       = let
1667             pp_name = ppr sty n
1668         in
1669         if codeStyle sty || tycon /= listTyCon
1670         then pp_name
1671         else ppBesides [ppLbrack, interpp'SP sty vs, ppRbrack]
1672
1673 {-ppBeside-} -- pp_tycon
1674 {- SOMETIMES:
1675              (ifPprShowAll sty
1676                 (ppCat [ ppStr " {-", ppInt a, interppSP sty vs,
1677                             interpp'SP PprForUser cons,
1678                             ppStr "deriving (", interpp'SP PprForUser derivings,
1679                             ppStr ")-}" ]))
1680 -}
1681
1682 pprTyCon sty (TupleTyCon a) [{-no specs-}]
1683   = ppBeside (ppPStr SLIT("Tuple")) (ppInt a)
1684
1685 pprTyCon sty (PrimTyCon k n a kind_fn) [{-no specs-}]
1686   = ppr sty n
1687
1688 pprTyCon sty (SpecTyCon tc ty_maybes) []
1689   = ppBeside (pprTyCon sty tc []) 
1690              (if (codeStyle sty)
1691               then identToC tys_stuff
1692               else ppPStr   tys_stuff)
1693   where
1694     tys_stuff = specMaybeTysSuffix ty_maybes
1695
1696 #ifdef DPH
1697 pprTyCon sty (ProcessorTyCon a) [] = ppBeside (ppStr "Processor") (ppInt a)
1698
1699 pprTyCon sty (PodizedPodTyCon dim tc) []
1700   = ppBesides [ ppr sty tc, ppStr "Podized", ppr sty dim]
1701 #endif {- Data Parallel Haskell -}
1702 \end{code}
1703
1704 \begin{code}
1705 pprIfaceClass :: (GlobalSwitch -> Bool) -> (Id -> Id) -> IdEnv UnfoldingDetails -> Class -> Pretty
1706
1707 pprIfaceClass sw_chker better_id_fn inline_env
1708         (MkClass k n tyvar super_classes sdsels ops sels defms insts links)
1709   = let
1710         sdsel_infos = map (getIdInfo . better_id_fn) sdsels
1711     in
1712     ppAboves [ ppCat [ppPStr SLIT("class"), ppr_theta tyvar super_classes,
1713                       ppr sty n, lookup_fn tyvar,
1714                       if null sdsel_infos
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.
1720                       then ppNil
1721                       else pp_sdsel_pragmas (sdsels `zip` sdsel_infos),
1722                       if (null ops)
1723                       then ppNil
1724                       else ppPStr SLIT("where")],
1725                ppNest 8  (ppAboves 
1726                  [ ppr_op op (better_id_fn sel) (better_id_fn defm)
1727                  | (op,sel,defm) <- zip3 ops sels defms]) ]
1728   where
1729     sty = PprInterface sw_chker
1730     omit_iface_pragmas = sw_chker OmitInterfacePragmas
1731
1732     lookup_fn = mk_lookup_tyvar_fn sty [tyvar]
1733
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), 
1739                    ppStr ") =>"]
1740       where
1741         ppr_assert (MkClass _ n _ _ _ _ _ _ _ _) = ppCat [ppr sty n, lookup_fn tv]
1742
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 ],
1748                ppStr "#-}"]
1749
1750     ppr_op op opsel_id defm_id
1751       = let
1752             stuff = ppBeside (ppChar '\t') (ppr_class_op sty [tyvar] op)
1753         in
1754         if omit_iface_pragmas
1755         then stuff
1756         else ppAbove stuff
1757                 (ppCat [ppStr "\t {-# GHC_PRAGMA", ppAbove pp_opsel pp_defm, ppStr "#-}"])
1758       where
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)]
1761 \end{code}
1762
1763 \begin{code}
1764 pprClassOp :: PprStyle -> ClassOp -> Pretty
1765
1766 pprClassOp sty op = ppr_class_op sty [] op
1767
1768 ppr_class_op sty tyvars (MkClassOp op_name i ty)
1769   = case sty of
1770       PprForC _       -> pp_C
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]
1774       _               -> pp_user
1775   where
1776     (local_tyvars,_,_)  = splitType ty
1777     lookup_fn           = mk_lookup_tyvar_fn sty (tyvars ++ local_tyvars)
1778
1779     pp_C                = ppPStr op_name
1780     pp_user             = if isAvarop op_name
1781                           then ppBesides [ppLparen, pp_C, ppRparen]
1782                           else pp_C
1783 \end{code}
1784
1785 %************************************************************************
1786 %*                                                                      *
1787 \subsection[UniTyFuns-matching]{@matchTy@}
1788 %*                                                                      *
1789 %************************************************************************
1790
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.
1795
1796 \begin{code}
1797 matchTy :: UniType                              -- Template
1798         -> UniType                              -- Proposed instance of template
1799         -> Maybe [(TyVarTemplate,UniType)]      -- Matching substitution
1800
1801 matchTy (UniTyVarTemplate v) ty = Just [(v,ty)]
1802 matchTy (UniTyVar _) ty = panic "matchTy: unexpected TyVar (need TyVarTemplates)"
1803
1804 matchTy (UniFun fun1 arg1) (UniFun fun2 arg2) = matchTys [fun1, arg1] [fun2, arg2]
1805
1806 matchTy ty1@(UniData con1 args1) ty2@(UniData con2 args2) | con1 == con2
1807   = matchTys args1 args2 -- Same constructors, just match the arguments
1808
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)
1813
1814 -- If just one or the other is a "visible" synonym (they all are at
1815 -- the moment...), just expand it.
1816
1817 matchTy (UniSyn con1 args1 ty1) ty2
1818   | isVisibleSynTyCon con1
1819   = matchTy ty1 ty2
1820 matchTy ty1 (UniSyn con2 args2 ty2)
1821   | isVisibleSynTyCon con2
1822   = matchTy ty1 ty2
1823
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
1831     else
1832         -- Never mind.  Just expand them and try again
1833         matchTy ty1 ty2
1834
1835 -- Catch-all fails
1836 matchTy templ ty = Nothing
1837 \end{code}
1838
1839 @matchTys@ matches corresponding elements of a list of templates and
1840 types.
1841
1842 \begin{code}
1843 matchTys :: [UniType] -> [UniType] -> Maybe [(TyVarTemplate, UniType)]
1844
1845 matchTys [] [] = Just []
1846 matchTys (templ:templs) (ty:tys)
1847   = case (matchTy templ ty) of
1848       Nothing    -> Nothing
1849       Just subst -> case (matchTys templs tys) of
1850                       Nothing     -> Nothing
1851                       Just subst2 -> Just (subst ++ subst2)
1852 #ifdef DEBUG
1853 matchTys [] tys
1854   = pprPanic "matchTys: out of templates!; tys:" (ppr PprDebug tys)
1855 matchTys tmpls []
1856   = pprPanic "matchTys: out of types!; templates:" (ppr PprDebug tmpls)
1857 #endif
1858 \end{code}
1859
1860 %************************************************************************
1861 %*                                                                      *
1862 \subsection[UniTyFuns-misc]{Misc @UniType@ functions}
1863 %*                                                                      *
1864 %************************************************************************
1865
1866 \begin{code}
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 }
1873
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
1878 \end{code}
1879
1880 Identity function if the type is a @TauType@; panics otherwise.
1881 \begin{code}
1882 #ifdef DEBUG
1883 verifyTauTy :: String -> TauType -> TauType
1884
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
1889
1890 #endif {- DEBUG -}
1891 \end{code}
1892
1893 \begin{code}
1894 showTypeCategory :: UniType -> Char
1895     {-
1896         {C,I,F,D}   char, int, float, double
1897         T           tuple
1898         S           other single-constructor type
1899         {c,i,f,d}   unboxed ditto
1900         t           *unpacked* tuple
1901         s           *unpacked" single-cons...
1902
1903         v           void#
1904         a           primitive array
1905
1906         E           enumeration type
1907         +           dictionary, unless it's a ...
1908         L           List
1909         >           function
1910         M           other (multi-constructor) data-con type
1911         .           other type
1912         -           reserved for others to mark as "uninteresting"
1913     -}
1914 showTypeCategory ty
1915   = if isDictTy ty
1916     then '+'
1917     else
1918       case getUniDataTyCon_maybe ty of
1919         Nothing -> if isFunType ty
1920                    then '>'
1921                    else '.'
1922
1923         Just (tycon,_,_) ->
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...
1940 \end{code}