Type.lhs 57.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_GHC -fno-warn-orphans #-}
Ian Lynagh's avatar
Ian Lynagh committed
10
11
12
13
14
15
16
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

batterseapower's avatar
batterseapower committed
17
-- | Main functions for manipulating types and type-related things
18
module Type (
batterseapower's avatar
batterseapower committed
19
	-- Note some of this is just re-exports from TyCon..
20

batterseapower's avatar
batterseapower committed
21
22
23
24
        -- * Main data types representing Types
	-- $type_classification
	
        -- $representation_types
dreixel's avatar
dreixel committed
25
        TyThing(..), Type, KindOrType, PredType, ThetaType,
26
        Var, TyVar, isTyVar, 
27

batterseapower's avatar
batterseapower committed
28
29
        -- ** Constructing and deconstructing types
        mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe,
30

31
	mkAppTy, mkAppTys, mkNakedAppTys, splitAppTy, splitAppTys, 
32
	splitAppTy_maybe, repSplitAppTy_maybe,
33

34
35
	mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, 
	splitFunTys, splitFunTysN,
36
	funResultTy, funArgTy, zipFunTys, 
37

dreixel's avatar
dreixel committed
38
	mkTyConApp, mkTyConTy,
39
	tyConAppTyCon_maybe, tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs, 
40
	splitTyConApp_maybe, splitTyConApp, tyConAppArgN,
41

batterseapower's avatar
batterseapower committed
42
        mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, 
43
        mkPiKinds, mkPiType, mkPiTypes,
44
	applyTy, applyTys, applyTysD, isForAllTy, dropForAlls,
45

46
47
        mkNumLitTy, isNumLitTy,
        mkStrLitTy, isStrLitTy,
batterseapower's avatar
batterseapower committed
48
49
	
	-- (Newtypes)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
50
	newTyConInstRhs, carefullySplitNewType_maybe,
batterseapower's avatar
batterseapower committed
51
	
52
	-- Pred types
batterseapower's avatar
batterseapower committed
53
54
        mkFamilyTyConApp,
	isDictLikeTy,
55
        mkEqPred, mkPrimEqPred,
56
        mkClassPred,
57
        noParenPred, isClassPred, isEqPred, isIPPred, isIPPred_maybe,
58
        
batterseapower's avatar
batterseapower committed
59
        -- Deconstructing predicate types
60
        PredTree(..), predTreePredType, classifyPredType,
batterseapower's avatar
batterseapower committed
61
62
        getClassPredTys, getClassPredTys_maybe,
        getEqPredTys, getEqPredTys_maybe,
63

batterseapower's avatar
batterseapower committed
64
65
	-- ** Common type constructors
        funTyCon,
66

batterseapower's avatar
batterseapower committed
67
        -- ** Predicates on types
68
        isTypeVar, isKindVar,
dreixel's avatar
dreixel committed
69
        isTyVarTy, isFunTy, isDictTy, isPredTy, isKindTy,
batterseapower's avatar
batterseapower committed
70
71

	-- (Lifting and boxity)
72
	isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType,
batterseapower's avatar
batterseapower committed
73
	isPrimitiveType, isStrictType,
74

batterseapower's avatar
batterseapower committed
75
76
	-- * Main data types representing Kinds
	-- $kind_subtyping
dreixel's avatar
dreixel committed
77
        Kind, SimpleKind, MetaKindVar,
batterseapower's avatar
batterseapower committed
78
79
80

        -- ** Finding the kind of a type
        typeKind,
batterseapower's avatar
batterseapower committed
81
82
        
        -- ** Common Kinds and SuperKinds
dreixel's avatar
dreixel committed
83
        anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind,
84
        constraintKind, superKind, 
batterseapower's avatar
batterseapower committed
85
86
87

        -- ** Common Kind type constructors
        liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
88
        constraintKindTyCon, anyKindTyCon,
batterseapower's avatar
batterseapower committed
89
90

	-- * Type free variables
batterseapower's avatar
batterseapower committed
91
	tyVarsOfType, tyVarsOfTypes,
92
	expandTypeSynonyms, 
93
	typeSize, varSetElemsKvsFirst, 
94

batterseapower's avatar
batterseapower committed
95
	-- * Type comparison
96
97
        eqType, eqTypeX, eqTypes, cmpType, cmpTypes, 
	eqPred, eqPredX, cmpPred, eqKind,
98

batterseapower's avatar
batterseapower committed
99
	-- * Forcing evaluation of types
batterseapower's avatar
batterseapower committed
100
        seqType, seqTypes,
101

batterseapower's avatar
batterseapower committed
102
        -- * Other views onto Types
103
        coreView, tcView, 
batterseapower's avatar
batterseapower committed
104

105
        UnaryType, RepType(..), flattenRepType, repType,
batterseapower's avatar
batterseapower committed
106
107

	-- * Type representation for the code generator
108
	typePrimRep, typeRepArity,
batterseapower's avatar
batterseapower committed
109
110
111
112
113
114
115
116

	-- * Main type substitution data types
	TvSubstEnv,	-- Representation widely visible
	TvSubst(..), 	-- Representation visible to a few friends
	
	-- ** Manipulating type substitutions
	emptyTvSubstEnv, emptyTvSubst,
	
117
	mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst,
118
119
        getTvSubstEnv, setTvSubstEnv,
        zapTvSubstEnv, getTvInScope,
120
        extendTvInScope, extendTvInScopeList,
121
122
 	extendTvSubst, extendTvSubstList,
        isInScope, composeTvSubst, zipTyEnv,
123
        isEmptyTvSubst, unionTvSubst,
124

dreixel's avatar
dreixel committed
125
	-- ** Performing substitution on types and kinds
126
	substTy, substTys, substTyWith, substTysWith, substTheta, 
batterseapower's avatar
batterseapower committed
127
        substTyVar, substTyVars, substTyVarBndr,
dreixel's avatar
dreixel committed
128
129
        cloneTyVarBndr, deShadowTy, lookupTyVar,
        substKiWith, substKisWith,
130

batterseapower's avatar
batterseapower committed
131
	-- * Pretty-printing
132
	pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, 
133
        pprTvBndr, pprTvBndrs, pprForAll, pprSigmaType,
batterseapower's avatar
batterseapower committed
134
	pprEqPred, pprTheta, pprThetaArrowTy, pprClassPred, 
dreixel's avatar
dreixel committed
135
        pprKind, pprParendKind, pprSourceTyCon,
136
    ) where
