Type.lhs 31 KB
Newer Older
1
2
3
%
% (c) The GRASP/AQUA Project, Glasgow University, 1998
%
4
\section[Type]{Type - public interface}
5

6
7
\begin{code}
module Type (
8
9
        -- re-exports from TypeRep
	TyThing(..), Type, PredType(..), ThetaType, TyVarSubst, 
10
	funTyCon,
11

12
13
14
	-- Re-exports from Kind
	module Kind,

15
16
	-- Re-exports from TyCon
	PrimRep(..),
17

18
19
	mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy,

20
	mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe,
21

22
	mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys, 
23
	funResultTy, funArgTy, zipFunTys, isFunTy,
24

25
	mkGenTyConApp, mkTyConApp, mkTyConTy, 
26
27
	tyConAppTyCon, tyConAppArgs, 
	splitTyConApp_maybe, splitTyConApp,
28

29
	mkSynTy, 
30

31
	repType, typePrimRep,
32

33
	mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, 
34
	applyTy, applyTys, isForAllTy, dropForAlls,
35

36
	-- Source types
37
	predTypeRep, mkPredTy, mkPredTys,
38

39
	-- Newtypes
40
	splitRecNewType_maybe,
41

42
	-- Lifting and boxity
43
44
	isUnLiftedType, isUnboxedTupleType, isAlgType, isPrimitiveType,
	isStrictType, isStrictPred, 
45

46
	-- Free variables
47
	tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
48
	typeKind, addFreeTyVars,
49

50
	-- Tidying up for printing
51
52
53
54
55
	tidyType,      tidyTypes,
	tidyOpenType,  tidyOpenTypes,
	tidyTyVarBndr, tidyFreeTyVars,
	tidyOpenTyVar, tidyOpenTyVars,
	tidyTopType,   tidyPred,
56

57
	-- Comparison
58
	eqType, 
59

60
	-- Seq
61
	seqType, seqTypes,
62

63
64
65
	-- Pretty-printing
	pprType, pprParendType,
	pprPred, pprTheta, pprThetaArrow, pprClassPred
66
    ) where
67

68
69
#include "HsVersions.h"

70
71
72
73
74
75
76
-- We import the representation and primitive functions from TypeRep.
-- Many things are reexported, but not the representation!

import TypeRep

-- Other imports:

