Type.lhs 54.1 KB
Newer Older
1
%
2
% (c) The University of Glasgow 2006
3 4 5
% (c) The GRASP/AQUA Project, Glasgow University, 1998
%

6
Type - public interface
7

8
\begin{code}
9
{-# OPTIONS -w #-}
10 11 12
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
13
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
14 15
-- for details

16
module Type (
17
        -- re-exports from TypeRep
18
	TyThing(..), Type, PredType(..), ThetaType, 
19
	funTyCon,
20

21 22
	-- Kinds
        Kind, SimpleKind, KindVar,
23
        kindFunResult, splitKindFunTys, splitKindFunTysN,
24 25 26 27 28 29 30 31 32 33 34

        liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
        argTypeKindTyCon, ubxTupleKindTyCon,

        liftedTypeKind, unliftedTypeKind, openTypeKind,
        argTypeKind, ubxTupleKind,

        tySuperKind, coSuperKind, 

        isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
        isUbxTupleKind, isArgTypeKind, isKind, isTySuperKind, 
35
        isCoSuperKind, isSuperKind, isCoercionKind, isEqPred,
36 37 38 39
	mkArrowKind, mkArrowKinds,

        isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind, eqKind,
        isSubKindCon,
40

41 42
	-- Re-exports from TyCon
	PrimRep(..),
43

44 45
	mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy,

46 47
	mkAppTy, mkAppTys, splitAppTy, splitAppTys, 
	splitAppTy_maybe, repSplitAppTy_maybe,
48

49 50
	mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, 
	splitFunTys, splitFunTysN,
51
	funResultTy, funArgTy, zipFunTys, isFunTy,
52

53
	mkTyConApp, mkTyConTy, 
54
	tyConAppTyCon, tyConAppArgs, 
55 56
	splitTyConApp_maybe, splitTyConApp, 
        splitNewTyConApp_maybe, splitNewTyConApp,
57

58
	repType, typePrimRep, coreView, tcView, kindView, rttiView,
59

60
	mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, 
61
	applyTy, applyTys, isForAllTy, dropForAlls,
62

63
	-- Source types
64
	predTypeRep, mkPredTy, mkPredTys, pprSourceTyCon, mkFamilyTyConApp,
65

66
	-- Newtypes
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
67
	newTyConInstRhs,
68

69
	-- Lifting and boxity
70 71
	isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType,
	isPrimitiveType, isStrictType, isStrictPred, 
72

73
	-- Free variables
74
	tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
75
	typeKind, addFreeTyVars,
76

77 78 79
        -- Type families
        tyFamInsts,

80
	-- Tidying up for printing
81 82 83 84 85
	tidyType,      tidyTypes,
	tidyOpenType,  tidyOpenTypes,
	tidyTyVarBndr, tidyFreeTyVars,
	tidyOpenTyVar, tidyOpenTyVars,
	tidyTopType,   tidyPred,
86
	tidyKind,
87

88
	-- Comparison
89
	coreEqType, tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, 
90
	tcEqPred, tcCmpPred, tcEqTypeX, tcPartOfType, tcPartOfPred,
91

92
	-- Seq
93
	seqType, seqTypes,
94

95
	-- Type substitutions
96 97
	TvSubstEnv, emptyTvSubstEnv,	-- Representation widely visible
	TvSubst(..), emptyTvSubst,	-- Representation visible to a few friends
98
	mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst,
99
	getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
100
 	extendTvSubst, extendTvSubstList, isInScope, composeTvSubst, zipTyEnv,
101
        isEmptyTvSubst,
102 103

	-- Performing substitution on types
104
	substTy, substTys, substTyWith, substTheta, 
105
	substPred, substTyVar, substTyVars, substTyVarBndr, deShadowTy, lookupTyVar,
106

107
	-- Pretty-printing
108
	pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll,
109
	pprPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind
110
    ) where
111

112 113
#include "HsVersions.h"

114 115 116 117 118
-- We import the representation and primitive functions from TypeRep.
-- Many things are reexported, but not the representation!

import TypeRep

119
-- friends:
120
import Var
121 122 123
import VarEnv
import VarSet

124 125 126 127
import Name
import Class
import PrelNames
import TyCon
128

129
-- others
130 131
import StaticFlags
import Util
132
import Outputable
133
import UniqSet
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
134

135
import Data.List
136
import Data.Maybe	( isJust )
137 138
\end{code}

139

140 141 142 143 144 145 146 147 148 149 150
%************************************************************************
%*									*
		Type representation
%*									*
%************************************************************************

In Core, we "look through" non-recursive newtypes and PredTypes.

\begin{code}
{-# INLINE coreView #-}
coreView :: Type -> Maybe Type
151
-- Strips off the *top layer only* of a type to give 
152 153 154
-- its underlying representation type. 
-- Returns Nothing if there is nothing to look through.
--
155
-- In the case of newtypes, it returns
156 157 158 159 160 161 162 163 164 165 166 167
--	*either* a vanilla TyConApp (recursive newtype, or non-saturated)
--	*or*     the newtype representation (otherwise), meaning the
--			type written in the RHS of the newtype decl,
--			which may itself be a newtype
--
-- Example: newtype R = MkR S
--	    newtype S = MkS T
--	    newtype T = MkT (T -> T)
--   expandNewTcApp on R gives Just S
--	            on S gives Just T
--		    on T gives Nothing	 (no expansion)

168 169 170
-- By being non-recursive and inlined, this case analysis gets efficiently
-- joined onto the case analysis that the caller is already doing
coreView (NoteTy _ ty) 	   = Just ty
171 172 173
coreView (PredTy p)
  | isEqPred p             = Nothing
  | otherwise    	   = Just (predTypeRep p)
174 175 176 177 178 179 180
coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc tys 
			   = Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys')
				-- Its important to use mkAppTys, rather than (foldl AppTy),
				-- because the function part might well return a 
				-- partially-applied type constructor; indeed, usually will!
coreView ty		   = Nothing

181 182


183 184 185 186 187 188 189 190
-----------------------------------------------
{-# INLINE tcView #-}
tcView :: Type -> Maybe Type
-- Same, but for the type checker, which just looks through synonyms
tcView (NoteTy _ ty) 	 = Just ty
tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys 
			 = Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys')
tcView ty		 = Nothing
191

192 193 194 195 196 197 198 199 200 201 202 203
-----------------------------------------------
rttiView :: Type -> Type
-- Same, but for the RTTI system, which cannot deal with predicates nor polymorphism
rttiView (ForAllTy _ ty) = rttiView ty
rttiView (NoteTy   _ ty) = rttiView ty
rttiView (FunTy PredTy{} ty) = rttiView ty
rttiView (FunTy NoteTy{} ty) = rttiView ty
rttiView ty@TyConApp{} | Just ty' <- coreView ty 
                           = rttiView ty'
rttiView (TyConApp tc tys) = mkTyConApp tc (map rttiView tys)
rttiView ty = ty

204 205 206 207 208 209 210
-----------------------------------------------
{-# INLINE kindView #-}
kindView :: Kind -> Maybe Kind
-- C.f. coreView, tcView
-- For the moment, we don't even handle synonyms in kinds
kindView (NoteTy _ k) = Just k
kindView other	      = Nothing
211 212 213
\end{code}


214 215 216 217 218
%************************************************************************
%*									*
\subsection{Constructor-specific functions}
%*									*
%************************************************************************
sof's avatar
sof committed
219 220


221 222 223
---------------------------------------------------------------------
				TyVarTy
				~~~~~~~
224
\begin{code}
225
mkTyVarTy  :: TyVar   -> Type
226
mkTyVarTy  = TyVarTy
227

228
mkTyVarTys :: [TyVar] -> [Type]
229
mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
230

231
getTyVar :: String -> Type -> TyVar
232 233 234
getTyVar msg ty = case getTyVar_maybe ty of
		    Just tv -> tv
		    Nothing -> panic ("getTyVar: " ++ msg)
235

236
isTyVarTy :: Type -> Bool
237 238 239
isTyVarTy ty = isJust (getTyVar_maybe ty)

getTyVar_maybe :: Type -> Maybe TyVar
240 241 242
getTyVar_maybe ty | Just ty' <- coreView ty = getTyVar_maybe ty'
getTyVar_maybe (TyVarTy tv) 	 	    = Just tv  
getTyVar_maybe other	         	    = Nothing
243

244 245 246
\end{code}


247 248 249 250 251 252
---------------------------------------------------------------------
				AppTy
				~~~~~
We need to be pretty careful with AppTy to make sure we obey the 
invariant that a TyConApp is always visibly so.  mkAppTy maintains the
invariant: use it.
253

254
\begin{code}
255
mkAppTy orig_ty1 orig_ty2
256
  = mk_app orig_ty1
257
  where
258
    mk_app (NoteTy _ ty1)    = mk_app ty1
259
    mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
260
    mk_app ty1		     = AppTy orig_ty1 orig_ty2
261
	-- Note that the TyConApp could be an 
262 263 264 265 266 267 268
	-- under-saturated type synonym.  GHC allows that; e.g.
	--	type Foo k = k a -> k a
	--	type Id x = x
	--	foo :: Foo Id -> Foo Id
	--
	-- Here Id is partially applied in the type sig for Foo,
	-- but once the type synonyms are expanded all is well
269

270
mkAppTys :: Type -> [Type] -> Type
271 272
mkAppTys orig_ty1 []	    = orig_ty1
	-- This check for an empty list of type arguments
273
	-- avoids the needless loss of a type synonym constructor.
274 275 276
	-- For example: mkAppTys Rational []
	--   returns to (Ratio Integer), which has needlessly lost
	--   the Rational part.
277
mkAppTys orig_ty1 orig_tys2
278
  = mk_app orig_ty1
279
  where
280
    mk_app (NoteTy _ ty1)    = mk_app ty1
281 282
    mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
				-- mkTyConApp: see notes with mkAppTy
283
    mk_app ty1		     = foldl AppTy orig_ty1 orig_tys2
284

285
-------------
286
splitAppTy_maybe :: Type -> Maybe (Type, Type)
287 288 289
splitAppTy_maybe ty | Just ty' <- coreView ty
		    = splitAppTy_maybe ty'
splitAppTy_maybe ty = repSplitAppTy_maybe ty
290

291 292 293 294 295
-------------
repSplitAppTy_maybe :: Type -> Maybe (Type,Type)
-- Does the AppTy split, but assumes that any view stuff is already done
repSplitAppTy_maybe (FunTy ty1 ty2)   = Just (TyConApp funTyCon [ty1], ty2)
repSplitAppTy_maybe (AppTy ty1 ty2)   = Just (ty1, ty2)
296 297 298 299 300 301
repSplitAppTy_maybe (TyConApp tc tys) 
  | not (isOpenSynTyCon tc) || length tys > tyConArity tc 
  = case snocView tys of       -- never create unsaturated type family apps
      Just (tys', ty') -> Just (TyConApp tc tys', ty')
      Nothing	       -> Nothing
repSplitAppTy_maybe _other = Nothing
302
-------------
303
splitAppTy :: Type -> (Type, Type)
304 305 306
splitAppTy ty = case splitAppTy_maybe ty of
			Just pr -> pr
			Nothing -> panic "splitAppTy"
307

308
-------------
309
splitAppTys :: Type -> (Type, [Type])
310
splitAppTys ty = split ty ty []
311
  where
312
    split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args
313
    split orig_ty (AppTy ty arg)        args = split ty ty (arg:args)
314 315 316 317 318 319 320
    split orig_ty (TyConApp tc tc_args) args 
      = let -- keep type families saturated
            n | isOpenSynTyCon tc = tyConArity tc
              | otherwise         = 0
            (tc_args1, tc_args2)  = splitAt n tc_args
        in
        (TyConApp tc tc_args1, tc_args2 ++ args)
321
    split orig_ty (FunTy ty1 ty2)       args = ASSERT( null args )
322
					       (TyConApp funTyCon [], [ty1,ty2])
323
    split orig_ty ty		        args = (orig_ty, args)
324

325 326
\end{code}

327 328 329 330 331

---------------------------------------------------------------------
				FunTy
				~~~~~

332
\begin{code}
333
mkFunTy :: Type -> Type -> Type
334
mkFunTy (PredTy (EqPred ty1 ty2)) res = mkForAllTy (mkWildCoVar (PredTy (EqPred ty1 ty2))) res
335
mkFunTy arg res = FunTy arg res
336

337
mkFunTys :: [Type] -> Type -> Type
338
mkFunTys tys ty = foldr mkFunTy ty tys
339

340 341 342
isFunTy :: Type -> Bool 
isFunTy ty = isJust (splitFunTy_maybe ty)

343
splitFunTy :: Type -> (Type, Type)
344
splitFunTy ty | Just ty' <- coreView ty = splitFunTy ty'
345
splitFunTy (FunTy arg res)   = (arg, res)
346
splitFunTy other	     = pprPanic "splitFunTy" (ppr other)
347

348
splitFunTy_maybe :: Type -> Maybe (Type, Type)
349
splitFunTy_maybe ty | Just ty' <- coreView ty = splitFunTy_maybe ty'
350 351
splitFunTy_maybe (FunTy arg res)   = Just (arg, res)
splitFunTy_maybe other	           = Nothing
352

353
splitFunTys :: Type -> ([Type], Type)
354
splitFunTys ty = split [] ty ty
355
  where
356
    split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty'
357 358
    split args orig_ty (FunTy arg res) 	 = split (arg:args) res res
    split args orig_ty ty                = (reverse args, orig_ty)
359

360 361 362 363 364 365 366
splitFunTysN :: Int -> Type -> ([Type], Type)
-- Split off exactly n arg tys
splitFunTysN 0 ty = ([], ty)
splitFunTysN n ty = case splitFunTy ty of { (arg, res) ->
		    case splitFunTysN (n-1) res of { (args, res) ->
		    (arg:args, res) }}

367 368 369
zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type)
zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
  where
370
    split acc []     nty ty  	           = (reverse acc, nty)
371 372
    split acc xs     nty ty 
	  | Just ty' <- coreView ty 	   = split acc xs nty ty'
373
    split acc (x:xs) nty (FunTy arg res)   = split ((x,arg):acc) xs res res
374
    split acc (x:xs) nty ty                = pprPanic "zipFunTys" (ppr orig_xs <+> ppr orig_ty)
375 376
    
funResultTy :: Type -> Type
377
funResultTy ty | Just ty' <- coreView ty = funResultTy ty'
378
funResultTy (FunTy arg res)   = res
379
funResultTy ty		      = pprPanic "funResultTy" (ppr ty)
380 381

funArgTy :: Type -> Type
382
funArgTy ty | Just ty' <- coreView ty = funArgTy ty'
383
funArgTy (FunTy arg res)   = arg
384
funArgTy ty		   = pprPanic "funArgTy" (ppr ty)
385 386 387
\end{code}


388 389 390
---------------------------------------------------------------------
				TyConApp
				~~~~~~~~
391
@mkTyConApp@ is a key function, because it builds a TyConApp, FunTy or PredTy,
392
as apppropriate.
393

394
\begin{code}
395
mkTyConApp :: TyCon -> [Type] -> Type
396
mkTyConApp tycon tys
397
  | isFunTyCon tycon, [ty1,ty2] <- tys
398
  = FunTy ty1 ty2
399

400
  | otherwise
401
  = TyConApp tycon tys
402

403
mkTyConTy :: TyCon -> Type
404
mkTyConTy tycon = mkTyConApp tycon []
405 406 407 408 409

-- splitTyConApp "looks through" synonyms, because they don't
-- mean a distinct type, but all other type-constructor applications
-- including functions are returned as Just ..

410
tyConAppTyCon :: Type -> TyCon
411
tyConAppTyCon ty = fst (splitTyConApp ty)
412 413

tyConAppArgs :: Type -> [Type]
414
tyConAppArgs ty = snd (splitTyConApp ty)
415 416 417 418

splitTyConApp :: Type -> (TyCon, [Type])
splitTyConApp ty = case splitTyConApp_maybe ty of
			Just stuff -> stuff
419
			Nothing	   -> pprPanic "splitTyConApp" (ppr ty)
420

421
splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
422
splitTyConApp_maybe ty | Just ty' <- coreView ty = splitTyConApp_maybe ty'
423
splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
424
splitTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [arg,res])
425
splitTyConApp_maybe other	      = Nothing
426 427 428 429 430 431 432 433 434 435 436 437 438 439

-- Sometimes we do NOT want to look throught a newtype.  When case matching
-- on a newtype we want a convenient way to access the arguments of a newty
-- constructor so as to properly form a coercion.
splitNewTyConApp :: Type -> (TyCon, [Type])
splitNewTyConApp ty = case splitNewTyConApp_maybe ty of
			Just stuff -> stuff
			Nothing	   -> pprPanic "splitNewTyConApp" (ppr ty)
splitNewTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
splitNewTyConApp_maybe ty | Just ty' <- tcView ty = splitNewTyConApp_maybe ty'
splitNewTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
splitNewTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [arg,res])
splitNewTyConApp_maybe other	      = Nothing

440
newTyConInstRhs :: TyCon -> [Type] -> Type
441 442 443 444 445 446 447 448
-- Unwrap one 'layer' of newtype
-- Use the eta'd version if possible
newTyConInstRhs tycon tys 
    = ASSERT2( equalLength tvs tys1, ppr tycon $$ ppr tys $$ ppr tvs )
      mkAppTys (substTyWith tvs tys1 ty) tys2
  where
    (tvs, ty)    = newTyConEtadRhs tycon
    (tys1, tys2) = splitAtList tvs tys
sof's avatar
sof committed
449
\end{code}
450

451

452 453 454 455 456 457 458 459
---------------------------------------------------------------------
				SynTy
				~~~~~

Notes on type synonyms
~~~~~~~~~~~~~~~~~~~~~~
The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
to return type synonyms whereever possible. Thus
460

461 462 463 464 465 466 467 468
	type Foo a = a -> a

we want 
	splitFunTys (a -> Foo a) = ([a], Foo a)
not			           ([a], a -> a)

The reason is that we then get better (shorter) type signatures in 
interfaces.  Notably this plays a role in tcTySigs in TcBinds.lhs.
469 470


471 472
		Representation types
		~~~~~~~~~~~~~~~~~~~~
473 474
repType looks through 
	(a) for-alls, and
475 476 477
	(b) synonyms
	(c) predicates
	(d) usage annotations
478
	(e) all newtypes, including recursive ones, but not newtype families
479
It's useful in the back end.
480 481 482

\begin{code}
repType :: Type -> Type
483
-- Only applied to types of kind *; hence tycons are saturated
484
repType ty | Just ty' <- coreView ty = repType ty'
485 486
repType (ForAllTy _ ty)  = repType ty
repType (TyConApp tc tys)
487 488 489 490 491 492 493 494 495
  | isNewTyCon tc
  , (tvs, rep_ty) <- newTyConRep tc
  = -- Recursive newtypes are opaque to coreView
    -- but we must expand them here.  Sure to
    -- be saturated because repType is only applied
    -- to types of kind *
    ASSERT( tys `lengthIs` tyConArity tc )
    repType (substTyWith tvs tys rep_ty)

496 497
repType ty = ty

498 499
-- ToDo: this could be moved to the code generator, using splitTyConApp instead
-- of inspecting the type directly.
500 501 502 503
typePrimRep :: Type -> PrimRep
typePrimRep ty = case repType ty of
		   TyConApp tc _ -> tyConPrimRep tc
		   FunTy _ _	 -> PtrRep
504
		   AppTy _ _	 -> PtrRep	-- See note below
505
		   TyVarTy _	 -> PtrRep
506
		   other	 -> pprPanic "typePrimRep" (ppr ty)
507 508 509 510 511
	-- Types of the form 'f a' must be of kind *, not *#, so
	-- we are guaranteed that they are represented by pointers.
	-- The reason is that f must have kind *->*, not *->*#, because
	-- (we claim) there is no way to constrain f's kind any other
	-- way.
512 513 514
\end{code}


515 516 517
---------------------------------------------------------------------
				ForAllTy
				~~~~~~~~
518 519

\begin{code}
520
mkForAllTy :: TyVar -> Type -> Type
521 522
mkForAllTy tyvar ty
  = mkForAllTys [tyvar] ty
523

524
mkForAllTys :: [TyVar] -> Type -> Type
525
mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
526 527 528 529 530

isForAllTy :: Type -> Bool
isForAllTy (NoteTy _ ty)  = isForAllTy ty
isForAllTy (ForAllTy _ _) = True
isForAllTy other_ty	  = False
531

532
splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
533
splitForAllTy_maybe ty = splitFAT_m ty
534
  where
535 536 537
    splitFAT_m ty | Just ty' <- coreView ty = splitFAT_m ty'
    splitFAT_m (ForAllTy tyvar ty)	    = Just(tyvar, ty)
    splitFAT_m _			    = Nothing
sof's avatar
sof committed
538

539
splitForAllTys :: Type -> ([TyVar], Type)
540
splitForAllTys ty = split ty ty []
541
   where
542
     split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs
543 544
     split orig_ty (ForAllTy tv ty)  tvs = split ty ty (tv:tvs)
     split orig_ty t		     tvs = (reverse tvs, orig_ty)
545 546 547

dropForAlls :: Type -> Type
dropForAlls ty = snd (splitForAllTys ty)
548 549
\end{code}

550
-- (mkPiType now in CoreUtils)
551

552 553 554 555 556 557 558
applyTy, applyTys
~~~~~~~~~~~~~~~~~
Instantiate a for-all type with one or more type arguments.
Used when we have a polymorphic function applied to type args:
	f t1 t2
Then we use (applyTys type-of-f [t1,t2]) to compute the type of
the expression. 
559

560
\begin{code}
561
applyTy :: Type -> Type -> Type
562 563 564
applyTy ty arg | Just ty' <- coreView ty = applyTy ty' arg
applyTy (ForAllTy tv ty) arg = substTyWith [tv] [arg] ty
applyTy other		 arg = panic "applyTy"
565

566
applyTys :: Type -> [Type] -> Type
567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585
-- This function is interesting because 
--	a) the function may have more for-alls than there are args
--	b) less obviously, it may have fewer for-alls
-- For case (b) think of 
--	applyTys (forall a.a) [forall b.b, Int]
-- This really can happen, via dressing up polymorphic types with newtype
-- clothing.  Here's an example:
--	newtype R = R (forall a. a->a)
--	foo = case undefined :: R of
--		R f -> f ()

