ghc/compiler/types/Type.lhs

   1 \begin{code}
   2 module Type (
   3         GenType(..), TyNote(..),                -- Representation visible to friends
   4         Type, GenKind, Kind,
   5         TyVarSubst, GenTyVarSubst,
   6
   7         funTyCon, boxedKindCon, unboxedKindCon, openKindCon,
   8
   9         boxedTypeKind, unboxedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds,
  10         hasMoreBoxityInfo, superKind,
  11
  12         mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy,
  13
  14         mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe,
  15
  16         mkFunTy, mkFunTys, splitFunTy_maybe, splitFunTys, funResultTy,
  17
  18         mkTyConApp, mkTyConTy, splitTyConApp_maybe,
  19         splitAlgTyConApp_maybe, splitAlgTyConApp,
  20         mkDictTy, splitDictTy_maybe, isDictTy,
  21
  22         mkSynTy, isSynTy,
  23
  24         mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
  25         applyTy, applyTys, isForAllTy,
  26         mkPiType,
  27
  28         TauType, RhoType, SigmaType, ThetaType,
  29         isTauTy,
  30         mkRhoTy, splitRhoTy,
  31         mkSigmaTy, splitSigmaTy,
  32
  33         isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType,
  34         typePrimRep,
  35
  36         tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind,
  37         addFreeTyVars,
  38
  39         substTy, fullSubstTy, substTyVar,
  40         substFlexiTy, substFlexiTheta,
  41
  42         showTypeCategory
  43     ) where
  44
  45 #include "HsVersions.h"
  46
  47 import {-# SOURCE #-}   DataCon( DataCon )
  48
  49 -- friends:
  50 import Var      ( Id, TyVar, GenTyVar, IdOrTyVar,
  51                   removeTyVarFlexi,
  52                   tyVarKind, isId, idType
  53                 )
  54 import VarEnv
  55 import VarSet
  56
  57 import Name     ( NamedThing(..), Provenance(..), ExportFlag(..),
  58                   mkWiredInTyConName, mkGlobalName, varOcc
  59                 )
  60 import NameSet
  61 import Class    ( classTyCon, Class )
  62 import TyCon    ( TyCon, Boxity(..),
  63                   mkFunTyCon, mkKindCon, superKindCon,
  64                   matchesTyCon, isUnboxedTupleTyCon, isUnLiftedTyCon,
  65                   isFunTyCon, isEnumerationTyCon,
  66                   isTupleTyCon, maybeTyConSingleCon,
  67                   isPrimTyCon, isAlgTyCon, isSynTyCon, tyConArity,
  68                   tyConKind, tyConDataCons, getSynTyConDefn,
  69                   tyConPrimRep, tyConClass_maybe
  70                 )
  71
  72 -- others
  73 import BasicTypes       ( Unused )
  74 import SrcLoc           ( mkBuiltinSrcLoc )
  75 import PrelMods         ( pREL_GHC )
  76 import Maybes           ( maybeToBool )
  77 import PrimRep          ( PrimRep(..), isFollowableRep )
  78 import Unique           -- quite a few *Keys
  79 import Util             ( thenCmp )
  80 import Outputable
  81
  82 \end{code}
  83
  84 %************************************************************************
  85 %*                                                                      *
  86 \subsection{Type Classifications}
  87 %*                                                                      *
  88 %************************************************************************
  89
  90 A type is
  91
  92         *unboxed*       iff its representation is other than a pointer
  93                         Unboxed types cannot instantiate a type variable
  94                         Unboxed types are always unlifted.
  95
  96         *lifted*        A type is lifted iff it has bottom as an element.
  97                         Closures always have lifted types:  i.e. any
  98                         let-bound identifier in Core must have a lifted
  99                         type.  Operationally, a lifted object is one that
 100                         can be entered.
 101                         (NOTE: previously "pointed").
 102
 103         *algebraic*     A type with one or more constructors.  An algebraic
 104                         type is one that can be deconstructed with a case
 105                         expression.  *NOT* the same as lifted types,
 106                         because we also include unboxed tuples in this
 107                         classification.
 108
 109         *primitive*     iff it is a built-in type that can't be expressed
 110                         in Haskell.
 111
 112 Currently, all primitive types are unlifted, but that's not necessarily
 113 the case.  (E.g. Int could be primitive.)
 114
 115 Some primitive types are unboxed, such as Int#, whereas some are boxed
 116 but unlifted (such as ByteArray#).  The only primitive types that we
 117 classify as algebraic are the unboxed tuples.
 118
 119 examples of type classifications:
 120
 121 Type            primitive       boxed           lifted          algebraic
 122 -----------------------------------------------------------------------------
 123 Int#,           Yes             No              No              No
 124 ByteArray#      Yes             Yes             No              No
 125 (# a, b #)      Yes             No              No              Yes
 126 (  a, b  )      No              Yes             Yes             Yes
 127 [a]             No              Yes             Yes             Yes
 128
 129 %************************************************************************
 130 %*                                                                      *
 131 \subsection{The data type}
 132 %*                                                                      *
 133 %************************************************************************
 134
 135
 136 \begin{code}
 137 type Type  = GenType Unused     -- Used after typechecker
 138
 139 type GenKind flexi = GenType flexi
 140 type Kind  = Type
 141
 142 type TyVarSubst          = TyVarEnv Type
 143 type GenTyVarSubst flexi = TyVarEnv (GenType flexi)
 144
 145 data GenType flexi                      -- Parameterised over the "flexi" part of a type variable
 146   = TyVarTy (GenTyVar flexi)
 147
 148   | AppTy
 149         (GenType flexi)         -- Function is *not* a TyConApp
 150         (GenType flexi)
 151
 152   | TyConApp                    -- Application of a TyCon
 153         TyCon                   -- *Invariant* saturated appliations of FunTyCon and
 154                                 --      synonyms have their own constructors, below.
 155         [GenType flexi]         -- Might not be saturated.
 156
 157   | FunTy                       -- Special case of TyConApp: TyConApp FunTyCon [t1,t2]
 158         (GenType flexi)
 159         (GenType flexi)
 160
 161   | NoteTy                      -- Saturated application of a type synonym
 162         (TyNote flexi)
 163         (GenType flexi)         -- The expanded version
 164
 165   | ForAllTy
 166         (GenTyVar flexi)
 167         (GenType flexi)         -- TypeKind
 168
 169 data TyNote flexi
 170   = SynNote (GenType flexi)     -- The unexpanded version of the type synonym; always a TyConApp
 171   | FTVNote (GenTyVarSet flexi) -- The free type variables of the noted expression
 172 \end{code}
 173
 174
 175 %************************************************************************
 176 %*                                                                      *
 177 \subsection{Wired-in type constructors
 178 %*                                                                      *
 179 %************************************************************************
 180
 181 We define a few wired-in type constructors here to avoid module knots
 182
 183 \begin{code}
 184 funTyConName = mkWiredInTyConName funTyConKey pREL_GHC SLIT("->") funTyCon
 185 funTyCon = mkFunTyCon funTyConName (mkArrowKinds [boxedTypeKind, boxedTypeKind] boxedTypeKind)
 186 \end{code}
 187
 188 \begin{code}
 189 mk_kind_name key str = mkGlobalName key pREL_GHC (varOcc str)
 190                                   (LocalDef mkBuiltinSrcLoc NotExported)
 191         -- mk_kind_name is a bit of a hack
 192         -- The LocalDef means that we print the name without
 193         -- a qualifier, which is what we want for these kinds.
 194
 195 boxedKindConName = mk_kind_name boxedKindConKey SLIT("*")
 196 boxedKindCon     = mkKindCon boxedKindConName superKind Boxed
 197
 198 unboxedKindConName = mk_kind_name unboxedKindConKey SLIT("*#")
 199 unboxedKindCon     = mkKindCon unboxedKindConName superKind Unboxed
 200
 201 openKindConName = mk_kind_name openKindConKey SLIT("*?")
 202 openKindCon     = mkKindCon openKindConName superKind Open
 203 \end{code}
 204
 205
 206 %************************************************************************
 207 %*                                                                      *
 208 \subsection{Kinds}
 209 %*                                                                      *
 210 %************************************************************************
 211
 212 \begin{code}
 213 superKind :: GenKind flexi      -- Box, the type of all kinds
 214 superKind = TyConApp superKindCon []
 215
 216 boxedTypeKind, unboxedTypeKind, openTypeKind :: GenKind flexi
 217 boxedTypeKind   = TyConApp boxedKindCon   []
 218 unboxedTypeKind = TyConApp unboxedKindCon []
 219 openTypeKind    = TyConApp openKindCon    []
 220
 221 mkArrowKind :: GenKind flexi -> GenKind flexi -> GenKind flexi
 222 mkArrowKind = FunTy
 223
 224 mkArrowKinds :: [GenKind flexi] -> GenKind flexi -> GenKind flexi
 225 mkArrowKinds arg_kinds result_kind = foldr FunTy result_kind arg_kinds
 226 \end{code}
 227
 228 \begin{code}
 229 hasMoreBoxityInfo :: GenKind flexi -> GenKind flexi -> Bool
 230
 231 (NoteTy _ k1) `hasMoreBoxityInfo` k2 = k1 `hasMoreBoxityInfo` k2
 232 k1 `hasMoreBoxityInfo` (NoteTy _ k2) = k1 `hasMoreBoxityInfo` k2
 233
 234 (TyConApp kc1 ts1) `hasMoreBoxityInfo` (TyConApp kc2 ts2)
 235   = ASSERT( null ts1 && null ts2 )
 236     kc2 `matchesTyCon` kc1      -- NB the reversal of arguments
 237
 238 kind1@(FunTy _ _) `hasMoreBoxityInfo` kind2@(FunTy _ _)
 239   = ASSERT( kind1 == kind2 )
 240     True
 241         -- The two kinds can be arrow kinds; for example when unifying
 242         -- (m1 Int) and (m2 Int) we end up unifying m1 and m2, which should
 243         -- have the same kind.
 244
 245 -- Other cases are impossible
 246 \end{code}
 247
 248
 249 %************************************************************************
 250 %*                                                                      *
 251 \subsection{Constructor-specific functions}
 252 %*                                                                      *
 253 %************************************************************************
 254
 255
 256 ---------------------------------------------------------------------
 257                                 TyVarTy
 258                                 ~~~~~~~
 259 \begin{code}
 260 mkTyVarTy  :: GenTyVar flexi   -> GenType flexi
 261 mkTyVarTy  = TyVarTy
 262
 263 mkTyVarTys :: [GenTyVar flexi] -> [GenType flexi]
 264 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
 265
 266 getTyVar :: String -> GenType flexi -> GenTyVar flexi
 267 getTyVar msg (TyVarTy tv) = tv
 268 getTyVar msg (NoteTy _ t) = getTyVar msg t
 269 getTyVar msg other        = panic ("getTyVar: " ++ msg)
 270
 271 getTyVar_maybe :: GenType flexi -> Maybe (GenTyVar flexi)
 272 getTyVar_maybe (TyVarTy tv) = Just tv
 273 getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t
 274 getTyVar_maybe other        = Nothing
 275
 276 isTyVarTy :: GenType flexi -> Bool
 277 isTyVarTy (TyVarTy tv)  = True
 278 isTyVarTy (NoteTy _ ty) = isTyVarTy ty
 279 isTyVarTy other         = False
 280 \end{code}
 281
 282
 283 ---------------------------------------------------------------------
 284                                 AppTy
 285                                 ~~~~~
 286 We need to be pretty careful with AppTy to make sure we obey the
 287 invariant that a TyConApp is always visibly so.  mkAppTy maintains the
 288 invariant: use it.
 289
 290 \begin{code}
 291 mkAppTy orig_ty1 orig_ty2 = mk_app orig_ty1
 292   where
 293     mk_app (NoteTy _ ty1)    = mk_app ty1
 294     mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
 295     mk_app ty1               = AppTy orig_ty1 orig_ty2
 296
 297 mkAppTys :: GenType flexi -> [GenType flexi] -> GenType flexi
 298 mkAppTys orig_ty1 []        = orig_ty1
 299         -- This check for an empty list of type arguments
 300         -- avoids the needless of a type synonym constructor.
 301         -- For example: mkAppTys Rational []
 302         --   returns to (Ratio Integer), which has needlessly lost
 303         --   the Rational part.
 304 mkAppTys orig_ty1 orig_tys2 = mk_app orig_ty1
 305   where
 306     mk_app (NoteTy _ ty1)    = mk_app ty1
 307     mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
 308     mk_app ty1               = foldl AppTy orig_ty1 orig_tys2
 309
 310 splitAppTy_maybe :: GenType flexi -> Maybe (GenType flexi, GenType flexi)
 311 splitAppTy_maybe (FunTy ty1 ty2)   = Just (TyConApp funTyCon [ty1], ty2)
 312 splitAppTy_maybe (AppTy ty1 ty2)   = Just (ty1, ty2)
 313 splitAppTy_maybe (NoteTy _ ty)     = splitAppTy_maybe ty
 314 splitAppTy_maybe (TyConApp tc [])  = Nothing
 315 splitAppTy_maybe (TyConApp tc tys) = split tys []
 316                             where
 317                                split [ty2]    acc = Just (TyConApp tc (reverse acc), ty2)
 318                                split (ty:tys) acc = split tys (ty:acc)
 319
 320 splitAppTy_maybe other            = Nothing
 321
 322 splitAppTy :: GenType flexi -> (GenType flexi, GenType flexi)
 323 splitAppTy ty = case splitAppTy_maybe ty of
 324                         Just pr -> pr
 325                         Nothing -> panic "splitAppTy"
 326
 327 splitAppTys :: GenType flexi -> (GenType flexi, [GenType flexi])
 328 splitAppTys ty = split ty ty []
 329   where
 330     split orig_ty (AppTy ty arg)        args = split ty ty (arg:args)
 331     split orig_ty (NoteTy _ ty)         args = split orig_ty ty args
 332     split orig_ty (FunTy ty1 ty2)       args = ASSERT( null args )
 333                                                (TyConApp funTyCon [], [ty1,ty2])
 334     split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
 335     split orig_ty ty                    args = (orig_ty, args)
 336 \end{code}
 337
 338
 339 ---------------------------------------------------------------------
 340                                 FunTy
 341                                 ~~~~~
 342
 343 \begin{code}
 344 mkFunTy :: GenType flexi -> GenType flexi -> GenType flexi
 345 mkFunTy arg res = FunTy arg res
 346
 347 mkFunTys :: [GenType flexi] -> GenType flexi -> GenType flexi
 348 mkFunTys tys ty = foldr FunTy ty tys
 349
 350 splitFunTy_maybe :: GenType flexi -> Maybe (GenType flexi, GenType flexi)
 351 splitFunTy_maybe (FunTy arg res) = Just (arg, res)
 352 splitFunTy_maybe (NoteTy _ ty)   = splitFunTy_maybe ty
 353 splitFunTy_maybe other           = Nothing
 354
 355
 356 splitFunTys :: GenType flexi -> ([GenType flexi], GenType flexi)
 357 splitFunTys ty = split [] ty ty
 358   where
 359     split args orig_ty (FunTy arg res) = split (arg:args) res res
 360     split args orig_ty (NoteTy _ ty)   = split args orig_ty ty
 361     split args orig_ty ty              = (reverse args, orig_ty)
 362
 363 funResultTy :: GenType flexi -> GenType flexi
 364 funResultTy (FunTy arg res) = res
 365 funResultTy (NoteTy _ ty)   = funResultTy ty
 366 funResultTy ty              = ty
 367 \end{code}
 368
 369
 370
 371 ---------------------------------------------------------------------
 372                                 TyConApp
 373                                 ~~~~~~~~
 374
 375 \begin{code}
 376 mkTyConApp :: TyCon -> [GenType flexi] -> GenType flexi
 377 mkTyConApp tycon tys
 378   | isFunTyCon tycon && length tys == 2
 379   = case tys of
 380         (ty1:ty2:_) -> FunTy ty1 ty2
 381
 382   | otherwise
 383   = ASSERT(not (isSynTyCon tycon))
 384     TyConApp tycon tys
 385
 386 mkTyConTy :: TyCon -> GenType flexi
 387 mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) )
 388                   TyConApp tycon []
 389
 390 -- splitTyConApp "looks through" synonyms, because they don't
 391 -- mean a distinct type, but all other type-constructor applications
 392 -- including functions are returned as Just ..
 393
 394 splitTyConApp_maybe :: GenType flexi -> Maybe (TyCon, [GenType flexi])
 395 splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
 396 splitTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [arg,res])
 397 splitTyConApp_maybe (NoteTy _ ty)     = splitTyConApp_maybe ty
 398 splitTyConApp_maybe other             = Nothing
 399
 400 -- splitAlgTyConApp_maybe looks for
 401 --      *saturated* applications of *algebraic* data types
 402 -- "Algebraic" => newtype, data type, or dictionary (not function types)
 403 -- We return the constructors too.
 404
 405 splitAlgTyConApp_maybe :: GenType flexi -> Maybe (TyCon, [GenType flexi], [DataCon])
 406 splitAlgTyConApp_maybe (TyConApp tc tys)
 407   | isAlgTyCon tc &&
 408     tyConArity tc == length tys      = Just (tc, tys, tyConDataCons tc)
 409 splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty
 410 splitAlgTyConApp_maybe other         = Nothing
 411
 412 splitAlgTyConApp :: GenType flexi -> (TyCon, [GenType flexi], [DataCon])
 413         -- Here the "algebraic" property is an *assertion*
 414 splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == length tys )
 415                                      (tc, tys, tyConDataCons tc)
 416 splitAlgTyConApp (NoteTy _ ty)     = splitAlgTyConApp ty
 417 \end{code}
 418
 419 "Dictionary" types are just ordinary data types, but you can
 420 tell from the type constructor whether it's a dictionary or not.
 421
 422 \begin{code}
 423 mkDictTy :: Class -> [GenType flexi] -> GenType flexi
 424 mkDictTy clas tys = TyConApp (classTyCon clas) tys
 425
 426 splitDictTy_maybe :: GenType flexi -> Maybe (Class, [GenType flexi])
 427 splitDictTy_maybe (TyConApp tc tys)
 428   |  maybeToBool maybe_class
 429   && tyConArity tc == length tys = Just (clas, tys)
 430   where
 431      maybe_class = tyConClass_maybe tc
 432      Just clas   = maybe_class
 433
 434 splitDictTy_maybe (NoteTy _ ty) = splitDictTy_maybe ty
 435 splitDictTy_maybe other         = Nothing
 436
 437 isDictTy :: GenType flexi -> Bool
 438         -- This version is slightly more efficient than (maybeToBool . splitDictTy)
 439 isDictTy (TyConApp tc tys)
 440   |  maybeToBool (tyConClass_maybe tc)
 441   && tyConArity tc == length tys
 442   = True
 443 isDictTy (NoteTy _ ty)  = isDictTy ty
 444 isDictTy other          = False
 445 \end{code}
 446
 447
 448 ---------------------------------------------------------------------
 449                                 SynTy
 450                                 ~~~~~
 451
 452 \begin{code}
 453 mkSynTy syn_tycon tys
 454   = ASSERT(isSynTyCon syn_tycon)
 455     NoteTy (SynNote (TyConApp syn_tycon tys))
 456            (substFlexiTy (zipVarEnv tyvars tys) body)
 457                 -- The "flexi" is needed so we can get a TcType from a synonym
 458   where
 459     (tyvars, body) = getSynTyConDefn syn_tycon
 460
 461 isSynTy (NoteTy (SynNote _) _) = True
 462 isSynTy other                  = False
 463 \end{code}
 464
 465 Notes on type synonyms
 466 ~~~~~~~~~~~~~~~~~~~~~~
 467 The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
 468 to return type synonyms whereever possible. Thus
 469
 470         type Foo a = a -> a
 471
 472 we want
 473         splitFunTys (a -> Foo a) = ([a], Foo a)
 474 not                                ([a], a -> a)
 475
 476 The reason is that we then get better (shorter) type signatures in
 477 interfaces.  Notably this plays a role in tcTySigs in TcBinds.lhs.
 478
 479
 480
 481
 482 ---------------------------------------------------------------------
 483                                 ForAllTy
 484                                 ~~~~~~~~
 485
 486 \begin{code}
 487 mkForAllTy = ForAllTy
 488
 489 mkForAllTys :: [GenTyVar flexi] -> GenType flexi -> GenType flexi
 490 mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
 491
 492 splitForAllTy_maybe :: GenType flexi -> Maybe (GenTyVar flexi, GenType flexi)
 493 splitForAllTy_maybe (NoteTy _ ty)       = splitForAllTy_maybe ty
 494 splitForAllTy_maybe (ForAllTy tyvar ty) = Just(tyvar, ty)
 495 splitForAllTy_maybe _                   = Nothing
 496
 497 isForAllTy :: GenType flexi -> Bool
 498 isForAllTy (NoteTy _ ty)       = isForAllTy ty
 499 isForAllTy (ForAllTy tyvar ty) = True
 500 isForAllTy _                 = False
 501
 502 splitForAllTys :: GenType flexi -> ([GenTyVar flexi], GenType flexi)
 503 splitForAllTys ty = split ty ty []
 504    where
 505      split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
 506      split orig_ty (NoteTy _ ty)    tvs = split orig_ty ty tvs
 507      split orig_ty t                tvs = (reverse tvs, orig_ty)
 508 \end{code}
 509
 510 @mkPiType@ makes a (->) type or a forall type, depending on whether
 511 it is given a type variable or a term variable.
 512
 513 \begin{code}
 514 mkPiType :: IdOrTyVar -> Type -> Type   -- The more polymorphic version doesn't work...
 515 mkPiType v ty | isId v    = mkFunTy (idType v) ty
 516               | otherwise = ForAllTy v ty
 517 \end{code}
 518
 519 \begin{code}
 520 applyTy :: GenType flexi -> GenType flexi -> GenType flexi
 521 applyTy (NoteTy _ fun)   arg = applyTy fun arg
 522 applyTy (ForAllTy tv ty) arg = substTy (mkVarEnv [(tv,arg)]) ty
 523 applyTy other            arg = panic "applyTy"
 524
 525 applyTys :: GenType flexi -> [GenType flexi] -> GenType flexi
 526 applyTys fun_ty arg_tys
 527  = go [] fun_ty arg_tys
 528  where
 529    go env ty               []         = substTy (mkVarEnv env) ty
 530    go env (NoteTy _ fun)   args       = go env fun args
 531    go env (ForAllTy tv ty) (arg:args) = go ((tv,arg):env) ty args
 532    go env other            args       = panic "applyTys"
 533 \end{code}
 534
 535
 536 %************************************************************************
 537 %*                                                                      *
 538 \subsection{Stuff to do with the source-language types}
 539 %*                                                                      *
 540 %************************************************************************
 541
 542 \begin{code}
 543 type RhoType   = Type
 544 type TauType   = Type
 545 type ThetaType = [(Class, [Type])]
 546 type SigmaType = Type
 547 \end{code}
 548
 549 @isTauTy@ tests for nested for-alls.
 550
 551 \begin{code}
 552 isTauTy :: GenType flexi -> Bool
 553 isTauTy (TyVarTy v)      = True
 554 isTauTy (TyConApp _ tys) = all isTauTy tys
 555 isTauTy (AppTy a b)      = isTauTy a && isTauTy b
 556 isTauTy (FunTy a b)      = isTauTy a && isTauTy b
 557 isTauTy (NoteTy _ ty)    = isTauTy ty
 558 isTauTy other            = False
 559 \end{code}
 560
 561 \begin{code}
 562 mkRhoTy :: [(Class, [GenType flexi])] -> GenType flexi -> GenType flexi
 563 mkRhoTy theta ty = foldr (\(c,t) r -> FunTy (mkDictTy c t) r) ty theta
 564
 565 splitRhoTy :: GenType flexi -> ([(Class, [GenType flexi])], GenType flexi)
 566 splitRhoTy ty = split ty ty []
 567  where
 568   split orig_ty (FunTy arg res) ts = case splitDictTy_maybe arg of
 569                                         Just pair -> split res res (pair:ts)
 570                                         Nothing   -> (reverse ts, orig_ty)
 571   split orig_ty (NoteTy _ ty) ts   = split orig_ty ty ts
 572   split orig_ty ty ts              = (reverse ts, orig_ty)
 573 \end{code}
 574
 575
 576
 577 \begin{code}
 578 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
 579
 580 splitSigmaTy :: GenType flexi -> ([GenTyVar flexi], [(Class, [GenType flexi])], GenType flexi)
 581 splitSigmaTy ty =
 582   (tyvars, theta, tau)
 583  where
 584   (tyvars,rho) = splitForAllTys ty
 585   (theta,tau)  = splitRhoTy rho
 586 \end{code}
 587
 588
 589 %************************************************************************
 590 %*                                                                      *
 591 \subsection{Kinds and free variables}
 592 %*                                                                      *
 593 %************************************************************************
 594
 595 ---------------------------------------------------------------------
 596                 Finding the kind of a type
 597                 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 598 \begin{code}
 599 -- typeKind is only ever used on Types, never Kinds
 600 -- If it were used on Kinds, the typeKind of FunTy would not be boxedTypeKind;
 601 -- yet at the type level functions are boxed even if neither argument nor
 602 -- result are boxed.   This seems pretty fishy to me.
 603
 604 typeKind :: GenType flexi -> Kind
 605
 606 typeKind (TyVarTy tyvar)        = tyVarKind tyvar
 607 typeKind (TyConApp tycon tys)   = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys
 608 typeKind (NoteTy _ ty)          = typeKind ty
 609 typeKind (FunTy fun arg)        = boxedTypeKind
 610 typeKind (AppTy fun arg)        = funResultTy (typeKind fun)
 611 typeKind (ForAllTy _ _)         = boxedTypeKind
 612 \end{code}
 613
 614
 615 ---------------------------------------------------------------------
 616                 Free variables of a type
 617                 ~~~~~~~~~~~~~~~~~~~~~~~~
 618 \begin{code}
 619 tyVarsOfType :: GenType flexi -> GenTyVarSet flexi
 620
 621 tyVarsOfType (TyVarTy tv)               = unitVarSet tv
 622 tyVarsOfType (TyConApp tycon tys)       = tyVarsOfTypes tys
 623 tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
 624 tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
 625 tyVarsOfType (FunTy arg res)            = tyVarsOfType arg `unionVarSet` tyVarsOfType res
 626 tyVarsOfType (AppTy fun arg)            = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
 627 tyVarsOfType (ForAllTy tyvar ty)        = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
 628
 629 tyVarsOfTypes :: [GenType flexi] -> GenTyVarSet flexi
 630 tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
 631
 632 -- Add a Note with the free tyvars to the top of the type
 633 addFreeTyVars :: GenType flexi -> GenType flexi
 634 addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty
 635 addFreeTyVars ty                        = NoteTy (FTVNote (tyVarsOfType ty)) ty
 636
 637 -- Find the free names of a type, including the type constructors and classes it mentions
 638 namesOfType :: GenType flexi -> NameSet
 639 namesOfType (TyVarTy tv)                = unitNameSet (getName tv)
 640 namesOfType (TyConApp tycon tys)        = unitNameSet (getName tycon) `unionNameSets`
 641                                           namesOfTypes tys
 642 namesOfType (NoteTy (SynNote ty1) ty2)  = namesOfType ty1
 643 namesOfType (NoteTy other_note    ty2)  = namesOfType ty2
 644 namesOfType (FunTy arg res)             = namesOfType arg `unionNameSets` namesOfType res
 645 namesOfType (AppTy fun arg)             = namesOfType fun `unionNameSets` namesOfType arg
 646 namesOfType (ForAllTy tyvar ty)         = namesOfType ty `minusNameSet` unitNameSet (getName tyvar)
 647
 648 namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys
 649 \end{code}
 650
 651
 652 %************************************************************************
 653 %*                                                                      *
 654 \subsection{Instantiating a type}
 655 %*                                                                      *
 656 %************************************************************************
 657
 658 @substTy@ applies a substitution to a type.  It deals correctly with name capture.
 659
 660 \begin{code}
 661 substTy :: GenTyVarSubst flexi -> GenType flexi -> GenType flexi
 662 substTy tenv ty = subst_ty tenv tset ty
 663                  where
 664                     tset = foldVarEnv (unionVarSet . tyVarsOfType) emptyVarSet tenv
 665                                 -- If ty doesn't have any for-alls, then this thunk
 666                                 -- will never be evaluated
 667 \end{code}
 668
 669 @fullSubstTy@ is like @substTy@ except that it needs to be given a set
 670 of in-scope type variables.  In exchange it's a bit more efficient, at least
 671 if you happen to have that set lying around.
 672
 673 \begin{code}
 674 fullSubstTy :: GenTyVarSubst flexi              -- Substitution to apply
 675             -> GenTyVarSet flexi                -- Superset of the free tyvars of
 676                                                 -- the range of the tyvar env
 677             -> GenType flexi  -> GenType flexi
 678 -- ASSUMPTION: The substitution is idempotent.
 679 -- Equivalently: No tyvar is both in scope, and in the domain of the substitution.
 680 fullSubstTy tenv tset ty | isEmptyVarEnv tenv = ty
 681                          | otherwise          = subst_ty tenv tset ty
 682
 683 -- subst_ty does the business
 684 subst_ty tenv tset ty
 685    = go ty
 686   where
 687     go (TyConApp tc tys)           = TyConApp tc (map go tys)
 688     go (NoteTy (SynNote ty1) ty2)  = NoteTy (SynNote (go ty1)) (go ty2)
 689     go (NoteTy (FTVNote _) ty2)    = go ty2             -- Discard the free tyvar note
 690     go (FunTy arg res)             = FunTy (go arg) (go res)
 691     go (AppTy fun arg)             = mkAppTy (go fun) (go arg)
 692     go ty@(TyVarTy tv)             = case (lookupVarEnv tenv tv) of
 693                                       Nothing  -> ty
 694                                       Just ty' -> ty'
 695     go (ForAllTy tv ty)            = case substTyVar tenv tset tv of
 696                                         (tenv', tset', tv') -> ForAllTy tv' (subst_ty tenv' tset' ty)
 697
 698 substTyVar ::  GenTyVarSubst flexi -> GenTyVarSet flexi -> GenTyVar flexi
 699            -> (GenTyVarSubst flexi,   GenTyVarSet flexi,   GenTyVar flexi)
 700
 701 substTyVar tenv tset tv
 702   | not (tv `elemVarSet` tset)  -- No need to clone
 703                                 -- But must delete from substitution
 704   = (tenv `delVarEnv` tv, tset `extendVarSet` tv, tv)
 705
 706   | otherwise   -- The forall's variable is in scope so
 707                 -- we'd better rename it away from the in-scope variables
 708                 -- Extending the substitution to do this renaming also
 709                 -- has the (correct) effect of discarding any existing
 710                 -- substitution for that variable
 711   = (extendVarEnv tenv tv (TyVarTy tv'), tset `extendVarSet` tv', tv')
 712   where
 713      tv' = uniqAway tset tv
 714 \end{code}
 715
 716
 717 @substFlexiTy@ applies a substitution to a (GenType flexi1) returning
 718 a (GenType flexi2).  Note that we convert from one flexi status to another.
 719
 720 Two assumptions, for (substFlexiTy env ty)
 721         (a) the substitution, env, must cover all free tyvars of the type, ty
 722         (b) the free vars of the range of the substitution must be
 723                 different than any of the forall'd variables in the type, ty
 724
 725 The latter assumption is reasonable because, after all, ty has a different
 726 type to the range of the substitution.
 727
 728 \begin{code}
 729 substFlexiTy :: GenTyVarSubst flexi2 -> GenType flexi1 -> GenType flexi2
 730 substFlexiTy env ty = go ty
 731   where
 732     go (TyVarTy tv)               = case lookupVarEnv env tv of
 733                                         Just ty -> ty
 734                                         Nothing -> pprPanic "substFlexiTy" (ppr tv)
 735     go (TyConApp tc tys)          = TyConApp tc (map go tys)
 736     go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote (go ty1)) (go ty2)
 737     go (NoteTy (FTVNote _)   ty2) = go ty2      -- Discard free tyvar note
 738     go (FunTy arg res)            = FunTy (go arg) (go res)
 739     go (AppTy fun arg)            = mkAppTy (go fun) (go arg)
 740     go (ForAllTy tv ty)           = ForAllTy tv' (substFlexiTy env' ty)
 741                                   where
 742                                     tv' = removeTyVarFlexi tv
 743                                     env' = extendVarEnv env tv (TyVarTy tv')
 744
 745 substFlexiTheta :: GenTyVarSubst flexi2 -> [(Class, [GenType flexi1])]
 746                                         -> [(Class, [GenType flexi2])]
 747 substFlexiTheta env theta = [(clas, map (substFlexiTy env) tys) | (clas,tys) <- theta]
 748 \end{code}
 749
 750
 751 %************************************************************************
 752 %*                                                                      *
 753 \subsection{Boxedness and liftedness}
 754 %*                                                                      *
 755 %************************************************************************
 756
 757 \begin{code}
 758 isUnboxedType :: GenType flexi -> Bool
 759 isUnboxedType ty = not (isFollowableRep (typePrimRep ty))
 760
 761 isUnLiftedType :: GenType flexi -> Bool
 762 isUnLiftedType ty = case splitTyConApp_maybe ty of
 763                            Just (tc, ty_args) -> isUnLiftedTyCon tc
 764                            other              -> False
 765
 766 isUnboxedTupleType :: GenType flexi -> Bool
 767 isUnboxedTupleType ty = case splitTyConApp_maybe ty of
 768                            Just (tc, ty_args) -> isUnboxedTupleTyCon tc
 769                            other              -> False
 770
 771 isAlgType :: GenType flexi -> Bool
 772 isAlgType ty = case splitTyConApp_maybe ty of
 773                         Just (tc, ty_args) -> isAlgTyCon tc
 774                         other              -> False
 775
 776 typePrimRep :: GenType flexi -> PrimRep
 777 typePrimRep ty = case splitTyConApp_maybe ty of
 778                    Just (tc, ty_args) -> tyConPrimRep tc
 779                    other              -> PtrRep
 780 \end{code}
 781
 782 %************************************************************************
 783 %*                                                                      *
 784 \subsection{Equality on types}
 785 %*                                                                      *
 786 %************************************************************************
 787
 788 For the moment at least, type comparisons don't work if
 789 there are embedded for-alls.
 790
 791 \begin{code}
 792 instance Eq (GenType flexi) where
 793   ty1 == ty2 = case ty1 `cmpTy` ty2 of { EQ -> True; other -> False }
 794
 795 instance Ord (GenType flexi) where
 796   compare ty1 ty2 = cmpTy ty1 ty2
 797
 798 cmpTy :: GenType flexi -> GenType flexi -> Ordering
 799 cmpTy ty1 ty2
 800   = cmp emptyVarEnv ty1 ty2
 801   where
 802   -- The "env" maps type variables in ty1 to type variables in ty2
 803   -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
 804   -- we in effect substitute tv2 for tv1 in t1 before continuing
 805     lookup env tv1 = case lookupVarEnv env tv1 of
 806                           Just tv2 -> tv2
 807                           Nothing  -> tv1
 808
 809     -- Get rid of NoteTy
 810     cmp env (NoteTy _ ty1) ty2 = cmp env ty1 ty2
 811     cmp env ty1 (NoteTy _ ty2) = cmp env ty1 ty2
 812
 813     -- Deal with equal constructors
 814     cmp env (TyVarTy tv1) (TyVarTy tv2) = lookup env tv1 `compare` tv2
 815     cmp env (AppTy f1 a1) (AppTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
 816     cmp env (FunTy f1 a1) (FunTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
 817     cmp env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmps env tys1 tys2)
 818     cmp env (ForAllTy tv1 t1)   (ForAllTy tv2 t2)   = cmp (extendVarEnv env tv1 tv2) t1 t2
 819
 820     -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy
 821     cmp env (AppTy _ _) (TyVarTy _) = GT
 822
 823     cmp env (FunTy _ _) (TyVarTy _) = GT
 824     cmp env (FunTy _ _) (AppTy _ _) = GT
 825
 826     cmp env (TyConApp _ _) (TyVarTy _) = GT
 827     cmp env (TyConApp _ _) (AppTy _ _) = GT
 828     cmp env (TyConApp _ _) (FunTy _ _) = GT
 829
 830     cmp env (ForAllTy _ _) other       = GT
 831
 832     cmp env _ _                        = LT
 833
 834     cmps env []     [] = EQ
 835     cmps env (t:ts) [] = GT
 836     cmps env [] (t:ts) = LT
 837     cmps env (t1:t1s) (t2:t2s) = cmp env t1 t2 `thenCmp` cmps env t1s t2s
 838 \end{code}
 839
 840
 841
 842 %************************************************************************
 843 %*                                                                      *
 844 \subsection{Grime}
 845 %*                                                                      *
 846 %************************************************************************
 847
 848
 849
 850 \begin{code}
 851 showTypeCategory :: Type -> Char
 852   {-
 853         {C,I,F,D}   char, int, float, double
 854         T           tuple
 855         S           other single-constructor type
 856         {c,i,f,d}   unboxed ditto
 857         t           *unpacked* tuple
 858         s           *unpacked" single-cons...
 859
 860         v           void#
 861         a           primitive array
 862
 863         E           enumeration type
 864         +           dictionary, unless it's a ...
 865         L           List
 866         >           function
 867         M           other (multi-constructor) data-con type
 868         .           other type
 869         -           reserved for others to mark as "uninteresting"
 870     -}
 871 showTypeCategory ty
 872   = if isDictTy ty
 873     then '+'
 874     else
 875       case splitTyConApp_maybe ty of
 876         Nothing -> if maybeToBool (splitFunTy_maybe ty)
 877                    then '>'
 878                    else '.'
 879
 880         Just (tycon, _) ->
 881           let utc = getUnique tycon in
 882           if      utc == charDataConKey    then 'C'
 883           else if utc == intDataConKey     then 'I'
 884           else if utc == floatDataConKey   then 'F'
 885           else if utc == doubleDataConKey  then 'D'
 886           else if utc == integerDataConKey then 'J'
 887           else if utc == charPrimTyConKey  then 'c'
 888           else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
 889                 || utc == addrPrimTyConKey)                then 'i'
 890           else if utc  == floatPrimTyConKey                then 'f'
 891           else if utc  == doublePrimTyConKey               then 'd'
 892           else if isPrimTyCon tycon {- array, we hope -}   then 'A'
 893           else if isEnumerationTyCon tycon                 then 'E'
 894           else if isTupleTyCon tycon                       then 'T'
 895           else if maybeToBool (maybeTyConSingleCon tycon)  then 'S'
 896           else if utc == listTyConKey                      then 'L'
 897           else 'M' -- oh, well...
 898 \end{code}