TcTyClsDecls.lhs 26.9 KB
Newer Older
1
%
2
% (c) The AQUA Project, Glasgow University, 1996-1998
3
4
5
6
7
%
\section[TcTyClsDecls]{Typecheck type and class declarations}

\begin{code}
module TcTyClsDecls (
8
	tcTyAndClassDecls
9
10
    ) where

11
#include "HsVersions.h"
12

13
import HsSyn		( TyClDecl(..),  HsConDetails(..), HsTyVarBndr(..),
14
15
16
			  ConDecl(..),   Sig(..), , NewOrData(..), 
			  tyClDeclTyVars, isSynDecl, LConDecl,
			  LTyClDecl, tcdName, LHsTyVarBndr, LHsContext
17
			)
18
import HsTypes          ( HsBang(..), getBangStrictness )
19
import BasicTypes	( RecFlag(..), StrictnessMark(..) )
20
import HscTypes		( implicitTyThings )
21
22
import BuildTyCl	( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon,
			  mkDataTyConRhs, mkNewTyConRhs )
23
import TcRnMonad
24
import TcEnv		( TcTyThing(..), TyThing(..), 
25
			  tcLookupLocated, tcLookupLocatedGlobal, 
26
			  tcExtendGlobalEnv, tcExtendKindEnv,
27
			  tcExtendRecEnv, tcLookupTyVar )
28
import TcTyDecls	( calcTyConArgVrcs, calcRecFlags, calcClassCycles, calcSynCycles )
29
import TcClassDcl	( tcClassSigs, tcAddDeclCtxt )
30
31
32
import TcHsType		( kcHsTyVars, kcHsLiftedSigType, kcHsType, 
			  kcHsContext, tcTyVarBndrs, tcHsKindedType, tcHsKindedContext,
			  kcHsSigType, tcHsBangType, tcLHsConSig )
33
import TcMType		( newKindVar, checkValidTheta, checkValidType, checkFreeness, 
34
			  UserTypeCtxt(..), SourceTyCtxt(..) ) 
35
import TcUnify		( unifyKind )
36
37
import TcType		( TcKind, ThetaType, TcType, tyVarsOfType, 
			  mkArrowKind, liftedTypeKind, mkTyVarTys, tcEqTypes,
38
			  tcSplitSigmaTy, tcEqType )
39
import Type		( splitTyConApp_maybe, pprThetaArrow, pprParendType )
40
import Generics		( validGenericMethodType, canDoGenerics )
41
import Class		( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars )
42
import TyCon		( TyCon, ArgVrcs, 
43
			  tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon,
44
45
46
47
			  tyConStupidTheta, getSynTyConDefn, tyConDataCons, isSynTyCon, tyConName )
import DataCon		( DataCon, dataConWrapId, dataConName, dataConSig, 
			  dataConFieldLabels, dataConOrigArgTys, dataConTyCon )
import Type		( zipTopTvSubst, substTys )
48
import Var		( TyVar, idType, idName )
49
import VarSet		( elemVarSet )
50
import Name		( Name )
sof's avatar
sof committed
51
import Outputable
52
import Util		( zipLazy, isSingleton, notNull, sortLe )
53
54
import List		( partition )
import SrcLoc		( Located(..), unLoc, getLoc )
55
import ListSetOps	( equivClasses )
56
import Digraph		( SCC(..) )
57
import CmdLineOpts	( DynFlag( Opt_GlasgowExts, Opt_Generics, Opt_UnboxStrictFields ) )
58
59
\end{code}

60
61
62
63
64
65
66

%************************************************************************
%*									*
\subsection{Type checking for type and class declarations}
%*									*
%************************************************************************

67
68
Dealing with a group
~~~~~~~~~~~~~~~~~~~~
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
Consider a mutually-recursive group, binding 
a type constructor T and a class C.

Step 1: 	getInitialKind
	Construct a KindEnv by binding T and C to a kind variable 

Step 2: 	kcTyClDecl
	In that environment, do a kind check

Step 3: Zonk the kinds

Step 4: 	buildTyConOrClass
	Construct an environment binding T to a TyCon and C to a Class.
	a) Their kinds comes from zonking the relevant kind variable
	b) Their arity (for synonyms) comes direct from the decl
	c) The funcional dependencies come from the decl
	d) The rest comes a knot-tied binding of T and C, returned from Step 4
	e) The variances of the tycons in the group is calculated from 
		the knot-tied stuff