applyTys orig_fun_ty []      = orig_fun_ty
applyTys orig_fun_ty arg_tys 
  | n_tvs == n_args 	-- The vastly common case
  = substTyWith tvs arg_tys rho_ty
  | n_tvs > n_args 	-- Too many for-alls
  = substTyWith (take n_args tvs) arg_tys 
		(mkForAllTys (drop n_args tvs) rho_ty)
  | otherwise		-- Too many type args
586
  = ASSERT2( n_tvs > 0, ppr orig_fun_ty )	-- Zero case gives infnite loop!
587 588 589 590 591 592
    applyTys (substTyWith tvs (take n_tvs arg_tys) rho_ty)
	     (drop n_tvs arg_tys)
  where
    (tvs, rho_ty) = splitForAllTys orig_fun_ty 
    n_tvs = length tvs
    n_args = length arg_tys     
593
\end{code}
594

595

596 597
%************************************************************************
%*									*
598
\subsection{Source types}
599 600
%*									*
%************************************************************************
601

602 603
A "source type" is a type that is a separate type as far as the type checker is
concerned, but which has low-level representation as far as the back end is concerned.
604

605
Source types are always lifted.
606

607
The key function is predTypeRep which gives the representation of a source type:
608 609

\begin{code}
610
mkPredTy :: PredType -> Type
611
mkPredTy pred = PredTy pred
612 613