77
import {-# SOURCE #-}   Subst  ( substTyWith )
78
79

-- friends:
80
import Kind
81
import Var	( TyVar, tyVarKind, tyVarName, setTyVarName )
82
83
84
import VarEnv
import VarSet

85
import Name	( NamedThing(..), mkInternalName, tidyOccName )
86
import Class	( Class, classTyCon )
87
import TyCon	( TyCon, isRecursiveTyCon, isPrimTyCon,
88
		  isUnboxedTupleTyCon, isUnLiftedTyCon,
89
		  isFunTyCon, isNewTyCon, newTyConRep, newTyConRhs,
90
		  isAlgTyCon, isSynTyCon, tyConArity, 
91
	          tyConKind, getSynTyConDefn, PrimRep(..), tyConPrimRep,
92
93
		)

94
-- others
95
import CmdLineOpts	( opt_DictsStrict )
96
97
import SrcLoc		( noSrcLoc )
import Unique		( Uniquable(..) )
98
import Util		( mapAccumL, seqList, lengthIs, snocView )
99
import Outputable
100
import UniqSet		( sizeUniqSet )		-- Should come via VarSet
101
import Maybe		( isJust )
102
103
\end{code}

104

105
106
107
108
109
%************************************************************************
%*									*
\subsection{Constructor-specific functions}
%*									*
%************************************************************************
sof's avatar
sof committed
110
111


112
113
114
---------------------------------------------------------------------
				TyVarTy
				~~~~~~~
115
\begin{code}
116
mkTyVarTy  :: TyVar   -> Type
117
mkTyVarTy  = TyVarTy
118

119
mkTyVarTys :: [TyVar] -> [Type]
120
mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
121

122
getTyVar :: String -> Type -> TyVar
123
124
125
getTyVar msg ty = case getTyVar_maybe ty of
		    Just tv -> tv
		    Nothing -> panic ("getTyVar: " ++ msg)
126

127
isTyVarTy :: Type -> Bool
128
129
130
131
132
133
134
135
isTyVarTy ty = isJust (getTyVar_maybe ty)

getTyVar_maybe :: Type -> Maybe TyVar
getTyVar_maybe (TyVarTy tv) 	 = Just tv
getTyVar_maybe (NoteTy _ t) 	 = getTyVar_maybe t
getTyVar_maybe (PredTy p) 	 = getTyVar_maybe (predTypeRep p)
getTyVar_maybe (NewTcApp tc tys) = getTyVar_maybe (newTypeRep tc tys)
getTyVar_maybe other	         = Nothing
136
137
138
\end{code}


139
140
141
142
143
144
---------------------------------------------------------------------
				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.
145

146
\begin{code}
147
mkAppTy orig_ty1 orig_ty2
148
  = mk_app orig_ty1
149
  where
150
    mk_app (NoteTy _ ty1)    = mk_app ty1
151
    mk_app (NewTcApp tc tys) = NewTcApp tc (tys ++ [orig_ty2])
152
    mk_app (TyConApp tc tys) = mkGenTyConApp tc (tys ++ [orig_ty2])
153
    mk_app ty1		     = AppTy orig_ty1 orig_ty2
154
155
156
157
158
159
160
161
	-- We call mkGenTyConApp because the TyConApp could be an 
	-- 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
162

163
mkAppTys :: Type -> [Type] -> Type
164
165
mkAppTys orig_ty1 []	    = orig_ty1
	-- This check for an empty list of type arguments
166
	-- avoids the needless loss of a type synonym constructor.
167
168
169
	-- For example: mkAppTys Rational []
	--   returns to (Ratio Integer), which has needlessly lost
	--   the Rational part.
170
mkAppTys orig_ty1 orig_tys2
171
  = mk_app orig_ty1
172
  where
173
    mk_app (NoteTy _ ty1)    = mk_app ty1
174
    mk_app (NewTcApp tc tys) = NewTcApp tc (tys ++ orig_tys2)
175
    mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
176
				-- Use mkTyConApp in case tc is (->)
177
    mk_app ty1		     = foldl AppTy orig_ty1 orig_tys2
178

179
splitAppTy_maybe :: Type -> Maybe (Type, Type)
180
splitAppTy_maybe (FunTy ty1 ty2)   = Just (TyConApp funTyCon [ty1], ty2)
181
182
splitAppTy_maybe (AppTy ty1 ty2)   = Just (ty1, ty2)
splitAppTy_maybe (NoteTy _ ty)     = splitAppTy_maybe ty
183
184
splitAppTy_maybe (PredTy p)        = splitAppTy_maybe (predTypeRep p)
splitAppTy_maybe (NewTcApp tc tys) = splitAppTy_maybe (newTypeRep tc tys)
185
186
splitAppTy_maybe (TyConApp tc tys) = case snocView tys of
					Nothing -> Nothing
187
188
189
					Just (tys',ty') -> Just (mkGenTyConApp tc tys', ty')
						-- mkGenTyConApp just in case the tc is a newtype

190
splitAppTy_maybe other	     	   = Nothing
191

192
splitAppTy :: Type -> (Type, Type)
193
194
195
splitAppTy ty = case splitAppTy_maybe ty of
			Just pr -> pr
			Nothing -> panic "splitAppTy"
196

197
splitAppTys :: Type -> (Type, [Type])
198
splitAppTys ty = split ty ty []
199
  where
200
    split orig_ty (AppTy ty arg)        args = split ty ty (arg:args)
201
    split orig_ty (NoteTy _ ty)         args = split orig_ty ty args
202
203
204
205
    split orig_ty (PredTy p)            args = split orig_ty (predTypeRep p) args
    split orig_ty (NewTcApp tc tc_args) args = split orig_ty (newTypeRep tc tc_args) args
    split orig_ty (TyConApp tc tc_args) args = (mkGenTyConApp tc [], tc_args ++ args)
						-- mkGenTyConApp just in case the tc is a newtype
206
    split orig_ty (FunTy ty1 ty2)       args = ASSERT( null args )
207
					       (TyConApp funTyCon [], [ty1,ty2])
208
    split orig_ty ty		        args = (orig_ty, args)
209
210
\end{code}

211
212
213
214
215

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

216
\begin{code}
217
mkFunTy :: Type -> Type -> Type
218
mkFunTy arg res = FunTy arg res
219

220
mkFunTys :: [Type] -> Type -> Type
221
mkFunTys tys ty = foldr FunTy ty tys
222

223
224
225
isFunTy :: Type -> Bool 
isFunTy ty = isJust (splitFunTy_maybe ty)

226
splitFunTy :: Type -> (Type, Type)
227
228
229
230
splitFunTy (FunTy arg res)   = (arg, res)
splitFunTy (NoteTy _ ty)     = splitFunTy ty
splitFunTy (PredTy p)        = splitFunTy (predTypeRep p)
splitFunTy (NewTcApp tc tys) = splitFunTy (newTypeRep tc tys)
231
splitFunTy other	     = pprPanic "splitFunTy" (ppr other)
232

233
splitFunTy_maybe :: Type -> Maybe (Type, Type)
234
235
236
237
238
splitFunTy_maybe (FunTy arg res)   = Just (arg, res)
splitFunTy_maybe (NoteTy _ ty)     = splitFunTy_maybe ty
splitFunTy_maybe (PredTy p)        = splitFunTy_maybe (predTypeRep p)
splitFunTy_maybe (NewTcApp tc tys) = splitFunTy_maybe (newTypeRep tc tys)
splitFunTy_maybe other	           = Nothing
239

240
splitFunTys :: Type -> ([Type], Type)
241
splitFunTys ty = split [] ty ty
242
  where
243
244
245
246
247
    split args orig_ty (FunTy arg res) 	 = split (arg:args) res res
    split args orig_ty (NoteTy _ ty)   	 = split args orig_ty ty
    split args orig_ty (PredTy p)     	 = split args orig_ty (predTypeRep p)
    split args orig_ty (NewTcApp tc tys) = split args orig_ty (newTypeRep tc tys)
    split args orig_ty ty                = (reverse args, orig_ty)
248

249
250
251
zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type)
zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
  where
