TcClassDcl.lhs 20.4 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
%
Simon Marlow's avatar
Simon Marlow committed
5
6

Typechecking class declarations
7
8

\begin{code}
9
module TcClassDcl ( tcClassSigs, tcClassDecl2, 
10
		    findMethodBind, instantiateMethod, tcInstanceMethodBody,
11
		    mkGenericDefMethBind, getGenericInstances, 
12
		    tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
13
		  ) where
14

15
#include "HsVersions.h"
16

17
import HsSyn
Simon Marlow's avatar
Simon Marlow committed
18
19
20
21
import RnHsSyn
import RnExpr
import Inst
import InstEnv
22
import TcPat( addInlinePrags )
Simon Marlow's avatar
Simon Marlow committed
23
24
import TcEnv
import TcBinds
25
import TcUnify
Simon Marlow's avatar
Simon Marlow committed
26
27
28
import TcHsType
import TcMType
import TcType
29
import TcRnMonad
30
import BuildTyCl( TcMethInfo )
Simon Marlow's avatar
Simon Marlow committed
31
32
33
34
35
36
import Generics
import Class
import TyCon
import MkId
import Id
import Name
Ian Lynagh's avatar
Ian Lynagh committed
37
import Var
Simon Marlow's avatar
Simon Marlow committed
38
39
import NameEnv
import NameSet
sof's avatar
sof committed
40
import Outputable
Simon Marlow's avatar
Simon Marlow committed
41
import PrelNames
42
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
43
44
45
46
47
48
import ErrUtils
import Util
import ListSetOps
import SrcLoc
import Maybes
import BasicTypes
49
import Bag
50
import FastString
51
52

import Control.Monad
Ian Lynagh's avatar
Ian Lynagh committed
53
import Data.List
54
55
\end{code}

56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89

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".


90
91
%************************************************************************
%*									*
92
		Type-checking the class op signatures
93
94
95
96
%*									*
%************************************************************************

\begin{code}
97
tcClassSigs :: Name	    		-- Name of the class
98
99
	    -> [LSig Name]
	    -> LHsBinds Name
100
101
102
	    -> TcM [TcMethInfo]

tcClassSigs clas sigs def_methods
103
104
105
  = do { dm_env <- mapM (addLocM (checkDefaultBind clas op_names)) 
                        (bagToList def_methods)
       ; mapM (tcClassSig (mkNameEnv dm_env)) op_sigs }
106
  where
107
    op_sigs  = [sig | sig@(L _ (TypeSig _ _))       <- sigs]
Ian Lynagh's avatar
Ian Lynagh committed
108
    op_names = [n   |     (L _ (TypeSig (L _ n) _)) <- op_sigs]
109

110
checkDefaultBind :: Name -> [Name] -> HsBindLR Name Name -> TcM (Name, DefMethSpec)
111
112
113
  -- Check default bindings
  -- 	a) must be for a class op for this class
  --	b) must be all generic or all non-generic
114
checkDefaultBind clas ops (FunBind {fun_id = L _ op, fun_matches = MatchGroup matches _ })
115
  = do {  	-- Check that the op is from this class
116
 	 checkTc (op `elem` ops) (badMethodErr clas op)
117
118

   	-- Check that all the defns ar generic, or none are
119
120
121
122
       ; case (none_generic, all_generic) of
           (True, _) -> return (op, VanillaDM)
           (_, True) -> return (op, GenericDM)
           _         -> failWith (mixedGenericErr op)
123
124
125
126
127
    }
  where
    n_generic    = count (isJust . maybeGenericMatch) matches
    none_generic = n_generic == 0
    all_generic  = matches `lengthIs` n_generic
128

Ian Lynagh's avatar
Ian Lynagh committed
129
checkDefaultBind _ _ b = pprPanic "checkDefaultBind" (ppr b)
130
131


132
tcClassSig :: NameEnv DefMethSpec	-- Info about default methods; 
133
	   -> LSig Name
134
135
	   -> TcM TcMethInfo

136
tcClassSig dm_env (L loc (TypeSig (L _ op_name) op_hs_ty))
137
  = setSrcSpan loc $ do
