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

\begin{code}
module TcInstDcls (
8
	tcInstDecls1,
sof's avatar
sof committed
9
	tcInstDecls2
10 11
    ) where

12
#include "HsVersions.h"
13

14
import HsSyn		( HsDecl(..), InstDecl(..),
15
			  HsBinds(..), MonoBinds(..), GRHSsAndBinds(..), GRHS(..),
sof's avatar
sof committed
16
			  HsExpr(..), InPat(..), HsLit(..), Sig(..),
17 18
			  unguardedRHS,
			  collectMonoBinders, andMonoBinds
sof's avatar
sof committed
19
			)
sof's avatar
sof committed
20
import HsBinds		( sigsForMe )
21
import RnHsSyn		( RenamedHsBinds, RenamedMonoBinds,
22 23
			  RenamedInstDecl, RenamedHsExpr,
			  RenamedSig, RenamedHsDecl
24
			)
25
import TcHsSyn		( TcMonoBinds, TcIdOcc(..), TcIdBndr, 
sof's avatar
sof committed
26
			  maybeBoxedPrimType, tcIdType
27
			)
28

29
import TcBinds		( tcPragmaSigs )
30
import TcClassDcl	( tcMethodBind, badMethodErr )
31
import TcMonad
32
import RnMonad		( RnNameSupply )
33
import Inst		( Inst, InstOrigin(..),
34
			  newDicts, LIE, emptyLIE, plusLIE, plusLIEs )
35
import TcDeriv		( tcDeriving )
36 37
import TcEnv		( tcExtendGlobalValEnv, tcAddImportedIdInfo )
import TcInstUtil	( InstInfo(..), mkInstanceRelatedIds, classDataCon )
38
import TcKind		( TcKind, unifyKind )
39
import TcMonoType	( tcHsType )
40
import TcSimplify	( tcSimplifyAndCheck )
41
import TcType		( TcType, TcTyVar, TcTyVarSet, 
42
			  zonkSigTyVar, tcInstSigTyVars, tcInstType, tcInstTheta
43
			)
44 45

import Bag		( emptyBag, unitBag, unionBags, unionManyBags,
46
			  foldBag, bagToList, Bag
47
			)
48 49
import CmdLineOpts	( opt_GlasgowExts, opt_WarnMissingMethods )
import Class		( classBigSig, Class )
sof's avatar
sof committed
50
import Id		( isNullaryDataCon, dataConArgTys, replaceIdInfo, idName, Id )
51 52
import Maybes 		( maybeToBool, seqMaybe, catMaybes )
import Name		( nameOccName, mkLocalName,
53
			  isLocallyDefined, Module,
sof's avatar
sof committed
54 55
			  NamedThing(..)
			)
sof's avatar
sof committed
56
import PrelVals		( nO_METHOD_BINDING_ERROR_ID, eRROR_ID )
57
import PprType		( pprParendType,  pprConstraint )
sof's avatar
sof committed
58
import SrcLoc		( SrcLoc, noSrcLoc )
59 60 61 62 63
import TyCon		( isSynTyCon, isDataTyCon, tyConDerivings )
import Type		( Type, ThetaType, isUnpointedType,
			  splitSigmaTy, isTyVarTy, mkSigmaTy,
			  splitTyConApp_maybe, splitDictTy_maybe,
			  splitAlgTyConApp_maybe, splitRhoTy,
64
			  tyVarsOfTypes
65
			)
