TcInstDcls.lhs 30 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
8
module TcInstDcls ( tcInstDecls1, tcIfaceInstDecls, 
		    tcInstDecls2, tcAddDeclCtxt ) where
9

10
#include "HsVersions.h"
11

12

13
import CmdLineOpts	( DynFlag(..) )
14

15
import HsSyn		( InstDecl(..), TyClDecl(..), HsType(..),
16
			  MonoBinds(..), HsExpr(..),  HsLit(..), Sig(..), HsTyVarBndr(..),
17
			  andMonoBindList, collectMonoBinders, 
18
			  isClassDecl, isSourceInstDecl, toHsType
sof's avatar
sof committed
19
			)
20
import RnHsSyn		( RenamedHsBinds, RenamedInstDecl, 
21
			  RenamedMonoBinds, RenamedTyClDecl, RenamedHsType, 
22
23
			  extractHsTyVars, maybeGenericMatch
			)
24
import TcHsSyn		( TcMonoBinds, mkHsConApp )
25
import TcBinds		( tcSpecSigs )
26
import TcClassDcl	( tcMethodBind, mkMethodBind, badMethodErr )
27
import TcRnMonad       
28
import TcMType		( tcInstType, checkValidTheta, checkValidInstHead, instTypeErr, 
29
30
			  checkAmbiguity, UserTypeCtxt(..), SourceTyCtxt(..) )
import TcType		( mkClassPred, mkTyVarTy, tcSplitForAllTys, tyVarsOfType,
31
			  tcSplitSigmaTy, getClassPredTys, tcSplitPredTy_maybe, mkTyVarTys,
32
			  TyVarDetails(..)
33
			)
34
import Inst		( InstOrigin(..), tcInstClassOp, newDicts, instToId, showLIE )
35
import TcDeriv		( tcDeriving )
36
import TcEnv		( tcExtendGlobalValEnv, 
37
38
			  tcLookupClass, tcExtendTyVarEnv2,
			  tcExtendInstEnv, tcExtendLocalInstEnv, tcLookupGlobalId,
39
 			  InstInfo(..), InstBindings(..), pprInstInfo, simpleInstInfoTyCon, 
40
			  simpleInstInfoTy, newDFunName
41
			)
42
import PprType		( pprClassPred )
43
import TcMonoType	( tcHsTyVars, kcHsSigType, tcHsType, tcHsSigType )
44
import TcUnify		( checkSigTyVars )
45
import TcSimplify	( tcSimplifyCheck, tcSimplifyTop )
46
import HscTypes		( DFunId )
47
import Subst		( mkTyVarSubst, substTheta, substTy )
48
import DataCon		( classDataCon )
49
import Class		( Class, classBigSig )
50
import Var		( idName, idType )
51
import NameSet		
52
import Id		( setIdLocalExported )
53
import MkId		( mkDictFunId, rUNTIME_ERROR_ID )
54
import FunDeps		( checkInstFDs )
55
import Generics		( validGenericInstanceType )
56
import Name		( getSrcLoc )
57
import NameSet		( unitNameSet, emptyNameSet, nameSetToList )
58
59
import TyCon		( TyCon )
import TysWiredIn	( genericTyCons )
60
61
import SrcLoc           ( SrcLoc )
import Unique		( Uniquable(..) )
62
import Util             ( lengthExceeds )
63
import BasicTypes	( NewOrData(..) )
64
import UnicodeUtil	( stringToUtf8 )
65
import ErrUtils		( dumpIfSet_dyn )
66
import ListSetOps	( Assoc, emptyAssoc, plusAssoc_C, mapAssoc, 
67
			  assocElts, extendAssoc_C, equivClassesByUniq, minusList
68
			)
69
import Maybe		( catMaybes )
70
import List		( partition )
71
import Outputable
72
import FastString
73
74
75
\end{code}