138
    { op_ty <- tcHsKindedType op_hs_ty	-- Class tyvars already in scope
139
    ; let dm = lookupNameEnv dm_env op_name `orElse` NoDM
140
    ; return (op_name, dm, op_ty) }
Ian Lynagh's avatar
Ian Lynagh committed
141
tcClassSig _ s = pprPanic "tcClassSig" (ppr s)
142
143
144
145
146
\end{code}


%************************************************************************
%*									*
147
		Class Declarations
148
149
150
%*									*
%************************************************************************

151
\begin{code}
152
tcClassDecl2 :: LTyClDecl Name		-- The class declaration
153
	     -> TcM (LHsBinds Id)
154

155
156
tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, 
				tcdMeths = default_binds}))
157
158
  = recoverM (return emptyLHsBinds)	$
    setSrcSpan loc		   	$
159
    do  { clas <- tcLookupLocatedClass class_name
160
161
162
163
164
165
166
167
168

	-- 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
169
170
	; let
	      (tyvars, _, _, op_items) = classBigSig clas
171
              prag_fn     = mkPragFun sigs default_binds
172
	      sig_fn	  = mkSigFun sigs
173
              clas_tyvars = tcSuperSkolTyVars tyvars
174
	      pred  	  = mkClassPred clas (mkTyVarTys clas_tyvars)
175
	; this_dict <- newEvVar pred
176

177
	; let tc_dm = tcDefMeth clas clas_tyvars
178
179
180
				this_dict default_binds
	      			sig_fn prag_fn

181
	; dm_binds <- tcExtendTyVarEnv clas_tyvars $
182
                      mapM tc_dm op_items
183

184
	; return (listToBag (catMaybes dm_binds)) }
185

Ian Lynagh's avatar
Ian Lynagh committed
186
tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
187
    
188
189
tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
          -> SigFun -> PragFun -> ClassOpItem
190
          -> TcM (Maybe (LHsBind Id))
191
192
193
194
195
196
197
198
199
200
201
202
203
204
-- Generate code for polymorphic default methods only (hence DefMeth)
-- (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.)
tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info)
  = case dm_info of
      NoDefMeth       -> return Nothing
      GenDefMeth      -> return Nothing
      DefMeth dm_name -> do
    	{ let sel_name = idName sel_id
	; local_dm_name <- newLocalName sel_name
 	  -- Base the local_dm_name on the selector name, because
205
206
207
208
209
 	  -- type errors from tcInstanceMethodBody come from here

		-- See Note [Silly default-method bind]
		-- (possibly out of date)

210
	; let meth_bind = findMethodBind sel_name binds_in
211
			  `orElse` pprPanic "tcDefMeth" (ppr sel_id)
212
		-- dm_info = DefMeth dm_name only if there is a binding in binds_in
213

214
215
	      dm_sig_fn  _  = sig_fn sel_name
	      dm_id         = mkDefaultMethodId sel_id dm_name
216
217
	      local_dm_type = instantiateMethod clas sel_id (mkTyVarTys tyvars)
	      local_dm_id   = mkLocalId local_dm_name local_dm_type
218
              prags         = prag_fn sel_name
219

220
        ; dm_id_w_inline <- addInlinePrags dm_id prags
221
        ; spec_prags     <- tcSpecPrags dm_id prags
222

223
224
225
226
        ; warnTc (not (null spec_prags))
                 (ptext (sLit "Ignoring SPECIALISE pragmas on default method") 
                  <+> quotes (ppr sel_name))

227
        ; liftM Just $
228
229
230
          tcInstanceMethodBody (ClsSkol clas)
                               tyvars 
                               [this_dict]
231
                               dm_id_w_inline local_dm_id
232
                               dm_sig_fn IsDefaultMethod meth_bind }
233
234

---------------
235
236
237
tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
                     -> Id -> Id
          	     -> SigFun -> TcSpecPrags -> LHsBind Name 
238
          	     -> TcM (LHsBind Id)
239
tcInstanceMethodBody skol_info tyvars dfun_ev_vars
240
                     meth_id local_meth_id
241
242
		     meth_sig_fn specs 
                     (L loc bind)
