2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcInstDecls]{Typechecking instance declarations}
7 #include "HsVersions.h"
18 import HsSyn ( HsDecl(..), InstDecl(..), TyDecl, ClassDecl, DefaultDecl,
19 FixityDecl, IfaceSig, Sig(..),
20 SpecInstSig(..), HsBinds(..),
21 MonoBinds(..), GRHSsAndBinds(..), GRHS(..), Match,
22 InPat(..), OutPat(..), HsExpr(..), HsLit(..),
23 Stmt, DoOrListComp, ArithSeqInfo, Fake, Fixity,
25 SYN_IE(RecFlag), recursive, nonRecursive, collectMonoBinders,
28 import RnHsSyn ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedMonoBinds),
29 SYN_IE(RenamedInstDecl), SYN_IE(RenamedFixityDecl), SYN_IE(RenamedHsExpr),
30 SYN_IE(RenamedSig), SYN_IE(RenamedSpecInstSig), SYN_IE(RenamedHsDecl)
32 import TcHsSyn ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcHsBinds),
33 SYN_IE(TcMonoBinds), SYN_IE(TcExpr), tcIdType,
35 mkHsDictLam, mkHsDictApp )
37 import TcBinds ( tcBindWithSigs, tcPragmaSigs, TcSigInfo(..), checkSigTyVars )
39 import RnMonad ( SYN_IE(RnNameSupply) )
40 import Inst ( Inst, InstOrigin(..), SYN_IE(InstanceMapper),
41 instToId, newDicts, newMethod, SYN_IE(LIE), emptyLIE, plusLIE )
42 import PragmaInfo ( PragmaInfo(..) )
43 import TcDeriv ( tcDeriving )
44 import TcEnv ( tcLookupClass, newLocalId, tcExtendGlobalTyVars, tcGetGlobalTyVars,
45 tcExtendGlobalValEnv, tcAddImportedIdInfo
47 import SpecEnv ( SpecEnv )
48 import TcGRHSs ( tcGRHSsAndBinds )
49 import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
50 import TcKind ( TcKind, unifyKind )
51 import TcMatches ( tcMatchesFun )
52 import TcMonoType ( tcTyVarScope, tcContext, tcHsTypeKind )
53 import TcSimplify ( tcSimplifyAndCheck )
54 import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet),
55 tcInstSigTyVars, tcInstType, tcInstSigTcType,
56 tcInstTheta, tcInstTcType, tcInstSigType
58 import Unify ( unifyTauTy, unifyTauTyLists )
61 import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
62 concatBag, foldBag, bagToList, listToBag,
64 import CmdLineOpts ( opt_GlasgowExts, opt_CompilingGhcInternals,
65 opt_OmitDefaultInstanceMethods, opt_PprUserLength,
66 opt_SpecialiseOverloaded
68 import Class ( GenClass,
70 classDefaultMethodId, SYN_IE(Class)
72 import Id ( GenId, idType, replacePragmaInfo,
73 isNullaryDataCon, dataConArgTys, SYN_IE(Id) )
74 import ListSetOps ( minusList )
75 import Maybes ( maybeToBool, expectJust, seqMaybe, catMaybes )
76 import Name ( nameOccName, getOccString, occNameString, moduleString, getSrcLoc,
77 isLocallyDefined, OccName, Name{--O only-}, SYN_IE(Module),
80 import PrelVals ( nO_EXPLICIT_METHOD_ERROR_ID, nO_DEFAULT_METHOD_ERROR_ID )
81 import PprType ( GenType, GenTyVar, GenClass, TyCon,
85 import SrcLoc ( SrcLoc, noSrcLoc )
87 import TyCon ( isSynTyCon, isDataTyCon, derivedClasses )
88 import Type ( GenType(..), SYN_IE(ThetaType), mkTyVarTys, isPrimType,
89 splitSigmaTy, splitAppTys, isTyVarTy, matchTy, mkSigmaTy,
90 getTyCon_maybe, maybeAppTyCon, SYN_IE(Type), getTyVar,
91 maybeBoxedPrimType, maybeAppDataTyCon, splitRhoTy, eqTy
93 import TyVar ( GenTyVar, SYN_IE(GenTyVarSet), tyVarSetToList,
94 mkTyVarSet, unionTyVarSets, SYN_IE(TyVar) )
95 import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
96 import TysWiredIn ( stringTy )
97 import Unique ( Unique, cCallableClassKey, cReturnableClassKey, Uniquable(..) )
98 import Util ( zipEqual, panic, pprPanic, pprTrace, removeDups, Ord3(..)
99 #if __GLASGOW_HASKELL__ < 202
105 Typechecking instance declarations is done in two passes. The first
106 pass, made by @tcInstDecls1@, collects information to be used in the
109 This pre-processed info includes the as-yet-unprocessed bindings
110 inside the instance declaration. These are type-checked in the second
111 pass, when the class-instance envs and GVE contain all the info from
112 all the instance and value decls. Indeed that's the reason we need
113 two passes over the instance decls.
116 Here is the overall algorithm.
117 Assume that we have an instance declaration
119 instance c => k (t tvs) where b
123 $LIE_c$ is the LIE for the context of class $c$
125 $betas_bar$ is the free variables in the class method type, excluding the
128 $LIE_cop$ is the LIE constraining a particular class method
130 $tau_cop$ is the tau type of a class method
132 $LIE_i$ is the LIE for the context of instance $i$
134 $X$ is the instance constructor tycon
136 $gammas_bar$ is the set of type variables of the instance
138 $LIE_iop$ is the LIE for a particular class method instance
140 $tau_iop$ is the tau type for this instance of a class method
142 $alpha$ is the class variable
144 $LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
146 $tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
149 ToDo: Update the list above with names actually in the code.
153 First, make the LIEs for the class and instance contexts, which means
154 instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
155 and make LIElistI and LIEI.
157 Then process each method in turn.
159 order the instance methods according to the ordering of the class methods
161 express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
163 Create final dictionary function from bindings generated already
165 df = lambda inst_tyvars
172 in <op1,op2,...,opn,sd1,...,sdm>
174 Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
175 and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
179 tcInstDecls1 :: TcEnv s -- Contains IdInfo for dfun ids
181 -> Module -- module name for deriving
182 -> RnNameSupply -- for renaming derivings
183 -> TcM s (Bag InstInfo,
187 tcInstDecls1 unf_env decls mod_name rn_name_supply
188 = -- Do the ordinary instance declarations
189 mapNF_Tc (tcInstDecl1 unf_env mod_name)
190 [inst_decl | InstD inst_decl <- decls] `thenNF_Tc` \ inst_info_bags ->
192 decl_inst_info = unionManyBags inst_info_bags
194 -- Handle "derived" instances; note that we only do derivings
195 -- for things in this module; we ignore deriving decls from
196 -- interfaces! We pass fixities, because they may be used
197 -- in deriving Read and Show.
198 tcDeriving mod_name rn_name_supply decl_inst_info
199 `thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) ->
202 full_inst_info = deriv_inst_info `unionBags` decl_inst_info
204 returnTc (full_inst_info, deriv_binds, ddump_deriv)
207 tcInstDecl1 :: TcEnv s -> Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
209 tcInstDecl1 unf_env mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
210 = -- Prime error recovery, set source location
211 recoverNF_Tc (returnNF_Tc emptyBag) $
212 tcAddSrcLoc src_loc $
215 tcLookupClass class_name `thenTc` \ (clas_kind, clas) ->
217 -- Typecheck the context and instance type
218 tcTyVarScope tyvar_names (\ tyvars ->
219 tcContext context `thenTc` \ theta ->
220 tcHsTypeKind inst_ty `thenTc` \ (tau_kind, tau) ->
221 unifyKind clas_kind tau_kind `thenTc_`
222 returnTc (tyvars, theta, tau)
223 ) `thenTc` \ (inst_tyvars, inst_theta, inst_tau) ->
225 -- Check for respectable instance type
226 scrutiniseInstanceType dfun_name clas inst_tau
227 `thenTc` \ (inst_tycon,arg_tys) ->
229 -- Make the dfun id and constant-method ids
231 (dfun_id, dfun_theta) = mkInstanceRelatedIds dfun_name
232 clas inst_tyvars inst_tau inst_theta
233 -- Add info from interface file
234 final_dfun_id = tcAddImportedIdInfo unf_env dfun_id
236 returnTc (unitBag (InstInfo clas inst_tyvars inst_tau inst_theta
237 dfun_theta final_dfun_id
238 binds src_loc uprags))
240 (tyvar_names, context, dict_ty) = case poly_ty of
241 HsForAllTy tvs cxt dict_ty -> (tvs, cxt, dict_ty)
242 other -> ([], [], poly_ty)
243 (class_name, inst_ty) = case dict_ty of
244 MonoDictTy cls ty -> (cls,ty)
245 other -> pprPanic "Malformed instance decl" (ppr PprDebug poly_ty)
249 %************************************************************************
251 \subsection{Type-checking instance declarations, pass 2}
253 %************************************************************************
256 tcInstDecls2 :: Bag InstInfo
257 -> NF_TcM s (LIE s, TcMonoBinds s)
259 tcInstDecls2 inst_decls
260 = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyMonoBinds)) inst_decls
262 combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
263 tc2 `thenNF_Tc` \ (lie2, binds2) ->
264 returnNF_Tc (lie1 `plusLIE` lie2,
265 binds1 `AndMonoBinds` binds2)
269 ======= New documentation starts here (Sept 92) ==============
271 The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
272 the dictionary function for this instance declaration. For example
274 instance Foo a => Foo [a] where
278 might generate something like
280 dfun.Foo.List dFoo_a = let op1 x = ...
286 HOWEVER, if the instance decl has no context, then it returns a
287 bigger @HsBinds@ with declarations for each method. For example
289 instance Foo [a] where
295 dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
296 const.Foo.op1.List a x = ...
297 const.Foo.op2.List a y = ...
299 This group may be mutually recursive, because (for example) there may
300 be no method supplied for op2 in which case we'll get
302 const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
304 that is, the default method applied to the dictionary at this type.
306 What we actually produce in either case is:
308 AbsBinds [a] [dfun_theta_dicts]
309 [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
310 { d = (sd1,sd2, ..., op1, op2, ...)
315 The "maybe" says that we only ask AbsBinds to make global constant methods
316 if the dfun_theta is empty.
319 For an instance declaration, say,
321 instance (C1 a, C2 b) => C (T a b) where
324 where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
325 function whose type is
327 (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
329 Notice that we pass it the superclass dictionaries at the instance type; this
330 is the ``Mark Jones optimisation''. The stuff before the "=>" here
331 is the @dfun_theta@ below.
333 First comes the easy case of a non-local instance decl.
336 tcInstDecl2 :: InstInfo -> NF_TcM s (LIE s, TcMonoBinds s)
338 tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
339 inst_decl_theta dfun_theta
342 | not (isLocallyDefined dfun_id)
343 = returnNF_Tc (emptyLIE, EmptyMonoBinds)
346 -- I deleted this "optimisation" because when importing these
347 -- instance decls the renamer would look for the dfun bindings and they weren't there.
348 -- This would be fixable, but it seems simpler just to produce a tiny void binding instead,
349 -- even though it's never used.
351 -- This case deals with CCallable etc, which don't need any bindings
353 = returnNF_Tc (emptyLIE, EmptyBinds)
357 = -- Prime error recovery
358 recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
361 -- Get the class signature
362 tcInstSigTyVars inst_tyvars `thenNF_Tc` \ (inst_tyvars', _, tenv) ->
364 origin = InstanceDeclOrigin
366 super_classes, sc_sel_ids,
367 op_sel_ids, defm_ids) = classBigSig clas
369 tcInstType tenv inst_ty `thenNF_Tc` \ inst_ty' ->
370 tcInstTheta tenv dfun_theta `thenNF_Tc` \ dfun_theta' ->
371 tcInstTheta tenv inst_decl_theta `thenNF_Tc` \ inst_decl_theta' ->
373 sc_theta' = super_classes `zip` repeat inst_ty'
375 -- Create dictionary Ids from the specified instance contexts.
376 newDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) ->
377 newDicts origin dfun_theta' `thenNF_Tc` \ (dfun_arg_dicts, dfun_arg_dicts_ids) ->
378 newDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) ->
379 newDicts origin [(clas,inst_ty')] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
381 -- Now process any INLINE or SPECIALIZE pragmas for the methods
382 -- ...[NB May 97; all ignored except INLINE]
383 tcPragmaSigs uprags `thenTc` \ (prag_fn, spec_binds, spec_lie) ->
385 -- Check the method bindings
387 inst_tyvars_set' = mkTyVarSet inst_tyvars'
388 check_from_this_class (bndr, loc)
389 | nameOccName bndr `elem` sel_names = returnTc ()
390 | otherwise = recoverTc (returnTc ()) $
392 failTc (instBndrErr bndr clas)
393 sel_names = map getOccName op_sel_ids
395 mapTc check_from_this_class (bagToList (collectMonoBinders monobinds)) `thenTc_`
396 tcExtendGlobalTyVars inst_tyvars_set' (
397 tcExtendGlobalValEnv (catMaybes defm_ids) $
398 -- Default-method Ids may be mentioned in synthesised RHSs
399 mapAndUnzip3Tc (tcMethodBind clas inst_ty' monobinds)
400 (op_sel_ids `zip` defm_ids)
401 ) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
403 -- Check the overloading constraints of the methods and superclasses
405 (meth_lies, meth_ids) = unzip meth_lies_w_ids
406 avail_insts -- These insts are in scope; quite a few, eh?
407 = this_dict `plusLIE` dfun_arg_dicts `plusLIE` unionManyBags meth_lies
409 tcAddErrCtxt bindSigCtxt (
411 inst_tyvars_set' -- Local tyvars
413 (sc_dicts `unionBags`
414 unionManyBags insts_needed_s) -- Need to get defns for all these
415 ) `thenTc` \ (const_lie, super_binds) ->
417 -- Check that we *could* construct the superclass dictionaries,
418 -- even though we are *actually* going to pass the superclass dicts in;
419 -- the check ensures that the caller will never have a problem building
421 tcAddErrCtxt superClassSigCtxt (
423 inst_tyvars_set' -- Local tyvars
424 inst_decl_dicts -- The instance dictionaries available
425 sc_dicts -- The superclass dicationaries reqd
427 -- Ignore the result; we're only doing
428 -- this to make sure it can be done.
430 -- Create the result bindings
432 dict_bind = VarMonoBind this_dict_id (Dictionary sc_dict_ids meth_ids)
433 method_binds = andMonoBinds method_binds_s
439 [(inst_tyvars', RealId dfun_id, this_dict_id)]
440 (super_binds `AndMonoBinds`
441 method_binds `AndMonoBinds`
444 returnTc (const_lie `plusLIE` spec_lie,
445 main_bind `AndMonoBinds` spec_binds)
449 %************************************************************************
451 \subsection{Processing each method}
453 %************************************************************************
458 -> TcType s -- Instance type
459 -> RenamedMonoBinds -- Method binding
460 -> (Id, Maybe Id) -- Selector id and default-method id
461 -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
463 tcMethodBind clas inst_ty meth_binds (sel_id, maybe_dm_id)
464 = newMethod origin (RealId sel_id) [inst_ty] `thenNF_Tc` \ meth@(_, TcId local_meth_id) ->
465 tcInstSigTcType (idType local_meth_id) `thenNF_Tc` \ (tyvars', rho_ty') ->
467 meth_name = getName local_meth_id
469 maybe_meth_bind = go (getOccName sel_id) meth_binds
470 (bndr_name, op_bind) = case maybe_meth_bind of
472 Nothing -> (meth_name, mk_default_bind meth_name)
474 (theta', tau') = splitRhoTy rho_ty'
475 sig_info = TySigInfo bndr_name local_meth_id tyvars' theta' tau' noSrcLoc
478 -- Warn if no method binding
479 warnTc (not (maybeToBool maybe_meth_bind) && not (maybeToBool maybe_dm_id))
480 (omittedMethodWarn sel_id clas) `thenNF_Tc_`
482 tcBindWithSigs [bndr_name] op_bind [sig_info]
483 nonRecursive (\_ -> NoPragmaInfo) `thenTc` \ (binds, insts, _) ->
485 returnTc (binds, insts, meth)
487 origin = InstanceDeclOrigin -- Poor
489 go occ EmptyMonoBinds = Nothing
490 go occ (AndMonoBinds b1 b2) = go occ b1 `seqMaybe` go occ b2
492 go occ b@(FunMonoBind op_name _ _ locn) | nameOccName op_name == occ = Just (op_name, b)
493 | otherwise = Nothing
494 go occ b@(PatMonoBind (VarPatIn op_name) _ locn) | nameOccName op_name == occ = Just (op_name, b)
495 | otherwise = Nothing
496 go occ other = panic "Urk! Bad instance method binding"
499 mk_default_bind local_meth_name
500 = PatMonoBind (VarPatIn local_meth_name)
501 (GRHSsAndBindsIn [OtherwiseGRHS default_expr noSrcLoc] EmptyBinds)
504 default_expr = case maybe_dm_id of
505 Just dm_id -> HsVar (getName dm_id) -- There's a default method
506 Nothing -> error_expr -- No default method
508 error_expr = HsApp (HsVar (getName nO_DEFAULT_METHOD_ERROR_ID))
509 (HsLit (HsString (_PK_ error_msg)))
511 error_msg = show (hcat [ppr (PprForUser opt_PprUserLength) (getSrcLoc sel_id), text "|",
512 ppr (PprForUser opt_PprUserLength) sel_id
518 %************************************************************************
520 \subsection{Type-checking specialise instance pragmas}
522 %************************************************************************
526 tcSpecInstSigs :: E -> CE -> TCE
527 -> Bag InstInfo -- inst decls seen (declared and derived)
528 -> [RenamedSpecInstSig] -- specialise instance upragmas
529 -> TcM (Bag InstInfo) -- new, overlapped, inst decls
531 tcSpecInstSigs e ce tce inst_infos []
534 tcSpecInstSigs e ce tce inst_infos sigs
535 = buildInstanceEnvs inst_infos `thenTc` \ inst_mapper ->
536 tc_inst_spec_sigs inst_mapper sigs `thenNF_Tc` \ spec_inst_infos ->
537 returnTc spec_inst_infos
539 tc_inst_spec_sigs inst_mapper []
540 = returnNF_Tc emptyBag
541 tc_inst_spec_sigs inst_mapper (sig:sigs)
542 = tcSpecInstSig e ce tce inst_infos inst_mapper sig `thenNF_Tc` \ info_sig ->
543 tc_inst_spec_sigs inst_mapper sigs `thenNF_Tc` \ info_sigs ->
544 returnNF_Tc (info_sig `unionBags` info_sigs)
546 tcSpecInstSig :: E -> CE -> TCE
549 -> RenamedSpecInstSig
550 -> NF_TcM (Bag InstInfo)
552 tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc)
553 = recoverTc emptyBag (
554 tcAddSrcLoc src_loc (
556 clas = lookupCE ce class_name -- Renamer ensures this can't fail
558 -- Make some new type variables, named as in the specialised instance type
559 ty_names = extractHsTyNames ???is_tyvarish_name??? ty
560 (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names
562 babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
563 `thenTc` \ inst_ty ->
565 maybe_tycon = case maybeAppDataTyCon inst_ty of
566 Just (tc,_,_) -> Just tc
569 maybe_unspec_inst = lookup_unspec_inst clas maybe_tycon inst_infos
571 -- Check that we have a local instance declaration to specialise
572 checkMaybeTc maybe_unspec_inst
573 (specInstUnspecInstNotFoundErr clas inst_ty src_loc) `thenTc_`
575 -- Create tvs to substitute for tmpls while simplifying the context
576 copyTyVars inst_tmpls `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) ->
578 Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta
579 _ _ binds _ uprag) = maybe_unspec_inst
581 subst = case matchTy unspec_inst_ty inst_ty of
583 Nothing -> panic "tcSpecInstSig:matchTy"
585 subst_theta = instantiateThetaTy subst unspec_theta
586 subst_tv_theta = instantiateThetaTy tv_e subst_theta
588 mk_spec_origin clas ty
589 = InstanceSpecOrigin inst_mapper clas ty src_loc
590 -- I'm VERY SUSPICIOUS ABOUT THIS
591 -- the inst-mapper is in a knot at this point so it's no good
592 -- looking at it in tcSimplify...
594 tcSimplifyThetas mk_spec_origin subst_tv_theta
595 `thenTc` \ simpl_tv_theta ->
597 simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ]
599 tv_tmpl_map = zipEqual "tcSpecInstSig" inst_tv_tys inst_tmpl_tys
600 tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv
603 clas inst_tmpls inst_ty simpl_theta uprag
604 `thenNF_Tc` \ (dfun_id, dfun_theta, const_meth_ids) ->
606 getSwitchCheckerTc `thenNF_Tc` \ sw_chkr ->
607 (if sw_chkr SpecialiseTrace then
608 pprTrace "Specialised Instance: "
609 (vcat [hsep [if null simpl_theta then empty else ppr PprDebug simpl_theta,
610 if null simpl_theta then empty else ptext SLIT("=>"),
612 pprParendGenType PprDebug inst_ty],
613 hsep [ptext SLIT(" derived from:"),
614 if null unspec_theta then empty else ppr PprDebug unspec_theta,
615 if null unspec_theta then empty else ptext SLIT("=>"),
617 pprParendGenType PprDebug unspec_inst_ty]])
620 returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
622 binds src_loc uprag))
626 lookup_unspec_inst clas maybe_tycon inst_infos
627 = case filter (match_info match_inst_ty) (bagToList inst_infos) of
629 (info:_) -> Just info
631 match_info match_ty (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _)
632 = from_here && clas == inst_clas &&
633 match_ty inst_ty && is_plain_instance inst_ty
635 match_inst_ty = case maybe_tycon of
636 Just tycon -> match_tycon tycon
639 match_tycon tycon inst_ty = case (maybeAppDataTyCon inst_ty) of
640 Just (inst_tc,_,_) -> tycon == inst_tc
643 match_fun inst_ty = isFunType inst_ty
646 is_plain_instance inst_ty
647 = case (maybeAppDataTyCon inst_ty) of
648 Just (_,tys,_) -> all isTyVarTemplateTy tys
649 Nothing -> case maybeUnpackFunTy inst_ty of
650 Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res
651 Nothing -> error "TcInstDecls:is_plain_instance"
656 Checking for a decent instance type
657 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
658 @scrutiniseInstanceType@ checks the type {\em and} its syntactic constraints:
659 it must normally look like: @instance Foo (Tycon a b c ...) ...@
661 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
662 flag is on, or (2)~the instance is imported (they must have been
663 compiled elsewhere). In these cases, we let them go through anyway.
665 We can also have instances for functions: @instance Foo (a -> b) ...@.
668 scrutiniseInstanceType dfun_name clas inst_tau
670 | not (maybeToBool inst_tycon_maybe) || isSynTyCon inst_tycon
671 = failTc (instTypeErr inst_tau)
673 -- IMPORTED INSTANCES ARE OK (but see tcInstDecl1)
674 | not (isLocallyDefined dfun_name)
675 = returnTc (inst_tycon,arg_tys)
678 | not (opt_GlasgowExts ||
679 (all isTyVarTy arg_tys && null tyvar_dups)
681 = failTc (instTypeErr inst_tau)
684 -- It is obviously illegal to have an explicit instance
685 -- for something that we are also planning to `derive'
686 -- Though we can have an explicit instance which is more
687 -- specific than the derived instance
688 | clas `elem` (derivedClasses inst_tycon)
689 && all isTyVarTy arg_tys
690 = failTc (derivingWhenInstanceExistsErr clas inst_tycon)
693 -- A user declaration of a CCallable/CReturnable instance
694 -- must be for a "boxed primitive" type.
695 (uniqueOf clas == cCallableClassKey && not (ccallable_type inst_tau)) ||
696 (uniqueOf clas == cReturnableClassKey && not (creturnable_type inst_tau))
697 = failTc (nonBoxedPrimCCallErr clas inst_tau)
700 = returnTc (inst_tycon,arg_tys)
703 (possible_tycon, arg_tys) = splitAppTys inst_tau
704 inst_tycon_maybe = getTyCon_maybe possible_tycon
705 inst_tycon = expectJust "tcInstDecls1:inst_tycon" inst_tycon_maybe
706 (_, tyvar_dups) = removeDups cmp (map (getTyVar "tcInstDecls1:getTyVarTy") arg_tys)
708 -- These conditions come directly from what the DsCCall is capable of.
709 -- Totally grotesque. Green card should solve this.
711 ccallable_type ty = isPrimType ty || -- Allow CCallable Int# etc
712 maybeToBool (maybeBoxedPrimType ty) || -- Ditto Int etc
713 ty `eqTy` stringTy ||
716 byte_arr_thing = case maybeAppDataTyCon ty of
717 Just (tycon, ty_args, [data_con]) | isDataTyCon tycon ->
718 length data_con_arg_tys == 2 &&
719 maybeToBool maybe_arg2_tycon &&
720 (arg2_tycon == byteArrayPrimTyCon ||
721 arg2_tycon == mutableByteArrayPrimTyCon)
723 data_con_arg_tys = dataConArgTys data_con ty_args
724 (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
725 maybe_arg2_tycon = maybeAppTyCon data_con_arg_ty2
726 Just (arg2_tycon,_) = maybe_arg2_tycon
730 creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
731 -- Or, a data type with a single nullary constructor
732 case (maybeAppDataTyCon ty) of
733 Just (tycon, tys_applied, [data_con])
734 -> isNullaryDataCon data_con
742 SynTy tc _ _ -> hsep [ptext SLIT("The type synonym"), ppr sty tc, rest_of_msg]
743 TyVarTy tv -> hsep [ptext SLIT("The type variable"), ppr sty tv, rest_of_msg]
744 other -> sep [ptext SLIT("The type"), nest 4 (ppr sty ty), rest_of_msg]
746 rest_of_msg = ptext SLIT("cannot be used as an instance type")
748 instBndrErr bndr clas sty
749 = hsep [ptext SLIT("Class"), ppr sty clas, ptext SLIT("does not have a method"), ppr sty bndr]
751 derivingWhenInstanceExistsErr clas tycon sty
752 = hang (hsep [ptext SLIT("Deriving class"),
754 ptext SLIT("type"), ppr sty tycon])
755 4 (ptext SLIT("when an explicit instance exists"))
757 nonBoxedPrimCCallErr clas inst_ty sty
758 = hang (ptext SLIT("Unacceptable instance type for ccall-ish class"))
759 4 (hsep [ ptext SLIT("class"), ppr sty clas, ptext SLIT("type"),
762 omittedMethodWarn sel_id clas sty
763 = sep [ptext SLIT("No explicit method nor default method for") <+> ppr sty sel_id,
764 ptext SLIT("in an instance declaration for") <+> ppr sty clas]
766 instMethodNotInClassErr occ clas sty
767 = hang (ptext SLIT("Instance mentions a method not in the class"))
768 4 (hsep [ptext SLIT("class"), ppr sty clas, ptext SLIT("method"),
771 patMonoBindsCtxt pbind sty
772 = hang (ptext SLIT("In a pattern binding:"))
775 methodSigCtxt name ty sty
776 = hang (hsep [ptext SLIT("When matching the definition of class method"),
777 ppr sty name, ptext SLIT("to its signature :") ])
781 = ptext SLIT("When checking methods of an instance declaration")
783 superClassSigCtxt sty
784 = ptext SLIT("When checking superclass constraints of an instance declaration")