TcType.lhs 28.2 KB
Newer Older
1

2
3
4
5
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcType]{Types used in the typechecker}

6
7
This module provides the Type interface for front-end parts of the 
compiler.  These parts 
8

9
10
11
	* treat "source types" as opaque: 
		newtypes, and predicates are meaningful. 
	* look through usage types
12

13
14
The "tc" prefix is for "typechechecker", because the type checker
is the principal client.
15

16
17
\begin{code}
module TcType (
18
  --------------------------------
19
  -- Types 
20
  TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, 
21
  TcTyVar, TcTyVarSet, TcKind, 
22
23

  --------------------------------
24
25
26
  -- MetaDetails
  TcTyVarDetails(..),
  MetaDetails(Flexi, Indirect), SkolemInfo(..), pprSkolemTyVar,
27
  isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isExistentialTyVar, skolemTvInfo, metaTvRef,
28
  isFlexi, isIndirect,
29
30

  --------------------------------
31
  -- Builders
32
  mkPhiTy, mkSigmaTy, 
33

34
35
36
  --------------------------------
  -- Splitters  
  -- These are important because they do not look through newtypes
37
  tcSplitForAllTys, tcSplitPhiTy, 
38
39
  tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy,
  tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs,
40
  tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcSplitSigmaTy,
41
  tcGetTyVar_maybe, tcGetTyVar,
42
43
44
45

  ---------------------------------
  -- Predicates. 
  -- Again, newtypes are opaque
46
  tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred, tcEqTypeX,
47
  isSigmaTy, isOverloadedTy, 
48
  isDoubleTy, isFloatTy, isIntTy,
49
  isIntegerTy, isAddrTy, isBoolTy, isUnitTy,
50
51
52
53
  isTauTy, tcIsTyVarTy, tcIsForAllTy,

  ---------------------------------
  -- Misc type manipulators
54
  deNoteType, classesOfTheta,
55
  tyClsNamesOfType, tyClsNamesOfDFunHead, 
56
57
58
59
  getDFunTyKey,

  ---------------------------------
  -- Predicate types  
60
  getClassPredTys_maybe, getClassPredTys, 
61
  isClassPred, isTyVarClassPred, 
62
  mkDictTy, tcSplitPredTy_maybe, 
63
  isPredTy, isDictTy, tcSplitDFunTy, predTyUnique, 
64
  mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName, 
65

66
67
68
69
70
71
72
73
74
  ---------------------------------
  -- Foreign import and export
  isFFIArgumentTy,     -- :: DynFlags -> Safety -> Type -> Bool
  isFFIImportResultTy, -- :: DynFlags -> Type -> Bool
  isFFIExportResultTy, -- :: Type -> Bool
  isFFIExternalTy,     -- :: Type -> Bool
  isFFIDynArgumentTy,  -- :: Type -> Bool
  isFFIDynResultTy,    -- :: Type -> Bool
  isFFILabelTy,        -- :: Type -> Bool
sof's avatar
sof committed
75
76
  isFFIDotnetTy,       -- :: DynFlags -> Type -> Bool
  isFFIDotnetObjTy,    -- :: Type -> Bool
77
  isFFITy,	       -- :: Type -> Bool
sof's avatar
sof committed
78
79
  
  toDNType,            -- :: Type -> DNType
80

81
82
  --------------------------------
  -- Rexported from Type
83
84
  Kind, 	-- Stuff to do with kinds is insensitive to pre/post Tc
  unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, 
85
  isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, 
86
  isArgTypeKind, isSubKind, defaultKind, 
87

88
  Type, PredType(..), ThetaType, 
89
90
  mkForAllTy, mkForAllTys, 
  mkFunTy, mkFunTys, zipFunTys, 
91
  mkTyConApp, mkGenTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
92
  mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys, 
93

94
95
96
97
98
99
  -- Type substitutions
  TvSubst(..), 	-- Representation visible to a few friends
  TvSubstEnv, emptyTvSubst,
  mkTvSubst, zipTvSubst, zipTopTvSubst, mkTopTvSubst,
  getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
  extendTvSubst, extendTvSubstList, isInScope,
100
  substTy, substTys, substTyWith, substTheta, substTyVar, substTyVarBndr,
101

102
103
  isUnLiftedType,	-- Source types are always lifted
  isUnboxedTupleType,	-- Ditto
104
  isPrimitiveType, 
105

106
  tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
107
  tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars,
108
  typeKind, 
109

110
  tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
111

112
  pprKind, pprParendKind,
113
  pprType, pprParendType, pprTyThingCategory,
114
  pprPred, pprTheta, pprThetaArrow, pprClassPred
115

116
  ) where