243
244
245
  = do	{       -- Typecheck the binding, first extending the envt
		-- so that when tcInstSig looks up the local_meth_id to find
		-- its signature, we'll find it in the environment
246
247
          let lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
                             -- Substitute the local_meth_name for the binder
248
249
250
			     -- NB: the binding is always a FunBind

	; (ev_binds, (tc_bind, _)) 
251
               <- checkConstraints skol_info tyvars dfun_ev_vars $
252
253
254
255
256
		  tcExtendIdEnv [local_meth_id] $
	          tcPolyBinds TopLevel meth_sig_fn no_prag_fn 
		  	     NonRecursive NonRecursive
		  	     [lm_bind]

257
        ; let full_bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
258
                                   , abs_exports = [(tyvars, meth_id, local_meth_id, specs)]
259
                                   , abs_ev_binds = ev_binds
260
                                   , abs_binds = tc_bind }
261

262
        ; return (L loc full_bind) } 
263
264
265
266
  where
    no_prag_fn  _ = []		-- No pragmas for local_meth_id; 
    		    		-- they are all for meth_id
\end{code}
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
\begin{code}
instantiateMethod :: Class -> Id -> [TcType] -> TcType
-- Take a class operation, say  
--	op :: forall ab. C a => forall c. Ix c => (b,c) -> a
-- Instantiate it at [ty1,ty2]
-- Return the "local method type": 
--	forall c. Ix x => (ty2,c) -> ty1
instantiateMethod clas sel_id inst_tys
  = ASSERT( ok_first_pred ) local_meth_ty
  where
    (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id)
    rho_ty = ASSERT( length sel_tyvars == length inst_tys )
    	     substTyWith sel_tyvars inst_tys sel_rho

    (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty
    		`orElse` pprPanic "tcInstanceMethod" (ppr sel_id)

    ok_first_pred = case getClassPredTys_maybe first_pred of
		      Just (clas1, _tys) -> clas == clas1
                      Nothing -> False
	      -- The first predicate should be of form (C a b)
	      -- where C is the class in question


292
---------------------------
293
findMethodBind	:: Name  	        -- Selector name
294
          	-> LHsBinds Name 	-- A group of bindings
295
296
		-> Maybe (LHsBind Name)	-- The binding
findMethodBind sel_name binds
297
298
  = foldlBag mplus Nothing (mapBag f binds)
  where 
299
300
301
302
    f bind@(L _ (FunBind { fun_id = L _ op_name }))
             | op_name == sel_name
    	     = Just bind
    f _other = Nothing
303
\end{code}
304

305
306
307
308
309
310
311
Note [Polymorphic methods]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
    class Foo a where
	op :: forall b. Ord b => a -> b -> b -> b
    instance Foo c => Foo [c] where
        op = e
312

313
314
315
When typechecking the binding 'op = e', we'll have a meth_id for op
whose type is
      op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b
316

317
318
So tcPolyBinds must be capable of dealing with nested polytypes; 
and so it is. See TcBinds.tcMonoBinds (with type-sig case).
319

320
321
322
323
324
Note [Silly default-method bind]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we pass the default method binding to the type checker, it must
look like    op2 = e
not  	     $dmop2 = e
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
325
326
327
otherwise the "$dm" stuff comes out error messages.  But we want the
"$dm" to come out in the interface file.  So we typecheck the former,
and wrap it in a let, thus
328
329
	  $dmop2 = let op2 = e in op2
This makes the error messages right.
330
331


332
333
334
335
336
%************************************************************************
%*									*
	Extracting generic instance declaration from class declarations
%*									*
%************************************************************************
337

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

341
342
	class C a where
	  op :: a -> a
343
	
344
345
346
347
	  op{ x+y } (Inl v)   = ...
	  op{ x+y } (Inr v)   = ...
	  op{ x*y } (v :*: w) = ...
	  op{ 1   } Unit      = ...
348

349
gives rise to the instance declarations
350

351
352
353
354
355
356
	instance C (x+y) where
	  op (Inl v)   = ...
	  op (Inr v)   = ...
	
	instance C (x*y) where
	  op (v :*: w) = ...
357

358
359
	instance C 1 where
	  op Unit      = ...
360

361
\begin{code}
362
363
mkGenericDefMethBind :: Class -> [Type] -> Id -> TcM (LHsBind Name)
mkGenericDefMethBind clas inst_tys sel_id
364
365
  = 	-- A generic default method
    	-- If the method is defined generically, we can only do the job if the
366
367
368
	-- 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)
