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