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