369
370
371
372
373
374
    do	{ checkTc (isJust maybe_tycon)
	 	  (badGenericInstance sel_id (notSimple inst_tys))
	; checkTc (tyConHasGenerics tycon)
	   	  (badGenericInstance sel_id (notGeneric tycon))

	; dflags <- getDOpts
twanvl's avatar
twanvl committed
375
	; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
376
377
378
379
		   (vcat [ppr clas <+> ppr inst_tys,
			  nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))

		-- Rename it before returning it
380
	; (rn_rhs, _) <- rnLExpr rhs
381
382
        ; return (noLoc $ mkFunBind (noLoc (idName sel_id))
                                    [mkSimpleMatch [] rn_rhs]) }
383
384
385
386
387
388
389
  where
    rhs = mkGenericRhs sel_id clas_tyvar tycon

	  -- 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)
390
391
392
    clas_tyvar  = ASSERT (not (null (classTyVars clas))) head (classTyVars clas)
    Just tycon	= maybe_tycon
    maybe_tycon = case inst_tys of 
393
394
			[ty] -> case tcSplitTyConApp_maybe ty of
				  Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
Ian Lynagh's avatar
Ian Lynagh committed
395
396
				  _    						  -> Nothing
			_ -> Nothing
397

398

399
---------------------------
400
getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo Name] 
401
getGenericInstances class_decls
402
  = do	{ gen_inst_infos <- mapM (addLocM get_generics) class_decls
403
404
405
	; let { gen_inst_info = concat gen_inst_infos }

	-- Return right away if there is no generic stuff
406
	; if null gen_inst_info then return []
407
408
409
	  else do 

	-- Otherwise print it out
410
411
        { dumpDerivingInfo $ hang (ptext (sLit "Generic instances"))
                                2 (vcat (map pprInstInfoDetails gen_inst_info))
412
	; return gen_inst_info }}
413

414
get_generics :: TyClDecl Name -> TcM [InstInfo Name]
415
get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods})
416
  | null generic_binds
417
  = return [] -- The comon case: no generic default methods
418
419

  | otherwise	-- A source class decl with generic default methods
420
421
422
  = recoverM (return [])                                $
    tcAddDeclCtxt decl                                  $ do
    clas <- tcLookupLocatedClass class_name
423
424
425
426

	-- Group by type, and
	-- make an InstInfo out of each group
    let
427
	groups = groupWith listToBag generic_binds
428
429

    inst_infos <- mapM (mkGenericInstance clas) groups
430
431
432
433
434
435

	-- 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
436
437
	--
	-- The class should be unary, which is why simpleInstInfoTyCon should be ok
438
    let
439
	tc_inst_infos :: [(TyCon, InstInfo Name)]
440
441
442
443
444
	tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]

	bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
			      group `lengthExceeds` 1]
	get_uniq (tc,_) = getUnique tc
445

446
    mapM_ (addErrTc . dupGenericInsts) bad_groups
447
448
449
450

	-- Check that there is an InstInfo for each generic type constructor
    let
	missing = genericTyConNames `minusList` [tyConName tc | (tc,_) <- tc_inst_infos]
451

452
453
454
    checkTc (null missing) (missingGenericInstances missing)

    return inst_infos
455
  where
456
    generic_binds :: [(HsType Name, LHsBind Name)]
457
    generic_binds = getGenericBinds def_methods
Ian Lynagh's avatar
Ian Lynagh committed
458
get_generics decl = pprPanic "get_generics" (ppr decl)
459
460
461


---------------------------------
462
getGenericBinds :: LHsBinds Name -> [(HsType Name, LHsBind Name)]
463
464
  -- Takes a group of method bindings, finds the generic ones, and returns
  -- them in finite map indexed by the type parameter in the definition.
465
getGenericBinds binds = concat (map getGenericBind (bagToList binds))
466

