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