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 )
29 import TcClassDcl ( tcMethodBind, badMethodErr )
31 import RnMonad ( RnNameSupply )
32 import Inst ( Inst, InstOrigin(..),
33 newDicts, LIE, emptyLIE, plusLIE, plusLIEs )
34 import TcDeriv ( tcDeriving )
35 import TcEnv ( tcExtendGlobalValEnv, tcAddImportedIdInfo )
36 import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, classDataCon )
37 import TcKind ( TcKind, unifyKind )
38 import TcMonoType ( tcHsType )
39 import TcSimplify ( tcSimplifyAndCheck )
40 import TcType ( TcType, TcTyVar, TcTyVarSet,
41 zonkSigTyVar, tcInstSigTyVars, tcInstType, tcInstTheta
44 import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
45 foldBag, bagToList, Bag
47 import CmdLineOpts ( opt_GlasgowExts, opt_WarnMissingMethods )
48 import Class ( classBigSig, Class )
49 import Id ( isNullaryDataCon, dataConArgTys, Id )
50 import Maybes ( maybeToBool, seqMaybe, catMaybes )
51 import Name ( nameOccName, mkLocalName,
52 isLocallyDefined, Module,
55 import PrelVals ( nO_METHOD_BINDING_ERROR_ID )
56 import PprType ( pprParendType, pprConstraint )
57 import SrcLoc ( SrcLoc, noSrcLoc )
58 import TyCon ( isSynTyCon, isDataTyCon, tyConDerivings )
59 import Type ( Type, ThetaType, isUnpointedType,
60 splitSigmaTy, isTyVarTy, mkSigmaTy,
61 splitTyConApp_maybe, splitDictTy_maybe,
62 splitAlgTyConApp_maybe, splitRhoTy,
65 import TyVar ( zipTyVarEnv, mkTyVarSet, tyVarSetToList, TyVar )
66 import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
67 import TysWiredIn ( stringTy )
68 import Unique ( Unique, cCallableClassKey, cReturnableClassKey, Uniquable(..) )
72 Typechecking instance declarations is done in two passes. The first
73 pass, made by @tcInstDecls1@, collects information to be used in the
76 This pre-processed info includes the as-yet-unprocessed bindings
77 inside the instance declaration. These are type-checked in the second
78 pass, when the class-instance envs and GVE contain all the info from
79 all the instance and value decls. Indeed that's the reason we need
80 two passes over the instance decls.
83 Here is the overall algorithm.
84 Assume that we have an instance declaration
86 instance c => k (t tvs) where b
90 $LIE_c$ is the LIE for the context of class $c$
92 $betas_bar$ is the free variables in the class method type, excluding the
95 $LIE_cop$ is the LIE constraining a particular class method
97 $tau_cop$ is the tau type of a class method
99 $LIE_i$ is the LIE for the context of instance $i$
101 $X$ is the instance constructor tycon
103 $gammas_bar$ is the set of type variables of the instance
105 $LIE_iop$ is the LIE for a particular class method instance
107 $tau_iop$ is the tau type for this instance of a class method
109 $alpha$ is the class variable
111 $LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
113 $tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
116 ToDo: Update the list above with names actually in the code.
120 First, make the LIEs for the class and instance contexts, which means
121 instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
122 and make LIElistI and LIEI.
124 Then process each method in turn.
126 order the instance methods according to the ordering of the class methods
128 express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
130 Create final dictionary function from bindings generated already
132 df = lambda inst_tyvars
139 in <op1,op2,...,opn,sd1,...,sdm>
141 Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
142 and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
146 tcInstDecls1 :: TcEnv s -- Contains IdInfo for dfun ids
148 -> Module -- module name for deriving
149 -> RnNameSupply -- for renaming derivings
150 -> TcM s (Bag InstInfo,
154 tcInstDecls1 unf_env decls mod_name rn_name_supply
155 = -- Do the ordinary instance declarations
156 mapNF_Tc (tcInstDecl1 unf_env mod_name)
157 [inst_decl | InstD inst_decl <- decls] `thenNF_Tc` \ inst_info_bags ->
159 decl_inst_info = unionManyBags inst_info_bags
161 -- Handle "derived" instances; note that we only do derivings
162 -- for things in this module; we ignore deriving decls from
164 tcDeriving mod_name rn_name_supply decl_inst_info
165 `thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) ->
168 full_inst_info = deriv_inst_info `unionBags` decl_inst_info
170 returnTc (full_inst_info, deriv_binds, ddump_deriv)
173 tcInstDecl1 :: TcEnv s -> Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
175 tcInstDecl1 unf_env mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
176 = -- Prime error recovery, set source location
177 recoverNF_Tc (returnNF_Tc emptyBag) $
178 tcAddSrcLoc src_loc $
180 -- Type-check all the stuff before the "where"
181 tcHsType poly_ty `thenTc` \ poly_ty' ->
183 (tyvars, theta, dict_ty) = splitSigmaTy poly_ty'
184 (clas, inst_tys) = case splitDictTy_maybe dict_ty of
185 Nothing -> pprPanic "tcInstDecl1" (ppr poly_ty)
189 -- Check for respectable instance type
190 scrutiniseInstanceType clas inst_tys `thenTc_`
192 -- Make the dfun id and constant-method ids
194 (dfun_id, dfun_theta) = mkInstanceRelatedIds dfun_name
195 clas tyvars inst_tys theta
196 -- Add info from interface file
197 final_dfun_id = tcAddImportedIdInfo unf_env dfun_id
199 returnTc (unitBag (InstInfo clas tyvars inst_tys theta
200 dfun_theta final_dfun_id
201 binds src_loc uprags))
205 %************************************************************************
207 \subsection{Type-checking instance declarations, pass 2}
209 %************************************************************************
212 tcInstDecls2 :: Bag InstInfo
213 -> NF_TcM s (LIE s, TcMonoBinds s)
215 tcInstDecls2 inst_decls
216 = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyMonoBinds)) inst_decls
218 combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
219 tc2 `thenNF_Tc` \ (lie2, binds2) ->
220 returnNF_Tc (lie1 `plusLIE` lie2,
221 binds1 `AndMonoBinds` binds2)
225 ======= New documentation starts here (Sept 92) ==============
227 The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
228 the dictionary function for this instance declaration. For example
230 instance Foo a => Foo [a] where
234 might generate something like
236 dfun.Foo.List dFoo_a = let op1 x = ...
242 HOWEVER, if the instance decl has no context, then it returns a
243 bigger @HsBinds@ with declarations for each method. For example
245 instance Foo [a] where
251 dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
252 const.Foo.op1.List a x = ...
253 const.Foo.op2.List a y = ...
255 This group may be mutually recursive, because (for example) there may
256 be no method supplied for op2 in which case we'll get
258 const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
260 that is, the default method applied to the dictionary at this type.
262 What we actually produce in either case is:
264 AbsBinds [a] [dfun_theta_dicts]
265 [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
266 { d = (sd1,sd2, ..., op1, op2, ...)
271 The "maybe" says that we only ask AbsBinds to make global constant methods
272 if the dfun_theta is empty.
275 For an instance declaration, say,
277 instance (C1 a, C2 b) => C (T a b) where
280 where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
281 function whose type is
283 (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
285 Notice that we pass it the superclass dictionaries at the instance type; this
286 is the ``Mark Jones optimisation''. The stuff before the "=>" here
287 is the @dfun_theta@ below.
289 First comes the easy case of a non-local instance decl.
292 tcInstDecl2 :: InstInfo -> NF_TcM s (LIE s, TcMonoBinds s)
294 tcInstDecl2 (InstInfo clas inst_tyvars inst_tys
295 inst_decl_theta dfun_theta
298 | not (isLocallyDefined dfun_id)
299 = returnNF_Tc (emptyLIE, EmptyMonoBinds)
302 -- I deleted this "optimisation" because when importing these
303 -- instance decls the renamer would look for the dfun bindings and they weren't there.
304 -- This would be fixable, but it seems simpler just to produce a tiny void binding instead,
305 -- even though it's never used.
307 -- This case deals with CCallable etc, which don't need any bindings
309 = returnNF_Tc (emptyLIE, EmptyBinds)
313 = -- Prime error recovery
314 recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
317 -- Get the class signature
319 origin = InstanceDeclOrigin
321 sc_theta, sc_sel_ids,
322 op_sel_ids, defm_ids) = classBigSig clas
325 -- Instantiate the instance decl with tc-style type variables
326 tcInstSigTyVars inst_tyvars `thenNF_Tc` \ (inst_tyvars', _, tenv) ->
327 mapNF_Tc (tcInstType tenv) inst_tys `thenNF_Tc` \ inst_tys' ->
328 tcInstTheta tenv dfun_theta `thenNF_Tc` \ dfun_theta' ->
329 tcInstTheta tenv inst_decl_theta `thenNF_Tc` \ inst_decl_theta' ->
331 -- Instantiate the super-class context with inst_tys
333 tcInstTheta (zipTyVarEnv class_tyvars inst_tys') sc_theta `thenNF_Tc` \ sc_theta' ->
335 -- Create dictionary Ids from the specified instance contexts.
336 newDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) ->
337 newDicts origin dfun_theta' `thenNF_Tc` \ (dfun_arg_dicts, dfun_arg_dicts_ids) ->
338 newDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) ->
339 newDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
341 -- Now process any INLINE or SPECIALIZE pragmas for the methods
342 -- ...[NB May 97; all ignored except INLINE]
343 tcPragmaSigs uprags `thenTc` \ (prag_fn, spec_binds, spec_lie) ->
345 -- Check that all the method bindings come from this class
347 check_from_this_class (bndr, loc)
348 | nameOccName bndr `elem` sel_names = returnNF_Tc ()
349 | otherwise = tcAddSrcLoc loc $
350 addErrTc (badMethodErr bndr clas)
351 sel_names = map getOccName op_sel_ids
352 bndrs = bagToList (collectMonoBinders monobinds)
354 mapNF_Tc check_from_this_class bndrs `thenNF_Tc_`
356 tcExtendGlobalValEnv (catMaybes defm_ids) (
358 -- Default-method Ids may be mentioned in synthesised RHSs
359 mapAndUnzip3Tc (tcInstMethodBind clas inst_tys' inst_tyvars' monobinds)
360 (op_sel_ids `zip` defm_ids)
361 ) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
363 -- Check the overloading constraints of the methods and superclasses
364 mapNF_Tc zonkSigTyVar inst_tyvars' `thenNF_Tc` \ zonked_inst_tyvars ->
367 inst_tyvars_set = mkTyVarSet zonked_inst_tyvars
369 (meth_lies, meth_ids) = unzip meth_lies_w_ids
371 -- These insts are in scope; quite a few, eh?
372 avail_insts = this_dict `plusLIE`
373 dfun_arg_dicts `plusLIE`
375 unionManyBags meth_lies
377 methods_lie = plusLIEs insts_needed_s
380 -- Check that we *could* construct the superclass dictionaries,
381 -- even though we are *actually* going to pass the superclass dicts in;
382 -- the check ensures that the caller will never have a problem building
384 tcAddErrCtxt superClassCtxt (
386 (ptext SLIT("instance declaration context"))
387 inst_tyvars_set -- Local tyvars
388 inst_decl_dicts -- The instance dictionaries available
389 sc_dicts -- The superclass dicationaries reqd
391 -- Ignore the result; we're only doing
392 -- this to make sure it can be done.
394 -- Ditto method bindings
395 tcAddErrCtxt methodCtxt (
397 (ptext SLIT("instance declaration context"))
398 inst_tyvars_set -- Local tyvars
403 -- Now do the simplification again, this time to get the
404 -- bindings; this time we use an enhanced "avails"
405 -- Ignore errors because they come from the *previous* tcSimplifys
408 (ptext SLIT("instance declaration context"))
410 dfun_arg_dicts -- NB! Don't include this_dict here, else the sc_dicts
411 -- get bound by just selecting from this_dict!!
412 (sc_dicts `plusLIE` methods_lie)
413 ) `thenTc` \ (const_lie, lie_binds) ->
416 -- Create the result bindings
418 dict_constr = classDataCon clas
420 con_app = foldl HsApp (TyApp (HsVar (RealId dict_constr)) inst_tys')
421 (map HsVar (sc_dict_ids ++ meth_ids))
422 -- We don't produce a binding for the dict_constr; instead we
423 -- rely on the simplifier to unfold this saturated application
425 dict_bind = VarMonoBind this_dict_id con_app
426 method_binds = andMonoBinds method_binds_s
432 [(inst_tyvars', RealId dfun_id, this_dict_id)]
433 (lie_binds `AndMonoBinds`
434 method_binds `AndMonoBinds`
437 returnTc (const_lie `plusLIE` spec_lie,
438 main_bind `AndMonoBinds` spec_binds)
442 %************************************************************************
444 \subsection{Processing each method}
446 %************************************************************************
451 -> [TcType s] -- Instance types
452 -> [TcTyVar s] -- and their free (sig) tyvars
453 -> RenamedMonoBinds -- Method binding
454 -> (Id, Maybe Id) -- Selector id and default-method id
455 -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
457 tcInstMethodBind clas inst_tys inst_tyvars meth_binds (sel_id, maybe_dm_id)
458 = tcGetSrcLoc `thenNF_Tc` \ loc ->
459 tcGetUnique `thenNF_Tc` \ uniq ->
461 meth_occ = getOccName sel_id
462 default_meth_name = mkLocalName uniq meth_occ loc
463 maybe_meth_bind = find meth_occ meth_binds
464 the_meth_bind = case maybe_meth_bind of
466 Nothing -> mk_default_bind default_meth_name loc
469 -- Warn if no method binding, only if -fwarn-missing-methods
471 warnTc (opt_WarnMissingMethods &&
472 not (maybeToBool maybe_meth_bind) &&
473 not (maybeToBool maybe_dm_id))
474 (omittedMethodWarn sel_id clas) `thenNF_Tc_`
476 -- Typecheck the method binding
477 tcMethodBind clas origin inst_tys inst_tyvars sel_id the_meth_bind
479 origin = InstanceDeclOrigin -- Poor
481 find occ EmptyMonoBinds = Nothing
482 find occ (AndMonoBinds b1 b2) = find occ b1 `seqMaybe` find occ b2
484 find occ b@(FunMonoBind op_name _ _ _) | nameOccName op_name == occ = Just b
485 | otherwise = Nothing
486 find occ b@(PatMonoBind (VarPatIn op_name) _ _) | nameOccName op_name == occ = Just b
487 | otherwise = Nothing
488 find occ other = panic "Urk! Bad instance method binding"
491 mk_default_bind local_meth_name loc
492 = PatMonoBind (VarPatIn local_meth_name)
493 (GRHSsAndBindsIn (unguardedRHS (default_expr loc) loc) EmptyBinds)
497 = case maybe_dm_id of
498 Just dm_id -> HsVar (getName dm_id) -- There's a default method
499 Nothing -> error_expr loc -- No default method
502 = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID))
503 (HsLit (HsString (_PK_ (error_msg loc))))
505 error_msg loc = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
511 %************************************************************************
513 \subsection{Type-checking specialise instance pragmas}
515 %************************************************************************
519 tcSpecInstSigs :: E -> CE -> TCE
520 -> Bag InstInfo -- inst decls seen (declared and derived)
521 -> [RenamedSpecInstSig] -- specialise instance upragmas
522 -> TcM (Bag InstInfo) -- new, overlapped, inst decls
524 tcSpecInstSigs e ce tce inst_infos []
527 tcSpecInstSigs e ce tce inst_infos sigs
528 = buildInstanceEnvs inst_infos `thenTc` \ inst_mapper ->
529 tc_inst_spec_sigs inst_mapper sigs `thenNF_Tc` \ spec_inst_infos ->
530 returnTc spec_inst_infos
532 tc_inst_spec_sigs inst_mapper []
533 = returnNF_Tc emptyBag
534 tc_inst_spec_sigs inst_mapper (sig:sigs)
535 = tcSpecInstSig e ce tce inst_infos inst_mapper sig `thenNF_Tc` \ info_sig ->
536 tc_inst_spec_sigs inst_mapper sigs `thenNF_Tc` \ info_sigs ->
537 returnNF_Tc (info_sig `unionBags` info_sigs)
539 tcSpecInstSig :: E -> CE -> TCE
542 -> RenamedSpecInstSig
543 -> NF_TcM (Bag InstInfo)
545 tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc)
546 = recoverTc emptyBag (
547 tcAddSrcLoc src_loc (
549 clas = lookupCE ce class_name -- Renamer ensures this can't fail
551 -- Make some new type variables, named as in the specialised instance type
552 ty_names = extractHsTyNames ???is_tyvarish_name??? ty
553 (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names
555 babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
556 `thenTc` \ inst_ty ->
558 maybe_tycon = case splitAlgTyConApp_maybe inst_ty of
559 Just (tc,_,_) -> Just tc
562 maybe_unspec_inst = lookup_unspec_inst clas maybe_tycon inst_infos
564 -- Check that we have a local instance declaration to specialise
565 checkMaybeTc maybe_unspec_inst
566 (specInstUnspecInstNotFoundErr clas inst_ty src_loc) `thenTc_`
568 -- Create tvs to substitute for tmpls while simplifying the context
569 copyTyVars inst_tmpls `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) ->
571 Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta
572 _ _ binds _ uprag) = maybe_unspec_inst
574 subst = case matchTy unspec_inst_ty inst_ty of
576 Nothing -> panic "tcSpecInstSig:matchTy"
578 subst_theta = instantiateThetaTy subst unspec_theta
579 subst_tv_theta = instantiateThetaTy tv_e subst_theta
581 mk_spec_origin clas ty
582 = InstanceSpecOrigin inst_mapper clas ty src_loc
583 -- I'm VERY SUSPICIOUS ABOUT THIS
584 -- the inst-mapper is in a knot at this point so it's no good
585 -- looking at it in tcSimplify...
587 tcSimplifyThetas mk_spec_origin subst_tv_theta
588 `thenTc` \ simpl_tv_theta ->
590 simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ]
592 tv_tmpl_map = zipEqual "tcSpecInstSig" inst_tv_tys inst_tmpl_tys
593 tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv
595 mkInstanceRelatedIds clas inst_tmpls inst_ty simpl_theta uprag
596 `thenNF_Tc` \ (dfun_id, dfun_theta, const_meth_ids) ->
598 getSwitchCheckerTc `thenNF_Tc` \ sw_chkr ->
599 (if sw_chkr SpecialiseTrace then
600 pprTrace "Specialised Instance: "
601 (vcat [hsep [if null simpl_theta then empty else ppr simpl_theta,
602 if null simpl_theta then empty else ptext SLIT("=>"),
604 pprParendType inst_ty],
605 hsep [ptext SLIT(" derived from:"),
606 if null unspec_theta then empty else ppr unspec_theta,
607 if null unspec_theta then empty else ptext SLIT("=>"),
609 pprParendType unspec_inst_ty]])
612 returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
614 binds src_loc uprag))
618 lookup_unspec_inst clas maybe_tycon inst_infos
619 = case filter (match_info match_inst_ty) (bagToList inst_infos) of
621 (info:_) -> Just info
623 match_info match_ty (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _)
624 = from_here && clas == inst_clas &&
625 match_ty inst_ty && is_plain_instance inst_ty
627 match_inst_ty = case maybe_tycon of
628 Just tycon -> match_tycon tycon
631 match_tycon tycon inst_ty = case (splitAlgTyConApp_maybe inst_ty) of
632 Just (inst_tc,_,_) -> tycon == inst_tc
635 match_fun inst_ty = isFunType inst_ty
638 is_plain_instance inst_ty
639 = case (splitAlgTyConApp_maybe inst_ty) of
640 Just (_,tys,_) -> all isTyVarTemplateTy tys
641 Nothing -> case maybeUnpackFunTy inst_ty of
642 Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res
643 Nothing -> error "TcInstDecls:is_plain_instance"
648 Checking for a decent instance type
649 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
650 @scrutiniseInstanceType@ checks the type {\em and} its syntactic constraints:
651 it must normally look like: @instance Foo (Tycon a b c ...) ...@
653 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
654 flag is on, or (2)~the instance is imported (they must have been
655 compiled elsewhere). In these cases, we let them go through anyway.
657 We can also have instances for functions: @instance Foo (a -> b) ...@.
660 scrutiniseInstanceType clas inst_taus
661 | -- CCALL CHECK (a).... urgh!
662 -- To verify that a user declaration of a CCallable/CReturnable
663 -- instance is OK, we must be able to see the constructor(s)
664 -- of the instance type (see next guard.)
666 -- We flag this separately to give a more precise error msg.
668 (uniqueOf clas == cCallableClassKey || uniqueOf clas == cReturnableClassKey)
669 && is_alg_tycon_app && not constructors_visible
670 = failWithTc (invisibleDataConPrimCCallErr clas first_inst_tau)
673 -- A user declaration of a CCallable/CReturnable instance
674 -- must be for a "boxed primitive" type.
675 (uniqueOf clas == cCallableClassKey && not (ccallable_type first_inst_tau)) ||
676 (uniqueOf clas == cReturnableClassKey && not (creturnable_type first_inst_tau))
677 = failWithTc (nonBoxedPrimCCallErr clas first_inst_tau)
680 -- It is obviously illegal to have an explicit instance
681 -- for something that we are also planning to `derive'
682 | maybeToBool alg_tycon_app_maybe && clas `elem` (tyConDerivings alg_tycon)
683 = failWithTc (derivingWhenInstanceExistsErr clas first_inst_tau)
684 -- Kind check will have ensured inst_taus is of length 1
686 -- WITH HASKELL 1.4, MUST HAVE C (T a b c)
687 | not opt_GlasgowExts
688 && not (length inst_taus == 1 &&
689 maybeToBool maybe_tycon_app && -- Yes, there's a type constuctor
690 not (isSynTyCon tycon) && -- ...but not a synonym
691 all isTyVarTy arg_tys && -- Applied to type variables
692 length (tyVarSetToList (tyVarsOfTypes arg_tys)) == length arg_tys
693 -- This last condition checks that all the type variables are distinct
695 = failWithTc (instTypeErr clas inst_taus
696 (text "the instance type must be of form (T a b c)" $$
697 text "where T is not a synonym, and a,b,c are distinct type variables")
704 (first_inst_tau : _) = inst_taus
706 -- Stuff for algebraic or -> type
707 maybe_tycon_app = splitTyConApp_maybe first_inst_tau
708 Just (tycon, arg_tys) = maybe_tycon_app
710 -- Stuff for an *algebraic* data type
711 alg_tycon_app_maybe = splitAlgTyConApp_maybe first_inst_tau
712 -- The "Alg" part looks through synonyms
713 is_alg_tycon_app = maybeToBool alg_tycon_app_maybe
714 Just (alg_tycon, _, data_cons) = alg_tycon_app_maybe
716 constructors_visible = not (null data_cons)
719 -- These conditions come directly from what the DsCCall is capable of.
720 -- Totally grotesque. Green card should solve this.
722 ccallable_type ty = isUnpointedType ty || -- Allow CCallable Int# etc
723 maybeToBool (maybeBoxedPrimType ty) || -- Ditto Int etc
727 byte_arr_thing = case splitAlgTyConApp_maybe ty of
728 Just (tycon, ty_args, [data_con]) | isDataTyCon tycon ->
729 length data_con_arg_tys == 2 &&
730 maybeToBool maybe_arg2_tycon &&
731 (arg2_tycon == byteArrayPrimTyCon ||
732 arg2_tycon == mutableByteArrayPrimTyCon)
734 data_con_arg_tys = dataConArgTys data_con ty_args
735 (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
736 maybe_arg2_tycon = splitTyConApp_maybe data_con_arg_ty2
737 Just (arg2_tycon,_) = maybe_arg2_tycon
741 creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
742 -- Or, a data type with a single nullary constructor
743 case (splitAlgTyConApp_maybe ty) of
744 Just (tycon, tys_applied, [data_con])
745 -> isNullaryDataCon data_con
751 instTypeErr clas tys msg
752 = sep [ptext SLIT("Illegal instance declaration for") <+> quotes (pprConstraint clas tys),
756 derivingWhenInstanceExistsErr clas tycon
757 = hang (hsep [ptext SLIT("Deriving class"),
759 ptext SLIT("type"), quotes (ppr tycon)])
760 4 (ptext SLIT("when an explicit instance exists"))
762 nonBoxedPrimCCallErr clas inst_ty
763 = hang (ptext SLIT("Unacceptable instance type for ccall-ish class"))
764 4 (hsep [ ptext SLIT("class"), ppr clas, ptext SLIT("type"),
767 omittedMethodWarn sel_id clas
768 = sep [ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id),
769 ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)]
772 Declaring CCallable & CReturnable instances in a module different
773 from where the type was defined. Caused by importing data type
774 abstractly (either programmatically or by the renamer being over-eager
777 invisibleDataConPrimCCallErr clas inst_ty
778 = hang (hsep [ptext SLIT("Constructors for"), quotes (ppr inst_ty),
779 ptext SLIT("not visible when checking"),
780 quotes (ppr clas), ptext SLIT("instance")])
781 4 (hsep [text "(Try either importing", ppr inst_ty,
782 text "non-abstractly or compile using -fno-prune-tydecls ..)"])
784 methodCtxt = ptext SLIT("When checking the methods of an instance declaration")
785 superClassCtxt = ptext SLIT("When checking the superclasses of an instance declaration")