2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcInstDecls]{Typechecking instance declarations}
7 #include "HsVersions.h"
18 import HsSyn ( InstDecl(..), FixityDecl, Sig(..),
19 SpecInstSig(..), HsBinds(..), Bind(..),
20 MonoBinds(..), GRHSsAndBinds, Match,
21 InPat(..), OutPat(..), HsExpr(..), HsLit(..),
22 Stmt, Qualifier, ArithSeqInfo, Fake,
23 PolyType(..), MonoType )
24 import RnHsSyn ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedMonoBinds),
25 RenamedInstDecl(..), RenamedFixityDecl(..),
26 RenamedSig(..), RenamedSpecInstSig(..),
27 RnName(..){-incl instance Outputable-}
29 import TcHsSyn ( TcIdOcc(..), SYN_IE(TcHsBinds),
30 SYN_IE(TcMonoBinds), SYN_IE(TcExpr), tcIdType,
32 mkHsDictLam, mkHsDictApp )
35 import TcMonad hiding ( rnMtoTcM )
36 import GenSpecEtc ( checkSigTyVars )
37 import Inst ( Inst, InstOrigin(..), SYN_IE(InstanceMapper),
38 newDicts, newMethod, SYN_IE(LIE), emptyLIE, plusLIE )
39 import TcBinds ( tcPragmaSigs )
40 import TcDeriv ( tcDeriving )
41 import TcEnv ( tcLookupClass, tcTyVarScope, newLocalId, tcExtendGlobalTyVars )
42 import SpecEnv ( SpecEnv )
43 import TcGRHSs ( tcGRHSsAndBinds )
44 import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
45 import TcKind ( TcKind, unifyKind )
46 import TcMatches ( tcMatchesFun )
47 import TcMonoType ( tcContext, tcMonoTypeKind )
48 import TcSimplify ( tcSimplifyAndCheck )
49 import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet),
50 tcInstSigTyVars, tcInstType, tcInstTheta, tcInstTcType
52 import Unify ( unifyTauTy, unifyTauTyLists )
55 import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
56 concatBag, foldBag, bagToList )
57 import CmdLineOpts ( opt_GlasgowExts, opt_CompilingGhcInternals,
58 opt_OmitDefaultInstanceMethods,
59 opt_SpecialiseOverloaded
61 import Class ( GenClass, GenClassOp,
62 isCcallishClass, classBigSig,
63 classOps, classOpLocalType,
64 classOpTagByString_maybe
66 import Id ( GenId, idType, isDefaultMethodId_maybe )
67 import ListSetOps ( minusList )
68 import Maybes ( maybeToBool, expectJust )
69 import Name ( getLocalName, origName, nameOf, Name{--O only-} )
70 import PrelVals ( nO_EXPLICIT_METHOD_ERROR_ID )
71 import PrelMods ( pRELUDE )
72 import PprType ( GenType, GenTyVar, GenClass, GenClassOp, TyCon,
77 import RnUtils ( SYN_IE(RnEnv) )
78 import TyCon ( isSynTyCon, derivedFor )
79 import Type ( GenType(..), SYN_IE(ThetaType), mkTyVarTys,
80 splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy,
81 getTyCon_maybe, maybeBoxedPrimType, splitRhoTy, eqTy
83 import TyVar ( GenTyVar, SYN_IE(GenTyVarSet), mkTyVarSet, unionTyVarSets )
84 import TysWiredIn ( stringTy )
85 import Unique ( Unique )
86 import Util ( zipEqual, panic )
89 Typechecking instance declarations is done in two passes. The first
90 pass, made by @tcInstDecls1@, collects information to be used in the
93 This pre-processed info includes the as-yet-unprocessed bindings
94 inside the instance declaration. These are type-checked in the second
95 pass, when the class-instance envs and GVE contain all the info from
96 all the instance and value decls. Indeed that's the reason we need
97 two passes over the instance decls.
100 Here is the overall algorithm.
101 Assume that we have an instance declaration
103 instance c => k (t tvs) where b
107 $LIE_c$ is the LIE for the context of class $c$
109 $betas_bar$ is the free variables in the class method type, excluding the
112 $LIE_cop$ is the LIE constraining a particular class method
114 $tau_cop$ is the tau type of a class method
116 $LIE_i$ is the LIE for the context of instance $i$
118 $X$ is the instance constructor tycon
120 $gammas_bar$ is the set of type variables of the instance
122 $LIE_iop$ is the LIE for a particular class method instance
124 $tau_iop$ is the tau type for this instance of a class method
126 $alpha$ is the class variable
128 $LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
130 $tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
133 ToDo: Update the list above with names actually in the code.
137 First, make the LIEs for the class and instance contexts, which means
138 instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
139 and make LIElistI and LIEI.
141 Then process each method in turn.
143 order the instance methods according to the ordering of the class methods
145 express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
147 Create final dictionary function from bindings generated already
149 df = lambda inst_tyvars
156 in <op1,op2,...,opn,sd1,...,sdm>
158 Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
159 and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
163 tcInstDecls1 :: Bag RenamedInstDecl
164 -> [RenamedSpecInstSig]
165 -> Module -- module name for deriving
166 -> RnEnv -- for renaming derivings
167 -> [RenamedFixityDecl] -- fixities for deriving
168 -> TcM s (Bag InstInfo,
172 tcInstDecls1 inst_decls specinst_sigs mod_name rn_env fixities
173 = -- Do the ordinary instance declarations
174 mapBagNF_Tc (tcInstDecl1 mod_name) inst_decls
175 `thenNF_Tc` \ inst_info_bags ->
177 decl_inst_info = concatBag inst_info_bags
179 -- Handle "derived" instances; note that we only do derivings
180 -- for things in this module; we ignore deriving decls from
181 -- interfaces! We pass fixities, because they may be used
182 -- in deriving Read and Show.
183 tcDeriving mod_name rn_env decl_inst_info fixities
184 `thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) ->
187 inst_info = deriv_inst_info `unionBags` decl_inst_info
190 -- Handle specialise instance pragmas
191 tcSpecInstSigs inst_info specinst_sigs
192 `thenTc` \ spec_inst_info ->
195 spec_inst_info = emptyBag -- For now
197 full_inst_info = inst_info `unionBags` spec_inst_info
199 returnTc (full_inst_info, deriv_binds, ddump_deriv)
202 tcInstDecl1 :: FAST_STRING -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
206 poly_ty@(HsForAllTy tyvar_names context inst_ty)
208 from_here inst_mod uprags pragmas src_loc)
209 = -- Prime error recovery, set source location
210 recoverNF_Tc (returnNF_Tc emptyBag) $
211 tcAddSrcLoc src_loc $
214 tcLookupClass class_name `thenNF_Tc` \ (clas_kind, clas) ->
219 -- Typecheck the context and instance type
220 tcTyVarScope (map de_rn tyvar_names) (\ tyvars ->
221 tcContext context `thenTc` \ theta ->
222 tcMonoTypeKind inst_ty `thenTc` \ (tau_kind, tau) ->
223 unifyKind clas_kind tau_kind `thenTc_`
224 returnTc (tyvars, theta, tau)
225 ) `thenTc` \ (inst_tyvars, inst_theta, inst_tau) ->
227 -- Check for respectable instance type
228 scrutiniseInstanceType from_here clas inst_tau
229 `thenTc` \ (inst_tycon,arg_tys) ->
231 -- Deal with the case where we are deriving
232 -- and importing the same instance
233 if (not from_here && (clas `derivedFor` inst_tycon)
234 && all isTyVarTy arg_tys)
236 if mod_name == inst_mod
238 -- Imported instance came from this module;
239 -- discard and derive fresh instance
242 -- Imported instance declared in another module;
243 -- report duplicate instance error
244 failTc (derivingWhenInstanceImportedErr inst_mod clas inst_tycon)
247 -- Make the dfun id and constant-method ids
248 mkInstanceRelatedIds from_here src_loc inst_mod pragmas
249 clas inst_tyvars inst_tau inst_theta uprags
250 `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
252 returnTc (unitBag (InstInfo clas inst_tyvars inst_tau inst_theta
253 dfun_theta dfun_id const_meth_ids
254 binds from_here inst_mod src_loc uprags))
258 %************************************************************************
260 \subsection{Type-checking instance declarations, pass 2}
262 %************************************************************************
265 tcInstDecls2 :: Bag InstInfo
266 -> NF_TcM s (LIE s, TcHsBinds s)
268 tcInstDecls2 inst_decls
269 = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyBinds)) inst_decls
271 combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
272 tc2 `thenNF_Tc` \ (lie2, binds2) ->
273 returnNF_Tc (lie1 `plusLIE` lie2,
274 binds1 `ThenBinds` binds2)
278 ======= New documentation starts here (Sept 92) ==============
280 The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
281 the dictionary function for this instance declaration. For example
283 instance Foo a => Foo [a] where
287 might generate something like
289 dfun.Foo.List dFoo_a = let op1 x = ...
295 HOWEVER, if the instance decl has no context, then it returns a
296 bigger @HsBinds@ with declarations for each method. For example
298 instance Foo [a] where
304 dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
305 const.Foo.op1.List a x = ...
306 const.Foo.op2.List a y = ...
308 This group may be mutually recursive, because (for example) there may
309 be no method supplied for op2 in which case we'll get
311 const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
313 that is, the default method applied to the dictionary at this type.
315 What we actually produce in either case is:
317 AbsBinds [a] [dfun_theta_dicts]
318 [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
319 { d = (sd1,sd2, ..., op1, op2, ...)
324 The "maybe" says that we only ask AbsBinds to make global constant methods
325 if the dfun_theta is empty.
328 For an instance declaration, say,
330 instance (C1 a, C2 b) => C (T a b) where
333 where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
334 function whose type is
336 (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
338 Notice that we pass it the superclass dictionaries at the instance type; this
339 is the ``Mark Jones optimisation''. The stuff before the "=>" here
340 is the @dfun_theta@ below.
342 First comes the easy case of a non-local instance decl.
345 tcInstDecl2 :: InstInfo
346 -> NF_TcM s (LIE s, TcHsBinds s)
348 tcInstDecl2 (InstInfo _ _ _ _ _ _ _ _ False{-import-} _ _ _)
349 = returnNF_Tc (emptyLIE, EmptyBinds)
351 tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
352 inst_decl_theta dfun_theta
353 dfun_id const_meth_ids monobinds
354 True{-here-} inst_mod locn uprags)
355 = -- Prime error recovery
356 recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds)) $
359 -- Get the class signature
360 tcInstSigTyVars inst_tyvars `thenNF_Tc` \ (inst_tyvars', _, tenv) ->
363 super_classes, sc_sel_ids,
364 class_ops, op_sel_ids, defm_ids) = classBigSig clas
366 tcInstType tenv inst_ty `thenNF_Tc` \ inst_ty' ->
367 tcInstTheta tenv dfun_theta `thenNF_Tc` \ dfun_theta' ->
368 tcInstTheta tenv inst_decl_theta `thenNF_Tc` \ inst_decl_theta' ->
370 sc_theta' = super_classes `zip` repeat inst_ty'
371 origin = InstanceDeclOrigin
372 mk_method sel_id = newMethod origin (RealId sel_id) [inst_ty']
374 -- Create dictionary Ids from the specified instance contexts.
375 newDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) ->
376 newDicts origin dfun_theta' `thenNF_Tc` \ (dfun_arg_dicts, dfun_arg_dicts_ids) ->
377 newDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) ->
378 newDicts origin [(clas,inst_ty')] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
380 -- Create method variables
381 mapAndUnzipNF_Tc mk_method op_sel_ids `thenNF_Tc` \ (meth_insts_s, meth_ids) ->
383 -- Collect available Insts
385 inst_tyvars_set' = mkTyVarSet inst_tyvars'
387 avail_insts -- These insts are in scope; quite a few, eh?
388 = unionManyBags (this_dict : dfun_arg_dicts : meth_insts_s)
391 = if opt_OmitDefaultInstanceMethods then
392 makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty' clas inst_mod
394 makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty' this_dict_id
396 tcExtendGlobalTyVars inst_tyvars_set' (
397 processInstBinds clas mk_method_expr avail_insts meth_ids monobinds
398 ) `thenTc` \ (insts_needed, method_mbinds) ->
400 -- Create the dict and method binds
402 = VarMonoBind this_dict_id (Dictionary sc_dict_ids meth_ids)
404 dict_and_method_binds
405 = dict_bind `AndMonoBinds` method_mbinds
408 -- Check the overloading constraints of the methods and superclasses
409 tcAddErrCtxt (bindSigCtxt meth_ids) (
411 inst_tyvars_set' -- Local tyvars
413 (sc_dicts `unionBags` insts_needed) -- Need to get defns for all these
414 ) `thenTc` \ (const_lie, super_binds) ->
416 -- Check that we *could* construct the superclass dictionaries,
417 -- even though we are *actually* going to pass the superclass dicts in;
418 -- the check ensures that the caller will never have a problem building
420 tcAddErrCtxt superClassSigCtxt (
422 inst_tyvars_set' -- Local tyvars
423 inst_decl_dicts -- The instance dictionaries available
424 sc_dicts -- The superclass dicationaries reqd
426 -- Ignore the result; we're only doing
427 -- this to make sure it can be done.
429 -- Now process any SPECIALIZE pragmas for the methods
431 spec_sigs = [ s | s@(SpecSig _ _ _ _) <- uprags ]
433 tcPragmaSigs spec_sigs `thenTc` \ (_, spec_binds, spec_lie) ->
435 -- Complete the binding group, adding any spec_binds
440 ((this_dict_id, RealId dfun_id)
441 : (meth_ids `zip` map RealId const_meth_ids))
442 -- NB: const_meth_ids will often be empty
444 (RecBind dict_and_method_binds)
450 returnTc (const_lie `plusLIE` spec_lie, inst_binds)
453 The next function makes a default method which calls the global default method, at
454 the appropriate instance type.
456 See the notes under default decls in TcClassDcl.lhs.
459 makeInstanceDeclDefaultMethodExpr
466 -> NF_TcM s (TcExpr s)
468 makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty this_dict tag
470 -- def_op_id = defm_id inst_ty this_dict
471 returnNF_Tc (mkHsDictApp (mkHsTyApp (HsVar (RealId defm_id)) [inst_ty]) [this_dict])
474 meth_id = meth_ids !! idx
475 defm_id = defm_ids !! idx
477 makeInstanceDeclNoDefaultExpr
485 -> NF_TcM s (TcExpr s)
487 makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty clas inst_mod tag
489 -- Produce a warning if the default instance method
490 -- has been omitted when one exists in the class
491 warnTc (not err_defm_ok)
492 (omitDefaultMethodWarn clas_op clas_name inst_ty)
494 returnNF_Tc (HsApp (mkHsTyApp (HsVar (RealId nO_EXPLICIT_METHOD_ERROR_ID)) [tcIdType meth_id])
495 (HsLitOut (HsString (_PK_ error_msg)) stringTy))
498 meth_id = meth_ids !! idx
499 clas_op = (classOps clas) !! idx
500 defm_id = defm_ids !! idx
502 Just (_, _, err_defm_ok) = isDefaultMethodId_maybe defm_id
504 error_msg = _UNPK_ inst_mod ++ "." ++ _UNPK_ clas_name ++ "."
505 ++ (ppShow 80 (ppr PprForUser inst_ty)) ++ "."
506 ++ (ppShow 80 (ppr PprForUser clas_op)) ++ "\""
508 clas_name = nameOf (origName "makeInstanceDeclNoDefaultExpr" clas)
512 %************************************************************************
514 \subsection{Processing each method}
516 %************************************************************************
518 @processInstBinds@ returns a @MonoBinds@ which binds
519 all the method ids (which are passed in). It is used
520 - both for instance decls,
521 - and to compile the default-method declarations in a class decl.
523 Any method ids which don't have a binding have a suitable default
524 binding created for them. The actual right-hand side used is
525 created using a function which is passed in, because the right thing to
526 do differs between instance and class decls.
531 -> (Int -> NF_TcM s (TcExpr s)) -- Function to make default method
532 -> LIE s -- available Insts
533 -> [TcIdOcc s] -- Local method ids in tag order
534 -- (instance tyvars are free in their types)
536 -> TcM s (LIE s, -- These are required
539 processInstBinds clas mk_default_method_rhs avail_insts method_ids monobinds
541 -- Process the explicitly-given method bindings
542 processInstBinds1 clas avail_insts method_ids monobinds
543 `thenTc` \ (tags, insts_needed_in_methods, method_binds) ->
545 -- Find the methods not handled, and make default method bindings for them.
547 unmentioned_tags = [1.. length method_ids] `minusList` tags
549 mapNF_Tc mk_default_method unmentioned_tags
550 `thenNF_Tc` \ default_bind_list ->
552 returnTc (insts_needed_in_methods,
553 foldr AndMonoBinds method_binds default_bind_list)
555 -- From a tag construct us the passed-in function to construct
556 -- the binding for the default method
557 mk_default_method tag = mk_default_method_rhs tag `thenNF_Tc` \ rhs ->
558 returnNF_Tc (VarMonoBind (method_ids !! (tag-1)) rhs)
564 -> LIE s -- available Insts
565 -> [TcIdOcc s] -- Local method ids in tag order (instance tyvars are free),
567 -> TcM s ([Int], -- Class-op tags accounted for
568 LIE s, -- These are required
571 processInstBinds1 clas avail_insts method_ids EmptyMonoBinds
572 = returnTc ([], emptyLIE, EmptyMonoBinds)
574 processInstBinds1 clas avail_insts method_ids (AndMonoBinds mb1 mb2)
575 = processInstBinds1 clas avail_insts method_ids mb1
576 `thenTc` \ (op_tags1,dicts1,method_binds1) ->
577 processInstBinds1 clas avail_insts method_ids mb2
578 `thenTc` \ (op_tags2,dicts2,method_binds2) ->
579 returnTc (op_tags1 ++ op_tags2,
580 dicts1 `unionBags` dicts2,
581 AndMonoBinds method_binds1 method_binds2)
585 processInstBinds1 clas avail_insts method_ids mbind
587 -- Find what class op is being defined here. The complication is
588 -- that we could have a PatMonoBind or a FunMonoBind. If the
589 -- former, it should only bind a single variable, or else we're in
590 -- trouble (I'm not sure what the static semantics of methods
591 -- defined in a pattern binding with multiple patterns is!)
592 -- Renamer has reduced us to these two cases.
594 (op,locn) = case mbind of
595 FunMonoBind op _ _ locn -> (op, locn)
596 PatMonoBind (VarPatIn op) _ locn -> (op, locn)
598 occ = getLocalName op
599 origin = InstanceDeclOrigin
603 -- Make a method id for the method
605 maybe_tag = classOpTagByString_maybe clas occ
606 (Just tag) = maybe_tag
607 method_id = method_ids !! (tag-1)
608 method_ty = tcIdType method_id
610 -- check that the method mentioned is actually in the class:
611 checkMaybeTc maybe_tag (instMethodNotInClassErr occ clas) `thenTc_`
613 tcInstTcType method_ty `thenNF_Tc` \ (method_tyvars, method_rho) ->
615 (method_theta, method_tau) = splitRhoTy method_rho
617 newDicts origin method_theta `thenNF_Tc` \ (method_dicts,method_dict_ids) ->
619 case (method_tyvars, method_dict_ids) of
621 ([],[]) -> -- The simple case; no local polymorphism or overloading in the method
623 -- Type check the method itself
624 tcMethodBind method_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
625 returnTc ([tag], lieIop, mbind')
627 other -> -- It's a locally-polymorphic and/or overloaded method; UGH!
629 -- Make a new id for (a) the local, non-overloaded method
630 -- and (b) the locally-overloaded method
631 -- The latter is needed just so we can return an AbsBinds wrapped
632 -- up inside a MonoBinds.
635 -- Make the method_tyvars into signature tyvars so they
636 -- won't get unified with anything.
637 tcInstSigTyVars method_tyvars `thenNF_Tc` \ (sig_tyvars, sig_tyvar_tys, _) ->
638 unifyTauTyLists sig_tyvar_tys (mkTyVarTys method_tyvars) `thenTc_`
640 newLocalId occ method_tau `thenNF_Tc` \ local_id ->
641 newLocalId occ method_ty `thenNF_Tc` \ copy_id ->
643 sig_tyvar_set = mkTyVarSet sig_tyvars
645 -- Typecheck the method
646 tcMethodBind local_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
648 -- Check the overloading part of the signature.
650 -- =========== POSSIBLE BUT NOT DONE =================
651 -- Simplify everything fully, even though some
652 -- constraints could "really" be left to the next
653 -- level out. The case which forces this is
655 -- class Foo a where { op :: Bar a => a -> a }
657 -- Here we must simplify constraints on "a" to catch all
658 -- the Bar-ish things.
660 -- We don't do this because it's currently illegal Haskell (not sure why),
661 -- and because the local type of the method would have a context at
662 -- the front with no for-all, which confuses the hell out of everything!
663 -- ====================================================
665 tcAddErrCtxt (methodSigCtxt op method_ty) (
667 sig_tyvars method_tau `thenTc_`
671 (method_dicts `plusLIE` avail_insts)
673 ) `thenTc` \ (f_dicts, dict_binds) ->
678 VarMonoBind method_id
683 [(local_id, copy_id)]
690 tcMethodBind :: TcIdOcc s -> TcType s -> RenamedMonoBinds
691 -> TcM s (TcMonoBinds s, LIE s)
693 tcMethodBind meth_id meth_ty (FunMonoBind name inf matches locn)
694 = tcMatchesFun name meth_ty matches `thenTc` \ (rhs', lie) ->
695 returnTc (FunMonoBind meth_id inf rhs' locn, lie)
697 tcMethodBind meth_id meth_ty pbind@(PatMonoBind pat grhss_and_binds locn)
698 -- pat is sure to be a (VarPatIn op)
699 = tcAddErrCtxt (patMonoBindsCtxt pbind) $
700 tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds', lie, rhs_ty) ->
701 unifyTauTy meth_ty rhs_ty `thenTc_`
702 returnTc (PatMonoBind (VarPat meth_id) grhss_and_binds' locn, lie)
706 %************************************************************************
708 \subsection{Type-checking specialise instance pragmas}
710 %************************************************************************
714 tcSpecInstSigs :: E -> CE -> TCE
715 -> Bag InstInfo -- inst decls seen (declared and derived)
716 -> [RenamedSpecInstSig] -- specialise instance upragmas
717 -> TcM (Bag InstInfo) -- new, overlapped, inst decls
719 tcSpecInstSigs e ce tce inst_infos []
722 tcSpecInstSigs e ce tce inst_infos sigs
723 = buildInstanceEnvs inst_infos `thenTc` \ inst_mapper ->
724 tc_inst_spec_sigs inst_mapper sigs `thenNF_Tc` \ spec_inst_infos ->
725 returnTc spec_inst_infos
727 tc_inst_spec_sigs inst_mapper []
728 = returnNF_Tc emptyBag
729 tc_inst_spec_sigs inst_mapper (sig:sigs)
730 = tcSpecInstSig e ce tce inst_infos inst_mapper sig `thenNF_Tc` \ info_sig ->
731 tc_inst_spec_sigs inst_mapper sigs `thenNF_Tc` \ info_sigs ->
732 returnNF_Tc (info_sig `unionBags` info_sigs)
734 tcSpecInstSig :: E -> CE -> TCE
737 -> RenamedSpecInstSig
738 -> NF_TcM (Bag InstInfo)
740 tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc)
741 = recoverTc emptyBag (
742 tcAddSrcLoc src_loc (
744 clas = lookupCE ce class_name -- Renamer ensures this can't fail
746 -- Make some new type variables, named as in the specialised instance type
747 ty_names = extractMonoTyNames ???is_tyvarish_name??? ty
748 (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names
750 babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
751 `thenTc` \ inst_ty ->
753 maybe_tycon = case maybeAppDataTyCon inst_ty of
754 Just (tc,_,_) -> Just tc
757 maybe_unspec_inst = lookup_unspec_inst clas maybe_tycon inst_infos
759 -- Check that we have a local instance declaration to specialise
760 checkMaybeTc maybe_unspec_inst
761 (specInstUnspecInstNotFoundErr clas inst_ty src_loc) `thenTc_`
763 -- Create tvs to substitute for tmpls while simplifying the context
764 copyTyVars inst_tmpls `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) ->
766 Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta
767 _ _ _ binds True{-from here-} mod _ uprag) = maybe_unspec_inst
769 subst = case matchTy unspec_inst_ty inst_ty of
771 Nothing -> panic "tcSpecInstSig:matchTy"
773 subst_theta = instantiateThetaTy subst unspec_theta
774 subst_tv_theta = instantiateThetaTy tv_e subst_theta
776 mk_spec_origin clas ty
777 = InstanceSpecOrigin inst_mapper clas ty src_loc
778 -- I'm VERY SUSPICIOUS ABOUT THIS
779 -- the inst-mapper is in a knot at this point so it's no good
780 -- looking at it in tcSimplify...
782 tcSimplifyThetas mk_spec_origin subst_tv_theta
783 `thenTc` \ simpl_tv_theta ->
785 simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ]
787 tv_tmpl_map = zipEqual "tcSpecInstSig" inst_tv_tys inst_tmpl_tys
788 tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv
790 mkInstanceRelatedIds e True{-from here-} src_loc mod NoInstancePragmas
791 clas inst_tmpls inst_ty simpl_theta uprag
792 `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
794 getSwitchCheckerTc `thenNF_Tc` \ sw_chkr ->
795 (if sw_chkr SpecialiseTrace then
796 pprTrace "Specialised Instance: "
797 (ppAboves [ppCat [if null simpl_theta then ppNil else ppr PprDebug simpl_theta,
798 if null simpl_theta then ppNil else ppStr "=>",
800 pprParendGenType PprDebug inst_ty],
801 ppCat [ppStr " derived from:",
802 if null unspec_theta then ppNil else ppr PprDebug unspec_theta,
803 if null unspec_theta then ppNil else ppStr "=>",
805 pprParendGenType PprDebug unspec_inst_ty]])
808 returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
809 dfun_theta dfun_id const_meth_ids
810 binds True{-from here-} mod src_loc uprag))
814 lookup_unspec_inst clas maybe_tycon inst_infos
815 = case filter (match_info match_inst_ty) (bagToList inst_infos) of
817 (info:_) -> Just info
819 match_info match_ty (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _)
820 = from_here && clas == inst_clas &&
821 match_ty inst_ty && is_plain_instance inst_ty
823 match_inst_ty = case maybe_tycon of
824 Just tycon -> match_tycon tycon
827 match_tycon tycon inst_ty = case (maybeAppDataTyCon inst_ty) of
828 Just (inst_tc,_,_) -> tycon == inst_tc
831 match_fun inst_ty = isFunType inst_ty
834 is_plain_instance inst_ty
835 = case (maybeAppDataTyCon inst_ty) of
836 Just (_,tys,_) -> all isTyVarTemplateTy tys
837 Nothing -> case maybeUnpackFunTy inst_ty of
838 Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res
839 Nothing -> error "TcInstDecls:is_plain_instance"
844 Checking for a decent instance type
845 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
846 @scrutiniseInstanceType@ checks the type {\em and} its syntactic constraints:
847 it must normally look like: @instance Foo (Tycon a b c ...) ...@
849 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
850 flag is on, or (2)~the instance is imported (they must have been
851 compiled elsewhere). In these cases, we let them go through anyway.
853 We can also have instances for functions: @instance Foo (a -> b) ...@.
856 scrutiniseInstanceType from_here clas inst_tau
858 | not (maybeToBool inst_tycon_maybe) || isSynTyCon inst_tycon
859 = failTc (instTypeErr inst_tau)
861 -- IMPORTED INSTANCES ARE OK (but see tcInstDecl1)
863 = returnTc (inst_tycon,arg_tys)
866 | not (all isTyVarTy arg_tys ||
868 = failTc (instTypeErr inst_tau)
871 -- It is obviously illegal to have an explicit instance
872 -- for something that we are also planning to `derive'
873 -- Though we can have an explicit instance which is more
874 -- specific than the derived instance
875 | clas `derivedFor` inst_tycon
876 && all isTyVarTy arg_tys
877 = failTc (derivingWhenInstanceExistsErr clas inst_tycon)
880 -- A user declaration of a CCallable/CReturnable instance
881 -- must be for a "boxed primitive" type.
883 && not (maybeToBool (maybeBoxedPrimType inst_tau)
884 || opt_CompilingGhcInternals) -- this lets us get up to mischief;
885 -- e.g., instance CCallable ()
886 = failTc (nonBoxedPrimCCallErr clas inst_tau)
889 = returnTc (inst_tycon,arg_tys)
892 (possible_tycon, arg_tys) = splitAppTy inst_tau
893 inst_tycon_maybe = getTyCon_maybe possible_tycon
894 inst_tycon = expectJust "tcInstDecls1:inst_tycon" inst_tycon_maybe
901 SynTy tc _ _ -> ppBesides [ppStr "The type synonym `", ppr sty tc, rest_of_msg]
902 TyVarTy tv -> ppBesides [ppStr "The type variable `", ppr sty tv, rest_of_msg]
903 other -> ppBesides [ppStr "The type `", ppr sty ty, rest_of_msg]
905 rest_of_msg = ppStr "' cannot be used as an instance type."
907 derivingWhenInstanceExistsErr clas tycon sty
908 = ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"])
909 4 (ppStr "when an explicit instance exists")
911 derivingWhenInstanceImportedErr inst_mod clas tycon sty
912 = ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"])
913 4 (ppBesides [ppStr "when an instance declared in module `", pp_mod, ppStr "' has been imported"])
915 pp_mod = ppBesides [ppStr "module `", ppPStr inst_mod, ppStr "'"]
917 nonBoxedPrimCCallErr clas inst_ty sty
918 = ppHang (ppStr "Instance isn't for a `boxed-primitive' type")
919 4 (ppBesides [ ppStr "class `", ppr sty clas, ppStr "' type `",
920 ppr sty inst_ty, ppStr "'"])
922 omitDefaultMethodWarn clas_op clas_name inst_ty sty
923 = ppCat [ppStr "Warning: Omitted default method for",
924 ppr sty clas_op, ppStr "in instance",
925 ppPStr clas_name, pprParendGenType sty inst_ty]
927 instMethodNotInClassErr occ clas sty
928 = ppHang (ppStr "Instance mentions a method not in the class")
929 4 (ppBesides [ppStr "class `", ppr sty clas, ppStr "' method `",
930 ppPStr occ, ppStr "'"])
932 patMonoBindsCtxt pbind sty
933 = ppHang (ppStr "In a pattern binding:")
936 methodSigCtxt name ty sty
937 = ppHang (ppBesides [ppStr "When matching the definition of class method `",
938 ppr sty name, ppStr "' to its signature :" ])
941 bindSigCtxt method_ids sty
942 = ppHang (ppStr "When checking type signatures for: ")
943 4 (ppInterleave (ppStr ", ") (map (ppr sty) method_ids))
945 superClassSigCtxt sty
946 = ppStr "When checking superclass constraints on instance declaration"