Typechecking instance declarations is done in two passes. The first
76
77
pass, made by @tcInstDecls1@, collects information to be used in the
second pass.
78
79
80
81
82
83
84
85

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.


86
87
Here is the overall algorithm.
Assume that we have an instance declaration
88

89
    instance c => k (t tvs) where b
90
91
92
93
94
95
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

\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}

148
149
150
151
152
153
154
155
156

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

Gather up the instance declarations from their various sources

157
\begin{code}
158
159
tcInstDecls1	-- Deal with both source-code and imported instance decls
   :: [RenamedTyClDecl]		-- For deriving stuff
160
   -> [RenamedInstDecl]		-- Source code instance decls
161
162
163
164
165
166
167
168
   -> TcM (TcGblEnv,		-- The full inst env
	   [InstInfo],		-- Source-code instance decls to process; 
				-- contains all dfuns for this module
	   RenamedHsBinds,	-- Supporting bindings for derived instances
	   FreeVars)		-- And the free vars of the derived code

tcInstDecls1 tycl_decls inst_decls
  = checkNoErrs $
169
170
	-- Stop if addInstInfos etc discovers any errors
	-- (they recover, so that we get more than one error each round)
171
172
173
174
175
176
177
178
    let
      (src_inst_decls, iface_inst_decls) = partition isSourceInstDecl inst_decls
    in

	-- (0) Deal with the imported instance decls
    tcIfaceInstDecls iface_inst_decls	`thenM` \ imp_dfuns ->
    tcExtendInstEnv imp_dfuns		$

179
   	-- (1) Do the ordinary instance declarations
180
    mappM tcLocalInstDecl1 src_inst_decls    `thenM` \ local_inst_infos ->
181

182
183
184
185
    let
	local_inst_info = catMaybes local_inst_infos
	clas_decls	= filter isClassDecl tycl_decls
    in
186
	-- (2) Instances from generic class declarations
187
    getGenericInstances clas_decls		`thenM` \ generic_inst_info -> 
188

189
	-- Next, construct the instance environment so far, consisting of
190
191
192
193
194
	--      a) imported instance decls (from this module)
	--	b) local instance decls
	--	c) generic instances
    tcExtendLocalInstEnv local_inst_info	$
    tcExtendLocalInstEnv generic_inst_info	$
195

196
197
198
199
	-- (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
200
	-- needs to know about all the instances possible; hence inst_env4
201
202
    tcDeriving tycl_decls			`thenM` \ (deriv_inst_info, deriv_binds, fvs) ->
    tcExtendLocalInstEnv deriv_inst_info	$
203

204
205
206
207
    getGblEnv					`thenM` \ gbl_env ->
    returnM (gbl_env, 
	     generic_inst_info ++ deriv_inst_info ++ local_inst_info,
	     deriv_binds, fvs)
208
\end{code} 
209

210
\begin{code}
211
tcLocalInstDecl1 :: RenamedInstDecl 
212
		 -> TcM (Maybe InstInfo)	-- Nothing if there was an error
213
214
215
216
217
218
219
220
221
222
	-- A source-file instance declaration
	-- Type-check all the stuff before the "where"
	--
	-- We 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] 
tcLocalInstDecl1 decl@(InstDecl poly_ty binds uprags Nothing src_loc)
  =	-- Prime error recovery, set source location
223
224
225
    recoverM (returnM Nothing)		$
    addSrcLoc src_loc			$
    addErrCtxt (instDeclCtxt poly_ty)	$
226

227
228
	-- Typecheck the instance type itself.  We can't use 
	-- tcHsSigType, because it's not a valid user type.
229
230
    kcHsSigType poly_ty			`thenM_`
    tcHsType poly_ty			`thenM` \ poly_ty' ->
231
    let
232
	(tyvars, theta, tau) = tcSplitSigmaTy poly_ty'
233
    in
234
235
    checkValidTheta InstThetaCtxt theta			`thenM_`
    checkAmbiguity tyvars theta (tyVarsOfType tau)	`thenM_`
