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