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