TcInstDcls.lhs 27.5 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
4
5
6
%
\section[TcInstDecls]{Typechecking instance declarations}

\begin{code}
7
module TcInstDcls ( tcInstDecls1, tcInstDecls2, tcAddDeclCtxt ) where
8

9
#include "HsVersions.h"
10

11

12
import CmdLineOpts	( DynFlag(..) )
13

14
import HsSyn		( HsDecl(..), InstDecl(..), TyClDecl(..), HsType(..),
15
			  MonoBinds(..), HsExpr(..),  HsLit(..), Sig(..), HsTyVarBndr(..),
16
17
			  andMonoBindList, collectMonoBinders, 
			  isClassDecl, isIfaceInstDecl, toHsType
sof's avatar
sof committed
18
			)
19
20
import RnHsSyn		( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, 
			  RenamedMonoBinds, RenamedTyClDecl, RenamedHsType, 
21
22
			  extractHsTyVars, maybeGenericMatch
			)
23
import TcHsSyn		( TcMonoBinds, mkHsConApp )
24
import TcBinds		( tcSpecSigs )
25
26
import TcClassDcl	( tcMethodBind, badMethodErr )
import TcMonad       
27
import TcMType		( tcInstSigTyVars, checkValidTheta, checkValidInstHead, instTypeErr, 
28
			  UserTypeCtxt(..), SourceTyCtxt(..) )
29
30
31
import TcType		( tcSplitDFunTy, mkClassPred, mkTyVarTy, mkTyVarTys,
			  tcSplitSigmaTy, tcSplitPredTy_maybe, getClassPredTys,
			  TyVarDetails(..)
32
			)
33
import Inst		( InstOrigin(..),
34
			  newDicts, instToId,
35
			  LIE, mkLIE, emptyLIE, plusLIE, plusLIEs )
36
import TcDeriv		( tcDeriving )
37
import TcEnv		( TcEnv, tcExtendGlobalValEnv, 
38
			  tcExtendTyVarEnvForMeths, tcLookupId, tcLookupClass,
39
 			  InstInfo(..), pprInstInfo, simpleInstInfoTyCon, 
40
			  simpleInstInfoTy, newDFunName
41
			)
42
import InstEnv		( InstEnv, extendInstEnv )
43
import PprType		( pprClassPred )
44
45
import TcMonoType	( tcHsTyVars, kcHsSigType, tcHsType, tcHsSigType )
import TcUnify		( checkSigTyVars )
46
import TcSimplify	( tcSimplifyCheck )
47
import HscTypes		( HomeSymbolTable, DFunId,
48
49
			  ModDetails(..), PackageInstEnv, PersistentRenamerState
			)
50

51
import Subst		( substTy, substTheta )
52
import DataCon		( classDataCon )
53
import Class		( Class, classBigSig )
54
import Var		( idName, idType )
55
import VarSet		( emptyVarSet )
56
import Id		( setIdLocalExported )
57
import MkId		( mkDictFunId )
58
import FunDeps		( checkInstFDs )
59
import Generics		( validGenericInstanceType )
60
import Module		( Module, foldModuleEnv )
61
import Name		( getSrcLoc )
62
import NameSet		( unitNameSet, emptyNameSet, nameSetToList )
63
import PrelInfo		( eRROR_ID )
64
import TyCon		( TyCon )
65
import Subst		( mkTopTyVarSubst, substTheta )
66
import TysWiredIn	( genericTyCons )
67
import Name             ( Name )
68
69
import SrcLoc           ( SrcLoc )
import Unique		( Uniquable(..) )
sof's avatar
sof committed
70
import Util             ( lengthExceeds )
71
import BasicTypes	( NewOrData(..), Fixity )
72
import ErrUtils		( dumpIfSet_dyn )
73
74
75
76
import ListSetOps	( Assoc, emptyAssoc, plusAssoc_C, mapAssoc, 
			  assocElts, extendAssoc_C,
			  equivClassesByUniq, minusList
			)
77
import List             ( partition )
78
import Outputable
79
80
81
\end{code}

Typechecking instance declarations is done in two passes. The first
82
83
pass, made by @tcInstDecls1@, collects information to be used in the
second pass.
84
85
86
87
88
89
90
91

This pre-processed info includes the as-yet-unprocessed bindings
inside the instance declaration.  These are type-checked in the second
pass, when the class-instance envs and GVE contain all the info from
all the instance and value decls.  Indeed that's the reason we need
two passes over the instance decls.