Step 5: 	tcTyClDecl1
	In this environment, walk over the decls, constructing the TyCons and Classes.
	This uses in a strict way items (a)-(c) above, which is why they must
92
93
94
	be constructed in Step 4. Feed the results back to Step 4.
	For this step, pass the is-recursive flag as the wimp-out flag
	to tcTyClDecl1.
95
	
96

97
Step 6:		Extend environment
98
99
100
	We extend the type environment with bindings not only for the TyCons and Classes,
	but also for their "implicit Ids" like data constructors and class selectors

101
102
103
104
105
106
Step 7:		checkValidTyCl
	For a recursive group only, check all the decls again, just
	to check all the side conditions on validity.  We could not
	do this before because we were in a mutually recursive knot.


107
108
The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
@TyThing@s.  @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
109

110
\begin{code}
111
tcTyAndClassDecls :: [Name] -> [LTyClDecl Name]
112
113
   	           -> TcM TcGblEnv 	-- Input env extended by types and classes 
					-- and their implicit Ids,DataCons
114
tcTyAndClassDecls boot_names decls
115
116
117
  = do	{ 	-- First check for cyclic type synonysm or classes
		-- See notes with checkCycleErrs
	  checkCycleErrs decls
118
119
	; mod <- getModule
	; traceTc (text "tcTyAndCl" <+> ppr mod <+> ppr boot_names)
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
	; (syn_tycons, alg_tyclss) <- fixM (\ ~(rec_syn_tycons, rec_alg_tyclss) ->
	  do	{ let {	-- Calculate variances and rec-flag
		      ; (syn_decls, alg_decls) = partition (isSynDecl . unLoc) decls }

			-- Extend the global env with the knot-tied results
			-- for data types and classes
			-- 
			-- We must populate the environment with the loop-tied T's right
			-- away, because the kind checker may "fault in" some type 
			-- constructors that recursively mention T
		; let { gbl_things = mkGlobalThings alg_decls rec_alg_tyclss }
		; tcExtendRecEnv gbl_things $ do

			-- Kind-check the declarations
		{ (kc_syn_decls, kc_alg_decls) <- kcTyClDecls syn_decls alg_decls

		; let {	calc_vrcs = calcTyConArgVrcs (rec_syn_tycons ++ rec_alg_tyclss)
137
		      ; calc_rec  = calcRecFlags boot_names rec_alg_tyclss
138
139
140
141
142
143
144
145
146
		      ; tc_decl   = addLocM (tcTyClDecl calc_vrcs calc_rec) }
			-- Type-check the type synonyms, and extend the envt
		; syn_tycons <- tcSynDecls calc_vrcs kc_syn_decls
		; tcExtendGlobalEnv syn_tycons $ do

			-- Type-check the data types and classes
		{ alg_tyclss <- mappM tc_decl kc_alg_decls
		; return (syn_tycons, alg_tyclss)
	    }}})
147
148
	-- Finished with knot-tying now
	-- Extend the environment with the finished things
149
	; tcExtendGlobalEnv (syn_tycons ++ alg_tyclss) $ do
150
151
152

	-- Perform the validity check
	{ traceTc (text "ready for validity check")
153
	; mappM_ (addLocM checkValidTyCl) decls
154
 	; traceTc (text "done")
155
   
156
157
158
	-- Add the implicit things;
	-- we want them in the environment because 
	-- they may be mentioned in interface files
159
160
	; let {	implicit_things = concatMap implicitTyThings alg_tyclss }
	; traceTc ((text "Adding" <+> ppr alg_tyclss) $$ (text "and" <+> ppr implicit_things))
161
162
163
  	; tcExtendGlobalEnv implicit_things getGblEnv
    }}

164
mkGlobalThings :: [LTyClDecl Name] 	-- The decls
165
166
167
168
169
170
	       -> [TyThing]		-- Knot-tied, in 1-1 correspondence with the decls
	       -> [(Name,TyThing)]
-- Driven by the Decls, and treating the TyThings lazily
-- make a TypeEnv for the new things
mkGlobalThings decls things
  = map mk_thing (decls `zipLazy` things)
171
  where
172
    mk_thing (L _ (ClassDecl {tcdLName = L _ name}), ~(AClass cl))
173
	 = (name, AClass cl)
174
    mk_thing (L _ decl, ~(ATyCon tc))
175
         = (tcdName decl, ATyCon tc)
176
\end{code}
177
178