236
    checkValidInstHead tau				`thenM` \ (clas,inst_tys) ->
237
    checkTc (checkInstFDs theta clas inst_tys)
238
239
	    (instTypeErr (pprClassPred clas inst_tys) msg)	`thenM_`
    newDFunName clas inst_tys src_loc				`thenM` \ dfun_name ->
240
241
    returnM (Just (InstInfo { iDFunId = mkDictFunId dfun_name tyvars theta clas inst_tys,
			      iBinds = VanillaInst binds uprags }))
242
243
  where
    msg  = parens (ptext SLIT("the instance types do not agree with the functional dependencies of the class"))
244
245
\end{code}

246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
Imported instance declarations

\begin{code}
tcIfaceInstDecls :: [RenamedInstDecl] -> TcM [DFunId]
-- Deal with the instance decls, 
tcIfaceInstDecls decls = mappM tcIfaceInstDecl decls

tcIfaceInstDecl :: RenamedInstDecl -> TcM DFunId
	-- An interface-file instance declaration
	-- 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
tcIfaceInstDecl decl@(InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
  = tcLookupGlobalId dfun_name
\end{code}

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

%************************************************************************
%*									*
\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}
294
295
getGenericInstances :: [RenamedTyClDecl] -> TcM [InstInfo] 
getGenericInstances class_decls
296
  = mappM get_generics class_decls		`thenM` \ gen_inst_infos ->
297
298
299
    let
	gen_inst_info = concat gen_inst_infos
    in
300
    if null gen_inst_info then
301
	returnM []
302
    else
303
304
305
306
307
    getDOpts						`thenM`  \ dflags ->
    ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances" 
	 	    (vcat (map pprInstInfo gen_inst_info)))	
							`thenM_`
    returnM gen_inst_info
308

309
get_generics decl@(ClassDecl {tcdMeths = Nothing})
310
  = returnM []	-- Imported class decls
311
312

get_generics decl@(ClassDecl {tcdName = class_name, tcdMeths = Just def_methods, tcdLoc = loc})
313
  | null groups		
314
  = returnM [] -- The comon case: no generic default methods
315

316
  | otherwise	-- A source class decl with generic default methods
317
318
319
  = recoverM (returnM [])				$
    tcAddDeclCtxt decl					$
    tcLookupClass class_name				`thenM` \ clas ->
320
321

	-- Make an InstInfo out of each group
322
    mappM (mkGenericInstance clas loc) groups		`thenM` \ inst_infos ->
323
324
325
326
327
328
329

	-- 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
330
331
332
333
	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
334
			      group `lengthExceeds` 1]
335
	get_uniq (tc,_) = getUnique tc
336
    in
337
    mappM (addErrTc . dupGenericInsts) bad_groups	`thenM_`
338
339
340

	-- Check that there is an InstInfo for each generic type constructor
    let
341
	missing = genericTyCons `minusList` [tc | (tc,_) <- tc_inst_infos]
342
    in
343
    checkTc (null missing) (missingGenericInstances missing)	`thenM_`
344

345
    returnM inst_infos
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362

  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)
363
364
365
  = mapAssoc wrap (foldl add emptyAssoc matches)
	-- Using foldl not foldr is vital, else
	-- we reverse the order of the bindings!
366
  where
367
    add env match = case maybeGenericMatch match of
368
369
370
371
372
373
		      Nothing		-> env
		      Just (ty, match') -> extendAssoc_C (++) env (ty, [match'])

    wrap ms = FunMonoBind id infixop ms loc

---------------------------------
374
mkGenericInstance :: Class -> SrcLoc
375
		  -> (RenamedHsType, RenamedMonoBinds)
376
		  -> TcM InstInfo
377

378
mkGenericInstance clas loc (hs_ty, binds)
379
380
381
382
  -- Make a generic instance declaration
  -- For example:	instance (C a, C b) => C (a+b) where { binds }

  = 	-- Extract the universally quantified type variables