66
import TyVar		( zipTyVarEnv, mkTyVarSet, tyVarSetToList, TyVar )
67
import TysPrim		( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
68
import TysWiredIn	( stringTy )
69
import Unique		( Unique, cCallableClassKey, cReturnableClassKey, Uniquable(..) )
70
import Outputable
71 72 73
\end{code}

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

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.


84 85
Here is the overall algorithm.
Assume that we have an instance declaration
86

87
    instance c => k (t tvs) where b
88 89 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

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

\begin{code}
sof's avatar
sof committed
147 148
tcInstDecls1 :: TcEnv s			-- Contains IdInfo for dfun ids
	     -> [RenamedHsDecl]
149
	     -> Module			-- module name for deriving
150
	     -> RnNameSupply			-- for renaming derivings
151 152
	     -> TcM s (Bag InstInfo,
		       RenamedHsBinds,
153
		       SDoc)
154

sof's avatar
sof committed
155
tcInstDecls1 unf_env decls mod_name rn_name_supply
156
  = 	-- Do the ordinary instance declarations
sof's avatar
sof committed
157
    mapNF_Tc (tcInstDecl1 unf_env mod_name) 
158
	     [inst_decl | InstD inst_decl <- decls]	`thenNF_Tc` \ inst_info_bags ->
159
    let
160
	decl_inst_info = unionManyBags inst_info_bags
161
    in
162 163
	-- Handle "derived" instances; note that we only do derivings
	-- for things in this module; we ignore deriving decls from
164
	-- interfaces!
165
    tcDeriving mod_name rn_name_supply decl_inst_info
166
		    	`thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) ->
167

168
    let
169
	full_inst_info = deriv_inst_info `unionBags` decl_inst_info
170
    in
171 172 173
    returnTc (full_inst_info, deriv_binds, ddump_deriv)


sof's avatar
sof committed
174
tcInstDecl1 :: TcEnv s -> Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
175

sof's avatar
sof committed
176
tcInstDecl1 unf_env mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
177 178 179 180
  = 	-- Prime error recovery, set source location
    recoverNF_Tc (returnNF_Tc emptyBag)	$
    tcAddSrcLoc src_loc			$

181 182 183 184 185 186 187 188
	-- Type-check all the stuff before the "where"
    tcHsType poly_ty			`thenTc` \ poly_ty' ->
    let
	(tyvars, theta, dict_ty) = splitSigmaTy poly_ty'
	(clas, inst_tys)         = case splitDictTy_maybe dict_ty of
				     Nothing   -> pprPanic "tcInstDecl1" (ppr poly_ty)
				     Just pair -> pair
    in
189 190

	-- Check for respectable instance type
191
    scrutiniseInstanceType clas inst_tys	`thenTc_`
192 193

	-- Make the dfun id and constant-method ids
sof's avatar
sof committed
194 195
    let
	(dfun_id, dfun_theta) = mkInstanceRelatedIds dfun_name
196
				         clas tyvars inst_tys theta
sof's avatar
sof committed
197 198 199
	-- Add info from interface file
	final_dfun_id = tcAddImportedIdInfo unf_env dfun_id
    in
200 201
    returnTc (unitBag (InstInfo clas tyvars inst_tys theta	
				dfun_theta final_dfun_id
202
			     	binds src_loc uprags))
203 204 205 206 207 208 209 210 211 212
\end{code}


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

\begin{code}
213
tcInstDecls2 :: Bag InstInfo
sof's avatar
sof committed
214
	     -> NF_TcM s (LIE s, TcMonoBinds s)
215

216
tcInstDecls2 inst_decls
sof's avatar
sof committed
217
  = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyMonoBinds)) inst_decls
218 219 220 221
  where
    combine tc1 tc2 = tc1 	`thenNF_Tc` \ (lie1, binds1) ->
		      tc2	`thenNF_Tc` \ (lie2, binds2) ->
		      returnNF_Tc (lie1 `plusLIE` lie2,
sof's avatar
sof committed
222
				   binds1 `AndMonoBinds` binds2)
223 224 225 226 227
\end{code}


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

228
The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
229 230 231 232 233 234 235 236 237 238 239 240 241 242
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}

243 244
HOWEVER, if the instance decl has no context, then it returns a
bigger @HsBinds@ with declarations for each method.  For example
245
\begin{verbatim}
246
	instance Foo [a] where
247 248 249 250 251
		op1 x = ...
		op2 y = ...
\end{verbatim}
might produce
\begin{verbatim}
252 253 254
	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 = ...
255 256 257 258
\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}
259
	const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
260 261 262
\end{verbatim}
that is, the default method applied to the dictionary at this type.

263
What we actually produce in either case is:
264

265 266 267 268 269 270
	AbsBinds [a] [dfun_theta_dicts]
		 [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
		 { d = (sd1,sd2, ..., op1, op2, ...)
		   op1 = ...
		   op2 = ...
	 	 }
271

272 273
The "maybe" says that we only ask AbsBinds to make global constant methods
if the dfun_theta is empty.
274

275 276
		
For an instance declaration, say,
277 278 279 280 281 282 283 284 285 286 287 288 289

	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.

290 291
First comes the easy case of a non-local instance decl.

292
\begin{code}
sof's avatar
sof committed
293
tcInstDecl2 :: InstInfo -> NF_TcM s (LIE s, TcMonoBinds s)
294

295
tcInstDecl2 (InstInfo clas inst_tyvars inst_tys
296
		      inst_decl_theta dfun_theta
297 298 299
		      dfun_id monobinds
		      locn uprags)
  | not (isLocallyDefined dfun_id)
sof's avatar
sof committed
300
  = returnNF_Tc (emptyLIE, EmptyMonoBinds)
301

sof's avatar
sof committed
302 303 304 305 306 307 308 309 310 311 312
{-
  -- I deleted this "optimisation" because when importing these
  -- instance decls the renamer would look for the dfun bindings and they weren't there.
  -- This would be fixable, but it seems simpler just to produce a tiny void binding instead,
  -- even though it's never used.

	-- This case deals with CCallable etc, which don't need any bindings
  | isNoDictClass clas			
  = returnNF_Tc (emptyLIE, EmptyBinds)
-}

313
  | otherwise
314
  =	 -- Prime error recovery
sof's avatar
sof committed
315 316
    recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds))  $
    tcAddSrcLoc locn					   $
317 318 319

	-- Get the class signature
    let 
sof's avatar
sof committed
320
	origin = InstanceDeclOrigin
321 322
        (class_tyvars,
	 sc_theta, sc_sel_ids,
sof's avatar
sof committed
323
	 op_sel_ids, defm_ids) = classBigSig clas
324
    in
325 326 327 328
      
	-- Instantiate the instance decl with tc-style type variables
    tcInstSigTyVars inst_tyvars		`thenNF_Tc` \ (inst_tyvars', _, tenv) ->
    mapNF_Tc (tcInstType tenv) inst_tys	`thenNF_Tc` \ inst_tys' ->
329 330
    tcInstTheta tenv dfun_theta		`thenNF_Tc` \ dfun_theta' ->
    tcInstTheta tenv inst_decl_theta	`thenNF_Tc` \ inst_decl_theta' ->
331 332 333 334

         -- Instantiate the super-class context with inst_tys
    tcInstTheta (zipTyVarEnv class_tyvars inst_tys') sc_theta		`thenNF_Tc` \ sc_theta' ->

335 336 337 338
	 -- Create dictionary Ids from the specified instance contexts.
    newDicts origin sc_theta'		`thenNF_Tc` \ (sc_dicts,        sc_dict_ids) ->
    newDicts origin dfun_theta'		`thenNF_Tc` \ (dfun_arg_dicts,  dfun_arg_dicts_ids)  ->
    newDicts origin inst_decl_theta'	`thenNF_Tc` \ (inst_decl_dicts, _) ->
339
    newDicts origin [(clas,inst_tys')]	`thenNF_Tc` \ (this_dict,       [this_dict_id]) ->
340

341
	 -- Check that all the method bindings come from this class
342
    let
sof's avatar
sof committed
343
	check_from_this_class (bndr, loc)
344 345 346
	  | nameOccName bndr `elem` sel_names = returnNF_Tc ()
	  | otherwise			      = tcAddSrcLoc loc $
						addErrTc (badMethodErr bndr clas)
sof's avatar
sof committed
347
	sel_names = map getOccName op_sel_ids
348
	bndrs = bagToList (collectMonoBinders monobinds)
349
    in
350
    mapNF_Tc check_from_this_class bndrs		`thenNF_Tc_`
351

352
    tcExtendGlobalValEnv (catMaybes defm_ids) (
353

354
		-- Default-method Ids may be mentioned in synthesised RHSs 
sof's avatar
sof committed
355
	mapAndUnzip3Tc (tcInstMethodBind clas inst_tys' inst_tyvars' monobinds uprags) 
sof's avatar
sof committed
356
		       (op_sel_ids `zip` defm_ids)
357
    )		 	`thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
358

sof's avatar
sof committed
359 360 361 362 363 364 365 366
	-- Deal with SPECIALISE instance pragmas
    let
	dfun_prags = [Sig (idName dfun_id) ty loc | SpecInstSig ty loc <- uprags]
    in
    tcExtendGlobalValEnv [dfun_id] (
	tcPragmaSigs dfun_prags
    )					`thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->

367
	-- Check the overloading constraints of the methods and superclasses
368 369
    mapNF_Tc zonkSigTyVar inst_tyvars' 	`thenNF_Tc` \ zonked_inst_tyvars ->

sof's avatar
sof committed
370
    let
371 372
        inst_tyvars_set = mkTyVarSet zonked_inst_tyvars

sof's avatar
sof committed
373
	(meth_lies, meth_ids) = unzip meth_lies_w_ids
374 375 376 377 378 379 380

		 -- These insts are in scope; quite a few, eh?
	avail_insts = this_dict			`plusLIE` 
		      dfun_arg_dicts		`plusLIE`
		      sc_dicts			`plusLIE`
		      unionManyBags meth_lies

381 382
        methods_lie = plusLIEs insts_needed_s
    in
383 384 385 386 387

	-- Check that we *could* construct the superclass dictionaries,
	-- even though we are *actually* going to pass the superclass dicts in;
	-- the check ensures that the caller will never have a problem building
	-- them.
388 389 390
    tcAddErrCtxt superClassCtxt (
      tcSimplifyAndCheck
		 (ptext SLIT("instance declaration context"))
391
		 inst_tyvars_set		-- Local tyvars
392 393
		 inst_decl_dicts		-- The instance dictionaries available
		 sc_dicts			-- The superclass dicationaries reqd
394 395
    )					`thenTc_`
    						-- Ignore the result; we're only doing
396
						-- this to make sure it can be done.
397

398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415
	-- Ditto method bindings
    tcAddErrCtxt methodCtxt (
      tcSimplifyAndCheck
		 (ptext SLIT("instance declaration context"))
		 inst_tyvars_set			-- Local tyvars
		 avail_insts
		 methods_lie
    )						 `thenTc_`
    
		-- Now do the simplification again, this time to get the
		-- bindings; this time we use an enhanced "avails"
		-- Ignore errors because they come from the *previous* tcSimplifys
    discardErrsTc (
	tcSimplifyAndCheck
		 (ptext SLIT("instance declaration context"))
		 inst_tyvars_set
		 dfun_arg_dicts		-- NB! Don't include this_dict here, else the sc_dicts
					-- get bound by just selecting from this_dict!!
sof's avatar
sof committed
416
		 (sc_dicts `plusLIE` methods_lie `plusLIE` prag_lie)
417 418 419
    )						 `thenTc` \ (const_lie, lie_binds) ->
	

sof's avatar
sof committed
420
	-- Create the result bindings
421
    let
sof's avatar
sof committed
422 423 424 425 426 427 428 429 430 431 432 433
        dict_constr   = classDataCon clas
	scs_and_meths = sc_dict_ids ++ meth_ids

	dict_rhs
	  | null scs_and_meths
	  = 	-- Blatant special case for CCallable, CReturnable
		-- 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.
	   HsApp (TyApp (HsVar (RealId eRROR_ID)) [tcIdType this_dict_id])
434
		 (HsLitOut (HsString msg) stringTy)
sof's avatar
sof committed
435 436 437 438

	  | otherwise	-- The common case
	  = foldl HsApp (TyApp (HsVar (RealId dict_constr)) inst_tys')
			       (map HsVar (sc_dict_ids ++ meth_ids))
439 440
		-- We don't produce a binding for the dict_constr; instead we
		-- rely on the simplifier to unfold this saturated application
441 442
	  where
	    msg = _PK_ ("Compiler error: bad dictionary " ++ showSDoc (ppr clas))
443

sof's avatar
sof committed
444
	dict_bind    = VarMonoBind this_dict_id dict_rhs
sof's avatar
sof committed
445 446
	method_binds = andMonoBinds method_binds_s

sof's avatar
sof committed
447 448
	final_dfun_id = replaceIdInfo dfun_id (prag_info_fn (idName dfun_id))
				-- Pretty truesome
sof's avatar
sof committed
449
	main_bind
sof's avatar
sof committed
450
	  = AbsBinds
451
		 zonked_inst_tyvars
452
		 dfun_arg_dicts_ids
sof's avatar
sof committed
453
		 [(inst_tyvars', RealId final_dfun_id, this_dict_id)] 
454
		 (lie_binds	`AndMonoBinds` 
sof's avatar
sof committed
455
		  method_binds	`AndMonoBinds`
sof's avatar
sof committed
456
		  prag_binds	`AndMonoBinds`
sof's avatar
sof committed
457
		  dict_bind)
458
    in
sof's avatar
sof committed
459 460
    returnTc (const_lie,
	      main_bind `AndMonoBinds` prag_binds)
461 462 463 464 465 466 467 468 469 470
\end{code}


%************************************************************************
%*									*
\subsection{Processing each method}
%*									*
%************************************************************************

\begin{code}
sof's avatar
sof committed
471
tcInstMethodBind 
sof's avatar
sof committed
472
	:: Class
473 474
	-> [TcType s]					-- Instance types
	-> [TcTyVar s]					-- and their free (sig) tyvars
sof's avatar
sof committed
475
	-> RenamedMonoBinds				-- Method binding
sof's avatar
sof committed
476
	-> [RenamedSig]					-- Pragmas
sof's avatar
sof committed
477
	-> (Id, Maybe Id)				-- Selector id and default-method id
sof's avatar
sof committed
478 479
	-> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))

sof's avatar
sof committed
480
tcInstMethodBind clas inst_tys inst_tyvars meth_binds prags (sel_id, maybe_dm_id)
sof's avatar
sof committed
481 482
  = tcGetSrcLoc			`thenNF_Tc` \ loc ->
    tcGetUnique			`thenNF_Tc` \ uniq ->
483
    let
sof's avatar
sof committed
484 485
	sel_name	  = idName sel_id
	meth_occ	  = getOccName sel_name
sof's avatar
sof committed
486
	default_meth_name = mkLocalName uniq meth_occ loc
487
	maybe_meth_bind   = find sel_name meth_binds 
sof's avatar
sof committed
488
        the_meth_bind     = case maybe_meth_bind of
sof's avatar
sof committed
489
				  Just stuff -> stuff
490
				  Nothing    -> mk_default_bind default_meth_name loc
sof's avatar
sof committed
491
	meth_prags	  = sigsForMe (== sel_name) prags
492
    in
sof's avatar
sof committed
493

494 495
	-- Warn if no method binding, only if -fwarn-missing-methods
    
496
    warnTc (opt_WarnMissingMethods &&
497
	    not (maybeToBool maybe_meth_bind) &&
sof's avatar
sof committed
498
	    not (maybeToBool maybe_dm_id))	
499
	(omittedMethodWarn sel_id clas)		`thenNF_Tc_`
sof's avatar
sof committed
500

sof's avatar
sof committed
501
	-- Typecheck the method binding
sof's avatar
sof committed
502
    tcMethodBind clas origin inst_tys inst_tyvars sel_id the_meth_bind meth_prags
sof's avatar
sof committed
503 504
  where
    origin = InstanceDeclOrigin 	-- Poor
505

506 507
    find sel EmptyMonoBinds 	  = Nothing
    find sel (AndMonoBinds b1 b2) = find sel b1 `seqMaybe` find sel b2
508

509 510 511 512 513
    find sel b@(FunMonoBind op_name _ _ _)          | op_name == sel = Just b
						    | otherwise	     = Nothing
    find sel b@(PatMonoBind (VarPatIn op_name) _ _) | op_name == sel = Just b
						    | otherwise      = Nothing
    find sel other = panic "Urk! Bad instance method binding"
sof's avatar
sof committed
514 515


516
    mk_default_bind local_meth_name loc
sof's avatar
sof committed
517
      = PatMonoBind (VarPatIn local_meth_name)
sof's avatar
sof committed
518
		    (GRHSsAndBindsIn (unguardedRHS (default_expr loc) loc) EmptyBinds)
519
		    loc
sof's avatar
sof committed
520

sof's avatar
sof committed
521 522 523 524
    default_expr loc 
      = case maybe_dm_id of
	  Just dm_id -> HsVar (getName dm_id)	-- There's a default method
   	  Nothing    -> error_expr loc		-- No default method
sof's avatar
sof committed
525

sof's avatar
sof committed
526 527 528 529 530
    error_expr loc
      = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID)) 
	             (HsLit (HsString (_PK_ (error_msg loc))))

    error_msg loc = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
531 532 533
\end{code}


sof's avatar
sof committed
534

535 536
%************************************************************************
%*									*
537
\subsection{Checking for a decent instance type}
538 539 540
%*									*
%************************************************************************

541 542 543 544 545 546 547 548 549 550
@scrutiniseInstanceType@ checks the type {\em and} its syntactic constraints:
it must normally look like: @instance Foo (Tycon a b c ...) ...@

The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
flag is on, or (2)~the instance is imported (they must have been
compiled elsewhere). In these cases, we let them go through anyway.

We can also have instances for functions: @instance Foo (a -> b) ...@.

\begin{code}
551 552
scrutiniseInstanceType clas inst_taus
  |	-- CCALL CHECK (a).... urgh!
sof's avatar
sof committed
553 554 555 556 557 558
	-- To verify that a user declaration of a CCallable/CReturnable 
	-- instance is OK, we must be able to see the constructor(s)
	-- of the instance type (see next guard.)
	--  
        -- We flag this separately to give a more precise error msg.
        --
559 560
     (uniqueOf clas == cCallableClassKey || uniqueOf clas == cReturnableClassKey)
  && is_alg_tycon_app && not constructors_visible
561
  = failWithTc (invisibleDataConPrimCCallErr clas first_inst_tau)
sof's avatar
sof committed
562

563
  |	-- CCALL CHECK (b) 
564
	-- A user declaration of a CCallable/CReturnable instance
565
	-- must be for a "boxed primitive" type.
566 567 568 569 570 571 572
    (uniqueOf clas == cCallableClassKey   && not (ccallable_type   first_inst_tau)) ||
    (uniqueOf clas == cReturnableClassKey && not (creturnable_type first_inst_tau))
  = failWithTc (nonBoxedPrimCCallErr clas first_inst_tau)

  	-- DERIVING CHECK
	-- It is obviously illegal to have an explicit instance
	-- for something that we are also planning to `derive'
573
  | maybeToBool alg_tycon_app_maybe && clas `elem` (tyConDerivings alg_tycon)
574 575 576 577
  = failWithTc (derivingWhenInstanceExistsErr clas first_inst_tau)
	   -- Kind check will have ensured inst_taus is of length 1

	-- WITH HASKELL 1.4, MUST HAVE C (T a b c)
578
  |  not opt_GlasgowExts
579
  && not (length inst_taus == 1 &&
580 581 582
	  maybeToBool maybe_tycon_app &&	-- Yes, there's a type constuctor
          not (isSynTyCon tycon) &&		-- ...but not a synonym
          all isTyVarTy arg_tys && 		-- Applied to type variables
583 584 585 586 587 588 589
	  length (tyVarSetToList (tyVarsOfTypes arg_tys)) == length arg_tys
		 -- This last condition checks that all the type variables are distinct
     )
  = failWithTc (instTypeErr clas inst_taus
			(text "the instance type must be of form (T a b c)" $$
			 text "where T is not a synonym, and a,b,c are distinct type variables")
    )
590 591

  | otherwise
592
  = returnTc ()
593 594

  where
595
    (first_inst_tau : _)       = inst_taus
596

597 598 599 600 601 602 603 604 605 606 607 608
	-- Stuff for algebraic or -> type
    maybe_tycon_app	  = splitTyConApp_maybe first_inst_tau
    Just (tycon, arg_tys) = maybe_tycon_app

	-- Stuff for an *algebraic* data type
    alg_tycon_app_maybe	           = splitAlgTyConApp_maybe first_inst_tau
					-- The "Alg" part looks through synonyms
    is_alg_tycon_app		   = maybeToBool alg_tycon_app_maybe
    Just (alg_tycon, _, data_cons) = alg_tycon_app_maybe

    constructors_visible = not (null data_cons)
 
sof's avatar
sof committed
609

610 611 612
-- These conditions come directly from what the DsCCall is capable of.
-- Totally grotesque.  Green card should solve this.

613
ccallable_type   ty = isUnpointedType ty ||				-- Allow CCallable Int# etc
614
                      maybeToBool (maybeBoxedPrimType ty) ||	-- Ditto Int etc
615
		      ty == stringTy ||
616 617
		      byte_arr_thing
  where
618
    byte_arr_thing = case splitAlgTyConApp_maybe ty of
sof's avatar
sof committed
619
			Just (tycon, ty_args, [data_con]) | isDataTyCon tycon -> 
620 621 622 623 624 625 626
		     		length data_con_arg_tys == 2 &&
				maybeToBool maybe_arg2_tycon &&
				(arg2_tycon == byteArrayPrimTyCon ||
				 arg2_tycon == mutableByteArrayPrimTyCon)
			     where
				data_con_arg_tys = dataConArgTys data_con ty_args
				(data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
627
				maybe_arg2_tycon = splitTyConApp_maybe data_con_arg_ty2
628 629 630 631 632 633
				Just (arg2_tycon,_) = maybe_arg2_tycon

			other -> False

creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
			-- Or, a data type with a single nullary constructor
634
		      case (splitAlgTyConApp_maybe ty) of
635 636 637
			Just (tycon, tys_applied, [data_con])
				-> isNullaryDataCon data_con
			other -> False
638 639 640 641
\end{code}

\begin{code}

642 643 644 645 646 647
instTypeErr clas tys msg
  = sep [ptext SLIT("Illegal instance declaration for") <+> quotes (pprConstraint clas tys),
	 nest 4 (parens msg)
    ]

derivingWhenInstanceExistsErr clas tycon
sof's avatar
sof committed
648
  = hang (hsep [ptext SLIT("Deriving class"), 
649 650
		       quotes (ppr clas), 
		       ptext SLIT("type"), quotes (ppr tycon)])
sof's avatar
sof committed
651
         4 (ptext SLIT("when an explicit instance exists"))
652

653
nonBoxedPrimCCallErr clas inst_ty
sof's avatar
sof committed
654
  = hang (ptext SLIT("Unacceptable instance type for ccall-ish class"))
655 656 657 658
	 4 (hsep [ ptext SLIT("class"), ppr clas, ptext SLIT("type"),
    		        ppr inst_ty])

omittedMethodWarn sel_id clas
659
  = sep [ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id), 
660
	 ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)]
661

sof's avatar
sof committed
662 663 664 665 666 667
{-
  Declaring CCallable & CReturnable instances in a module different
  from where the type was defined. Caused by importing data type
  abstractly (either programmatically or by the renamer being over-eager
  in its pruning.)
-}
668 669 670 671 672
invisibleDataConPrimCCallErr clas inst_ty
  = hang (hsep [ptext SLIT("Constructors for"), quotes (ppr inst_ty),
		ptext SLIT("not visible when checking"),
                quotes (ppr clas), ptext SLIT("instance")])
        4 (hsep [text "(Try either importing", ppr inst_ty, 
sof's avatar
sof committed
673
	         text "non-abstractly or compile using -fno-prune-tydecls ..)"])
sof's avatar
sof committed
674

675 676
methodCtxt     = ptext SLIT("When checking the methods of an instance declaration")
superClassCtxt = ptext SLIT("When checking the superclasses of an instance declaration")
677
\end{code}