179
180
%************************************************************************
%*									*
181
		Kind checking
182
183
%*									*
%************************************************************************
184

185
186
We need to kind check all types in the mutually recursive group
before we know the kind of the type variables.  For example:
187
188
189
190
191
192
193
194
195
196
197

class C a where
   op :: D b => a -> b -> b

class D c where
   bop :: (Monad c) => ...

Here, the kind of the locally-polymorphic type variable "b"
depends on *all the uses of class D*.  For example, the use of
Monad c in bop's type signature means that D must have kind Type->Type.

198
199
200
201
202
203
204
205
However type synonyms work differently.  They can have kinds which don't
just involve (->) and *:
	type R = Int#		-- Kind #
	type S a = Array# a	-- Kind * -> #
	type T a b = (# a,b #)	-- Kind * -> * -> (# a,b #)
So we must infer their kinds from their right-hand sides *first* and then
use them, whereas for the mutually recursive data types D we bring into
scope kind bindings D -> k, where k is a kind variable, and do inference.
206

207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
\begin{code}
kcTyClDecls syn_decls alg_decls
  = do	{ 	-- First extend the kind env with each data 
		-- type and class, mapping them to a type variable
	  alg_kinds <- mappM getInitialKind alg_decls
	; tcExtendKindEnv alg_kinds $ do

		-- Now kind-check the type synonyms, in dependency order
		-- We do these differently to data type and classes,
		-- because a type synonym can be an unboxed type
		--	type Foo = Int#
		-- and a kind variable can't unify with UnboxedTypeKind
		-- So we infer their kinds in dependency order
	{ (kc_syn_decls, syn_kinds) <- kcSynDecls (calcSynCycles syn_decls)
	; tcExtendKindEnv syn_kinds $  do

		-- Now kind-check the data type and class declarations, 
		-- returning kind-annotated decls
	{ kc_alg_decls <- mappM (wrapLocM kcTyClDecl) alg_decls

	; return (kc_syn_decls, kc_alg_decls) }}}
228

229
------------------------------------------------------------------------
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
getInitialKind :: LTyClDecl Name -> TcM (Name, TcKind)

getInitialKind decl
 = newKindVar			`thenM` \ kind  ->
   returnM (unLoc (tcdLName (unLoc decl)), kind)

----------------
kcSynDecls :: [SCC (LTyClDecl Name)] 
	   -> TcM ([LTyClDecl Name], 	-- Kind-annotated decls
		   [(Name,TcKind)])	-- Kind bindings
kcSynDecls []
  = return ([], [])
kcSynDecls (group : groups)
  = do	{ (decl,  nk)  <- kcSynDecl group
	; (decls, nks) <- tcExtendKindEnv [nk] (kcSynDecls groups)
	; return (decl:decls, nk:nks) }
			
----------------
kcSynDecl :: SCC (LTyClDecl Name) 
	   -> TcM (LTyClDecl Name, 	-- Kind-annotated decls
		   (Name,TcKind))	-- Kind bindings
kcSynDecl (AcyclicSCC ldecl@(L loc decl))
  = tcAddDeclCtxt decl	$
    kcHsTyVars (tcdTyVars decl) (\ k_tvs ->
    do { traceTc (text "kcd1" <+> ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl)) 
			<+> brackets (ppr k_tvs))
       ; (k_rhs, rhs_kind) <- kcHsType (tcdSynRhs decl)
       ; traceTc (text "kcd2" <+> ppr (unLoc (tcdLName decl)))
       ; let tc_kind = foldr (mkArrowKind . kindedTyVarKind) rhs_kind k_tvs
       ; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }),
		 (unLoc (tcdLName decl), tc_kind)) })

kcSynDecl (CyclicSCC decls)
  = do { recSynErr decls; failM }	-- Fail here to avoid error cascade
					-- of out-of-scope tycons
265

266
267
268
------------------------------------------------------------------------
kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name)
	-- Not used for type synonyms (see kcSynDecl)
269

270
271
kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
  = kcTyClDeclBody decl	$ \ tvs' ->
