ghc/compiler/types/Type.lhs

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