117

118
#include "HsVersions.h"
119

120
-- friends:
121
122
123
import TypeRep		( Type(..), TyNote(..), funTyCon )  -- friend

import Type		(	-- Re-exports
124
			  tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
125
			  tyVarsOfTheta, Kind, PredType(..),
126
			  ThetaType, unliftedTypeKind, 
127
			  liftedTypeKind, openTypeKind, mkArrowKind,
128
		  	  isLiftedTypeKind, isUnliftedTypeKind, 
129
			  mkArrowKinds, mkForAllTy, mkForAllTys,
130
			  defaultKind, isArgTypeKind, isOpenTypeKind,
131
			  mkFunTy, mkFunTys, zipFunTys, 
132
133
134
			  mkTyConApp, mkGenTyConApp, mkAppTy,
			  mkAppTys, mkSynTy, applyTy, applyTys,
			  mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy,
135
			  mkPredTys, isUnLiftedType, 
136
			  isUnboxedTupleType, isPrimitiveType,
137
			  splitTyConApp_maybe,
138
139
140
			  tidyTopType, tidyType, tidyPred, tidyTypes,
			  tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
			  tidyTyVarBndr, tidyOpenTyVar,
141
142
			  tidyOpenTyVars, 
			  isSubKind, 
143
144
145
146

			  tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, 
			  tcEqPred, tcCmpPred, tcEqTypeX, 

147
148
149
150
151
			  TvSubst(..),
			  TvSubstEnv, emptyTvSubst,
			  mkTvSubst, zipTvSubst, zipTopTvSubst, mkTopTvSubst,
			  getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
			  extendTvSubst, extendTvSubstList, isInScope,
152
		  	  substTy, substTys, substTyWith, substTheta, substTyVar, substTyVarBndr,
153

154
			  typeKind, repType,
155
			  pprKind, pprParendKind,
156
			  pprType, pprParendType, pprTyThingCategory,
157
			  pprPred, pprTheta, pprThetaArrow, pprClassPred
158
			)
159
import TyCon		( TyCon, isUnLiftedTyCon, tyConUnique )
160
import DataCon		( DataCon )
161
import Class		( Class )
162
import Var		( TyVar, Id, isTcTyVar, tcTyVarDetails )
163
import ForeignCall	( Safety, playSafe, DNType(..) )
164
import VarSet
165
166

-- others:
167
import CmdLineOpts	( DynFlags, DynFlag( Opt_GlasgowExts ), dopt )
168
import Name		( Name, NamedThing(..), mkInternalName, getSrcLoc )
169
import NameSet
170
import OccName		( OccName, mkDictOcc )
171
import PrelNames	-- Lots (e.g. in isFFIArgumentTy)
172
import TysWiredIn	( unitTyCon, charTyCon, listTyCon )
173
import BasicTypes	( IPName(..), ipNameName )
174
import SrcLoc		( SrcLoc, SrcSpan )
175
import Util		( snocView )
176
import Maybes		( maybeToBool, expectJust )
177
import Outputable
178
import DATA_IOREF
179
180
181
\end{code}


182
183
%************************************************************************
%*									*
184
185
186
187
\subsection{Types}
%*									*
%************************************************************************

188
189
190
The type checker divides the generic Type world into the 
following more structured beasts:

191
sigma ::= forall tyvars. phi
192
193
194
195
196
197
198
199
200
201
	-- A sigma type is a qualified type
	--
	-- Note that even if 'tyvars' is empty, theta
	-- may not be: e.g.   (?x::Int) => Int

	-- Note that 'sigma' is in prenex form:
	-- all the foralls are at the front.
	-- A 'phi' type has no foralls to the right of
	-- an arrow

202
203
204
phi :: theta => rho

rho ::= sigma -> rho
205
206
207
208
209
210
211
212
213
214
215
216
     |  tau

-- A 'tau' type has no quantification anywhere
-- Note that the args of a type constructor must be taus
tau ::= tyvar
     |  tycon tau_1 .. tau_n
     |  tau_1 tau_2
     |  tau_1 -> tau_2

-- In all cases, a (saturated) type synonym application is legal,
-- provided it expands to the required form.

217
218
219
220
221
222
223
224
225
\begin{code}
type TcType = Type 		-- A TcType can have mutable type variables
	-- Invariant on ForAllTy in TcTypes:
	-- 	forall a. T
	-- a cannot occur inside a MutTyVar in T; that is,
	-- T is "flattened" before quantifying over a