92
93
Here is the overall algorithm.
Assume that we have an instance declaration
94

95
    instance c => k (t tvs) where b
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153

\begin{enumerate}
\item
$LIE_c$ is the LIE for the context of class $c$
\item
$betas_bar$ is the free variables in the class method type, excluding the
   class variable
\item
$LIE_cop$ is the LIE constraining a particular class method
\item
$tau_cop$ is the tau type of a class method
\item
$LIE_i$ is the LIE for the context of instance $i$
\item
$X$ is the instance constructor tycon
\item
$gammas_bar$ is the set of type variables of the instance
\item
$LIE_iop$ is the LIE for a particular class method instance
\item
$tau_iop$ is the tau type for this instance of a class method
\item
$alpha$ is the class variable
\item
$LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
\item
$tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
\end{enumerate}

ToDo: Update the list above with names actually in the code.

\begin{enumerate}
\item
First, make the LIEs for the class and instance contexts, which means
instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
and make LIElistI and LIEI.
\item
Then process each method in turn.
\item
order the instance methods according to the ordering of the class methods
\item
express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
\item
Create final dictionary function from bindings generated already
\begin{pseudocode}
df = lambda inst_tyvars
       lambda LIEI
	 let Bop1
	     Bop2
	     ...
	     Bopn
	 and dbinds_super
	      in <op1,op2,...,opn,sd1,...,sdm>
\end{pseudocode}
Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
\end{enumerate}

154
155
156
157
158
159
160
161
162

%************************************************************************
%*									*
\subsection{Extracting instance decls}
%*									*
%************************************************************************

Gather up the instance declarations from their various sources

163
\begin{code}
164
165
tcInstDecls1 :: PackageInstEnv
	     -> PersistentRenamerState	
166
	     -> HomeSymbolTable		-- Contains instances
167
	     -> TcEnv 			-- Contains IdInfo for dfun ids
168
	     -> (Name -> Maybe Fixity)	-- for deriving Show and Read
169
	     -> Module			-- Module for deriving
170
	     -> [RenamedHsDecl]
171
	     -> TcM (PackageInstEnv, InstEnv, [InstInfo], RenamedHsBinds)
172

173
tcInstDecls1 inst_env0 prs hst unf_env get_fixity this_mod decls
174
  = let
175
176
177
	inst_decls = [inst_decl | InstD inst_decl <- decls]	
	tycl_decls = [decl      | TyClD decl <- decls]
	clas_decls = filter isClassDecl tycl_decls
178
	(imported_inst_ds, local_inst_ds) = partition isIfaceInstDecl inst_decls
179
180
    in
   	-- (1) Do the ordinary instance declarations
181
182
    mapNF_Tc tcInstDecl1 local_inst_ds		`thenNF_Tc` \ local_inst_infos ->
    mapNF_Tc tcInstDecl1 imported_inst_ds	`thenNF_Tc` \ imported_inst_infos ->
183
184

	-- (2) Instances from generic class declarations
185
    getGenericInstances clas_decls		`thenTc` \ generic_inst_info -> 
186

187
	-- Next, construct the instance environment so far, consisting of
188
	--	a) cached non-home-package InstEnv (gotten from pcs)	pcs_insts pcs
189
190
191
192
193
	--	b) imported instance decls (not in the home package)	inst_env1
	--	c) other modules in this package (gotten from hst)	inst_env2
	--	d) local instance decls					inst_env3
	--	e) generic instances					inst_env4
	-- The result of (b) replaces the cached InstEnv in the PCS
194
    let
195
196
197
	local_inst_info    = concat local_inst_infos
	imported_inst_info = concat imported_inst_infos
	hst_dfuns	   = foldModuleEnv ((++) . md_insts) [] hst
198
199
200
201
    in 

--    pprTrace "tcInstDecls" (vcat [ppr imported_dfuns, ppr hst_dfuns]) $

202
    addInstInfos inst_env0 imported_inst_info	`thenNF_Tc` \ inst_env1 ->
203
204
205
    addInstDFuns inst_env1 hst_dfuns		`thenNF_Tc` \ inst_env2 ->
    addInstInfos inst_env2 local_inst_info	`thenNF_Tc` \ inst_env3 ->
    addInstInfos inst_env3 generic_inst_info	`thenNF_Tc` \ inst_env4 ->
206

207
208
209
210
	-- (3) Compute instances from "deriving" clauses; 
	--     note that we only do derivings for things in this module; 
	--     we ignore deriving decls from interfaces!
	-- This stuff computes a context for the derived instance decl, so it