383
384
385
386
    let
	sig_tvs = map UserTyVar (nameSetToList (extractHsTyVars hs_ty))
    in
    tcHsTyVars sig_tvs (kcHsSigType hs_ty)	$ \ tyvars ->
387
388

	-- Type-check the instance type, and check its form
389
    tcHsSigType GenPatCtxt hs_ty		`thenM` \ inst_ty ->
390
    checkTc (validGenericInstanceType inst_ty)
391
	    (badGenericInstanceType binds)	`thenM_`
392
393

	-- Make the dictionary function.
394
    newDFunName clas [inst_ty] loc		`thenM` \ dfun_name ->
395
396
    let
	inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
397
	dfun_id    = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
398
399
    in

400
    returnM (InstInfo { iDFunId = dfun_id, iBinds = VanillaInst binds [] })
401
402
403
404
405
406
407
408
409
410
\end{code}


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

\begin{code}
411
tcInstDecls2 :: [InstInfo] -> TcM TcMonoBinds
412
tcInstDecls2 inst_decls
413
414
  = mappM tcInstDecl2 inst_decls	`thenM` \ binds_s ->
    returnM (andMonoBindList binds_s)
415
416
417
418
\end{code}

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

419
The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
420
421
422
423
424
425
426
427
428
429
430
431
432
433
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}

434
435
HOWEVER, if the instance decl has no context, then it returns a
bigger @HsBinds@ with declarations for each method.  For example
436
\begin{verbatim}
437
	instance Foo [a] where
438
439
440
441
442
		op1 x = ...
		op2 y = ...
\end{verbatim}
might produce
\begin{verbatim}
443
444
445
	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 = ...
446
447
448
449
\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}
450
	const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
451
452
453
\end{verbatim}
that is, the default method applied to the dictionary at this type.

454
What we actually produce in either case is:
455

456
457
458
459
460
461
	AbsBinds [a] [dfun_theta_dicts]
		 [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
		 { d = (sd1,sd2, ..., op1, op2, ...)
		   op1 = ...
		   op2 = ...
	 	 }
462

463
464
The "maybe" says that we only ask AbsBinds to make global constant methods
if the dfun_theta is empty.
465

466
467
		
For an instance declaration, say,
468
469
470
471
472
473
474
475
476
477
478
479
480

	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.

481
482
First comes the easy case of a non-local instance decl.

483

484
\begin{code}
485
tcInstDecl2 :: InstInfo -> TcM TcMonoBinds
486

487
tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds })
488
  =	 -- Prime error recovery
489
490
491
    recoverM (returnM EmptyMonoBinds)	$
    addSrcLoc (getSrcLoc dfun_id)			   	$
    addErrCtxt (instDeclCtxt (toHsType (idType dfun_id)))	$
492
493
494
495
496
497
498
    let
	inst_ty = idType dfun_id
	(inst_tyvars, _) = tcSplitForAllTys inst_ty
		-- The tyvars of the instance decl scope over the 'where' part
		-- Those tyvars are inside the dfun_id's type, which is a bit
		-- bizarre, but OK so long as you realise it!
    in
499

500
	-- Instantiate the instance decl with tc-style type variables
