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