252
253
254
255
256
    split acc []     nty ty  	           = (reverse acc, nty)
    split acc (x:xs) nty (FunTy arg res)   = split ((x,arg):acc) xs res res
    split acc xs     nty (NoteTy _ ty)     = split acc           xs nty ty
    split acc xs     nty (PredTy p)        = split acc           xs nty (predTypeRep p)
    split acc xs     nty (NewTcApp tc tys) = split acc           xs nty (newTypeRep tc tys)
257
    split acc (x:xs) nty ty                = pprPanic "zipFunTys" (ppr orig_xs <+> ppr orig_ty)
258
259
    
funResultTy :: Type -> Type
260
261
262
263
funResultTy (FunTy arg res)   = res
funResultTy (NoteTy _ ty)     = funResultTy ty
funResultTy (PredTy p)        = funResultTy (predTypeRep p)
funResultTy (NewTcApp tc tys) = funResultTy (newTypeRep tc tys)
264
funResultTy ty		      = pprPanic "funResultTy" (ppr ty)
265
266

funArgTy :: Type -> Type
267
268
269
270
funArgTy (FunTy arg res)   = arg
funArgTy (NoteTy _ ty)     = funArgTy ty
funArgTy (PredTy p)        = funArgTy (predTypeRep p)
funArgTy (NewTcApp tc tys) = funArgTy (newTypeRep tc tys)
271
funArgTy ty		   = pprPanic "funArgTy" (ppr ty)
272
273
274
\end{code}


275
276
277
---------------------------------------------------------------------
				TyConApp
				~~~~~~~~
278
@mkTyConApp@ is a key function, because it builds a TyConApp, FunTy or PredTy,
279
as apppropriate.
280

281
\begin{code}
282
283
284
285
286
mkGenTyConApp :: TyCon -> [Type] -> Type
mkGenTyConApp tc tys
  | isSynTyCon tc = mkSynTy tc tys
  | otherwise     = mkTyConApp tc tys

287
mkTyConApp :: TyCon -> [Type] -> Type
288
-- Assumes TyCon is not a SynTyCon; use mkSynTy instead for those
289
mkTyConApp tycon tys
290
  | isFunTyCon tycon, [ty1,ty2] <- tys
291
  = FunTy ty1 ty2
292

293
294
  | isNewTyCon tycon
  = NewTcApp tycon tys
295
296
297
298
299

  | otherwise
  = ASSERT(not (isSynTyCon tycon))
    TyConApp tycon tys

300
mkTyConTy :: TyCon -> Type
301
mkTyConTy tycon = mkTyConApp tycon []
302
303
304
305
306

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

307
tyConAppTyCon :: Type -> TyCon
308
tyConAppTyCon ty = fst (splitTyConApp ty)
309
310

tyConAppArgs :: Type -> [Type]
311
tyConAppArgs ty = snd (splitTyConApp ty)
312
313
314
315

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

