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

\begin{code}
7
module TcClassDcl ( tcClassDecl1, tcClassDecls2, 
8
		    MethodSpec, tcMethodBind, mkMethodBind, badMethodErr
9
		  ) where
10

11
#include "HsVersions.h"
12

13
import HsSyn		( TyClDecl(..), Sig(..), MonoBinds(..),
14
			  HsExpr(..), HsLit(..), Pat(WildPat),
15
			  mkSimpleMatch, andMonoBinds, andMonoBindList, 
16
			  isClassOpSig, isPragSig, 
17
			  placeHolderType
18
			)
19
import BasicTypes	( RecFlag(..), StrictnessMark(..) )
20
import RnHsSyn		( RenamedTyClDecl, RenamedSig,
sof's avatar
sof committed
21
			  RenamedClassOpSig, RenamedMonoBinds,
22
			  maybeGenericMatch
23
			)
24
import RnEnv		( lookupSysName )
25
import TcHsSyn		( TcMonoBinds )
26

27
import Inst		( Inst, InstOrigin(..), instToId, newDicts, newMethod )
28
29
30
import TcEnv		( TyThingDetails(..), 
			  tcLookupClass, tcExtendTyVarEnv2, 
			  tcExtendTyVarEnv
sof's avatar
sof committed
31
			)
32
import TcTyDecls	( tcMkDataCon )
33
34
35
import TcBinds		( tcMonoBinds )
import TcMonoType	( TcSigInfo(..), tcHsType, tcHsTheta, mkTcSig )
import TcSimplify	( tcSimplifyCheck )
36
import TcUnify		( checkSigTyVars, sigCtxt )
37
import TcMType		( tcInstTyVars )
38
import TcType		( Type, TyVarDetails(..), TcType, TcThetaType, TcTyVar, 
39
			  mkTyVarTys, mkPredTys, mkClassPred, tcSplitSigmaTy, tcSplitFunTys,
40
41
			  tcIsTyVarTy, tcSplitTyConApp_maybe, tcSplitForAllTys, tcSplitPhiTy,
			  getClassPredTys_maybe, mkPhiTy
42
			)
43
import TcRnMonad
44
import Generics		( mkGenericRhs )
45
import PrelInfo		( nO_METHOD_BINDING_ERROR_ID )
46
import Class		( classTyVars, classBigSig, classTyCon, 
47
			  Class, ClassOpItem, DefMeth (..) )
48
import TyCon		( tyConGenInfo )
49
import Subst		( substTyWith )
50
import MkId		( mkDictSelId, mkDefaultMethodId )
51
import Id		( Id, idType, idName, mkUserLocal, setIdLocalExported, setInlinePragma )
52
import Name		( Name, NamedThing(..) )
53
import NameEnv		( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv )
54
import NameSet		( emptyNameSet, unitNameSet )
55
56
import OccName		( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc, 
			  mkSuperDictSelOcc, reportIfUnused )
sof's avatar
sof committed
57
import Outputable
58
import Var		( TyVar )
59
import CmdLineOpts
60
import UnicodeUtil	( stringToUtf8 )
61
import ErrUtils		( dumpIfSet )
62
import Util		( count, lengthIs, isSingleton )
63
64
import Maybes		( seqMaybe )
import Maybe		( isJust )
65
import FastString
66
67
\end{code}

68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102


Dictionary handling
~~~~~~~~~~~~~~~~~~~
Every class implicitly declares a new data type, corresponding to dictionaries
of that class. So, for example:

	class (D a) => C a where
	  op1 :: a -> a
	  op2 :: forall b. Ord b => a -> b -> b

would implicitly declare

	data CDict a = CDict (D a)	
			     (a -> a)
			     (forall b. Ord b => a -> b -> b)

(We could use a record decl, but that means changing more of the existing apparatus.
One step at at time!)

For classes with just one superclass+method, we use a newtype decl instead:

	class C a where
	  op :: forallb. a -> b -> b