type TcPredType     = PredType
type TcThetaType    = ThetaType
226
type TcSigmaType    = TcType
227
type TcRhoType      = TcType
228
type TcTauType      = TcType
229
type TcKind         = Kind
230
type TcTyVarSet     = TyVarSet
231
232
233
234
235
236
\end{code}


%************************************************************************
%*									*
\subsection{TyVarDetails}
237
238
239
%*									*
%************************************************************************

240
241
TyVarDetails gives extra info about type variables, used during type
checking.  It's attached to mutable type variables only.
242
243
It's knot-tied back to Var.lhs.  There is no reason in principle
why Var.lhs shouldn't actually have the definition, but it "belongs" here.
244

245
\begin{code}
246
247
type TcTyVar = TyVar  	-- Used only during type inference

248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
-- A TyVarDetails is inside a TyVar
data TcTyVarDetails
  = SkolemTv SkolemInfo		-- A skolem constant
  | MetaTv (IORef MetaDetails)	-- A meta type variable stands for a tau-type

data SkolemInfo
  = SigSkol Name	-- Bound at a type signature
  | ClsSkol Class	-- Bound at a class decl
  | InstSkol Id		-- Bound at an instance decl
  | PatSkol DataCon	-- An existential type variable bound by a pattern for
	    SrcSpan	-- a data constructor with an existential type. E.g.
			--	data T = forall a. Eq a => MkT a
			-- 	f (MkT x) = ...
			-- The pattern MkT x will allocate an existential type
			-- variable for 'a'.  
  | ArrowSkol SrcSpan	-- An arrow form (see TcArrows)

  | GenSkol TcType	-- Bound when doing a subsumption check for this type
	    SrcSpan

data MetaDetails
  = Flexi          -- Flexi type variables unify to become 
                   -- Indirects.  

  | Indirect TcType  -- Type indirections, treated as wobbly 
                     -- for the purpose of GADT unification.

pprSkolemTyVar :: TcTyVar -> SDoc
pprSkolemTyVar tv
  = ASSERT( isSkolemTyVar tv )
    quotes (ppr tv) <+> ptext SLIT("is bound by") <+> ppr (skolemTvInfo tv)

instance Outputable SkolemInfo where
  ppr (SigSkol id)  = ptext SLIT("the type signature for") <+> quotes (ppr id)
  ppr (ClsSkol cls) = ptext SLIT("the class declaration for") <+> quotes (ppr cls)
  ppr (InstSkol df) = ptext SLIT("the instance declaration at") <+> ppr (getSrcLoc df)
  ppr (ArrowSkol loc)  = ptext SLIT("the arrow form at") <+> ppr loc
  ppr (PatSkol dc loc) = sep [ptext SLIT("the pattern for") <+> quotes (ppr dc),
	       		    nest 2 (ptext SLIT("at") <+> ppr loc)]
  ppr (GenSkol ty loc) = sep [ptext SLIT("the polymorphic type") <+> quotes (ppr ty),
			    nest 2 (ptext SLIT("at") <+> ppr loc)]

instance Outputable MetaDetails where
  ppr Flexi 	    = ptext SLIT("Flexi")
  ppr (Indirect ty) = ptext SLIT("Indirect") <+> ppr ty

294
isImmutableTyVar, isSkolemTyVar, isExistentialTyVar, isMetaTyVar :: TyVar -> Bool
295
296
297
298
299
300
301
302
303
304
isImmutableTyVar tv
  | isTcTyVar tv = isSkolemTyVar tv
  | otherwise    = True

isSkolemTyVar tv 
  = ASSERT( isTcTyVar tv )
    case tcTyVarDetails tv of
	SkolemTv _ -> True
	MetaTv _   -> False

305
306
307
308
309
310
isExistentialTyVar tv 	-- Existential type variable, bound by a pattern
  = ASSERT( isTcTyVar tv )
    case tcTyVarDetails tv of
	SkolemTv (PatSkol _ _) -> True
	other 		       -> False

311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
isMetaTyVar tv 
  = ASSERT( isTcTyVar tv )
    case tcTyVarDetails tv of
	SkolemTv _ -> False
	MetaTv _   -> True

skolemTvInfo :: TyVar -> SkolemInfo
skolemTvInfo tv 
  = ASSERT( isTcTyVar tv )
    case tcTyVarDetails tv of
	SkolemTv info -> info

metaTvRef :: TyVar -> IORef MetaDetails
metaTvRef tv 
  = ASSERT( isTcTyVar tv )
    case tcTyVarDetails tv of
	 MetaTv ref -> ref

isFlexi, isIndirect :: MetaDetails -> Bool
isFlexi Flexi = True
isFlexi other = False

isIndirect (Indirect _) = True
isIndirect other        = False
335
\end{code}
336