318
splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
319
splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
320
splitTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [arg,res])
321
splitTyConApp_maybe (NoteTy _ ty)     = splitTyConApp_maybe ty
322
323
splitTyConApp_maybe (PredTy p)        = splitTyConApp_maybe (predTypeRep p)
splitTyConApp_maybe (NewTcApp tc tys) = splitTyConApp_maybe (newTypeRep tc tys)
324
splitTyConApp_maybe other	      = Nothing
sof's avatar
sof committed
325
\end{code}
326

327

328
329
330
331
---------------------------------------------------------------------
				SynTy
				~~~~~

332
\begin{code}
333
334
335
336
mkSynTy tycon tys
  | n_args == arity	-- Exactly saturated
  = mk_syn tys
  | n_args >  arity	-- Over-saturated
337
338
339
340
  = case splitAt arity tys of { (as,bs) -> mkAppTys (mk_syn as) bs }
	-- Its important to use mkAppTys, rather than (foldl AppTy),
	-- because (mk_syn as) might well return a partially-applied
	-- type constructor; indeed, usually will!
341
342
343
344
345
346
347
348
  | otherwise		-- Un-saturated
  = TyConApp tycon tys
	-- For the un-saturated case we build TyConApp directly
	-- (mkTyConApp ASSERTs that the tc isn't a SynTyCon).
	-- Here we are relying on checkValidType to find
	-- the error.  What we can't do is use mkSynTy with
	-- too few arg tys, because that is utterly bogus.

349
  where
350
351
352
353
354
355
    mk_syn tys = NoteTy (SynNote (TyConApp tycon tys))
			(substTyWith tyvars tys body)

    (tyvars, body) = ASSERT( isSynTyCon tycon ) getSynTyConDefn tycon
    arity 	   = tyConArity tycon
    n_args	   = length tys
356
357
\end{code}

358
359
360
361
Notes on type synonyms
~~~~~~~~~~~~~~~~~~~~~~
The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
to return type synonyms whereever possible. Thus
362

363
364
365
366
367
368
369
370
	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.
371
372


373
374
		Representation types
		~~~~~~~~~~~~~~~~~~~~
375
376
repType looks through 
	(a) for-alls, and
377
378
379
	(b) synonyms
	(c) predicates
	(d) usage annotations
380
	(e) [recursive] newtypes
381
It's useful in the back end.
382
383
384

\begin{code}
repType :: Type -> Type
385
-- Only applied to types of kind *; hence tycons are saturated
386
387
repType (ForAllTy _ ty)   = repType ty
repType (NoteTy   _ ty)   = repType ty
388
389
390
repType (PredTy  p)       = repType (predTypeRep p)
repType (NewTcApp tc tys) = ASSERT( tys `lengthIs` tyConArity tc )
			    repType (new_type_rep tc tys)
391
repType ty	 	  = ty
392

393

394
395
-- ToDo: this could be moved to the code generator, using splitTyConApp instead
-- of inspecting the type directly.
396
397
398
399
typePrimRep :: Type -> PrimRep
typePrimRep ty = case repType ty of
		   TyConApp tc _ -> tyConPrimRep tc
		   FunTy _ _	 -> PtrRep
400
		   AppTy _ _	 -> PtrRep	-- See note below
401
		   TyVarTy _	 -> PtrRep
402
		   other	 -> pprPanic "typePrimRep" (ppr ty)
403
404
405
406
407
	-- 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.
408
409
410
411
412
413

-- new_type_rep doesn't ask any questions: 
-- it just expands newtype, whether recursive or not
new_type_rep new_tycon tys = ASSERT( tys `lengthIs` tyConArity new_tycon )
			     case newTyConRep new_tycon of
				 (tvs, rep_ty) -> substTyWith tvs tys rep_ty
414
415
416
\end{code}


417
418
419
---------------------------------------------------------------------
				ForAllTy
				~~~~~~~~
420
421

\begin{code}
422
mkForAllTy :: TyVar -> Type -> Type
423
424
mkForAllTy tyvar ty
  = mkForAllTys [tyvar] ty
425

426
mkForAllTys :: [TyVar] -> Type -> Type
427
mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
428
429
430
431
432

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

434
splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
435
splitForAllTy_maybe ty = splitFAT_m ty
436
  where
437
    splitFAT_m (NoteTy _ ty)		= splitFAT_m ty
438
439
    splitFAT_m (PredTy p)		= splitFAT_m (predTypeRep p)
    splitFAT_m (NewTcApp tc tys)	= splitFAT_m (newTypeRep tc tys)
440
441
    splitFAT_m (ForAllTy tyvar ty)	= Just(tyvar, ty)
    splitFAT_m _			= Nothing
sof's avatar
sof committed
442

443
splitForAllTys :: Type -> ([TyVar], Type)
444
splitForAllTys ty = split ty ty []
445
   where
446
447
448
449
450
     split orig_ty (ForAllTy tv ty)  tvs = split ty ty (tv:tvs)
     split orig_ty (NoteTy _ ty)     tvs = split orig_ty ty tvs
     split orig_ty (PredTy p)	     tvs = split orig_ty (predTypeRep p) tvs
     split orig_ty (NewTcApp tc tys) tvs = split orig_ty (newTypeRep tc tys) tvs
     split orig_ty t		     tvs = (reverse tvs, orig_ty)
451
452
453

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

456
-- (mkPiType now in CoreUtils)
457

458
459
460
461
462
463
464
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. 
465

466
\begin{code}
467
applyTy :: Type -> Type -> Type
468
469
470
471
472
applyTy (PredTy p) 	  arg = applyTy (predTypeRep p) arg
applyTy (NewTcApp tc tys) arg = applyTy (newTypeRep tc tys) arg
applyTy (NoteTy _ fun)    arg = applyTy fun arg
applyTy (ForAllTy tv ty)  arg = substTyWith [tv] [arg] ty
applyTy other		  arg = panic "applyTy"
473

474
applyTys :: Type -> [Type] -> Type
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
-- 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
494
  = ASSERT2( n_tvs > 0, ppr orig_fun_ty )	-- Zero case gives infnite loop!
495
496
497
498
499
500
    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     
501
\end{code}
502

503

504
505
%************************************************************************
%*									*
506
\subsection{Source types}
507
508
%*									*
%************************************************************************
509

510
511
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.
512

513
Source types are always lifted.
514

515
The key function is predTypeRep which gives the representation of a source type:
516
517

\begin{code}
518
mkPredTy :: PredType -> Type
519
mkPredTy pred = PredTy pred
520
521

mkPredTys :: ThetaType -> [Type]
522
523
524
525
526
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.
527
528
-- Unwraps only the outermost level; for example, the result might
-- be a NewTcApp; c.f. newTypeRep
529
530
531
532
533
predTypeRep (IParam _ ty)     = ty
predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys
	-- Result might be a NewTcApp, but the consumer will
	-- look through that too if necessary
\end{code}
534
535


536
537
538
539
540
%************************************************************************
%*									*
		NewTypes
%*									*
%************************************************************************
541

542
543
544
545
\begin{code}
splitRecNewType_maybe :: Type -> Maybe Type
-- Newtypes are always represented by a NewTcApp
-- Sometimes we want to look through a recursive newtype, and that's what happens here
546
-- It only strips *one layer* off, so the caller will usually call itself recursively
547
548
-- Only applied to types of kind *, hence the newtype is always saturated
splitRecNewType_maybe (NoteTy _ ty) = splitRecNewType_maybe ty  
549
splitRecNewType_maybe (PredTy p)    = splitRecNewType_maybe (predTypeRep p)
550
551
552
splitRecNewType_maybe (NewTcApp tc tys)
  | isRecursiveTyCon tc
  = ASSERT( tys `lengthIs` tyConArity tc && isNewTyCon tc )
553
554
555
	-- The assert should hold because splitRecNewType_maybe
	-- should only be applied to *types* (of kind *)
    Just (new_type_rhs tc tys)
556
splitRecNewType_maybe other = Nothing
557
			
558
559
-----------------------------
newTypeRep :: TyCon -> [Type] -> Type
560
-- A local helper function (not exported)
561
-- Expands *the outermoset level of* a newtype application to 
562
--	*either* a vanilla TyConApp (recursive newtype, or non-saturated)
563
564
565
566
567
568
569
570
571
572
--	*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)
--   newTypeRep on R gives NewTcApp S
--		on S gives NewTcApp T
--		on T gives TyConApp T
573
574
575
576
577
578
579
--
-- NB: the returned TyConApp is always deconstructed immediately by the 
--     caller... a TyConApp with a newtype type constructor never lives
--     in an ordinary type
newTypeRep tc tys
  | not (isRecursiveTyCon tc),		-- Not recursive and saturated
    tys `lengthIs` tyConArity tc 	-- treat as equivalent to expansion
