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
    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
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)
575 576 577 578

     -- 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
579
mkDefMethRhs origin clas inst_tys sel_id loc (DefMeth dm_name)
580
  =  -- An polymorphic default method
581 582
    traceRn (text "mkDefMeth" <+> ppr dm_name) 	`thenM_`
    returnM (HsVar dm_name)
583

584
mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth
585 586
  =  	-- No default method
	-- Warn only if -fwarn-missing-methods
587
    doptM Opt_WarnMissingMethods 		`thenM` \ warn -> 
588 589 590
    warnTc (isInstDecl origin
	   && warn
	   && reportIfUnused (getOccName sel_id))
591 592
   	   (omittedMethodWarn sel_id)		`thenM_`
    returnM error_rhs
593
  where
594 595 596
    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))))
597 598
    error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])

599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616
	-- 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
617
    wild_pats	 = [WildPat placeHolderType | ty <- arg_tys]
618

619
mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth 
620 621 622 623 624
  =  	-- 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)
625 626 627
     ASSERT( isInstDecl origin )	-- We never get here from a class decl

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

632 633
     ioToTcRn (dumpIfSet opt_PprStyle_Debug "Generic RHS" stuff)	`thenM_`
     returnM rhs
634 635 636 637 638 639 640 641 642 643 644 645 646
  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 
647 648 649
			[ty] -> case tcSplitTyConApp_maybe ty of
				  Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
				  other						  -> Nothing
650
			other -> Nothing
651 652 653

isInstDecl InstanceDeclOrigin = True
isInstDecl ClassDeclOrigin    = False
654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670
\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
671 672
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
673
find_prags sel_name meth_name (prag:prags) = find_prags sel_name meth_name prags
sof's avatar
sof committed
674
\end{code}
sof's avatar
sof committed
675

676

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

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

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

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

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

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