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(..), HsType(..),
15 HsBinds(..), MonoBinds(..), GRHSsAndBinds(..), GRHS(..),
16 HsExpr(..), InPat(..), HsLit(..),
18 collectMonoBinders, andMonoBinds
20 import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds,
21 RenamedInstDecl, RenamedFixityDecl, RenamedHsExpr,
22 RenamedSig, RenamedSpecInstSig, RenamedHsDecl
24 import TcHsSyn ( TcHsBinds,
25 TcMonoBinds, TcExpr, TcIdOcc(..), TcIdBndr,
26 tcIdType, maybeBoxedPrimType,
28 mkHsDictLam, mkHsDictApp )
30 import TcBinds ( tcPragmaSigs, sigThetaCtxt )
31 import TcClassDcl ( tcMethodBind, badMethodErr )
33 import RnMonad ( RnNameSupply )
34 import Inst ( Inst, InstOrigin(..), InstanceMapper,
35 instToId, newDicts, newMethod, LIE, emptyLIE, plusLIE )
36 import PragmaInfo ( PragmaInfo(..) )
37 import TcDeriv ( tcDeriving )
38 import TcEnv ( tcLookupClass, newLocalId, tcGetGlobalTyVars,
39 tcExtendGlobalValEnv, tcAddImportedIdInfo
41 import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs, classDataCon )
42 import TcKind ( TcKind, unifyKind )
43 import TcMatches ( tcMatchesFun )
44 import TcMonoType ( tcTyVarScope, tcContext, tcHsTypeKind, tcHsType )
45 import TcSimplify ( tcSimplifyAndCheck )
46 import TcType ( TcType, TcTyVar, TcTyVarSet,
48 tcInstSigTyVars, tcInstType, tcInstSigTcType,
49 tcInstTheta, tcInstTcType
51 import Unify ( unifyTauTy, unifyTauTyLists )
54 import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
55 concatBag, foldBag, bagToList, listToBag,
58 import CmdLineOpts ( opt_GlasgowExts,
59 opt_SpecialiseOverloaded, opt_WarnMissingMethods
61 import Class ( classBigSig, classTyCon, Class )
62 import Id ( idType, replacePragmaInfo,
63 isNullaryDataCon, dataConArgTys, Id )
64 import ListSetOps ( minusList )
65 import Maybes ( maybeToBool, expectJust, seqMaybe, catMaybes )
66 import Name ( nameOccName, getSrcLoc, mkLocalName,
67 isLocallyDefined, Module,
70 import PrelVals ( nO_EXPLICIT_METHOD_ERROR_ID, nO_DEFAULT_METHOD_ERROR_ID )
71 import PprType ( pprParendGenType, pprConstraint )
72 import SrcLoc ( SrcLoc, noSrcLoc )
73 import TyCon ( tyConDataCons, isSynTyCon, isDataTyCon, tyConDerivings )
74 import Type ( Type, ThetaType, mkTyVarTys, isUnpointedType,
75 splitSigmaTy, splitAppTys, isTyVarTy, matchTy, mkSigmaTy,
76 splitTyConApp_maybe, getTyVar, splitDictTy_maybe,
77 splitAlgTyConApp_maybe, splitRhoTy, isSynTy,
80 import TyVar ( zipTyVarEnv, mkTyVarSet, tyVarSetToList, TyVar )
81 import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
82 import TysWiredIn ( stringTy )
83 import Unique ( Unique, cCallableClassKey, cReturnableClassKey, Uniquable(..) )
84 import Util ( zipEqual, removeDups )
88 Typechecking instance declarations is done in two passes. The first
89 pass, made by @tcInstDecls1@, collects information to be used in the
92 This pre-processed info includes the as-yet-unprocessed bindings
93 inside the instance declaration. These are type-checked in the second
94 pass, when the class-instance envs and GVE contain all the info from
95 all the instance and value decls. Indeed that's the reason we need
96 two passes over the instance decls.
99 Here is the overall algorithm.
100 Assume that we have an instance declaration
102 instance c => k (t tvs) where b
106 $LIE_c$ is the LIE for the context of class $c$
108 $betas_bar$ is the free variables in the class method type, excluding the
111 $LIE_cop$ is the LIE constraining a particular class method
113 $tau_cop$ is the tau type of a class method
115 $LIE_i$ is the LIE for the context of instance $i$
117 $X$ is the instance constructor tycon
119 $gammas_bar$ is the set of type variables of the instance
121 $LIE_iop$ is the LIE for a particular class method instance
123 $tau_iop$ is the tau type for this instance of a class method
125 $alpha$ is the class variable
127 $LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
129 $tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
132 ToDo: Update the list above with names actually in the code.
136 First, make the LIEs for the class and instance contexts, which means
137 instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
138 and make LIElistI and LIEI.
140 Then process each method in turn.
142 order the instance methods according to the ordering of the class methods
144 express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
146 Create final dictionary function from bindings generated already
148 df = lambda inst_tyvars
155 in <op1,op2,...,opn,sd1,...,sdm>
157 Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
158 and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
162 tcInstDecls1 :: TcEnv s -- Contains IdInfo for dfun ids
164 -> Module -- module name for deriving
165 -> RnNameSupply -- for renaming derivings
166 -> TcM s (Bag InstInfo,
170 tcInstDecls1 unf_env decls mod_name rn_name_supply
171 = -- Do the ordinary instance declarations
172 mapNF_Tc (tcInstDecl1 unf_env mod_name)
173 [inst_decl | InstD inst_decl <- decls] `thenNF_Tc` \ inst_info_bags ->
175 decl_inst_info = unionManyBags inst_info_bags
177 -- Handle "derived" instances; note that we only do derivings
178 -- for things in this module; we ignore deriving decls from
180 tcDeriving mod_name rn_name_supply decl_inst_info
181 `thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) ->
184 full_inst_info = deriv_inst_info `unionBags` decl_inst_info
186 returnTc (full_inst_info, deriv_binds, ddump_deriv)
189 tcInstDecl1 :: TcEnv s -> Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
191 tcInstDecl1 unf_env mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
192 = -- Prime error recovery, set source location
193 recoverNF_Tc (returnNF_Tc emptyBag) $
194 tcAddSrcLoc src_loc $
196 -- Type-check all the stuff before the "where"
197 tcHsType poly_ty `thenTc` \ poly_ty' ->
199 (tyvars, theta, dict_ty) = splitSigmaTy poly_ty'
200 (clas, inst_tys) = case splitDictTy_maybe dict_ty of
201 Nothing -> pprPanic "tcInstDecl1" (ppr poly_ty)
205 -- Check for respectable instance type
206 scrutiniseInstanceType clas inst_tys `thenTc_`
208 -- Make the dfun id and constant-method ids
210 (dfun_id, dfun_theta) = mkInstanceRelatedIds dfun_name
211 clas tyvars inst_tys theta
212 -- Add info from interface file
213 final_dfun_id = tcAddImportedIdInfo unf_env dfun_id
215 returnTc (unitBag (InstInfo clas tyvars inst_tys theta
216 dfun_theta final_dfun_id
217 binds src_loc uprags))
221 %************************************************************************
223 \subsection{Type-checking instance declarations, pass 2}
225 %************************************************************************
228 tcInstDecls2 :: Bag InstInfo
229 -> NF_TcM s (LIE s, TcMonoBinds s)
231 tcInstDecls2 inst_decls
232 = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyMonoBinds)) inst_decls
234 combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
235 tc2 `thenNF_Tc` \ (lie2, binds2) ->
236 returnNF_Tc (lie1 `plusLIE` lie2,
237 binds1 `AndMonoBinds` binds2)
241 ======= New documentation starts here (Sept 92) ==============
243 The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
244 the dictionary function for this instance declaration. For example
246 instance Foo a => Foo [a] where
250 might generate something like
252 dfun.Foo.List dFoo_a = let op1 x = ...
258 HOWEVER, if the instance decl has no context, then it returns a
259 bigger @HsBinds@ with declarations for each method. For example
261 instance Foo [a] where
267 dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
268 const.Foo.op1.List a x = ...
269 const.Foo.op2.List a y = ...
271 This group may be mutually recursive, because (for example) there may
272 be no method supplied for op2 in which case we'll get
274 const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
276 that is, the default method applied to the dictionary at this type.
278 What we actually produce in either case is:
280 AbsBinds [a] [dfun_theta_dicts]
281 [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
282 { d = (sd1,sd2, ..., op1, op2, ...)
287 The "maybe" says that we only ask AbsBinds to make global constant methods
288 if the dfun_theta is empty.
291 For an instance declaration, say,
293 instance (C1 a, C2 b) => C (T a b) where
296 where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
297 function whose type is
299 (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
301 Notice that we pass it the superclass dictionaries at the instance type; this
302 is the ``Mark Jones optimisation''. The stuff before the "=>" here
303 is the @dfun_theta@ below.
305 First comes the easy case of a non-local instance decl.
308 tcInstDecl2 :: InstInfo -> NF_TcM s (LIE s, TcMonoBinds s)
310 tcInstDecl2 (InstInfo clas inst_tyvars inst_tys
311 inst_decl_theta dfun_theta
314 | not (isLocallyDefined dfun_id)
315 = returnNF_Tc (emptyLIE, EmptyMonoBinds)
318 -- I deleted this "optimisation" because when importing these
319 -- instance decls the renamer would look for the dfun bindings and they weren't there.
320 -- This would be fixable, but it seems simpler just to produce a tiny void binding instead,
321 -- even though it's never used.
323 -- This case deals with CCallable etc, which don't need any bindings
325 = returnNF_Tc (emptyLIE, EmptyBinds)
329 = -- Prime error recovery
330 recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
333 -- Get the class signature
335 origin = InstanceDeclOrigin
337 sc_theta, sc_sel_ids,
338 op_sel_ids, defm_ids) = classBigSig clas
341 -- Instantiate the instance decl with tc-style type variables
342 tcInstSigTyVars inst_tyvars `thenNF_Tc` \ (inst_tyvars', _, tenv) ->
343 mapNF_Tc (tcInstType tenv) inst_tys `thenNF_Tc` \ inst_tys' ->
344 tcInstTheta tenv dfun_theta `thenNF_Tc` \ dfun_theta' ->
345 tcInstTheta tenv inst_decl_theta `thenNF_Tc` \ inst_decl_theta' ->
347 -- Instantiate the super-class context with inst_tys
349 tcInstTheta (zipTyVarEnv class_tyvars inst_tys') sc_theta `thenNF_Tc` \ sc_theta' ->
351 -- Create dictionary Ids from the specified instance contexts.
352 newDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) ->
353 newDicts origin dfun_theta' `thenNF_Tc` \ (dfun_arg_dicts, dfun_arg_dicts_ids) ->
354 newDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) ->
355 newDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
357 -- Now process any INLINE or SPECIALIZE pragmas for the methods
358 -- ...[NB May 97; all ignored except INLINE]
359 tcPragmaSigs uprags `thenTc` \ (prag_fn, spec_binds, spec_lie) ->
361 -- Check that all the method bindings come from this class
363 check_from_this_class (bndr, loc)
364 | nameOccName bndr `elem` sel_names = returnNF_Tc ()
365 | otherwise = tcAddSrcLoc loc $
366 addErrTc (badMethodErr bndr clas)
367 sel_names = map getOccName op_sel_ids
368 bndrs = bagToList (collectMonoBinders monobinds)
370 mapNF_Tc check_from_this_class bndrs `thenNF_Tc_`
372 tcExtendGlobalValEnv (catMaybes defm_ids) (
374 -- Default-method Ids may be mentioned in synthesised RHSs
375 mapAndUnzip3Tc (tcInstMethodBind clas inst_tys' inst_tyvars' monobinds)
376 (op_sel_ids `zip` defm_ids)
377 ) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
379 -- Check the overloading constraints of the methods and superclasses
380 mapNF_Tc zonkSigTyVar inst_tyvars' `thenNF_Tc` \ zonked_inst_tyvars ->
383 inst_tyvars_set = mkTyVarSet zonked_inst_tyvars
385 (meth_lies, meth_ids) = unzip meth_lies_w_ids
387 -- These insts are in scope; quite a few, eh?
388 avail_insts = this_dict `plusLIE`
389 dfun_arg_dicts `plusLIE`
391 unionManyBags meth_lies
393 tcAddErrCtxt superClassCtxt $
394 tcAddErrCtxtM (sigThetaCtxt sc_dicts) $
397 -- Deal with the LIE arising from the method bindings
398 tcSimplifyAndCheck (text "inst decl1a")
399 inst_tyvars_set -- Local tyvars
401 (unionManyBags insts_needed_s) -- Need to get defns for all these
402 `thenTc` \ (const_lie1, op_binds) ->
404 -- Deal with the super-class bindings
405 -- Ignore errors because they come from the *next* tcSimplify
407 tcSimplifyAndCheck (text "inst decl1b")
409 dfun_arg_dicts -- NB! Don't include this_dict here, else the sc_dicts
410 -- get bound by just selecting from this_dict!!
412 ) `thenTc` \ (const_lie2, sc_binds) ->
415 -- Check that we *could* construct the superclass dictionaries,
416 -- even though we are *actually* going to pass the superclass dicts in;
417 -- the check ensures that the caller will never have a problem building
419 tcSimplifyAndCheck (text "inst decl1c")
420 inst_tyvars_set -- Local tyvars
421 inst_decl_dicts -- The instance dictionaries available
422 sc_dicts -- The superclass dicationaries reqd
424 -- Ignore the result; we're only doing
425 -- this to make sure it can be done.
427 -- Create the result bindings
429 const_lie = const_lie1 `plusLIE` const_lie2
430 lie_binds = op_binds `AndMonoBinds` sc_binds
432 dict_constr = classDataCon clas
434 con_app = foldl HsApp (TyApp (HsVar (RealId dict_constr)) inst_tys')
435 (map HsVar (sc_dict_ids ++ meth_ids))
436 -- We don't produce a binding for the dict_constr; instead we
437 -- rely on the simplifier to unfold this saturated application
439 dict_bind = VarMonoBind this_dict_id con_app
440 method_binds = andMonoBinds method_binds_s
446 [(inst_tyvars', RealId dfun_id, this_dict_id)]
447 (lie_binds `AndMonoBinds`
448 method_binds `AndMonoBinds`
451 returnTc (const_lie `plusLIE` spec_lie,
452 main_bind `AndMonoBinds` spec_binds)
456 %************************************************************************
458 \subsection{Processing each method}
460 %************************************************************************
465 -> [TcType s] -- Instance types
466 -> [TcTyVar s] -- and their free (sig) tyvars
467 -> RenamedMonoBinds -- Method binding
468 -> (Id, Maybe Id) -- Selector id and default-method id
469 -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
471 tcInstMethodBind clas inst_tys inst_tyvars meth_binds (sel_id, maybe_dm_id)
472 = tcGetSrcLoc `thenNF_Tc` \ loc ->
473 tcGetUnique `thenNF_Tc` \ uniq ->
475 meth_occ = getOccName sel_id
476 default_meth_name = mkLocalName uniq meth_occ loc
477 maybe_meth_bind = find meth_occ meth_binds
478 the_meth_bind = case maybe_meth_bind of
480 Nothing -> mk_default_bind default_meth_name loc
483 -- Warn if no method binding, only if -fwarn-missing-methods
485 warnTc (opt_WarnMissingMethods &&
486 not (maybeToBool maybe_meth_bind) &&
487 not (maybeToBool maybe_dm_id))
488 (omittedMethodWarn sel_id clas) `thenNF_Tc_`
490 -- Typecheck the method binding
491 tcMethodBind clas origin inst_tys inst_tyvars sel_id the_meth_bind
493 origin = InstanceDeclOrigin -- Poor
495 find occ EmptyMonoBinds = Nothing
496 find occ (AndMonoBinds b1 b2) = find occ b1 `seqMaybe` find occ b2
498 find occ b@(FunMonoBind op_name _ _ _) | nameOccName op_name == occ = Just b
499 | otherwise = Nothing
500 find occ b@(PatMonoBind (VarPatIn op_name) _ _) | nameOccName op_name == occ = Just b
501 | otherwise = Nothing
502 find occ other = panic "Urk! Bad instance method binding"
505 mk_default_bind local_meth_name loc
506 = PatMonoBind (VarPatIn local_meth_name)
507 (GRHSsAndBindsIn (unguardedRHS default_expr loc) EmptyBinds)
510 default_expr = case maybe_dm_id of
511 Just dm_id -> HsVar (getName dm_id) -- There's a default method
512 Nothing -> error_expr -- No default method
514 error_expr = HsApp (HsVar (getName nO_DEFAULT_METHOD_ERROR_ID))
515 (HsLit (HsString (_PK_ error_msg)))
517 error_msg = show (hcat [ppr (getSrcLoc sel_id), text "|",
524 %************************************************************************
526 \subsection{Type-checking specialise instance pragmas}
528 %************************************************************************
532 tcSpecInstSigs :: E -> CE -> TCE
533 -> Bag InstInfo -- inst decls seen (declared and derived)
534 -> [RenamedSpecInstSig] -- specialise instance upragmas
535 -> TcM (Bag InstInfo) -- new, overlapped, inst decls
537 tcSpecInstSigs e ce tce inst_infos []
540 tcSpecInstSigs e ce tce inst_infos sigs
541 = buildInstanceEnvs inst_infos `thenTc` \ inst_mapper ->
542 tc_inst_spec_sigs inst_mapper sigs `thenNF_Tc` \ spec_inst_infos ->
543 returnTc spec_inst_infos
545 tc_inst_spec_sigs inst_mapper []
546 = returnNF_Tc emptyBag
547 tc_inst_spec_sigs inst_mapper (sig:sigs)
548 = tcSpecInstSig e ce tce inst_infos inst_mapper sig `thenNF_Tc` \ info_sig ->
549 tc_inst_spec_sigs inst_mapper sigs `thenNF_Tc` \ info_sigs ->
550 returnNF_Tc (info_sig `unionBags` info_sigs)
552 tcSpecInstSig :: E -> CE -> TCE
555 -> RenamedSpecInstSig
556 -> NF_TcM (Bag InstInfo)
558 tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc)
559 = recoverTc emptyBag (
560 tcAddSrcLoc src_loc (
562 clas = lookupCE ce class_name -- Renamer ensures this can't fail
564 -- Make some new type variables, named as in the specialised instance type
565 ty_names = extractHsTyNames ???is_tyvarish_name??? ty
566 (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names
568 babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
569 `thenTc` \ inst_ty ->
571 maybe_tycon = case splitAlgTyConApp_maybe inst_ty of
572 Just (tc,_,_) -> Just tc
575 maybe_unspec_inst = lookup_unspec_inst clas maybe_tycon inst_infos
577 -- Check that we have a local instance declaration to specialise
578 checkMaybeTc maybe_unspec_inst
579 (specInstUnspecInstNotFoundErr clas inst_ty src_loc) `thenTc_`
581 -- Create tvs to substitute for tmpls while simplifying the context
582 copyTyVars inst_tmpls `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) ->
584 Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta
585 _ _ binds _ uprag) = maybe_unspec_inst
587 subst = case matchTy unspec_inst_ty inst_ty of
589 Nothing -> panic "tcSpecInstSig:matchTy"
591 subst_theta = instantiateThetaTy subst unspec_theta
592 subst_tv_theta = instantiateThetaTy tv_e subst_theta
594 mk_spec_origin clas ty
595 = InstanceSpecOrigin inst_mapper clas ty src_loc
596 -- I'm VERY SUSPICIOUS ABOUT THIS
597 -- the inst-mapper is in a knot at this point so it's no good
598 -- looking at it in tcSimplify...
600 tcSimplifyThetas mk_spec_origin subst_tv_theta
601 `thenTc` \ simpl_tv_theta ->
603 simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ]
605 tv_tmpl_map = zipEqual "tcSpecInstSig" inst_tv_tys inst_tmpl_tys
606 tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv
608 mkInstanceRelatedIds clas inst_tmpls inst_ty simpl_theta uprag
609 `thenNF_Tc` \ (dfun_id, dfun_theta, const_meth_ids) ->
611 getSwitchCheckerTc `thenNF_Tc` \ sw_chkr ->
612 (if sw_chkr SpecialiseTrace then
613 pprTrace "Specialised Instance: "
614 (vcat [hsep [if null simpl_theta then empty else ppr simpl_theta,
615 if null simpl_theta then empty else ptext SLIT("=>"),
617 pprParendGenType inst_ty],
618 hsep [ptext SLIT(" derived from:"),
619 if null unspec_theta then empty else ppr unspec_theta,
620 if null unspec_theta then empty else ptext SLIT("=>"),
622 pprParendGenType unspec_inst_ty]])
625 returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
627 binds src_loc uprag))
631 lookup_unspec_inst clas maybe_tycon inst_infos
632 = case filter (match_info match_inst_ty) (bagToList inst_infos) of
634 (info:_) -> Just info
636 match_info match_ty (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _)
637 = from_here && clas == inst_clas &&
638 match_ty inst_ty && is_plain_instance inst_ty
640 match_inst_ty = case maybe_tycon of
641 Just tycon -> match_tycon tycon
644 match_tycon tycon inst_ty = case (splitAlgTyConApp_maybe inst_ty) of
645 Just (inst_tc,_,_) -> tycon == inst_tc
648 match_fun inst_ty = isFunType inst_ty
651 is_plain_instance inst_ty
652 = case (splitAlgTyConApp_maybe inst_ty) of
653 Just (_,tys,_) -> all isTyVarTemplateTy tys
654 Nothing -> case maybeUnpackFunTy inst_ty of
655 Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res
656 Nothing -> error "TcInstDecls:is_plain_instance"
661 Checking for a decent instance type
662 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
663 @scrutiniseInstanceType@ checks the type {\em and} its syntactic constraints:
664 it must normally look like: @instance Foo (Tycon a b c ...) ...@
666 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
667 flag is on, or (2)~the instance is imported (they must have been
668 compiled elsewhere). In these cases, we let them go through anyway.
670 We can also have instances for functions: @instance Foo (a -> b) ...@.
673 scrutiniseInstanceType clas inst_taus
674 | -- CCALL CHECK (a).... urgh!
675 -- To verify that a user declaration of a CCallable/CReturnable
676 -- instance is OK, we must be able to see the constructor(s)
677 -- of the instance type (see next guard.)
679 -- We flag this separately to give a more precise error msg.
681 (uniqueOf clas == cCallableClassKey && not constructors_visible) ||
682 (uniqueOf clas == cReturnableClassKey && not constructors_visible)
683 = failWithTc (invisibleDataConPrimCCallErr clas first_inst_tau)
686 -- A user declaration of a CCallable/CReturnable instance
687 -- must be for a "boxed primitive" type.
688 (uniqueOf clas == cCallableClassKey && not (ccallable_type first_inst_tau)) ||
689 (uniqueOf clas == cReturnableClassKey && not (creturnable_type first_inst_tau))
690 = failWithTc (nonBoxedPrimCCallErr clas first_inst_tau)
693 -- It is obviously illegal to have an explicit instance
694 -- for something that we are also planning to `derive'
695 | clas `elem` (tyConDerivings inst_tycon)
696 = failWithTc (derivingWhenInstanceExistsErr clas first_inst_tau)
697 -- Kind check will have ensured inst_taus is of length 1
699 -- ALL TYPE VARIABLES => bad
700 | all isTyVarTy inst_taus
701 = failWithTc (instTypeErr clas inst_taus (text "all the instance types are type variables"))
703 -- WITH HASKELL 1.4, MUST HAVE C (T a b c)
704 | not opt_GlasgowExts
705 && not (length inst_taus == 1 &&
706 maybeToBool tyconapp_maybe &&
707 not (isSynTyCon inst_tycon) &&
708 all isTyVarTy arg_tys &&
709 length (tyVarSetToList (tyVarsOfTypes arg_tys)) == length arg_tys
710 -- This last condition checks that all the type variables are distinct
712 = failWithTc (instTypeErr clas inst_taus
713 (text "the instance type must be of form (T a b c)" $$
714 text "where T is not a synonym, and a,b,c are distinct type variables")
721 tyconapp_maybe = splitTyConApp_maybe first_inst_tau
722 Just (inst_tycon, arg_tys) = tyconapp_maybe
723 (first_inst_tau : _) = inst_taus
725 constructors_visible =
726 case splitAlgTyConApp_maybe first_inst_tau of
727 Just (_,_,[]) -> False
728 everything_else -> True
730 -- These conditions come directly from what the DsCCall is capable of.
731 -- Totally grotesque. Green card should solve this.
733 ccallable_type ty = isUnpointedType ty || -- Allow CCallable Int# etc
734 maybeToBool (maybeBoxedPrimType ty) || -- Ditto Int etc
738 byte_arr_thing = case splitAlgTyConApp_maybe ty of
739 Just (tycon, ty_args, [data_con]) | isDataTyCon tycon ->
740 length data_con_arg_tys == 2 &&
741 maybeToBool maybe_arg2_tycon &&
742 (arg2_tycon == byteArrayPrimTyCon ||
743 arg2_tycon == mutableByteArrayPrimTyCon)
745 data_con_arg_tys = dataConArgTys data_con ty_args
746 (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
747 maybe_arg2_tycon = splitTyConApp_maybe data_con_arg_ty2
748 Just (arg2_tycon,_) = maybe_arg2_tycon
752 creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
753 -- Or, a data type with a single nullary constructor
754 case (splitAlgTyConApp_maybe ty) of
755 Just (tycon, tys_applied, [data_con])
756 -> isNullaryDataCon data_con
762 instTypeErr clas tys msg
763 = sep [ptext SLIT("Illegal instance declaration for") <+> quotes (pprConstraint clas tys),
767 instBndrErr bndr clas
768 = hsep [ptext SLIT("Class"), quotes (ppr clas), ptext SLIT("does not have a method"), quotes (ppr bndr)]
770 derivingWhenInstanceExistsErr clas tycon
771 = hang (hsep [ptext SLIT("Deriving class"),
773 ptext SLIT("type"), quotes (ppr tycon)])
774 4 (ptext SLIT("when an explicit instance exists"))
776 nonBoxedPrimCCallErr clas inst_ty
777 = hang (ptext SLIT("Unacceptable instance type for ccall-ish class"))
778 4 (hsep [ ptext SLIT("class"), ppr clas, ptext SLIT("type"),
781 omittedMethodWarn sel_id clas
782 = sep [ptext SLIT("Warning: no explicit method nor default method for") <+> quotes (ppr sel_id),
783 ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)]
786 Declaring CCallable & CReturnable instances in a module different
787 from where the type was defined. Caused by importing data type
788 abstractly (either programmatically or by the renamer being over-eager
791 invisibleDataConPrimCCallErr clas inst_ty
792 = hang (hsep [ptext SLIT("Constructors for"), quotes (ppr inst_ty),
793 ptext SLIT("not visible when checking"),
794 quotes (ppr clas), ptext SLIT("instance")])
795 4 (hsep [text "(Try either importing", ppr inst_ty,
796 text "non-abstractly or compile using -fno-prune-tydecls ..)"])
798 instMethodNotInClassErr occ clas
799 = hang (ptext SLIT("Instance mentions a method not in the class"))
800 4 (hsep [ptext SLIT("class") <+> quotes (ppr clas),
801 ptext SLIT("method") <+> quotes (ppr occ)])
803 patMonoBindsCtxt pbind
804 = hang (ptext SLIT("In a pattern binding:"))
807 methodSigCtxt name ty
808 = hang (hsep [ptext SLIT("When matching the definition of class method"),
809 quotes (ppr name), ptext SLIT("to its signature :") ])
812 superClassCtxt = ptext SLIT("From the superclasses of the instance declaration")