211
	-- needs to know about all the instances possible; hence inst_env4
212
213
    tcDeriving prs this_mod inst_env4 get_fixity tycl_decls
					`thenTc` \ (deriv_inst_info, deriv_binds) ->
214
    addInstInfos inst_env4 deriv_inst_info		`thenNF_Tc` \ final_inst_env ->
215

216
    returnTc (inst_env1, 
217
218
219
220
221
	      final_inst_env, 
	      generic_inst_info ++ deriv_inst_info ++ local_inst_info,
	      deriv_binds)

addInstInfos :: InstEnv -> [InstInfo] -> NF_TcM InstEnv
222
addInstInfos inst_env infos = addInstDFuns inst_env (map iDFunId infos)
223
224

addInstDFuns :: InstEnv -> [DFunId] -> NF_TcM InstEnv
225
addInstDFuns inst_env dfuns
226
  = getDOptsTc				`thenTc` \ dflags ->
227
    let
228
	(inst_env', errs) = extendInstEnv dflags inst_env dfuns
229
    in
230
    addErrsTc errs			`thenNF_Tc_` 
231
    traceTc (text "Adding instances:" <+> vcat (map pp dfuns))	`thenTc_`
232
    returnTc inst_env'
233
234
  where
    pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
235
\end{code} 
236

237
\begin{code}
238
tcInstDecl1 :: RenamedInstDecl -> NF_TcM [InstInfo]
239
-- Deal with a single instance declaration
240
-- Type-check all the stuff before the "where"
241
tcInstDecl1 decl@(InstDecl poly_ty binds uprags maybe_dfun_name src_loc)
242
  = 	-- Prime error recovery, set source location
243
    recoverNF_Tc (returnNF_Tc [])	$
244
    tcAddSrcLoc src_loc			$
245
    tcAddErrCtxt (instDeclCtxt poly_ty)	$
246

247
248
249
250
	-- Typecheck the instance type itself.  We can't use 
	-- tcHsSigType, because it's not a valid user type.
    kcHsSigType poly_ty			`thenTc_`
    tcHsType poly_ty			`thenTc` \ poly_ty' ->
251
    let
252
	(tyvars, theta, tau) = tcSplitSigmaTy poly_ty'
253
254
	(clas,inst_tys)      = case tcSplitPredTy_maybe tau of { Just st -> getClassPredTys st }
		-- The checkValidInstHead makes sure these splits succeed
255
    in
256
257
258
259
260
261
262
    (case maybe_dfun_name of
	Nothing ->	-- A source-file instance declaration
		-- Check for respectable instance type, and context
		-- but only do this for non-imported instance decls.
		-- Imported ones should have been checked already, and may indeed
		-- contain something illegal in normal Haskell, notably
		--	instance CCallable [Char] 
263
264
265
266
	    checkValidTheta InstThetaCtxt theta		`thenTc_`
    	    checkValidInstHead tau			`thenTc_`
	    checkTc (checkInstFDs theta clas inst_tys)
		    (instTypeErr (pprClassPred clas inst_tys) msg)	`thenTc_`
267
268
	    newDFunName clas inst_tys src_loc				`thenTc` \ dfun_name ->
	    returnTc (mkDictFunId dfun_name clas tyvars inst_tys theta)
269
270

	Just dfun_name -> 	-- An interface-file instance declaration
271
272
273
274
275
				-- Should be in scope by now, because we should
				-- have sucked in its interface-file definition
				-- So it will be replete with its unfolding etc
			  tcLookupId dfun_name
    )							`thenNF_Tc` \ dfun_id ->
276
    returnTc [InstInfo { iDFunId = dfun_id, iBinds = binds, iPrags = uprags }]
277
278
  where
    msg  = parens (ptext SLIT("the instance types do not agree with the functional dependencies of the class"))
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
\end{code}


%************************************************************************
%*									*
\subsection{Extracting generic instance declaration from class declarations}
%*									*
%************************************************************************

@getGenericInstances@ extracts the generic instance declarations from a class
declaration.  For exmaple

	class C a where
	  op :: a -> a
	
	  op{ x+y } (Inl v)   = ...
	  op{ x+y } (Inr v)   = ...
	  op{ x*y } (v :*: w) = ...
	  op{ 1   } Unit      = ...

gives rise to the instance declarations

	instance C (x+y) where
	  op (Inl v)   = ...
	  op (Inr v)   = ...
	
	instance C (x*y) where
	  op (v :*: w) = ...

	instance C 1 where
	  op Unit      = ...


\begin{code}
313
314
315
getGenericInstances :: [RenamedTyClDecl] -> TcM [InstInfo] 
getGenericInstances class_decls
  = mapTc get_generics class_decls		`thenTc` \ gen_inst_infos ->
316
317
318
    let
	gen_inst_info = concat gen_inst_infos
    in
319
320
321
    if null gen_inst_info then
	returnTc []
    else
322
323
324
325
    getDOptsTc						`thenTc`  \ dflags ->
    ioToTc (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances" 
		      (vcat (map pprInstInfo gen_inst_info)))	
							`thenNF_Tc_`
326
327
    returnTc gen_inst_info

328
329
330
331
get_generics decl@(ClassDecl {tcdMeths = Nothing})
  = returnTc []	-- Imported class decls

get_generics decl@(ClassDecl {tcdName = class_name, tcdMeths = Just def_methods, tcdLoc = loc})
332
  | null groups		
333
  = returnTc [] -- The comon case: no generic default methods
334

335
  | otherwise	-- A source class decl with generic default methods
336
337
  = recoverNF_Tc (returnNF_Tc [])				$
    tcAddDeclCtxt decl						$
338
    tcLookupClass class_name					`thenTc` \ clas ->
339
340

	-- Make an InstInfo out of each group
341
    mapTc (mkGenericInstance clas loc) groups		`thenTc` \ inst_infos ->
342
343
344
345
346
347
348

	-- Check that there is only one InstInfo for each type constructor
  	-- The main way this can fail is if you write
	--	f {| a+b |} ... = ...
	--	f {| x+y |} ... = ...
	-- Then at this point we'll have an InstInfo for each
    let
349
350
351
352
	tc_inst_infos :: [(TyCon, InstInfo)]
	tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]

	bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
