2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcInstDecls]{Typechecking instance declarations}
12 #include "HsVersions.h"
14 import HsSyn ( HsDecl(..), InstDecl(..),
15 HsBinds(..), MonoBinds(..), GRHSsAndBinds(..), GRHS(..),
16 HsExpr(..), InPat(..), HsLit(..), Sig(..),
18 collectMonoBinders, andMonoBinds
20 import HsBinds ( sigsForMe )
21 import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds,
22 RenamedInstDecl, RenamedHsExpr,
23 RenamedSig, RenamedHsDecl
25 import TcHsSyn ( TcMonoBinds, TcIdOcc(..), TcIdBndr,
26 maybeBoxedPrimType, tcIdType
29 import TcBinds ( tcPragmaSigs )
30 import TcClassDcl ( tcMethodBind, badMethodErr )
32 import RnMonad ( RnNameSupply )
33 import Inst ( Inst, InstOrigin(..),
34 newDicts, LIE, emptyLIE, plusLIE, plusLIEs )
35 import TcDeriv ( tcDeriving )
36 import TcEnv ( GlobalValueEnv, tcExtendGlobalValEnv, tcAddImportedIdInfo )
37 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, tcInstSigType, tcInstTheta
45 import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
46 foldBag, bagToList, Bag
48 import CmdLineOpts ( opt_GlasgowExts )
49 import Class ( classBigSig, Class )
50 import Id ( isNullaryDataCon, dataConArgTys, replaceIdInfo, idName, idType, Id )
51 import Maybes ( maybeToBool, seqMaybe, catMaybes, expectJust )
52 import Name ( nameOccName, mkLocalName,
53 isLocallyDefined, Module,
56 import PrelVals ( eRROR_ID )
57 import PprType ( pprParendType, pprConstraint )
58 import SrcLoc ( SrcLoc, noSrcLoc )
59 import TyCon ( isSynTyCon, isDataTyCon, tyConDerivings )
60 import Type ( Type, ThetaType, isUnpointedType,
61 splitSigmaTy, isTyVarTy, mkSigmaTy,
62 splitTyConApp_maybe, splitDictTy_maybe,
63 splitAlgTyConApp_maybe, splitRhoTy,
64 tyVarsOfTypes, mkTyVarTys,
66 import TyVar ( zipTyVarEnv, mkTyVarSet, tyVarSetToList, TyVar )
67 import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
68 import TysWiredIn ( stringTy )
69 import Unique ( Unique, cCallableClassKey, cReturnableClassKey, Uniquable(..) )
73 Typechecking instance declarations is done in two passes. The first
74 pass, made by @tcInstDecls1@, collects information to be used in the
77 This pre-processed info includes the as-yet-unprocessed bindings
78 inside the instance declaration. These are type-checked in the second
79 pass, when the class-instance envs and GVE contain all the info from
80 all the instance and value decls. Indeed that's the reason we need
81 two passes over the instance decls.
84 Here is the overall algorithm.
85 Assume that we have an instance declaration
87 instance c => k (t tvs) where b
91 $LIE_c$ is the LIE for the context of class $c$
93 $betas_bar$ is the free variables in the class method type, excluding the
96 $LIE_cop$ is the LIE constraining a particular class method
98 $tau_cop$ is the tau type of a class method
100 $LIE_i$ is the LIE for the context of instance $i$
102 $X$ is the instance constructor tycon
104 $gammas_bar$ is the set of type variables of the instance
106 $LIE_iop$ is the LIE for a particular class method instance
108 $tau_iop$ is the tau type for this instance of a class method
110 $alpha$ is the class variable
112 $LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
114 $tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
117 ToDo: Update the list above with names actually in the code.
121 First, make the LIEs for the class and instance contexts, which means
122 instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
123 and make LIElistI and LIEI.
125 Then process each method in turn.
127 order the instance methods according to the ordering of the class methods
129 express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
131 Create final dictionary function from bindings generated already
133 df = lambda inst_tyvars
140 in <op1,op2,...,opn,sd1,...,sdm>
142 Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
143 and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
147 tcInstDecls1 :: GlobalValueEnv -- Contains IdInfo for dfun ids
149 -> Module -- module name for deriving
150 -> RnNameSupply -- for renaming derivings
151 -> TcM s (Bag InstInfo,
155 tcInstDecls1 unf_env decls mod_name rn_name_supply
156 = -- Do the ordinary instance declarations
157 mapNF_Tc (tcInstDecl1 unf_env mod_name)
158 [inst_decl | InstD inst_decl <- decls] `thenNF_Tc` \ inst_info_bags ->
160 decl_inst_info = unionManyBags inst_info_bags
162 -- Handle "derived" instances; note that we only do derivings
163 -- for things in this module; we ignore deriving decls from
165 tcDeriving mod_name rn_name_supply decl_inst_info
166 `thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) ->
169 full_inst_info = deriv_inst_info `unionBags` decl_inst_info
171 returnTc (full_inst_info, deriv_binds, ddump_deriv)
174 tcInstDecl1 :: GlobalValueEnv -> Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
176 tcInstDecl1 unf_env mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
177 = -- Prime error recovery, set source location
178 recoverNF_Tc (returnNF_Tc emptyBag) $
179 tcAddSrcLoc src_loc $
181 -- Type-check all the stuff before the "where"
182 tcHsType poly_ty `thenTc` \ poly_ty' ->
184 (tyvars, theta, dict_ty) = splitSigmaTy poly_ty'
185 (clas, inst_tys) = case splitDictTy_maybe dict_ty of
186 Nothing -> pprPanic "tcInstDecl1" (ppr poly_ty)
190 -- Check for respectable instance type, and context
191 scrutiniseInstanceHead clas inst_tys `thenNF_Tc_`
192 mapNF_Tc scrutiniseInstanceConstraint theta `thenNF_Tc_`
194 -- Make the dfun id and constant-method ids
196 (dfun_id, dfun_theta) = mkInstanceRelatedIds dfun_name
197 clas tyvars inst_tys theta
198 -- Add info from interface file
199 final_dfun_id = tcAddImportedIdInfo unf_env dfun_id
201 returnTc (unitBag (InstInfo clas tyvars inst_tys theta
202 dfun_theta final_dfun_id
203 binds src_loc uprags))
207 %************************************************************************
209 \subsection{Type-checking instance declarations, pass 2}
211 %************************************************************************
214 tcInstDecls2 :: Bag InstInfo
215 -> NF_TcM s (LIE s, TcMonoBinds s)
217 tcInstDecls2 inst_decls
218 = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyMonoBinds)) inst_decls
220 combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
221 tc2 `thenNF_Tc` \ (lie2, binds2) ->
222 returnNF_Tc (lie1 `plusLIE` lie2,
223 binds1 `AndMonoBinds` binds2)
227 ======= New documentation starts here (Sept 92) ==============
229 The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
230 the dictionary function for this instance declaration. For example
232 instance Foo a => Foo [a] where
236 might generate something like
238 dfun.Foo.List dFoo_a = let op1 x = ...
244 HOWEVER, if the instance decl has no context, then it returns a
245 bigger @HsBinds@ with declarations for each method. For example
247 instance Foo [a] where
253 dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
254 const.Foo.op1.List a x = ...
255 const.Foo.op2.List a y = ...
257 This group may be mutually recursive, because (for example) there may
258 be no method supplied for op2 in which case we'll get
260 const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
262 that is, the default method applied to the dictionary at this type.
264 What we actually produce in either case is:
266 AbsBinds [a] [dfun_theta_dicts]
267 [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
268 { d = (sd1,sd2, ..., op1, op2, ...)
273 The "maybe" says that we only ask AbsBinds to make global constant methods
274 if the dfun_theta is empty.
277 For an instance declaration, say,
279 instance (C1 a, C2 b) => C (T a b) where
282 where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
283 function whose type is
285 (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
287 Notice that we pass it the superclass dictionaries at the instance type; this
288 is the ``Mark Jones optimisation''. The stuff before the "=>" here
289 is the @dfun_theta@ below.
291 First comes the easy case of a non-local instance decl.
294 tcInstDecl2 :: InstInfo -> NF_TcM s (LIE s, TcMonoBinds s)
296 tcInstDecl2 (InstInfo clas inst_tyvars inst_tys
297 inst_decl_theta dfun_theta
300 | not (isLocallyDefined dfun_id)
301 = returnNF_Tc (emptyLIE, EmptyMonoBinds)
304 -- I deleted this "optimisation" because when importing these
305 -- instance decls the renamer would look for the dfun bindings and they weren't there.
306 -- This would be fixable, but it seems simpler just to produce a tiny void binding instead,
307 -- even though it's never used.
309 -- This case deals with CCallable etc, which don't need any bindings
311 = returnNF_Tc (emptyLIE, EmptyBinds)
315 = -- Prime error recovery
316 recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
319 -- Instantiate the instance decl with tc-style type variables
320 tcInstSigType (idType dfun_id) `thenNF_Tc` \ dfun_ty' ->
323 dfun_theta', dict_ty') = splitSigmaTy dfun_ty'
325 (clas, inst_tys') = expectJust "tcInstDecl2" (splitDictTy_maybe dict_ty')
328 sc_theta, sc_sel_ids,
329 op_sel_ids, defm_ids) = classBigSig clas
331 origin = InstanceDeclOrigin
333 -- Instantiate the theta found in the original instance decl
334 tcInstTheta (zipTyVarEnv inst_tyvars (mkTyVarTys inst_tyvars'))
335 inst_decl_theta `thenNF_Tc` \ inst_decl_theta' ->
337 -- Instantiate the super-class context with the instance types
338 tcInstTheta (zipTyVarEnv class_tyvars inst_tys') sc_theta `thenNF_Tc` \ sc_theta' ->
340 -- Create dictionary Ids from the specified instance contexts.
341 newDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) ->
342 newDicts origin dfun_theta' `thenNF_Tc` \ (dfun_arg_dicts, dfun_arg_dicts_ids) ->
343 newDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) ->
344 newDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
346 -- Check that all the method bindings come from this class
348 check_from_this_class (bndr, loc)
349 | nameOccName bndr `elem` sel_names = returnNF_Tc ()
350 | otherwise = tcAddSrcLoc loc $
351 addErrTc (badMethodErr bndr clas)
352 sel_names = map getOccName op_sel_ids
353 bndrs = bagToList (collectMonoBinders monobinds)
355 mapNF_Tc check_from_this_class bndrs `thenNF_Tc_`
357 tcExtendGlobalValEnv (catMaybes defm_ids) (
359 -- Default-method Ids may be mentioned in synthesised RHSs
360 mapAndUnzip3Tc (tcMethodBind clas origin inst_tys' inst_tyvars' monobinds uprags True)
361 (op_sel_ids `zip` defm_ids)
362 ) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
364 -- Deal with SPECIALISE instance pragmas
366 dfun_prags = [Sig (idName dfun_id) ty loc | SpecInstSig ty loc <- uprags]
368 tcExtendGlobalValEnv [dfun_id] (
369 tcPragmaSigs dfun_prags
370 ) `thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
372 -- Check the overloading constraints of the methods and superclasses
373 mapNF_Tc zonkSigTyVar inst_tyvars' `thenNF_Tc` \ zonked_inst_tyvars ->
376 inst_tyvars_set = mkTyVarSet zonked_inst_tyvars
378 (meth_lies, meth_ids) = unzip meth_lies_w_ids
380 -- These insts are in scope; quite a few, eh?
381 avail_insts = this_dict `plusLIE`
382 dfun_arg_dicts `plusLIE`
384 unionManyBags meth_lies
386 methods_lie = plusLIEs insts_needed_s
389 -- Ditto method bindings
390 tcAddErrCtxt methodCtxt (
392 (ptext SLIT("instance declaration context"))
393 inst_tyvars_set -- Local tyvars
396 ) `thenTc` \ (const_lie1, lie_binds1) ->
398 -- Check that we *could* construct the superclass dictionaries,
399 -- even though we are *actually* going to pass the superclass dicts in;
400 -- the check ensures that the caller will never have
401 --a problem building them.
402 tcAddErrCtxt superClassCtxt (
404 (ptext SLIT("instance declaration context"))
405 inst_tyvars_set -- Local tyvars
406 inst_decl_dicts -- The instance dictionaries available
407 sc_dicts -- The superclass dicationaries reqd
409 -- Ignore the result; we're only doing
410 -- this to make sure it can be done.
412 -- Now do the simplification again, this time to get the
413 -- bindings; this time we use an enhanced "avails"
414 -- Ignore errors because they come from the *previous* tcSimplify
417 (ptext SLIT("instance declaration context"))
419 dfun_arg_dicts -- NB! Don't include this_dict here, else the sc_dicts
420 -- get bound by just selecting from this_dict!!
422 ) `thenTc` \ (const_lie2, lie_binds2) ->
425 -- Create the result bindings
427 dict_constr = classDataCon clas
428 scs_and_meths = sc_dict_ids ++ meth_ids
432 = -- Blatant special case for CCallable, CReturnable [and Eval -- sof 5/98]
433 -- If the dictionary is empty then we should never
434 -- select anything from it, so we make its RHS just
435 -- emit an error message. This in turn means that we don't
436 -- mention the constructor, which doesn't exist for CCallable, CReturnable
437 -- Hardly beautiful, but only three extra lines.
438 HsApp (TyApp (HsVar (RealId eRROR_ID)) [tcIdType this_dict_id])
439 (HsLitOut (HsString msg) stringTy)
441 | otherwise -- The common case
442 = foldl HsApp (TyApp (HsVar (RealId dict_constr)) inst_tys')
443 (map HsVar (sc_dict_ids ++ meth_ids))
444 -- We don't produce a binding for the dict_constr; instead we
445 -- rely on the simplifier to unfold this saturated application
446 -- We do this rather than generate an HsCon directly, because
447 -- it means that the special cases (e.g. dictionary with only one
448 -- member) are dealt with by the common MkId.mkDataConId code rather
449 -- than needing to be repeated here.
452 msg = _PK_ ("Compiler error: bad dictionary " ++ showSDoc (ppr clas))
454 dict_bind = VarMonoBind this_dict_id dict_rhs
455 method_binds = andMonoBinds method_binds_s
457 final_dfun_id = replaceIdInfo dfun_id (prag_info_fn (idName dfun_id))
463 [(inst_tyvars', RealId final_dfun_id, this_dict_id)]
464 (lie_binds1 `AndMonoBinds`
465 lie_binds2 `AndMonoBinds`
466 method_binds `AndMonoBinds`
469 returnTc (const_lie1 `plusLIE` const_lie2 `plusLIE` prag_lie,
470 main_bind `AndMonoBinds` prag_binds)
474 %************************************************************************
476 \subsection{Checking for a decent instance type}
478 %************************************************************************
480 @scrutiniseInstanceHead@ checks the type {\em and} its syntactic constraints:
481 it must normally look like: @instance Foo (Tycon a b c ...) ...@
483 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
484 flag is on, or (2)~the instance is imported (they must have been
485 compiled elsewhere). In these cases, we let them go through anyway.
487 We can also have instances for functions: @instance Foo (a -> b) ...@.
490 scrutiniseInstanceConstraint (clas, tys)
491 | all isTyVarTy tys = returnNF_Tc ()
492 | otherwise = addErrTc (instConstraintErr clas tys)
494 scrutiniseInstanceHead clas inst_taus
495 | -- CCALL CHECK (a).... urgh!
496 -- To verify that a user declaration of a CCallable/CReturnable
497 -- instance is OK, we must be able to see the constructor(s)
498 -- of the instance type (see next guard.)
500 -- We flag this separately to give a more precise error msg.
502 (uniqueOf clas == cCallableClassKey || uniqueOf clas == cReturnableClassKey)
503 && is_alg_tycon_app && not constructors_visible
504 = addErrTc (invisibleDataConPrimCCallErr clas first_inst_tau)
507 -- A user declaration of a CCallable/CReturnable instance
508 -- must be for a "boxed primitive" type.
509 (uniqueOf clas == cCallableClassKey && not (ccallable_type first_inst_tau)) ||
510 (uniqueOf clas == cReturnableClassKey && not (creturnable_type first_inst_tau))
511 = addErrTc (nonBoxedPrimCCallErr clas first_inst_tau)
514 -- It is obviously illegal to have an explicit instance
515 -- for something that we are also planning to `derive'
516 | maybeToBool alg_tycon_app_maybe && clas `elem` (tyConDerivings alg_tycon)
517 = addErrTc (derivingWhenInstanceExistsErr clas first_inst_tau)
518 -- Kind check will have ensured inst_taus is of length 1
520 -- WITH HASKELL 1.4, MUST HAVE C (T a b c)
521 | not opt_GlasgowExts
522 && not (length inst_taus == 1 &&
523 maybeToBool maybe_tycon_app && -- Yes, there's a type constuctor
524 not (isSynTyCon tycon) && -- ...but not a synonym
525 all isTyVarTy arg_tys && -- Applied to type variables
526 length (tyVarSetToList (tyVarsOfTypes arg_tys)) == length arg_tys
527 -- This last condition checks that all the type variables are distinct
529 = addErrTc (instTypeErr clas inst_taus
530 (text "the instance type must be of form (T a b c)" $$
531 text "where T is not a synonym, and a,b,c are distinct type variables")
538 (first_inst_tau : _) = inst_taus
540 -- Stuff for algebraic or -> type
541 maybe_tycon_app = splitTyConApp_maybe first_inst_tau
542 Just (tycon, arg_tys) = maybe_tycon_app
544 -- Stuff for an *algebraic* data type
545 alg_tycon_app_maybe = splitAlgTyConApp_maybe first_inst_tau
546 -- The "Alg" part looks through synonyms
547 is_alg_tycon_app = maybeToBool alg_tycon_app_maybe
548 Just (alg_tycon, _, data_cons) = alg_tycon_app_maybe
550 constructors_visible = not (null data_cons)
553 -- These conditions come directly from what the DsCCall is capable of.
554 -- Totally grotesque. Green card should solve this.
556 ccallable_type ty = isUnpointedType ty || -- Allow CCallable Int# etc
557 maybeToBool (maybeBoxedPrimType ty) || -- Ditto Int etc
561 byte_arr_thing = case splitAlgTyConApp_maybe ty of
562 Just (tycon, ty_args, [data_con]) | isDataTyCon tycon ->
563 length data_con_arg_tys == 2 &&
564 maybeToBool maybe_arg2_tycon &&
565 (arg2_tycon == byteArrayPrimTyCon ||
566 arg2_tycon == mutableByteArrayPrimTyCon)
568 data_con_arg_tys = dataConArgTys data_con ty_args
569 (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
570 maybe_arg2_tycon = splitTyConApp_maybe data_con_arg_ty2
571 Just (arg2_tycon,_) = maybe_arg2_tycon
575 creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
576 -- Or, a data type with a single nullary constructor
577 case (splitAlgTyConApp_maybe ty) of
578 Just (tycon, tys_applied, [data_con])
579 -> isNullaryDataCon data_con
584 instConstraintErr clas tys
585 = hang (ptext SLIT("Illegal constaint") <+>
586 quotes (pprConstraint clas tys) <+>
587 ptext SLIT("in instance context"))
588 4 (ptext SLIT("(Instance contexts must constrain only type variables)"))
590 instTypeErr clas tys msg
591 = sep [ptext SLIT("Illegal instance declaration for") <+> quotes (pprConstraint clas tys),
595 derivingWhenInstanceExistsErr clas tycon
596 = hang (hsep [ptext SLIT("Deriving class"),
598 ptext SLIT("type"), quotes (ppr tycon)])
599 4 (ptext SLIT("when an explicit instance exists"))
601 nonBoxedPrimCCallErr clas inst_ty
602 = hang (ptext SLIT("Unacceptable instance type for ccall-ish class"))
603 4 (hsep [ ptext SLIT("class"), ppr clas, ptext SLIT("type"),
607 Declaring CCallable & CReturnable instances in a module different
608 from where the type was defined. Caused by importing data type
609 abstractly (either programmatically or by the renamer being over-eager
612 invisibleDataConPrimCCallErr clas inst_ty
613 = hang (hsep [ptext SLIT("Constructors for"), quotes (ppr inst_ty),
614 ptext SLIT("not visible when checking"),
615 quotes (ppr clas), ptext SLIT("instance")])
616 4 (hsep [text "(Try either importing", ppr inst_ty,
617 text "non-abstractly or compile using -fno-prune-tydecls ..)"])
619 methodCtxt = ptext SLIT("When checking the methods of an instance declaration")
620 superClassCtxt = ptext SLIT("When checking the superclasses of an instance declaration")