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