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(..),
18 collectMonoBinders, andMonoBinds
20 import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds,
21 RenamedInstDecl, RenamedHsExpr,
22 RenamedSig, RenamedHsDecl
24 import TcHsSyn ( TcMonoBinds, TcIdOcc(..), TcIdBndr,
28 import TcBinds ( tcPragmaSigs, sigThetaCtxt )
29 import TcClassDcl ( tcMethodBind, badMethodErr )
31 import RnMonad ( RnNameSupply )
32 import Inst ( Inst, InstOrigin(..),
33 newDicts, LIE, emptyLIE, plusLIE )
34 import PragmaInfo ( PragmaInfo(..) )
35 import TcDeriv ( tcDeriving )
36 import TcEnv ( 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, tcInstSigTyVars, tcInstType, tcInstTheta
45 import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
46 foldBag, bagToList, Bag
48 import CmdLineOpts ( opt_GlasgowExts, opt_WarnMissingMethods )
49 import Class ( classBigSig, Class )
50 import Id ( isNullaryDataCon, dataConArgTys, Id )
51 import Maybes ( maybeToBool, seqMaybe, catMaybes )
52 import Name ( nameOccName, mkLocalName,
53 isLocallyDefined, Module,
56 import PrelVals ( nO_METHOD_BINDING_ERROR_ID )
57 import PprType ( pprParendGenType, 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,
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 :: TcEnv s -- 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 :: TcEnv s -> 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
191 scrutiniseInstanceType clas inst_tys `thenTc_`
193 -- Make the dfun id and constant-method ids
195 (dfun_id, dfun_theta) = mkInstanceRelatedIds dfun_name
196 clas tyvars inst_tys theta
197 -- Add info from interface file
198 final_dfun_id = tcAddImportedIdInfo unf_env dfun_id
200 returnTc (unitBag (InstInfo clas tyvars inst_tys theta
201 dfun_theta final_dfun_id
202 binds src_loc uprags))
206 %************************************************************************
208 \subsection{Type-checking instance declarations, pass 2}
210 %************************************************************************
213 tcInstDecls2 :: Bag InstInfo
214 -> NF_TcM s (LIE s, TcMonoBinds s)
216 tcInstDecls2 inst_decls
217 = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyMonoBinds)) inst_decls
219 combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
220 tc2 `thenNF_Tc` \ (lie2, binds2) ->
221 returnNF_Tc (lie1 `plusLIE` lie2,
222 binds1 `AndMonoBinds` binds2)
226 ======= New documentation starts here (Sept 92) ==============
228 The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
229 the dictionary function for this instance declaration. For example
231 instance Foo a => Foo [a] where
235 might generate something like
237 dfun.Foo.List dFoo_a = let op1 x = ...
243 HOWEVER, if the instance decl has no context, then it returns a
244 bigger @HsBinds@ with declarations for each method. For example
246 instance Foo [a] where
252 dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
253 const.Foo.op1.List a x = ...
254 const.Foo.op2.List a y = ...
256 This group may be mutually recursive, because (for example) there may
257 be no method supplied for op2 in which case we'll get
259 const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
261 that is, the default method applied to the dictionary at this type.
263 What we actually produce in either case is:
265 AbsBinds [a] [dfun_theta_dicts]
266 [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
267 { d = (sd1,sd2, ..., op1, op2, ...)
272 The "maybe" says that we only ask AbsBinds to make global constant methods
273 if the dfun_theta is empty.
276 For an instance declaration, say,
278 instance (C1 a, C2 b) => C (T a b) where
281 where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
282 function whose type is
284 (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
286 Notice that we pass it the superclass dictionaries at the instance type; this
287 is the ``Mark Jones optimisation''. The stuff before the "=>" here
288 is the @dfun_theta@ below.
290 First comes the easy case of a non-local instance decl.
293 tcInstDecl2 :: InstInfo -> NF_TcM s (LIE s, TcMonoBinds s)
295 tcInstDecl2 (InstInfo clas inst_tyvars inst_tys
296 inst_decl_theta dfun_theta
299 | not (isLocallyDefined dfun_id)
300 = returnNF_Tc (emptyLIE, EmptyMonoBinds)
303 -- I deleted this "optimisation" because when importing these
304 -- instance decls the renamer would look for the dfun bindings and they weren't there.
305 -- This would be fixable, but it seems simpler just to produce a tiny void binding instead,
306 -- even though it's never used.
308 -- This case deals with CCallable etc, which don't need any bindings
310 = returnNF_Tc (emptyLIE, EmptyBinds)
314 = -- Prime error recovery
315 recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
318 -- Get the class signature
320 origin = InstanceDeclOrigin
322 sc_theta, sc_sel_ids,
323 op_sel_ids, defm_ids) = classBigSig clas
326 -- Instantiate the instance decl with tc-style type variables
327 tcInstSigTyVars inst_tyvars `thenNF_Tc` \ (inst_tyvars', _, tenv) ->
328 mapNF_Tc (tcInstType tenv) inst_tys `thenNF_Tc` \ inst_tys' ->
329 tcInstTheta tenv dfun_theta `thenNF_Tc` \ dfun_theta' ->
330 tcInstTheta tenv inst_decl_theta `thenNF_Tc` \ inst_decl_theta' ->
332 -- Instantiate the super-class context with inst_tys
334 tcInstTheta (zipTyVarEnv class_tyvars inst_tys') sc_theta `thenNF_Tc` \ sc_theta' ->
336 -- Create dictionary Ids from the specified instance contexts.
337 newDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) ->
338 newDicts origin dfun_theta' `thenNF_Tc` \ (dfun_arg_dicts, dfun_arg_dicts_ids) ->
339 newDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) ->
340 newDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
342 -- Now process any INLINE or SPECIALIZE pragmas for the methods
343 -- ...[NB May 97; all ignored except INLINE]
344 tcPragmaSigs uprags `thenTc` \ (prag_fn, spec_binds, spec_lie) ->
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 (tcInstMethodBind clas inst_tys' inst_tyvars' monobinds)
361 (op_sel_ids `zip` defm_ids)
362 ) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
364 -- Check the overloading constraints of the methods and superclasses
365 mapNF_Tc zonkSigTyVar inst_tyvars' `thenNF_Tc` \ zonked_inst_tyvars ->
368 inst_tyvars_set = mkTyVarSet zonked_inst_tyvars
370 (meth_lies, meth_ids) = unzip meth_lies_w_ids
372 -- These insts are in scope; quite a few, eh?
373 avail_insts = this_dict `plusLIE`
374 dfun_arg_dicts `plusLIE`
376 unionManyBags meth_lies
378 tcAddErrCtxt superClassCtxt $
379 tcAddErrCtxtM (sigThetaCtxt sc_dicts) $
382 -- Deal with the LIE arising from the method bindings
383 tcSimplifyAndCheck (text "inst decl1a")
384 inst_tyvars_set -- Local tyvars
386 (unionManyBags insts_needed_s) -- Need to get defns for all these
387 `thenTc` \ (const_lie1, op_binds) ->
389 -- Deal with the super-class bindings
390 -- Ignore errors because they come from the *next* tcSimplify
392 tcSimplifyAndCheck (text "inst decl1b")
394 dfun_arg_dicts -- NB! Don't include this_dict here, else the sc_dicts
395 -- get bound by just selecting from this_dict!!
397 ) `thenTc` \ (const_lie2, sc_binds) ->
400 -- Check that we *could* construct the superclass dictionaries,
401 -- even though we are *actually* going to pass the superclass dicts in;
402 -- the check ensures that the caller will never have a problem building
404 tcSimplifyAndCheck (text "inst decl1c")
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 -- Create the result bindings
414 const_lie = const_lie1 `plusLIE` const_lie2
415 lie_binds = op_binds `AndMonoBinds` sc_binds
417 dict_constr = classDataCon clas
419 con_app = foldl HsApp (TyApp (HsVar (RealId dict_constr)) inst_tys')
420 (map HsVar (sc_dict_ids ++ meth_ids))
421 -- We don't produce a binding for the dict_constr; instead we
422 -- rely on the simplifier to unfold this saturated application
424 dict_bind = VarMonoBind this_dict_id con_app
425 method_binds = andMonoBinds method_binds_s
431 [(inst_tyvars', RealId dfun_id, this_dict_id)]
432 (lie_binds `AndMonoBinds`
433 method_binds `AndMonoBinds`
436 returnTc (const_lie `plusLIE` spec_lie,
437 main_bind `AndMonoBinds` spec_binds)
441 %************************************************************************
443 \subsection{Processing each method}
445 %************************************************************************
450 -> [TcType s] -- Instance types
451 -> [TcTyVar s] -- and their free (sig) tyvars
452 -> RenamedMonoBinds -- Method binding
453 -> (Id, Maybe Id) -- Selector id and default-method id
454 -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
456 tcInstMethodBind clas inst_tys inst_tyvars meth_binds (sel_id, maybe_dm_id)
457 = tcGetSrcLoc `thenNF_Tc` \ loc ->
458 tcGetUnique `thenNF_Tc` \ uniq ->
460 meth_occ = getOccName sel_id
461 default_meth_name = mkLocalName uniq meth_occ loc
462 maybe_meth_bind = find meth_occ meth_binds
463 the_meth_bind = case maybe_meth_bind of
465 Nothing -> mk_default_bind default_meth_name loc
468 -- Warn if no method binding, only if -fwarn-missing-methods
470 warnTc (opt_WarnMissingMethods &&
471 not (maybeToBool maybe_meth_bind) &&
472 not (maybeToBool maybe_dm_id))
473 (omittedMethodWarn sel_id clas) `thenNF_Tc_`
475 -- Typecheck the method binding
476 tcMethodBind clas origin inst_tys inst_tyvars sel_id the_meth_bind
478 origin = InstanceDeclOrigin -- Poor
480 find occ EmptyMonoBinds = Nothing
481 find occ (AndMonoBinds b1 b2) = find occ b1 `seqMaybe` find occ b2
483 find occ b@(FunMonoBind op_name _ _ _) | nameOccName op_name == occ = Just b
484 | otherwise = Nothing
485 find occ b@(PatMonoBind (VarPatIn op_name) _ _) | nameOccName op_name == occ = Just b
486 | otherwise = Nothing
487 find occ other = panic "Urk! Bad instance method binding"
490 mk_default_bind local_meth_name loc
491 = PatMonoBind (VarPatIn local_meth_name)
492 (GRHSsAndBindsIn (unguardedRHS (default_expr loc) loc) EmptyBinds)
496 = case maybe_dm_id of
497 Just dm_id -> HsVar (getName dm_id) -- There's a default method
498 Nothing -> error_expr loc -- No default method
501 = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID))
502 (HsLit (HsString (_PK_ (error_msg loc))))
504 error_msg loc = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
510 %************************************************************************
512 \subsection{Type-checking specialise instance pragmas}
514 %************************************************************************
518 tcSpecInstSigs :: E -> CE -> TCE
519 -> Bag InstInfo -- inst decls seen (declared and derived)
520 -> [RenamedSpecInstSig] -- specialise instance upragmas
521 -> TcM (Bag InstInfo) -- new, overlapped, inst decls
523 tcSpecInstSigs e ce tce inst_infos []
526 tcSpecInstSigs e ce tce inst_infos sigs
527 = buildInstanceEnvs inst_infos `thenTc` \ inst_mapper ->
528 tc_inst_spec_sigs inst_mapper sigs `thenNF_Tc` \ spec_inst_infos ->
529 returnTc spec_inst_infos
531 tc_inst_spec_sigs inst_mapper []
532 = returnNF_Tc emptyBag
533 tc_inst_spec_sigs inst_mapper (sig:sigs)
534 = tcSpecInstSig e ce tce inst_infos inst_mapper sig `thenNF_Tc` \ info_sig ->
535 tc_inst_spec_sigs inst_mapper sigs `thenNF_Tc` \ info_sigs ->
536 returnNF_Tc (info_sig `unionBags` info_sigs)
538 tcSpecInstSig :: E -> CE -> TCE
541 -> RenamedSpecInstSig
542 -> NF_TcM (Bag InstInfo)
544 tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc)
545 = recoverTc emptyBag (
546 tcAddSrcLoc src_loc (
548 clas = lookupCE ce class_name -- Renamer ensures this can't fail
550 -- Make some new type variables, named as in the specialised instance type
551 ty_names = extractHsTyNames ???is_tyvarish_name??? ty
552 (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names
554 babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
555 `thenTc` \ inst_ty ->
557 maybe_tycon = case splitAlgTyConApp_maybe inst_ty of
558 Just (tc,_,_) -> Just tc
561 maybe_unspec_inst = lookup_unspec_inst clas maybe_tycon inst_infos
563 -- Check that we have a local instance declaration to specialise
564 checkMaybeTc maybe_unspec_inst
565 (specInstUnspecInstNotFoundErr clas inst_ty src_loc) `thenTc_`
567 -- Create tvs to substitute for tmpls while simplifying the context
568 copyTyVars inst_tmpls `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) ->
570 Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta
571 _ _ binds _ uprag) = maybe_unspec_inst
573 subst = case matchTy unspec_inst_ty inst_ty of
575 Nothing -> panic "tcSpecInstSig:matchTy"
577 subst_theta = instantiateThetaTy subst unspec_theta
578 subst_tv_theta = instantiateThetaTy tv_e subst_theta
580 mk_spec_origin clas ty
581 = InstanceSpecOrigin inst_mapper clas ty src_loc
582 -- I'm VERY SUSPICIOUS ABOUT THIS
583 -- the inst-mapper is in a knot at this point so it's no good
584 -- looking at it in tcSimplify...
586 tcSimplifyThetas mk_spec_origin subst_tv_theta
587 `thenTc` \ simpl_tv_theta ->
589 simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ]
591 tv_tmpl_map = zipEqual "tcSpecInstSig" inst_tv_tys inst_tmpl_tys
592 tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv
594 mkInstanceRelatedIds clas inst_tmpls inst_ty simpl_theta uprag
595 `thenNF_Tc` \ (dfun_id, dfun_theta, const_meth_ids) ->
597 getSwitchCheckerTc `thenNF_Tc` \ sw_chkr ->
598 (if sw_chkr SpecialiseTrace then
599 pprTrace "Specialised Instance: "
600 (vcat [hsep [if null simpl_theta then empty else ppr simpl_theta,
601 if null simpl_theta then empty else ptext SLIT("=>"),
603 pprParendGenType inst_ty],
604 hsep [ptext SLIT(" derived from:"),
605 if null unspec_theta then empty else ppr unspec_theta,
606 if null unspec_theta then empty else ptext SLIT("=>"),
608 pprParendGenType unspec_inst_ty]])
611 returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
613 binds src_loc uprag))
617 lookup_unspec_inst clas maybe_tycon inst_infos
618 = case filter (match_info match_inst_ty) (bagToList inst_infos) of
620 (info:_) -> Just info
622 match_info match_ty (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _)
623 = from_here && clas == inst_clas &&
624 match_ty inst_ty && is_plain_instance inst_ty
626 match_inst_ty = case maybe_tycon of
627 Just tycon -> match_tycon tycon
630 match_tycon tycon inst_ty = case (splitAlgTyConApp_maybe inst_ty) of
631 Just (inst_tc,_,_) -> tycon == inst_tc
634 match_fun inst_ty = isFunType inst_ty
637 is_plain_instance inst_ty
638 = case (splitAlgTyConApp_maybe inst_ty) of
639 Just (_,tys,_) -> all isTyVarTemplateTy tys
640 Nothing -> case maybeUnpackFunTy inst_ty of
641 Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res
642 Nothing -> error "TcInstDecls:is_plain_instance"
647 Checking for a decent instance type
648 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
649 @scrutiniseInstanceType@ checks the type {\em and} its syntactic constraints:
650 it must normally look like: @instance Foo (Tycon a b c ...) ...@
652 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
653 flag is on, or (2)~the instance is imported (they must have been
654 compiled elsewhere). In these cases, we let them go through anyway.
656 We can also have instances for functions: @instance Foo (a -> b) ...@.
659 scrutiniseInstanceType clas inst_taus
660 | -- CCALL CHECK (a).... urgh!
661 -- To verify that a user declaration of a CCallable/CReturnable
662 -- instance is OK, we must be able to see the constructor(s)
663 -- of the instance type (see next guard.)
665 -- We flag this separately to give a more precise error msg.
667 (uniqueOf clas == cCallableClassKey && not constructors_visible) ||
668 (uniqueOf clas == cReturnableClassKey && not constructors_visible)
669 = failWithTc (invisibleDataConPrimCCallErr clas first_inst_tau)
672 -- A user declaration of a CCallable/CReturnable instance
673 -- must be for a "boxed primitive" type.
674 (uniqueOf clas == cCallableClassKey && not (ccallable_type first_inst_tau)) ||
675 (uniqueOf clas == cReturnableClassKey && not (creturnable_type first_inst_tau))
676 = failWithTc (nonBoxedPrimCCallErr clas first_inst_tau)
679 -- It is obviously illegal to have an explicit instance
680 -- for something that we are also planning to `derive'
681 | clas `elem` (tyConDerivings inst_tycon)
682 = failWithTc (derivingWhenInstanceExistsErr clas first_inst_tau)
683 -- Kind check will have ensured inst_taus is of length 1
685 -- ALL TYPE VARIABLES => bad
686 | all isTyVarTy inst_taus
687 = failWithTc (instTypeErr clas inst_taus (text "all the instance types are type variables"))
689 -- WITH HASKELL 1.4, MUST HAVE C (T a b c)
690 | not opt_GlasgowExts
691 && not (length inst_taus == 1 &&
692 maybeToBool tyconapp_maybe &&
693 not (isSynTyCon inst_tycon) &&
694 all isTyVarTy arg_tys &&
695 length (tyVarSetToList (tyVarsOfTypes arg_tys)) == length arg_tys
696 -- This last condition checks that all the type variables are distinct
698 = failWithTc (instTypeErr clas inst_taus
699 (text "the instance type must be of form (T a b c)" $$
700 text "where T is not a synonym, and a,b,c are distinct type variables")
707 tyconapp_maybe = splitTyConApp_maybe first_inst_tau
708 Just (inst_tycon, arg_tys) = tyconapp_maybe
709 (first_inst_tau : _) = inst_taus
711 constructors_visible =
712 case splitAlgTyConApp_maybe first_inst_tau of
713 Just (_,_,[]) -> False
714 everything_else -> True
716 -- These conditions come directly from what the DsCCall is capable of.
717 -- Totally grotesque. Green card should solve this.
719 ccallable_type ty = isUnpointedType ty || -- Allow CCallable Int# etc
720 maybeToBool (maybeBoxedPrimType ty) || -- Ditto Int etc
724 byte_arr_thing = case splitAlgTyConApp_maybe ty of
725 Just (tycon, ty_args, [data_con]) | isDataTyCon tycon ->
726 length data_con_arg_tys == 2 &&
727 maybeToBool maybe_arg2_tycon &&
728 (arg2_tycon == byteArrayPrimTyCon ||
729 arg2_tycon == mutableByteArrayPrimTyCon)
731 data_con_arg_tys = dataConArgTys data_con ty_args
732 (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
733 maybe_arg2_tycon = splitTyConApp_maybe data_con_arg_ty2
734 Just (arg2_tycon,_) = maybe_arg2_tycon
738 creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
739 -- Or, a data type with a single nullary constructor
740 case (splitAlgTyConApp_maybe ty) of
741 Just (tycon, tys_applied, [data_con])
742 -> isNullaryDataCon data_con
748 instTypeErr clas tys msg
749 = sep [ptext SLIT("Illegal instance declaration for") <+> quotes (pprConstraint clas tys),
753 derivingWhenInstanceExistsErr clas tycon
754 = hang (hsep [ptext SLIT("Deriving class"),
756 ptext SLIT("type"), quotes (ppr tycon)])
757 4 (ptext SLIT("when an explicit instance exists"))
759 nonBoxedPrimCCallErr clas inst_ty
760 = hang (ptext SLIT("Unacceptable instance type for ccall-ish class"))
761 4 (hsep [ ptext SLIT("class"), ppr clas, ptext SLIT("type"),
764 omittedMethodWarn sel_id clas
765 = sep [ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id),
766 ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)]
769 Declaring CCallable & CReturnable instances in a module different
770 from where the type was defined. Caused by importing data type
771 abstractly (either programmatically or by the renamer being over-eager
774 invisibleDataConPrimCCallErr clas inst_ty
775 = hang (hsep [ptext SLIT("Constructors for"), quotes (ppr inst_ty),
776 ptext SLIT("not visible when checking"),
777 quotes (ppr clas), ptext SLIT("instance")])
778 4 (hsep [text "(Try either importing", ppr inst_ty,
779 text "non-abstractly or compile using -fno-prune-tydecls ..)"])
781 superClassCtxt = ptext SLIT("From the superclasses of the instance declaration")