sof's avatar
sof committed
353
			      group `lengthExceeds` 1]
354
	get_uniq (tc,_) = getUnique tc
355
356
357
358
359
    in
    mapTc (addErrTc . dupGenericInsts) bad_groups	`thenTc_`

	-- Check that there is an InstInfo for each generic type constructor
    let
360
	missing = genericTyCons `minusList` [tc | (tc,_) <- tc_inst_infos]
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
    in
    checkTc (null missing) (missingGenericInstances missing)	`thenTc_`

    returnTc inst_infos

  where
	-- Group the declarations by type pattern
	groups :: [(RenamedHsType, RenamedMonoBinds)]
	groups = assocElts (getGenericBinds def_methods)


---------------------------------
getGenericBinds :: RenamedMonoBinds -> Assoc RenamedHsType RenamedMonoBinds
  -- Takes a group of method bindings, finds the generic ones, and returns
  -- them in finite map indexed by the type parameter in the definition.

getGenericBinds EmptyMonoBinds    = emptyAssoc
getGenericBinds (AndMonoBinds m1 m2) 
  = plusAssoc_C AndMonoBinds (getGenericBinds m1) (getGenericBinds m2)

getGenericBinds (FunMonoBind id infixop matches loc)
382
383
384
  = mapAssoc wrap (foldl add emptyAssoc matches)
	-- Using foldl not foldr is vital, else
	-- we reverse the order of the bindings!
385
  where
386
    add env match = case maybeGenericMatch match of
387
388
389
390
391
392
		      Nothing		-> env
		      Just (ty, match') -> extendAssoc_C (++) env (ty, [match'])

    wrap ms = FunMonoBind id infixop ms loc

---------------------------------
393
mkGenericInstance :: Class -> SrcLoc
394
		  -> (RenamedHsType, RenamedMonoBinds)
395
		  -> TcM InstInfo
396

397
mkGenericInstance clas loc (hs_ty, binds)
398
399
400
401
  -- Make a generic instance declaration
  -- For example:	instance (C a, C b) => C (a+b) where { binds }

  = 	-- Extract the universally quantified type variables
402
403
404
405
    let
	sig_tvs = map UserTyVar (nameSetToList (extractHsTyVars hs_ty))
    in
    tcHsTyVars sig_tvs (kcHsSigType hs_ty)	$ \ tyvars ->
406
407

	-- Type-check the instance type, and check its form
408
    tcHsSigType GenPatCtxt hs_ty		`thenTc` \ inst_ty ->
409
410
411
412
    checkTc (validGenericInstanceType inst_ty)
	    (badGenericInstanceType binds)	`thenTc_`

	-- Make the dictionary function.