580
  = new_type_rhs tc tys
581
582
583
584
  | otherwise
  = TyConApp tc tys
	-- ToDo: Consider caching this substitution in a NType

585
586
587
588
589
-- new_type_rhs doesn't ask any questions: 
-- it just expands newtype one level, whether recursive or not
new_type_rhs tc tys 
  = case newTyConRhs tc of
	(tvs, rep_ty) -> substTyWith tvs tys rep_ty
590
591
\end{code}

592

593
594
595
596
597
598
599
600
601
%************************************************************************
%*									*
\subsection{Kinds and free variables}
%*									*
%************************************************************************

---------------------------------------------------------------------
		Finding the kind of a type
		~~~~~~~~~~~~~~~~~~~~~~~~~~
602
\begin{code}
603
typeKind :: Type -> Kind
604

605
typeKind (TyVarTy tyvar)	= tyVarKind tyvar
606
607
typeKind (TyConApp tycon tys)	= foldr (\_ k -> kindFunResult k) (tyConKind tycon) tys
typeKind (NewTcApp tycon tys)	= foldr (\_ k -> kindFunResult k) (tyConKind tycon) tys
608
typeKind (NoteTy _ ty)		= typeKind ty
609
typeKind (PredTy _)		= liftedTypeKind -- Predicates are always 
610
						 -- represented by lifted types