mkPredTys :: ThetaType -> [Type]
614 615 616 617 618
mkPredTys preds = map PredTy preds

predTypeRep :: PredType -> Type
-- Convert a PredType to its "representation type";
-- the post-type-checking type used by all the Core passes of GHC.
619
-- Unwraps only the outermost level; for example, the result might
620
-- be a newtype application
621 622
predTypeRep (IParam _ ty)     = ty
predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys
623
	-- Result might be a newtype application, but the consumer will
624
	-- look through that too if necessary
625
predTypeRep (EqPred ty1 ty2) = pprPanic "predTypeRep" (ppr (EqPred ty1 ty2))
626

627 628 629 630 631 632 633 634 635 636 637 638 639 640
mkFamilyTyConApp :: TyCon -> [Type] -> Type
-- Given a family instance TyCon and its arg types, return the
-- corresponding family type.  E.g.
--	data family T a
--	data instance T (Maybe b) = MkT b	-- Instance tycon :RTL
-- Then 
--	mkFamilyTyConApp :RTL Int  =  T (Maybe Int)
mkFamilyTyConApp tc tys
  | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc
  , let fam_subst = zipTopTvSubst (tyConTyVars tc) tys
  = mkTyConApp fam_tc (substTys fam_subst fam_tys)
  | otherwise
  = mkTyConApp tc tys