337
338
339
340
341
342
343
344

%************************************************************************
%*									*
\subsection{Tau, sigma and rho}
%*									*
%************************************************************************

\begin{code}
345
mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau)
sof's avatar
sof committed
346

347
mkPhiTy :: [PredType] -> Type -> Type
348
mkPhiTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta
349
350
351
\end{code}

@isTauTy@ tests for nested for-alls.
sof's avatar
sof committed
352

353
\begin{code}
354
355
356
357
358
isTauTy :: Type -> Bool
isTauTy (TyVarTy v)	 = True
isTauTy (TyConApp _ tys) = all isTauTy tys
isTauTy (AppTy a b)	 = isTauTy a && isTauTy b
isTauTy (FunTy a b)	 = isTauTy a && isTauTy b
359
isTauTy (PredTy p)	 = True		-- Don't look through source types
360
361
362
363
364
365
366
isTauTy (NoteTy _ ty)	 = isTauTy ty
isTauTy other		 = False
\end{code}

\begin{code}
getDFunTyKey :: Type -> OccName	-- Get some string from a type, to be used to 
				-- construct a dictionary function name
367
368
369
370
371
372
373
374
getDFunTyKey (TyVarTy tv)    = getOccName tv
getDFunTyKey (TyConApp tc _) = getOccName tc
getDFunTyKey (AppTy fun _)   = getDFunTyKey fun
getDFunTyKey (NoteTy _ t)    = getDFunTyKey t
getDFunTyKey (FunTy arg _)   = getOccName funTyCon
getDFunTyKey (ForAllTy _ t)  = getDFunTyKey t
getDFunTyKey ty		     = pprPanic "getDFunTyKey" (pprType ty)
-- PredTy shouldn't happen
sof's avatar
sof committed
375
376
377
\end{code}


378
379
%************************************************************************
%*									*
380
\subsection{Expanding and splitting}
381
382
%*									*
%************************************************************************
383

384
385
386
387
388
389
390
391
These tcSplit functions are like their non-Tc analogues, but
	a) they do not look through newtypes
	b) they do not look through PredTys
	c) [future] they ignore usage-type annotations

However, they are non-monadic and do not follow through mutable type
variables.  It's up to you to make sure this doesn't matter.

392
\begin{code}
393
394
395
396
397
398
399
400
401
402
403
tcSplitForAllTys :: Type -> ([TyVar], Type)
tcSplitForAllTys ty = split ty ty []
   where
     split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
     split orig_ty (NoteTy n  ty)   tvs = split orig_ty ty tvs
     split orig_ty t		    tvs = (reverse tvs, orig_ty)

tcIsForAllTy (ForAllTy tv ty) = True
tcIsForAllTy (NoteTy n ty)    = tcIsForAllTy ty
tcIsForAllTy t		      = False

404
405
tcSplitPhiTy :: Type -> ([PredType], Type)
tcSplitPhiTy ty = split ty ty []
406
407
408
409
410
411
412
413
 where
  split orig_ty (FunTy arg res) ts = case tcSplitPredTy_maybe arg of
					Just p  -> split res res (p:ts)
					Nothing -> (reverse ts, orig_ty)
  split orig_ty (NoteTy n ty)	ts = split orig_ty ty ts
  split orig_ty ty		ts = (reverse ts, orig_ty)

tcSplitSigmaTy ty = case tcSplitForAllTys ty of
414
			(tvs, rho) -> case tcSplitPhiTy rho of
415
416
417
418
419
420
421
422
423
424
425
426
427
428
					(theta, tau) -> (tvs, theta, tau)

tcTyConAppTyCon :: Type -> TyCon
tcTyConAppTyCon ty = fst (tcSplitTyConApp ty)

tcTyConAppArgs :: Type -> [Type]
tcTyConAppArgs ty = snd (tcSplitTyConApp ty)

tcSplitTyConApp :: Type -> (TyCon, [Type])
tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of
			Just stuff -> stuff
			Nothing	   -> pprPanic "tcSplitTyConApp" (pprType ty)

tcSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
429
430
431
tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
tcSplitTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [arg,res])
tcSplitTyConApp_maybe (NoteTy n ty)     = tcSplitTyConApp_maybe ty
432
	-- Newtypes are opaque, so they may be split
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
	-- However, predicates are not treated
	-- as tycon applications by the type checker
tcSplitTyConApp_maybe other	        	= Nothing