611
612
typeKind (AppTy fun arg)	= kindFunResult (typeKind fun)
typeKind (FunTy arg res)	= liftedTypeKind
613
typeKind (ForAllTy tv ty)	= typeKind ty
614
615
616
\end{code}


617
618
619
---------------------------------------------------------------------
		Free variables of a type
		~~~~~~~~~~~~~~~~~~~~~~~~
620
\begin{code}
621
tyVarsOfType :: Type -> TyVarSet
622
tyVarsOfType (TyVarTy tv)		= unitVarSet tv
623
tyVarsOfType (TyConApp tycon tys)	= tyVarsOfTypes tys
624
tyVarsOfType (NewTcApp tycon tys)	= tyVarsOfTypes tys
625
tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
626
tyVarsOfType (NoteTy (SynNote ty1) ty2)	= tyVarsOfType ty2	-- See note [Syn] below
627
tyVarsOfType (PredTy sty)		= tyVarsOfPred sty
628
629
630
tyVarsOfType (FunTy arg res)		= tyVarsOfType arg `unionVarSet` tyVarsOfType res
tyVarsOfType (AppTy fun arg)		= tyVarsOfType fun `unionVarSet` tyVarsOfType arg
tyVarsOfType (ForAllTy tyvar ty)	= tyVarsOfType ty `minusVarSet` unitVarSet tyvar
631

632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
-- 			Note [Syn]
-- Consider
--	type T a = Int
-- What are the free tyvars of (T x)?  Empty, of course!  
-- Here's the example that Ralf Laemmel showed me:
--	foo :: (forall a. C u a -> C u a) -> u
--	mappend :: Monoid u => u -> u -> u
--
--	bar :: Monoid u => u
--	bar = foo (\t -> t `mappend` t)
-- We have to generalise at the arg to f, and we don't
-- want to capture the constraint (Monad (C u a)) because
-- it appears to mention a.  Pretty silly, but it was useful to him.


647
tyVarsOfTypes :: [Type] -> TyVarSet
648
649
tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys

650
tyVarsOfPred :: PredType -> TyVarSet
651
652
tyVarsOfPred (IParam _ ty)  = tyVarsOfType ty
tyVarsOfPred (ClassP _ tys) = tyVarsOfTypes tys
653
654

tyVarsOfTheta :: ThetaType -> TyVarSet
655
tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet
656

657
-- Add a Note with the free tyvars to the top of the type
658
addFreeTyVars :: Type -> Type
659
660
addFreeTyVars ty@(NoteTy (FTVNote _) _)      = ty
addFreeTyVars ty			     = NoteTy (FTVNote (tyVarsOfType ty)) ty
661
\end{code}
662

663
664
665
666
667
%************************************************************************
%*									*
\subsection{TidyType}
%*									*
%************************************************************************
668

669
670
tidyTy tidies up a type for printing in an error message, or in
an interface file.
671

672
It doesn't change the uniques at all, just the print names.
673
674