501
    tcInstType InstTv inst_ty		`thenM` \ (inst_tyvars', dfun_theta', inst_head') ->
502
    let
503
504
	Just pred         = tcSplitPredTy_maybe inst_head'
	(clas, inst_tys') = getClassPredTys pred
505
        (class_tyvars, sc_theta, _, op_items) = classBigSig clas
506

507
        -- Instantiate the super-class context with inst_tys
508
509
	sc_theta' = substTheta (mkTyVarSubst class_tyvars inst_tys') sc_theta
	origin	  = InstanceDeclOrigin
510
    in
511
	 -- Create dictionary Ids from the specified instance contexts.
512
513
514
    newDicts origin sc_theta'		`thenM` \ sc_dicts ->
    newDicts origin dfun_theta'		`thenM` \ dfun_arg_dicts ->
    newDicts origin [pred] 		`thenM` \ [this_dict] ->
515
516
		-- Default-method Ids may be mentioned in synthesised RHSs,
		-- but they'll already be in the environment.
517

518
519
520
521
	------------------
	-- Typecheck the methods
    let		-- These insts are in scope; quite a few, eh?
	avail_insts = [this_dict] ++ dfun_arg_dicts ++ sc_dicts
522
    in
523
524
525
    tcMethods clas inst_tyvars inst_tyvars' 
	      dfun_theta' inst_tys' avail_insts 
	      op_items binds		`thenM` \ (meth_ids, meth_binds) ->
526

527
	-- Figure out bindings for the superclass context
528
    tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts	
529
		`thenM` \ (zonked_inst_tyvars, sc_binds_inner, sc_binds_outer) ->
530

531
	-- Deal with 'SPECIALISE instance' pragmas by making them
532
533
	-- look like SPECIALISE pragmas for the dfun
    let
534
535
536
	uprags = case binds of
		       VanillaInst _ uprags -> uprags
		       other		    -> []
537
	spec_prags = [ SpecSig (idName dfun_id) ty loc
538
539
		     | SpecInstSig ty loc <- uprags ]
	xtve = inst_tyvars `zip` inst_tyvars'
540
541
    in
    tcExtendGlobalValEnv [dfun_id] (
542
	tcExtendTyVarEnv2 xtve		$
543
	tcSpecSigs spec_prags
544
    )					`thenM` \ prag_binds ->
545

sof's avatar
sof committed
546
	-- Create the result bindings
547
    let
sof's avatar
sof committed
548
        dict_constr   = classDataCon clas
549
	scs_and_meths = map instToId sc_dicts ++ meth_ids
550
	this_dict_id  = instToId this_dict
551
552
	inlines       | null dfun_arg_dicts = emptyNameSet
		      | otherwise	    = unitNameSet (idName dfun_id)
553
554
555
		-- 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
556
		-- inline the method as well.  Marcin's idea; see comments below.
557
558
559
560
		--
		-- 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
561
562
		--
		--	See Note [Inline dfuns] below
sof's avatar
sof committed
563
564
565

	dict_rhs
	  | null scs_and_meths
sof's avatar
sof committed
566
	  = 	-- Blatant special case for CCallable, CReturnable
sof's avatar
sof committed
567
568
569
570
571
		-- 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.
572
	    HsApp (TyApp (HsVar rUNTIME_ERROR_ID) [idType this_dict_id])
573
		  (HsLit (HsStringPrim (mkFastString (stringToUtf8 msg))))
sof's avatar
sof committed
574
575

	  | otherwise	-- The common case
576
	  = mkHsConApp dict_constr inst_tys' (map HsVar scs_and_meths)
577
		-- We don't produce a binding for the dict_constr; instead we
578
579
580
		-- 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
581
		-- member) are dealt with by the common MkId.mkDataConWrapId code rather
582
583
		-- than needing to be repeated here.

584
	  where
585
	    msg = "Compiler error: bad dictionary " ++ showSDoc (ppr clas)
586

587
	dict_bind  = VarMonoBind this_dict_id dict_rhs
588
	all_binds  = sc_binds_inner `AndMonoBinds` meth_binds `AndMonoBinds` dict_bind
589
590
591
592

	main_bind = AbsBinds
		 	 zonked_inst_tyvars
		 	 (map instToId dfun_arg_dicts)