tcSplitFunTys :: Type -> ([Type], Type)
tcSplitFunTys ty = case tcSplitFunTy_maybe ty of
			Nothing	       -> ([], ty)
			Just (arg,res) -> (arg:args, res')
				       where
					  (args,res') = tcSplitFunTys res

tcSplitFunTy_maybe :: Type -> Maybe (Type, Type)
tcSplitFunTy_maybe (FunTy arg res)  = Just (arg, res)
tcSplitFunTy_maybe (NoteTy n ty)    = tcSplitFunTy_maybe ty
tcSplitFunTy_maybe other	    = Nothing

tcFunArgTy    ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> arg }
tcFunResultTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> res }


tcSplitAppTy_maybe :: Type -> Maybe (Type, Type)
454
455
456
457
458
459
460
tcSplitAppTy_maybe (FunTy ty1 ty2)   = Just (TyConApp funTyCon [ty1], ty2)
tcSplitAppTy_maybe (AppTy ty1 ty2)   = Just (ty1, ty2)
tcSplitAppTy_maybe (NoteTy n ty)     = tcSplitAppTy_maybe ty
tcSplitAppTy_maybe (TyConApp tc tys) = case snocView tys of
					Just (tys', ty') -> Just (TyConApp tc tys', ty')
					Nothing		 -> Nothing
tcSplitAppTy_maybe other	     = Nothing
461
462
463
464
465

tcSplitAppTy ty = case tcSplitAppTy_maybe ty of
		    Just stuff -> stuff
		    Nothing    -> pprPanic "tcSplitAppTy" (pprType ty)

466
467
468
469
470
471
472
473
tcSplitAppTys :: Type -> (Type, [Type])
tcSplitAppTys ty
  = go ty []
  where
    go ty args = case tcSplitAppTy_maybe ty of
		   Just (ty', arg) -> go ty' (arg:args)
		   Nothing	   -> (ty,args)

474
475
476
477
478
479
480
481
482
483
484
tcGetTyVar_maybe :: Type -> Maybe TyVar
tcGetTyVar_maybe (TyVarTy tv) 	= Just tv
tcGetTyVar_maybe (NoteTy _ t) 	= tcGetTyVar_maybe t
tcGetTyVar_maybe other	        = Nothing

tcGetTyVar :: String -> Type -> TyVar
tcGetTyVar msg ty = expectJust msg (tcGetTyVar_maybe ty)

tcIsTyVarTy :: Type -> Bool
tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty)

485
tcSplitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type])
486
487
488
489
490
-- Split the type of a dictionary function
tcSplitDFunTy ty 
  = case tcSplitSigmaTy ty       of { (tvs, theta, tau) ->
    case tcSplitPredTy_maybe tau of { Just (ClassP clas tys) -> 
    (tvs, theta, clas, tys) }}
491
492
\end{code}

493

494
495
496

%************************************************************************
%*									*
497
\subsection{Predicate types}
498
499
%*									*
%************************************************************************
500

501
\begin{code}
502
503
tcSplitPredTy_maybe :: Type -> Maybe PredType
   -- Returns Just for predicates only
504
tcSplitPredTy_maybe (NoteTy _ ty) = tcSplitPredTy_maybe ty
505
tcSplitPredTy_maybe (PredTy p)    = Just p
506
tcSplitPredTy_maybe other	  = Nothing
507
	
508
predTyUnique :: PredType -> Unique
509
predTyUnique (IParam n _)      = getUnique (ipNameName n)
510
511
predTyUnique (ClassP clas tys) = getUnique clas

512
mkPredName :: Unique -> SrcLoc -> PredType -> Name
513
514
mkPredName uniq loc (ClassP cls tys) = mkInternalName uniq (mkDictOcc (getOccName cls)) loc
mkPredName uniq loc (IParam ip ty)   = mkInternalName uniq (getOccName (ipNameName ip)) loc
515
516
\end{code}

517
518

--------------------- Dictionary types ---------------------------------
519
520

\begin{code}
521
mkClassPred clas tys = ClassP clas tys
522

523
isClassPred :: PredType -> Bool
524
525
526
isClassPred (ClassP clas tys) = True
isClassPred other	      = False

527
isTyVarClassPred (ClassP clas tys) = all tcIsTyVarTy tys
528
529
isTyVarClassPred other		   = False

530
getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])
531
532
533
534
535
536
537
getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys)
getClassPredTys_maybe _		        = Nothing

getClassPredTys :: PredType -> (Class, [Type])
getClassPredTys (ClassP clas tys) = (clas, tys)

mkDictTy :: Class -> [Type] -> Type
538
mkDictTy clas tys = mkPredTy (ClassP clas tys)
539
540

isDictTy :: Type -> Bool
541
isDictTy (PredTy p)   = isClassPred p
542
543
isDictTy (NoteTy _ ty)	= isDictTy ty
isDictTy other		= False
544
\end{code}
545

