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