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}