593
		 	 [(inst_tyvars', dfun_id, this_dict_id)] 
594
		 	 inlines all_binds
595
    in
596
597
    showLIE "instance" 		`thenM_`
    returnM (main_bind `AndMonoBinds` prag_binds `AndMonoBinds` sc_binds_outer)
598
599
600
601
602
603
604
605
606
607
608
609


tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys' 
	  avail_insts op_items (VanillaInst monobinds uprags)
  = 	-- Check that all the method bindings come from this class
    let
	sel_names = [idName sel_id | (sel_id, _) <- op_items]
	bad_bndrs = collectMonoBinders monobinds `minusList` sel_names
    in
    mappM (addErrTc . badMethodErr clas) bad_bndrs	`thenM_`

	-- Make the method bindings
610
611
612
    let
	mk_method_bind = mkMethodBind InstanceDeclOrigin clas inst_tys' monobinds
    in
613
    mapAndUnzipM mk_method_bind op_items 	`thenM` \ (meth_insts, meth_infos) ->
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631

	-- And type check them
	-- It's really worth making meth_insts available to the tcMethodBind
	-- Consider	instance Monad (ST s) where
	--		  {-# INLINE (>>) #-}
	--		  (>>) = ...(>>=)...
	-- If we don't include meth_insts, we end up with bindings like this:
	--	rec { dict = MkD then bind ...
	--	      then = inline_me (... (GHC.Base.>>= dict) ...)
	--	      bind = ... }
	-- The trouble is that (a) 'then' and 'dict' are mutually recursive, 
	-- and (b) the inline_me prevents us inlining the >>= selector, which
	-- would unravel the loop.  Result: (>>) ends up as a loop breaker, and
	-- is not inlined across modules. Rather ironic since this does not
	-- happen without the INLINE pragma!  
	--
	-- Solution: make meth_insts available, so that 'then' refers directly
	-- 	     to the local 'bind' rather than going via the dictionary.
632
633
634
635
636
637
638
639
640
641
642
643
	--
	-- BUT WATCH OUT!  If the method type mentions the class variable, then
	-- this optimisation is not right.  Consider
	--	class C a where
	--	  op :: Eq a => a
	--
	--	instance C Int where
	--	  op = op
	-- The occurrence of 'op' on the rhs gives rise to a constraint
	--	op at Int
	-- The trouble is that the 'meth_inst' for op, which is 'available', also
	-- looks like 'op at Int'.  But they are not the same.
644
    let
645
	all_insts      = avail_insts ++ catMaybes meth_insts
646
647
648
649
	xtve	       = inst_tyvars `zip` inst_tyvars'
	tc_method_bind = tcMethodBind xtve inst_tyvars' dfun_theta' all_insts uprags 
    in
    mapM tc_method_bind meth_infos		`thenM` \ meth_binds_s ->
650
   
651
652
    returnM ([meth_id | (_,meth_id,_) <- meth_infos], 
	     andMonoBindList meth_binds_s)
653
654
655
656
657


-- Derived newtype instances
tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys' 
	  avail_insts op_items (NewTypeDerived rep_tys)
658
659
  = getInstLoc InstanceDeclOrigin		`thenM` \ inst_loc ->
    mapAndUnzip3M (do_one inst_loc) op_items	`thenM` \ (meth_ids, meth_binds, rhs_insts) ->
660
661
662
    
    tcSimplifyCheck
	 (ptext SLIT("newtype derived instance"))
663
	 inst_tyvars' avail_insts rhs_insts	`thenM` \ lie_binds ->
664
665
666
667
668
669
670

	-- I don't think we have to do the checkSigTyVars thing

    returnM (meth_ids, lie_binds `AndMonoBinds` andMonoBindList meth_binds)

  where
    do_one inst_loc (sel_id, _)
671
672
673
674
675
	= -- The binding is like "op @ NewTy = op @ RepTy"
		-- Make the *binder*, like in mkMethodBind
	  tcInstClassOp inst_loc sel_id inst_tys'	`thenM` \ meth_inst ->

		-- Make the *occurrence on the rhs*
676
	  tcInstClassOp inst_loc sel_id rep_tys'	`thenM` \ rhs_inst ->
677
678
679
	  let
	     meth_id = instToId meth_inst
	  in
680
	  return (meth_id, VarMonoBind meth_id (HsVar (instToId rhs_inst)), rhs_inst)
681
682
683
684

	-- Instantiate rep_tys with the relevant type variables
    rep_tys' = map (substTy subst) rep_tys
    subst    = mkTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars')
685
686
\end{code}

687
688
Note: [Superclass loops]
~~~~~~~~~~~~~~~~~~~~~~~~~
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
We have to be very, very careful when generating superclasses, lest we
accidentally build a loop. Here's an example:

  class S a

  class S a => C a where { opc :: a -> a }
  class S b => D b where { opd :: b -> b }
  
  instance C Int where
     opc = opd
  
  instance D Int where
     opd = opc

From (instance C Int) we get the constraint set {ds1:S Int, dd:D Int}
Simplifying, we may well get:
	$dfCInt = :C ds1 (opd dd)
	dd  = $dfDInt
	ds1 = $p1 dd
Notice that we spot that we can extract ds1 from dd.  

Alas!  Alack! We can do the same for (instance D Int):

	$dfDInt = :D ds2 (opc dc)
	dc  = $dfCInt
	ds2 = $p1 dc

And now we've defined the superclass in terms of itself.


Solution: treat the superclass context separately, and simplify it
all the way down to nothing on its own.  Don't toss any 'free' parts
out to be simplified together with other bits of context.
Hence the tcSimplifyTop below.

At a more basic level, don't include this_dict in the context wrt
which we simplify sc_dicts, else sc_dicts get bound by just selecting
from this_dict!!

\begin{code}
tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts
730
731
732
733
  = addErrCtxt superClassCtxt 	$
    getLIE (tcSimplifyCheck doc inst_tyvars'
			    dfun_arg_dicts
			    sc_dicts)		`thenM` \ (sc_binds1, sc_lie) ->
734
735

	-- It's possible that the superclass stuff might have done unification
736
    checkSigTyVars inst_tyvars' 	`thenM` \ zonked_inst_tyvars ->
737
738
739

	-- We must simplify this all the way down 
	-- lest we build superclass loops
740
	-- See Note [Superclass loops] above
741
    tcSimplifyTop sc_lie		`thenM` \ sc_binds2 ->
742

743
    returnM (zonked_inst_tyvars, sc_binds1, sc_binds2)
744
745
746

  where
    doc = ptext SLIT("instance declaration superclass context")
747
748
\end{code}

749

750
		------------------------------
751
	[Inline dfuns] Inlining dfuns unconditionally
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
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
		------------------------------

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.

840

841
842
843
844
845
846
847
848
%************************************************************************
%*									*
\subsection{Error messages}
%*									*
%************************************************************************

\begin{code}
tcAddDeclCtxt decl thing_inside
849
850
  = addSrcLoc (tcdLoc decl) 	$
    addErrCtxt ctxt 	$
851
852
    thing_inside
  where
853
854
855
856
857
     thing = case decl of
	   	ClassDecl {}		  -> "class"
		TySynonym {}		  -> "type synonym"
		TyData {tcdND = NewType}  -> "newtype"
		TyData {tcdND = DataType} -> "data type"
858
859

     ctxt = hsep [ptext SLIT("In the"), text thing, 
860
		  ptext SLIT("declaration for"), quotes (ppr (tcdName decl))]
861
862
863
864
865
866
867

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
868
869
\end{code}

870
\begin{code}
871
872
873
874
875
876
877
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
	  
878
dupGenericInsts tc_inst_infos
879
  = vcat [ptext SLIT("More than one type pattern for a single generic type constructor:"),
880
	  nest 4 (vcat (map ppr_inst_ty tc_inst_infos)),
881
882
	  ptext SLIT("All the type patterns for a generic type constructor must be identical")
    ]
883
884
  where 
    ppr_inst_ty (tc,inst) = ppr (simpleInstInfoTy inst)
885

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