413
    newDFunName clas [inst_ty] loc		`thenNF_Tc` \ dfun_name ->
414
415
416
417
418
419
    let
	inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
	inst_tys   = [inst_ty]
	dfun_id    = mkDictFunId dfun_name clas tyvars inst_tys inst_theta
    in

420
    returnTc (InstInfo { iDFunId = dfun_id, 
421
		  	 iBinds = binds, iPrags = [] })
422
423
424
425
426
427
428
429
430
431
\end{code}


%************************************************************************
%*									*
\subsection{Type-checking instance declarations, pass 2}
%*									*
%************************************************************************

\begin{code}
432
tcInstDecls2 :: [InstInfo]
433
	     -> NF_TcM (LIE, TcMonoBinds)
434

435
tcInstDecls2 inst_decls
436
437
438
--  = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyMonoBinds)) inst_decls
  = foldr combine (returnNF_Tc (emptyLIE, EmptyMonoBinds)) 
          (map tcInstDecl2 inst_decls)
439
440
441
442
  where
    combine tc1 tc2 = tc1 	`thenNF_Tc` \ (lie1, binds1) ->
		      tc2	`thenNF_Tc` \ (lie2, binds2) ->
		      returnNF_Tc (lie1 `plusLIE` lie2,
sof's avatar
sof committed
443
				   binds1 `AndMonoBinds` binds2)
444
445
446
447
\end{code}

======= New documentation starts here (Sept 92)	 ==============

448
The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
449
450
451
452
453
454
455
456
457
458
459
460
461
462
the dictionary function for this instance declaration.	For example
\begin{verbatim}
	instance Foo a => Foo [a] where
		op1 x = ...
		op2 y = ...
\end{verbatim}
might generate something like
\begin{verbatim}
	dfun.Foo.List dFoo_a = let op1 x = ...
				   op2 y = ...
			       in
				   Dict [op1, op2]
\end{verbatim}

463
464
HOWEVER, if the instance decl has no context, then it returns a
bigger @HsBinds@ with declarations for each method.  For example
465
\begin{verbatim}
466
	instance Foo [a] where
467
468
469
470
471
		op1 x = ...
		op2 y = ...
\end{verbatim}
might produce
\begin{verbatim}
472
473
474
	dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
	const.Foo.op1.List a x = ...
	const.Foo.op2.List a y = ...
475
476
477
478
\end{verbatim}
This group may be mutually recursive, because (for example) there may
be no method supplied for op2 in which case we'll get
\begin{verbatim}
479
	const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
480
481
482
\end{verbatim}
that is, the default method applied to the dictionary at this type.

483
What we actually produce in either case is:
484

485
486
487
488
489
490
	AbsBinds [a] [dfun_theta_dicts]
		 [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
		 { d = (sd1,sd2, ..., op1, op2, ...)
		   op1 = ...
		   op2 = ...
	 	 }
491

492
493
The "maybe" says that we only ask AbsBinds to make global constant methods
if the dfun_theta is empty.
494

495
496
		
For an instance declaration, say,
497
498
499
500
501
502
503
504
505
506
507
508
509

	instance (C1 a, C2 b) => C (T a b) where
		...

where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
function whose type is

	(C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)

Notice that we pass it the superclass dictionaries at the instance type; this
is the ``Mark Jones optimisation''.  The stuff before the "=>" here
is the @dfun_theta@ below.

510
511
First comes the easy case of a non-local instance decl.

512

513
\begin{code}
514
tcInstDecl2 :: InstInfo -> NF_TcM (LIE, TcMonoBinds)
515
-- tcInstDecl2 is called *only* on InstInfos 
516

517
tcInstDecl2 (InstInfo { iDFunId = dfun_id, 
518
			iBinds = monobinds, iPrags = uprags })
519
  =	 -- Prime error recovery
520
521
522
    recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds))	$
    tcAddSrcLoc (getSrcLoc dfun_id)			   	$
    tcAddErrCtxt (instDeclCtxt (toHsType (idType dfun_id)))	$
523

524
525
	-- Instantiate the instance decl with tc-style type variables
    let
526
527
	(inst_tyvars, dfun_theta, clas, inst_tys) = tcSplitDFunTy (idType dfun_id)
    in
528
    tcInstSigTyVars InstTv inst_tyvars		`thenNF_Tc` \ inst_tyvars' ->
529
    let
530
	tenv	    = mkTopTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars')