generates

	newtype CDict a = CDict (forall b. a -> b -> b)

Now DictTy in Type is just a form of type synomym: 
	DictTy c t = TyConTy CDict `AppTy` t

Death to "ExpandingDicts".


103
104
105
106
107
108
109
%************************************************************************
%*									*
\subsection{Type checking}
%*									*
%************************************************************************

\begin{code}
110

111
112
tcClassDecl1 :: RenamedTyClDecl -> TcM (Name, TyThingDetails)
tcClassDecl1 (ClassDecl {tcdCtxt = context, tcdName = class_name,
113
114
			 tcdTyVars = tyvar_names, tcdFDs = fundeps,
			 tcdSigs = class_sigs, tcdMeths = def_methods,
115
			 tcdLoc = src_loc})
116
  = 	-- LOOK THINGS UP IN THE ENVIRONMENT
117
    tcLookupClass class_name				`thenM` \ clas ->
118
    let
119
120
121
	tyvars     = classTyVars clas
	op_sigs    = filter isClassOpSig class_sigs
	op_names   = [n | ClassOpSig n _ _ _ <- op_sigs]
122
    in
123
124
    tcExtendTyVarEnv tyvars				$ 

125
    checkDefaultBinds clas op_names def_methods		`thenM` \ mb_dm_env ->
126
	
127
	-- CHECK THE CONTEXT
128
129
130
	-- The renamer has already checked that the context mentions
	-- only the type variable of the class decl.
	-- Context is already kind-checked
131
    tcHsTheta context					`thenM` \ sc_theta ->
132

133
	-- CHECK THE CLASS SIGNATURES,
134
    mappM (tcClassSig clas tyvars mb_dm_env) op_sigs	`thenM` \ sig_stuff ->
135

136
	-- MAKE THE CLASS DETAILS
137
138
    lookupSysName class_name mkClassTyConOcc 		`thenM` \ tycon_name ->
    lookupSysName class_name mkClassDataConOcc	 	`thenM` \ datacon_name ->
139
140
141
142
143
144
145
146
147
    mapM (lookupSysName class_name . mkSuperDictSelOcc) 
	 [1..length context]				`thenM` \ sc_sel_names ->
      -- We number off the superclass selectors, 1, 2, 3 etc so that we 
      -- can construct names for the selectors.  Thus
      --      class (C a, C b) => D a b where ...
      -- gives superclass selectors
      --      D_sc1, D_sc2
      -- (We used to call them D_C, but now we can have two different
      --  superclasses both called C!)
148
    let
149
	(op_tys, op_items) = unzip sig_stuff
150
        sc_tys		   = mkPredTys sc_theta
151
	dict_component_tys = sc_tys ++ op_tys
152
        sc_sel_ids	   = [mkDictSelId sc_name clas | sc_name <- sc_sel_names]
153
    in
154
155
156
157
158
159
160
161
    tcMkDataCon datacon_name
		[{- No strictness -}]
		[{- No labelled fields -}]
		tyvars [{-No context-}]
		[{-No existential tyvars-}] [{-Or context-}]
		dict_component_tys
		(classTyCon clas)			`thenM` \ dict_con ->

162
    returnM (class_name, ClassDetails sc_theta sc_sel_ids op_items dict_con tycon_name)
163
\end{code}
164

165
\begin{code}
166
167
checkDefaultBinds :: Class -> [Name] -> Maybe RenamedMonoBinds
		  -> TcM (Maybe (NameEnv Bool))
168
169
170
171
172
	-- The returned environment says
	--	x not in env => no default method
	--	x -> True    => generic default method
	--	x -> False   => polymorphic default method

173
174
175
176
177
  -- Check default bindings
  -- 	a) must be for a class op for this class
  --	b) must be all generic or all non-generic
  -- and return a mapping from class-op to DefMeth info

178
179
  -- But do all this only for source binds

180
checkDefaultBinds clas ops Nothing
181
  = returnM Nothing
182
183