272
    do	{ ctxt' <- kcHsContext ctxt	
273
	; cons' <- mappM (wrapLocM kc_con_decl) cons
274
	; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdCons = cons'}) }
275
  where
276
    kc_con_decl (ConDecl name ex_tvs ex_ctxt details)
277
278
279
      = kcHsTyVars ex_tvs		$ \ ex_tvs' ->
	do { ex_ctxt' <- kcHsContext ex_ctxt
	   ; details' <- kc_con_details details 
280
	   ; return (ConDecl name ex_tvs' ex_ctxt' details')}
281
282
283
    kc_con_decl (GadtDecl name ty)
        = do { ty' <- kcHsSigType ty
	     ; return (GadtDecl name ty') }
284
285

    kc_con_details (PrefixCon btys) 
286
	= do { btys' <- mappM kc_larg_ty btys ; return (PrefixCon btys') }
287
    kc_con_details (InfixCon bty1 bty2) 
288
	= do { bty1' <- kc_larg_ty bty1; bty2' <- kc_larg_ty bty2; return (InfixCon bty1' bty2') }
289
290
291
    kc_con_details (RecCon fields) 
	= do { fields' <- mappM kc_field fields; return (RecCon fields') }

292
293
    kc_field (fld, bty) = do { bty' <- kc_larg_ty bty ; return (fld, bty') }

294
295
296
297
298
299
    kc_larg_ty bty = case new_or_data of
			DataType -> kcHsSigType bty
			NewType  -> kcHsLiftedSigType bty
	-- Can't allow an unlifted type for newtypes, because we're effectively
	-- going to remove the constructor while coercing it to a lifted type.
	-- And newtypes can't be bang'd
300

301
302
kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt,  tcdSigs = sigs})
  = kcTyClDeclBody decl	$ \ tvs' ->
303
    do	{ ctxt' <- kcHsContext ctxt	
304
	; sigs' <- mappM (wrapLocM kc_sig) sigs
305
	; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs'}) }
306
  where
307
308
    kc_sig (Sig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
				; return (Sig nm op_ty') }
309
310
    kc_sig other_sig	      = return other_sig

311
kcTyClDecl decl@(ForeignType {})
312
313
  = return decl

314
kcTyClDeclBody :: TyClDecl Name
315
	       -> ([LHsTyVarBndr Name] -> TcM a)
316
317
318
319
	       -> TcM a
  -- Extend the env with bindings for the tyvars, taken from
  -- the kind of the tycon/class.  Give it to the thing inside, and 
  -- check the result kind matches
320
kcTyClDeclBody decl thing_inside
321
  = tcAddDeclCtxt decl		$
322
323
324
    kcHsTyVars (tyClDeclTyVars decl)	$ \ kinded_tvs ->
    do 	{ tc_ty_thing <- tcLookupLocated (tcdLName decl)
	; let tc_kind = case tc_ty_thing of { AThing k -> k }
325
	; unifyKind tc_kind (foldr (mkArrowKind . kindedTyVarKind) 
326
327
				   (result_kind decl)
				   kinded_tvs)
328
	; thing_inside kinded_tvs }
329
330
331
332
333
  where
    result_kind (TyData { tcdKindSig = Just kind }) = kind
    result_kind other				   = liftedTypeKind
	-- On GADT-style declarations we allow a kind signature
	--	data T :: *->* where { ... }
334

335
kindedTyVarKind (L _ (KindedTyVar _ k)) = k
336
337
338
339
340
\end{code}


%************************************************************************
%*									*
341
\subsection{Type checking}
342
343
%*									*
%************************************************************************
344
345

\begin{code}
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
tcSynDecls :: (Name -> ArgVrcs) -> [LTyClDecl Name] -> TcM [TyThing]
tcSynDecls calc_vrcs [] = return []
tcSynDecls calc_vrcs (decl : decls) 
  = do { syn_tc <- addLocM (tcSynDecl calc_vrcs) decl
       ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls calc_vrcs decls)
       ; return (syn_tc : syn_tcs) }

tcSynDecl calc_vrcs 
  (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
  = tcTyVarBndrs tvs		$ \ tvs' -> do 
    { traceTc (text "tcd1" <+> ppr tc_name) 
    ; rhs_ty' <- tcHsKindedType rhs_ty
    ; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty' (calc_vrcs tc_name))) }

--------------------
361
tcTyClDecl :: (Name -> ArgVrcs) -> (Name -> RecFlag) 
362
	   -> TyClDecl Name -> TcM TyThing
363
364

tcTyClDecl calc_vrcs calc_isrec decl
365
  = tcAddDeclCtxt decl (tcTyClDecl1 calc_vrcs calc_isrec decl)
366
367

tcTyClDecl1 calc_vrcs calc_isrec 
368
  (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
369
	   tcdLName = L _ tc_name, tcdCons = cons})
370
  = tcTyVarBndrs tvs		$ \ tvs' -> do 
371
  { stupid_theta <- tcStupidTheta ctxt cons
372
373
  ; want_generic <- doptM Opt_Generics
  ; tycon <- fixM (\ tycon -> do 
374
375
	{ unbox_strict <- doptM Opt_UnboxStrictFields
	; data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data tycon tvs')) cons
376
	; let tc_rhs = case new_or_data of
377
			DataType -> mkDataTyConRhs stupid_theta data_cons
378
			NewType  -> ASSERT( isSingleton data_cons )
379
380
				    mkNewTyConRhs tycon (head data_cons)
	; buildAlgTyCon tc_name tvs' tc_rhs arg_vrcs is_rec
381
			(want_generic && canDoGenerics data_cons)
382
383
384
	})
  ; return (ATyCon tycon)
  }
385
  where
386
387
388
389
    arg_vrcs = calc_vrcs tc_name
    is_rec   = calc_isrec tc_name

tcTyClDecl1 calc_vrcs calc_isrec 
390
  (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs, 
391
392
	      tcdCtxt = ctxt, tcdMeths = meths,
	      tcdFDs = fundeps, tcdSigs = sigs} )
393
394
  = tcTyVarBndrs tvs		$ \ tvs' -> do 
  { ctxt' <- tcHsKindedContext ctxt
395
  ; fds' <- mappM (addLocM tc_fundep) fundeps
396
397
398
399
400
401
402
403
404
405
406
407
  ; sig_stuff <- tcClassSigs class_name sigs meths
  ; clas <- fixM (\ clas ->
		let 	-- This little knot is just so we can get
			-- hold of the name of the class TyCon, which we
			-- need to look up its recursiveness and variance
		    tycon_name = tyConName (classTyCon clas)
		    tc_isrec = calc_isrec tycon_name
		    tc_vrcs  = calc_vrcs  tycon_name
		in
		buildClass class_name tvs' ctxt' fds' 
			   sig_stuff tc_isrec tc_vrcs)
  ; return (AClass clas) }
408
  where
409
410
411
412
413
414
    tc_fundep (tvs1, tvs2) = do { tvs1' <- mappM tcLookupTyVar tvs1 ;
				; tvs2' <- mappM tcLookupTyVar tvs2 ;
				; return (tvs1', tvs2') }


tcTyClDecl1 calc_vrcs calc_isrec 
415
  (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name})
416
417
418
  = returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0 []))