531
532
533
	inst_tys'   = map (substTy tenv) inst_tys
	dfun_theta' = substTheta tenv dfun_theta
	origin	    = InstanceDeclOrigin
534

535
        (class_tyvars, sc_theta, _, op_items) = classBigSig clas
536

537
	sel_names = [idName sel_id | (sel_id, _) <- op_items]
538

539
        -- Instantiate the super-class context with inst_tys
540
	sc_theta' = substTheta (mkTopTyVarSubst class_tyvars inst_tys') sc_theta
541
542
543

	-- Find any definitions in monobinds that aren't from the class
	bad_bndrs = collectMonoBinders monobinds `minusList` sel_names
544
    in
545
546
547
	 -- Check that all the method bindings come from this class
    mapTc (addErrTc . badMethodErr clas) bad_bndrs		`thenNF_Tc_`

548
	 -- Create dictionary Ids from the specified instance contexts.
549
550
551
    newDicts origin sc_theta'			 `thenNF_Tc` \ sc_dicts ->
    newDicts origin dfun_theta'			 `thenNF_Tc` \ dfun_arg_dicts ->
    newDicts origin [mkClassPred clas inst_tys'] `thenNF_Tc` \ [this_dict] ->
552

553
    tcExtendTyVarEnvForMeths inst_tyvars inst_tyvars' (
554
555
556
	-- The type variable from the dict fun actually scope 
	-- over the bindings.  They were gotten from
	-- the original instance declaration
557
558
559

		-- Default-method Ids may be mentioned in synthesised RHSs,
		-- but they'll already be in the environment.
560

561
	mapAndUnzip3Tc (tcMethodBind clas origin inst_tyvars' inst_tys'
562
				     dfun_theta'
563
				     monobinds uprags True)
564
		       op_items
565
    )		 	`thenTc` \ (method_binds_s, insts_needed_s, meth_insts) ->
566

567
568
	-- Deal with SPECIALISE instance pragmas by making them
	-- look like SPECIALISE pragmas for the dfun
sof's avatar
sof committed
569
    let
570
	dfun_prags = [SpecSig (idName dfun_id) ty loc | SpecInstSig ty loc <- uprags]
sof's avatar
sof committed
571
572
    in
    tcExtendGlobalValEnv [dfun_id] (
573
574
	tcSpecSigs dfun_prags
    )					`thenTc` \ (prag_binds, prag_lie) ->
sof's avatar
sof committed
575

576
	-- Check the overloading constraints of the methods and superclasses
sof's avatar
sof committed
577
    let
578
		 -- These insts are in scope; quite a few, eh?
579
580
581
582
	avail_insts = [this_dict] ++
		      dfun_arg_dicts ++
		      sc_dicts ++
		      meth_insts
583

584
        methods_lie    = plusLIEs insts_needed_s
585
    in
586

587
	-- Simplify the constraints from methods
588
    tcAddErrCtxt methodCtxt (
589
      tcSimplifyCheck
590
		 (ptext SLIT("instance declaration context"))
591
		 inst_tyvars'
592
593
594
595
		 avail_insts
		 methods_lie
    )						 `thenTc` \ (const_lie1, lie_binds1) ->
    
596
597
	-- Figure out bindings for the superclass context
    tcAddErrCtxt superClassCtxt (
598
      tcSimplifyCheck
599
		 (ptext SLIT("instance declaration context"))
600
		 inst_tyvars'
601
602
		 dfun_arg_dicts		-- NB! Don't include this_dict here, else the sc_dicts
					-- get bound by just selecting from this_dict!!
603
604
605
606
		 (mkLIE sc_dicts)
    )						`thenTc` \ (const_lie2, lie_binds2) ->

    checkSigTyVars inst_tyvars' emptyVarSet	`thenNF_Tc` \ zonked_inst_tyvars ->
607

sof's avatar
sof committed
608
	-- Create the result bindings
609
    let
610
611
612
	local_dfun_id = setIdLocalExported dfun_id
		-- Reason for setIdLocalExported: see notes with MkId.mkDictFunId

sof's avatar
sof committed
613
        dict_constr   = classDataCon clas
614
615
	scs_and_meths = map instToId (sc_dicts ++ meth_insts)
	this_dict_id  = instToId this_dict
616
617
	inlines       | null dfun_arg_dicts = emptyNameSet
		      | otherwise	    = unitNameSet (idName dfun_id)
618
619
620
		-- Always inline the dfun; this is an experimental decision
		-- because it makes a big performance difference sometimes.
		-- Often it means we can do the method selection, and then
