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, PredType, TauType, ThetaType,
  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,
  34         funResultTy, funArgTy, zipFunTys,
  35
  36         mkTyConApp, mkTyConTy,
  37         tyConAppTyCon, tyConAppArgs,
  38         splitTyConApp_maybe, splitTyConApp,
  39
  40         mkUTy, splitUTy, splitUTy_maybe,
  41         isUTy, uaUTy, unUTy, liftUTy, mkUTyM,
  42         isUsageKind, isUsage, isUTyVar,
  43
  44         mkSynTy,
  45
  46         repType, splitRepFunTys, typePrimRep,
  47
  48         mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
  49         applyTy, applyTys, isForAllTy,
  50
  51         -- Source types
  52         SourceType(..), sourceTypeRep,
  53
  54         -- Newtypes
  55         mkNewTyConApp,
  56
  57         -- Lifting and boxity
  58         isUnLiftedType, isUnboxedTupleType, isAlgType,
  59
  60         -- Free variables
  61         tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
  62         usageAnnOfType, typeKind, addFreeTyVars,
  63
  64         -- Tidying up for printing
  65         tidyType,     tidyTypes,
  66         tidyOpenType, tidyOpenTypes,
  67         tidyTyVar,    tidyTyVars, tidyFreeTyVars,
  68         tidyTopType,  tidyPred,
  69
  70         -- Comparison
  71         eqType, eqKind, eqUsage,
  72
  73         -- Seq
  74         seqType, seqTypes
  75
  76     ) where
  77
  78 #include "HsVersions.h"
  79
  80 -- We import the representation and primitive functions from TypeRep.
  81 -- Many things are reexported, but not the representation!
  82
  83 import TypeRep
  84
  85 -- Other imports:
  86
  87 import {-# SOURCE #-}   DataCon( DataCon )
  88 import {-# SOURCE #-}   PprType( pprType )      -- Only called in debug messages
  89 import {-# SOURCE #-}   Subst  ( mkTyVarSubst, substTy )
  90
  91 -- friends:
  92 import Var      ( Var, TyVar, tyVarKind, tyVarName, setTyVarName )
  93 import VarEnv
  94 import VarSet
  95
  96 import OccName  ( mkDictOcc )
  97 import Name     ( Name, NamedThing(..), OccName, mkLocalName, tidyOccName )
  98 import NameSet
  99 import Class    ( classTyCon )
 100 import TyCon    ( TyCon, isRecursiveTyCon,
 101                   isUnboxedTupleTyCon, isUnLiftedTyCon,
 102                   isFunTyCon, isNewTyCon, newTyConRep,
 103                   isAlgTyCon, isSynTyCon, tyConArity, tyConTyVars,
 104                   tyConKind, tyConDataCons, getSynTyConDefn,
 105                   tyConPrimRep, isPrimTyCon
 106                 )
 107
 108 -- others
 109 import Maybes           ( maybeToBool )
 110 import SrcLoc           ( SrcLoc, noSrcLoc )
 111 import PrimRep          ( PrimRep(..) )
 112 import Unique           ( Unique, Uniquable(..) )
 113 import Util             ( mapAccumL, seqList, thenCmp )
 114 import Outputable
 115 import UniqSet          ( sizeUniqSet )         -- Should come via VarSet
 116 \end{code}
 117
 118
 119 %************************************************************************
 120 %*                                                                      *
 121 \subsection{Stuff to do with kinds.}
 122 %*                                                                      *
 123 %************************************************************************
 124
 125 \begin{code}
 126 hasMoreBoxityInfo :: Kind -> Kind -> Bool
 127 hasMoreBoxityInfo k1 k2
 128   | k2 `eqKind` openTypeKind = True
 129   | otherwise                = k1 `eqType` k2
 130
 131 defaultKind :: Kind -> Kind
 132 -- Used when generalising: default kind '?' to '*'
 133 defaultKind kind | kind `eqKind` openTypeKind = liftedTypeKind
 134                  | otherwise                  = kind
 135 \end{code}
 136
 137
 138 %************************************************************************
 139 %*                                                                      *
 140 \subsection{Constructor-specific functions}
 141 %*                                                                      *
 142 %************************************************************************
 143
 144
 145 ---------------------------------------------------------------------
 146                                 TyVarTy
 147                                 ~~~~~~~
 148 \begin{code}
 149 mkTyVarTy  :: TyVar   -> Type
 150 mkTyVarTy  = TyVarTy
 151
 152 mkTyVarTys :: [TyVar] -> [Type]
 153 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
 154
 155 getTyVar :: String -> Type -> TyVar
 156 getTyVar msg (TyVarTy tv)     = tv
 157 getTyVar msg (SourceTy p)     = getTyVar msg (sourceTypeRep p)
 158 getTyVar msg (NoteTy _ t)     = getTyVar msg t
 159 getTyVar msg ty@(UsageTy _ _) = pprPanic "getTyVar: UTy:" (text msg $$ pprType ty)
 160 getTyVar msg other            = panic ("getTyVar: " ++ msg)
 161
 162 getTyVar_maybe :: Type -> Maybe TyVar
 163 getTyVar_maybe (TyVarTy tv)     = Just tv
 164 getTyVar_maybe (NoteTy _ t)     = getTyVar_maybe t
 165 getTyVar_maybe (SourceTy p)     = getTyVar_maybe (sourceTypeRep p)
 166 getTyVar_maybe ty@(UsageTy _ _) = pprPanic "getTyVar_maybe: UTy:" (pprType ty)
 167 getTyVar_maybe other            = Nothing
 168
 169 isTyVarTy :: Type -> Bool
 170 isTyVarTy (TyVarTy tv)     = True
 171 isTyVarTy (NoteTy _ ty)    = isTyVarTy ty
 172 isTyVarTy (SourceTy p)     = isTyVarTy (sourceTypeRep p)
 173 isTyVarTy ty@(UsageTy _ _) = pprPanic "isTyVarTy: UTy:" (pprType ty)
 174 isTyVarTy other            = False
 175 \end{code}
 176
 177
 178 ---------------------------------------------------------------------
 179                                 AppTy
 180                                 ~~~~~
 181 We need to be pretty careful with AppTy to make sure we obey the
 182 invariant that a TyConApp is always visibly so.  mkAppTy maintains the
 183 invariant: use it.
 184
 185 \begin{code}
 186 mkAppTy orig_ty1 orig_ty2
 187   = ASSERT( not (isSourceTy orig_ty1) ) -- Source types are of kind *
 188     UASSERT2( not (isUTy orig_ty2), pprType orig_ty1 <+> pprType orig_ty2 )
 189                                         -- argument must be unannotated
 190     mk_app orig_ty1
 191   where
 192     mk_app (NoteTy _ ty1)    = mk_app ty1
 193     mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
 194     mk_app ty@(UsageTy _ _)  = pprPanic "mkAppTy: UTy:" (pprType ty)
 195     mk_app ty1               = AppTy orig_ty1 orig_ty2
 196
 197 mkAppTys :: Type -> [Type] -> Type
 198 mkAppTys orig_ty1 []        = orig_ty1
 199         -- This check for an empty list of type arguments
 200         -- avoids the needless loss of a type synonym constructor.
 201         -- For example: mkAppTys Rational []
 202         --   returns to (Ratio Integer), which has needlessly lost
 203         --   the Rational part.
 204 mkAppTys orig_ty1 orig_tys2
 205   = ASSERT( not (isSourceTy orig_ty1) ) -- Source types are of kind *
 206     UASSERT2( not (any isUTy orig_tys2), pprType orig_ty1 <+> fsep (map pprType orig_tys2) )
 207                                         -- arguments must be unannotated
 208     mk_app orig_ty1
 209   where
 210     mk_app (NoteTy _ ty1)    = mk_app ty1
 211     mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
 212     mk_app ty@(UsageTy _ _)  = pprPanic "mkAppTys: UTy:" (pprType ty)
 213     mk_app ty1               = foldl AppTy orig_ty1 orig_tys2
 214
 215 splitAppTy_maybe :: Type -> Maybe (Type, Type)
 216 splitAppTy_maybe (FunTy ty1 ty2)   = Just (TyConApp funTyCon [unUTy ty1], unUTy ty2)
 217 splitAppTy_maybe (AppTy ty1 ty2)   = Just (ty1, ty2)
 218 splitAppTy_maybe (NoteTy _ ty)     = splitAppTy_maybe ty
 219 splitAppTy_maybe (SourceTy p)        = splitAppTy_maybe (sourceTypeRep p)
 220 splitAppTy_maybe (TyConApp tc [])  = Nothing
 221 splitAppTy_maybe (TyConApp tc tys) = split tys []
 222                             where
 223                                split [ty2]    acc = Just (TyConApp tc (reverse acc), ty2)
 224                                split (ty:tys) acc = split tys (ty:acc)
 225
 226 splitAppTy_maybe ty@(UsageTy _ _)  = pprPanic "splitAppTy_maybe: UTy:" (pprType ty)
 227 splitAppTy_maybe other            = Nothing
 228
 229 splitAppTy :: Type -> (Type, Type)
 230 splitAppTy ty = case splitAppTy_maybe ty of
 231                         Just pr -> pr
 232                         Nothing -> panic "splitAppTy"
 233
 234 splitAppTys :: Type -> (Type, [Type])
 235 splitAppTys ty = split ty ty []
 236   where
 237     split orig_ty (AppTy ty arg)        args = split ty ty (arg:args)
 238     split orig_ty (NoteTy _ ty)         args = split orig_ty ty args
 239     split orig_ty (SourceTy p)            args = split orig_ty (sourceTypeRep p) args
 240     split orig_ty (FunTy ty1 ty2)       args = ASSERT( null args )
 241                                                (TyConApp funTyCon [], [unUTy ty1,unUTy ty2])
 242     split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
 243     split orig_ty (UsageTy _ _)         args = pprPanic "splitAppTys: UTy:" (pprType orig_ty)
 244     split orig_ty ty                    args = (orig_ty, args)
 245 \end{code}
 246
 247
 248 ---------------------------------------------------------------------
 249                                 FunTy
 250                                 ~~~~~
 251
 252 \begin{code}
 253 mkFunTy :: Type -> Type -> Type
 254 mkFunTy arg res = UASSERT2( isUTy arg && isUTy res, pprType arg <+> pprType res )
 255                   FunTy arg res
 256
 257 mkFunTys :: [Type] -> Type -> Type
 258 mkFunTys tys ty = UASSERT2( all isUTy (ty:tys), fsep (map pprType (tys++[ty])) )
 259                   foldr FunTy ty tys
 260
 261 splitFunTy :: Type -> (Type, Type)
 262 splitFunTy (FunTy arg res) = (arg, res)
 263 splitFunTy (NoteTy _ ty)   = splitFunTy ty
 264 splitFunTy (SourceTy p)      = splitFunTy (sourceTypeRep p)
 265 splitFunTy ty@(UsageTy _ _) = pprPanic "splitFunTy: UTy:" (pprType ty)
 266
 267 splitFunTy_maybe :: Type -> Maybe (Type, Type)
 268 splitFunTy_maybe (FunTy arg res) = Just (arg, res)
 269 splitFunTy_maybe (NoteTy _ ty)   = splitFunTy_maybe ty
 270 splitFunTy_maybe (SourceTy p)            = splitFunTy_maybe (sourceTypeRep p)
 271 splitFunTy_maybe ty@(UsageTy _ _) = pprPanic "splitFunTy_maybe: UTy:" (pprType ty)
 272 splitFunTy_maybe other           = Nothing
 273
 274 splitFunTys :: Type -> ([Type], Type)
 275 splitFunTys ty = split [] ty ty
 276   where
 277     split args orig_ty (FunTy arg res) = split (arg:args) res res
 278     split args orig_ty (NoteTy _ ty)   = split args orig_ty ty
 279     split args orig_ty (SourceTy p)      = split args orig_ty (sourceTypeRep p)
 280     split args orig_ty (UsageTy _ _)   = pprPanic "splitFunTys: UTy:" (pprType orig_ty)
 281     split args orig_ty ty              = (reverse args, orig_ty)
 282
 283 zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type)
 284 zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
 285   where
 286     split acc []     nty ty              = (reverse acc, nty)
 287     split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res
 288     split acc xs     nty (NoteTy _ ty)   = split acc           xs nty ty
 289     split acc xs     nty (SourceTy p)      = split acc           xs nty (sourceTypeRep p)
 290     split acc xs     nty (UsageTy _ _)   = pprPanic "zipFunTys: UTy:" (ppr orig_xs <+> pprType orig_ty)
 291     split acc (x:xs) nty ty              = pprPanic "zipFunTys" (ppr orig_xs <+> pprType orig_ty)
 292
 293 funResultTy :: Type -> Type
 294 funResultTy (FunTy arg res) = res
 295 funResultTy (NoteTy _ ty)   = funResultTy ty
 296 funResultTy (SourceTy p)      = funResultTy (sourceTypeRep p)
 297 funResultTy (UsageTy _ ty)  = funResultTy ty
 298 funResultTy ty              = pprPanic "funResultTy" (pprType ty)
 299
 300 funArgTy :: Type -> Type
 301 funArgTy (FunTy arg res) = arg
 302 funArgTy (NoteTy _ ty)   = funArgTy ty
 303 funArgTy (SourceTy p)      = funArgTy (sourceTypeRep p)
 304 funArgTy (UsageTy _ ty)  = funArgTy ty
 305 funArgTy ty              = pprPanic "funArgTy" (pprType ty)
 306 \end{code}
 307
 308
 309 ---------------------------------------------------------------------
 310                                 TyConApp
 311                                 ~~~~~~~~
 312 @mkTyConApp@ is a key function, because it builds a TyConApp, FunTy or SourceTy,
 313 as apppropriate.
 314
 315 \begin{code}
 316 mkTyConApp :: TyCon -> [Type] -> Type
 317 mkTyConApp tycon tys
 318   | isFunTyCon tycon, [ty1,ty2] <- tys
 319   = FunTy (mkUTyM ty1) (mkUTyM ty2)
 320
 321   | isNewTyCon tycon,                   -- A saturated newtype application;
 322     not (isRecursiveTyCon tycon),       -- Not recursive (we don't use SourceTypes for them)
 323     length tys == tyConArity tycon      -- use the SourceType form
 324   = SourceTy (NType tycon tys)
 325
 326   | otherwise
 327   = ASSERT(not (isSynTyCon tycon))
 328     UASSERT2( not (any isUTy tys), ppr tycon <+> fsep (map pprType tys) )
 329     TyConApp tycon tys
 330
 331 mkTyConTy :: TyCon -> Type
 332 mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) )
 333                   TyConApp tycon []
 334
 335 -- splitTyConApp "looks through" synonyms, because they don't
 336 -- mean a distinct type, but all other type-constructor applications
 337 -- including functions are returned as Just ..
 338
 339 tyConAppTyCon :: Type -> TyCon
 340 tyConAppTyCon ty = fst (splitTyConApp ty)
 341
 342 tyConAppArgs :: Type -> [Type]
 343 tyConAppArgs ty = snd (splitTyConApp ty)
 344
 345 splitTyConApp :: Type -> (TyCon, [Type])
 346 splitTyConApp ty = case splitTyConApp_maybe ty of
 347                         Just stuff -> stuff
 348                         Nothing    -> pprPanic "splitTyConApp" (pprType ty)
 349
 350 splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
 351 splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
 352 splitTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [unUTy arg,unUTy res])
 353 splitTyConApp_maybe (NoteTy _ ty)     = splitTyConApp_maybe ty
 354 splitTyConApp_maybe (SourceTy p)      = splitTyConApp_maybe (sourceTypeRep p)
 355 splitTyConApp_maybe (UsageTy _ ty)    = splitTyConApp_maybe ty
 356 splitTyConApp_maybe other             = Nothing
 357 \end{code}
 358
 359
 360 ---------------------------------------------------------------------
 361                                 SynTy
 362                                 ~~~~~
 363
 364 \begin{code}
 365 mkSynTy syn_tycon tys
 366   = ASSERT( isSynTyCon syn_tycon )
 367     ASSERT( length tyvars == length tys )
 368     NoteTy (SynNote (TyConApp syn_tycon tys))
 369            (substTy (mkTyVarSubst tyvars tys) body)
 370   where
 371     (tyvars, body) = getSynTyConDefn syn_tycon
 372 \end{code}
 373
 374 Notes on type synonyms
 375 ~~~~~~~~~~~~~~~~~~~~~~
 376 The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
 377 to return type synonyms whereever possible. Thus
 378
 379         type Foo a = a -> a
 380
 381 we want
 382         splitFunTys (a -> Foo a) = ([a], Foo a)
 383 not                                ([a], a -> a)
 384
 385 The reason is that we then get better (shorter) type signatures in
 386 interfaces.  Notably this plays a role in tcTySigs in TcBinds.lhs.
 387
 388
 389                 Representation types
 390                 ~~~~~~~~~~~~~~~~~~~~
 391
 392 repType looks through
 393         (a) for-alls, and
 394         (b) synonyms
 395         (c) predicates
 396         (d) usage annotations
 397 It's useful in the back end.
 398
 399 \begin{code}
 400 repType :: Type -> Type
 401 repType (ForAllTy _ ty) = repType ty
 402 repType (NoteTy   _ ty) = repType ty
 403 repType (SourceTy  p)   = repType (sourceTypeRep p)
 404 repType (UsageTy  _ ty) = repType ty
 405 repType ty              = ty
 406
 407 splitRepFunTys :: Type -> ([Type], Type)
 408 -- Like splitFunTys, but looks through newtypes and for-alls
 409 splitRepFunTys ty = split [] (repType ty)
 410   where
 411     split args (FunTy arg res)  = split (arg:args) (repType res)
 412     split args ty               = (reverse args, ty)
 413
 414 typePrimRep :: Type -> PrimRep
 415 typePrimRep ty = case repType ty of
 416                    TyConApp tc _ -> tyConPrimRep tc
 417                    FunTy _ _     -> PtrRep
 418                    AppTy _ _     -> PtrRep      -- ??
 419                    TyVarTy _     -> PtrRep
 420 \end{code}
 421
 422
 423
 424 ---------------------------------------------------------------------
 425                                 ForAllTy
 426                                 ~~~~~~~~
 427
 428 \begin{code}
 429 mkForAllTy :: TyVar -> Type -> Type
 430 mkForAllTy tyvar ty
 431   = mkForAllTys [tyvar] ty
 432
 433 mkForAllTys :: [TyVar] -> Type -> Type
 434 mkForAllTys tyvars ty
 435   = case splitUTy_maybe ty of
 436       Just (u,ty1) -> UASSERT2( not (mkVarSet tyvars `intersectsVarSet` tyVarsOfType u),
 437                                 ptext SLIT("mkForAllTys: usage scope")
 438                                 <+> ppr tyvars <+> pprType ty )
 439                       mkUTy u (foldr ForAllTy ty1 tyvars)  -- we lift usage annotations over foralls
 440       Nothing      -> foldr ForAllTy ty tyvars
 441
 442 isForAllTy :: Type -> Bool
 443 isForAllTy (NoteTy _ ty)  = isForAllTy ty
 444 isForAllTy (ForAllTy _ _) = True
 445 isForAllTy (UsageTy _ ty) = isForAllTy ty
 446 isForAllTy other_ty       = False
 447
 448 splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
 449 splitForAllTy_maybe ty = splitFAT_m ty
 450   where
 451     splitFAT_m (NoteTy _ ty)            = splitFAT_m ty
 452     splitFAT_m (SourceTy p)             = splitFAT_m (sourceTypeRep p)
 453     splitFAT_m (ForAllTy tyvar ty)      = Just(tyvar, ty)
 454     splitFAT_m (UsageTy _ ty)           = splitFAT_m ty
 455     splitFAT_m _                        = Nothing
 456
 457 splitForAllTys :: Type -> ([TyVar], Type)
 458 splitForAllTys ty = split ty ty []
 459    where
 460      split orig_ty (ForAllTy tv ty)       tvs = split ty ty (tv:tvs)
 461      split orig_ty (NoteTy _ ty)          tvs = split orig_ty ty tvs
 462      split orig_ty (SourceTy p)           tvs = split orig_ty (sourceTypeRep p) tvs
 463      split orig_ty (UsageTy _ ty)         tvs = split orig_ty ty tvs
 464      split orig_ty t                      tvs = (reverse tvs, orig_ty)
 465 \end{code}
 466
 467 -- (mkPiType now in CoreUtils)
 468
 469 Applying a for-all to its arguments.  Lift usage annotation as required.
 470
 471 \begin{code}
 472 applyTy :: Type -> Type -> Type
 473 applyTy (SourceTy p)                    arg = applyTy (sourceTypeRep p) arg
 474 applyTy (NoteTy _ fun)                  arg = applyTy fun arg
 475 applyTy (ForAllTy tv ty)                arg = UASSERT2( not (isUTy arg),
 476                                                         ptext SLIT("applyTy")
 477                                                         <+> pprType ty <+> pprType arg )
 478                                               substTy (mkTyVarSubst [tv] [arg]) ty
 479 applyTy (UsageTy u ty)                  arg = UsageTy u (applyTy ty arg)
 480 applyTy other                           arg = panic "applyTy"
 481
 482 applyTys :: Type -> [Type] -> Type
 483 applyTys fun_ty arg_tys
 484  = UASSERT2( not (any isUTy arg_tys), ptext SLIT("applyTys") <+> pprType fun_ty )
 485    (case mu of
 486       Just u  -> UsageTy u
 487       Nothing -> id) $
 488    substTy (mkTyVarSubst tvs arg_tys) ty
 489  where
 490    (mu, tvs, ty) = split fun_ty arg_tys
 491
 492    split fun_ty               []         = (Nothing, [], fun_ty)
 493    split (NoteTy _ fun_ty)    args       = split fun_ty args
 494    split (SourceTy p)         args       = split (sourceTypeRep p) args
 495    split (ForAllTy tv fun_ty) (arg:args) = case split fun_ty args of
 496                                                   (mu, tvs, ty) -> (mu, tv:tvs, ty)
 497    split (UsageTy u ty)       args       = case split ty args of
 498                                                   (Nothing, tvs, ty) -> (Just u, tvs, ty)
 499                                                   (Just _ , _  , _ ) -> pprPanic "applyTys:"
 500                                                                           (pprType fun_ty)
 501    split other_ty             args       = panic "applyTys"
 502 \end{code}
 503
 504
 505 ---------------------------------------------------------------------
 506                                 UsageTy
 507                                 ~~~~~~~
 508
 509 Constructing and taking apart usage types.
 510
 511 \begin{code}
 512 mkUTy :: Type -> Type -> Type
 513 mkUTy u ty
 514   = ASSERT2( typeKind u `eqKind` usageTypeKind,
 515              ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty )
 516     UASSERT2( not (isUTy ty), ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty )
 517     -- if u == usMany then ty else  : ToDo? KSW 2000-10
 518 #ifdef DO_USAGES
 519     UsageTy u ty
 520 #else
 521     ty
 522 #endif
 523
 524 splitUTy :: Type -> (Type {- :: $ -}, Type)
 525 splitUTy orig_ty
 526   = case splitUTy_maybe orig_ty of
 527       Just (u,ty) -> (u,ty)
 528 #ifdef DO_USAGES
 529       Nothing     -> pprPanic "splitUTy:" (pprType orig_ty)
 530 #else
 531       Nothing     -> (usMany,orig_ty)  -- default annotation ToDo KSW 2000-10
 532 #endif
 533
 534 splitUTy_maybe :: Type -> Maybe (Type {- :: $ -}, Type)
 535 splitUTy_maybe (UsageTy u ty) = Just (u,ty)
 536 splitUTy_maybe (NoteTy _ ty)  = splitUTy_maybe ty
 537 splitUTy_maybe other_ty       = Nothing
 538
 539 isUTy :: Type -> Bool
 540   -- has usage annotation
 541 isUTy = maybeToBool . splitUTy_maybe
 542
 543 uaUTy :: Type -> Type
 544   -- extract annotation
 545 uaUTy = fst . splitUTy
 546
 547 unUTy :: Type -> Type
 548   -- extract unannotated type
 549 unUTy = snd . splitUTy
 550 \end{code}
 551
 552 \begin{code}
 553 liftUTy :: (Type -> Type) -> Type -> Type
 554   -- lift outer usage annot over operation on unannotated types
 555 liftUTy f ty
 556   = let
 557       (u,ty') = splitUTy ty
 558     in
 559     mkUTy u (f ty')
 560 \end{code}
 561
 562 \begin{code}
 563 mkUTyM :: Type -> Type
 564   -- put TOP (no info) annotation on unannotated type
 565 mkUTyM ty = mkUTy usMany ty
 566 \end{code}
 567
 568 \begin{code}
 569 isUsageKind :: Kind -> Bool
 570 isUsageKind k
 571   = ASSERT( typeKind k `eqKind` superKind )
 572     k `eqKind` usageTypeKind
 573
 574 isUsage :: Type -> Bool
 575 isUsage ty
 576   = isUsageKind (typeKind ty)
 577
 578 isUTyVar :: Var -> Bool
 579 isUTyVar v
 580   = isUsageKind (tyVarKind v)
 581 \end{code}
 582
 583
 584 %************************************************************************
 585 %*                                                                      *
 586 \subsection{Source types}
 587 %*                                                                      *
 588 %************************************************************************
 589
 590 A "source type" is a type that is a separate type as far as the type checker is
 591 concerned, but which has low-level representation as far as the back end is concerned.
 592
 593 Source types are always lifted.
 594
 595 The key function is sourceTypeRep which gives the representation of a source type:
 596
 597 \begin{code}
 598 sourceTypeRep :: SourceType -> Type
 599 -- Convert a predicate to its "representation type";
 600 -- the type of evidence for that predicate, which is actually passed at runtime
 601 sourceTypeRep (IParam n ty)     = ty
 602 sourceTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys
 603         -- Note the mkTyConApp; the classTyCon might be a newtype!
 604 sourceTypeRep (NType  tc tys)   = case newTyConRep tc of
 605                                     (tvs, rep_ty) -> substTy (mkTyVarSubst tvs tys) rep_ty
 606         -- ToDo: Consider caching this substitution in a NType
 607
 608 mkNewTyConApp :: TyCon -> [Type] -> SourceType
 609 mkNewTyConApp tc tys = NType tc tys     -- Here is where we might cache the substitution
 610
 611 isSourceTy :: Type -> Bool
 612 isSourceTy (NoteTy _ ty)  = isSourceTy ty
 613 isSourceTy (UsageTy _ ty) = isSourceTy ty
 614 isSourceTy (SourceTy sty) = True
 615 isSourceTy _              = False
 616 \end{code}
 617
 618
 619 %************************************************************************
 620 %*                                                                      *
 621 \subsection{Kinds and free variables}
 622 %*                                                                      *
 623 %************************************************************************
 624
 625 ---------------------------------------------------------------------
 626                 Finding the kind of a type
 627                 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 628 \begin{code}
 629 typeKind :: Type -> Kind
 630
 631 typeKind (TyVarTy tyvar)        = tyVarKind tyvar
 632 typeKind (TyConApp tycon tys)   = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys
 633 typeKind (NoteTy _ ty)          = typeKind ty
 634 typeKind (SourceTy _)           = liftedTypeKind -- Predicates are always
 635                                                  -- represented by lifted types
 636 typeKind (AppTy fun arg)        = funResultTy (typeKind fun)
 637
 638 typeKind (FunTy arg res)        = fix_up (typeKind res)
 639                                 where
 640                                   fix_up (TyConApp tycon _) |  tycon == typeCon
 641                                                             || tycon == openKindCon = liftedTypeKind
 642                                   fix_up (NoteTy _ kind) = fix_up kind
 643                                   fix_up kind            = kind
 644                 -- The basic story is
 645                 --      typeKind (FunTy arg res) = typeKind res
 646                 -- But a function is lifted regardless of its result type
 647                 -- Hence the strange fix-up.
 648                 -- Note that 'res', being the result of a FunTy, can't have
 649                 -- a strange kind like (*->*).
 650
 651 typeKind (ForAllTy tv ty)       = typeKind ty
 652 typeKind (UsageTy _ ty)         = typeKind ty  -- we don't have separate kinds for ann/unann
 653 \end{code}
 654
 655
 656 ---------------------------------------------------------------------
 657                 Free variables of a type
 658                 ~~~~~~~~~~~~~~~~~~~~~~~~
 659 \begin{code}
 660
 661 tyVarsOfType :: Type -> TyVarSet
 662 tyVarsOfType (TyVarTy tv)               = unitVarSet tv
 663 tyVarsOfType (TyConApp tycon tys)       = tyVarsOfTypes tys
 664 tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
 665 tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
 666 tyVarsOfType (SourceTy sty)             = tyVarsOfSourceType sty
 667 tyVarsOfType (FunTy arg res)            = tyVarsOfType arg `unionVarSet` tyVarsOfType res
 668 tyVarsOfType (AppTy fun arg)            = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
 669 tyVarsOfType (ForAllTy tyvar ty)        = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
 670 tyVarsOfType (UsageTy u ty)             = tyVarsOfType u `unionVarSet` tyVarsOfType ty
 671
 672 tyVarsOfTypes :: [Type] -> TyVarSet
 673 tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
 674
 675 tyVarsOfPred :: PredType -> TyVarSet
 676 tyVarsOfPred = tyVarsOfSourceType       -- Just a subtype
 677
 678 tyVarsOfSourceType :: SourceType -> TyVarSet
 679 tyVarsOfSourceType (IParam n ty)     = tyVarsOfType ty
 680 tyVarsOfSourceType (ClassP clas tys) = tyVarsOfTypes tys
 681 tyVarsOfSourceType (NType tc tys)    = tyVarsOfTypes tys
 682
 683 tyVarsOfTheta :: ThetaType -> TyVarSet
 684 tyVarsOfTheta = foldr (unionVarSet . tyVarsOfSourceType) emptyVarSet
 685
 686 -- Add a Note with the free tyvars to the top of the type
 687 addFreeTyVars :: Type -> Type
 688 addFreeTyVars ty@(NoteTy (FTVNote _) _)      = ty
 689 addFreeTyVars ty                             = NoteTy (FTVNote (tyVarsOfType ty)) ty
 690 \end{code}
 691
 692 Usage annotations of a type
 693 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 694
 695 Get a list of usage annotations of a type, *in left-to-right pre-order*.
 696
 697 \begin{code}
 698 usageAnnOfType :: Type -> [Type]
 699 usageAnnOfType ty
 700   = goS ty
 701   where
 702     goT (TyVarTy _)       = []
 703     goT (AppTy ty1 ty2)   = goT ty1 ++ goT ty2
 704     goT (TyConApp tc tys) = concatMap goT tys
 705     goT (FunTy sty1 sty2) = goS sty1 ++ goS sty2
 706     goT (ForAllTy mv ty)  = goT ty
 707     goT (SourceTy p)      = goT (sourceTypeRep p)
 708     goT ty@(UsageTy _ _)  = pprPanic "usageAnnOfType: unexpected usage:" (pprType ty)
 709     goT (NoteTy note ty)  = goT ty
 710
 711     goS sty = case splitUTy sty of
 712                 (u,tty) -> u : goT tty
 713 \end{code}
 714
 715
 716 %************************************************************************
 717 %*                                                                      *
 718 \subsection{TidyType}
 719 %*                                                                      *
 720 %************************************************************************
 721
 722 tidyTy tidies up a type for printing in an error message, or in
 723 an interface file.
 724
 725 It doesn't change the uniques at all, just the print names.
 726
 727 \begin{code}
 728 tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
 729 tidyTyVar env@(tidy_env, subst) tyvar
 730   = case lookupVarEnv subst tyvar of
 731
 732         Just tyvar' ->  -- Already substituted
 733                 (env, tyvar')
 734
 735         Nothing ->      -- Make a new nice name for it
 736
 737                 case tidyOccName tidy_env (getOccName name) of
 738                     (tidy', occ') ->    -- New occname reqd
 739                                 ((tidy', subst'), tyvar')
 740                               where
 741                                 subst' = extendVarEnv subst tyvar tyvar'
 742                                 tyvar' = setTyVarName tyvar name'
 743                                 name'  = mkLocalName (getUnique name) occ' noSrcLoc
 744                                         -- Note: make a *user* tyvar, so it printes nicely
 745                                         -- Could extract src loc, but no need.
 746   where
 747     name = tyVarName tyvar
 748
 749 tidyTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
 750 tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars
 751
 752 tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv
 753 -- Add the free tyvars to the env in tidy form,
 754 -- so that we can tidy the type they are free in
 755 tidyFreeTyVars env tyvars = foldl add env (varSetElems tyvars)
 756                           where
 757                             add env tv = fst (tidyTyVar env tv)
 758
 759 tidyType :: TidyEnv -> Type -> Type
 760 tidyType env@(tidy_env, subst) ty
 761   = go ty
 762   where
 763     go (TyVarTy tv)         = case lookupVarEnv subst tv of
 764                                 Nothing  -> TyVarTy tv
 765                                 Just tv' -> TyVarTy tv'
 766     go (TyConApp tycon tys) = let args = map go tys
 767                               in args `seqList` TyConApp tycon args
 768     go (NoteTy note ty)     = (NoteTy SAPPLY (go_note note)) SAPPLY (go ty)
 769     go (SourceTy sty)       = SourceTy (tidySourceType env sty)
 770     go (AppTy fun arg)      = (AppTy SAPPLY (go fun)) SAPPLY (go arg)
 771     go (FunTy fun arg)      = (FunTy SAPPLY (go fun)) SAPPLY (go arg)
 772     go (ForAllTy tv ty)     = ForAllTy tvp SAPPLY (tidyType envp ty)
 773                               where
 774                                 (envp, tvp) = tidyTyVar env tv
 775     go (UsageTy u ty)       = (UsageTy SAPPLY (go u)) SAPPLY (go ty)
 776
 777     go_note (SynNote ty)        = SynNote SAPPLY (go ty)
 778     go_note note@(FTVNote ftvs) = note  -- No need to tidy the free tyvars
 779
 780 tidyTypes env tys = map (tidyType env) tys
 781
 782 tidyPred :: TidyEnv -> SourceType -> SourceType
 783 tidyPred = tidySourceType
 784
 785 tidySourceType :: TidyEnv -> SourceType -> SourceType
 786 tidySourceType env (IParam n ty)     = IParam n (tidyType env ty)
 787 tidySourceType env (ClassP clas tys) = ClassP clas (tidyTypes env tys)
 788 tidySourceType env (NType tc tys)    = NType  tc   (tidyTypes env tys)
 789 \end{code}
 790
 791
 792 @tidyOpenType@ grabs the free type variables, tidies them
 793 and then uses @tidyType@ to work over the type itself
 794
 795 \begin{code}
 796 tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
 797 tidyOpenType env ty
 798   = (env', tidyType env' ty)
 799   where
 800     env' = tidyFreeTyVars env (tyVarsOfType ty)
 801
 802 tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
 803 tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
 804
 805 tidyTopType :: Type -> Type
 806 tidyTopType ty = tidyType emptyTidyEnv ty
 807 \end{code}
 808
 809
 810
 811 %************************************************************************
 812 %*                                                                      *
 813 \subsection{Liftedness}
 814 %*                                                                      *
 815 %************************************************************************
 816
 817 \begin{code}
 818 isUnLiftedType :: Type -> Bool
 819         -- isUnLiftedType returns True for forall'd unlifted types:
 820         --      x :: forall a. Int#
 821         -- I found bindings like these were getting floated to the top level.
 822         -- They are pretty bogus types, mind you.  It would be better never to
 823         -- construct them
 824
 825 isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty
 826 isUnLiftedType (NoteTy _ ty)    = isUnLiftedType ty
 827 isUnLiftedType (TyConApp tc _)  = isUnLiftedTyCon tc
 828 isUnLiftedType (UsageTy _ ty)   = isUnLiftedType ty
 829 isUnLiftedType (SourceTy _)     = False         -- All source types are lifted
 830 isUnLiftedType other            = False
 831
 832 isUnboxedTupleType :: Type -> Bool
 833 isUnboxedTupleType ty = case splitTyConApp_maybe ty of
 834                            Just (tc, ty_args) -> isUnboxedTupleTyCon tc
 835                            other              -> False
 836
 837 -- Should only be applied to *types*; hence the assert
 838 isAlgType :: Type -> Bool
 839 isAlgType ty = case splitTyConApp_maybe ty of
 840                         Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
 841                                               isAlgTyCon tc
 842                         other              -> False
 843 \end{code}
 844
 845
 846 %************************************************************************
 847 %*                                                                      *
 848 \subsection{Sequencing on types
 849 %*                                                                      *
 850 %************************************************************************
 851
 852 \begin{code}
 853 seqType :: Type -> ()
 854 seqType (TyVarTy tv)      = tv `seq` ()
 855 seqType (AppTy t1 t2)     = seqType t1 `seq` seqType t2
 856 seqType (FunTy t1 t2)     = seqType t1 `seq` seqType t2
 857 seqType (NoteTy note t2)  = seqNote note `seq` seqType t2
 858 seqType (SourceTy p)      = seqPred p
 859 seqType (TyConApp tc tys) = tc `seq` seqTypes tys
 860 seqType (ForAllTy tv ty)  = tv `seq` seqType ty
 861 seqType (UsageTy u ty)    = seqType u `seq` seqType ty
 862
 863 seqTypes :: [Type] -> ()
 864 seqTypes []       = ()
 865 seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
 866
 867 seqNote :: TyNote -> ()
 868 seqNote (SynNote ty)  = seqType ty
 869 seqNote (FTVNote set) = sizeUniqSet set `seq` ()
 870
 871 seqPred :: SourceType -> ()
 872 seqPred (ClassP c tys) = c  `seq` seqTypes tys
 873 seqPred (NType tc tys) = tc `seq` seqTypes tys
 874 seqPred (IParam n ty)  = n  `seq` seqType ty
 875 \end{code}
 876
 877
 878 %************************************************************************
 879 %*                                                                      *
 880 \subsection{Equality on types}
 881 %*                                                                      *
 882 %************************************************************************
 883
 884 Comparison; don't use instances so that we know where it happens.
 885 Look through newtypes but not usage types.
 886
 887 \begin{code}
 888 eqType t1 t2 = eq_ty emptyVarEnv t1 t2
 889 eqKind  = eqType        -- No worries about looking
 890 eqUsage = eqType        -- through source types for these two
 891
 892 -- Look through Notes
 893 eq_ty env (NoteTy _ t1)       t2                  = eq_ty env t1 t2
 894 eq_ty env t1                  (NoteTy _ t2)       = eq_ty env t1 t2
 895
 896 -- Look through SourceTy.  This is where the looping danger comes from
 897 eq_ty env (SourceTy sty1)     t2                  = eq_ty env (sourceTypeRep sty1) t2
 898 eq_ty env t1                  (SourceTy sty2)     = eq_ty env t1 (sourceTypeRep sty2)
 899
 900 -- The rest is plain sailing
 901 eq_ty env (TyVarTy tv1)       (TyVarTy tv2)       = case lookupVarEnv env tv1 of
 902                                                           Just tv1a -> tv1a == tv2
 903                                                           Nothing   -> tv1  == tv2
 904 eq_ty env (ForAllTy tv1 t1)   (ForAllTy tv2 t2)
 905         | tv1 == tv2                              = eq_ty env t1 t2
 906         | otherwise                               = eq_ty (extendVarEnv env tv1 tv2) t1 t2
 907 eq_ty env (AppTy s1 t1)       (AppTy s2 t2)       = (eq_ty env s1 s2) && (eq_ty env t1 t2)
 908 eq_ty env (FunTy s1 t1)       (FunTy s2 t2)       = (eq_ty env s1 s2) && (eq_ty env t1 t2)
 909 eq_ty env (UsageTy _ t1)      (UsageTy _ t2)      = eq_ty env t1 t2
 910 eq_ty env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 == tc2) && (eq_tys env tys1 tys2)
 911 eq_ty env t1                   t2                 = False
 912
 913 eq_tys env []        []        = True
 914 eq_tys env (t1:tys1) (t2:tys2) = (eq_ty env t1 t2) && (eq_tys env tys2 tys2)
 915 eq_tys env tys1      tys2      = False
 916 \end{code}
 917