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