\begin{code}
675
676
677
tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
tidyTyVarBndr (tidy_env, subst) tyvar
  = case tidyOccName tidy_env (getOccName name) of
678
      (tidy', occ') -> 	((tidy', subst'), tyvar')
679
680
681
		    where
			subst' = extendVarEnv subst tyvar tyvar'
			tyvar' = setTyVarName tyvar name'
682
			name'  = mkInternalName (getUnique name) occ' noSrcLoc
683
684
				-- Note: make a *user* tyvar, so it printes nicely
				-- Could extract src loc, but no need.
685
686
  where
    name = tyVarName tyvar
687

688
689
690
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
691
692
693
694
695
696
697
698
699
700
701
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
702

703
704
705
tidyType :: TidyEnv -> Type -> Type
tidyType env@(tidy_env, subst) ty
  = go ty
706
  where
707
708
709
    go (TyVarTy tv)	    = case lookupVarEnv subst tv of
				Nothing  -> TyVarTy tv
				Just tv' -> TyVarTy tv'
710
711
    go (TyConApp tycon tys) = let args = map go tys
			      in args `seqList` TyConApp tycon args
712
713
    go (NewTcApp tycon tys) = let args = map go tys
			      in args `seqList` NewTcApp tycon args
sof's avatar
sof committed
714
    go (NoteTy note ty)     = (NoteTy $! (go_note note)) $! (go ty)
715
    go (PredTy sty)	    = PredTy (tidyPred env sty)
sof's avatar
sof committed
716
717
718
    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)
719
			      where
720
			        (envp, tvp) = tidyTyVarBndr env tv
721

sof's avatar
sof committed
722
    go_note (SynNote ty)        = SynNote $! (go ty)
723
724
    go_note note@(FTVNote ftvs) = note	-- No need to tidy the free tyvars

725
tidyTypes env tys = map (tidyType env) tys
726

727
728
729
tidyPred :: TidyEnv -> PredType -> PredType
tidyPred env (IParam n ty)     = IParam n (tidyType env ty)
tidyPred env (ClassP clas tys) = ClassP clas (tidyTypes env tys)
730
731
732
\end{code}


733
@tidyOpenType@ grabs the free type variables, tidies them
734
735
736
737
738
739
740
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
741
    env' = tidyFreeTyVars env (tyVarsOfType ty)
742
743
744
745
746
747

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

tidyTopType :: Type -> Type
tidyTopType ty = tidyType emptyTidyEnv ty
748
749
\end{code}

750

751

752
753
%************************************************************************
%*									*
754
\subsection{Liftedness}
755
756
757
%*									*
%************************************************************************

758
\begin{code}
759
isUnLiftedType :: Type -> Bool
760
761
762
763
764
765
	-- 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

766
767
768
769
770
771
isUnLiftedType (ForAllTy tv ty)  = isUnLiftedType ty
isUnLiftedType (NoteTy _ ty)	 = isUnLiftedType ty
isUnLiftedType (TyConApp tc _)   = isUnLiftedTyCon tc
isUnLiftedType (PredTy _)	 = False		-- All source types are lifted
isUnLiftedType (NewTcApp tc tys) = isUnLiftedType (newTypeRep tc tys)
isUnLiftedType other		 = False	
772

773
isUnboxedTupleType :: Type -> Bool
774
775
776
isUnboxedTupleType ty = case splitTyConApp_maybe ty of
			   Just (tc, ty_args) -> isUnboxedTupleTyCon tc
			   other	      -> False
777

778
-- Should only be applied to *types*; hence the assert
779
isAlgType :: Type -> Bool
780
isAlgType ty = case splitTyConApp_maybe ty of
sof's avatar
sof committed
781
			Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
782
783
					      isAlgTyCon tc
			other		   -> False
784
785
\end{code}

786
787
788
789
790
791
792
793
@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}
794
795
796
797
798
799
800
801
802
isStrictType (ForAllTy tv ty)  = isStrictType ty
isStrictType (NoteTy _ ty)     = isStrictType ty
isStrictType (TyConApp tc _)   = isUnLiftedTyCon tc
isStrictType (NewTcApp tc tys) = isStrictType (newTypeRep tc tys)
isStrictType (PredTy pred)     = isStrictPred pred
isStrictType other	       = False	

isStrictPred (ClassP clas _) = opt_DictsStrict && not (isNewTyCon (classTyCon clas))
isStrictPred other	     = False
803
804
805
806
807
808
809
810
811
812
813
814
	-- 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
815
			Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
