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         (e) [recursive] newtypes
 402 It's useful in the back end.
 403
 404 Remember, non-recursive newtypes get expanded as part of the SourceTy case,
 405 but recursive ones are represented by TyConApps and have to be expanded
 406 by steam.
 407
 408 \begin{code}
 409 repType :: Type -> Type
 410 repType (ForAllTy _ ty)   = repType ty
 411 repType (NoteTy   _ ty)   = repType ty
 412 repType (SourceTy  p)     = repType (sourceTypeRep p)
 413 repType (UsageTy  _ ty)   = repType ty
 414 repType (TyConApp tc tys) | isNewTyCon tc && length tys == tyConArity tc
 415                           = repType (newTypeRep tc tys)
 416 repType ty                = ty
 417
 418 splitRepFunTys :: Type -> ([Type], Type)
 419 -- Like splitFunTys, but looks through newtypes and for-alls
 420 splitRepFunTys ty = split [] (repType ty)
 421   where
 422     split args (FunTy arg res)  = split (arg:args) (repType res)
 423     split args ty               = (reverse args, ty)
 424
 425 typePrimRep :: Type -> PrimRep
 426 typePrimRep ty = case repType ty of
 427                    TyConApp tc _ -> tyConPrimRep tc
 428                    FunTy _ _     -> PtrRep
 429                    AppTy _ _     -> PtrRep      -- ??
 430                    TyVarTy _     -> PtrRep
 431 \end{code}
 432
 433
 434
 435 ---------------------------------------------------------------------
 436                                 ForAllTy
 437                                 ~~~~~~~~
 438
 439 \begin{code}
 440 mkForAllTy :: TyVar -> Type -> Type
 441 mkForAllTy tyvar ty
 442   = mkForAllTys [tyvar] ty
 443
 444 mkForAllTys :: [TyVar] -> Type -> Type
 445 mkForAllTys tyvars ty
 446   = case splitUTy_maybe ty of
 447       Just (u,ty1) -> UASSERT2( not (mkVarSet tyvars `intersectsVarSet` tyVarsOfType u),
 448                                 ptext SLIT("mkForAllTys: usage scope")
 449                                 <+> ppr tyvars <+> pprType ty )
 450                       mkUTy u (foldr ForAllTy ty1 tyvars)  -- we lift usage annotations over foralls
 451       Nothing      -> foldr ForAllTy ty tyvars
 452
 453 isForAllTy :: Type -> Bool
 454 isForAllTy (NoteTy _ ty)  = isForAllTy ty
 455 isForAllTy (ForAllTy _ _) = True
 456 isForAllTy (UsageTy _ ty) = isForAllTy ty
 457 isForAllTy other_ty       = False
 458
 459 splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
 460 splitForAllTy_maybe ty = splitFAT_m ty
 461   where
 462     splitFAT_m (NoteTy _ ty)            = splitFAT_m ty
 463     splitFAT_m (SourceTy p)             = splitFAT_m (sourceTypeRep p)
 464     splitFAT_m (ForAllTy tyvar ty)      = Just(tyvar, ty)
 465     splitFAT_m (UsageTy _ ty)           = splitFAT_m ty
 466     splitFAT_m _                        = Nothing
 467
 468 splitForAllTys :: Type -> ([TyVar], Type)
 469 splitForAllTys ty = split ty ty []
 470    where
 471      split orig_ty (ForAllTy tv ty)       tvs = split ty ty (tv:tvs)
 472      split orig_ty (NoteTy _ ty)          tvs = split orig_ty ty tvs
 473      split orig_ty (SourceTy p)           tvs = split orig_ty (sourceTypeRep p) tvs
 474      split orig_ty (UsageTy _ ty)         tvs = split orig_ty ty tvs
 475      split orig_ty t                      tvs = (reverse tvs, orig_ty)
 476 \end{code}
 477
 478 -- (mkPiType now in CoreUtils)
 479
 480 Applying a for-all to its arguments.  Lift usage annotation as required.
 481
 482 \begin{code}
 483 applyTy :: Type -> Type -> Type
 484 applyTy (SourceTy p)                    arg = applyTy (sourceTypeRep p) arg
 485 applyTy (NoteTy _ fun)                  arg = applyTy fun arg
 486 applyTy (ForAllTy tv ty)                arg = UASSERT2( not (isUTy arg),
 487                                                         ptext SLIT("applyTy")
 488                                                         <+> pprType ty <+> pprType arg )
 489                                               substTyWith [tv] [arg] ty
 490 applyTy (UsageTy u ty)                  arg = UsageTy u (applyTy ty arg)
 491 applyTy other                           arg = panic "applyTy"
 492
 493 applyTys :: Type -> [Type] -> Type
 494 applyTys fun_ty arg_tys
 495  = UASSERT2( not (any isUTy arg_tys), ptext SLIT("applyTys") <+> pprType fun_ty )
 496    (case mu of
 497       Just u  -> UsageTy u
 498       Nothing -> id) $
 499    substTyWith tvs arg_tys ty
 500  where
 501    (mu, tvs, ty) = split fun_ty arg_tys
 502
 503    split fun_ty               []         = (Nothing, [], fun_ty)
 504    split (NoteTy _ fun_ty)    args       = split fun_ty args
 505    split (SourceTy p)         args       = split (sourceTypeRep p) args
 506    split (ForAllTy tv fun_ty) (arg:args) = case split fun_ty args of
 507                                                   (mu, tvs, ty) -> (mu, tv:tvs, ty)
 508    split (UsageTy u ty)       args       = case split ty args of
 509                                                   (Nothing, tvs, ty) -> (Just u, tvs, ty)
 510                                                   (Just _ , _  , _ ) -> pprPanic "applyTys:"
 511                                                                           (pprType fun_ty)
 512    split other_ty             args       = panic "applyTys"
 513 \end{code}
 514
 515
 516 ---------------------------------------------------------------------
 517                                 UsageTy
 518                                 ~~~~~~~
 519
 520 Constructing and taking apart usage types.
 521
 522 \begin{code}
 523 mkUTy :: Type -> Type -> Type
 524 mkUTy u ty
 525   = ASSERT2( typeKind u `eqKind` usageTypeKind,
 526              ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty )
 527     UASSERT2( not (isUTy ty), ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty )
 528     -- if u == usMany then ty else  : ToDo? KSW 2000-10
 529 #ifdef DO_USAGES
 530     UsageTy u ty
 531 #else
 532     ty
 533 #endif
 534
 535 splitUTy :: Type -> (Type {- :: $ -}, Type)
 536 splitUTy orig_ty
 537   = case splitUTy_maybe orig_ty of
 538       Just (u,ty) -> (u,ty)
 539 #ifdef DO_USAGES
 540       Nothing     -> pprPanic "splitUTy:" (pprType orig_ty)
 541 #else
 542       Nothing     -> (usMany,orig_ty)  -- default annotation ToDo KSW 2000-10
 543 #endif
 544
 545 splitUTy_maybe :: Type -> Maybe (Type {- :: $ -}, Type)
 546 splitUTy_maybe (UsageTy u ty) = Just (u,ty)
 547 splitUTy_maybe (NoteTy _ ty)  = splitUTy_maybe ty
 548 splitUTy_maybe other_ty       = Nothing
 549
 550 isUTy :: Type -> Bool
 551   -- has usage annotation
 552 isUTy = maybeToBool . splitUTy_maybe
 553
 554 uaUTy :: Type -> Type
 555   -- extract annotation
 556 uaUTy = fst . splitUTy
 557
 558 unUTy :: Type -> Type
 559   -- extract unannotated type
 560 unUTy = snd . splitUTy
 561 \end{code}
 562
 563 \begin{code}
 564 liftUTy :: (Type -> Type) -> Type -> Type
 565   -- lift outer usage annot over operation on unannotated types
 566 liftUTy f ty
 567   = let
 568       (u,ty') = splitUTy ty
 569     in
 570     mkUTy u (f ty')
 571 \end{code}
 572
 573 \begin{code}
 574 mkUTyM :: Type -> Type
 575   -- put TOP (no info) annotation on unannotated type
 576 mkUTyM ty = mkUTy usMany ty
 577 \end{code}
 578
 579 \begin{code}
 580 isUsageKind :: Kind -> Bool
 581 isUsageKind k
 582   = ASSERT( typeKind k `eqKind` superKind )
 583     k `eqKind` usageTypeKind
 584
 585 isUsage :: Type -> Bool
 586 isUsage ty
 587   = isUsageKind (typeKind ty)
 588
 589 isUTyVar :: Var -> Bool
 590 isUTyVar v
 591   = isUsageKind (tyVarKind v)
 592 \end{code}
 593
 594
 595 %************************************************************************
 596 %*                                                                      *
 597 \subsection{Source types}
 598 %*                                                                      *
 599 %************************************************************************
 600
 601 A "source type" is a type that is a separate type as far as the type checker is
 602 concerned, but which has low-level representation as far as the back end is concerned.
 603
 604 Source types are always lifted.
 605
 606 The key function is sourceTypeRep which gives the representation of a source type:
 607
 608 \begin{code}
 609 sourceTypeRep :: SourceType -> Type
 610 -- Convert a predicate to its "representation type";
 611 -- the type of evidence for that predicate, which is actually passed at runtime
 612 sourceTypeRep (IParam n ty)     = ty
 613 sourceTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys
 614         -- Note the mkTyConApp; the classTyCon might be a newtype!
 615 sourceTypeRep (NType  tc tys)   = newTypeRep tc tys
 616         -- ToDo: Consider caching this substitution in a NType
 617
 618 isSourceTy :: Type -> Bool
 619 isSourceTy (NoteTy _ ty)  = isSourceTy ty
 620 isSourceTy (UsageTy _ ty) = isSourceTy ty
 621 isSourceTy (SourceTy sty) = True
 622 isSourceTy _              = False
 623
 624
 625 splitNewType_maybe :: Type -> Maybe Type
 626 -- Newtypes that are recursive are reprsented by TyConApp, just
 627 -- as they always were.  Occasionally we want to find their representation type.
 628 -- NB: remember that in this module, non-recursive newtypes are transparent
 629
 630 splitNewType_maybe ty
 631   = case splitTyConApp_maybe ty of
 632         Just (tc,tys) | isNewTyCon tc -> ASSERT( length tys == tyConArity tc )
 633                                                 -- The assert should hold because repType should
 634                                                 -- only be applied to *types* (of kind *)
 635                                          Just (newTypeRep tc tys)
 636         other -> Nothing
 637
 638 -- A local helper function (not exported)
 639 newTypeRep new_tycon tys = case newTyConRep new_tycon of
 640                              (tvs, rep_ty) -> substTyWith tvs tys rep_ty
 641 \end{code}
 642
 643
 644 %************************************************************************
 645 %*                                                                      *
 646 \subsection{Kinds and free variables}
 647 %*                                                                      *
 648 %************************************************************************
 649
 650 ---------------------------------------------------------------------
 651                 Finding the kind of a type
 652                 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 653 \begin{code}
 654 typeKind :: Type -> Kind
 655
 656 typeKind (TyVarTy tyvar)        = tyVarKind tyvar
 657 typeKind (TyConApp tycon tys)   = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys
 658 typeKind (NoteTy _ ty)          = typeKind ty
 659 typeKind (SourceTy _)           = liftedTypeKind -- Predicates are always
 660                                                  -- represented by lifted types
 661 typeKind (AppTy fun arg)        = funResultTy (typeKind fun)
 662
 663 typeKind (FunTy arg res)        = fix_up (typeKind res)
 664                                 where
 665                                   fix_up (TyConApp tycon _) |  tycon == typeCon
 666                                                             || tycon == openKindCon = liftedTypeKind
 667                                   fix_up (NoteTy _ kind) = fix_up kind
 668                                   fix_up kind            = kind
 669                 -- The basic story is
 670                 --      typeKind (FunTy arg res) = typeKind res
 671                 -- But a function is lifted regardless of its result type
 672                 -- Hence the strange fix-up.
 673                 -- Note that 'res', being the result of a FunTy, can't have
 674                 -- a strange kind like (*->*).
 675
 676 typeKind (ForAllTy tv ty)       = typeKind ty
 677 typeKind (UsageTy _ ty)         = typeKind ty  -- we don't have separate kinds for ann/unann
 678 \end{code}
 679
 680
 681 ---------------------------------------------------------------------
 682                 Free variables of a type
 683                 ~~~~~~~~~~~~~~~~~~~~~~~~
 684 \begin{code}
 685
 686 tyVarsOfType :: Type -> TyVarSet
 687 tyVarsOfType (TyVarTy tv)               = unitVarSet tv
 688 tyVarsOfType (TyConApp tycon tys)       = tyVarsOfTypes tys
 689 tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
 690 tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
 691 tyVarsOfType (SourceTy sty)             = tyVarsOfSourceType sty
 692 tyVarsOfType (FunTy arg res)            = tyVarsOfType arg `unionVarSet` tyVarsOfType res
 693 tyVarsOfType (AppTy fun arg)            = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
 694 tyVarsOfType (ForAllTy tyvar ty)        = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
 695 tyVarsOfType (UsageTy u ty)             = tyVarsOfType u `unionVarSet` tyVarsOfType ty
 696
 697 tyVarsOfTypes :: [Type] -> TyVarSet
 698 tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
 699
 700 tyVarsOfPred :: PredType -> TyVarSet
 701 tyVarsOfPred = tyVarsOfSourceType       -- Just a subtype
 702
 703 tyVarsOfSourceType :: SourceType -> TyVarSet
 704 tyVarsOfSourceType (IParam n ty)     = tyVarsOfType ty
 705 tyVarsOfSourceType (ClassP clas tys) = tyVarsOfTypes tys
 706 tyVarsOfSourceType (NType tc tys)    = tyVarsOfTypes tys
 707
 708 tyVarsOfTheta :: ThetaType -> TyVarSet
 709 tyVarsOfTheta = foldr (unionVarSet . tyVarsOfSourceType) emptyVarSet
 710
 711 -- Add a Note with the free tyvars to the top of the type
 712 addFreeTyVars :: Type -> Type
 713 addFreeTyVars ty@(NoteTy (FTVNote _) _)      = ty
 714 addFreeTyVars ty                             = NoteTy (FTVNote (tyVarsOfType ty)) ty
 715 \end{code}
 716
 717 Usage annotations of a type
 718 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 719
 720 Get a list of usage annotations of a type, *in left-to-right pre-order*.
 721
 722 \begin{code}
 723 usageAnnOfType :: Type -> [Type]
 724 usageAnnOfType ty
 725   = goS ty
 726   where
 727     goT (TyVarTy _)       = []
 728     goT (AppTy ty1 ty2)   = goT ty1 ++ goT ty2
 729     goT (TyConApp tc tys) = concatMap goT tys
 730     goT (FunTy sty1 sty2) = goS sty1 ++ goS sty2
 731     goT (ForAllTy mv ty)  = goT ty
 732     goT (SourceTy p)      = goT (sourceTypeRep p)
 733     goT ty@(UsageTy _ _)  = pprPanic "usageAnnOfType: unexpected usage:" (pprType ty)
 734     goT (NoteTy note ty)  = goT ty
 735
 736     goS sty = case splitUTy sty of
 737                 (u,tty) -> u : goT tty
 738 \end{code}
 739
 740
 741 %************************************************************************
 742 %*                                                                      *
 743 \subsection{TidyType}
 744 %*                                                                      *
 745 %************************************************************************
 746
 747 tidyTy tidies up a type for printing in an error message, or in
 748 an interface file.
 749
 750 It doesn't change the uniques at all, just the print names.
 751
 752 \begin{code}
 753 tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
 754 tidyTyVar env@(tidy_env, subst) tyvar
 755   = case lookupVarEnv subst tyvar of
 756
 757         Just tyvar' ->  -- Already substituted
 758                 (env, tyvar')
 759
 760         Nothing ->      -- Make a new nice name for it
 761
 762                 case tidyOccName tidy_env (getOccName name) of
 763                     (tidy', occ') ->    -- New occname reqd
 764                                 ((tidy', subst'), tyvar')
 765                               where
 766                                 subst' = extendVarEnv subst tyvar tyvar'
 767                                 tyvar' = setTyVarName tyvar name'
 768                                 name'  = mkLocalName (getUnique name) occ' noSrcLoc
 769                                         -- Note: make a *user* tyvar, so it printes nicely
 770                                         -- Could extract src loc, but no need.
 771   where
 772     name = tyVarName tyvar
 773
 774 tidyTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
 775 tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars
 776
 777 tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv
 778 -- Add the free tyvars to the env in tidy form,
 779 -- so that we can tidy the type they are free in
 780 tidyFreeTyVars env tyvars = foldl add env (varSetElems tyvars)
 781                           where
 782                             add env tv = fst (tidyTyVar env tv)
 783
 784 tidyType :: TidyEnv -> Type -> Type
 785 tidyType env@(tidy_env, subst) ty
 786   = go ty
 787   where
 788     go (TyVarTy tv)         = case lookupVarEnv subst tv of
 789                                 Nothing  -> TyVarTy tv
 790                                 Just tv' -> TyVarTy tv'
 791     go (TyConApp tycon tys) = let args = map go tys
 792                               in args `seqList` TyConApp tycon args
 793     go (NoteTy note ty)     = (NoteTy SAPPLY (go_note note)) SAPPLY (go ty)
 794     go (SourceTy sty)       = SourceTy (tidySourceType env sty)
 795     go (AppTy fun arg)      = (AppTy SAPPLY (go fun)) SAPPLY (go arg)
 796     go (FunTy fun arg)      = (FunTy SAPPLY (go fun)) SAPPLY (go arg)
 797     go (ForAllTy tv ty)     = ForAllTy tvp SAPPLY (tidyType envp ty)
 798                               where
 799                                 (envp, tvp) = tidyTyVar env tv
 800     go (UsageTy u ty)       = (UsageTy SAPPLY (go u)) SAPPLY (go ty)
 801
 802     go_note (SynNote ty)        = SynNote SAPPLY (go ty)
 803     go_note note@(FTVNote ftvs) = note  -- No need to tidy the free tyvars
 804
 805 tidyTypes env tys = map (tidyType env) tys
 806
 807 tidyPred :: TidyEnv -> SourceType -> SourceType
 808 tidyPred = tidySourceType
 809
 810 tidySourceType :: TidyEnv -> SourceType -> SourceType
 811 tidySourceType env (IParam n ty)     = IParam n (tidyType env ty)
 812 tidySourceType env (ClassP clas tys) = ClassP clas (tidyTypes env tys)
 813 tidySourceType env (NType tc tys)    = NType  tc   (tidyTypes env tys)
 814 \end{code}
 815
 816
 817 @tidyOpenType@ grabs the free type variables, tidies them
 818 and then uses @tidyType@ to work over the type itself
 819
 820 \begin{code}
 821 tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
 822 tidyOpenType env ty
 823   = (env', tidyType env' ty)
 824   where
 825     env' = tidyFreeTyVars env (tyVarsOfType ty)
 826
 827 tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
 828 tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
 829
 830 tidyTopType :: Type -> Type
 831 tidyTopType ty = tidyType emptyTidyEnv ty
 832 \end{code}
 833
 834
 835
 836 %************************************************************************
 837 %*                                                                      *
 838 \subsection{Liftedness}
 839 %*                                                                      *
 840 %************************************************************************
 841
 842 \begin{code}
 843 isUnLiftedType :: Type -> Bool
 844         -- isUnLiftedType returns True for forall'd unlifted types:
 845         --      x :: forall a. Int#
 846         -- I found bindings like these were getting floated to the top level.
 847         -- They are pretty bogus types, mind you.  It would be better never to
 848         -- construct them
 849
 850 isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty
 851 isUnLiftedType (NoteTy _ ty)    = isUnLiftedType ty
 852 isUnLiftedType (TyConApp tc _)  = isUnLiftedTyCon tc
 853 isUnLiftedType (UsageTy _ ty)   = isUnLiftedType ty
 854 isUnLiftedType (SourceTy _)     = False         -- All source types are lifted
 855 isUnLiftedType other            = False
 856
 857 isUnboxedTupleType :: Type -> Bool
 858 isUnboxedTupleType ty = case splitTyConApp_maybe ty of
 859                            Just (tc, ty_args) -> isUnboxedTupleTyCon tc
 860                            other              -> False
 861
 862 -- Should only be applied to *types*; hence the assert
 863 isAlgType :: Type -> Bool
 864 isAlgType ty = case splitTyConApp_maybe ty of
 865                         Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
 866                                               isAlgTyCon tc
 867                         other              -> False
 868 \end{code}
 869
 870
 871 %************************************************************************
 872 %*                                                                      *
 873 \subsection{Sequencing on types
 874 %*                                                                      *
 875 %************************************************************************
 876
 877 \begin{code}
 878 seqType :: Type -> ()
 879 seqType (TyVarTy tv)      = tv `seq` ()
 880 seqType (AppTy t1 t2)     = seqType t1 `seq` seqType t2
 881 seqType (FunTy t1 t2)     = seqType t1 `seq` seqType t2
 882 seqType (NoteTy note t2)  = seqNote note `seq` seqType t2
 883 seqType (SourceTy p)      = seqPred p
 884 seqType (TyConApp tc tys) = tc `seq` seqTypes tys
 885 seqType (ForAllTy tv ty)  = tv `seq` seqType ty
 886 seqType (UsageTy u ty)    = seqType u `seq` seqType ty
 887
 888 seqTypes :: [Type] -> ()
 889 seqTypes []       = ()
 890 seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
 891
 892 seqNote :: TyNote -> ()
 893 seqNote (SynNote ty)  = seqType ty
 894 seqNote (FTVNote set) = sizeUniqSet set `seq` ()
 895
 896 seqPred :: SourceType -> ()
 897 seqPred (ClassP c tys) = c  `seq` seqTypes tys
 898 seqPred (NType tc tys) = tc `seq` seqTypes tys
 899 seqPred (IParam n ty)  = n  `seq` seqType ty
 900 \end{code}
 901
 902
 903 %************************************************************************
 904 %*                                                                      *
 905 \subsection{Equality on types}
 906 %*                                                                      *
 907 %************************************************************************
 908
 909 Comparison; don't use instances so that we know where it happens.
 910 Look through newtypes but not usage types.
 911
 912 \begin{code}
 913 eqType t1 t2 = eq_ty emptyVarEnv t1 t2
 914 eqKind  = eqType        -- No worries about looking
 915 eqUsage = eqType        -- through source types for these two
 916
 917 -- Look through Notes
 918 eq_ty env (NoteTy _ t1)       t2                  = eq_ty env t1 t2
 919 eq_ty env t1                  (NoteTy _ t2)       = eq_ty env t1 t2
 920
 921 -- Look through SourceTy.  This is where the looping danger comes from
 922 eq_ty env (SourceTy sty1)     t2                  = eq_ty env (sourceTypeRep sty1) t2
 923 eq_ty env t1                  (SourceTy sty2)     = eq_ty env t1 (sourceTypeRep sty2)
 924
 925 -- The rest is plain sailing
 926 eq_ty env (TyVarTy tv1)       (TyVarTy tv2)       = case lookupVarEnv env tv1 of
 927                                                           Just tv1a -> tv1a == tv2
 928                                                           Nothing   -> tv1  == tv2
 929 eq_ty env (ForAllTy tv1 t1)   (ForAllTy tv2 t2)
 930         | tv1 == tv2                              = eq_ty env t1 t2
 931         | otherwise                               = eq_ty (extendVarEnv env tv1 tv2) t1 t2
 932 eq_ty env (AppTy s1 t1)       (AppTy s2 t2)       = (eq_ty env s1 s2) && (eq_ty env t1 t2)
 933 eq_ty env (FunTy s1 t1)       (FunTy s2 t2)       = (eq_ty env s1 s2) && (eq_ty env t1 t2)
 934 eq_ty env (UsageTy _ t1)      (UsageTy _ t2)      = eq_ty env t1 t2
 935 eq_ty env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 == tc2) && (eq_tys env tys1 tys2)
 936 eq_ty env t1                   t2                 = False
 937
 938 eq_tys env []        []        = True
 939 eq_tys env (t1:tys1) (t2:tys2) = (eq_ty env t1 t2) && (eq_tys env tys1 tys2)
 940 eq_tys env tys1      tys2      = False
 941 \end{code}
 942