checkDefaultBinds clas ops (Just mbs)
184
185
  = go mbs	`thenM` \ dm_env ->
    returnM (Just dm_env)
186
  where
187
    go EmptyMonoBinds = returnM emptyNameEnv
188

189
    go (AndMonoBinds b1 b2)
190
191
192
      = go b1	`thenM` \ dm_info1 ->
        go b2	`thenM` \ dm_info2 ->
        returnM (dm_info1 `plusNameEnv` dm_info2)
193

194
    go (FunMonoBind op _ matches loc)
195
      = addSrcLoc loc					$
196
197

  	-- Check that the op is from this class
198
	checkTc (op `elem` ops) (badMethodErr clas op)		`thenM_`
199
200

   	-- Check that all the defns ar generic, or none are
201
	checkTc (all_generic || none_generic) (mixedGenericErr op)	`thenM_`
202

203
	returnM (unitNameEnv op all_generic)
204
      where
205
	n_generic    = count (isJust . maybeGenericMatch) matches
206
	none_generic = n_generic == 0
sof's avatar
sof committed
207
	all_generic  = matches `lengthIs` n_generic
208
209
210
211
\end{code}


\begin{code}
212
tcClassSig :: Class	    		-- ...ditto...
213
	   -> [TyVar]		 	-- The class type variable, used for error check only
214
215
	   -> Maybe (NameEnv Bool)	-- Info about default methods; 
					--	Nothing => imported class defn with no method binds
216
	   -> RenamedClassOpSig
217
	   -> TcM (Type,		-- Type of the method
218
219
		     ClassOpItem)	-- Selector Id, default-method Id, True if explicit default binding

220
221
222
223
-- This warrants an explanation: we need to separate generic
-- default methods and default methods later on in the compiler
-- so we distinguish them in checkDefaultBinds, and pass this knowledge in the
-- Class.DefMeth data structure. 
224

225
tcClassSig clas clas_tyvars maybe_dm_env
226
	   (ClassOpSig op_name sig_dm op_ty src_loc)
227
  = addSrcLoc src_loc $
228
229
230

	-- Check the type signature.  NB that the envt *already has*
	-- bindings for the type variables; see comments in TcTyAndClassDcls.
231
    tcHsType op_ty			`thenM` \ local_ty ->
232

233
    let
234
	theta = [mkClassPred clas (mkTyVarTys clas_tyvars)]
235

236
	-- Build the selector id and default method id
237
238
239
240
	sel_id = mkDictSelId op_name clas
	DefMeth dm_name = sig_dm

	dm_info = case maybe_dm_env of
241
		    Nothing     -> sig_dm
242
243
244
245
246
		    Just dm_env -> mk_src_dm_info dm_env

	mk_src_dm_info dm_env = case lookupNameEnv dm_env op_name of
				   Nothing    -> NoDefMeth
				   Just True  -> GenDefMeth
247
				   Just False -> DefMeth dm_name
248
    in
249
    returnM (local_ty, (sel_id, dm_info))
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
\end{code}


%************************************************************************
%*									*
\subsection[Default methods]{Default methods}
%*									*
%************************************************************************

The default methods for a class are each passed a dictionary for the
class, so that they get access to the other methods at the same type.
So, given the class decl
\begin{verbatim}
class Foo a where
	op1 :: a -> Bool
	op2 :: Ord b => a -> b -> b -> b

	op1 x = True
	op2 x y z = if (op1 x) && (y < z) then y else z
\end{verbatim}
we get the default methods:
\begin{verbatim}
defm.Foo.op1 :: forall a. Foo a => a -> Bool
defm.Foo.op1 = /\a -> \dfoo -> \x -> True

275
276
277
278
279
defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
		  if (op1 a dfoo x) && (< b dord y z) then y else z
\end{verbatim}

280
281
282
283
284
285
286
287
288
289
290
When we come across an instance decl, we may need to use the default
methods:
\begin{verbatim}
instance Foo Int where {}
\end{verbatim}
gives
\begin{verbatim}
const.Foo.Int.op1 :: Int -> Bool
const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int

