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