816
817
818
819
					      isPrimTyCon tc
			other		   -> False
\end{code}

820

821
822
823
824
825
826
827
828
829
830
831
832
%************************************************************************
%*									*
\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
833
seqType (PredTy p) 	  = seqPred p
834
seqType (TyConApp tc tys) = tc `seq` seqTypes tys
835
seqType (NewTcApp tc tys) = tc `seq` seqTypes tys
836
837
838
839
840
841
842
843
844
seqType (ForAllTy tv ty)  = tv `seq` seqType ty

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

seqNote :: TyNote -> ()
seqNote (SynNote ty)  = seqType ty
seqNote (FTVNote set) = sizeUniqSet set `seq` ()
845

846
seqPred :: PredType -> ()
847
848
seqPred (ClassP c tys) = c  `seq` seqTypes tys
seqPred (IParam n ty)  = n  `seq` seqType ty
849
850
851
852
853
854
855
856
857
\end{code}


%************************************************************************
%*									*
\subsection{Equality on types}
%*									*
%************************************************************************

858
859
Comparison; don't use instances so that we know where it happens.
Look through newtypes but not usage types.
860

861
862
863
864
865
866
867
868
869
870
Note that eqType can respond 'False' for partial applications of newtypes.
Consider
	newtype Parser m a = MkParser (Foogle m a)

Does 	
	Monad (Parser m) `eqType` Monad (Foogle m)

Well, yes, but eqType won't see that they are the same. 
I don't think this is harmful, but it's soemthing to watch out for.

871
\begin{code}
872
873
874
875
876
877
eqType t1 t2 = eq_ty emptyVarEnv t1 t2

-- Look through Notes
eq_ty env (NoteTy _ t1)       t2	  	  = eq_ty env t1 t2
eq_ty env t1		      (NoteTy _ t2)       = eq_ty env t1 t2

878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
-- Look through PredTy and NewTcApp.  This is where the looping danger comes from.
-- We don't bother to check for the PredType/PredType case, no good reason
-- Hmm: maybe there is a good reason: see the notes below about newtypes
eq_ty env (PredTy sty1)     t2		  = eq_ty env (predTypeRep sty1) t2
eq_ty env t1		    (PredTy sty2) = eq_ty env t1 (predTypeRep sty2)

-- NB: we *cannot* short-cut the newtype comparison thus:
-- eq_ty env (NewTcApp tc1 tys1) (NewTcApp tc2 tys2) 
--	| (tc1 == tc2) = (eq_tys env tys1 tys2)
--
-- Consider:
--	newtype T a = MkT [a]
--	newtype Foo m = MkFoo (forall a. m a -> Int)
--	w1 :: Foo []
--	w1 = ...
--	
--	w2 :: Foo T
--	w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x)
--
-- We end up with w2 = w1; so we need that Foo T = Foo []
-- but we can only expand saturated newtypes, so just comparing
-- T with [] won't do. 

eq_ty env (NewTcApp tc1 tys1) t2		  = eq_ty env (newTypeRep tc1 tys1) t2
eq_ty env t1		      (NewTcApp tc2 tys2) = eq_ty env t1 (newTypeRep tc2 tys2)
903
904
905
906
907
908

-- The rest is plain sailing
eq_ty env (TyVarTy tv1)       (TyVarTy tv2)       = case lookupVarEnv env tv1 of
							  Just tv1a -> tv1a == tv2
							  Nothing   -> tv1  == tv2
eq_ty env (ForAllTy tv1 t1)   (ForAllTy tv2 t2)   
909
	| tv1 == tv2				  = eq_ty (delVarEnv env tv1)        t1 t2
910
911
912
913
914
915
916
	| otherwise				  = eq_ty (extendVarEnv env tv1 tv2) t1 t2
eq_ty env (AppTy s1 t1)       (AppTy s2 t2)       = (eq_ty env s1 s2) && (eq_ty env t1 t2)
eq_ty env (FunTy s1 t1)       (FunTy s2 t2)       = (eq_ty env s1 s2) && (eq_ty env t1 t2)
eq_ty env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 == tc2) && (eq_tys env tys1 tys2)
eq_ty env t1		       t2		  = False

eq_tys env []        []        = True
apt's avatar
apt committed
917
eq_tys env (t1:tys1) (t2:tys2) = (eq_ty env t1 t2) && (eq_tys env tys1 tys2)
918
eq_tys env tys1      tys2      = False
919
920
\end{code}