const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
291
const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
292
293
294
295
296
297

dfun.Foo.Int :: Foo Int
dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
\end{verbatim}
Notice that, as with method selectors above, we assume that dictionary
application is curried, so there's no need to mention the Ord dictionary
298
299
in const.Foo.Int.op2 (or the type variable).

300
301
302
303
304
305
306
307
\begin{verbatim}
instance Foo a => Foo [a] where {}

dfun.Foo.List :: forall a. Foo a -> Foo [a]
dfun.Foo.List
  = /\ a -> \ dfoo_a ->
    let rec
	op1 = defm.Foo.op1 [a] dfoo_list
308
	op2 = defm.Foo.op2 [a] dfoo_list
309
310
311
312
313
	dfoo_list = (op1, op2)
    in
	dfoo_list
\end{verbatim}

314
315
316
The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
each local class decl.

317
\begin{code}
318
tcClassDecls2 :: [RenamedTyClDecl] -> TcM (TcMonoBinds, [Id])
319

320
tcClassDecls2 decls
321
  = foldr combine
322
	  (returnM (EmptyMonoBinds, []))
323
324
	  [tcClassDecl2 cls_decl | cls_decl@(ClassDecl {tcdMeths = Just _}) <- decls] 
		-- The 'Just' picks out source ClassDecls
325
  where
326
327
328
329
    combine tc1 tc2 = tc1 `thenM` \ (binds1, ids1) ->
		      tc2 `thenM` \ (binds2, ids2) ->
		      returnM (binds1 `AndMonoBinds` binds2,
			       ids1 ++ ids2)
330
\end{code}
331

332
333
@tcClassDecl2@ generates bindings for polymorphic default methods
(generic default methods have by now turned into instance declarations)
334

335
336
\begin{code}
tcClassDecl2 :: RenamedTyClDecl		-- The class declaration
337
	     -> TcM (TcMonoBinds, [Id])
338

339
340
341
tcClassDecl2 (ClassDecl {tcdName = class_name, tcdSigs = sigs, 
			 tcdMeths = Just default_binds, tcdLoc = src_loc})
  = 	-- The 'Just' picks out source ClassDecls
342
343
344
    recoverM (returnM (EmptyMonoBinds, []))	$ 
    addSrcLoc src_loc		   			$
    tcLookupClass class_name				`thenM` \ clas ->
345
346
347
348
349
350
351
352
353
354
355
356
357
358

	-- We make a separate binding for each default method.
	-- At one time I used a single AbsBinds for all of them, thus
	-- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
	-- But that desugars into
	--	ds = \d -> (..., ..., ...)
	--	dm1 = \d -> case ds d of (a,b,c) -> a
	-- And since ds is big, it doesn't get inlined, so we don't get good
	-- default methods.  Better to make separate AbsBinds for each
    let
	(tyvars, _, _, op_items) = classBigSig clas
	prags 			 = filter isPragSig sigs
	tc_dm			 = tcDefMeth clas tyvars default_binds prags
    in
359
    mapAndUnzipM tc_dm op_items	`thenM` \ (defm_binds, dm_ids_s) ->
360

361
    returnM (andMonoBindList defm_binds, concat dm_ids_s)
362
    
363

