ghc/compiler/types/Type.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1998
   3 %
   4 \section[Type]{Type - public interface}
   5
   6 \begin{code}
   7 module Type (
   8         -- re-exports from TypeRep:
   9         Type,
  10         Kind, TyVarSubst,
  11
  12         superKind, superBoxity,                         -- :: SuperKind
  13
  14         boxedKind,                                      -- :: Kind :: BX
  15         anyBoxKind,                                     -- :: Kind :: BX
  16         typeCon,                                        -- :: KindCon :: BX -> KX
  17         anyBoxCon,                                      -- :: KindCon :: BX
  18
  19         boxedTypeKind, unboxedTypeKind, openTypeKind,   -- Kind :: superKind
  20
  21         mkArrowKind, mkArrowKinds, -- mentioned below: hasMoreBoxityInfo,
  22
  23         funTyCon,
  24
  25         -- exports from this module:
  26         hasMoreBoxityInfo,
  27
  28         mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy,
  29
  30         mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe,
  31
  32         mkFunTy, mkFunTys, splitFunTy_maybe, splitFunTys, splitFunTysN,
  33         funResultTy, funArgTy, zipFunTys,
  34
  35         mkTyConApp, mkTyConTy, splitTyConApp_maybe,
  36         splitAlgTyConApp_maybe, splitAlgTyConApp,
  37         mkDictTy, splitDictTy_maybe, isDictTy,
  38
  39         mkSynTy, isSynTy, deNoteType, repType, splitNewType_maybe,
  40
  41         UsageAnn(..), mkUsgTy, isUsgTy{- dont use -}, isNotUsgTy, splitUsgTy, unUsgTy, tyUsg,
  42         mkUsForAllTy, mkUsForAllTys, splitUsForAllTys, substUsTy,
  43
  44         mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
  45         isForAllTy, applyTy, applyTys, mkPiType,
  46
  47         TauType, RhoType, SigmaType, ThetaType,
  48         isTauTy,
  49         mkRhoTy, splitRhoTy,
  50         mkSigmaTy, splitSigmaTy,
  51
  52         -- Lifting and boxity
  53         isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, isDataType, isNewType,
  54         typePrimRep,
  55
  56         -- Free variables
  57         tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind,
  58         addFreeTyVars,
  59
  60         -- Tidying up for printing
  61         tidyType,     tidyTypes,
  62         tidyOpenType, tidyOpenTypes,
  63         tidyTyVar,    tidyTyVars,
  64         tidyTopType,
  65
  66         -- Seq
  67         seqType, seqTypes
  68
  69     ) where
  70
  71 #include "HsVersions.h"
  72
  73 -- We import the representation and primitive functions from TypeRep.
  74 -- Many things are reexported, but not the representation!
  75
  76 import TypeRep
  77
  78 -- Other imports:
  79
  80 import {-# SOURCE #-}   DataCon( DataCon, dataConType )
  81 import {-# SOURCE #-}   PprType( pprType )      -- Only called in debug messages
  82 import {-# SOURCE #-}   Subst  ( mkTyVarSubst, substTy )
  83
  84 -- friends:
  85 import Var      ( TyVar, IdOrTyVar, UVar,
  86                   tyVarKind, tyVarName, setTyVarName, isId, idType,
  87                 )
  88 import VarEnv
  89 import VarSet
  90
  91 import Name     ( NamedThing(..), mkLocalName, tidyOccName,
  92                 )
  93 import NameSet
  94 import Class    ( classTyCon, Class )
  95 import TyCon    ( TyCon,
  96                   isUnboxedTupleTyCon, isUnLiftedTyCon,
  97                   isFunTyCon, isDataTyCon, isNewTyCon,
  98                   isAlgTyCon, isSynTyCon, tyConArity,
  99                   tyConKind, tyConDataCons, getSynTyConDefn,
 100                   tyConPrimRep, tyConClass_maybe
 101                 )
 102
 103 -- others
 104 import SrcLoc           ( noSrcLoc )
 105 import Maybes           ( maybeToBool )
 106 import PrimRep          ( PrimRep(..), isFollowableRep )
 107 import Unique           ( Uniquable(..) )
 108 import Util             ( mapAccumL, seqList )
 109 import Outputable
 110 import UniqSet          ( sizeUniqSet )         -- Should come via VarSet
 111 \end{code}
 112
 113
 114 %************************************************************************
 115 %*                                                                      *
 116 \subsection{Stuff to do with kinds.}
 117 %*                                                                      *
 118 %************************************************************************
 119
 120 \begin{code}
 121 hasMoreBoxityInfo :: Kind -> Kind -> Bool
 122 hasMoreBoxityInfo k1 k2
 123   | k2 == openTypeKind = ASSERT( is_type_kind k1) True
 124   | otherwise          = k1 == k2
 125   where
 126         -- Returns true for things of form (Type x)
 127     is_type_kind k = case splitTyConApp_maybe k of
 128                         Just (tc,[_]) -> tc == typeCon
 129                         Nothing       -> False
 130 \end{code}
 131
 132
 133 %************************************************************************
 134 %*                                                                      *
 135 \subsection{Constructor-specific functions}
 136 %*                                                                      *
 137 %************************************************************************
 138
 139
 140 ---------------------------------------------------------------------
 141                                 TyVarTy
 142                                 ~~~~~~~
 143 \begin{code}
 144 mkTyVarTy  :: TyVar   -> Type
 145 mkTyVarTy  = TyVarTy
 146
 147 mkTyVarTys :: [TyVar] -> [Type]
 148 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
 149
 150 getTyVar :: String -> Type -> TyVar
 151 getTyVar msg (TyVarTy tv) = tv
 152 getTyVar msg (NoteTy _ t) = getTyVar msg t
 153 getTyVar msg other        = panic ("getTyVar: " ++ msg)
 154
 155 getTyVar_maybe :: Type -> Maybe TyVar
 156 getTyVar_maybe (TyVarTy tv) = Just tv
 157 getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t
 158 getTyVar_maybe other        = Nothing
 159
 160 isTyVarTy :: Type -> Bool
 161 isTyVarTy (TyVarTy tv)  = True
 162 isTyVarTy (NoteTy _ ty) = isTyVarTy ty
 163 isTyVarTy other         = False
 164 \end{code}
 165
 166
 167 ---------------------------------------------------------------------
 168                                 AppTy
 169                                 ~~~~~
 170 We need to be pretty careful with AppTy to make sure we obey the
 171 invariant that a TyConApp is always visibly so.  mkAppTy maintains the
 172 invariant: use it.
 173
 174 \begin{code}
 175 mkAppTy orig_ty1 orig_ty2 = ASSERT2( isNotUsgTy orig_ty1 && isNotUsgTy orig_ty2, pprType orig_ty1 <+> text "to" <+> pprType orig_ty2 )
 176                             mk_app orig_ty1
 177   where
 178     mk_app (NoteTy _ ty1)    = mk_app ty1
 179     mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
 180     mk_app ty1               = AppTy orig_ty1 orig_ty2
 181
 182 mkAppTys :: Type -> [Type] -> Type
 183 mkAppTys orig_ty1 []        = orig_ty1
 184         -- This check for an empty list of type arguments
 185         -- avoids the needless of a type synonym constructor.
 186         -- For example: mkAppTys Rational []
 187         --   returns to (Ratio Integer), which has needlessly lost
 188         --   the Rational part.
 189 mkAppTys orig_ty1 orig_tys2 = ASSERT2( isNotUsgTy orig_ty1, pprType orig_ty1 )
 190                               mk_app orig_ty1
 191   where
 192     mk_app (NoteTy _ ty1)    = mk_app ty1
 193     mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
 194     mk_app ty1               = ASSERT2( all isNotUsgTy orig_tys2, pprType orig_ty1 <+> text "to" <+> hsep (map pprType orig_tys2) )
 195                                foldl AppTy orig_ty1 orig_tys2
 196
 197 splitAppTy_maybe :: Type -> Maybe (Type, Type)
 198 splitAppTy_maybe (FunTy ty1 ty2)   = Just (TyConApp funTyCon [ty1], ty2)
 199 splitAppTy_maybe (AppTy ty1 ty2)   = Just (ty1, ty2)
 200 splitAppTy_maybe (NoteTy _ ty)     = splitAppTy_maybe ty
 201 splitAppTy_maybe (TyConApp tc [])  = Nothing
 202 splitAppTy_maybe (TyConApp tc tys) = split tys []
 203                             where
 204                                split [ty2]    acc = Just (TyConApp tc (reverse acc), ty2)
 205                                split (ty:tys) acc = split tys (ty:acc)
 206
 207 splitAppTy_maybe other            = Nothing
 208
 209 splitAppTy :: Type -> (Type, Type)
 210 splitAppTy ty = case splitAppTy_maybe ty of
 211                         Just pr -> pr
 212                         Nothing -> panic "splitAppTy"
 213
 214 splitAppTys :: Type -> (Type, [Type])
 215 splitAppTys ty = split ty ty []
 216   where
 217     split orig_ty (AppTy ty arg)        args = split ty ty (arg:args)
 218     split orig_ty (NoteTy _ ty)         args = split orig_ty ty args
 219     split orig_ty (FunTy ty1 ty2)       args = ASSERT( null args )
 220                                                (TyConApp funTyCon [], [ty1,ty2])
 221     split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
 222     split orig_ty ty                    args = (orig_ty, args)
 223 \end{code}
 224
 225
 226 ---------------------------------------------------------------------
 227                                 FunTy
 228                                 ~~~~~
 229
 230 \begin{code}
 231 mkFunTy :: Type -> Type -> Type
 232 mkFunTy arg res = FunTy arg res
 233
 234 mkFunTys :: [Type] -> Type -> Type
 235 mkFunTys tys ty = foldr FunTy ty tys
 236
 237 splitFunTy_maybe :: Type -> Maybe (Type, Type)
 238 splitFunTy_maybe (FunTy arg res) = Just (arg, res)
 239 splitFunTy_maybe (NoteTy _ ty)   = splitFunTy_maybe ty
 240 splitFunTy_maybe other           = Nothing
 241
 242 splitFunTys :: Type -> ([Type], Type)
 243 splitFunTys ty = split [] ty ty
 244   where
 245     split args orig_ty (FunTy arg res) = split (arg:args) res res
 246     split args orig_ty (NoteTy _ ty)   = split args orig_ty ty
 247     split args orig_ty ty              = (reverse args, orig_ty)
 248
 249 splitFunTysN :: String -> Int -> Type -> ([Type], Type)
 250 splitFunTysN msg orig_n orig_ty = split orig_n [] orig_ty orig_ty
 251   where
 252     split 0 args syn_ty ty              = (reverse args, syn_ty)
 253     split n args syn_ty (FunTy arg res) = split (n-1) (arg:args) res    res
 254     split n args syn_ty (NoteTy _ ty)   = split n     args       syn_ty ty
 255     split n args syn_ty ty              = pprPanic ("splitFunTysN: " ++ msg) (int orig_n <+> pprType orig_ty)
 256
 257 zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type)
 258 zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
 259   where
 260     split acc []     nty ty              = (reverse acc, nty)
 261     split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res
 262     split acc xs     nty (NoteTy _ ty)   = split acc           xs nty ty
 263     split acc (x:xs) nty ty              = pprPanic "zipFunTys" (ppr orig_xs <+> pprType orig_ty)
 264
 265 funResultTy :: Type -> Type
 266 funResultTy (FunTy arg res) = res
 267 funResultTy (NoteTy _ ty)   = funResultTy ty
 268 funResultTy ty              = pprPanic "funResultTy" (pprType ty)
 269
 270 funArgTy :: Type -> Type
 271 funArgTy (FunTy arg res) = arg
 272 funArgTy (NoteTy _ ty)   = funArgTy ty
 273 funArgTy ty              = pprPanic "funArgTy" (pprType ty)
 274 \end{code}
 275
 276
 277 ---------------------------------------------------------------------
 278                                 TyConApp
 279                                 ~~~~~~~~
 280
 281 \begin{code}
 282 mkTyConApp :: TyCon -> [Type] -> Type
 283 mkTyConApp tycon tys
 284   | isFunTyCon tycon && length tys == 2
 285   = case tys of
 286         (ty1:ty2:_) -> FunTy ty1 ty2
 287
 288   | otherwise
 289   = ASSERT(not (isSynTyCon tycon))
 290     TyConApp tycon tys
 291
 292 mkTyConTy :: TyCon -> Type
 293 mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) )
 294                   TyConApp tycon []
 295
 296 -- splitTyConApp "looks through" synonyms, because they don't
 297 -- mean a distinct type, but all other type-constructor applications
 298 -- including functions are returned as Just ..
 299
 300 splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
 301 splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
 302 splitTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [arg,res])
 303 splitTyConApp_maybe (NoteTy _ ty)     = splitTyConApp_maybe ty
 304 splitTyConApp_maybe other             = Nothing
 305
 306 -- splitAlgTyConApp_maybe looks for
 307 --      *saturated* applications of *algebraic* data types
 308 -- "Algebraic" => newtype, data type, or dictionary (not function types)
 309 -- We return the constructors too.
 310
 311 splitAlgTyConApp_maybe :: Type -> Maybe (TyCon, [Type], [DataCon])
 312 splitAlgTyConApp_maybe (TyConApp tc tys)
 313   | isAlgTyCon tc &&
 314     tyConArity tc == length tys      = Just (tc, tys, tyConDataCons tc)
 315 splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty
 316 splitAlgTyConApp_maybe other         = Nothing
 317
 318 splitAlgTyConApp :: Type -> (TyCon, [Type], [DataCon])
 319         -- Here the "algebraic" property is an *assertion*
 320 splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == length tys )
 321                                      (tc, tys, tyConDataCons tc)
 322 splitAlgTyConApp (NoteTy _ ty)     = splitAlgTyConApp ty
 323 \end{code}
 324
 325 "Dictionary" types are just ordinary data types, but you can
 326 tell from the type constructor whether it's a dictionary or not.
 327
 328 \begin{code}
 329 mkDictTy :: Class -> [Type] -> Type
 330 mkDictTy clas tys = TyConApp (classTyCon clas) tys
 331
 332 splitDictTy_maybe :: Type -> Maybe (Class, [Type])
 333 splitDictTy_maybe (TyConApp tc tys)
 334   |  maybeToBool maybe_class
 335   && tyConArity tc == length tys = Just (clas, tys)
 336   where
 337      maybe_class = tyConClass_maybe tc
 338      Just clas   = maybe_class
 339
 340 splitDictTy_maybe (NoteTy _ ty) = splitDictTy_maybe ty
 341 splitDictTy_maybe other         = Nothing
 342
 343 isDictTy :: Type -> Bool
 344         -- This version is slightly more efficient than (maybeToBool . splitDictTy)
 345 isDictTy (TyConApp tc tys)
 346   |  maybeToBool (tyConClass_maybe tc)
 347   && tyConArity tc == length tys
 348   = True
 349 isDictTy (NoteTy _ ty)  = isDictTy ty
 350 isDictTy other          = False
 351 \end{code}
 352
 353 ---------------------------------------------------------------------
 354                                 SynTy
 355                                 ~~~~~
 356
 357 \begin{code}
 358 mkSynTy syn_tycon tys
 359   = ASSERT( isSynTyCon syn_tycon )
 360     ASSERT( isNotUsgTy body )
 361     ASSERT( length tyvars == length tys )
 362     NoteTy (SynNote (TyConApp syn_tycon tys))
 363            (substTy (mkTyVarSubst tyvars tys) body)
 364   where
 365     (tyvars, body) = getSynTyConDefn syn_tycon
 366
 367 isSynTy (NoteTy (SynNote _) _) = True
 368 isSynTy other                  = False
 369
 370 deNoteType :: Type -> Type
 371         -- Sorry for the cute name
 372 deNoteType ty@(TyVarTy tyvar)   = ty
 373 deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys)
 374 deNoteType (NoteTy _ ty)        = deNoteType ty
 375 deNoteType (AppTy fun arg)      = AppTy (deNoteType fun) (deNoteType arg)
 376 deNoteType (FunTy fun arg)      = FunTy (deNoteType fun) (deNoteType arg)
 377 deNoteType (ForAllTy tv ty)     = ForAllTy tv (deNoteType ty)
 378 \end{code}
 379
 380 Notes on type synonyms
 381 ~~~~~~~~~~~~~~~~~~~~~~
 382 The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
 383 to return type synonyms whereever possible. Thus
 384
 385         type Foo a = a -> a
 386
 387 we want
 388         splitFunTys (a -> Foo a) = ([a], Foo a)
 389 not                                ([a], a -> a)
 390
 391 The reason is that we then get better (shorter) type signatures in
 392 interfaces.  Notably this plays a role in tcTySigs in TcBinds.lhs.
 393
 394
 395
 396 repType looks through
 397         (a) for-alls, and
 398         (b) newtypes
 399 in addition to synonyms.  It's useful in the back end where we're not
 400 interested in newtypes anymore.
 401
 402 \begin{code}
 403 repType :: Type -> Type
 404 repType (NoteTy _ ty)                     = repType ty
 405 repType (ForAllTy _ ty)                   = repType ty
 406 repType (TyConApp tc tys) | isNewTyCon tc = repType (new_type_rep tc tys)
 407 repType other_ty                          = other_ty
 408
 409 splitNewType_maybe :: Type -> Maybe Type
 410 -- Find the representation of a newtype, if it is one
 411 -- Looks through multiple levels of newtype
 412 splitNewType_maybe (NoteTy _ ty)                     = splitNewType_maybe ty
 413 splitNewType_maybe (TyConApp tc tys) | isNewTyCon tc = case splitNewType_maybe rep_ty of
 414                                                                 Just rep_ty' -> Just rep_ty'
 415                                                                 Nothing      -> Just rep_ty
 416                                                      where
 417                                                        rep_ty = new_type_rep tc tys
 418
 419 splitNewType_maybe other                             = Nothing
 420
 421 new_type_rep :: TyCon -> [Type] -> Type
 422 -- The representation type for (T t1 .. tn), where T is a newtype
 423 -- Looks through one layer only
 424 new_type_rep tc tys
 425   = ASSERT( isNewTyCon tc )
 426     case splitFunTy_maybe (applyTys (dataConType (head (tyConDataCons tc))) tys) of
 427         Just (rep_ty, _) -> rep_ty
 428 \end{code}
 429
 430
 431
 432 ---------------------------------------------------------------------
 433                                 UsgNote
 434                                 ~~~~~~~
 435
 436 NB: Invariant: if present, usage note is at the very top of the type.
 437 This should be carefully preserved.
 438
 439 In some parts of the compiler, comments use the _Once Upon a
 440 Polymorphic Type_ (POPL'99) usage of "rho = generalised
 441 usage-annotated type; sigma = usage-annotated type; tau =
 442 usage-annotated type except on top"; unfortunately this conflicts with
 443 the rho/tau/theta/sigma usage in the rest of the compiler.  (KSW
 444 1999-07)
 445
 446 \begin{code}
 447 mkUsgTy :: UsageAnn -> Type -> Type
 448 #ifndef USMANY
 449 mkUsgTy UsMany ty = ASSERT2( isNotUsgTy ty, pprType ty )
 450                     ty
 451 #endif
 452 mkUsgTy usg    ty = ASSERT2( isNotUsgTy ty, pprType ty )
 453                     NoteTy (UsgNote usg) ty
 454
 455 -- The isUsgTy function is utterly useless if UsManys are omitted.
 456 -- Be warned!  KSW 1999-04.
 457 isUsgTy :: Type -> Bool
 458 #ifndef USMANY
 459 isUsgTy _ = True
 460 #else
 461 isUsgTy (NoteTy (UsgForAll _) ty) = isUsgTy ty
 462 isUsgTy (NoteTy (UsgNote   _) _ ) = True
 463 isUsgTy other                     = False
 464 #endif
 465
 466 -- The isNotUsgTy function may return a false True if UsManys are omitted;
 467 -- in other words, A SSERT( isNotUsgTy ty ) may be useful but
 468 -- A SSERT( not (isNotUsg ty) ) is asking for trouble.  KSW 1999-04.
 469 isNotUsgTy :: Type -> Bool
 470 isNotUsgTy (NoteTy (UsgForAll _) _) = False
 471 isNotUsgTy (NoteTy (UsgNote   _) _) = False
 472 isNotUsgTy other                    = True
 473
 474 -- splitUsgTy_maybe is not exported, since it is meaningless if
 475 -- UsManys are omitted.  It is used in several places in this module,
 476 -- however.  KSW 1999-04.
 477 splitUsgTy_maybe :: Type -> Maybe (UsageAnn,Type)
 478 splitUsgTy_maybe (NoteTy (UsgNote usg) ty2) = ASSERT( isNotUsgTy ty2 )
 479                                               Just (usg,ty2)
 480 splitUsgTy_maybe ty@(NoteTy (UsgForAll _) _) = pprPanic "splitUsgTy_maybe:" $ pprType ty
 481 splitUsgTy_maybe ty                          = Nothing
 482
 483 splitUsgTy :: Type -> (UsageAnn,Type)
 484 splitUsgTy ty = case splitUsgTy_maybe ty of
 485                   Just ans -> ans
 486                   Nothing  ->
 487 #ifndef USMANY
 488                               (UsMany,ty)
 489 #else
 490                               pprPanic "splitUsgTy: no usage annot:" $ pprType ty
 491 #endif
 492
 493 tyUsg :: Type -> UsageAnn
 494 tyUsg = fst . splitUsgTy
 495
 496 unUsgTy :: Type -> Type
 497 -- strip outer usage annotation if present
 498 unUsgTy ty = case splitUsgTy_maybe ty of
 499                Just (_,ty1) -> ASSERT2( isNotUsgTy ty1, pprType ty )
 500                                ty1
 501                Nothing      -> ty
 502
 503 mkUsForAllTy :: UVar -> Type -> Type
 504 mkUsForAllTy uv ty = NoteTy (UsgForAll uv) ty
 505
 506 mkUsForAllTys :: [UVar] -> Type -> Type
 507 mkUsForAllTys uvs ty = foldr (NoteTy . UsgForAll) ty uvs
 508
 509 splitUsForAllTys :: Type -> ([UVar],Type)
 510 splitUsForAllTys ty = split ty []
 511   where split (NoteTy (UsgForAll u) ty) uvs = split ty (u:uvs)
 512         split other_ty                  uvs = (reverse uvs, other_ty)
 513
 514 substUsTy :: VarEnv UsageAnn -> Type -> Type
 515 -- assumes range is fresh uvars, so no conflicts
 516 substUsTy ve    (NoteTy  note@(UsgNote (UsVar u))
 517                                             ty ) = NoteTy (case lookupVarEnv ve u of
 518                                                              Just ua -> UsgNote ua
 519                                                              Nothing -> note)
 520                                                           (substUsTy ve ty)
 521 substUsTy ve    (NoteTy  note@(UsgNote   _) ty ) = NoteTy note (substUsTy ve ty)
 522 substUsTy ve    (NoteTy  note@(UsgForAll _) ty ) = NoteTy note (substUsTy ve ty)
 523 substUsTy ve    (NoteTy  (SynNote ty1)      ty2) = NoteTy (SynNote (substUsTy ve ty1))
 524                                                           (substUsTy ve ty2)
 525 substUsTy ve    (NoteTy  note@(FTVNote _)   ty ) = NoteTy note (substUsTy ve ty)
 526 substUsTy ve ty@(TyVarTy _                     ) = ty
 527 substUsTy ve    (AppTy   ty1                ty2) = AppTy (substUsTy ve ty1)
 528                                                          (substUsTy ve ty2)
 529 substUsTy ve    (FunTy   ty1                ty2) = FunTy (substUsTy ve ty1)
 530                                                          (substUsTy ve ty2)
 531 substUsTy ve    (TyConApp tyc               tys) = TyConApp tyc (map (substUsTy ve) tys)
 532 substUsTy ve    (ForAllTy yv                ty ) = ForAllTy yv (substUsTy ve ty)
 533 \end{code}
 534
 535
 536 ---------------------------------------------------------------------
 537                                 ForAllTy
 538                                 ~~~~~~~~
 539
 540 We need to be clever here with usage annotations; they need to be
 541 lifted or lowered through the forall as appropriate.
 542
 543 \begin{code}
 544 mkForAllTy :: TyVar -> Type -> Type
 545 mkForAllTy tyvar ty = case splitUsgTy_maybe ty of
 546                         Just (usg,ty') -> NoteTy (UsgNote usg)
 547                                                  (ForAllTy tyvar ty')
 548                         Nothing        -> ForAllTy tyvar ty
 549
 550 mkForAllTys :: [TyVar] -> Type -> Type
 551 mkForAllTys tyvars ty = case splitUsgTy_maybe ty of
 552                           Just (usg,ty') -> NoteTy (UsgNote usg)
 553                                                    (foldr ForAllTy ty' tyvars)
 554                           Nothing        -> foldr ForAllTy ty tyvars
 555
 556 splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
 557 splitForAllTy_maybe ty = case splitUsgTy_maybe ty of
 558                            Just (usg,ty') -> do (tyvar,ty'') <- splitFAT_m ty'
 559                                                 return (tyvar, NoteTy (UsgNote usg) ty'')
 560                            Nothing        -> splitFAT_m ty
 561   where
 562     splitFAT_m (NoteTy _ ty)       = splitFAT_m ty
 563     splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty)
 564     splitFAT_m _                   = Nothing
 565
 566 isForAllTy :: Type -> Bool
 567 isForAllTy (NoteTy _ ty)       = isForAllTy ty
 568 isForAllTy (ForAllTy tyvar ty) = True
 569 isForAllTy _                 = False
 570
 571 splitForAllTys :: Type -> ([TyVar], Type)
 572 splitForAllTys ty = case splitUsgTy_maybe ty of
 573                       Just (usg,ty') -> let (tvs,ty'') = split ty' ty' []
 574                                         in  (tvs, NoteTy (UsgNote usg) ty'')
 575                       Nothing        -> split ty ty []
 576    where
 577      split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
 578      split orig_ty (NoteTy _ ty)    tvs = split orig_ty ty tvs
 579      split orig_ty t                tvs = (reverse tvs, orig_ty)
 580 \end{code}
 581
 582 @mkPiType@ makes a (->) type or a forall type, depending on whether
 583 it is given a type variable or a term variable.
 584
 585 \begin{code}
 586 mkPiType :: IdOrTyVar -> Type -> Type   -- The more polymorphic version doesn't work...
 587 mkPiType v ty | isId v    = mkFunTy (idType v) ty
 588               | otherwise = mkForAllTy v ty
 589 \end{code}
 590
 591 Applying a for-all to its arguments
 592
 593 \begin{code}
 594 applyTy :: Type -> Type -> Type
 595 applyTy (NoteTy note@(UsgNote   _) fun) arg = NoteTy note (applyTy fun arg)
 596 applyTy (NoteTy note@(UsgForAll _) fun) arg = NoteTy note (applyTy fun arg)
 597 applyTy (NoteTy _ fun)                  arg = applyTy fun arg
 598 applyTy (ForAllTy tv ty)                arg = ASSERT( isNotUsgTy arg )
 599                                               substTy (mkTyVarSubst [tv] [arg]) ty
 600 applyTy other                           arg = panic "applyTy"
 601
 602 applyTys :: Type -> [Type] -> Type
 603 applyTys fun_ty arg_tys
 604  = substTy (mkTyVarSubst tvs arg_tys) ty
 605  where
 606    (tvs, ty) = split fun_ty arg_tys
 607
 608    split fun_ty               []         = ([], fun_ty)
 609    split (NoteTy note@(UsgNote   _) fun_ty)
 610                               args       = case split fun_ty args of
 611                                              (tvs, ty) -> (tvs, NoteTy note ty)
 612    split (NoteTy note@(UsgForAll _) fun_ty)
 613                               args       = case split fun_ty args of
 614                                              (tvs, ty) -> (tvs, NoteTy note ty)
 615    split (NoteTy _ fun_ty)    args       = split fun_ty args
 616    split (ForAllTy tv fun_ty) (arg:args) = ASSERT2( isNotUsgTy arg, vcat (map pprType arg_tys) $$
 617                                                                     text "in application of" <+> pprType fun_ty)
 618                                            case split fun_ty args of
 619                                                   (tvs, ty) -> (tv:tvs, ty)
 620    split other_ty             args       = panic "applyTys"
 621 \end{code}
 622
 623 Note that we allow applications to be of usage-annotated- types, as an
 624 extension: we handle them by lifting the annotation outside.  The
 625 argument, however, must still be unannotated.
 626
 627
 628 %************************************************************************
 629 %*                                                                      *
 630 \subsection{Stuff to do with the source-language types}
 631 %*                                                                      *
 632 %************************************************************************
 633
 634 \begin{code}
 635 type RhoType   = Type
 636 type TauType   = Type
 637 type ThetaType = [(Class, [Type])]
 638 type SigmaType = Type
 639 \end{code}
 640
 641 @isTauTy@ tests for nested for-alls.
 642
 643 \begin{code}
 644 isTauTy :: Type -> Bool
 645 isTauTy (TyVarTy v)      = True
 646 isTauTy (TyConApp _ tys) = all isTauTy tys
 647 isTauTy (AppTy a b)      = isTauTy a && isTauTy b
 648 isTauTy (FunTy a b)      = isTauTy a && isTauTy b
 649 isTauTy (NoteTy _ ty)    = isTauTy ty
 650 isTauTy other            = False
 651 \end{code}
 652
 653 \begin{code}
 654 mkRhoTy :: [(Class, [Type])] -> Type -> Type
 655 mkRhoTy theta ty = foldr (\(c,t) r -> FunTy (mkDictTy c t) r) ty theta
 656
 657 splitRhoTy :: Type -> ([(Class, [Type])], Type)
 658 splitRhoTy ty = split ty ty []
 659  where
 660   split orig_ty (FunTy arg res) ts = case splitDictTy_maybe arg of
 661                                         Just pair -> split res res (pair:ts)
 662                                         Nothing   -> (reverse ts, orig_ty)
 663   split orig_ty (NoteTy _ ty) ts   = split orig_ty ty ts
 664   split orig_ty ty ts              = (reverse ts, orig_ty)
 665 \end{code}
 666
 667
 668
 669 \begin{code}
 670 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
 671
 672 splitSigmaTy :: Type -> ([TyVar], [(Class, [Type])], Type)
 673 splitSigmaTy ty =
 674   (tyvars, theta, tau)
 675  where
 676   (tyvars,rho) = splitForAllTys ty
 677   (theta,tau)  = splitRhoTy rho
 678 \end{code}
 679
 680
 681 %************************************************************************
 682 %*                                                                      *
 683 \subsection{Kinds and free variables}
 684 %*                                                                      *
 685 %************************************************************************
 686
 687 ---------------------------------------------------------------------
 688                 Finding the kind of a type
 689                 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 690 \begin{code}
 691 typeKind :: Type -> Kind
 692
 693 typeKind (TyVarTy tyvar)        = tyVarKind tyvar
 694 typeKind (TyConApp tycon tys)   = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys
 695 typeKind (NoteTy _ ty)          = typeKind ty
 696 typeKind (AppTy fun arg)        = funResultTy (typeKind fun)
 697
 698 typeKind (FunTy arg res)        = boxedTypeKind -- A function is boxed regardless of its result type
 699                                                 -- No functions at the type level, hence we don't need
 700                                                 -- to say (typeKind res).
 701
 702 typeKind (ForAllTy tv ty)       = typeKind ty
 703 \end{code}
 704
 705
 706 ---------------------------------------------------------------------
 707                 Free variables of a type
 708                 ~~~~~~~~~~~~~~~~~~~~~~~~
 709 \begin{code}
 710 tyVarsOfType :: Type -> TyVarSet
 711
 712 tyVarsOfType (TyVarTy tv)               = unitVarSet tv
 713 tyVarsOfType (TyConApp tycon tys)       = tyVarsOfTypes tys
 714 tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
 715 tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
 716 tyVarsOfType (NoteTy (UsgNote _) ty)    = tyVarsOfType ty
 717 tyVarsOfType (NoteTy (UsgForAll _) ty)  = tyVarsOfType ty
 718 tyVarsOfType (FunTy arg res)            = tyVarsOfType arg `unionVarSet` tyVarsOfType res
 719 tyVarsOfType (AppTy fun arg)            = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
 720 tyVarsOfType (ForAllTy tyvar ty)        = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
 721
 722 tyVarsOfTypes :: [Type] -> TyVarSet
 723 tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
 724
 725 -- Add a Note with the free tyvars to the top of the type
 726 -- (but under a usage if there is one)
 727 addFreeTyVars :: Type -> Type
 728 addFreeTyVars (NoteTy note@(UsgNote   _) ty) = NoteTy note (addFreeTyVars ty)
 729 addFreeTyVars (NoteTy note@(UsgForAll _) ty) = NoteTy note (addFreeTyVars ty)
 730 addFreeTyVars ty@(NoteTy (FTVNote _) _)      = ty
 731 addFreeTyVars ty                             = NoteTy (FTVNote (tyVarsOfType ty)) ty
 732
 733 -- Find the free names of a type, including the type constructors and classes it mentions
 734 namesOfType :: Type -> NameSet
 735 namesOfType (TyVarTy tv)                = unitNameSet (getName tv)
 736 namesOfType (TyConApp tycon tys)        = unitNameSet (getName tycon) `unionNameSets`
 737                                           namesOfTypes tys
 738 namesOfType (NoteTy (SynNote ty1) ty2)  = namesOfType ty1
 739 namesOfType (NoteTy other_note    ty2)  = namesOfType ty2
 740 namesOfType (FunTy arg res)             = namesOfType arg `unionNameSets` namesOfType res
 741 namesOfType (AppTy fun arg)             = namesOfType fun `unionNameSets` namesOfType arg
 742 namesOfType (ForAllTy tyvar ty)         = namesOfType ty `minusNameSet` unitNameSet (getName tyvar)
 743
 744 namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys
 745 \end{code}
 746
 747
 748 %************************************************************************
 749 %*                                                                      *
 750 \subsection{TidyType}
 751 %*                                                                      *
 752 %************************************************************************
 753
 754 tidyTy tidies up a type for printing in an error message, or in
 755 an interface file.
 756
 757 It doesn't change the uniques at all, just the print names.
 758
 759 \begin{code}
 760 tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
 761 tidyTyVar env@(tidy_env, subst) tyvar
 762   = case lookupVarEnv subst tyvar of
 763
 764         Just tyvar' ->  -- Already substituted
 765                 (env, tyvar')
 766
 767         Nothing ->      -- Make a new nice name for it
 768
 769                 case tidyOccName tidy_env (getOccName name) of
 770                     (tidy', occ') ->    -- New occname reqd
 771                                 ((tidy', subst'), tyvar')
 772                               where
 773                                 subst' = extendVarEnv subst tyvar tyvar'
 774                                 tyvar' = setTyVarName tyvar name'
 775                                 name'  = mkLocalName (getUnique name) occ' noSrcLoc
 776                                         -- Note: make a *user* tyvar, so it printes nicely
 777                                         -- Could extract src loc, but no need.
 778   where
 779     name = tyVarName tyvar
 780
 781 tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars
 782
 783 tidyType :: TidyEnv -> Type -> Type
 784 tidyType env@(tidy_env, subst) ty
 785   = go ty
 786   where
 787     go (TyVarTy tv)         = case lookupVarEnv subst tv of
 788                                 Nothing  -> TyVarTy tv
 789                                 Just tv' -> TyVarTy tv'
 790     go (TyConApp tycon tys) = let args = map go tys
 791                               in args `seqList` TyConApp tycon args
 792     go (NoteTy note ty)     = (NoteTy SAPPLY (go_note note)) SAPPLY (go ty)
 793     go (AppTy fun arg)      = (AppTy SAPPLY (go fun)) SAPPLY (go arg)
 794     go (FunTy fun arg)      = (FunTy SAPPLY (go fun)) SAPPLY (go arg)
 795     go (ForAllTy tv ty)     = ForAllTy tvp SAPPLY (tidyType envp ty)
 796                               where
 797                                 (envp, tvp) = tidyTyVar env tv
 798
 799     go_note (SynNote ty)        = SynNote SAPPLY (go ty)
 800     go_note note@(FTVNote ftvs) = note  -- No need to tidy the free tyvars
 801     go_note note@(UsgNote _)    = note  -- Usage annotation is already tidy
 802     go_note note@(UsgForAll _)  = note  -- Uvar binder is already tidy
 803
 804 tidyTypes  env tys    = map (tidyType env) tys
 805 \end{code}
 806
 807
 808 @tidyOpenType@ grabs the free type variables, tidies them
 809 and then uses @tidyType@ to work over the type itself
 810
 811 \begin{code}
 812 tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
 813 tidyOpenType env ty
 814   = (env', tidyType env' ty)
 815   where
 816     env'         = foldl go env (varSetElems (tyVarsOfType ty))
 817     go env tyvar = fst (tidyTyVar env tyvar)
 818
 819 tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
 820 tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
 821
 822 tidyTopType :: Type -> Type
 823 tidyTopType ty = tidyType emptyTidyEnv ty
 824 \end{code}
 825
 826
 827 %************************************************************************
 828 %*                                                                      *
 829 \subsection{Boxedness and liftedness}
 830 %*                                                                      *
 831 %************************************************************************
 832
 833 \begin{code}
 834 isUnboxedType :: Type -> Bool
 835 isUnboxedType ty = not (isFollowableRep (typePrimRep ty))
 836
 837 isUnLiftedType :: Type -> Bool
 838 isUnLiftedType ty = case splitTyConApp_maybe ty of
 839                            Just (tc, ty_args) -> isUnLiftedTyCon tc
 840                            other              -> False
 841
 842 isUnboxedTupleType :: Type -> Bool
 843 isUnboxedTupleType ty = case splitTyConApp_maybe ty of
 844                            Just (tc, ty_args) -> isUnboxedTupleTyCon tc
 845                            other              -> False
 846
 847 -- Should only be applied to *types*; hence the assert
 848 isAlgType :: Type -> Bool
 849 isAlgType ty = case splitTyConApp_maybe ty of
 850                         Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
 851                                               isAlgTyCon tc
 852                         other              -> False
 853
 854 -- Should only be applied to *types*; hence the assert
 855 isDataType :: Type -> Bool
 856 isDataType ty = case splitTyConApp_maybe ty of
 857                         Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
 858                                               isDataTyCon tc
 859                         other              -> False
 860
 861 isNewType :: Type -> Bool
 862 isNewType ty = case splitTyConApp_maybe ty of
 863                         Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
 864                                               isNewTyCon tc
 865                         other              -> False
 866
 867 typePrimRep :: Type -> PrimRep
 868 typePrimRep ty = case splitTyConApp_maybe ty of
 869                    Just (tc, ty_args) -> tyConPrimRep tc
 870                    other              -> PtrRep
 871 \end{code}
 872
 873
 874 %************************************************************************
 875 %*                                                                      *
 876 \subsection{Sequencing on types
 877 %*                                                                      *
 878 %************************************************************************
 879
 880 \begin{code}
 881 seqType :: Type -> ()
 882 seqType (TyVarTy tv)      = tv `seq` ()
 883 seqType (AppTy t1 t2)     = seqType t1 `seq` seqType t2
 884 seqType (FunTy t1 t2)     = seqType t1 `seq` seqType t2
 885 seqType (NoteTy note t2)  = seqNote note `seq` seqType t2
 886 seqType (TyConApp tc tys) = tc `seq` seqTypes tys
 887 seqType (ForAllTy tv ty)  = tv `seq` seqType ty
 888
 889 seqTypes :: [Type] -> ()
 890 seqTypes []       = ()
 891 seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
 892
 893 seqNote :: TyNote -> ()
 894 seqNote (SynNote ty)  = seqType ty
 895 seqNote (FTVNote set) = sizeUniqSet set `seq` ()
 896 seqNote (UsgNote usg) = usg `seq` ()
 897 \end{code}
 898