621
		-- inline the method as well.  Marcin's idea; see comments below.
622
623
624
625
		--
		-- BUT: don't inline it if it's a constant dictionary;
		-- we'll get all the benefit without inlining, and we get
		-- a **lot** of code duplication if we inline it
sof's avatar
sof committed
626
627
628

	dict_rhs
	  | null scs_and_meths
sof's avatar
sof committed
629
	  = 	-- Blatant special case for CCallable, CReturnable
sof's avatar
sof committed
630
631
632
633
634
		-- If the dictionary is empty then we should never
		-- select anything from it, so we make its RHS just
		-- emit an error message.  This in turn means that we don't
		-- mention the constructor, which doesn't exist for CCallable, CReturnable
		-- Hardly beautiful, but only three extra lines.
635
	    HsApp (TyApp (HsVar eRROR_ID) [idType this_dict_id])
636
		  (HsLit (HsString msg))
sof's avatar
sof committed
637
638

	  | otherwise	-- The common case
639
	  = mkHsConApp dict_constr inst_tys' (map HsVar scs_and_meths)
640
		-- We don't produce a binding for the dict_constr; instead we
641
642
643
		-- rely on the simplifier to unfold this saturated application
		-- We do this rather than generate an HsCon directly, because
		-- it means that the special cases (e.g. dictionary with only one
644
		-- member) are dealt with by the common MkId.mkDataConWrapId code rather
645
646
		-- than needing to be repeated here.

647
648
	  where
	    msg = _PK_ ("Compiler error: bad dictionary " ++ showSDoc (ppr clas))
649

sof's avatar
sof committed
650
	dict_bind    = VarMonoBind this_dict_id dict_rhs
651
	method_binds = andMonoBindList method_binds_s
sof's avatar
sof committed
652
653

	main_bind
sof's avatar
sof committed
654
	  = AbsBinds
655
		 zonked_inst_tyvars
656
		 (map instToId dfun_arg_dicts)
657
		 [(inst_tyvars', local_dfun_id, this_dict_id)] 
658
		 inlines
659
660
		 (lie_binds1	`AndMonoBinds` 
		  lie_binds2	`AndMonoBinds`
sof's avatar
sof committed
661
		  method_binds	`AndMonoBinds`
sof's avatar
sof committed
662
		  dict_bind)
663
    in
664
    returnTc (const_lie1 `plusLIE` const_lie2 `plusLIE` prag_lie,
sof's avatar
sof committed
665
	      main_bind `AndMonoBinds` prag_binds)
666
667
\end{code}

668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
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
		------------------------------
		Inlining dfuns unconditionally
		------------------------------

The code above unconditionally inlines dict funs.  Here's why.
Consider this program:

    test :: Int -> Int -> Bool
    test x y = (x,y) == (y,x) || test y x
    -- Recursive to avoid making it inline.

This needs the (Eq (Int,Int)) instance.  If we inline that dfun
the code we end up with is good:

    Test.$wtest =
	\r -> case ==# [ww ww1] of wild {
		PrelBase.False -> Test.$wtest ww1 ww;
		PrelBase.True ->
		  case ==# [ww1 ww] of wild1 {
		    PrelBase.False -> Test.$wtest ww1 ww;
		    PrelBase.True -> PrelBase.True [];
		  };
	    };
    Test.test = \r [w w1]
	    case w of w2 {
	      PrelBase.I# ww ->
		  case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
	    };

