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,                         -- KX and BX respectively
  13         boxedBoxity, unboxedBoxity,                     -- :: BX
  14         openKindCon,                                    -- :: KX
  15         typeCon,                                        -- :: BX -> KX
  16         boxedTypeKind, unboxedTypeKind, openTypeKind,   -- :: KX
  17         mkArrowKind, mkArrowKinds,                      -- :: KX -> KX -> KX
  18
  19         funTyCon,
  20
  21         usageKindCon,                                   -- :: KX
  22         usageTypeKind,                                  -- :: KX
  23         usOnceTyCon, usManyTyCon,                       -- :: $
  24         usOnce, usMany,                                 -- :: $
  25
  26         -- exports from this module:
  27         hasMoreBoxityInfo, defaultKind,
  28
  29         mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy,
  30
  31         mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe,
  32
  33         mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys, splitFunTysN,
  34         funResultTy, funArgTy, zipFunTys,
  35
  36         mkTyConApp, mkTyConTy, splitTyConApp_maybe,
  37         splitAlgTyConApp_maybe, splitAlgTyConApp,
  38
  39         mkUTy, splitUTy, splitUTy_maybe,
  40         isUTy, uaUTy, unUTy, liftUTy, mkUTyM,
  41         isUsageKind, isUsage, isUTyVar,
  42
  43         -- Predicates and the like
  44         mkDictTy, mkDictTys, mkPredTy, splitPredTy_maybe,
  45         splitDictTy, splitDictTy_maybe, isDictTy, predRepTy, splitDFunTy,
  46
  47         mkSynTy, deNoteType,
  48
  49         repType, splitRepFunTys, splitNewType_maybe, typePrimRep,
  50
  51         mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
  52         applyTy, applyTys, hoistForAllTys, isForAllTy,
  53
  54         TauType, RhoType, SigmaType, PredType(..), ThetaType,
  55         ClassPred, ClassContext, mkClassPred,
  56         getClassTys_maybe, ipName_maybe, classesOfPreds,
  57         isTauTy, mkRhoTy, splitRhoTy,
  58         mkSigmaTy, isSigmaTy, splitSigmaTy,
  59         getDFunTyKey,
  60
  61         -- Lifting and boxity
  62         isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, isDataType, isNewType,
  63
  64         -- Free variables
  65         tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
  66         namesOfType, usageAnnOfType, typeKind, addFreeTyVars,
  67
  68         -- Tidying up for printing
  69         tidyType,     tidyTypes,
  70         tidyOpenType, tidyOpenTypes,
  71         tidyTyVar,    tidyTyVars,
  72         tidyTopType,
  73
  74         -- Seq
  75         seqType, seqTypes
  76
  77     ) where
  78
  79 #include "HsVersions.h"
  80
  81 -- We import the representation and primitive functions from TypeRep.
  82 -- Many things are reexported, but not the representation!
  83
  84 import TypeRep
  85
  86 -- Other imports:
  87
  88 import {-# SOURCE #-}   DataCon( DataCon )
  89 import {-# SOURCE #-}   PprType( pprType )      -- Only called in debug messages
  90 import {-# SOURCE #-}   Subst  ( mkTyVarSubst, substTy )
  91
  92 -- friends:
  93 import Var      ( Var, TyVar, tyVarKind, tyVarName, setTyVarName )
  94 import VarEnv
  95 import VarSet
  96
  97 import Name     ( Name, NamedThing(..), OccName, mkLocalName, tidyOccName )
  98 import NameSet
  99 import Class    ( classTyCon, Class, ClassPred, ClassContext )
 100 import TyCon    ( TyCon,
 101                   isUnboxedTupleTyCon, isUnLiftedTyCon,
 102                   isFunTyCon, isDataTyCon, isNewTyCon, newTyConRep,
 103                   isAlgTyCon, isSynTyCon, tyConArity,
 104                   tyConKind, tyConDataCons, getSynTyConDefn,
 105                   tyConPrimRep
 106                 )
 107
 108 -- others
 109 import Maybes           ( maybeToBool )
 110 import SrcLoc           ( noSrcLoc )
 111 import PrimRep          ( PrimRep(..), isFollowableRep )
 112 import Unique           ( Uniquable(..) )
 113 import Util             ( mapAccumL, seqList, thenCmp )
 114 import Outputable
 115 import UniqSet          ( sizeUniqSet )         -- Should come via VarSet
 116 \end{code}
 117
 118
 119 %************************************************************************
 120 %*                                                                      *
 121 \subsection{Stuff to do with kinds.}
 122 %*                                                                      *
 123 %************************************************************************
 124
 125 \begin{code}
 126 hasMoreBoxityInfo :: Kind -> Kind -> Bool
 127 hasMoreBoxityInfo k1 k2
 128   | k2 == openTypeKind = True
 129   | otherwise          = k1 == k2
 130
 131 defaultKind :: Kind -> Kind
 132 -- Used when generalising: default kind '?' to '*'
 133 defaultKind kind | kind == openTypeKind = boxedTypeKind
 134                  | otherwise            = kind
 135 \end{code}
 136
 137
 138 %************************************************************************
 139 %*                                                                      *
 140 \subsection{Constructor-specific functions}
 141 %*                                                                      *
 142 %************************************************************************
 143
 144
 145 ---------------------------------------------------------------------
 146                                 TyVarTy
 147                                 ~~~~~~~
 148 \begin{code}
 149 mkTyVarTy  :: TyVar   -> Type
 150 mkTyVarTy  = TyVarTy
 151
 152 mkTyVarTys :: [TyVar] -> [Type]
 153 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
 154
 155 getTyVar :: String -> Type -> TyVar
 156 getTyVar msg (TyVarTy tv) = tv
 157 getTyVar msg (PredTy p)   = getTyVar msg (predRepTy p)
 158 getTyVar msg (NoteTy _ t) = getTyVar msg t
 159 getTyVar msg ty@(UsageTy _ _) = pprPanic "getTyVar: UTy:" (text msg $$ pprType ty)
 160 getTyVar msg other        = panic ("getTyVar: " ++ msg)
 161
 162 getTyVar_maybe :: Type -> Maybe TyVar
 163 getTyVar_maybe (TyVarTy tv) = Just tv
 164 getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t
 165 getTyVar_maybe (PredTy p)   = getTyVar_maybe (predRepTy p)
 166 getTyVar_maybe ty@(UsageTy _ _) = pprPanic "getTyVar_maybe: UTy:" (pprType ty)
 167 getTyVar_maybe other        = Nothing
 168
 169 isTyVarTy :: Type -> Bool
 170 isTyVarTy (TyVarTy tv)  = True
 171 isTyVarTy (NoteTy _ ty) = isTyVarTy ty
 172 isTyVarTy (PredTy p)    = isTyVarTy (predRepTy p)
 173 isTyVarTy ty@(UsageTy _ _) = pprPanic "isTyVarTy: UTy:" (pprType ty)
 174 isTyVarTy other         = False
 175 \end{code}
 176
 177
 178 ---------------------------------------------------------------------
 179                                 AppTy
 180                                 ~~~~~
 181 We need to be pretty careful with AppTy to make sure we obey the
 182 invariant that a TyConApp is always visibly so.  mkAppTy maintains the
 183 invariant: use it.
 184
 185 \begin{code}
 186 mkAppTy orig_ty1 orig_ty2
 187   = ASSERT( not (isPredTy orig_ty1) )   -- Predicates are of kind *
 188     UASSERT2( not (isUTy orig_ty2), pprType orig_ty1 <+> pprType orig_ty2 )
 189                                         -- argument must be unannotated
 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_ty2])
 194     mk_app ty@(UsageTy _ _)  = pprPanic "mkAppTy: UTy:" (pprType ty)
 195     mk_app ty1               = AppTy orig_ty1 orig_ty2
 196
 197 mkAppTys :: Type -> [Type] -> Type
 198 mkAppTys orig_ty1 []        = orig_ty1
 199         -- This check for an empty list of type arguments
 200         -- avoids the needless loss of a type synonym constructor.
 201         -- For example: mkAppTys Rational []
 202         --   returns to (Ratio Integer), which has needlessly lost
 203         --   the Rational part.
 204 mkAppTys orig_ty1 orig_tys2
 205   = ASSERT( not (isPredTy orig_ty1) )   -- Predicates are of kind *
 206     UASSERT2( not (any isUTy orig_tys2), pprType orig_ty1 <+> fsep (map pprType orig_tys2) )
 207                                         -- arguments must be unannotated
 208     mk_app orig_ty1
 209   where
 210     mk_app (NoteTy _ ty1)    = mk_app ty1
 211     mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
 212     mk_app ty@(UsageTy _ _)  = pprPanic "mkAppTys: UTy:" (pprType ty)
 213     mk_app ty1               = foldl AppTy orig_ty1 orig_tys2
 214
 215 splitAppTy_maybe :: Type -> Maybe (Type, Type)
 216 splitAppTy_maybe (FunTy ty1 ty2)   = Just (TyConApp funTyCon [unUTy ty1], unUTy ty2)
 217 splitAppTy_maybe (AppTy ty1 ty2)   = Just (ty1, ty2)
 218 splitAppTy_maybe (NoteTy _ ty)     = splitAppTy_maybe ty
 219 splitAppTy_maybe (PredTy p)        = splitAppTy_maybe (predRepTy p)
 220 splitAppTy_maybe (TyConApp tc [])  = Nothing
 221 splitAppTy_maybe (TyConApp tc tys) = split tys []
 222                             where
 223                                split [ty2]    acc = Just (TyConApp tc (reverse acc), ty2)
 224                                split (ty:tys) acc = split tys (ty:acc)
 225
 226 splitAppTy_maybe ty@(UsageTy _ _)  = pprPanic "splitAppTy_maybe: UTy:" (pprType ty)
 227 splitAppTy_maybe other            = Nothing
 228
 229 splitAppTy :: Type -> (Type, Type)
 230 splitAppTy ty = case splitAppTy_maybe ty of
 231                         Just pr -> pr
 232                         Nothing -> panic "splitAppTy"
 233
 234 splitAppTys :: Type -> (Type, [Type])
 235 splitAppTys ty = split ty ty []
 236   where
 237     split orig_ty (AppTy ty arg)        args = split ty ty (arg:args)
 238     split orig_ty (NoteTy _ ty)         args = split orig_ty ty args
 239     split orig_ty (PredTy p)            args = split orig_ty (predRepTy p) args
 240     split orig_ty (FunTy ty1 ty2)       args = ASSERT( null args )
 241                                                (TyConApp funTyCon [], [unUTy ty1,unUTy ty2])
 242     split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
 243     split orig_ty (UsageTy _ _)         args = pprPanic "splitAppTys: UTy:" (pprType orig_ty)
 244     split orig_ty ty                    args = (orig_ty, args)
 245 \end{code}
 246
 247
 248 ---------------------------------------------------------------------
 249                                 FunTy
 250                                 ~~~~~
 251
 252 \begin{code}
 253 mkFunTy :: Type -> Type -> Type
 254 mkFunTy arg res = UASSERT2( isUTy arg && isUTy res, pprType arg <+> pprType res )
 255                   FunTy arg res
 256
 257 mkFunTys :: [Type] -> Type -> Type
 258 mkFunTys tys ty = UASSERT2( all isUTy (ty:tys), fsep (map pprType (tys++[ty])) )
 259                   foldr FunTy ty tys
 260
 261 splitFunTy :: Type -> (Type, Type)
 262 splitFunTy (FunTy arg res) = (arg, res)
 263 splitFunTy (NoteTy _ ty)   = splitFunTy ty
 264 splitFunTy (PredTy p)      = splitFunTy (predRepTy p)
 265 splitFunTy ty@(UsageTy _ _) = pprPanic "splitFunTy: UTy:" (pprType ty)
 266
 267 splitFunTy_maybe :: Type -> Maybe (Type, Type)
 268 splitFunTy_maybe (FunTy arg res) = Just (arg, res)
 269 splitFunTy_maybe (NoteTy _ ty)   = splitFunTy_maybe ty
 270 splitFunTy_maybe (PredTy p)      = splitFunTy_maybe (predRepTy p)
 271 splitFunTy_maybe ty@(UsageTy _ _) = pprPanic "splitFunTy_maybe: UTy:" (pprType ty)
 272 splitFunTy_maybe other           = Nothing
 273
 274 splitFunTys :: Type -> ([Type], Type)
 275 splitFunTys ty = split [] ty ty
 276   where
 277     split args orig_ty (FunTy arg res) = split (arg:args) res res
 278     split args orig_ty (NoteTy _ ty)   = split args orig_ty ty
 279     split args orig_ty (PredTy p)      = split args orig_ty (predRepTy p)
 280     split args orig_ty (UsageTy _ _)   = pprPanic "splitFunTys: UTy:" (pprType orig_ty)
 281     split args orig_ty ty              = (reverse args, orig_ty)
 282
 283 splitFunTysN :: String -> Int -> Type -> ([Type], Type)
 284 splitFunTysN msg orig_n orig_ty = split orig_n [] orig_ty orig_ty
 285   where
 286     split 0 args syn_ty ty              = (reverse args, syn_ty)
 287     split n args syn_ty (FunTy arg res) = split (n-1) (arg:args) res    res
 288     split n args syn_ty (NoteTy _ ty)   = split n     args       syn_ty ty
 289     split n args syn_ty (PredTy p)      = split n     args       syn_ty (predRepTy p)
 290     split n args syn_ty (UsageTy _ _)   = pprPanic "splitFunTysN: UTy:" (pprType orig_ty)
 291     split n args syn_ty ty              = pprPanic ("splitFunTysN: " ++ msg) (int orig_n <+> pprType orig_ty)
 292
 293 zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type)
 294 zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
 295   where
 296     split acc []     nty ty              = (reverse acc, nty)
 297     split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res
 298     split acc xs     nty (NoteTy _ ty)   = split acc           xs nty ty
 299     split acc xs     nty (PredTy p)      = split acc           xs nty (predRepTy p)
 300     split acc xs     nty (UsageTy _ _)   = pprPanic "zipFunTys: UTy:" (ppr orig_xs <+> pprType orig_ty)
 301     split acc (x:xs) nty ty              = pprPanic "zipFunTys" (ppr orig_xs <+> pprType orig_ty)
 302
 303 funResultTy :: Type -> Type
 304 funResultTy (FunTy arg res) = res
 305 funResultTy (NoteTy _ ty)   = funResultTy ty
 306 funResultTy (PredTy p)      = funResultTy (predRepTy p)
 307 funResultTy (UsageTy _ ty)  = funResultTy ty
 308 funResultTy ty              = pprPanic "funResultTy" (pprType ty)
 309
 310 funArgTy :: Type -> Type
 311 funArgTy (FunTy arg res) = arg
 312 funArgTy (NoteTy _ ty)   = funArgTy ty
 313 funArgTy (PredTy p)      = funArgTy (predRepTy p)
 314 funArgTy (UsageTy _ ty)  = funArgTy ty
 315 funArgTy ty              = pprPanic "funArgTy" (pprType ty)
 316 \end{code}
 317
 318
 319 ---------------------------------------------------------------------
 320                                 TyConApp
 321                                 ~~~~~~~~
 322
 323 \begin{code}
 324 mkTyConApp :: TyCon -> [Type] -> Type
 325 mkTyConApp tycon tys
 326   | isFunTyCon tycon && length tys == 2
 327   = case tys of
 328         (ty1:ty2:_) -> FunTy (mkUTyM ty1) (mkUTyM ty2)
 329
 330   | otherwise
 331   = ASSERT(not (isSynTyCon tycon))
 332     UASSERT2( not (any isUTy tys), ppr tycon <+> fsep (map pprType tys) )
 333     TyConApp tycon tys
 334
 335 mkTyConTy :: TyCon -> Type
 336 mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) )
 337                   TyConApp tycon []
 338
 339 -- splitTyConApp "looks through" synonyms, because they don't
 340 -- mean a distinct type, but all other type-constructor applications
 341 -- including functions are returned as Just ..
 342
 343 splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
 344 splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
 345 splitTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [unUTy arg,unUTy res])
 346 splitTyConApp_maybe (NoteTy _ ty)     = splitTyConApp_maybe ty
 347 splitTyConApp_maybe (PredTy p)        = splitTyConApp_maybe (predRepTy p)
 348 splitTyConApp_maybe (UsageTy _ ty)    = splitTyConApp_maybe ty
 349 splitTyConApp_maybe other             = Nothing
 350
 351 -- splitAlgTyConApp_maybe looks for
 352 --      *saturated* applications of *algebraic* data types
 353 -- "Algebraic" => newtype, data type, or dictionary (not function types)
 354 -- We return the constructors too, so there had better be some.
 355
 356 splitAlgTyConApp_maybe :: Type -> Maybe (TyCon, [Type], [DataCon])
 357 splitAlgTyConApp_maybe (TyConApp tc tys)
 358   | isAlgTyCon tc &&
 359     tyConArity tc == length tys      = Just (tc, tys, tyConDataCons tc)
 360 splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty
 361 splitAlgTyConApp_maybe (PredTy p)    = splitAlgTyConApp_maybe (predRepTy p)
 362 splitAlgTyConApp_maybe (UsageTy _ ty)= splitAlgTyConApp_maybe ty
 363 splitAlgTyConApp_maybe other         = Nothing
 364
 365 splitAlgTyConApp :: Type -> (TyCon, [Type], [DataCon])
 366         -- Here the "algebraic" property is an *assertion*
 367 splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == length tys )
 368                                      (tc, tys, tyConDataCons tc)
 369 splitAlgTyConApp (NoteTy _ ty)     = splitAlgTyConApp ty
 370 splitAlgTyConApp (PredTy p)        = splitAlgTyConApp (predRepTy p)
 371 splitAlgTyConApp (UsageTy _ ty)    = splitAlgTyConApp ty
 372 #ifdef DEBUG
 373 splitAlgTyConApp ty = pprPanic "splitAlgTyConApp" (pprType ty)
 374 #endif
 375 \end{code}
 376
 377
 378 ---------------------------------------------------------------------
 379                                 SynTy
 380                                 ~~~~~
 381
 382 \begin{code}
 383 mkSynTy syn_tycon tys
 384   = ASSERT( isSynTyCon syn_tycon )
 385     ASSERT( length tyvars == length tys )
 386     NoteTy (SynNote (TyConApp syn_tycon tys))
 387            (substTy (mkTyVarSubst tyvars tys) body)
 388   where
 389     (tyvars, body) = getSynTyConDefn syn_tycon
 390
 391 deNoteType :: Type -> Type
 392         -- Remove synonyms, but not Preds
 393 deNoteType ty@(TyVarTy tyvar)   = ty
 394 deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys)
 395 deNoteType (PredTy p)           = PredTy (deNotePred p)
 396 deNoteType (NoteTy _ ty)        = deNoteType ty
 397 deNoteType (AppTy fun arg)      = AppTy (deNoteType fun) (deNoteType arg)
 398 deNoteType (FunTy fun arg)      = FunTy (deNoteType fun) (deNoteType arg)
 399 deNoteType (ForAllTy tv ty)     = ForAllTy tv (deNoteType ty)
 400 deNoteType (UsageTy u ty)       = UsageTy u (deNoteType ty)
 401
 402 deNotePred :: PredType -> PredType
 403 deNotePred (Class c tys) = Class c (map deNoteType tys)
 404 deNotePred (IParam n ty) = IParam n (deNoteType ty)
 405 \end{code}
 406
 407 Notes on type synonyms
 408 ~~~~~~~~~~~~~~~~~~~~~~
 409 The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
 410 to return type synonyms whereever possible. Thus
 411
 412         type Foo a = a -> a
 413
 414 we want
 415         splitFunTys (a -> Foo a) = ([a], Foo a)
 416 not                                ([a], a -> a)
 417
 418 The reason is that we then get better (shorter) type signatures in
 419 interfaces.  Notably this plays a role in tcTySigs in TcBinds.lhs.
 420
 421
 422                 Representation types
 423                 ~~~~~~~~~~~~~~~~~~~~
 424
 425 repType looks through
 426         (a) for-alls, and
 427         (b) newtypes
 428         (c) synonyms
 429         (d) predicates
 430         (e) usage annotations
 431 It's useful in the back end where we're not
 432 interested in newtypes anymore.
 433
 434 \begin{code}
 435 repType :: Type -> Type
 436 repType (ForAllTy _ ty) = repType ty
 437 repType (NoteTy   _ ty) = repType ty
 438 repType (PredTy  p)     = repType (predRepTy p)
 439 repType (UsageTy  _ ty) = repType ty
 440 repType ty              = case splitNewType_maybe ty of
 441                             Just ty' -> repType ty'     -- Still re-apply repType in case of for-all
 442                             Nothing  -> ty
 443
 444 splitRepFunTys :: Type -> ([Type], Type)
 445 -- Like splitFunTys, but looks through newtypes and for-alls
 446 splitRepFunTys ty = split [] (repType ty)
 447   where
 448     split args (FunTy arg res)  = split (arg:args) (repType res)
 449     split args ty               = (reverse args, ty)
 450
 451 typePrimRep :: Type -> PrimRep
 452 typePrimRep ty = case repType ty of
 453                    TyConApp tc _ -> tyConPrimRep tc
 454                    FunTy _ _     -> PtrRep
 455                    AppTy _ _     -> PtrRep      -- ??
 456                    TyVarTy _     -> PtrRep
 457
 458 splitNewType_maybe :: Type -> Maybe Type
 459 -- Find the representation of a newtype, if it is one
 460 -- Looks through multiple levels of newtype, but does not look through for-alls
 461 splitNewType_maybe (NoteTy _ ty)     = splitNewType_maybe ty
 462 splitNewType_maybe (PredTy p)        = splitNewType_maybe (predRepTy p)
 463 splitNewType_maybe (UsageTy _ ty)    = splitNewType_maybe ty
 464 splitNewType_maybe (TyConApp tc tys) = case newTyConRep tc of
 465                                          Just rep_ty -> ASSERT( length tys == tyConArity tc )
 466                                                 -- The assert should hold because repType should
 467                                                 -- only be applied to *types* (of kind *)
 468                                                         Just (applyTys rep_ty tys)
 469                                          Nothing     -> Nothing
 470 splitNewType_maybe other             = Nothing
 471 \end{code}
 472
 473
 474
 475 ---------------------------------------------------------------------
 476                                 ForAllTy
 477                                 ~~~~~~~~
 478
 479 \begin{code}
 480 mkForAllTy :: TyVar -> Type -> Type
 481 mkForAllTy tyvar ty
 482   = mkForAllTys [tyvar] ty
 483
 484 mkForAllTys :: [TyVar] -> Type -> Type
 485 mkForAllTys tyvars ty
 486   = case splitUTy_maybe ty of
 487       Just (u,ty1) -> UASSERT2( not (mkVarSet tyvars `intersectsVarSet` tyVarsOfType u),
 488                                 ptext SLIT("mkForAllTys: usage scope")
 489                                 <+> ppr tyvars <+> pprType ty )
 490                       mkUTy u (foldr ForAllTy ty1 tyvars)  -- we lift usage annotations over foralls
 491       Nothing      -> foldr ForAllTy ty tyvars
 492
 493 isForAllTy :: Type -> Bool
 494 isForAllTy (NoteTy _ ty)  = isForAllTy ty
 495 isForAllTy (ForAllTy _ _) = True
 496 isForAllTy (UsageTy _ ty) = isForAllTy ty
 497 isForAllTy other_ty       = False
 498
 499 splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
 500 splitForAllTy_maybe ty = splitFAT_m ty
 501   where
 502     splitFAT_m (NoteTy _ ty)            = splitFAT_m ty
 503     splitFAT_m (PredTy p)               = splitFAT_m (predRepTy p)
 504     splitFAT_m (ForAllTy tyvar ty)      = Just(tyvar, ty)
 505     splitFAT_m (UsageTy _ ty)           = splitFAT_m ty
 506     splitFAT_m _                        = Nothing
 507
 508 splitForAllTys :: Type -> ([TyVar], Type)
 509 splitForAllTys ty = split ty ty []
 510    where
 511      split orig_ty (ForAllTy tv ty)       tvs = split ty ty (tv:tvs)
 512      split orig_ty (NoteTy _ ty)          tvs = split orig_ty ty tvs
 513      split orig_ty (PredTy p)             tvs = split orig_ty (predRepTy p) tvs
 514      split orig_ty (UsageTy _ ty)         tvs = split orig_ty ty tvs
 515      split orig_ty t                      tvs = (reverse tvs, orig_ty)
 516 \end{code}
 517
 518 -- (mkPiType now in CoreUtils)
 519
 520 Applying a for-all to its arguments.  Lift usage annotation as required.
 521
 522 \begin{code}
 523 applyTy :: Type -> Type -> Type
 524 applyTy (PredTy p)                      arg = applyTy (predRepTy p) arg
 525 applyTy (NoteTy _ fun)                  arg = applyTy fun arg
 526 applyTy (ForAllTy tv ty)                arg = UASSERT2( not (isUTy arg),
 527                                                         ptext SLIT("applyTy")
 528                                                         <+> pprType ty <+> pprType arg )
 529                                               substTy (mkTyVarSubst [tv] [arg]) ty
 530 applyTy (UsageTy u ty)                  arg = UsageTy u (applyTy ty arg)
 531 applyTy other                           arg = panic "applyTy"
 532
 533 applyTys :: Type -> [Type] -> Type
 534 applyTys fun_ty arg_tys
 535  = UASSERT2( not (any isUTy arg_tys), ptext SLIT("applyTys") <+> pprType fun_ty )
 536    (case mu of
 537       Just u  -> UsageTy u
 538       Nothing -> id) $
 539    substTy (mkTyVarSubst tvs arg_tys) ty
 540  where
 541    (mu, tvs, ty) = split fun_ty arg_tys
 542
 543    split fun_ty               []         = (Nothing, [], fun_ty)
 544    split (NoteTy _ fun_ty)    args       = split fun_ty args
 545    split (PredTy p)           args       = split (predRepTy p) args
 546    split (ForAllTy tv fun_ty) (arg:args) = case split fun_ty args of
 547                                                   (mu, tvs, ty) -> (mu, tv:tvs, ty)
 548    split (UsageTy u ty)       args       = case split ty args of
 549                                                   (Nothing, tvs, ty) -> (Just u, tvs, ty)
 550                                                   (Just _ , _  , _ ) -> pprPanic "applyTys:"
 551                                                                           (pprType fun_ty)
 552    split other_ty             args       = panic "applyTys"
 553 \end{code}
 554
 555 \begin{code}
 556 hoistForAllTys :: Type -> Type
 557         -- Move all the foralls to the top
 558         -- e.g.  T -> forall a. a  ==>   forall a. T -> a
 559         -- Careful: LOSES USAGE ANNOTATIONS!
 560 hoistForAllTys ty
 561   = case hoist ty of { (tvs, body) -> mkForAllTys tvs body }
 562   where
 563     hoist :: Type -> ([TyVar], Type)
 564     hoist ty = case splitFunTys    ty  of { (args, res) ->
 565                case splitForAllTys res of {
 566                   ([], body)  -> ([], ty) ;
 567                   (tvs1, body1) -> case hoist body1 of { (tvs2,body2) ->
 568                                    (tvs1 ++ tvs2, mkFunTys args body2)
 569                }}}
 570 \end{code}
 571
 572
 573 ---------------------------------------------------------------------
 574                                 UsageTy
 575                                 ~~~~~~~
 576
 577 Constructing and taking apart usage types.
 578
 579 \begin{code}
 580 mkUTy :: Type -> Type -> Type
 581 mkUTy u ty
 582   = ASSERT2( typeKind u == usageTypeKind, ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty )
 583     UASSERT2( not (isUTy ty), ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty )
 584     -- if u == usMany then ty else  : ToDo? KSW 2000-10
 585 #ifdef DO_USAGES
 586     UsageTy u ty
 587 #else
 588     ty
 589 #endif
 590
 591 splitUTy :: Type -> (Type {- :: $ -}, Type)
 592 splitUTy orig_ty
 593   = case splitUTy_maybe orig_ty of
 594       Just (u,ty) -> (u,ty)
 595 #ifdef DO_USAGES
 596       Nothing     -> pprPanic "splitUTy:" (pprType orig_ty)
 597 #else
 598       Nothing     -> (usMany,orig_ty)  -- default annotation ToDo KSW 2000-10
 599 #endif
 600
 601 splitUTy_maybe :: Type -> Maybe (Type {- :: $ -}, Type)
 602 splitUTy_maybe (UsageTy u ty) = Just (u,ty)
 603 splitUTy_maybe (NoteTy _ ty)  = splitUTy_maybe ty
 604 splitUTy_maybe other_ty       = Nothing
 605
 606 isUTy :: Type -> Bool
 607   -- has usage annotation
 608 isUTy = maybeToBool . splitUTy_maybe
 609
 610 uaUTy :: Type -> Type
 611   -- extract annotation
 612 uaUTy = fst . splitUTy
 613
 614 unUTy :: Type -> Type
 615   -- extract unannotated type
 616 unUTy = snd . splitUTy
 617 \end{code}
 618
 619 \begin{code}
 620 liftUTy :: (Type -> Type) -> Type -> Type
 621   -- lift outer usage annot over operation on unannotated types
 622 liftUTy f ty
 623   = let
 624       (u,ty') = splitUTy ty
 625     in
 626     mkUTy u (f ty')
 627 \end{code}
 628
 629 \begin{code}
 630 mkUTyM :: Type -> Type
 631   -- put TOP (no info) annotation on unannotated type
 632 mkUTyM ty = mkUTy usMany ty
 633 \end{code}
 634
 635 \begin{code}
 636 isUsageKind :: Kind -> Bool
 637 isUsageKind k
 638   = ASSERT( typeKind k == superKind )
 639     k == usageTypeKind
 640
 641 isUsage :: Type -> Bool
 642 isUsage ty
 643   = isUsageKind (typeKind ty)
 644
 645 isUTyVar :: Var -> Bool
 646 isUTyVar v
 647   = isUsageKind (tyVarKind v)
 648 \end{code}
 649
 650
 651 %************************************************************************
 652 %*                                                                      *
 653 \subsection{Stuff to do with the source-language types}
 654
 655 PredType and ThetaType are used in types for expressions and bindings.
 656 ClassPred and ClassContext are used in class and instance declarations.
 657 %*                                                                      *
 658 %************************************************************************
 659
 660 "Dictionary" types are just ordinary data types, but you can
 661 tell from the type constructor whether it's a dictionary or not.
 662
 663 \begin{code}
 664 mkClassPred clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) )
 665                        Class clas tys
 666
 667 mkDictTy :: Class -> [Type] -> Type
 668 mkDictTy clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) )
 669                     mkPredTy (Class clas tys)
 670
 671 mkDictTys :: ClassContext -> [Type]
 672 mkDictTys cxt = [mkDictTy cls tys | (cls,tys) <- cxt]
 673
 674 mkPredTy :: PredType -> Type
 675 mkPredTy pred = PredTy pred
 676
 677 predRepTy :: PredType -> Type
 678 -- Convert a predicate to its "representation type";
 679 -- the type of evidence for that predicate, which is actually passed at runtime
 680 predRepTy (Class clas tys) = TyConApp (classTyCon clas) tys
 681 predRepTy (IParam n ty)    = ty
 682
 683 isPredTy :: Type -> Bool
 684 isPredTy (NoteTy _ ty) = isPredTy ty
 685 isPredTy (PredTy _)    = True
 686 isPredTy (UsageTy _ ty)= isPredTy ty
 687 isPredTy _             = False
 688
 689 isDictTy :: Type -> Bool
 690 isDictTy (NoteTy _ ty)        = isDictTy ty
 691 isDictTy (PredTy (Class _ _)) = True
 692 isDictTy (UsageTy _ ty)       = isDictTy ty
 693 isDictTy other                = False
 694
 695 splitPredTy_maybe :: Type -> Maybe PredType
 696 splitPredTy_maybe (NoteTy _ ty) = splitPredTy_maybe ty
 697 splitPredTy_maybe (PredTy p)    = Just p
 698 splitPredTy_maybe (UsageTy _ ty)= splitPredTy_maybe ty
 699 splitPredTy_maybe other         = Nothing
 700
 701 splitDictTy :: Type -> (Class, [Type])
 702 splitDictTy (NoteTy _ ty) = splitDictTy ty
 703 splitDictTy (PredTy (Class clas tys)) = (clas, tys)
 704
 705 splitDictTy_maybe :: Type -> Maybe (Class, [Type])
 706 splitDictTy_maybe (NoteTy _ ty) = Just (splitDictTy ty)
 707 splitDictTy_maybe (PredTy (Class clas tys)) = Just (clas, tys)
 708 splitDictTy_maybe other                     = Nothing
 709
 710 splitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type])
 711 -- Split the type of a dictionary function
 712 splitDFunTy ty
 713   = case splitSigmaTy ty of { (tvs, theta, tau) ->
 714     case splitDictTy tau of { (clas, tys) ->
 715     (tvs, theta, clas, tys) }}
 716
 717 getClassTys_maybe :: PredType -> Maybe ClassPred
 718 getClassTys_maybe (Class clas tys) = Just (clas, tys)
 719 getClassTys_maybe _                = Nothing
 720
 721 ipName_maybe :: PredType -> Maybe Name
 722 ipName_maybe (IParam n _) = Just n
 723 ipName_maybe _            = Nothing
 724
 725 classesOfPreds :: ThetaType -> ClassContext
 726 classesOfPreds theta = [(clas,tys) | Class clas tys <- theta]
 727 \end{code}
 728
 729 @isTauTy@ tests for nested for-alls.
 730
 731 \begin{code}
 732 isTauTy :: Type -> Bool
 733 isTauTy (TyVarTy v)      = True
 734 isTauTy (TyConApp _ tys) = all isTauTy tys
 735 isTauTy (AppTy a b)      = isTauTy a && isTauTy b
 736 isTauTy (FunTy a b)      = isTauTy a && isTauTy b
 737 isTauTy (PredTy p)       = isTauTy (predRepTy p)
 738 isTauTy (NoteTy _ ty)    = isTauTy ty
 739 isTauTy (UsageTy _ ty)   = isTauTy ty
 740 isTauTy other            = False
 741 \end{code}
 742
 743 \begin{code}
 744 mkRhoTy :: [PredType] -> Type -> Type
 745 mkRhoTy theta ty = UASSERT2( not (isUTy ty), pprType ty )
 746                    foldr (\p r -> FunTy (mkUTyM (mkPredTy p)) (mkUTyM r)) ty theta
 747
 748 splitRhoTy :: Type -> ([PredType], Type)
 749 splitRhoTy ty = split ty ty []
 750  where
 751   split orig_ty (FunTy arg res) ts = case splitPredTy_maybe arg of
 752                                         Just p  -> split res res (p:ts)
 753                                         Nothing -> (reverse ts, orig_ty)
 754   split orig_ty (NoteTy _ ty)   ts = split orig_ty ty ts
 755   split orig_ty (UsageTy _ ty)  ts = split orig_ty ty ts
 756   split orig_ty ty              ts = (reverse ts, orig_ty)
 757 \end{code}
 758
 759
 760 isSigmaType returns true of any qualified type.  It doesn't *necessarily* have
 761 any foralls.  E.g.
 762         f :: (?x::Int) => Int -> Int
 763
 764 \begin{code}
 765 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
 766
 767 isSigmaTy :: Type -> Bool
 768 isSigmaTy (ForAllTy tyvar ty)   = True
 769 isSigmaTy (FunTy a b)           = isPredTy a
 770 isSigmaTy (NoteTy _ ty)         = isSigmaTy ty
 771 isSigmaTy (UsageTy _ ty)        = isSigmaTy ty
 772 isSigmaTy _                     = False
 773
 774 splitSigmaTy :: Type -> ([TyVar], [PredType], Type)
 775 splitSigmaTy ty =
 776   (tyvars, theta, tau)
 777  where
 778   (tyvars,rho) = splitForAllTys ty
 779   (theta,tau)  = splitRhoTy rho
 780 \end{code}
 781
 782 \begin{code}
 783 getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
 784                                 -- construct a dictionary function name
 785 getDFunTyKey (TyVarTy tv)    = getOccName tv
 786 getDFunTyKey (TyConApp tc _) = getOccName tc
 787 getDFunTyKey (AppTy fun _)   = getDFunTyKey fun
 788 getDFunTyKey (NoteTy _ t)    = getDFunTyKey t
 789 getDFunTyKey (FunTy arg _)   = getOccName funTyCon
 790 getDFunTyKey (ForAllTy _ t)  = getDFunTyKey t
 791 getDFunTyKey (UsageTy _ t)   = getDFunTyKey t
 792 -- PredTy shouldn't happen
 793 \end{code}
 794
 795
 796 %************************************************************************
 797 %*                                                                      *
 798 \subsection{Kinds and free variables}
 799 %*                                                                      *
 800 %************************************************************************
 801
 802 ---------------------------------------------------------------------
 803                 Finding the kind of a type
 804                 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 805 \begin{code}
 806 typeKind :: Type -> Kind
 807
 808 typeKind (TyVarTy tyvar)        = tyVarKind tyvar
 809 typeKind (TyConApp tycon tys)   = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys
 810 typeKind (NoteTy _ ty)          = typeKind ty
 811 typeKind (PredTy _)             = boxedTypeKind         -- Predicates are always
 812                                                         -- represented by boxed types
 813 typeKind (AppTy fun arg)        = funResultTy (typeKind fun)
 814
 815 typeKind (FunTy arg res)        = fix_up (typeKind res)
 816                                 where
 817                                   fix_up (TyConApp tycon _) |  tycon == typeCon
 818                                                             || tycon == openKindCon = boxedTypeKind
 819                                   fix_up (NoteTy _ kind) = fix_up kind
 820                                   fix_up kind            = kind
 821                 -- The basic story is
 822                 --      typeKind (FunTy arg res) = typeKind res
 823                 -- But a function is boxed regardless of its result type
 824                 -- Hence the strange fix-up.
 825                 -- Note that 'res', being the result of a FunTy, can't have
 826                 -- a strange kind like (*->*).
 827
 828 typeKind (ForAllTy tv ty)       = typeKind ty
 829 typeKind (UsageTy _ ty)         = typeKind ty  -- we don't have separate kinds for ann/unann
 830 \end{code}
 831
 832
 833 ---------------------------------------------------------------------
 834                 Free variables of a type
 835                 ~~~~~~~~~~~~~~~~~~~~~~~~
 836 \begin{code}
 837
 838 tyVarsOfType :: Type -> TyVarSet
 839 tyVarsOfType (TyVarTy tv)               = unitVarSet tv
 840 tyVarsOfType (TyConApp tycon tys)       = tyVarsOfTypes tys
 841 tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
 842 tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
 843 tyVarsOfType (PredTy p)                 = tyVarsOfPred p
 844 tyVarsOfType (FunTy arg res)            = tyVarsOfType arg `unionVarSet` tyVarsOfType res
 845 tyVarsOfType (AppTy fun arg)            = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
 846 tyVarsOfType (ForAllTy tyvar ty)        = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
 847 tyVarsOfType (UsageTy u ty)             = tyVarsOfType u `unionVarSet` tyVarsOfType ty
 848
 849 tyVarsOfTypes :: [Type] -> TyVarSet
 850 tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
 851
 852 tyVarsOfPred :: PredType -> TyVarSet
 853 tyVarsOfPred (Class clas tys) = tyVarsOfTypes tys
 854 tyVarsOfPred (IParam n ty)    = tyVarsOfType ty
 855
 856 tyVarsOfTheta :: ThetaType -> TyVarSet
 857 tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet
 858
 859 -- Add a Note with the free tyvars to the top of the type
 860 addFreeTyVars :: Type -> Type
 861 addFreeTyVars ty@(NoteTy (FTVNote _) _)      = ty
 862 addFreeTyVars ty                             = NoteTy (FTVNote (tyVarsOfType ty)) ty
 863
 864 -- Find the free names of a type, including the type constructors and classes it mentions
 865 namesOfType :: Type -> NameSet
 866 namesOfType (TyVarTy tv)                = unitNameSet (getName tv)
 867 namesOfType (TyConApp tycon tys)        = unitNameSet (getName tycon) `unionNameSets`
 868                                           namesOfTypes tys
 869 namesOfType (NoteTy (SynNote ty1) ty2)  = namesOfType ty1
 870 namesOfType (NoteTy other_note    ty2)  = namesOfType ty2
 871 namesOfType (PredTy p)                  = namesOfType (predRepTy p)
 872 namesOfType (FunTy arg res)             = namesOfType arg `unionNameSets` namesOfType res
 873 namesOfType (AppTy fun arg)             = namesOfType fun `unionNameSets` namesOfType arg
 874 namesOfType (ForAllTy tyvar ty)         = namesOfType ty `delFromNameSet` getName tyvar
 875 namesOfType (UsageTy u ty)              = namesOfType u `unionNameSets` namesOfType ty
 876
 877 namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys
 878 \end{code}
 879
 880 Usage annotations of a type
 881 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 882
 883 Get a list of usage annotations of a type, *in left-to-right pre-order*.
 884
 885 \begin{code}
 886 usageAnnOfType :: Type -> [Type]
 887 usageAnnOfType ty
 888   = goS ty
 889   where
 890     goT (TyVarTy _)       = []
 891     goT (AppTy ty1 ty2)   = goT ty1 ++ goT ty2
 892     goT (TyConApp tc tys) = concatMap goT tys
 893     goT (FunTy sty1 sty2) = goS sty1 ++ goS sty2
 894     goT (ForAllTy mv ty)  = goT ty
 895     goT (PredTy p)        = goT (predRepTy p)
 896     goT ty@(UsageTy _ _)  = pprPanic "usageAnnOfType: unexpected usage:" (pprType ty)
 897     goT (NoteTy note ty)  = goT ty
 898
 899     goS sty = case splitUTy sty of
 900                 (u,tty) -> u : goT tty
 901 \end{code}
 902
 903
 904 %************************************************************************
 905 %*                                                                      *
 906 \subsection{TidyType}
 907 %*                                                                      *
 908 %************************************************************************
 909
 910 tidyTy tidies up a type for printing in an error message, or in
 911 an interface file.
 912
 913 It doesn't change the uniques at all, just the print names.
 914
 915 \begin{code}
 916 tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
 917 tidyTyVar env@(tidy_env, subst) tyvar
 918   = case lookupVarEnv subst tyvar of
 919
 920         Just tyvar' ->  -- Already substituted
 921                 (env, tyvar')
 922
 923         Nothing ->      -- Make a new nice name for it
 924
 925                 case tidyOccName tidy_env (getOccName name) of
 926                     (tidy', occ') ->    -- New occname reqd
 927                                 ((tidy', subst'), tyvar')
 928                               where
 929                                 subst' = extendVarEnv subst tyvar tyvar'
 930                                 tyvar' = setTyVarName tyvar name'
 931                                 name'  = mkLocalName (getUnique name) occ' noSrcLoc
 932                                         -- Note: make a *user* tyvar, so it printes nicely
 933                                         -- Could extract src loc, but no need.
 934   where
 935     name = tyVarName tyvar
 936
 937 tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars
 938
 939 tidyType :: TidyEnv -> Type -> Type
 940 tidyType env@(tidy_env, subst) ty
 941   = go ty
 942   where
 943     go (TyVarTy tv)         = case lookupVarEnv subst tv of
 944                                 Nothing  -> TyVarTy tv
 945                                 Just tv' -> TyVarTy tv'
 946     go (TyConApp tycon tys) = let args = map go tys
 947                               in args `seqList` TyConApp tycon args
 948     go (NoteTy note ty)     = (NoteTy SAPPLY (go_note note)) SAPPLY (go ty)
 949     go (PredTy p)           = PredTy (go_pred p)
 950     go (AppTy fun arg)      = (AppTy SAPPLY (go fun)) SAPPLY (go arg)
 951     go (FunTy fun arg)      = (FunTy SAPPLY (go fun)) SAPPLY (go arg)
 952     go (ForAllTy tv ty)     = ForAllTy tvp SAPPLY (tidyType envp ty)
 953                               where
 954                                 (envp, tvp) = tidyTyVar env tv
 955     go (UsageTy u ty)       = (UsageTy SAPPLY (go u)) SAPPLY (go ty)
 956
 957     go_note (SynNote ty)        = SynNote SAPPLY (go ty)
 958     go_note note@(FTVNote ftvs) = note  -- No need to tidy the free tyvars
 959
 960     go_pred (Class c tys) = Class c (tidyTypes env tys)
 961     go_pred (IParam n ty) = IParam n (go ty)
 962
 963 tidyTypes env tys = map (tidyType env) tys
 964 \end{code}
 965
 966
 967 @tidyOpenType@ grabs the free type variables, tidies them
 968 and then uses @tidyType@ to work over the type itself
 969
 970 \begin{code}
 971 tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
 972 tidyOpenType env ty
 973   = (env', tidyType env' ty)
 974   where
 975     env'         = foldl go env (varSetElems (tyVarsOfType ty))
 976     go env tyvar = fst (tidyTyVar env tyvar)
 977
 978 tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
 979 tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
 980
 981 tidyTopType :: Type -> Type
 982 tidyTopType ty = tidyType emptyTidyEnv ty
 983 \end{code}
 984
 985
 986
 987 %************************************************************************
 988 %*                                                                      *
 989 \subsection{Boxedness and liftedness}
 990 %*                                                                      *
 991 %************************************************************************
 992
 993 \begin{code}
 994 isUnboxedType :: Type -> Bool
 995 isUnboxedType ty = not (isFollowableRep (typePrimRep ty))
 996
 997 isUnLiftedType :: Type -> Bool
 998         -- isUnLiftedType returns True for forall'd unlifted types:
 999         --      x :: forall a. Int#
1000         -- I found bindings like these were getting floated to the top level.
1001         -- They are pretty bogus types, mind you.  It would be better never to
1002         -- construct them
1003
1004 isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty
1005 isUnLiftedType (NoteTy _ ty)    = isUnLiftedType ty
1006 isUnLiftedType (TyConApp tc _)  = isUnLiftedTyCon tc
1007 isUnLiftedType (UsageTy _ ty)   = isUnLiftedType ty
1008 isUnLiftedType other            = False
1009
1010 isUnboxedTupleType :: Type -> Bool
1011 isUnboxedTupleType ty = case splitTyConApp_maybe ty of
1012                            Just (tc, ty_args) -> isUnboxedTupleTyCon tc
1013                            other              -> False
1014
1015 -- Should only be applied to *types*; hence the assert
1016 isAlgType :: Type -> Bool
1017 isAlgType ty = case splitTyConApp_maybe ty of
1018                         Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
1019                                               isAlgTyCon tc
1020                         other              -> False
1021
1022 -- Should only be applied to *types*; hence the assert
1023 isDataType :: Type -> Bool
1024 isDataType ty = case splitTyConApp_maybe ty of
1025                         Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
1026                                               isDataTyCon tc
1027                         other              -> False
1028
1029 isNewType :: Type -> Bool
1030 isNewType ty = case splitTyConApp_maybe ty of
1031                         Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
1032                                               isNewTyCon tc
1033                         other              -> False
1034 \end{code}
1035
1036
1037 %************************************************************************
1038 %*                                                                      *
1039 \subsection{Sequencing on types
1040 %*                                                                      *
1041 %************************************************************************
1042
1043 \begin{code}
1044 seqType :: Type -> ()
1045 seqType (TyVarTy tv)      = tv `seq` ()
1046 seqType (AppTy t1 t2)     = seqType t1 `seq` seqType t2
1047 seqType (FunTy t1 t2)     = seqType t1 `seq` seqType t2
1048 seqType (NoteTy note t2)  = seqNote note `seq` seqType t2
1049 seqType (PredTy p)        = seqPred p
1050 seqType (TyConApp tc tys) = tc `seq` seqTypes tys
1051 seqType (ForAllTy tv ty)  = tv `seq` seqType ty
1052 seqType (UsageTy u ty)    = seqType u `seq` seqType ty
1053
1054 seqTypes :: [Type] -> ()
1055 seqTypes []       = ()
1056 seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
1057
1058 seqNote :: TyNote -> ()
1059 seqNote (SynNote ty)  = seqType ty
1060 seqNote (FTVNote set) = sizeUniqSet set `seq` ()
1061
1062 seqPred :: PredType -> ()
1063 seqPred (Class c tys) = c `seq` seqTypes tys
1064 seqPred (IParam n ty) = n `seq` seqType ty
1065 \end{code}
1066
1067
1068 %************************************************************************
1069 %*                                                                      *
1070 \subsection{Equality on types}
1071 %*                                                                      *
1072 %************************************************************************
1073
1074
1075 \begin{code}
1076 instance Eq Type where
1077   ty1 == ty2 = case ty1 `compare` ty2 of { EQ -> True; other -> False }
1078
1079 instance Ord Type where
1080   compare ty1 ty2 = cmpTy emptyVarEnv ty1 ty2
1081
1082 cmpTy :: TyVarEnv TyVar -> Type -> Type -> Ordering
1083   -- The "env" maps type variables in ty1 to type variables in ty2
1084   -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
1085   -- we in effect substitute tv2 for tv1 in t1 before continuing
1086
1087     -- Get rid of NoteTy
1088 cmpTy env (NoteTy _ ty1) ty2 = cmpTy env ty1 ty2
1089 cmpTy env ty1 (NoteTy _ ty2) = cmpTy env ty1 ty2
1090
1091     -- Get rid of PredTy
1092 cmpTy env (PredTy p1) (PredTy p2) = cmpPred env p1 p2
1093 cmpTy env (PredTy p1) ty2         = cmpTy env (predRepTy p1) ty2
1094 cmpTy env ty1         (PredTy p2) = cmpTy env ty1 (predRepTy p2)
1095
1096     -- Deal with equal constructors
1097 cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of
1098                                           Just tv1a -> tv1a `compare` tv2
1099                                           Nothing   -> tv1  `compare` tv2
1100
1101 cmpTy env (AppTy f1 a1) (AppTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
1102 cmpTy env (FunTy f1 a1) (FunTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
1103 cmpTy env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2)
1104 cmpTy env (ForAllTy tv1 t1)   (ForAllTy tv2 t2)   = cmpTy (extendVarEnv env tv1 tv2) t1 t2
1105 cmpTy env (UsageTy   u1 t1)   (UsageTy   u2 t2)   = cmpTy env u1 u2 `thenCmp` cmpTy env t1 t2
1106
1107     -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy < UsageTy
1108 cmpTy env (AppTy _ _) (TyVarTy _) = GT
1109
1110 cmpTy env (FunTy _ _) (TyVarTy _) = GT
1111 cmpTy env (FunTy _ _) (AppTy _ _) = GT
1112
1113 cmpTy env (TyConApp _ _) (TyVarTy _) = GT
1114 cmpTy env (TyConApp _ _) (AppTy _ _) = GT
1115 cmpTy env (TyConApp _ _) (FunTy _ _) = GT
1116
1117 cmpTy env (ForAllTy _ _) (TyVarTy _)    = GT
1118 cmpTy env (ForAllTy _ _) (AppTy _ _)    = GT
1119 cmpTy env (ForAllTy _ _) (FunTy _ _)    = GT
1120 cmpTy env (ForAllTy _ _) (TyConApp _ _) = GT
1121
1122 cmpTy env (UsageTy  _ _) other       = GT
1123
1124 cmpTy env _ _                        = LT
1125
1126
1127 cmpTys env []       []       = EQ
1128 cmpTys env (t:ts)   []       = GT
1129 cmpTys env []       (t:ts)   = LT
1130 cmpTys env (t1:t1s) (t2:t2s) = cmpTy env t1 t2 `thenCmp` cmpTys env t1s t2s
1131 \end{code}
1132
1133 \begin{code}
1134 instance Eq PredType where
1135   p1 == p2 = case p1 `compare` p2 of { EQ -> True; other -> False }
1136
1137 instance Ord PredType where
1138   compare p1 p2 = cmpPred emptyVarEnv p1 p2
1139
1140 cmpPred :: TyVarEnv TyVar -> PredType -> PredType -> Ordering
1141 cmpPred env (IParam n1 t)   (IParam n2 t2)  = n1 `compare` n2
1142         -- Just compare the names!
1143 cmpPred env (Class c1 tys1) (Class c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2)
1144 cmpPred env (IParam _ _)    (Class _ _)     = LT
1145 cmpPred env (Class _ _)     (IParam _ _)    = GT
1146 \end{code}