-----------------------------------
419
420
tcConDecl :: Bool 		-- True <=> -funbox-strict_fields
	  -> NewOrData -> TyCon -> [TyVar]
421
	  -> ConDecl Name -> TcM DataCon
422

423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
tcConDecl unbox_strict NewType tycon tc_tvs	-- Newtypes
	  (ConDecl name ex_tvs ex_ctxt details)
  = ASSERT( null ex_tvs && null (unLoc ex_ctxt) )	
    do	{ let tc_datacon field_lbls arg_ty
		= do { arg_ty' <- tcHsKindedType arg_ty	-- No bang on newtype
		     ; buildDataCon (unLoc name) False {- Prefix -} 
				    True {- Vanilla -} [NotMarkedStrict]
		    		    (map unLoc field_lbls)
			   	    tc_tvs [] [arg_ty']
				    tycon (mkTyVarTys tc_tvs) }
	; case details of
	    PrefixCon [arg_ty] -> tc_datacon [] arg_ty
	    RecCon [(field_lbl, arg_ty)] -> tc_datacon [field_lbl] arg_ty }

tcConDecl unbox_strict DataType tycon tc_tvs	-- Ordinary data types
438
	  (ConDecl name ex_tvs ex_ctxt details)
439
  = tcTyVarBndrs ex_tvs		$ \ ex_tvs' -> do 
440
441
    { ex_ctxt' <- tcHsKindedContext ex_ctxt
    ; let 
442
443
444
	is_vanilla = null ex_tvs && null (unLoc ex_ctxt) 
		-- Vanilla iff no ex_tvs and no context

445
	tc_datacon is_infix field_lbls btys
446
447
448
449
	  = do { let { bangs = map getBangStrictness btys }
	       ; arg_tys <- mappM tcHsBangType btys
    	       ; buildDataCon (unLoc name) is_infix is_vanilla
    		    (argStrictness unbox_strict tycon bangs arg_tys)
450
    		    (map unLoc field_lbls)
451
452
453
454
    		    (tc_tvs ++ ex_tvs')
		    ex_ctxt'
    		    arg_tys
		    tycon (mkTyVarTys tc_tvs) }
455
    ; case details of
456
457
	PrefixCon btys     -> tc_datacon False [] btys
	InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2]
458
	RecCon fields      -> do { checkTc is_vanilla (exRecConErr name)
459
				 ; let { (field_names, btys) = unzip fields }
460
				 ; tc_datacon False field_names btys } }
461

462
tcConDecl unbox_strict DataType tycon tc_tvs	-- GADTs
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
	  decl@(GadtDecl name con_ty)
  = do	{ traceTc (text "tcConDecl"  <+> ppr name)
	; (tvs, theta, bangs, arg_tys, tc, res_tys) <- tcLHsConSig con_ty
		
	; traceTc (text "tcConDecl1"  <+> ppr name)
	; let 	-- Now dis-assemble the type, and check its form
	      is_vanilla = null theta && mkTyVarTys tvs `tcEqTypes` res_tys

		-- Vanilla datacons guarantee to use the same
		-- type variables as the parent tycon
	      (tvs', arg_tys', res_tys') 
		  | is_vanilla = (tc_tvs, substTys subst arg_tys, substTys subst res_tys)
		  | otherwise  = (tvs, arg_tys, res_tys)
	      subst = zipTopTvSubst tvs (mkTyVarTys tc_tvs)

	; traceTc (text "tcConDecl3"  <+> ppr name)
	; buildDataCon (unLoc name) False {- Not infix -} is_vanilla
    		       (argStrictness unbox_strict tycon bangs arg_tys)
		       [{- No field labels -}]
		       tvs' theta arg_tys' tycon res_tys' }

484
-------------------
485
486
487
488
489
490
491
492
493
tcStupidTheta :: LHsContext Name -> [LConDecl Name] -> TcM (Maybe ThetaType)
-- For GADTs we don't allow a context on the data declaration
-- whereas for standard Haskell style data declarations, we do
tcStupidTheta ctxt (L _ (ConDecl _ _ _ _) : _)
  = do { theta <- tcHsKindedContext ctxt; return (Just theta) }
tcStupidTheta ctxt other	-- Includes an empty constructor list
  = ASSERT( null (unLoc ctxt) ) return Nothing

-------------------
494
argStrictness :: Bool		-- True <=> -funbox-strict_fields
495
	      -> TyCon -> [HsBang]
496
	      -> [TcType] -> [StrictnessMark]
497
498
499
argStrictness unbox_strict tycon bangs arg_tys
 = ASSERT( length bangs == length arg_tys )
   zipWith (chooseBoxingStrategy unbox_strict tycon) arg_tys bangs
500
501
502
503
504
505
506
507
508
509
510
511

-- We attempt to unbox/unpack a strict field when either:
--   (i)  The field is marked '!!', or
--   (ii) The field is marked '!', and the -funbox-strict-fields flag is on.

chooseBoxingStrategy :: Bool -> TyCon -> TcType -> HsBang -> StrictnessMark
chooseBoxingStrategy unbox_strict_fields tycon arg_ty bang
  = case bang of
	HsNoBang				    -> NotMarkedStrict
	HsStrict | unbox_strict_fields && can_unbox -> MarkedUnboxed
	HsUnbox  | can_unbox			    -> MarkedUnboxed
	other					    -> MarkedStrict
512
  where
513
514
515
516
    can_unbox = case splitTyConApp_maybe arg_ty of
		   Nothing 	       -> False
		   Just (arg_tycon, _) -> not (isRecursiveTyCon tycon) &&
					  isProductTyCon arg_tycon
517
518
\end{code}

519
520
521
522
523
524
%************************************************************************
%*									*
\subsection{Dependency analysis}
%*									*
%************************************************************************

525
526
527
Validity checking is done once the mutually-recursive knot has been
tied, so we can look at things freely.

528
\begin{code}
529
checkCycleErrs :: [LTyClDecl Name] -> TcM ()
530
checkCycleErrs tyclss
531
  | null cls_cycles
532
533
  = return ()
  | otherwise
534
  = do	{ mappM_ recClsErr cls_cycles
535
536
	; failM	}	-- Give up now, because later checkValidTyCl
			-- will loop if the synonym is recursive
537
  where
538
    cls_cycles = calcClassCycles tyclss
539

540
checkValidTyCl :: TyClDecl Name -> TcM ()
541
542
543
544
-- We do the validity check over declarations, rather than TyThings
-- only so that we can add a nice context with tcAddDeclCtxt
checkValidTyCl decl
  = tcAddDeclCtxt decl $
545
    do	{ thing <- tcLookupLocatedGlobal (tcdLName decl)
546
547
548
549
550
551
552
553
554
555
556
	; traceTc (text "Validity of" <+> ppr thing)	
	; case thing of
	    ATyCon tc -> checkValidTyCon tc
	    AClass cl -> checkValidClass cl 
	; traceTc (text "Done validity of" <+> ppr thing)	
	}

-------------------------
checkValidTyCon :: TyCon -> TcM ()
checkValidTyCon tc
  | isSynTyCon tc 
557
  = checkValidType syn_ctxt syn_rhs
558
559
  | otherwise
  = 	-- Check the context on the data decl
560
    checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)	`thenM_` 
561
562
	
	-- Check arg types of data constructors
563
    mappM_ (checkValidDataCon tc) data_cons			`thenM_`
564

565
566
	-- Check that fields with the same name share a type
    mappM_ check_fields groups
567

568
569
570
571
572
573
  where
    syn_ctxt	 = TySynCtxt name
    name         = tyConName tc
    (_, syn_rhs) = getSynTyConDefn tc
    data_cons    = tyConDataCons tc

574
575
576
577
    groups = equivClasses cmp_fld (concatMap get_fields data_cons)
    cmp_fld (f1,_) (f2,_) = f1 `compare` f2
    get_fields con = dataConFieldLabels con `zip` dataConOrigArgTys con
	-- dataConFieldLabels may return the empty list, which is fine
578

579
    check_fields fields@((first_field_label, field_ty) : other_fields)
580
581
582
583
584
	-- These fields all have the same name, but are from
	-- different constructors in the data type
	= 	-- Check that all the fields in the group have the same type
		-- NB: this check assumes that all the constructors of a given
		-- data type use the same type variables
585
586
	  checkTc (all (tcEqType field_ty . snd) other_fields) 
		  (fieldTypeMisMatch first_field_label)
587
588

-------------------------------
589
590
591
592
593
594
checkValidDataCon :: TyCon -> DataCon -> TcM ()
checkValidDataCon tc con
  = addErrCtxt (dataConCtxt con) $ 
    do	{ checkTc (dataConTyCon con == tc) (badDataConTyCon con)
	; checkValidType ctxt (idType (dataConWrapId con)) }

595
596
		-- This checks the argument types and
		-- ambiguity of the existential context (if any)
597
598
599
600
		-- 
		-- Note [Sept 04] Now that tvs is all the tvs, this
		-- test doesn't actually check anything
--	; checkFreeness tvs ex_theta }
601
602
  where
    ctxt = ConArgCtxt (dataConName con) 
603
    (tvs, ex_theta, _, _, _) = dataConSig con
604

605

606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
-------------------------------
checkValidClass :: Class -> TcM ()
checkValidClass cls
  = do	{ 	-- CHECK ARITY 1 FOR HASKELL 1.4
	  gla_exts <- doptM Opt_GlasgowExts

    	-- Check that the class is unary, unless GlaExs
	; checkTc (notNull tyvars) (nullaryClassErr cls)
	; checkTc (gla_exts || unary) (classArityErr cls)

   	-- Check the super-classes
	; checkValidTheta (ClassSCCtxt (className cls)) theta

	-- Check the class operations
	; mappM_ check_op op_stuff
621

622
623
624
625
626
  	-- Check that if the class has generic methods, then the
	-- class has only one parameter.  We can't do generic
	-- multi-parameter type classes!
	; checkTc (unary || no_generics) (genericMultiParamErr cls)
	}
627
  where
628
629
630
    (tyvars, theta, _, op_stuff) = classBigSig cls
    unary 	= isSingleton tyvars
    no_generics = null [() | (_, GenDefMeth) <- op_stuff]
631

632
    check_op (sel_id, dm) 
633
634
      = addErrCtxt (classOpCtxt sel_id tau) $ do
	{ checkValidTheta SigmaCtxt (tail theta)
635
636
637
		-- The 'tail' removes the initial (C a) from the
		-- class itself, leaving just the method type

638
639
640
641
642
643
	; checkValidType (FunSigCtxt op_name) tau

		-- Check that the type mentions at least one of
		-- the class type variables
	; checkTc (any (`elemVarSet` tyVarsOfType tau) tyvars)
	          (noClassTyVarErr cls sel_id)
644
645
646

		-- Check that for a generic method, the type of 
		-- the method is sufficiently simple
647
	; checkTc (dm /= GenDefMeth || validGenericMethodType op_ty)
648
		  (badGenericMethodType op_name op_ty)
649
	}
650
651
652
653
654
655
656
657
658
659
660
661
662
	where
	  op_name = idName sel_id
	  op_ty   = idType sel_id
	  (_,theta,tau) = tcSplitSigmaTy op_ty



---------------------------------------------------------------------
fieldTypeMisMatch field_name
  = sep [ptext SLIT("Different constructors give different types for field"), quotes (ppr field_name)]

dataConCtxt con = sep [ptext SLIT("When checking the data constructor:"),
		       nest 2 (ex_part <+> pprThetaArrow ex_theta <+> ppr con <+> arg_part)]
663
  where
664
    (ex_tvs, ex_theta, arg_tys, _, _) = dataConSig con
665
666
667
668
669
670
671
672
673
674
675
676
    ex_part | null ex_tvs = empty
	    | otherwise   = ptext SLIT("forall") <+> hsep (map ppr ex_tvs) <> dot
	-- The 'ex_theta' part could be non-empty, if the user (bogusly) wrote
	--	data T a = Eq a => T a a
	-- So we make sure to print it

    fields = dataConFieldLabels con
    arg_part | null fields = sep (map pprParendType arg_tys)
	     | otherwise   = braces (sep (punctuate comma 
			     [ ppr n <+> dcolon <+> ppr ty 
			     | (n,ty) <- fields `zip` arg_tys]))

677
678
classOpCtxt sel_id tau = sep [ptext SLIT("When checking the class method:"),
			      nest 2 (ppr sel_id <+> dcolon <+> ppr tau)]
679
680
681
682
683
684
685
686

nullaryClassErr cls
  = ptext SLIT("No parameters for class")  <+> quotes (ppr cls)

classArityErr cls
  = vcat [ptext SLIT("Too many parameters for class") <+> quotes (ppr cls),
	  parens (ptext SLIT("Use -fglasgow-exts to allow multi-parameter classes"))]

687
688
689
690
691
noClassTyVarErr clas op
  = sep [ptext SLIT("The class method") <+> quotes (ppr op),
	 ptext SLIT("mentions none of the type variables of the class") <+> 
		ppr clas <+> hsep (map ppr (classTyVars clas))]

692
693
694
695
696
697
698
699
700
genericMultiParamErr clas
  = ptext SLIT("The multi-parameter class") <+> quotes (ppr clas) <+> 
    ptext SLIT("cannot have generic methods")

badGenericMethodType op op_ty
  = hang (ptext SLIT("Generic method type is too complex"))
       4 (vcat [ppr op <+> dcolon <+> ppr op_ty,
		ptext SLIT("You can only use type variables, arrows, and tuples")])

701
recSynErr syn_decls
702
  = setSrcSpan (getLoc (head sorted_decls)) $
703
    addErr (sep [ptext SLIT("Cycle in type synonym declarations:"),
704
		 nest 2 (vcat (map ppr_decl sorted_decls))])
705
  where
706
    sorted_decls = sortLocated syn_decls
707
    ppr_decl (L loc decl) = ppr loc <> colon <+> ppr decl
708

709
recClsErr cls_decls
710
  = setSrcSpan (getLoc (head sorted_decls)) $
711
    addErr (sep [ptext SLIT("Cycle in class declarations (via superclasses):"),
712
		 nest 2 (vcat (map ppr_decl sorted_decls))])
713
  where
714
    sorted_decls = sortLocated cls_decls
715
    ppr_decl (L loc decl) = ppr loc <> colon <+> ppr (decl { tcdSigs = [] })
716

717
718
719
720
721
sortLocated :: [Located a] -> [Located a]
sortLocated things = sortLe le things
  where
    le (L l1 _) (L l2 _) = l1 <= l2

722
exRecConErr name
723
  = ptext SLIT("Can't combine named fields with locally-quantified type variables or context")
724
725
    $$
    (ptext SLIT("In the declaration of data constructor") <+> ppr name)
726
727
728
729

badDataConTyCon data_con
  = hang (ptext SLIT("Data constructor does not return its parent type:"))
       2 (ppr data_con)
730
\end{code}