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