364
365
tcDefMeth clas tyvars binds_in prags (_, NoDefMeth)  = returnM (EmptyMonoBinds, [])
tcDefMeth clas tyvars binds_in prags (_, GenDefMeth) = returnM (EmptyMonoBinds, [])
366
367
368
369
370
371
372
	-- Generate code for polymorphic default methods only
	-- (Generic default methods have turned into instance decls by now.)
	-- This is incompatible with Hugs, which expects a polymorphic 
	-- default method for every class op, regardless of whether or not 
	-- the programmer supplied an explicit default decl for the class.  
	-- (If necessary we can fix that, but we don't have a convenient Id to hand.)

373
tcDefMeth clas tyvars binds_in prags op_item@(sel_id, DefMeth dm_name)
374
  = tcInstTyVars ClsTv tyvars		`thenM` \ (clas_tyvars, inst_tys, _) ->
375
    let
376
377
378
379
380
381
382
383
	dm_ty = idType sel_id	-- Same as dict selector!
          -- The default method's type should really come from the
          -- iface file, since it could be usage-generalised, but this
          -- requires altering the mess of knots in TcModule and I'm
          -- too scared to do that.  Instead, I have disabled generalisation
          -- of types of default methods (and dict funs) by annotating them
          -- TyGenNever (in MkId).  Ugh!  KSW 1999-09.

384
        theta       = [mkClassPred clas inst_tys]
385
386
	local_dm_id = mkDefaultMethodId dm_name dm_ty
	xtve 	    = tyvars `zip` clas_tyvars
387
    in
388
    newDicts origin theta 				`thenM` \ [this_dict] ->
389

390
    mkMethodBind origin clas inst_tys binds_in op_item	`thenM` \ (_, meth_info) ->
391
392
    getLIE (tcMethodBind xtve clas_tyvars theta 
			 [this_dict] prags meth_info)	`thenM` \ (defm_bind, insts_needed) ->
393
    
394
    addErrCtxt (defltMethCtxt clas) $
395
    
396
        -- Check the context
397
    tcSimplifyCheck
398
        (ptext SLIT("class") <+> ppr clas)
399
400
	clas_tyvars
        [this_dict]
401
        insts_needed			`thenM` \ dict_binds ->
402
403

	-- Simplification can do unification
404
    checkSigTyVars clas_tyvars		`thenM` \ clas_tyvars' ->
405
    
406
    let
407
	(_,dm_inst_id,_) = meth_info
408
409
        full_bind = AbsBinds
    		    clas_tyvars'
410
    		    [instToId this_dict]
411
    		    [(clas_tyvars', local_dm_id, dm_inst_id)]
412
413
414
    		    emptyNameSet	-- No inlines (yet)
    		    (dict_binds `andMonoBinds` defm_bind)
    in
415
    returnM (full_bind, [local_dm_id])
416
  where
417
    origin = ClassDeclOrigin
418
\end{code}
419

420
421
    

422
423
424
425
426
427
%************************************************************************
%*									*
\subsection{Typechecking a method}
%*									*
%************************************************************************

sof's avatar
sof committed
428
429
430
431
@tcMethodBind@ is used to type-check both default-method and
instance-decl method declarations.  We must type-check methods one at a
time, because their signatures may have different contexts and
tyvar sets.
432

sof's avatar
sof committed
433
\begin{code}
434
type MethodSpec = (Id, 			-- Global selector Id
435
		   Id, 			-- Local Id (class tyvars instantiated)
436
437
		   RenamedMonoBinds)	-- Binding for the method

sof's avatar
sof committed
438
tcMethodBind 
439
	:: [(TyVar,TcTyVar)]	-- Bindings for type environment
440
	-> [TcTyVar]		-- Instantiated type variables for the
441
442
443
444
445
446
447
				--  	enclosing class/instance decl. 
				--  	They'll be signature tyvars, and we
				--  	want to check that they don't get bound
				-- Always equal the range of the type envt
	-> TcThetaType		-- Available theta; it's just used for the error message
	-> [Inst]		-- Available from context, used to simplify constraints 
				-- 	from the method body
448
	-> [RenamedSig]		-- Pragmas (e.g. inline pragmas)
449
	-> MethodSpec		-- Details of this method
450
	-> TcM TcMonoBinds
451

452
tcMethodBind xtve inst_tyvars inst_theta avail_insts prags
453
	     (sel_id, meth_id, meth_bind)
454
  =  	-- Check the bindings; first adding inst_tyvars to the envt
455
	-- so that we don't quantify over them in nested places
456
457
    mkTcSig meth_id 				`thenM` \ meth_sig ->

458
     tcExtendTyVarEnv2 xtve (
459
460
461
	addErrCtxt (methodCtxt sel_id)		$
	getLIE (tcMonoBinds meth_bind [meth_sig] NonRecursive)
     )						`thenM` \ ((meth_bind, _, _), meth_lie) ->
462
463
464
465
466
467
468
469
470
471
472
473

	-- Now do context reduction.   We simplify wrt both the local tyvars
	-- and the ones of the class/instance decl, so that there is
	-- no problem with
	--	class C a where
	--	  op :: Eq a => a -> b -> a
	--
	-- We do this for each method independently to localise error messages

     let
	TySigInfo meth_id meth_tvs meth_theta _ local_meth_id _ _ = meth_sig
     in
474
475
     addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id))	$
     newDicts SignatureOrigin meth_theta	`thenM` \ meth_dicts ->
476
477
478
479
480
481
     let
	all_tyvars = meth_tvs ++ inst_tyvars
	all_insts  = avail_insts ++ meth_dicts
     in
     tcSimplifyCheck
	 (ptext SLIT("class or instance method") <+> quotes (ppr sel_id))
482
	 all_tyvars all_insts meth_lie		`thenM` \ lie_binds ->
483

484
     checkSigTyVars all_tyvars			`thenM` \ all_tyvars' ->
485
486

     let
487
488
489
490
491
492
493
494
495
496
497
		-- Attach inline pragmas as appropriate
	(final_meth_id, inlines) 
	   | (InlineSig inl _ phase _ : _) <- filter is_inline prags
	   = (meth_id `setInlinePragma` phase,
	      if inl then unitNameSet (idName meth_id) else emptyNameSet)
	   | otherwise
	   = (meth_id, emptyNameSet)

	is_inline (InlineSig _ name _ _) = name == idName sel_id
	is_inline other		         = False

498
499
500
	meth_tvs'      = take (length meth_tvs) all_tyvars'
	poly_meth_bind = AbsBinds meth_tvs'
				  (map instToId meth_dicts)
501
502
     				  [(meth_tvs', final_meth_id, local_meth_id)]
				  inlines
503
504
				  (lie_binds `andMonoBinds` meth_bind)
     in
505
     returnM poly_meth_bind
506
507
508
509
510
511


mkMethodBind :: InstOrigin
	     -> Class -> [TcType]	-- Class and instance types
	     -> RenamedMonoBinds	-- Method binding (pick the right one from in here)
	     -> ClassOpItem
512
	     -> TcM (Maybe Inst,		-- Method inst
513
514
515
		     MethodSpec)
-- Find the binding for the specified method, or make
-- up a suitable default method if it isn't there
516
517

mkMethodBind origin clas inst_tys meth_binds (sel_id, dm_info)
518
  = mkMethId origin clas sel_id inst_tys		`thenM` \ (mb_inst, meth_id) ->
519
520
521
522
523
    let
	meth_name  = idName meth_id
    in
	-- Figure out what method binding to use
	-- If the user suppplied one, use it, else construct a default one
524
    getSrcLocM					`thenM` \ loc -> 
525
    (case find_bind (idName sel_id) meth_name meth_binds of
526
527
528
	Just user_bind -> returnM user_bind 
	Nothing	       -> mkDefMethRhs origin clas inst_tys sel_id loc dm_info	`thenM` \ rhs ->
			  returnM (FunMonoBind meth_name False	-- Not infix decl
529
				               [mkSimpleMatch [] rhs placeHolderType loc] loc)
530
    )								`thenM` \ meth_bind ->
531

532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
    returnM (mb_inst, (sel_id, meth_id, meth_bind))

mkMethId :: InstOrigin -> Class 
	 -> Id -> [TcType]	-- Selector, and instance types
	 -> TcM (Maybe Inst, Id)
	     
-- mkMethId instantiates the selector Id at the specified types
-- THe 
mkMethId origin clas sel_id inst_tys
  = let
	(tyvars,rho) = tcSplitForAllTys (idType sel_id)
	rho_ty	     = ASSERT( length tyvars == length inst_tys )
		       substTyWith tyvars inst_tys rho
	(preds,tau)  = tcSplitPhiTy rho_ty
        first_pred   = head preds
    in
	-- The first predicate should be of form (C a b)
	-- where C is the class in question
    ASSERT( not (null preds) && 
	    case getClassPredTys_maybe first_pred of
		{ Just (clas1,tys) -> clas == clas1 ; Nothing -> False }
    )
    if isSingleton preds then
	-- If it's the only one, make a 'method'
	getInstLoc origin				`thenM` \ inst_loc ->
    	newMethod inst_loc sel_id inst_tys preds tau	`thenM` \ meth_inst ->
	returnM (Just meth_inst, instToId meth_inst)
    else
	-- If it's not the only one we need to be careful
	-- For example, given 'op' defined thus:
	--	class Foo a where
	--	  op :: (?x :: String) => a -> a
	-- (mkMethId op T) should return an Inst with type
	--	(?x :: String) => T -> T
	-- That is, the class-op's context is still there.  
	-- BUT: it can't be a Method any more, because it breaks
	-- 	INVARIANT 2 of methods.  (See the data decl for Inst.)
	newUnique			`thenM` \ uniq ->
	getSrcLocM			`thenM` \ loc ->
	let 
	    real_tau = mkPhiTy (tail preds) tau
	    meth_id  = mkUserLocal (getOccName sel_id) uniq real_tau loc
	in
	returnM (Nothing, meth_id)
576
577
578
579

     -- The user didn't supply a method binding, 
     -- so we have to make up a default binding
     -- The RHS of a default method depends on the default-method info
580
mkDefMethRhs origin clas inst_tys sel_id loc (DefMeth dm_name)
581
  =  -- An polymorphic default method
582
583
    traceRn (text "mkDefMeth" <+> ppr dm_name) 	`thenM_`
    returnM (HsVar dm_name)
584

585
mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth
586
587
  =  	-- No default method
	-- Warn only if -fwarn-missing-methods
588
    doptM Opt_WarnMissingMethods 		`thenM` \ warn -> 
589
590
591
    warnTc (isInstDecl origin
	   && warn
	   && reportIfUnused (getOccName sel_id))
592
593
   	   (omittedMethodWarn sel_id)		`thenM_`
    returnM error_rhs
594
  where
595
596
597
    error_rhs  = HsLam (mkSimpleMatch wild_pats simple_rhs placeHolderType loc)
    simple_rhs = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID)) 
	    	       (HsLit (HsStringPrim (mkFastString (stringToUtf8 error_msg))))
598
599
    error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])

