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         TyThing(..), Type, PredType(..), ThetaType, TyVarSubst,
  10         funTyCon,
  11
  12         -- Re-exports from Kind
  13         module Kind,
  14
  15
  16         mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy,
  17
  18         mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe,
  19
  20         mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys,
  21         funResultTy, funArgTy, zipFunTys, isFunTy,
  22
  23         mkGenTyConApp, mkTyConApp, mkTyConTy,
  24         tyConAppTyCon, tyConAppArgs,
  25         splitTyConApp_maybe, splitTyConApp,
  26
  27         mkSynTy,
  28
  29         repType, typePrimRep,
  30
  31         mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
  32         applyTy, applyTys, isForAllTy, dropForAlls,
  33
  34         -- Source types
  35         predTypeRep, mkPredTy, mkPredTys,
  36
  37         -- Newtypes
  38         splitRecNewType_maybe,
  39
  40         -- Lifting and boxity
  41         isUnLiftedType, isUnboxedTupleType, isAlgType, isPrimitiveType,
  42         isStrictType, isStrictPred,
  43
  44         -- Free variables
  45         tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
  46         typeKind, addFreeTyVars,
  47
  48         -- Tidying up for printing
  49         tidyType,      tidyTypes,
  50         tidyOpenType,  tidyOpenTypes,
  51         tidyTyVarBndr, tidyFreeTyVars,
  52         tidyOpenTyVar, tidyOpenTyVars,
  53         tidyTopType,   tidyPred,
  54
  55         -- Comparison
  56         eqType,
  57
  58         -- Seq
  59         seqType, seqTypes,
  60
  61         -- Pretty-printing
  62         pprType, pprParendType,
  63         pprPred, pprTheta, pprThetaArrow, pprClassPred
  64     ) where
  65
  66 #include "HsVersions.h"
  67
  68 -- We import the representation and primitive functions from TypeRep.
  69 -- Many things are reexported, but not the representation!
  70
  71 import TypeRep
  72
  73 -- Other imports:
  74
  75 import {-# SOURCE #-}   Subst  ( substTyWith )
  76
  77 -- friends:
  78 import Kind
  79 import Var      ( TyVar, tyVarKind, tyVarName, setTyVarName )
  80 import VarEnv
  81 import VarSet
  82
  83 import Name     ( NamedThing(..), mkInternalName, tidyOccName )
  84 import Class    ( Class, classTyCon )
  85 import TyCon    ( TyCon, isRecursiveTyCon, isPrimTyCon,
  86                   isUnboxedTupleTyCon, isUnLiftedTyCon,
  87                   isFunTyCon, isNewTyCon, newTyConRep,
  88                   isAlgTyCon, isSynTyCon, tyConArity,
  89                   tyConKind, getSynTyConDefn,
  90                   tyConPrimRep,
  91                 )
  92
  93 -- others
  94 import CmdLineOpts      ( opt_DictsStrict )
  95 import SrcLoc           ( noSrcLoc )
  96 import PrimRep          ( PrimRep(..) )
  97 import Unique           ( Uniquable(..) )
  98 import Util             ( mapAccumL, seqList, lengthIs, snocView )
  99 import Outputable
 100 import UniqSet          ( sizeUniqSet )         -- Should come via VarSet
 101 import Maybe            ( isJust )
 102 \end{code}
 103
 104
 105 %************************************************************************
 106 %*                                                                      *
 107 \subsection{Constructor-specific functions}
 108 %*                                                                      *
 109 %************************************************************************
 110
 111
 112 ---------------------------------------------------------------------
 113                                 TyVarTy
 114                                 ~~~~~~~
 115 \begin{code}
 116 mkTyVarTy  :: TyVar   -> Type
 117 mkTyVarTy  = TyVarTy
 118
 119 mkTyVarTys :: [TyVar] -> [Type]
 120 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
 121
 122 getTyVar :: String -> Type -> TyVar
 123 getTyVar msg ty = case getTyVar_maybe ty of
 124                     Just tv -> tv
 125                     Nothing -> panic ("getTyVar: " ++ msg)
 126
 127 isTyVarTy :: Type -> Bool
 128 isTyVarTy ty = isJust (getTyVar_maybe ty)
 129
 130 getTyVar_maybe :: Type -> Maybe TyVar
 131 getTyVar_maybe (TyVarTy tv)      = Just tv
 132 getTyVar_maybe (NoteTy _ t)      = getTyVar_maybe t
 133 getTyVar_maybe (PredTy p)        = getTyVar_maybe (predTypeRep p)
 134 getTyVar_maybe (NewTcApp tc tys) = getTyVar_maybe (newTypeRep tc tys)
 135 getTyVar_maybe other             = Nothing
 136 \end{code}
 137
 138
 139 ---------------------------------------------------------------------
 140                                 AppTy
 141                                 ~~~~~
 142 We need to be pretty careful with AppTy to make sure we obey the
 143 invariant that a TyConApp is always visibly so.  mkAppTy maintains the
 144 invariant: use it.
 145
 146 \begin{code}
 147 mkAppTy orig_ty1 orig_ty2
 148   = mk_app orig_ty1
 149   where
 150     mk_app (NoteTy _ ty1)    = mk_app ty1
 151     mk_app (NewTcApp tc tys) = NewTcApp tc (tys ++ [orig_ty2])
 152     mk_app (TyConApp tc tys) = mkGenTyConApp tc (tys ++ [orig_ty2])
 153     mk_app ty1               = AppTy orig_ty1 orig_ty2
 154         -- We call mkGenTyConApp because the TyConApp could be an
 155         -- under-saturated type synonym.  GHC allows that; e.g.
 156         --      type Foo k = k a -> k a
 157         --      type Id x = x
 158         --      foo :: Foo Id -> Foo Id
 159         --
 160         -- Here Id is partially applied in the type sig for Foo,
 161         -- but once the type synonyms are expanded all is well
 162
 163 mkAppTys :: Type -> [Type] -> Type
 164 mkAppTys orig_ty1 []        = orig_ty1
 165         -- This check for an empty list of type arguments
 166         -- avoids the needless loss of a type synonym constructor.
 167         -- For example: mkAppTys Rational []
 168         --   returns to (Ratio Integer), which has needlessly lost
 169         --   the Rational part.
 170 mkAppTys orig_ty1 orig_tys2
 171   = mk_app orig_ty1
 172   where
 173     mk_app (NoteTy _ ty1)    = mk_app ty1
 174     mk_app (NewTcApp tc tys) = NewTcApp tc (tys ++ orig_tys2)
 175     mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
 176                                 -- Use mkTyConApp in case tc is (->)
 177     mk_app ty1               = foldl AppTy orig_ty1 orig_tys2
 178
 179 splitAppTy_maybe :: Type -> Maybe (Type, Type)
 180 splitAppTy_maybe (FunTy ty1 ty2)   = Just (TyConApp funTyCon [ty1], ty2)
 181 splitAppTy_maybe (AppTy ty1 ty2)   = Just (ty1, ty2)
 182 splitAppTy_maybe (NoteTy _ ty)     = splitAppTy_maybe ty
 183 splitAppTy_maybe (PredTy p)        = splitAppTy_maybe (predTypeRep p)
 184 splitAppTy_maybe (NewTcApp tc tys) = splitAppTy_maybe (newTypeRep tc tys)
 185 splitAppTy_maybe (TyConApp tc tys) = case snocView tys of
 186                                         Nothing -> Nothing
 187                                         Just (tys',ty') -> Just (mkGenTyConApp tc tys', ty')
 188                                                 -- mkGenTyConApp just in case the tc is a newtype
 189
 190 splitAppTy_maybe other             = Nothing
 191
 192 splitAppTy :: Type -> (Type, Type)
 193 splitAppTy ty = case splitAppTy_maybe ty of
 194                         Just pr -> pr
 195                         Nothing -> panic "splitAppTy"
 196
 197 splitAppTys :: Type -> (Type, [Type])
 198 splitAppTys ty = split ty ty []
 199   where
 200     split orig_ty (AppTy ty arg)        args = split ty ty (arg:args)
 201     split orig_ty (NoteTy _ ty)         args = split orig_ty ty args
 202     split orig_ty (PredTy p)            args = split orig_ty (predTypeRep p) args
 203     split orig_ty (NewTcApp tc tc_args) args = split orig_ty (newTypeRep tc tc_args) args
 204     split orig_ty (TyConApp tc tc_args) args = (mkGenTyConApp tc [], tc_args ++ args)
 205                                                 -- mkGenTyConApp just in case the tc is a newtype
 206     split orig_ty (FunTy ty1 ty2)       args = ASSERT( null args )
 207                                                (TyConApp funTyCon [], [ty1,ty2])
 208     split orig_ty ty                    args = (orig_ty, args)
 209 \end{code}
 210
 211
 212 ---------------------------------------------------------------------
 213                                 FunTy
 214                                 ~~~~~
 215
 216 \begin{code}
 217 mkFunTy :: Type -> Type -> Type
 218 mkFunTy arg res = FunTy arg res
 219
 220 mkFunTys :: [Type] -> Type -> Type
 221 mkFunTys tys ty = foldr FunTy ty tys
 222
 223 isFunTy :: Type -> Bool
 224 isFunTy ty = isJust (splitFunTy_maybe ty)
 225
 226 splitFunTy :: Type -> (Type, Type)
 227 splitFunTy (FunTy arg res)   = (arg, res)
 228 splitFunTy (NoteTy _ ty)     = splitFunTy ty
 229 splitFunTy (PredTy p)        = splitFunTy (predTypeRep p)
 230 splitFunTy (NewTcApp tc tys) = splitFunTy (newTypeRep tc tys)
 231 splitFunTy other             = pprPanic "splitFunTy" (ppr other)
 232
 233 splitFunTy_maybe :: Type -> Maybe (Type, Type)
 234 splitFunTy_maybe (FunTy arg res)   = Just (arg, res)
 235 splitFunTy_maybe (NoteTy _ ty)     = splitFunTy_maybe ty
 236 splitFunTy_maybe (PredTy p)        = splitFunTy_maybe (predTypeRep p)
 237 splitFunTy_maybe (NewTcApp tc tys) = splitFunTy_maybe (newTypeRep tc tys)
 238 splitFunTy_maybe other             = Nothing
 239
 240 splitFunTys :: Type -> ([Type], Type)
 241 splitFunTys ty = split [] ty ty
 242   where
 243     split args orig_ty (FunTy arg res)   = split (arg:args) res res
 244     split args orig_ty (NoteTy _ ty)     = split args orig_ty ty
 245     split args orig_ty (PredTy p)        = split args orig_ty (predTypeRep p)
 246     split args orig_ty (NewTcApp tc tys) = split args orig_ty (newTypeRep tc tys)
 247     split args orig_ty ty                = (reverse args, orig_ty)
 248
 249 zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type)
 250 zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
 251   where
 252     split acc []     nty ty                = (reverse acc, nty)
 253     split acc (x:xs) nty (FunTy arg res)   = split ((x,arg):acc) xs res res
 254     split acc xs     nty (NoteTy _ ty)     = split acc           xs nty ty
 255     split acc xs     nty (PredTy p)        = split acc           xs nty (predTypeRep p)
 256     split acc xs     nty (NewTcApp tc tys) = split acc           xs nty (newTypeRep tc tys)
 257     split acc (x:xs) nty ty                = pprPanic "zipFunTys" (ppr orig_xs <+> ppr orig_ty)
 258
 259 funResultTy :: Type -> Type
 260 funResultTy (FunTy arg res)   = res
 261 funResultTy (NoteTy _ ty)     = funResultTy ty
 262 funResultTy (PredTy p)        = funResultTy (predTypeRep p)
 263 funResultTy (NewTcApp tc tys) = funResultTy (newTypeRep tc tys)
 264 funResultTy ty                = pprPanic "funResultTy" (ppr ty)
 265
 266 funArgTy :: Type -> Type
 267 funArgTy (FunTy arg res)   = arg
 268 funArgTy (NoteTy _ ty)     = funArgTy ty
 269 funArgTy (PredTy p)        = funArgTy (predTypeRep p)
 270 funArgTy (NewTcApp tc tys) = funArgTy (newTypeRep tc tys)
 271 funArgTy ty                = pprPanic "funArgTy" (ppr ty)
 272 \end{code}
 273
 274
 275 ---------------------------------------------------------------------
 276                                 TyConApp
 277                                 ~~~~~~~~
 278 @mkTyConApp@ is a key function, because it builds a TyConApp, FunTy or PredTy,
 279 as apppropriate.
 280
 281 \begin{code}
 282 mkGenTyConApp :: TyCon -> [Type] -> Type
 283 mkGenTyConApp tc tys
 284   | isSynTyCon tc = mkSynTy tc tys
 285   | otherwise     = mkTyConApp tc tys
 286
 287 mkTyConApp :: TyCon -> [Type] -> Type
 288 -- Assumes TyCon is not a SynTyCon; use mkSynTy instead for those
 289 mkTyConApp tycon tys
 290   | isFunTyCon tycon, [ty1,ty2] <- tys
 291   = FunTy ty1 ty2
 292
 293   | isNewTyCon tycon
 294   = NewTcApp tycon tys
 295
 296   | otherwise
 297   = ASSERT(not (isSynTyCon tycon))
 298     TyConApp tycon tys
 299
 300 mkTyConTy :: TyCon -> Type
 301 mkTyConTy tycon = mkTyConApp tycon []
 302
 303 -- splitTyConApp "looks through" synonyms, because they don't
 304 -- mean a distinct type, but all other type-constructor applications
 305 -- including functions are returned as Just ..
 306
 307 tyConAppTyCon :: Type -> TyCon
 308 tyConAppTyCon ty = fst (splitTyConApp ty)
 309
 310 tyConAppArgs :: Type -> [Type]
 311 tyConAppArgs ty = snd (splitTyConApp ty)
 312
 313 splitTyConApp :: Type -> (TyCon, [Type])
 314 splitTyConApp ty = case splitTyConApp_maybe ty of
 315                         Just stuff -> stuff
 316                         Nothing    -> pprPanic "splitTyConApp" (ppr ty)
 317
 318 splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
 319 splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
 320 splitTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [arg,res])
 321 splitTyConApp_maybe (NoteTy _ ty)     = splitTyConApp_maybe ty
 322 splitTyConApp_maybe (PredTy p)        = splitTyConApp_maybe (predTypeRep p)
 323 splitTyConApp_maybe (NewTcApp tc tys) = splitTyConApp_maybe (newTypeRep tc tys)
 324 splitTyConApp_maybe other             = Nothing
 325 \end{code}
 326
 327
 328 ---------------------------------------------------------------------
 329                                 SynTy
 330                                 ~~~~~
 331
 332 \begin{code}
 333 mkSynTy tycon tys
 334   | n_args == arity     -- Exactly saturated
 335   = mk_syn tys
 336   | n_args >  arity     -- Over-saturated
 337   = case splitAt arity tys of { (as,bs) -> mkAppTys (mk_syn as) bs }
 338         -- Its important to use mkAppTys, rather than (foldl AppTy),
 339         -- because (mk_syn as) might well return a partially-applied
 340         -- type constructor; indeed, usually will!
 341   | otherwise           -- Un-saturated
 342   = TyConApp tycon tys
 343         -- For the un-saturated case we build TyConApp directly
 344         -- (mkTyConApp ASSERTs that the tc isn't a SynTyCon).
 345         -- Here we are relying on checkValidType to find
 346         -- the error.  What we can't do is use mkSynTy with
 347         -- too few arg tys, because that is utterly bogus.
 348
 349   where
 350     mk_syn tys = NoteTy (SynNote (TyConApp tycon tys))
 351                         (substTyWith tyvars tys body)
 352
 353     (tyvars, body) = ASSERT( isSynTyCon tycon ) getSynTyConDefn tycon
 354     arity          = tyConArity tycon
 355     n_args         = length tys
 356 \end{code}
 357
 358 Notes on type synonyms
 359 ~~~~~~~~~~~~~~~~~~~~~~
 360 The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
 361 to return type synonyms whereever possible. Thus
 362
 363         type Foo a = a -> a
 364
 365 we want
 366         splitFunTys (a -> Foo a) = ([a], Foo a)
 367 not                                ([a], a -> a)
 368
 369 The reason is that we then get better (shorter) type signatures in
 370 interfaces.  Notably this plays a role in tcTySigs in TcBinds.lhs.
 371
 372
 373                 Representation types
 374                 ~~~~~~~~~~~~~~~~~~~~
 375 repType looks through
 376         (a) for-alls, and
 377         (b) synonyms
 378         (c) predicates
 379         (d) usage annotations
 380         (e) [recursive] newtypes
 381 It's useful in the back end.
 382
 383 \begin{code}
 384 repType :: Type -> Type
 385 -- Only applied to types of kind *; hence tycons are saturated
 386 repType (ForAllTy _ ty)   = repType ty
 387 repType (NoteTy   _ ty)   = repType ty
 388 repType (PredTy  p)       = repType (predTypeRep p)
 389 repType (NewTcApp tc tys) = ASSERT( tys `lengthIs` tyConArity tc )
 390                             repType (new_type_rep tc tys)
 391 repType ty                = ty
 392
 393
 394 typePrimRep :: Type -> PrimRep
 395 typePrimRep ty = case repType ty of
 396                    TyConApp tc _ -> tyConPrimRep tc
 397                    FunTy _ _     -> PtrRep
 398                    AppTy _ _     -> PtrRep      -- ??
 399                    TyVarTy _     -> PtrRep
 400                    other         -> pprPanic "typePrimRep" (ppr ty)
 401 \end{code}
 402
 403
 404
 405 ---------------------------------------------------------------------
 406                                 ForAllTy
 407                                 ~~~~~~~~
 408
 409 \begin{code}
 410 mkForAllTy :: TyVar -> Type -> Type
 411 mkForAllTy tyvar ty
 412   = mkForAllTys [tyvar] ty
 413
 414 mkForAllTys :: [TyVar] -> Type -> Type
 415 mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
 416
 417 isForAllTy :: Type -> Bool
 418 isForAllTy (NoteTy _ ty)  = isForAllTy ty
 419 isForAllTy (ForAllTy _ _) = True
 420 isForAllTy other_ty       = False
 421
 422 splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
 423 splitForAllTy_maybe ty = splitFAT_m ty
 424   where
 425     splitFAT_m (NoteTy _ ty)            = splitFAT_m ty
 426     splitFAT_m (PredTy p)               = splitFAT_m (predTypeRep p)
 427     splitFAT_m (NewTcApp tc tys)        = splitFAT_m (newTypeRep tc tys)
 428     splitFAT_m (ForAllTy tyvar ty)      = Just(tyvar, ty)
 429     splitFAT_m _                        = Nothing
 430
 431 splitForAllTys :: Type -> ([TyVar], Type)
 432 splitForAllTys ty = split ty ty []
 433    where
 434      split orig_ty (ForAllTy tv ty)  tvs = split ty ty (tv:tvs)
 435      split orig_ty (NoteTy _ ty)     tvs = split orig_ty ty tvs
 436      split orig_ty (PredTy p)        tvs = split orig_ty (predTypeRep p) tvs
 437      split orig_ty (NewTcApp tc tys) tvs = split orig_ty (newTypeRep tc tys) tvs
 438      split orig_ty t                 tvs = (reverse tvs, orig_ty)
 439
 440 dropForAlls :: Type -> Type
 441 dropForAlls ty = snd (splitForAllTys ty)
 442 \end{code}
 443
 444 -- (mkPiType now in CoreUtils)
 445
 446 applyTy, applyTys
 447 ~~~~~~~~~~~~~~~~~
 448 Instantiate a for-all type with one or more type arguments.
 449 Used when we have a polymorphic function applied to type args:
 450         f t1 t2
 451 Then we use (applyTys type-of-f [t1,t2]) to compute the type of
 452 the expression.
 453
 454 \begin{code}
 455 applyTy :: Type -> Type -> Type
 456 applyTy (PredTy p)        arg = applyTy (predTypeRep p) arg
 457 applyTy (NewTcApp tc tys) arg = applyTy (newTypeRep tc tys) arg
 458 applyTy (NoteTy _ fun)    arg = applyTy fun arg
 459 applyTy (ForAllTy tv ty)  arg = substTyWith [tv] [arg] ty
 460 applyTy other             arg = panic "applyTy"
 461
 462 applyTys :: Type -> [Type] -> Type
 463 -- This function is interesting because
 464 --      a) the function may have more for-alls than there are args
 465 --      b) less obviously, it may have fewer for-alls
 466 -- For case (b) think of
 467 --      applyTys (forall a.a) [forall b.b, Int]
 468 -- This really can happen, via dressing up polymorphic types with newtype
 469 -- clothing.  Here's an example:
 470 --      newtype R = R (forall a. a->a)
 471 --      foo = case undefined :: R of
 472 --              R f -> f ()
 473
 474 applyTys orig_fun_ty []      = orig_fun_ty
 475 applyTys orig_fun_ty arg_tys
 476   | n_tvs == n_args     -- The vastly common case
 477   = substTyWith tvs arg_tys rho_ty
 478   | n_tvs > n_args      -- Too many for-alls
 479   = substTyWith (take n_args tvs) arg_tys
 480                 (mkForAllTys (drop n_args tvs) rho_ty)
 481   | otherwise           -- Too many type args
 482   = ASSERT2( n_tvs > 0, ppr orig_fun_ty )       -- Zero case gives infnite loop!
 483     applyTys (substTyWith tvs (take n_tvs arg_tys) rho_ty)
 484              (drop n_tvs arg_tys)
 485   where
 486     (tvs, rho_ty) = splitForAllTys orig_fun_ty
 487     n_tvs = length tvs
 488     n_args = length arg_tys
 489 \end{code}
 490
 491
 492 %************************************************************************
 493 %*                                                                      *
 494 \subsection{Source types}
 495 %*                                                                      *
 496 %************************************************************************
 497
 498 A "source type" is a type that is a separate type as far as the type checker is
 499 concerned, but which has low-level representation as far as the back end is concerned.
 500
 501 Source types are always lifted.
 502
 503 The key function is predTypeRep which gives the representation of a source type:
 504
 505 \begin{code}
 506 mkPredTy :: PredType -> Type
 507 mkPredTy pred = PredTy pred
 508
 509 mkPredTys :: ThetaType -> [Type]
 510 mkPredTys preds = map PredTy preds
 511
 512 predTypeRep :: PredType -> Type
 513 -- Convert a PredType to its "representation type";
 514 -- the post-type-checking type used by all the Core passes of GHC.
 515 predTypeRep (IParam _ ty)     = ty
 516 predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys
 517         -- Result might be a NewTcApp, but the consumer will
 518         -- look through that too if necessary
 519 \end{code}
 520
 521
 522 %************************************************************************
 523 %*                                                                      *
 524                 NewTypes
 525 %*                                                                      *
 526 %************************************************************************
 527
 528 \begin{code}
 529 splitRecNewType_maybe :: Type -> Maybe Type
 530 -- Newtypes are always represented by a NewTcApp
 531 -- Sometimes we want to look through a recursive newtype, and that's what happens here
 532 -- Only applied to types of kind *, hence the newtype is always saturated
 533 splitRecNewType_maybe (NoteTy _ ty) = splitRecNewType_maybe ty
 534 splitRecNewType_maybe (NewTcApp tc tys)
 535   | isRecursiveTyCon tc
 536   = ASSERT( tys `lengthIs` tyConArity tc && isNewTyCon tc )
 537         -- The assert should hold because repType should
 538         -- only be applied to *types* (of kind *)
 539     Just (new_type_rep tc tys)
 540 splitRecNewType_maybe other = Nothing
 541
 542 -----------------------------
 543 newTypeRep :: TyCon -> [Type] -> Type
 544 -- A local helper function (not exported)
 545 -- Expands a newtype application to
 546 --      *either* a vanilla TyConApp (recursive newtype, or non-saturated)
 547 --      *or*     the newtype representation (otherwise)
 548 -- Either way, the result is not a NewTcApp
 549 --
 550 -- NB: the returned TyConApp is always deconstructed immediately by the
 551 --     caller... a TyConApp with a newtype type constructor never lives
 552 --     in an ordinary type
 553 newTypeRep tc tys
 554   | not (isRecursiveTyCon tc),          -- Not recursive and saturated
 555     tys `lengthIs` tyConArity tc        -- treat as equivalent to expansion
 556   = new_type_rep tc tys
 557   | otherwise
 558   = TyConApp tc tys
 559         -- ToDo: Consider caching this substitution in a NType
 560
 561 ----------------------------
 562 -- new_type_rep doesn't ask any questions:
 563 -- it just expands newtype, whether recursive or not
 564 new_type_rep new_tycon tys = ASSERT( tys `lengthIs` tyConArity new_tycon )
 565                              case newTyConRep new_tycon of
 566                                  (tvs, rep_ty) -> substTyWith tvs tys rep_ty
 567 \end{code}
 568
 569
 570 %************************************************************************
 571 %*                                                                      *
 572 \subsection{Kinds and free variables}
 573 %*                                                                      *
 574 %************************************************************************
 575
 576 ---------------------------------------------------------------------
 577                 Finding the kind of a type
 578                 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 579 \begin{code}
 580 typeKind :: Type -> Kind
 581
 582 typeKind (TyVarTy tyvar)        = tyVarKind tyvar
 583 typeKind (TyConApp tycon tys)   = foldr (\_ k -> kindFunResult k) (tyConKind tycon) tys
 584 typeKind (NewTcApp tycon tys)   = foldr (\_ k -> kindFunResult k) (tyConKind tycon) tys
 585 typeKind (NoteTy _ ty)          = typeKind ty
 586 typeKind (PredTy _)             = liftedTypeKind -- Predicates are always
 587                                                  -- represented by lifted types
 588 typeKind (AppTy fun arg)        = kindFunResult (typeKind fun)
 589 typeKind (FunTy arg res)        = liftedTypeKind
 590 typeKind (ForAllTy tv ty)       = typeKind ty
 591 \end{code}
 592
 593
 594 ---------------------------------------------------------------------
 595                 Free variables of a type
 596                 ~~~~~~~~~~~~~~~~~~~~~~~~
 597 \begin{code}
 598 tyVarsOfType :: Type -> TyVarSet
 599 tyVarsOfType (TyVarTy tv)               = unitVarSet tv
 600 tyVarsOfType (TyConApp tycon tys)       = tyVarsOfTypes tys
 601 tyVarsOfType (NewTcApp tycon tys)       = tyVarsOfTypes tys
 602 tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
 603 tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty2      -- See note [Syn] below
 604 tyVarsOfType (PredTy sty)               = tyVarsOfPred sty
 605 tyVarsOfType (FunTy arg res)            = tyVarsOfType arg `unionVarSet` tyVarsOfType res
 606 tyVarsOfType (AppTy fun arg)            = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
 607 tyVarsOfType (ForAllTy tyvar ty)        = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
 608
 609 --                      Note [Syn]
 610 -- Consider
 611 --      type T a = Int
 612 -- What are the free tyvars of (T x)?  Empty, of course!
 613 -- Here's the example that Ralf Laemmel showed me:
 614 --      foo :: (forall a. C u a -> C u a) -> u
 615 --      mappend :: Monoid u => u -> u -> u
 616 --
 617 --      bar :: Monoid u => u
 618 --      bar = foo (\t -> t `mappend` t)
 619 -- We have to generalise at the arg to f, and we don't
 620 -- want to capture the constraint (Monad (C u a)) because
 621 -- it appears to mention a.  Pretty silly, but it was useful to him.
 622
 623
 624 tyVarsOfTypes :: [Type] -> TyVarSet
 625 tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
 626
 627 tyVarsOfPred :: PredType -> TyVarSet
 628 tyVarsOfPred (IParam _ ty)  = tyVarsOfType ty
 629 tyVarsOfPred (ClassP _ tys) = tyVarsOfTypes tys
 630
 631 tyVarsOfTheta :: ThetaType -> TyVarSet
 632 tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet
 633
 634 -- Add a Note with the free tyvars to the top of the type
 635 addFreeTyVars :: Type -> Type
 636 addFreeTyVars ty@(NoteTy (FTVNote _) _)      = ty
 637 addFreeTyVars ty                             = NoteTy (FTVNote (tyVarsOfType ty)) ty
 638 \end{code}
 639
 640 %************************************************************************
 641 %*                                                                      *
 642 \subsection{TidyType}
 643 %*                                                                      *
 644 %************************************************************************
 645
 646 tidyTy tidies up a type for printing in an error message, or in
 647 an interface file.
 648
 649 It doesn't change the uniques at all, just the print names.
 650
 651 \begin{code}
 652 tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
 653 tidyTyVarBndr (tidy_env, subst) tyvar
 654   = case tidyOccName tidy_env (getOccName name) of
 655       (tidy', occ') ->  ((tidy', subst'), tyvar')
 656                     where
 657                         subst' = extendVarEnv subst tyvar tyvar'
 658                         tyvar' = setTyVarName tyvar name'
 659                         name'  = mkInternalName (getUnique name) occ' noSrcLoc
 660                                 -- Note: make a *user* tyvar, so it printes nicely
 661                                 -- Could extract src loc, but no need.
 662   where
 663     name = tyVarName tyvar
 664
 665 tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv
 666 -- Add the free tyvars to the env in tidy form,
 667 -- so that we can tidy the type they are free in
 668 tidyFreeTyVars env tyvars = fst (tidyOpenTyVars env (varSetElems tyvars))
 669
 670 tidyOpenTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
 671 tidyOpenTyVars env tyvars = mapAccumL tidyOpenTyVar env tyvars
 672
 673 tidyOpenTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
 674 -- Treat a new tyvar as a binder, and give it a fresh tidy name
 675 tidyOpenTyVar env@(tidy_env, subst) tyvar
 676   = case lookupVarEnv subst tyvar of
 677         Just tyvar' -> (env, tyvar')            -- Already substituted
 678         Nothing     -> tidyTyVarBndr env tyvar  -- Treat it as a binder
 679
 680 tidyType :: TidyEnv -> Type -> Type
 681 tidyType env@(tidy_env, subst) ty
 682   = go ty
 683   where
 684     go (TyVarTy tv)         = case lookupVarEnv subst tv of
 685                                 Nothing  -> TyVarTy tv
 686                                 Just tv' -> TyVarTy tv'
 687     go (TyConApp tycon tys) = let args = map go tys
 688                               in args `seqList` TyConApp tycon args
 689     go (NewTcApp tycon tys) = let args = map go tys
 690                               in args `seqList` NewTcApp tycon args
 691     go (NoteTy note ty)     = (NoteTy $! (go_note note)) $! (go ty)
 692     go (PredTy sty)         = PredTy (tidyPred env sty)
 693     go (AppTy fun arg)      = (AppTy $! (go fun)) $! (go arg)
 694     go (FunTy fun arg)      = (FunTy $! (go fun)) $! (go arg)
 695     go (ForAllTy tv ty)     = ForAllTy tvp $! (tidyType envp ty)
 696                               where
 697                                 (envp, tvp) = tidyTyVarBndr env tv
 698
 699     go_note (SynNote ty)        = SynNote $! (go ty)
 700     go_note note@(FTVNote ftvs) = note  -- No need to tidy the free tyvars
 701
 702 tidyTypes env tys = map (tidyType env) tys
 703
 704 tidyPred :: TidyEnv -> PredType -> PredType
 705 tidyPred env (IParam n ty)     = IParam n (tidyType env ty)
 706 tidyPred env (ClassP clas tys) = ClassP clas (tidyTypes env tys)
 707 \end{code}
 708
 709
 710 @tidyOpenType@ grabs the free type variables, tidies them
 711 and then uses @tidyType@ to work over the type itself
 712
 713 \begin{code}
 714 tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
 715 tidyOpenType env ty
 716   = (env', tidyType env' ty)
 717   where
 718     env' = tidyFreeTyVars env (tyVarsOfType ty)
 719
 720 tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
 721 tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
 722
 723 tidyTopType :: Type -> Type
 724 tidyTopType ty = tidyType emptyTidyEnv ty
 725 \end{code}
 726
 727
 728
 729 %************************************************************************
 730 %*                                                                      *
 731 \subsection{Liftedness}
 732 %*                                                                      *
 733 %************************************************************************
 734
 735 \begin{code}
 736 isUnLiftedType :: Type -> Bool
 737         -- isUnLiftedType returns True for forall'd unlifted types:
 738         --      x :: forall a. Int#
 739         -- I found bindings like these were getting floated to the top level.
 740         -- They are pretty bogus types, mind you.  It would be better never to
 741         -- construct them
 742
 743 isUnLiftedType (ForAllTy tv ty)  = isUnLiftedType ty
 744 isUnLiftedType (NoteTy _ ty)     = isUnLiftedType ty
 745 isUnLiftedType (TyConApp tc _)   = isUnLiftedTyCon tc
 746 isUnLiftedType (PredTy _)        = False                -- All source types are lifted
 747 isUnLiftedType (NewTcApp tc tys) = isUnLiftedType (newTypeRep tc tys)
 748 isUnLiftedType other             = False
 749
 750 isUnboxedTupleType :: Type -> Bool
 751 isUnboxedTupleType ty = case splitTyConApp_maybe ty of
 752                            Just (tc, ty_args) -> isUnboxedTupleTyCon tc
 753                            other              -> False
 754
 755 -- Should only be applied to *types*; hence the assert
 756 isAlgType :: Type -> Bool
 757 isAlgType ty = case splitTyConApp_maybe ty of
 758                         Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
 759                                               isAlgTyCon tc
 760                         other              -> False
 761 \end{code}
 762
 763 @isStrictType@ computes whether an argument (or let RHS) should
 764 be computed strictly or lazily, based only on its type.
 765 Works just like isUnLiftedType, except that it has a special case
 766 for dictionaries.  Since it takes account of ClassP, you might think
 767 this function should be in TcType, but isStrictType is used by DataCon,
 768 which is below TcType in the hierarchy, so it's convenient to put it here.
 769
 770 \begin{code}
 771 isStrictType (ForAllTy tv ty)  = isStrictType ty
 772 isStrictType (NoteTy _ ty)     = isStrictType ty
 773 isStrictType (TyConApp tc _)   = isUnLiftedTyCon tc
 774 isStrictType (NewTcApp tc tys) = isStrictType (newTypeRep tc tys)
 775 isStrictType (PredTy pred)     = isStrictPred pred
 776 isStrictType other             = False
 777
 778 isStrictPred (ClassP clas _) = opt_DictsStrict && not (isNewTyCon (classTyCon clas))
 779 isStrictPred other           = False
 780         -- We may be strict in dictionary types, but only if it
 781         -- has more than one component.
 782         -- [Being strict in a single-component dictionary risks
 783         --  poking the dictionary component, which is wrong.]
 784 \end{code}
 785
 786 \begin{code}
 787 isPrimitiveType :: Type -> Bool
 788 -- Returns types that are opaque to Haskell.
 789 -- Most of these are unlifted, but now that we interact with .NET, we
 790 -- may have primtive (foreign-imported) types that are lifted
 791 isPrimitiveType ty = case splitTyConApp_maybe ty of
 792                         Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
 793                                               isPrimTyCon tc
 794                         other              -> False
 795 \end{code}
 796
 797
 798 %************************************************************************
 799 %*                                                                      *
 800 \subsection{Sequencing on types
 801 %*                                                                      *
 802 %************************************************************************
 803
 804 \begin{code}
 805 seqType :: Type -> ()
 806 seqType (TyVarTy tv)      = tv `seq` ()
 807 seqType (AppTy t1 t2)     = seqType t1 `seq` seqType t2
 808 seqType (FunTy t1 t2)     = seqType t1 `seq` seqType t2
 809 seqType (NoteTy note t2)  = seqNote note `seq` seqType t2
 810 seqType (PredTy p)        = seqPred p
 811 seqType (TyConApp tc tys) = tc `seq` seqTypes tys
 812 seqType (NewTcApp tc tys) = tc `seq` seqTypes tys
 813 seqType (ForAllTy tv ty)  = tv `seq` seqType ty
 814
 815 seqTypes :: [Type] -> ()
 816 seqTypes []       = ()
 817 seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
 818
 819 seqNote :: TyNote -> ()
 820 seqNote (SynNote ty)  = seqType ty
 821 seqNote (FTVNote set) = sizeUniqSet set `seq` ()
 822
 823 seqPred :: PredType -> ()
 824 seqPred (ClassP c tys) = c  `seq` seqTypes tys
 825 seqPred (IParam n ty)  = n  `seq` seqType ty
 826 \end{code}
 827
 828
 829 %************************************************************************
 830 %*                                                                      *
 831 \subsection{Equality on types}
 832 %*                                                                      *
 833 %************************************************************************
 834
 835 Comparison; don't use instances so that we know where it happens.
 836 Look through newtypes but not usage types.
 837
 838 Note that eqType can respond 'False' for partial applications of newtypes.
 839 Consider
 840         newtype Parser m a = MkParser (Foogle m a)
 841
 842 Does
 843         Monad (Parser m) `eqType` Monad (Foogle m)
 844
 845 Well, yes, but eqType won't see that they are the same.
 846 I don't think this is harmful, but it's soemthing to watch out for.
 847
 848 \begin{code}
 849 eqType t1 t2 = eq_ty emptyVarEnv t1 t2
 850
 851 -- Look through Notes
 852 eq_ty env (NoteTy _ t1)       t2                  = eq_ty env t1 t2
 853 eq_ty env t1                  (NoteTy _ t2)       = eq_ty env t1 t2
 854
 855 -- Look through PredTy and NewTcApp.  This is where the looping danger comes from.
 856 -- We don't bother to check for the PredType/PredType case, no good reason
 857 -- Hmm: maybe there is a good reason: see the notes below about newtypes
 858 eq_ty env (PredTy sty1)     t2            = eq_ty env (predTypeRep sty1) t2
 859 eq_ty env t1                (PredTy sty2) = eq_ty env t1 (predTypeRep sty2)
 860
 861 -- NB: we *cannot* short-cut the newtype comparison thus:
 862 -- eq_ty env (NewTcApp tc1 tys1) (NewTcApp tc2 tys2)
 863 --      | (tc1 == tc2) = (eq_tys env tys1 tys2)
 864 --
 865 -- Consider:
 866 --      newtype T a = MkT [a]
 867 --      newtype Foo m = MkFoo (forall a. m a -> Int)
 868 --      w1 :: Foo []
 869 --      w1 = ...
 870 --
 871 --      w2 :: Foo T
 872 --      w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x)
 873 --
 874 -- We end up with w2 = w1; so we need that Foo T = Foo []
 875 -- but we can only expand saturated newtypes, so just comparing
 876 -- T with [] won't do.
 877
 878 eq_ty env (NewTcApp tc1 tys1) t2                  = eq_ty env (newTypeRep tc1 tys1) t2
 879 eq_ty env t1                  (NewTcApp tc2 tys2) = eq_ty env t1 (newTypeRep tc2 tys2)
 880
 881 -- The rest is plain sailing
 882 eq_ty env (TyVarTy tv1)       (TyVarTy tv2)       = case lookupVarEnv env tv1 of
 883                                                           Just tv1a -> tv1a == tv2
 884                                                           Nothing   -> tv1  == tv2
 885 eq_ty env (ForAllTy tv1 t1)   (ForAllTy tv2 t2)
 886         | tv1 == tv2                              = eq_ty (delVarEnv env tv1)        t1 t2
 887         | otherwise                               = eq_ty (extendVarEnv env tv1 tv2) t1 t2
 888 eq_ty env (AppTy s1 t1)       (AppTy s2 t2)       = (eq_ty env s1 s2) && (eq_ty env t1 t2)
 889 eq_ty env (FunTy s1 t1)       (FunTy s2 t2)       = (eq_ty env s1 s2) && (eq_ty env t1 t2)
 890 eq_ty env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 == tc2) && (eq_tys env tys1 tys2)
 891 eq_ty env t1                   t2                 = False
 892
 893 eq_tys env []        []        = True
 894 eq_tys env (t1:tys1) (t2:tys2) = (eq_ty env t1 t2) && (eq_tys env tys1 tys2)
 895 eq_tys env tys1      tys2      = False
 896 \end{code}
 897