ghc/compiler/types/Type.lhs

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