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