641
-- Pretty prints a tycon, using the family instance in case of a
642 643 644 645
-- representation tycon.  For example
--  	e.g.  data T [a] = ...
-- In that case we want to print `T [a]', where T is the family TyCon
pprSourceTyCon tycon 
646 647
  | Just (fam_tc, tys) <- tyConFamInst_maybe tycon
  = ppr $ fam_tc `TyConApp` tys	       -- can't be FunTyCon
648 649
  | otherwise
  = ppr tycon
650
\end{code}
651 652


653 654 655 656 657 658 659 660 661
%************************************************************************
%*									*
\subsection{Kinds and free variables}
%*									*
%************************************************************************

---------------------------------------------------------------------
		Finding the kind of a type
		~~~~~~~~~~~~~~~~~~~~~~~~~~
662
\begin{code}
663
typeKind :: Type -> Kind
664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687
typeKind (TyConApp tycon tys) = ASSERT( not (isCoercionTyCon tycon) )
				   -- We should be looking for the coercion kind,
				   -- not the type kind
				foldr (\_ k -> kindFunResult k) (tyConKind tycon) tys
typeKind (NoteTy _ ty)	      = typeKind ty
typeKind (PredTy pred)	      = predKind pred
typeKind (AppTy fun arg)      = kindFunResult (typeKind fun)
typeKind (ForAllTy tv ty)     = typeKind ty
typeKind (TyVarTy tyvar)      = tyVarKind tyvar
typeKind (FunTy arg res)
    -- Hack alert.  The kind of (Int -> Int#) is liftedTypeKind (*), 
    --              not unliftedTypKind (#)
    -- The only things that can be after a function arrow are
    --   (a) types (of kind openTypeKind or its sub-kinds)
    --   (b) kinds (of super-kind TY) (e.g. * -> (* -> *))
    | isTySuperKind k         = k
    | otherwise               = ASSERT( isSubOpenTypeKind k) liftedTypeKind 
    where
      k = typeKind res

predKind :: PredType -> Kind
predKind (EqPred {}) = coSuperKind	-- A coercion kind!
predKind (ClassP {}) = liftedTypeKind	-- Class and implicitPredicates are
predKind (IParam {}) = liftedTypeKind 	-- always represented by lifted types
688 689 690
\end{code}


691 692 693
---------------------------------------------------------------------
		Free variables of a type
		~~~~~~~~~~~~~~~~~~~~~~~~
694
\begin{code}
695
tyVarsOfType :: Type -> TyVarSet
696
-- NB: for type synonyms tyVarsOfType does *not* expand the synonym
697
tyVarsOfType (TyVarTy tv)		= unitVarSet tv
698
tyVarsOfType (TyConApp tycon tys)	= tyVarsOfTypes tys
699
tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
700
tyVarsOfType (PredTy sty)		= tyVarsOfPred sty
701 702
tyVarsOfType (FunTy arg res)		= tyVarsOfType arg `unionVarSet` tyVarsOfType res
tyVarsOfType (AppTy fun arg)		= tyVarsOfType fun `unionVarSet` tyVarsOfType arg
703
tyVarsOfType (ForAllTy tyvar ty)	= delVarSet (tyVarsOfType ty) tyvar
704

705
tyVarsOfTypes :: [Type] -> TyVarSet
706 707
tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys

708
tyVarsOfPred :: PredType -> TyVarSet
709 710 711
tyVarsOfPred (IParam _ ty)    = tyVarsOfType ty
tyVarsOfPred (ClassP _ tys)   = tyVarsOfTypes tys
tyVarsOfPred (EqPred ty1 ty2) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
712 713

tyVarsOfTheta :: ThetaType -> TyVarSet
714
tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet
715

716
-- Add a Note with the free tyvars to the top of the type
717
addFreeTyVars :: Type -> Type
718 719
addFreeTyVars ty@(NoteTy (FTVNote _) _)      = ty
addFreeTyVars ty			     = NoteTy (FTVNote (tyVarsOfType ty)) ty
720
\end{code}
721

722

723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744
%************************************************************************
%*									*
\subsection{Type families}
%*									*
%************************************************************************

Type family instances occuring in a type after expanding synonyms.

\begin{code}
tyFamInsts :: Type -> [(TyCon, [Type])]
tyFamInsts ty 
  | Just exp_ty <- tcView ty    = tyFamInsts exp_ty
tyFamInsts (TyVarTy _)          = []
tyFamInsts (TyConApp tc tys) 
  | isOpenSynTyCon tc           = [(tc, tys)]
  | otherwise                   = concat (map tyFamInsts tys)
tyFamInsts (FunTy ty1 ty2)      = tyFamInsts ty1 ++ tyFamInsts ty2
tyFamInsts (AppTy ty1 ty2)      = tyFamInsts ty1 ++ tyFamInsts ty2
tyFamInsts (ForAllTy _ ty)      = tyFamInsts ty
\end{code}


745 746 747 748 749
%************************************************************************
%*									*
\subsection{TidyType}
%*									*
%************************************************************************
750

751 752
tidyTy tidies up a type for printing in an error message, or in
an interface file.
753

754
It doesn't change the uniques at all, just the print names.
755 756

\begin{code}
757
tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
758
tidyTyVarBndr env@(tidy_env, subst) tyvar
759
  = case tidyOccName tidy_env (getOccName name) of
760 761 762 763 764 765 766 767 768
      (tidy', occ') -> ((tidy', subst'), tyvar'')
	where
	  subst' = extendVarEnv subst tyvar tyvar''
	  tyvar' = setTyVarName tyvar name'
	  name'  = tidyNameOcc name occ'
		-- Don't forget to tidy the kind for coercions!
	  tyvar'' | isCoVar tyvar = setTyVarKind tyvar' kind'
		  | otherwise	  = tyvar'
	  kind'  = tidyType env (tyVarKind tyvar)
769 770
  where
    name = tyVarName tyvar
771

772 773 774
tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv
-- Add the free tyvars to the env in tidy form,
-- so that we can tidy the type they are free in
775 776 777 778 779 780 781 782 783 784 785
tidyFreeTyVars env tyvars = fst (tidyOpenTyVars env (varSetElems tyvars))

tidyOpenTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
tidyOpenTyVars env tyvars = mapAccumL tidyOpenTyVar env tyvars

tidyOpenTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
-- Treat a new tyvar as a binder, and give it a fresh tidy name
tidyOpenTyVar env@(tidy_env, subst) tyvar
  = case lookupVarEnv subst tyvar of
	Just tyvar' -> (env, tyvar')		-- Already substituted
	Nothing	    -> tidyTyVarBndr env tyvar	-- Treat it as a binder
786

787 788 789
tidyType :: TidyEnv -> Type -> Type
tidyType env@(tidy_env, subst) ty
  = go ty
790
  where
791 792 793
    go (TyVarTy tv)	    = case lookupVarEnv subst tv of
				Nothing  -> TyVarTy tv
				Just tv' -> TyVarTy tv'
794 795
    go (TyConApp tycon tys) = let args = map go tys
			      in args `seqList` TyConApp tycon args
sof's avatar
sof committed
796
    go (NoteTy note ty)     = (NoteTy $! (go_note note)) $! (go ty)
797
    go (PredTy sty)	    = PredTy (tidyPred env sty)
sof's avatar
sof committed
798 799 800
    go (AppTy fun arg)	    = (AppTy $! (go fun)) $! (go arg)
    go (FunTy fun arg)	    = (FunTy $! (go fun)) $! (go arg)
    go (ForAllTy tv ty)	    = ForAllTy tvp $! (tidyType envp ty)
801
			      where
802
			        (envp, tvp) = tidyTyVarBndr env tv
803 804 805

    go_note note@(FTVNote ftvs) = note	-- No need to tidy the free tyvars

806
tidyTypes env tys = map (tidyType env) tys
807

808 809 810
tidyPred :: TidyEnv -> PredType -> PredType
tidyPred env (IParam n ty)     = IParam n (tidyType env ty)
tidyPred env (ClassP clas tys) = ClassP clas (tidyTypes env tys)
811
tidyPred env (EqPred ty1 ty2)  = EqPred (tidyType env ty1) (tidyType env ty2)
812 813 814
\end{code}


815
@tidyOpenType@ grabs the free type variables, tidies them
816 817 818 819 820 821 822
and then uses @tidyType@ to work over the type itself

\begin{code}
tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
tidyOpenType env ty
  = (env', tidyType env' ty)
  where
823
    env' = tidyFreeTyVars env (tyVarsOfType ty)
824 825 826 827 828 829

tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
tidyOpenTypes env tys = mapAccumL tidyOpenType env tys

tidyTopType :: Type -> Type
tidyTopType ty = tidyType emptyTidyEnv ty
830 831
\end{code}

832
\begin{code}
833

834
tidyKind :: TidyEnv -> Kind -> (TidyEnv, Kind)
835
tidyKind env k = tidyOpenType env k
836 837 838

\end{code}

839

840 841
%************************************************************************
%*									*
842
\subsection{Liftedness}
843 844 845
%*									*
%************************************************************************

846
\begin{code}
847
isUnLiftedType :: Type -> Bool
848 849 850 851 852 853
	-- isUnLiftedType returns True for forall'd unlifted types:
	--	x :: forall a. Int#
	-- I found bindings like these were getting floated to the top level.
	-- They are pretty bogus types, mind you.  It would be better never to
	-- construct them

854
isUnLiftedType ty | Just ty' <- coreView ty = isUnLiftedType ty'
855 856 857
isUnLiftedType (ForAllTy tv ty)  = isUnLiftedType ty
isUnLiftedType (TyConApp tc _)   = isUnLiftedTyCon tc
isUnLiftedType other		 = False	
858

859
isUnboxedTupleType :: Type -> Bool
860 861 862
isUnboxedTupleType ty = case splitTyConApp_maybe ty of
			   Just (tc, ty_args) -> isUnboxedTupleTyCon tc
			   other	      -> False
863

864
-- Should only be applied to *types*; hence the assert
865
isAlgType :: Type -> Bool
866 867 868 869 870 871 872 873 874 875 876 877 878
isAlgType ty 
  = case splitTyConApp_maybe ty of
      Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
			    isAlgTyCon tc
      _other	         -> False

-- Should only be applied to *types*; hence the assert
isClosedAlgType :: Type -> Bool
isClosedAlgType ty
  = case splitTyConApp_maybe ty of
      Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
			    isAlgTyCon tc && not (isOpenTyCon tc)
      _other	         -> False
879 880
\end{code}

881 882 883 884 885 886 887 888
@isStrictType@ computes whether an argument (or let RHS) should
be computed strictly or lazily, based only on its type.
Works just like isUnLiftedType, except that it has a special case 
for dictionaries.  Since it takes account of ClassP, you might think
this function should be in TcType, but isStrictType is used by DataCon,
which is below TcType in the hierarchy, so it's convenient to put it here.

\begin{code}
889 890
isStrictType (PredTy pred)     = isStrictPred pred
isStrictType ty | Just ty' <- coreView ty = isStrictType ty'
891 892 893 894 895 896
isStrictType (ForAllTy tv ty)  = isStrictType ty
isStrictType (TyConApp tc _)   = isUnLiftedTyCon tc
isStrictType other	       = False	

isStrictPred (ClassP clas _) = opt_DictsStrict && not (isNewTyCon (classTyCon clas))
isStrictPred other	     = False
897 898 899 900 901 902 903 904 905 906 907 908
	-- We may be strict in dictionary types, but only if it 
	-- has more than one component.
	-- [Being strict in a single-component dictionary risks
	--  poking the dictionary component, which is wrong.]
\end{code}

\begin{code}
isPrimitiveType :: Type -> Bool
-- Returns types that are opaque to Haskell.
-- Most of these are unlifted, but now that we interact with .NET, we
-- may have primtive (foreign-imported) types that are lifted
isPrimitiveType ty = case splitTyConApp_maybe ty of
sof's avatar
sof committed
909
			Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
910 911 912 913
					      isPrimTyCon tc
			other		   -> False
\end{code}

914

915 916 917 918 919 920 921 922 923 924 925 926
%************************************************************************
%*									*
\subsection{Sequencing on types
%*									*
%************************************************************************

\begin{code}
seqType :: Type -> ()
seqType (TyVarTy tv) 	  = tv `seq` ()
seqType (AppTy t1 t2) 	  = seqType t1 `seq` seqType t2
seqType (FunTy t1 t2) 	  = seqType t1 `seq` seqType t2
seqType (NoteTy note t2)  = seqNote note `seq` seqType t2
927
seqType (PredTy p) 	  = seqPred p
928 929 930 931 932 933 934 935 936
seqType (TyConApp tc tys) = tc `seq` seqTypes tys
seqType (ForAllTy tv ty)  = tv `seq` seqType ty

seqTypes :: [Type] -> ()
seqTypes []       = ()
seqTypes (ty:tys) = seqType ty `seq` seqTypes tys

seqNote :: TyNote -> ()
seqNote (FTVNote set) = sizeUniqSet set `seq` ()
937

938
seqPred :: PredType -> ()
<