137

138
139
#include "HsVersions.h"

140
141
142
-- We import the representation and primitive functions from TypeRep.
-- Many things are reexported, but not the representation!

dreixel's avatar
dreixel committed
143
import Kind
144
145
import TypeRep

146
-- friends:
147
import Var
148
149
150
import VarEnv
import VarSet

151
152
import Class
import TyCon
153
import TysPrim
batterseapower's avatar
batterseapower committed
154
import {-# SOURCE #-} TysWiredIn ( eqTyCon, mkBoxedTupleTy )
155
import PrelNames	         ( eqTyConKey, ipClassName )
156

157
-- others
158
import Unique		( Unique, hasKey )
159
import BasicTypes	( Arity, RepArity )
Simon Peyton Jones's avatar
Simon Peyton Jones committed
160
import NameSet
161
162
import StaticFlags
import Util
163
import Outputable
164
import FastString
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
165

166
import Data.List        ( partition )
167
import Maybes		( orElse )
168
import Data.Maybe	( isJust )
169
import Control.Monad    ( guard )
170
171

infixr 3 `mkFunTy`	-- Associates to the right
172
173
\end{code}

batterseapower's avatar
batterseapower committed
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
\begin{code}
-- $type_classification
-- #type_classification#
-- 
-- Types are one of:
-- 
-- [Unboxed]            Iff its representation is other than a pointer
-- 			Unboxed types are also unlifted.
-- 
-- [Lifted]             Iff it has bottom as an element.
-- 			Closures always have lifted types: i.e. any
-- 			let-bound identifier in Core must have a lifted
-- 			type. Operationally, a lifted object is one that
-- 			can be entered.
-- 			Only lifted types may be unified with a type variable.
-- 
-- [Algebraic]          Iff it is a type with one or more constructors, whether
-- 			declared with @data@ or @newtype@.
-- 			An algebraic type is one that can be deconstructed
-- 			with a case expression. This is /not/ the same as 
--			lifted types, because we also include unboxed
-- 			tuples in this classification.
-- 
-- [Data]               Iff it is a type declared with @data@, or a boxed tuple.
-- 
-- [Primitive]          Iff it is a built-in type that can't be expressed in Haskell.
-- 
-- Currently, all primitive types are unlifted, but that's not necessarily
-- the case: for example, @Int@ could be primitive.
-- 
-- Some primitive types are unboxed, such as @Int#@, whereas some are boxed
-- but unlifted (such as @ByteArray#@).  The only primitive types that we
-- classify as algebraic are the unboxed tuples.
-- 
-- Some examples of type classifications that may make this a bit clearer are:
-- 
-- @
-- Type         primitive       boxed           lifted          algebraic
-- -----------------------------------------------------------------------------
-- Int#         Yes             No              No              No
-- ByteArray#   Yes             Yes             No              No
-- (\# a, b \#)   Yes             No              No              Yes
-- (  a, b  )   No              Yes             Yes             Yes
-- [a]          No              Yes             Yes             Yes
-- @

-- $representation_types
-- A /source type/ is a type that is a separate type as far as the type checker is
-- concerned, but which has a more low-level representation as far as Core-to-Core
batterseapower's avatar
batterseapower committed
223
-- passes and the rest of the back end is concerned.
batterseapower's avatar
batterseapower committed
224
225
226
227
228
229
--
-- You don't normally have to worry about this, as the utility functions in
-- this module will automatically convert a source into a representation type
-- if they are spotted, to the best of it's abilities. If you don't want this
-- to happen, use the equivalent functions from the "TcType" module.
\end{code}
230

231
232
233
234
235
236
237
238
239
%************************************************************************
%*									*
		Type representation
%*									*
%************************************************************************

\begin{code}
{-# INLINE coreView #-}
coreView :: Type -> Maybe Type
batterseapower's avatar
batterseapower committed
240
241
242
243
-- ^ In Core, we \"look through\" non-recursive newtypes and 'PredTypes': this
-- function tries to obtain a different view of the supplied type given this
--
-- Strips off the /top layer only/ of a type to give 
244
245
246
-- its underlying representation type. 
-- Returns Nothing if there is nothing to look through.
--
247
248
249
-- By being non-recursive and inlined, this case analysis gets efficiently
-- joined onto the case analysis that the caller is already doing
coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc tys 
batterseapower's avatar
batterseapower committed
250
251
252
253
              = 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!
254
coreView _                 = Nothing
255
256
257
258

-----------------------------------------------
{-# INLINE tcView #-}
tcView :: Type -> Maybe Type
batterseapower's avatar
batterseapower committed
259
-- ^ Similar to 'coreView', but for the type checker, which just looks through synonyms
260
261
tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys 
			 = Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys')
262
tcView _                 = Nothing
263
264
265
  -- You might think that tcView belows in TcType rather than Type, but unfortunately
  -- it is needed by Unify, which is turn imported by Coercion (for MatchEnv and matchList).
  -- So we will leave it here to avoid module loops.
266

267
268
269
270
271
272
273
274
275
276
277
278
279
-----------------------------------------------
expandTypeSynonyms :: Type -> Type
-- ^ Expand out all type synonyms.  Actually, it'd suffice to expand out
-- just the ones that discard type variables (e.g.  type Funny a = Int)
-- But we don't know which those are currently, so we just expand all.
expandTypeSynonyms ty 
  = go ty
  where
    go (TyConApp tc tys)
      | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys 
      = go (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys')
      | otherwise
      = TyConApp tc (map go tys)
280
    go (LitTy l)       = LitTy l
281
    go (TyVarTy tv)    = TyVarTy tv
282
    go (AppTy t1 t2)   = mkAppTy (go t1) (go t2)
283
284
    go (FunTy t1 t2)   = FunTy (go t1) (go t2)
    go (ForAllTy tv t) = ForAllTy tv (go t)
285
286
287
\end{code}


288
289
290
291
292
%************************************************************************
%*									*
\subsection{Constructor-specific functions}
%*									*
%************************************************************************
sof's avatar
sof committed
293
294


295
296
297
---------------------------------------------------------------------
				TyVarTy
				~~~~~~~
298
\begin{code}
batterseapower's avatar
batterseapower committed
299
300
-- | Attempts to obtain the type variable underlying a 'Type', and panics with the
-- given message if this is not a type variable type. See also 'getTyVar_maybe'
301
getTyVar :: String -> Type -> TyVar
302
303
304
getTyVar msg ty = case getTyVar_maybe ty of
		    Just tv -> tv
		    Nothing -> panic ("getTyVar: " ++ msg)
305

306
isTyVarTy :: Type -> Bool
307
308
isTyVarTy ty = isJust (getTyVar_maybe ty)

batterseapower's avatar
batterseapower committed
309
-- | Attempts to obtain the type variable underlying a 'Type'
310
getTyVar_maybe :: Type -> Maybe TyVar
311
312
getTyVar_maybe ty | Just ty' <- coreView ty = getTyVar_maybe ty'
getTyVar_maybe (TyVarTy tv) 	 	    = Just tv  
313
getTyVar_maybe _                            = Nothing
314

315
316
317
\end{code}


318
319
320
321
322
323
---------------------------------------------------------------------
				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.
324

325
\begin{code}
batterseapower's avatar
batterseapower committed
326
-- | Applies a type to another, as in e.g. @k a@
327
mkAppTy :: Type -> Type -> Type
328
329
mkAppTy (TyConApp tc tys) ty2 = mkTyConApp tc (tys ++ [ty2])
mkAppTy ty1               ty2 = AppTy ty1 ty2
330
	-- Note that the TyConApp could be an 
331
332
333
334
335
336
337
	-- 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
338

339
mkAppTys :: Type -> [Type] -> Type
340
341
342
343
344
345
346
347
mkAppTys ty1                []	 = ty1
mkAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2)
mkAppTys ty1                tys2 = foldl AppTy ty1 tys2

mkNakedAppTys :: Type -> [Type] -> Type
mkNakedAppTys ty1           []	 = ty1
mkNakedAppTys (TyConApp tc tys1) tys2 = mkNakedTyConApp tc (tys1 ++ tys2)
mkNakedAppTys ty1                tys2 = foldl AppTy ty1 tys2
348

349
-------------
350
splitAppTy_maybe :: Type -> Maybe (Type, Type)
batterseapower's avatar
batterseapower committed
351
352
353
-- ^ Attempt to take a type application apart, whether it is a
-- function, type constructor, or plain type application. Note
-- that type family applications are NEVER unsaturated by this!
354
355
356
splitAppTy_maybe ty | Just ty' <- coreView ty
		    = splitAppTy_maybe ty'
splitAppTy_maybe ty = repSplitAppTy_maybe ty
357

358
359
-------------
repSplitAppTy_maybe :: Type -> Maybe (Type,Type)
batterseapower's avatar
batterseapower committed
360
361
-- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that 
-- any Core view stuff is already done
362
363
repSplitAppTy_maybe (FunTy ty1 ty2)   = Just (TyConApp funTyCon [ty1], ty2)
repSplitAppTy_maybe (AppTy ty1 ty2)   = Just (ty1, ty2)
364
repSplitAppTy_maybe (TyConApp tc tys) 
365
366
367
  | isDecomposableTyCon tc || tys `lengthExceeds` tyConArity tc 
  , Just (tys', ty') <- snocView tys
  = Just (TyConApp tc tys', ty')    -- Never create unsaturated type family apps!
368
repSplitAppTy_maybe _other = Nothing
369
-------------
370
splitAppTy :: Type -> (Type, Type)
batterseapower's avatar
batterseapower committed
371
372
-- ^ Attempts to take a type application apart, as in 'splitAppTy_maybe',
-- and panics if this is not possible
373
374
375
splitAppTy ty = case splitAppTy_maybe ty of
			Just pr -> pr
			Nothing -> panic "splitAppTy"
376

377
-------------
378
splitAppTys :: Type -> (Type, [Type])
batterseapower's avatar
batterseapower committed
379
380
381
-- ^ Recursively splits a type as far as is possible, leaving a residual
-- type being applied to and the type arguments applied to it. Never fails,
-- even if that means returning an empty list of type applications.
382
splitAppTys ty = split ty ty []
383
  where
384
    split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args
385
386
    split _       (AppTy ty arg)        args = split ty ty (arg:args)
    split _       (TyConApp tc tc_args) args
387
      = let -- keep type families saturated
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
388
389
            n | isDecomposableTyCon tc = 0
              | otherwise              = tyConArity tc
390
            (tc_args1, tc_args2) = splitAt n tc_args
391
392
        in
        (TyConApp tc tc_args1, tc_args2 ++ args)
393
    split _       (FunTy ty1 ty2)       args = ASSERT( null args )
394
					       (TyConApp funTyCon [], [ty1,ty2])
395
    split orig_ty _                     args = (orig_ty, args)
396

397
398
\end{code}

399

400
                      LitTy
401
                      ~~~~~
402
403

\begin{code}
404
405
mkNumLitTy :: Integer -> Type
mkNumLitTy n = LitTy (NumTyLit n)
406

407
408
409
isNumLitTy :: Type -> Maybe Integer
isNumLitTy (LitTy (NumTyLit n)) = Just n
isNumLitTy _                    = Nothing
410

411
412
413
414
415
416
mkStrLitTy :: FastString -> Type
mkStrLitTy s = LitTy (StrTyLit s)

isStrLitTy :: Type -> Maybe FastString
isStrLitTy (LitTy (StrTyLit s)) = Just s
isStrLitTy _                    = Nothing
417
418
419
420

\end{code}


421
422
423
424
---------------------------------------------------------------------
				FunTy
				~~~~~

425
\begin{code}
426
mkFunTy :: Type -> Type -> Type
batterseapower's avatar
batterseapower committed
427
-- ^ Creates a function type from the given argument and result type
428
mkFunTy arg res = FunTy arg res
429

430
mkFunTys :: [Type] -> Type -> Type
431
mkFunTys tys ty = foldr mkFunTy ty tys
432

433
434
435
isFunTy :: Type -> Bool 
isFunTy ty = isJust (splitFunTy_maybe ty)

436
splitFunTy :: Type -> (Type, Type)
batterseapower's avatar
batterseapower committed
437
438
-- ^ Attempts to extract the argument and result types from a type, and
-- panics if that is not possible. See also 'splitFunTy_maybe'
439
splitFunTy ty | Just ty' <- coreView ty = splitFunTy ty'
440
splitFunTy (FunTy arg res)   = (arg, res)
441
splitFunTy other	     = pprPanic "splitFunTy" (ppr other)
442

443
splitFunTy_maybe :: Type -> Maybe (Type, Type)
batterseapower's avatar
batterseapower committed
444
-- ^ Attempts to extract the argument and result types from a type
445
splitFunTy_maybe ty | Just ty' <- coreView ty = splitFunTy_maybe ty'
446
splitFunTy_maybe (FunTy arg res)   = Just (arg, res)
447
splitFunTy_maybe _                 = Nothing
448

449
splitFunTys :: Type -> ([Type], Type)
450
splitFunTys ty = split [] ty ty
451
  where
452
    split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty'
453
454
    split args _       (FunTy arg res)   = split (arg:args) res res
    split args orig_ty _                 = (reverse args, orig_ty)
455

456
splitFunTysN :: Int -> Type -> ([Type], Type)
batterseapower's avatar
batterseapower committed
457
-- ^ Split off exactly the given number argument types, and panics if that is not possible
458
splitFunTysN 0 ty = ([], ty)
simonpj@microsoft.com's avatar
Assert    
simonpj@microsoft.com committed
459
460
splitFunTysN n ty = ASSERT2( isFunTy ty, int n <+> ppr ty )
                    case splitFunTy ty of { (arg, res) ->
461
462
463
		    case splitFunTysN (n-1) res of { (args, res) ->
		    (arg:args, res) }}

batterseapower's avatar
batterseapower committed
464
465
466
467
468
469
-- | Splits off argument types from the given type and associating
-- them with the things in the input list from left to right. The
-- final result type is returned, along with the resulting pairs of
-- objects and types, albeit with the list of pairs in reverse order.
-- Panics if there are not enough argument types for the input list.
zipFunTys :: Outputable a => [a] -> Type -> ([(a, Type)], Type)
470
471
zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
  where
472
    split acc []     nty _                 = (reverse acc, nty)
473
474
    split acc xs     nty ty 
	  | Just ty' <- coreView ty 	   = split acc xs nty ty'
475
476
    split acc (x:xs) _   (FunTy arg res)   = split ((x,arg):acc) xs res res
    split _   _      _   _                 = pprPanic "zipFunTys" (ppr orig_xs <+> ppr orig_ty)
477
478
    
funResultTy :: Type -> Type
batterseapower's avatar
batterseapower committed
479
-- ^ Extract the function result type and panic if that is not possible
480
funResultTy ty | Just ty' <- coreView ty = funResultTy ty'
481
482
funResultTy (FunTy _arg res)  = res
funResultTy ty                = pprPanic "funResultTy" (ppr ty)
483
484

funArgTy :: Type -> Type
batterseapower's avatar
batterseapower committed
485
-- ^ Extract the function argument type and panic if that is not possible
486
funArgTy ty | Just ty' <- coreView ty = funArgTy ty'
487
488
funArgTy (FunTy arg _res)  = arg
funArgTy ty                = pprPanic "funArgTy" (ppr ty)
489
490
\end{code}

491
492
493
---------------------------------------------------------------------
				TyConApp
				~~~~~~~~
494

495
\begin{code}
496
497
498
499
500
501
502
503
504
505
-- | A key function: builds a 'TyConApp' or 'FunTy' as apppropriate to 
-- its arguments.  Applies its arguments to the constructor from left to right.
mkTyConApp :: TyCon -> [Type] -> Type
mkTyConApp tycon tys
  | isFunTyCon tycon, [ty1,ty2] <- tys
  = FunTy ty1 ty2

  | otherwise
  = TyConApp tycon tys

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

batterseapower's avatar
batterseapower committed
510
-- | The same as @fst . splitTyConApp@
511
512
513
514
515
516
tyConAppTyCon_maybe :: Type -> Maybe TyCon
tyConAppTyCon_maybe ty | Just ty' <- coreView ty = tyConAppTyCon_maybe ty'
tyConAppTyCon_maybe (TyConApp tc _) = Just tc
tyConAppTyCon_maybe (FunTy {})      = Just funTyCon
tyConAppTyCon_maybe _               = Nothing

517
tyConAppTyCon :: Type -> TyCon
518
tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr ty)
519

batterseapower's avatar
batterseapower committed
520
-- | The same as @snd . splitTyConApp@
521
522
523
524
525
526
527
tyConAppArgs_maybe :: Type -> Maybe [Type]
tyConAppArgs_maybe ty | Just ty' <- coreView ty = tyConAppArgs_maybe ty'
tyConAppArgs_maybe (TyConApp _ tys) = Just tys
tyConAppArgs_maybe (FunTy arg res)  = Just [arg,res]
tyConAppArgs_maybe _                = Nothing


528
tyConAppArgs :: Type -> [Type]
529
tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty)
530

531
532
533
534
535
536
537
tyConAppArgN :: Int -> Type -> Type
-- Executing Nth
tyConAppArgN n ty 
  = case tyConAppArgs_maybe ty of
      Just tys -> ASSERT2( n < length tys, ppr n <+> ppr tys ) tys !! n
      Nothing  -> pprPanic "tyConAppArgN" (ppr n <+> ppr ty)

batterseapower's avatar
batterseapower committed
538
539
540
-- | Attempts to tease a type apart into a type constructor and the application
-- of a number of arguments to that constructor. Panics if that is not possible.
-- See also 'splitTyConApp_maybe'
541
542
543
splitTyConApp :: Type -> (TyCon, [Type])
splitTyConApp ty = case splitTyConApp_maybe ty of
			Just stuff -> stuff
544
			Nothing	   -> pprPanic "splitTyConApp" (ppr ty)
545

batterseapower's avatar
batterseapower committed
546
547
-- | Attempts to tease a type apart into a type constructor and the application
-- of a number of arguments to that constructor
548
splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
549
splitTyConApp_maybe ty | Just ty' <- coreView ty = splitTyConApp_maybe ty'
550
splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
551
splitTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [arg,res])
552
splitTyConApp_maybe _                 = Nothing
553

554
newTyConInstRhs :: TyCon -> [Type] -> Type
555
-- ^ Unwrap one 'layer' of newtype on a type constructor and its arguments, using an 
batterseapower's avatar
batterseapower committed
556
-- eta-reduced version of the @newtype@ if possible
557
558
559
560
561
562
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
563
\end{code}
564

565

566
567
568
569
570
571
572
573
---------------------------------------------------------------------
				SynTy
				~~~~~

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

575
576
577
578
579
580
581
582
	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.
583
584


585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
Note [Expanding newtypes]
~~~~~~~~~~~~~~~~~~~~~~~~~
When expanding a type to expose a data-type constructor, we need to be
careful about newtypes, lest we fall into an infinite loop. Here are
the key examples:

  newtype Id  x = MkId x
  newtype Fix f = MkFix (f (Fix f))
  newtype T     = MkT (T -> T) 
  
  Type	         Expansion
 --------------------------
  T		 T -> T
  Fix Maybe      Maybe (Fix Maybe)
  Id (Id Int)    Int
  Fix Id         NO NO NO

Notice that we can expand T, even though it's recursive.
And we can expand Id (Id Int), even though the Id shows up
twice at the outer level.  

So, when expanding, we keep track of when we've seen a recursive
newtype at outermost level; and bale out if we see it again.


610
611
		Representation types
		~~~~~~~~~~~~~~~~~~~~
612

613
614
Note [Nullary unboxed tuple]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
615
616
617
618
619
620
621
622
We represent the nullary unboxed tuple as the unary (but void) type
State# RealWorld.  The reason for this is that the ReprArity is never
less than the Arity (as it would otherwise be for a function type like
(# #) -> Int).

As a result, ReprArity is always strictly positive if Arity is. This
is important because it allows us to distinguish at runtime between a
thunk and a function takes a nullary unboxed tuple as an argument!
623

624
\begin{code}
625
626
627
628
629
630
631
632
633
type UnaryType = Type

data RepType = UbxTupleRep [UnaryType] -- INVARIANT: never an empty list (see Note [Nullary unboxed tuple])
             | UnaryRep UnaryType

flattenRepType :: RepType -> [UnaryType]
flattenRepType (UbxTupleRep tys) = tys
flattenRepType (UnaryRep ty)     = [ty]

batterseapower's avatar
batterseapower committed
634
635
636
637
638
-- | Looks through:
--
--	1. For-alls
--	2. Synonyms
--	3. Predicates
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
639
--	4. All newtypes, including recursive ones, but not newtype families
batterseapower's avatar
batterseapower committed
640
641
--
-- It's useful in the back end of the compiler.
642
repType :: Type -> RepType
643
repType ty
Simon Peyton Jones's avatar
Simon Peyton Jones committed
644
  = go emptyNameSet ty
645
  where
646
    go :: NameSet -> Type -> RepType
Simon Peyton Jones's avatar
Simon Peyton Jones committed
647
648
649
    go rec_nts ty    	  		-- Expand predicates and synonyms
      | Just ty' <- coreView ty
      = go rec_nts ty'
650

Simon Peyton Jones's avatar
Simon Peyton Jones committed
651
652
    go rec_nts (ForAllTy _ ty)		-- Drop foralls
	= go rec_nts ty
653

Simon Peyton Jones's avatar
Simon Peyton Jones committed
654
    go rec_nts (TyConApp tc tys)	-- Expand newtypes
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
655
656
      | Just (rec_nts', ty') <- carefullySplitNewType_maybe rec_nts tc tys
      = go rec_nts' ty'
657

658
659
660
661
      | isUnboxedTupleTyCon tc
      = if null tys
         then UnaryRep realWorldStatePrimTy -- See Note [Nullary unboxed tuple]
         else UbxTupleRep (concatMap (flattenRepType . go rec_nts) tys)
662

663
    go _ ty = UnaryRep ty
664

Simon Peyton Jones's avatar
Simon Peyton Jones committed
665
carefullySplitNewType_maybe :: NameSet -> TyCon -> [Type] -> Maybe (NameSet,Type)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
666
667
-- Return the representation of a newtype, unless 
-- we've seen it already: see Note [Expanding newtypes]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
668
-- Assumes the newtype is saturated
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
669
670
carefullySplitNewType_maybe rec_nts tc tys
  | isNewTyCon tc
Simon Peyton Jones's avatar
Simon Peyton Jones committed
671
672
673
  , tys `lengthAtLeast` tyConArity tc
  , not (tc_name `elemNameSet` rec_nts) = Just (rec_nts', newTyConInstRhs tc tys)
  | otherwise	   	                = Nothing
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
674
  where
Simon Peyton Jones's avatar
Simon Peyton Jones committed
675
676
    tc_name = tyConName tc
    rec_nts' | isRecursiveTyCon tc = addOneToNameSet rec_nts tc_name
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
677
678
679
	     | otherwise	   = rec_nts


680
681
-- ToDo: this could be moved to the code generator, using splitTyConApp instead
-- of inspecting the type directly.
batterseapower's avatar
batterseapower committed
682

683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
-- | Discovers the primitive representation of a more abstract 'UnaryType'
typePrimRep :: UnaryType -> PrimRep
typePrimRep ty
  = case repType ty of
      UbxTupleRep _ -> pprPanic "typePrimRep: UbxTupleRep" (ppr ty)
      UnaryRep rep -> case rep of
        TyConApp tc _ -> tyConPrimRep tc
        FunTy _ _     -> PtrRep
        AppTy _ _     -> PtrRep      -- See Note [AppTy rep] 
        TyVarTy _     -> PtrRep
        _             -> pprPanic "typePrimRep: UnaryRep" (ppr ty)

typeRepArity :: Arity -> Type -> RepArity
typeRepArity 0 _ = 0
typeRepArity n ty = case repType ty of
  UnaryRep (FunTy ty1 ty2) -> length (flattenRepType (repType ty1)) + typeRepArity (n - 1) ty2
  _                        -> pprPanic "typeRepArity: arity greater than type can handle" (ppr (n, ty))
700
701
\end{code}

702
703
704
705
706
707
Note [AppTy rep]
~~~~~~~~~~~~~~~~
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 (kk -> kk) and kk cannot be unlifted; see Note [The kind invariant] 
in TypeRep.
708

709
710
711
---------------------------------------------------------------------
				ForAllTy
				~~~~~~~~
712
713

\begin{code}
714
mkForAllTy :: TyVar -> Type -> Type
715
mkForAllTy tyvar ty
716
  = ForAllTy tyvar ty
717

batterseapower's avatar
batterseapower committed
718
-- | Wraps foralls over the type using the provided 'TyVar's from left to right
719
mkForAllTys :: [TyVar] -> Type -> Type
720
mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
721

722
723
mkPiKinds :: [TyVar] -> Kind -> Kind
-- mkPiKinds [k1, k2, (a:k1 -> *)] k2
dreixel's avatar
dreixel committed
724
-- returns forall k1 k2. (k1 -> *) -> k2
725
726
mkPiKinds [] res = res
mkPiKinds (tv:tvs) res 
727
728
  | isKindVar tv = ForAllTy tv          (mkPiKinds tvs res)
  | otherwise    = FunTy (tyVarKind tv) (mkPiKinds tvs res)
729
730
731
732
733
734
735
736
737
738
739
740

mkPiType  :: Var -> Type -> Type
-- ^ Makes a @(->)@ type or a forall type, depending
-- on whether it is given a type variable or a term variable.
mkPiTypes :: [Var] -> Type -> Type
-- ^ 'mkPiType' for multiple type or value arguments

mkPiType v ty
   | isId v    = mkFunTy (varType v) ty
   | otherwise = mkForAllTy v ty

mkPiTypes vs ty = foldr mkPiType ty vs
dreixel's avatar
dreixel committed
741

742
743
isForAllTy :: Type -> Bool
isForAllTy (ForAllTy _ _) = True
744
isForAllTy _              = False
745

batterseapower's avatar
batterseapower committed
746
747
-- | Attempts to take a forall type apart, returning the bound type variable
-- and the remainder of the type
748
splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
749
splitForAllTy_maybe ty = splitFAT_m ty
750
  where
751
752
753
    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
754

batterseapower's avatar
batterseapower committed
755
756
757
-- | Attempts to take a forall type apart, returning all the immediate such bound
-- type variables and the remainder of the type. Always suceeds, even if that means
-- returning an empty list of 'TyVar's
758
splitForAllTys :: Type -> ([TyVar], Type)
759
splitForAllTys ty = split ty ty []
760
   where
761
     split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs
762
763
     split _       (ForAllTy tv ty)  tvs = split ty ty (tv:tvs)
     split orig_ty _                 tvs = (reverse tvs, orig_ty)
764

batterseapower's avatar
batterseapower committed
765
-- | Equivalent to @snd . splitForAllTys@
766
767
dropForAlls :: Type -> Type
dropForAlls ty = snd (splitForAllTys ty)
768
769
\end{code}

770
-- (mkPiType now in CoreUtils)
771

772
773
applyTy, applyTys
~~~~~~~~~~~~~~~~~
774

775
\begin{code}
batterseapower's avatar
batterseapower committed
776
777
778
779
780
781
782
-- | Instantiate a forall type with one or more type arguments.
-- Used when we have a polymorphic function applied to type args:
--
-- > f t1 t2
--
-- We use @applyTys type-of-f [t1,t2]@ to compute the type of the expression.
-- Panics if no application is possible.
dreixel's avatar
dreixel committed
783
applyTy :: Type -> KindOrType -> Type
784
785
applyTy ty arg | Just ty' <- coreView ty = applyTy ty' arg
applyTy (ForAllTy tv ty) arg = substTyWith [tv] [arg] ty
786
applyTy _                _   = panic "applyTy"
787

dreixel's avatar
dreixel committed
788
applyTys :: Type -> [KindOrType] -> Type
batterseapower's avatar
batterseapower committed
789
790
791
792
793
794
795
796
797
798
-- ^ This function is interesting because:
--
--	1. The function may have more for-alls than there are args
--
--	2. Less obviously, it may have fewer for-alls
--
-- For case 2. think of:
--
-- > applyTys (forall a.a) [forall b.b, Int]
--
dreixel's avatar
dreixel committed
799
800
801
802
803
804
-- This really can happen, but only (I think) in situations involving
-- undefined.  For example:
--       undefined :: forall a. a
-- Term: undefined @(forall b. b->b) @Int 
-- This term should have type (Int -> Int), but notice that
-- there are more type args than foralls in 'undefined's type.
805

806
807
808
809
810
applyTys ty args = applyTysD empty ty args

applyTysD :: SDoc -> Type -> [Type] -> Type	-- Debug version
applyTysD _   orig_fun_ty []      = orig_fun_ty
applyTysD doc orig_fun_ty arg_tys 
811
812
813
814
815
816
  | 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
817
  = ASSERT2( n_tvs > 0, doc $$ ppr orig_fun_ty )	-- Zero case gives infnite loop!
818
819
    applyTysD doc (substTyWith tvs (take n_tvs arg_tys) rho_ty)
	          (drop n_tvs arg_tys)
820
821
822
823
  where
    (tvs, rho_ty) = splitForAllTys orig_fun_ty 
    n_tvs = length tvs
    n_args = length arg_tys     
824
\end{code}
825

826

827
828
%************************************************************************
%*									*
829
                         Pred
830
831
%*									*
%************************************************************************
832

batterseapower's avatar
batterseapower committed
833
Predicates on PredType
834

835
\begin{code}
batterseapower's avatar
batterseapower committed
836
837
838
839
840
noParenPred :: PredType -> Bool
-- A predicate that can appear without parens before a "=>"
--       C a => a -> a
--       a~b => a -> b
-- But   (?x::Int) => Int -> Int
841
noParenPred p = not (isIPPred p) && isClassPred p || isEqPred p
batterseapower's avatar
batterseapower committed
842

843
isPredTy :: Type -> Bool
dreixel's avatar
dreixel committed
844
845
846
847
848
849
isPredTy ty
  | isSuperKind ty = False
  | otherwise = typeKind ty `eqKind` constraintKind

isKindTy :: Type -> Bool
isKindTy = isSuperKind . typeKind
850

batterseapower's avatar
batterseapower committed
851
852
853
854
855
856
857
isClassPred, isEqPred, isIPPred :: PredType -> Bool
isClassPred ty = case tyConAppTyCon_maybe ty of
    Just tyCon | isClassTyCon tyCon -> True
    _                               -> False
isEqPred ty = case tyConAppTyCon_maybe ty of
    Just tyCon -> tyCon `hasKey` eqTyConKey
    _          -> False
858

batterseapower's avatar
batterseapower committed
859
isIPPred ty = case tyConAppTyCon_maybe ty of
860
861
862
863
864
865
866
867
868
    Just tyCon -> tyConName tyCon == ipClassName
    _          -> False

isIPPred_maybe :: Type -> Maybe (FastString, Type)
isIPPred_maybe ty =
  do (tc,[t1,t2]) <- splitTyConApp_maybe ty
     guard (tyConName tc == ipClassName)
     x <- isStrLitTy t1
     return (x,t2)
869
870
871
\end{code}

Make PredTypes
872

873
874
875
--------------------- Equality types ---------------------------------
\begin{code}
-- | Creates a type equality predicate
876
877
878
mkEqPred :: Type -> Type -> PredType
mkEqPred ty1 ty2
  = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 )
dreixel's avatar
dreixel committed
879
    TyConApp eqTyCon [k, ty1, ty2]
880
881
  where 
    k = typeKind ty1
batterseapower's avatar
batterseapower committed
882

883
884
885
mkPrimEqPred :: Type -> Type -> Type
mkPrimEqPred ty1  ty2
  = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 )
dreixel's avatar
dreixel committed
886
    TyConApp eqPrimTyCon [k, ty1, ty2]
887
888
  where 
    k = typeKind ty1
889
\end{code}
890

891
--------------------- Dictionary types ---------------------------------
892
\begin{code}
893
mkClassPred :: Class -> [Type] -> PredType
batterseapower's avatar
batterseapower committed
894
mkClassPred clas tys = TyConApp (classTyCon clas) tys
895

896
isDictTy :: Type -> Bool
batterseapower's avatar
batterseapower committed
897
isDictTy = isClassPred
898

899
900
isDictLikeTy :: Type -> Bool
-- Note [Dictionary-like types]
901
902
903
904
905
isDictLikeTy ty | Just ty' <- coreView ty = isDictLikeTy ty'
isDictLikeTy ty = case splitTyConApp_maybe ty of
	Just (tc, tys) | isClassTyCon tc -> True
	 			   | isTupleTyCon tc -> all isDictLikeTy tys
	_other                           -> False
906
\end{code}
907

908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
Note [Dictionary-like types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Being "dictionary-like" means either a dictionary type or a tuple thereof.
In GHC 6.10 we build implication constraints which construct such tuples,
and if we land up with a binding
    t :: (C [a], Eq [a])
    t = blah
then we want to treat t as cheap under "-fdicts-cheap" for example.
(Implication constraints are normally inlined, but sadly not if the
occurrence is itself inside an INLINE function!  Until we revise the 
handling of implication constraints, that is.)  This turned out to
be important in getting good arities in DPH code.  Example:

    class C a
    class D a where { foo :: a -> a }
    instance C a => D (Maybe a) where { foo x = x }

    bar :: (C a, C b) => a -> b -> (Maybe a, Maybe b)
    {-# INLINE bar #-}
    bar x y = (foo (Just x), foo (Just y))

Then 'bar' should jolly well have arity 4 (two dicts, two args), but
we ended up with something like
   bar = __inline_me__ (\d1,d2. let t :: (D (Maybe a), D (Maybe b)) = ...
                                in \x,y. <blah>)

This is all a bit ad-hoc; eg it relies on knowing that implication
constraints build tuples.

batterseapower's avatar
batterseapower committed
937
938
939
940
941
942

Decomposing PredType

\begin{code}
data PredTree = ClassPred Class [Type]
              | EqPred Type Type
943
              | TuplePred [PredType]
batterseapower's avatar
batterseapower committed
944
945
946
947
              | IrredPred PredType

predTreePredType :: PredTree -> PredType
predTreePredType (ClassPred clas tys) = mkClassPred clas tys
948
predTreePredType (EqPred ty1 ty2)     = mkEqPred ty1 ty2
949
predTreePredType (TuplePred tys)      = mkBoxedTupleTy tys
batterseapower's avatar
batterseapower committed
950
951
predTreePredType (IrredPred ty)       = ty

952
953
classifyPredType :: PredType -> PredTree
classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of
batterseapower's avatar
batterseapower committed
954
955
956
    Just (tc, tys) | Just clas <- tyConClass_maybe tc
                   -> ClassPred clas tys
    Just (tc, tys) | tc `hasKey` eqTyConKey
dreixel's avatar
dreixel committed
957
                   , let [_, ty1, ty2] = tys
batterseapower's avatar
batterseapower committed
958
959
                   -> EqPred ty1 ty2
    Just (tc, tys) | isTupleTyCon tc
960
                   -> TuplePred tys
batterseapower's avatar
batterseapower committed
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
    _ -> IrredPred ev_ty
\end{code}

\begin{code}
getClassPredTys :: PredType -> (Class, [Type])
getClassPredTys ty = case getClassPredTys_maybe ty of
        Just (clas, tys) -> (clas, tys)
        Nothing          -> pprPanic "getClassPredTys" (ppr ty)

getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])
getClassPredTys_maybe ty = case splitTyConApp_maybe ty of 
        Just (tc, tys) | Just clas <- tyConClass_maybe tc -> Just (clas, tys)
        _ -> Nothing

getEqPredTys :: PredType -> (Type, Type)
976
977
978
979
980
getEqPredTys ty 
  = case splitTyConApp_maybe ty of 
      Just (tc, (_ : ty1 : ty2 : tys)) -> ASSERT( tc `hasKey` eqTyConKey && null tys )
                                          (ty1, ty2)
      _ -> pprPanic "getEqPredTys" (ppr ty)
batterseapower's avatar
batterseapower committed
981
982

getEqPredTys_maybe :: PredType -> Maybe (Type, Type)
983
984
985
986
getEqPredTys_maybe ty 
  = case splitTyConApp_maybe ty of 
      Just (tc, [_, ty1, ty2]) | tc `hasKey` eqTyConKey -> Just (ty1, ty2)
      _ -> Nothing
batterseapower's avatar
batterseapower committed
987
988
\end{code}

989
990
991
992
993
994
995
996
%************************************************************************
%*									*
                   Size									
%*									*
%************************************************************************

\begin{code}
typeSize :: Type -> Int
997
998
typeSize (LitTy {})      = 1
typeSize (TyVarTy {})    = 1
999
1000
1001
1002
typeSize (AppTy t1 t2)   = typeSize t1 + typeSize t2
typeSize (FunTy t1 t2)   = typeSize t1 + typeSize t2
typeSize (ForAllTy _ t)  = 1 + typeSize t
typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts)
dreixel's avatar
dreixel committed
1003
1004
1005

varSetElemsKvsFirst :: VarSet -> [TyVar]
-- {k1,a,k2,b} --> [k1,k2,a,b]
1006
1007
varSetElemsKvsFirst set 
  = kvs ++ tvs
dreixel's avatar
dreixel committed
1008
  where
1009
    (kvs, tvs) = partition isKindVar (varSetElems set)
1010
1011
1012
\end{code}


1013
1014
1015
1016
1017
1018
1019
%************************************************************************
%*									*
\subsection{Type families}
%*									*
%************************************************************************

\begin{code}
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
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
--
-- Where the instance tycon is :RTL, so:
--
-- > 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

-- | Pretty prints a 'TyCon', using the family instance in case of a
-- representation tycon.  For example:
--
-- > data T [a] = ...
--
-- In that case we want to print @T [a]@, where @T@ is the family 'TyCon'
pprSourceTyCon :: TyCon -> SDoc
pprSourceTyCon tycon 
  | Just (fam_tc, tys) <- tyConFamInst_maybe tycon
  = ppr $ fam_tc `TyConApp` tys	       -- can't be FunTyCon
  | otherwise
  = ppr tycon
\end{code}
1050

1051
1052
%************************************************************************
%*									*
1053
\subsection{Liftedness}
1054
1055
1056
%*									*
%************************************************************************

1057
\begin{code}
batterseapower's avatar
batterseapower committed
1058
-- | See "Type#type_classification" for what an unlifted type is
1059
isUnLiftedType :: Type -> Bool
1060
1061
1062
1063
1064
1065
	-- 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

1066
isUnLiftedType ty | Just ty' <- coreView ty = isUnLiftedType ty'
1067
1068
1069
isUnLiftedType (ForAllTy _ ty)      = isUnLiftedType ty
isUnLiftedType (TyConApp tc _)      = isUnLiftedTyCon tc
isUnLiftedType _                    = False
1070

1071
isUnboxedTupleType :: Type -> Bool
1072
1073
1074
isUnboxedTupleType ty = case tyConAppTyCon_maybe ty of
                           Just tc -> isUnboxedTupleTyCon tc
                           _       -> False
1075

batterseapower's avatar
batterseapower committed
1076
1077
1078
-- | See "Type#type_classification" for what an algebraic type is.
-- Should only be applied to /types/, as opposed to e.g. partially
-- saturated type constructors
1079
isAlgType :: Type -> Bool
1080
1081
1082
1083
1084
1085
isAlgType ty 
  = case splitTyConApp_maybe ty of
      Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
			    isAlgTyCon tc
      _other	         -> False

batterseapower's avatar
batterseapower committed
1086
1087
1088
1089
-- | See "Type#type_classification" for what an algebraic type is.
-- Should only be applied to /types/, as opposed to e.g. partially
-- saturated type constructors. Closed type constructors are those
-- with a fixed right hand side, as opposed to e.g. associated types
1090
1091
1092
isClosedAlgType :: Type -> Bool
isClosedAlgType ty
  = case splitTyConApp_maybe ty of