600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
	-- When the type is of form t1 -> t2 -> t3
	-- make a default method like (\ _ _ -> noMethBind "blah")
	-- rather than simply        (noMethBind "blah")
	-- Reason: if t1 or t2 are higher-ranked types we get n
	--	   silly ambiguity messages.
	-- Example:	f :: (forall a. Eq a => a -> a) -> Int
	--		f = error "urk"
	-- Here, tcSub tries to force (error "urk") to have the right type,
	-- thus:	f = \(x::forall a. Eq a => a->a) -> error "urk" (x t)
	-- where 't' is fresh ty var.  This leads directly to "ambiguous t".
	-- 
	-- NB: technically this changes the meaning of the default-default
	--     method slightly, because `seq` can see the lambdas.  Oh well.
    (_,_,tau1)    = tcSplitSigmaTy (idType sel_id)
    (_,_,tau2)    = tcSplitSigmaTy tau1
	-- Need two splits because the  selector can have a type like
	-- 	forall a. Foo a => forall b. Eq b => ...
    (arg_tys, _) = tcSplitFunTys tau2
618
    wild_pats	 = [WildPat placeHolderType | ty <- arg_tys]
619

620
mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth 
621
622
623
624
625
  =  	-- A generic default method
	-- If the method is defined generically, we can only do the job if the
	-- instance declaration is for a single-parameter type class with
	-- a type constructor applied to type arguments in the instance decl
	-- 	(checkTc, so False provokes the error)