546
547
548
--------------------- Implicit parameters ---------------------------------

\begin{code}
549
isIPPred :: PredType -> Bool
550
551
552
isIPPred (IParam _ _) = True
isIPPred other	      = False

553
isInheritablePred :: PredType -> Bool
554
555
556
557
558
559
560
561
-- Can be inherited by a context.  For example, consider
--	f x = let g y = (?v, y+x)
--	      in (g 3 with ?v = 8, 
--		  g 4 with ?v = 9)
-- The point is that g's type must be quantifed over ?v:
--	g :: (?v :: a) => a -> a
-- but it doesn't need to be quantified over the Num a dictionary
-- which can be free in g's rhs, and shared by both calls to g
562
563
564
565
566
567
isInheritablePred (ClassP _ _) = True
isInheritablePred other	     = False

isLinearPred :: TcPredType -> Bool
isLinearPred (IParam (Linear n) _) = True
isLinearPred other		   = False
568
\end{code}
569
570


571
572
573
574
575
%************************************************************************
%*									*
\subsection{Predicates}
%*									*
%************************************************************************
576

577
isSigmaTy returns true of any qualified type.  It doesn't *necessarily* have 
578
579
any foralls.  E.g.
	f :: (?x::Int) => Int -> Int
580

581
\begin{code}
582
583
584
585
586
isSigmaTy :: Type -> Bool
isSigmaTy (ForAllTy tyvar ty) = True
isSigmaTy (FunTy a b)	      = isPredTy a
isSigmaTy (NoteTy n ty)	      = isSigmaTy ty
isSigmaTy _		      = False
587
588
589
590
591
592

isOverloadedTy :: Type -> Bool
isOverloadedTy (ForAllTy tyvar ty) = isOverloadedTy ty
isOverloadedTy (FunTy a b)	   = isPredTy a
isOverloadedTy (NoteTy n ty)	   = isOverloadedTy ty
isOverloadedTy _		   = False
593
594
595
596
597
598

isPredTy :: Type -> Bool	-- Belongs in TcType because it does 
				-- not look through newtypes, or predtypes (of course)
isPredTy (NoteTy _ ty) = isPredTy ty
isPredTy (PredTy sty)  = True
isPredTy _	       = False
599
\end{code}
600
601

\begin{code}
602
603
604
605
606
607
isFloatTy      = is_tc floatTyConKey
isDoubleTy     = is_tc doubleTyConKey
isIntegerTy    = is_tc integerTyConKey
isIntTy        = is_tc intTyConKey
isAddrTy       = is_tc addrTyConKey
isBoolTy       = is_tc boolTyConKey
608
isUnitTy       = is_tc unitTyConKey
609
610
611
612
613
614
615

is_tc :: Unique -> Type -> Bool
-- Newtypes are opaque to this
is_tc uniq ty = case tcSplitTyConApp_maybe ty of
			Just (tc, _) -> uniq == getUnique tc
			Nothing	     -> False
\end{code}
616

617

618
619
620
621
622
623
624
625
%************************************************************************
%*									*
\subsection{Misc}
%*									*
%************************************************************************

\begin{code}
deNoteType :: Type -> Type
626
	-- Remove synonyms, but not predicate types
627
628
deNoteType ty@(TyVarTy tyvar)	= ty
deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys)
629
deNoteType (PredTy p)		= PredTy (deNotePredType p)
630
631
632
633
634
deNoteType (NoteTy _ ty)	= deNoteType ty
deNoteType (AppTy fun arg)	= AppTy (deNoteType fun) (deNoteType arg)
deNoteType (FunTy fun arg)	= FunTy (deNoteType fun) (deNoteType arg)
deNoteType (ForAllTy tv ty)	= ForAllTy tv (deNoteType ty)

635
636
637
deNotePredType :: PredType -> PredType
deNotePredType (ClassP c tys)   = ClassP c (map deNoteType tys)
deNotePredType (IParam n ty)    = IParam n (deNoteType ty)
638
639
\end{code}

640
641
Find the free tycons and classes of a type.  This is used in the front
end of the compiler.
642