Ian Lynagh's avatar
Ian Lynagh committed
467
getGenericBind :: LHsBindLR Name Name -> [(HsType Name, LHsBindLR Name Name)]
468
getGenericBind (L loc bind@(FunBind { fun_matches = MatchGroup matches ty }))
469
470
  = groupWith wrap (mapCatMaybes maybeGenericMatch matches)
  where
471
    wrap ms = L loc (bind { fun_matches = MatchGroup ms ty })
472
473
getGenericBind _
  = []
474
475

groupWith :: ([a] -> b) -> [(HsType Name, a)] -> [(HsType Name, b)]
Ian Lynagh's avatar
Ian Lynagh committed
476
groupWith _  [] 	 = []
477
478
groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest
    where
Ian Lynagh's avatar
Ian Lynagh committed
479
480
481
      vs              = map snd this
      (this,rest)     = partition same_t prs
      same_t (t', _v) = t `eqPatType` t'
482

483
484
485
eqPatLType :: LHsType Name -> LHsType Name -> Bool
eqPatLType t1 t2 = unLoc t1 `eqPatType` unLoc t2

486
487
488
eqPatType :: HsType Name -> HsType Name -> Bool
-- A very simple equality function, only for 
-- type patterns in generic function definitions.
489
eqPatType (HsTyVar v1)       (HsTyVar v2)    	= v1==v2
Ian Lynagh's avatar
Ian Lynagh committed
490
491
eqPatType (HsAppTy s1 t1)    (HsAppTy s2 t2) 	= s1 `eqPatLType` s2 && t1 `eqPatLType` t2
eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatLType` s2 && t1 `eqPatLType` t2 && unLoc op1 == unLoc op2
492
eqPatType (HsNumTy n1)	     (HsNumTy n2)	= n1 == n2
493
494
eqPatType (HsParTy t1)	     t2			= unLoc t1 `eqPatType` t2
eqPatType t1		     (HsParTy t2)	= t1 `eqPatType` unLoc t2
495
496
497
eqPatType _ _ = False

---------------------------------
498
mkGenericInstance :: Class
499
		  -> (HsType Name, LHsBinds Name)
500
		  -> TcM (InstInfo Name)
501

502
mkGenericInstance clas (hs_ty, binds) = do
503
504
505
  -- Make a generic instance declaration
  -- For example:	instance (C a, C b) => C (a+b) where { binds }

506
	-- Extract the universally quantified type variables
507
508
509
	-- and wrap them as forall'd tyvars, so that kind inference
	-- works in the standard way
    let
510
511
	sig_tvs = userHsTyVarBndrs $ map noLoc $ nameSetToList $
                  extractHsTyVars (noLoc hs_ty)
512
	hs_forall_ty = noLoc $ mkExplicitHsForAllTy sig_tvs (noLoc []) (noLoc hs_ty)
513

514
	-- Type-check the instance type, and check its form
515
    forall_inst_ty <- tcHsSigType GenPatCtxt hs_forall_ty
516
517
    let
	(tyvars, inst_ty) = tcSplitForAllTys forall_inst_ty
518

519
    checkTc (validGenericInstanceType inst_ty)
520
            (badGenericInstanceType binds)
521
522

	-- Make the dictionary function.
523
524
525
    span <- getSrcSpanM
    overlap_flag <- getOverlapFlag
    dfun_name <- newDFunName clas [inst_ty] span
526
527
528
    let
	inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
	dfun_id    = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
529
        ispec      = mkLocalInstance dfun_id overlap_flag
530

531
    return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds [] False })
sof's avatar
sof committed
532
\end{code}
sof's avatar
sof committed
533

534

535
536
537
538
539
540
%************************************************************************
%*									*
		Error messages
%*									*
%************************************************************************

541
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
542
tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a
543
544
tcAddDeclCtxt decl thing_inside
  = addErrCtxt ctxt thing_inside
545
  where
546
547
548
549
550
551
     thing | isClassDecl decl  = "class"
	   | isTypeDecl decl   = "type synonym" ++ maybeInst
	   | isDataDecl decl   = if tcdND decl == NewType 
				 then "newtype" ++ maybeInst
				 else "data type" ++ maybeInst
	   | isFamilyDecl decl = "family"
Ian Lynagh's avatar
Ian Lynagh committed
552
	   | otherwise         = panic "tcAddDeclCtxt/thing"
553

554
     maybeInst | isFamInstDecl decl = " instance"
555
	       | otherwise          = ""
556

Ian Lynagh's avatar
Ian Lynagh committed
557
558
     ctxt = hsep [ptext (sLit "In the"), text thing, 
		  ptext (sLit "declaration for"), quotes (ppr (tcdName decl))]
559

Ian Lynagh's avatar
Ian Lynagh committed
560
badMethodErr :: Outputable a => a -> Name -> SDoc
561
badMethodErr clas op
Ian Lynagh's avatar
Ian Lynagh committed
562
563
  = hsep [ptext (sLit "Class"), quotes (ppr clas), 
	  ptext (sLit "does not have a method"), quotes (ppr op)]
564

Ian Lynagh's avatar
Ian Lynagh committed
565
badATErr :: Class -> Name -> SDoc
566
badATErr clas at
Ian Lynagh's avatar
Ian Lynagh committed
567
568
  = hsep [ptext (sLit "Class"), quotes (ppr clas), 
	  ptext (sLit "does not have an associated type"), quotes (ppr at)]
569

Ian Lynagh's avatar
Ian Lynagh committed
570
omittedATWarn :: Name -> SDoc
571
omittedATWarn at
Ian Lynagh's avatar
Ian Lynagh committed
572
  = ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at)
573

Ian Lynagh's avatar
Ian Lynagh committed
574
badGenericInstance :: Var -> SDoc -> SDoc
575
badGenericInstance sel_id because
Ian Lynagh's avatar
Ian Lynagh committed
576
  = sep [ptext (sLit "Can't derive generic code for") <+> quotes (ppr sel_id),
577
578
	 because]

Ian Lynagh's avatar
Ian Lynagh committed
579
notSimple :: [Type] -> SDoc
580
notSimple inst_tys
Ian Lynagh's avatar
Ian Lynagh committed
581
  = vcat [ptext (sLit "because the instance type(s)"), 
582
	  nest 2 (ppr inst_tys),
Ian Lynagh's avatar
Ian Lynagh committed
583
	  ptext (sLit "is not a simple type of form (T a1 ... an)")]
584

Ian Lynagh's avatar
Ian Lynagh committed
585
notGeneric :: TyCon -> SDoc
586
notGeneric tycon
Ian Lynagh's avatar
Ian Lynagh committed
587
  = vcat [ptext (sLit "because the instance type constructor") <+> quotes (ppr tycon) <+> 
588
	  ptext (sLit "was not compiled with -XGenerics")]
589

Ian Lynagh's avatar
Ian Lynagh committed
590
badGenericInstanceType :: LHsBinds Name -> SDoc
591
badGenericInstanceType binds
Ian Lynagh's avatar
Ian Lynagh committed
592
  = vcat [ptext (sLit "Illegal type pattern in the generic bindings"),
593
	  nest 2 (ppr binds)]
594

Ian Lynagh's avatar
Ian Lynagh committed
595
missingGenericInstances :: [Name] -> SDoc
596
missingGenericInstances missing
Ian Lynagh's avatar
Ian Lynagh committed
597
  = ptext (sLit "Missing type patterns for") <+> pprQuotedList missing
598
	  
599
dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc
600
dupGenericInsts tc_inst_infos
Ian Lynagh's avatar
Ian Lynagh committed
601
  = vcat [ptext (sLit "More than one type pattern for a single generic type constructor:"),
602
	  nest 2 (vcat (map ppr_inst_ty tc_inst_infos)),
Ian Lynagh's avatar
Ian Lynagh committed
603
	  ptext (sLit "All the type patterns for a generic type constructor must be identical")
604
605
    ]
  where 
606
    ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
607

Ian Lynagh's avatar
Ian Lynagh committed
608
mixedGenericErr :: Name -> SDoc
609
mixedGenericErr op
Ian Lynagh's avatar
Ian Lynagh committed
610
  = ptext (sLit "Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)
611
\end{code}