626
627
628
     ASSERT( isInstDecl origin )	-- We never get here from a class decl

     checkTc (isJust maybe_tycon)
629
	     (badGenericInstance sel_id (notSimple inst_tys))		`thenM_`
630
     checkTc (isJust (tyConGenInfo tycon))
631
	     (badGenericInstance sel_id (notGeneric tycon))		`thenM_`
632

633
634
     ioToTcRn (dumpIfSet opt_PprStyle_Debug "Generic RHS" stuff)	`thenM_`
     returnM rhs
635
636
637
638
639
640
641
642
643
644
645
646
647
  where
    rhs = mkGenericRhs sel_id clas_tyvar tycon

    stuff = vcat [ppr clas <+> ppr inst_tys,
		  nest 4 (ppr sel_id <+> equals <+> ppr rhs)]

	  -- The tycon is only used in the generic case, and in that
	  -- case we require that the instance decl is for a single-parameter
	  -- type class with type variable arguments:
	  --	instance (...) => C (T a b)
    clas_tyvar    = head (classTyVars clas)
    Just tycon	  = maybe_tycon
    maybe_tycon   = case inst_tys of 
648
649
650
			[ty] -> case tcSplitTyConApp_maybe ty of
				  Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
				  other						  -> Nothing
651
			other -> Nothing