643
\begin{code}
644
645
646
647
648
tyClsNamesOfType :: Type -> NameSet
tyClsNamesOfType (TyVarTy tv)		    = emptyNameSet
tyClsNamesOfType (TyConApp tycon tys)	    = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
tyClsNamesOfType (NoteTy (SynNote ty1) ty2) = tyClsNamesOfType ty1
tyClsNamesOfType (NoteTy other_note    ty2) = tyClsNamesOfType ty2
649
650
tyClsNamesOfType (PredTy (IParam n ty))   = tyClsNamesOfType ty
tyClsNamesOfType (PredTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys
651
652
653
654
655
656
657
tyClsNamesOfType (FunTy arg res)	    = tyClsNamesOfType arg `unionNameSets` tyClsNamesOfType res
tyClsNamesOfType (AppTy fun arg)	    = tyClsNamesOfType fun `unionNameSets` tyClsNamesOfType arg
tyClsNamesOfType (ForAllTy tyvar ty)	    = tyClsNamesOfType ty

tyClsNamesOfTypes tys = foldr (unionNameSets . tyClsNamesOfType) emptyNameSet tys

tyClsNamesOfDFunHead :: Type -> NameSet
658
659
660
661
662
663
-- Find the free type constructors and classes 
-- of the head of the dfun instance type
-- The 'dfun_head_type' is because of
--	instance Foo a => Baz T where ...
-- The decl is an orphan if Baz and T are both not locally defined,
--	even if Foo *is* locally defined
664
665
666
667
tyClsNamesOfDFunHead dfun_ty 
  = case tcSplitSigmaTy dfun_ty of
	(tvs,_,head_ty) -> tyClsNamesOfType head_ty

668
classesOfTheta :: ThetaType -> [Class]
669
-- Looks just for ClassP things; maybe it should check
670
classesOfTheta preds = [ c | ClassP c _ <- preds ]
671
672
673
\end{code}


674
675
676
677
678
679
680
681
682
683
684
%************************************************************************
%*									*
\subsection[TysWiredIn-ext-type]{External types}
%*									*
%************************************************************************

The compiler's foreign function interface supports the passing of a
restricted set of types as arguments and results (the restricting factor
being the )

\begin{code}
685
686
687
688
isFFITy :: Type -> Bool
-- True for any TyCon that can possibly be an arg or result of an FFI call
isFFITy ty = checkRepTyCon legalFFITyCon ty

689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool
-- Checks for valid argument type for a 'foreign import'
isFFIArgumentTy dflags safety ty 
   = checkRepTyCon (legalOutgoingTyCon dflags safety) ty

isFFIExternalTy :: Type -> Bool
-- Types that are allowed as arguments of a 'foreign export'
isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty

isFFIImportResultTy :: DynFlags -> Type -> Bool
isFFIImportResultTy dflags ty 
  = checkRepTyCon (legalFIResultTyCon dflags) ty

isFFIExportResultTy :: Type -> Bool
isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty

isFFIDynArgumentTy :: Type -> Bool
-- The argument type of a foreign import dynamic must be Ptr, FunPtr, Addr,
-- or a newtype of either.
708
isFFIDynArgumentTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
709
710
711
712

isFFIDynResultTy :: Type -> Bool
-- The result type of a foreign export dynamic must be Ptr, FunPtr, Addr,
-- or a newtype of either.
713
isFFIDynResultTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
714
715
716
717

isFFILabelTy :: Type -> Bool
-- The type of a foreign label must be Ptr, FunPtr, Addr,
-- or a newtype of either.
718
isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
719

sof's avatar
sof committed
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
isFFIDotnetTy :: DynFlags -> Type -> Bool
isFFIDotnetTy dflags ty
  = checkRepTyCon (\ tc -> not (isByteArrayLikeTyCon tc) &&
  			   (legalFIResultTyCon dflags tc || 
			   isFFIDotnetObjTy ty || isStringTy ty)) ty

-- Support String as an argument or result from a .NET FFI call.
isStringTy ty = 
  case tcSplitTyConApp_maybe (repType ty) of
    Just (tc, [arg_ty])
      | tc == listTyCon ->
        case tcSplitTyConApp_maybe (repType arg_ty) of
	  Just (cc,[]) -> cc == charTyCon
	  _ -> False
    _ -> False

-- Support String as an argument or result from a .NET FFI call.
isFFIDotnetObjTy ty = 
  let
   (_, t_ty) = tcSplitForAllTys ty
  in
  case tcSplitTyConApp_maybe (repType t_ty) of
    Just (tc, [arg_ty]) | getName tc == objectTyConName -> True
    _ -> False

toDNType :: Type -> DNType
toDNType ty
  | isStringTy ty = DNString
  | isFFIDotnetObjTy ty = DNObject
  | Just (tc,argTys) <- tcSplitTyConApp_maybe ty = 
     case lookup (getUnique tc) dn_assoc of
       Just x  -> x
       Nothing 
         | tc `hasKey` ioTyConKey -> toDNType (head argTys)
	 | otherwise -> pprPanic ("toDNType: unsupported .NET type") (pprType ty <+> parens (hcat (map pprType argTys)) <+> ppr tc)
    where
      dn_assoc :: [ (Unique, DNType) ]
      dn_assoc = [ (unitTyConKey,   DNUnit)
      		 , (intTyConKey,    DNInt)
      	         , (int8TyConKey,   DNInt8)
		 , (int16TyConKey,  DNInt16)
		 , (int32TyConKey,  DNInt32)
		 , (int64TyConKey,  DNInt64)
		 , (wordTyConKey,   DNInt)
		 , (word8TyConKey,  DNWord8)
		 , (word16TyConKey, DNWord16)
		 , (word32TyConKey, DNWord32)
		 , (word64TyConKey, DNWord64)
		 , (floatTyConKey,  DNFloat)
		 , (doubleTyConKey, DNDouble)
		 , (addrTyConKey,   DNPtr)
		 , (ptrTyConKey,    DNPtr)
		 , (funPtrTyConKey, DNPtr)
		 , (charTyConKey,   DNChar)
		 , (boolTyConKey,   DNBool)
		 ]

777
778
779
checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
	-- Look through newtypes
	-- Non-recursive ones are transparent to splitTyConApp,
780
781
782
	-- but recursive ones aren't.  Manuel had:
	--	newtype T = MkT (Ptr T)
	-- and wanted it to work...
783
checkRepTyCon check_tc ty 
784
785
  | Just (tc,_) <- splitTyConApp_maybe (repType ty) = check_tc tc
  | otherwise				  	    = False
786
787
788
789
790

checkRepTyConKey :: [Unique] -> Type -> Bool
-- Like checkRepTyCon, but just looks at the TyCon key
checkRepTyConKey keys
  = checkRepTyCon (\tc -> tyConUnique tc `elem` keys)
791
792
793
794
795
796
797
798
799
800
801
802
\end{code}

----------------------------------------------
These chaps do the work; they are not exported
----------------------------------------------

\begin{code}
legalFEArgTyCon :: TyCon -> Bool
-- It's illegal to return foreign objects and (mutable)
-- bytearrays from a _ccall_ / foreign declaration
-- (or be passed them as arguments in foreign exported functions).
legalFEArgTyCon tc
sof's avatar
sof committed
803
  | isByteArrayLikeTyCon tc
804
805
806
807
808
809
810
811
  = False
  -- It's also illegal to make foreign exports that take unboxed
  -- arguments.  The RTS API currently can't invoke such things.  --SDM 7/2000
  | otherwise
  = boxedMarshalableTyCon tc

legalFIResultTyCon :: DynFlags -> TyCon -> Bool
legalFIResultTyCon dflags tc
sof's avatar
sof committed
812
813
814
  | isByteArrayLikeTyCon tc = False
  | tc == unitTyCon         = True
  | otherwise	            = marshalableTyCon dflags tc
815
816
817

legalFEResultTyCon :: TyCon -> Bool
legalFEResultTyCon tc
sof's avatar
sof committed
818
819
820
  | isByteArrayLikeTyCon tc = False
  | tc == unitTyCon         = True
  | otherwise               = boxedMarshalableTyCon tc
821
822
823
824

legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool
-- Checks validity of types going from Haskell -> external world
legalOutgoingTyCon dflags safety tc
sof's avatar
sof committed
825
  | playSafe safety && isByteArrayLikeTyCon tc
826
827
828
829
  = False
  | otherwise
  = marshalableTyCon dflags tc

830
831
832
833
834
legalFFITyCon :: TyCon -> Bool
-- True for any TyCon that can possibly be an arg or result of an FFI call
legalFFITyCon tc
  = isUnLiftedTyCon tc || boxedMarshalableTyCon tc || tc == unitTyCon

835
836
837
838
839
840
841
842
843
844
845
marshalableTyCon dflags tc
  =  (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc)
  || boxedMarshalableTyCon tc

boxedMarshalableTyCon tc
   = getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey
			 , int32TyConKey, int64TyConKey
			 , wordTyConKey, word8TyConKey, word16TyConKey
			 , word32TyConKey, word64TyConKey
			 , floatTyConKey, doubleTyConKey
			 , addrTyConKey, ptrTyConKey, funPtrTyConKey
846
			 , charTyConKey
847
848
849
850
			 , stablePtrTyConKey
			 , byteArrayTyConKey, mutableByteArrayTyConKey
			 , boolTyConKey
			 ]
sof's avatar
sof committed
851
852
853
854

isByteArrayLikeTyCon :: TyCon -> Bool
isByteArrayLikeTyCon tc = 
  getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey]
855
856
857
\end{code}