If we don't inline the dfun, the code is not nearly as good:

    (==) = case PrelTup.$fEq(,) PrelBase.$fEqInt PrelBase.$fEqInt of tpl {
	      PrelBase.:DEq tpl1 tpl2 -> tpl2;
	    };
    
    Test.$wtest =
	\r [ww ww1]
	    let { y = PrelBase.I#! [ww1]; } in
	    let { x = PrelBase.I#! [ww]; } in
	    let { sat_slx = PrelTup.(,)! [y x]; } in
	    let { sat_sly = PrelTup.(,)! [x y];
	    } in
	      case == sat_sly sat_slx of wild {
		PrelBase.False -> Test.$wtest ww1 ww;
		PrelBase.True -> PrelBase.True [];
	      };
    
    Test.test =
	\r [w w1]
	    case w of w2 {
	      PrelBase.I# ww ->
		  case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
	    };

Why doesn't GHC inline $fEq?  Because it looks big:

    PrelTup.zdfEqZ1T{-rcX-}
	= \ @ a{-reT-} :: * @ b{-reS-} :: *
            zddEq{-rf6-} _Ks :: {PrelBase.Eq{-23-} a{-reT-}}
            zddEq1{-rf7-} _Ks :: {PrelBase.Eq{-23-} b{-reS-}} ->
            let {
              zeze{-rf0-} _Kl :: (b{-reS-} -> b{-reS-} -> PrelBase.Bool{-3c-})
              zeze{-rf0-} = PrelBase.zeze{-01L-}@ b{-reS-} zddEq1{-rf7-} } in
            let {
              zeze1{-rf3-} _Kl :: (a{-reT-} -> a{-reT-} -> PrelBase.Bool{-3c-})
              zeze1{-rf3-} = PrelBase.zeze{-01L-} @ a{-reT-} zddEq{-rf6-} } in
            let {
              zeze2{-reN-} :: ((a{-reT-}, b{-reS-}) -> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
              zeze2{-reN-} = \ ds{-rf5-} _Ks :: (a{-reT-}, b{-reS-})
		               ds1{-rf4-} _Ks :: (a{-reT-}, b{-reS-}) ->
                  	     case ds{-rf5-}
                  	     of wild{-reW-} _Kd { (a1{-rf2-} _Ks, a2{-reZ-} _Ks) ->
                  	     case ds1{-rf4-}
                  	     of wild1{-reX-} _Kd { (b1{-rf1-} _Ks, b2{-reY-} _Ks) ->
                  	     PrelBase.zaza{-r4e-}
                  	       (zeze1{-rf3-} a1{-rf2-} b1{-rf1-})
                  	       (zeze{-rf0-} a2{-reZ-} b2{-reY-})
                  	     }
                  	     } } in     
            let {
              a1{-reR-} :: ((a{-reT-}, b{-reS-})-> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
              a1{-reR-} = \ a2{-reV-} _Ks :: (a{-reT-}, b{-reS-})
			    b1{-reU-} _Ks :: (a{-reT-}, b{-reS-}) ->
                    	  PrelBase.not{-r6I-} (zeze2{-reN-} a2{-reV-} b1{-reU-})
            } in
              PrelBase.zdwZCDEq{-r8J-} @ (a{-reT-}, b{-reS-}) a1{-reR-} zeze2{-reN-})

and it's not as bad as it seems, because it's further dramatically
simplified: only zeze2 is extracted and its body is simplified.

758

759
760
761
762
763
764
765
766
%************************************************************************
%*									*
\subsection{Error messages}
%*									*
%************************************************************************

\begin{code}
tcAddDeclCtxt decl thing_inside
767
  = tcAddSrcLoc (tcdLoc decl) 	$
768
769
770
    tcAddErrCtxt ctxt 	$
    thing_inside
  where
771
772
773
774
775
     thing = case decl of
	   	ClassDecl {}		  -> "class"
		TySynonym {}		  -> "type synonym"
		TyData {tcdND = NewType}  -> "newtype"
		TyData {tcdND = DataType} -> "data type"
776
777

     ctxt = hsep [ptext SLIT("In the"), text thing, 
778
		  ptext SLIT("declaration for"), quotes (ppr (tcdName decl))]
779
780
781
782
783
784
785

instDeclCtxt inst_ty = ptext SLIT("In the instance declaration for") <+> quotes doc
		     where
			doc = case inst_ty of
				HsForAllTy _ _ (HsPredTy pred) -> ppr pred
				HsPredTy pred	      	       -> ppr pred
				other			       -> ppr inst_ty	-- Don't expect this
786
787
\end{code}

788
\begin{code}
789
790
791
792
793
794
795
badGenericInstanceType binds
  = vcat [ptext SLIT("Illegal type pattern in the generic bindings"),
	  nest 4 (ppr binds)]

missingGenericInstances missing
  = ptext SLIT("Missing type patterns for") <+> pprQuotedList missing
	  
796
dupGenericInsts tc_inst_infos
797
  = vcat [ptext SLIT("More than one type pattern for a single generic type constructor:"),
798
	  nest 4 (vcat (map ppr_inst_ty tc_inst_infos)),
799
800
	  ptext SLIT("All the type patterns for a generic type constructor must be identical")
    ]
801
802
  where 
    ppr_inst_ty (tc,inst) = ppr (simpleInstInfoTy inst)
803

804
methodCtxt     = ptext SLIT("When checking the methods of an instance declaration")
805
superClassCtxt = ptext SLIT("When checking the super-classes of an instance declaration")
806
\end{code}