652
653
654

isInstDecl InstanceDeclOrigin = True
isInstDecl ClassDeclOrigin    = False
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
\end{code}


\begin{code}
-- The renamer just puts the selector ID as the binder in the method binding
-- but we must use the method name; so we substitute it here.  Crude but simple.
find_bind sel_name meth_name (FunMonoBind op_name fix matches loc)
    | op_name == sel_name = Just (FunMonoBind meth_name fix matches loc)
find_bind sel_name meth_name (AndMonoBinds b1 b2)
    = find_bind sel_name meth_name b1 `seqMaybe` find_bind sel_name meth_name b2
find_bind sel_name meth_name other  = Nothing	-- Default case

 -- Find the prags for this method, and replace the
 -- selector name with the method name
find_prags sel_name meth_name [] = []
find_prags sel_name meth_name (SpecSig name ty loc : prags) 
     | name == sel_name = SpecSig meth_name ty loc : find_prags sel_name meth_name prags
672
673
find_prags sel_name meth_name (InlineSig sense name phase loc : prags)
   | name == sel_name = InlineSig sense meth_name phase loc : find_prags sel_name meth_name prags
674
find_prags sel_name meth_name (prag:prags) = find_prags sel_name meth_name prags
sof's avatar
sof committed
675
\end{code}
sof's avatar
sof committed
676

677

678
679
Contexts and errors
~~~~~~~~~~~~~~~~~~~
680
\begin{code}
681
682
defltMethCtxt clas
  = ptext SLIT("When checking the default methods for class") <+> quotes (ppr clas)
683

684
685
686
methodCtxt sel_id
  = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)

687
badMethodErr clas op
688
  = hsep [ptext SLIT("Class"), quotes (ppr clas), 
689
	  ptext SLIT("does not have a method"), quotes (ppr op)]
690

691
692
omittedMethodWarn sel_id
  = ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id)
693

694
badGenericInstance sel_id because
695
  = sep [ptext SLIT("Can't derive generic code for") <+> quotes (ppr sel_id),
696
697
698
699
700
701
702
703
704
705
	 because]

notSimple inst_tys
  = vcat [ptext SLIT("because the instance type(s)"), 
	  nest 2 (ppr inst_tys),
	  ptext SLIT("is not a simple type of form (T a b c)")]

notGeneric tycon
  = vcat [ptext SLIT("because the instance type constructor") <+> quotes (ppr tycon) <+> 
	  ptext SLIT("was not compiled with -fgenerics")]
706
707
708

mixedGenericErr op
  = ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)
709
\end{code}