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 TcGRHSs ( tcGRHSsAndBinds )
43 import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
44 import TcKind ( TcKind, unifyKind )
45 import TcMatches ( tcMatchesFun )
46 import TcMonoType ( tcContext, tcMonoTypeKind )
47 import TcSimplify ( tcSimplifyAndCheck )
48 import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet),
49 tcInstSigTyVars, tcInstType, tcInstTheta, tcInstTcType
51 import Unify ( unifyTauTy, unifyTauTyLists )
54 import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
55 concatBag, foldBag, bagToList )
56 import CmdLineOpts ( opt_GlasgowExts, opt_CompilingGhcInternals,
57 opt_OmitDefaultInstanceMethods,
58 opt_SpecialiseOverloaded
60 import Class ( GenClass, GenClassOp,
61 isCcallishClass, classBigSig,
62 classOps, classOpLocalType,
65 import Id ( GenId, idType, isDefaultMethodId_maybe )
66 import ListSetOps ( minusList )
67 import Maybes ( maybeToBool, expectJust )
68 import Name ( getLocalName, origName, nameOf, Name{--O only-} )
69 import PrelVals ( nO_EXPLICIT_METHOD_ERROR_ID )
70 import PrelMods ( pRELUDE )
71 import PprType ( GenType, GenTyVar, GenClass, GenClassOp, TyCon,
76 import RnUtils ( SYN_IE(RnEnv) )
77 import TyCon ( isSynTyCon, derivedFor )
78 import Type ( GenType(..), SYN_IE(ThetaType), mkTyVarTys,
79 splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy,
80 getTyCon_maybe, maybeBoxedPrimType, splitRhoTy, eqTy
82 import TyVar ( GenTyVar, GenTyVarSet(..), mkTyVarSet, unionTyVarSets )
83 import TysWiredIn ( stringTy )
84 import Unique ( Unique )
85 import Util ( zipEqual, panic )
88 Typechecking instance declarations is done in two passes. The first
89 pass, made by @tcInstDecls1@, collects information to be used in the
92 This pre-processed info includes the as-yet-unprocessed bindings
93 inside the instance declaration. These are type-checked in the second
94 pass, when the class-instance envs and GVE contain all the info from
95 all the instance and value decls. Indeed that's the reason we need
96 two passes over the instance decls.
99 Here is the overall algorithm.
100 Assume that we have an instance declaration
102 instance c => k (t tvs) where b
106 $LIE_c$ is the LIE for the context of class $c$
108 $betas_bar$ is the free variables in the class method type, excluding the
111 $LIE_cop$ is the LIE constraining a particular class method
113 $tau_cop$ is the tau type of a class method
115 $LIE_i$ is the LIE for the context of instance $i$
117 $X$ is the instance constructor tycon
119 $gammas_bar$ is the set of type variables of the instance
121 $LIE_iop$ is the LIE for a particular class method instance
123 $tau_iop$ is the tau type for this instance of a class method
125 $alpha$ is the class variable
127 $LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
129 $tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
132 ToDo: Update the list above with names actually in the code.
136 First, make the LIEs for the class and instance contexts, which means
137 instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
138 and make LIElistI and LIEI.
140 Then process each method in turn.
142 order the instance methods according to the ordering of the class methods
144 express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
146 Create final dictionary function from bindings generated already
148 df = lambda inst_tyvars
155 in <op1,op2,...,opn,sd1,...,sdm>
157 Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
158 and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
162 tcInstDecls1 :: Bag RenamedInstDecl
163 -> [RenamedSpecInstSig]
164 -> Module -- module name for deriving
165 -> RnEnv -- for renaming derivings
166 -> [RenamedFixityDecl] -- fixities for deriving
167 -> TcM s (Bag InstInfo,
171 tcInstDecls1 inst_decls specinst_sigs mod_name rn_env fixities
172 = -- Do the ordinary instance declarations
173 mapBagNF_Tc (tcInstDecl1 mod_name) inst_decls
174 `thenNF_Tc` \ inst_info_bags ->
176 decl_inst_info = concatBag inst_info_bags
178 -- Handle "derived" instances; note that we only do derivings
179 -- for things in this module; we ignore deriving decls from
180 -- interfaces! We pass fixities, because they may be used
181 -- in deriving Read and Show.
182 tcDeriving mod_name rn_env decl_inst_info fixities
183 `thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) ->
186 inst_info = deriv_inst_info `unionBags` decl_inst_info
189 -- Handle specialise instance pragmas
190 tcSpecInstSigs inst_info specinst_sigs
191 `thenTc` \ spec_inst_info ->
194 spec_inst_info = emptyBag -- For now
196 full_inst_info = inst_info `unionBags` spec_inst_info
198 returnTc (full_inst_info, deriv_binds, ddump_deriv)
201 tcInstDecl1 :: FAST_STRING -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
205 poly_ty@(HsForAllTy tyvar_names context inst_ty)
207 from_here inst_mod uprags pragmas src_loc)
208 = -- Prime error recovery, set source location
209 recoverNF_Tc (returnNF_Tc emptyBag) $
210 tcAddSrcLoc src_loc $
213 tcLookupClass class_name `thenNF_Tc` \ (clas_kind, clas) ->
218 -- Typecheck the context and instance type
219 tcTyVarScope (map de_rn tyvar_names) (\ tyvars ->
220 tcContext context `thenTc` \ theta ->
221 tcMonoTypeKind inst_ty `thenTc` \ (tau_kind, tau) ->
222 unifyKind clas_kind tau_kind `thenTc_`
223 returnTc (tyvars, theta, tau)
224 ) `thenTc` \ (inst_tyvars, inst_theta, inst_tau) ->
226 -- Check for respectable instance type
227 scrutiniseInstanceType from_here clas inst_tau
228 `thenTc` \ (inst_tycon,arg_tys) ->
230 -- Deal with the case where we are deriving
231 -- and importing the same instance
232 if (not from_here && (clas `derivedFor` inst_tycon)
233 && all isTyVarTy arg_tys)
235 if mod_name == inst_mod
237 -- Imported instance came from this module;
238 -- discard and derive fresh instance
241 -- Imported instance declared in another module;
242 -- report duplicate instance error
243 failTc (derivingWhenInstanceImportedErr inst_mod clas inst_tycon)
246 -- Make the dfun id and constant-method ids
247 mkInstanceRelatedIds from_here src_loc inst_mod pragmas
248 clas inst_tyvars inst_tau inst_theta uprags
249 `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
251 returnTc (unitBag (InstInfo clas inst_tyvars inst_tau inst_theta
252 dfun_theta dfun_id const_meth_ids
253 binds from_here inst_mod src_loc uprags))
257 %************************************************************************
259 \subsection{Type-checking instance declarations, pass 2}
261 %************************************************************************
264 tcInstDecls2 :: Bag InstInfo
265 -> NF_TcM s (LIE s, TcHsBinds s)
267 tcInstDecls2 inst_decls
268 = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyBinds)) inst_decls
270 combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
271 tc2 `thenNF_Tc` \ (lie2, binds2) ->
272 returnNF_Tc (lie1 `plusLIE` lie2,
273 binds1 `ThenBinds` binds2)
277 ======= New documentation starts here (Sept 92) ==============
279 The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
280 the dictionary function for this instance declaration. For example
282 instance Foo a => Foo [a] where
286 might generate something like
288 dfun.Foo.List dFoo_a = let op1 x = ...
294 HOWEVER, if the instance decl has no context, then it returns a
295 bigger @HsBinds@ with declarations for each method. For example
297 instance Foo [a] where
303 dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
304 const.Foo.op1.List a x = ...
305 const.Foo.op2.List a y = ...
307 This group may be mutually recursive, because (for example) there may
308 be no method supplied for op2 in which case we'll get
310 const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
312 that is, the default method applied to the dictionary at this type.
314 What we actually produce in either case is:
316 AbsBinds [a] [dfun_theta_dicts]
317 [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
318 { d = (sd1,sd2, ..., op1, op2, ...)
323 The "maybe" says that we only ask AbsBinds to make global constant methods
324 if the dfun_theta is empty.
327 For an instance declaration, say,
329 instance (C1 a, C2 b) => C (T a b) where
332 where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
333 function whose type is
335 (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
337 Notice that we pass it the superclass dictionaries at the instance type; this
338 is the ``Mark Jones optimisation''. The stuff before the "=>" here
339 is the @dfun_theta@ below.
341 First comes the easy case of a non-local instance decl.
344 tcInstDecl2 :: InstInfo
345 -> NF_TcM s (LIE s, TcHsBinds s)
347 tcInstDecl2 (InstInfo _ _ _ _ _ _ _ _ False{-import-} _ _ _)
348 = returnNF_Tc (emptyLIE, EmptyBinds)
350 tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
351 inst_decl_theta dfun_theta
352 dfun_id const_meth_ids monobinds
353 True{-here-} inst_mod locn uprags)
354 = -- Prime error recovery
355 recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds)) $
358 -- Get the class signature
359 tcInstSigTyVars inst_tyvars `thenNF_Tc` \ (inst_tyvars', _, tenv) ->
362 super_classes, sc_sel_ids,
363 class_ops, op_sel_ids, defm_ids) = classBigSig clas
365 tcInstType tenv inst_ty `thenNF_Tc` \ inst_ty' ->
366 tcInstTheta tenv dfun_theta `thenNF_Tc` \ dfun_theta' ->
367 tcInstTheta tenv inst_decl_theta `thenNF_Tc` \ inst_decl_theta' ->
369 sc_theta' = super_classes `zip` repeat inst_ty'
370 origin = InstanceDeclOrigin
371 mk_method sel_id = newMethod origin (RealId sel_id) [inst_ty']
373 -- Create dictionary Ids from the specified instance contexts.
374 newDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) ->
375 newDicts origin dfun_theta' `thenNF_Tc` \ (dfun_arg_dicts, dfun_arg_dicts_ids) ->
376 newDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) ->
377 newDicts origin [(clas,inst_ty')] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
379 -- Create method variables
380 mapAndUnzipNF_Tc mk_method op_sel_ids `thenNF_Tc` \ (meth_insts_s, meth_ids) ->
382 -- Collect available Insts
384 inst_tyvars_set' = mkTyVarSet inst_tyvars'
386 avail_insts -- These insts are in scope; quite a few, eh?
387 = unionManyBags (this_dict : dfun_arg_dicts : meth_insts_s)
390 = if opt_OmitDefaultInstanceMethods then
391 makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty' clas inst_mod
393 makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty' this_dict_id
395 tcExtendGlobalTyVars inst_tyvars_set' (
396 processInstBinds clas mk_method_expr avail_insts meth_ids monobinds
397 ) `thenTc` \ (insts_needed, method_mbinds) ->
399 -- Create the dict and method binds
401 = VarMonoBind this_dict_id (Dictionary sc_dict_ids meth_ids)
403 dict_and_method_binds
404 = dict_bind `AndMonoBinds` method_mbinds
407 -- Check the overloading constraints of the methods and superclasses
408 tcAddErrCtxt (bindSigCtxt meth_ids) (
410 inst_tyvars_set' -- Local tyvars
412 (sc_dicts `unionBags` insts_needed) -- Need to get defns for all these
413 ) `thenTc` \ (const_lie, super_binds) ->
415 -- Check that we *could* construct the superclass dictionaries,
416 -- even though we are *actually* going to pass the superclass dicts in;
417 -- the check ensures that the caller will never have a problem building
419 tcAddErrCtxt superClassSigCtxt (
421 inst_tyvars_set' -- Local tyvars
422 inst_decl_dicts -- The instance dictionaries available
423 sc_dicts -- The superclass dicationaries reqd
425 -- Ignore the result; we're only doing
426 -- this to make sure it can be done.
428 -- Now process any SPECIALIZE pragmas for the methods
430 spec_sigs = [ s | s@(SpecSig _ _ _ _) <- uprags ]
432 tcPragmaSigs spec_sigs `thenTc` \ (_, spec_binds, spec_lie) ->
434 -- Complete the binding group, adding any spec_binds
439 ((this_dict_id, RealId dfun_id)
440 : (meth_ids `zip` map RealId const_meth_ids))
441 -- NB: const_meth_ids will often be empty
443 (RecBind dict_and_method_binds)
449 returnTc (const_lie `plusLIE` spec_lie, inst_binds)
452 The next function makes a default method which calls the global default method, at
453 the appropriate instance type.
455 See the notes under default decls in TcClassDcl.lhs.
458 makeInstanceDeclDefaultMethodExpr
465 -> NF_TcM s (TcExpr s)
467 makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty this_dict tag
469 -- def_op_id = defm_id inst_ty this_dict
470 returnNF_Tc (mkHsDictApp (mkHsTyApp (HsVar (RealId defm_id)) [inst_ty]) [this_dict])
473 meth_id = meth_ids !! idx
474 defm_id = defm_ids !! idx
476 makeInstanceDeclNoDefaultExpr
484 -> NF_TcM s (TcExpr s)
486 makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty clas inst_mod tag
488 -- Produce a warning if the default instance method
489 -- has been omitted when one exists in the class
490 warnTc (not err_defm_ok)
491 (omitDefaultMethodWarn clas_op clas_name inst_ty)
493 returnNF_Tc (HsApp (mkHsTyApp (HsVar (RealId nO_EXPLICIT_METHOD_ERROR_ID)) [tcIdType meth_id])
494 (HsLitOut (HsString (_PK_ error_msg)) stringTy))
497 meth_id = meth_ids !! idx
498 clas_op = (classOps clas) !! idx
499 defm_id = defm_ids !! idx
501 Just (_, _, err_defm_ok) = isDefaultMethodId_maybe defm_id
503 error_msg = _UNPK_ inst_mod ++ "." ++ _UNPK_ clas_name ++ "."
504 ++ (ppShow 80 (ppr PprForUser inst_ty)) ++ "."
505 ++ (ppShow 80 (ppr PprForUser clas_op)) ++ "\""
507 clas_name = nameOf (origName "makeInstanceDeclNoDefaultExpr" clas)
511 %************************************************************************
513 \subsection{Processing each method}
515 %************************************************************************
517 @processInstBinds@ returns a @MonoBinds@ which binds
518 all the method ids (which are passed in). It is used
519 - both for instance decls,
520 - and to compile the default-method declarations in a class decl.
522 Any method ids which don't have a binding have a suitable default
523 binding created for them. The actual right-hand side used is
524 created using a function which is passed in, because the right thing to
525 do differs between instance and class decls.
530 -> (Int -> NF_TcM s (TcExpr s)) -- Function to make default method
531 -> LIE s -- available Insts
532 -> [TcIdOcc s] -- Local method ids in tag order
533 -- (instance tyvars are free in their types)
535 -> TcM s (LIE s, -- These are required
538 processInstBinds clas mk_default_method_rhs avail_insts method_ids monobinds
540 -- Process the explicitly-given method bindings
541 processInstBinds1 clas avail_insts method_ids monobinds
542 `thenTc` \ (tags, insts_needed_in_methods, method_binds) ->
544 -- Find the methods not handled, and make default method bindings for them.
546 unmentioned_tags = [1.. length method_ids] `minusList` tags
548 mapNF_Tc mk_default_method unmentioned_tags
549 `thenNF_Tc` \ default_bind_list ->
551 returnTc (insts_needed_in_methods,
552 foldr AndMonoBinds method_binds default_bind_list)
554 -- From a tag construct us the passed-in function to construct
555 -- the binding for the default method
556 mk_default_method tag = mk_default_method_rhs tag `thenNF_Tc` \ rhs ->
557 returnNF_Tc (VarMonoBind (method_ids !! (tag-1)) rhs)
563 -> LIE s -- available Insts
564 -> [TcIdOcc s] -- Local method ids in tag order (instance tyvars are free),
566 -> TcM s ([Int], -- Class-op tags accounted for
567 LIE s, -- These are required
570 processInstBinds1 clas avail_insts method_ids EmptyMonoBinds
571 = returnTc ([], emptyLIE, EmptyMonoBinds)
573 processInstBinds1 clas avail_insts method_ids (AndMonoBinds mb1 mb2)
574 = processInstBinds1 clas avail_insts method_ids mb1
575 `thenTc` \ (op_tags1,dicts1,method_binds1) ->
576 processInstBinds1 clas avail_insts method_ids mb2
577 `thenTc` \ (op_tags2,dicts2,method_binds2) ->
578 returnTc (op_tags1 ++ op_tags2,
579 dicts1 `unionBags` dicts2,
580 AndMonoBinds method_binds1 method_binds2)
584 processInstBinds1 clas avail_insts method_ids mbind
586 -- Find what class op is being defined here. The complication is
587 -- that we could have a PatMonoBind or a FunMonoBind. If the
588 -- former, it should only bind a single variable, or else we're in
589 -- trouble (I'm not sure what the static semantics of methods
590 -- defined in a pattern binding with multiple patterns is!)
591 -- Renamer has reduced us to these two cases.
593 (op,locn) = case mbind of
594 FunMonoBind op _ _ locn -> (op, locn)
595 PatMonoBind (VarPatIn op) _ locn -> (op, locn)
597 occ = getLocalName op
598 origin = InstanceDeclOrigin
602 -- Make a method id for the method
604 tag = classOpTagByString clas occ
605 method_id = method_ids !! (tag-1)
606 method_ty = tcIdType method_id
609 tcInstTcType method_ty `thenNF_Tc` \ (method_tyvars, method_rho) ->
611 (method_theta, method_tau) = splitRhoTy method_rho
613 newDicts origin method_theta `thenNF_Tc` \ (method_dicts,method_dict_ids) ->
615 case (method_tyvars, method_dict_ids) of
617 ([],[]) -> -- The simple case; no local polymorphism or overloading in the method
619 -- Type check the method itself
620 tcMethodBind method_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
621 returnTc ([tag], lieIop, mbind')
623 other -> -- It's a locally-polymorphic and/or overloaded method; UGH!
625 -- Make a new id for (a) the local, non-overloaded method
626 -- and (b) the locally-overloaded method
627 -- The latter is needed just so we can return an AbsBinds wrapped
628 -- up inside a MonoBinds.
631 -- Make the method_tyvars into signature tyvars so they
632 -- won't get unified with anything.
633 tcInstSigTyVars method_tyvars `thenNF_Tc` \ (sig_tyvars, sig_tyvar_tys, _) ->
634 unifyTauTyLists (mkTyVarTys method_tyvars) sig_tyvar_tys `thenTc_`
636 newLocalId occ method_tau `thenNF_Tc` \ local_id ->
637 newLocalId occ method_ty `thenNF_Tc` \ copy_id ->
639 sig_tyvar_set = mkTyVarSet sig_tyvars
641 -- Typecheck the method
642 tcMethodBind local_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
644 -- Check the overloading part of the signature.
646 -- =========== POSSIBLE BUT NOT DONE =================
647 -- Simplify everything fully, even though some
648 -- constraints could "really" be left to the next
649 -- level out. The case which forces this is
651 -- class Foo a where { op :: Bar a => a -> a }
653 -- Here we must simplify constraints on "a" to catch all
654 -- the Bar-ish things.
656 -- We don't do this because it's currently illegal Haskell (not sure why),
657 -- and because the local type of the method would have a context at
658 -- the front with no for-all, which confuses the hell out of everything!
659 -- ====================================================
661 tcAddErrCtxt (methodSigCtxt op method_ty) (
663 sig_tyvars method_tau `thenTc_`
667 (method_dicts `plusLIE` avail_insts)
669 ) `thenTc` \ (f_dicts, dict_binds) ->
674 VarMonoBind method_id
679 [(local_id, copy_id)]
686 tcMethodBind :: TcIdOcc s -> TcType s -> RenamedMonoBinds
687 -> TcM s (TcMonoBinds s, LIE s)
689 tcMethodBind meth_id meth_ty (FunMonoBind name inf matches locn)
690 = tcMatchesFun name meth_ty matches `thenTc` \ (rhs', lie) ->
691 returnTc (FunMonoBind meth_id inf rhs' locn, lie)
693 tcMethodBind meth_id meth_ty pbind@(PatMonoBind pat grhss_and_binds locn)
694 -- pat is sure to be a (VarPatIn op)
695 = tcAddErrCtxt (patMonoBindsCtxt pbind) $
696 tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds', lie, rhs_ty) ->
697 unifyTauTy meth_ty rhs_ty `thenTc_`
698 returnTc (PatMonoBind (VarPat meth_id) grhss_and_binds' locn, lie)
702 %************************************************************************
704 \subsection{Type-checking specialise instance pragmas}
706 %************************************************************************
710 tcSpecInstSigs :: E -> CE -> TCE
711 -> Bag InstInfo -- inst decls seen (declared and derived)
712 -> [RenamedSpecInstSig] -- specialise instance upragmas
713 -> TcM (Bag InstInfo) -- new, overlapped, inst decls
715 tcSpecInstSigs e ce tce inst_infos []
718 tcSpecInstSigs e ce tce inst_infos sigs
719 = buildInstanceEnvs inst_infos `thenTc` \ inst_mapper ->
720 tc_inst_spec_sigs inst_mapper sigs `thenNF_Tc` \ spec_inst_infos ->
721 returnTc spec_inst_infos
723 tc_inst_spec_sigs inst_mapper []
724 = returnNF_Tc emptyBag
725 tc_inst_spec_sigs inst_mapper (sig:sigs)
726 = tcSpecInstSig e ce tce inst_infos inst_mapper sig `thenNF_Tc` \ info_sig ->
727 tc_inst_spec_sigs inst_mapper sigs `thenNF_Tc` \ info_sigs ->
728 returnNF_Tc (info_sig `unionBags` info_sigs)
730 tcSpecInstSig :: E -> CE -> TCE
733 -> RenamedSpecInstSig
734 -> NF_TcM (Bag InstInfo)
736 tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc)
737 = recoverTc emptyBag (
738 tcAddSrcLoc src_loc (
740 clas = lookupCE ce class_name -- Renamer ensures this can't fail
742 -- Make some new type variables, named as in the specialised instance type
743 ty_names = extractMonoTyNames ???is_tyvarish_name??? ty
744 (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names
746 babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
747 `thenTc` \ inst_ty ->
749 maybe_tycon = case maybeAppDataTyCon inst_ty of
750 Just (tc,_,_) -> Just tc
753 maybe_unspec_inst = lookup_unspec_inst clas maybe_tycon inst_infos
755 -- Check that we have a local instance declaration to specialise
756 checkMaybeTc maybe_unspec_inst
757 (specInstUnspecInstNotFoundErr clas inst_ty src_loc) `thenTc_`
759 -- Create tvs to substitute for tmpls while simplifying the context
760 copyTyVars inst_tmpls `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) ->
762 Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta
763 _ _ _ binds True{-from here-} mod _ uprag) = maybe_unspec_inst
765 subst = case matchTy unspec_inst_ty inst_ty of
767 Nothing -> panic "tcSpecInstSig:matchTy"
769 subst_theta = instantiateThetaTy subst unspec_theta
770 subst_tv_theta = instantiateThetaTy tv_e subst_theta
772 mk_spec_origin clas ty
773 = InstanceSpecOrigin inst_mapper clas ty src_loc
774 -- I'm VERY SUSPICIOUS ABOUT THIS
775 -- the inst-mapper is in a knot at this point so it's no good
776 -- looking at it in tcSimplify...
778 tcSimplifyThetas mk_spec_origin subst_tv_theta
779 `thenTc` \ simpl_tv_theta ->
781 simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ]
783 tv_tmpl_map = zipEqual "tcSpecInstSig" inst_tv_tys inst_tmpl_tys
784 tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv
786 mkInstanceRelatedIds e True{-from here-} src_loc mod NoInstancePragmas
787 clas inst_tmpls inst_ty simpl_theta uprag
788 `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
790 getSwitchCheckerTc `thenNF_Tc` \ sw_chkr ->
791 (if sw_chkr SpecialiseTrace then
792 pprTrace "Specialised Instance: "
793 (ppAboves [ppCat [if null simpl_theta then ppNil else ppr PprDebug simpl_theta,
794 if null simpl_theta then ppNil else ppStr "=>",
796 pprParendGenType PprDebug inst_ty],
797 ppCat [ppStr " derived from:",
798 if null unspec_theta then ppNil else ppr PprDebug unspec_theta,
799 if null unspec_theta then ppNil else ppStr "=>",
801 pprParendGenType PprDebug unspec_inst_ty]])
804 returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
805 dfun_theta dfun_id const_meth_ids
806 binds True{-from here-} mod src_loc uprag))
810 lookup_unspec_inst clas maybe_tycon inst_infos
811 = case filter (match_info match_inst_ty) (bagToList inst_infos) of
813 (info:_) -> Just info
815 match_info match_ty (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _)
816 = from_here && clas == inst_clas &&
817 match_ty inst_ty && is_plain_instance inst_ty
819 match_inst_ty = case maybe_tycon of
820 Just tycon -> match_tycon tycon
823 match_tycon tycon inst_ty = case (maybeAppDataTyCon inst_ty) of
824 Just (inst_tc,_,_) -> tycon == inst_tc
827 match_fun inst_ty = isFunType inst_ty
830 is_plain_instance inst_ty
831 = case (maybeAppDataTyCon inst_ty) of
832 Just (_,tys,_) -> all isTyVarTemplateTy tys
833 Nothing -> case maybeUnpackFunTy inst_ty of
834 Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res
835 Nothing -> error "TcInstDecls:is_plain_instance"
840 Checking for a decent instance type
841 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
842 @scrutiniseInstanceType@ checks the type {\em and} its syntactic constraints:
843 it must normally look like: @instance Foo (Tycon a b c ...) ...@
845 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
846 flag is on, or (2)~the instance is imported (they must have been
847 compiled elsewhere). In these cases, we let them go through anyway.
849 We can also have instances for functions: @instance Foo (a -> b) ...@.
852 scrutiniseInstanceType from_here clas inst_tau
854 | not (maybeToBool inst_tycon_maybe) || isSynTyCon inst_tycon
855 = failTc (instTypeErr inst_tau)
857 -- IMPORTED INSTANCES ARE OK (but see tcInstDecl1)
859 = returnTc (inst_tycon,arg_tys)
862 | not (all isTyVarTy arg_tys ||
864 = failTc (instTypeErr inst_tau)
867 -- It is obviously illegal to have an explicit instance
868 -- for something that we are also planning to `derive'
869 -- Though we can have an explicit instance which is more
870 -- specific than the derived instance
871 | clas `derivedFor` inst_tycon
872 && all isTyVarTy arg_tys
873 = failTc (derivingWhenInstanceExistsErr clas inst_tycon)
876 -- A user declaration of a CCallable/CReturnable instance
877 -- must be for a "boxed primitive" type.
879 && not (maybeToBool (maybeBoxedPrimType inst_tau)
880 || opt_CompilingGhcInternals) -- this lets us get up to mischief;
881 -- e.g., instance CCallable ()
882 = failTc (nonBoxedPrimCCallErr clas inst_tau)
885 = returnTc (inst_tycon,arg_tys)
888 (possible_tycon, arg_tys) = splitAppTy inst_tau
889 inst_tycon_maybe = getTyCon_maybe possible_tycon
890 inst_tycon = expectJust "tcInstDecls1:inst_tycon" inst_tycon_maybe
897 SynTy tc _ _ -> ppBesides [ppStr "The type synonym `", ppr sty tc, rest_of_msg]
898 TyVarTy tv -> ppBesides [ppStr "The type variable `", ppr sty tv, rest_of_msg]
899 other -> ppBesides [ppStr "The type `", ppr sty ty, rest_of_msg]
901 rest_of_msg = ppStr "' cannot be used as an instance type."
903 derivingWhenInstanceExistsErr clas tycon sty
904 = ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"])
905 4 (ppStr "when an explicit instance exists")
907 derivingWhenInstanceImportedErr inst_mod clas tycon sty
908 = ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"])
909 4 (ppBesides [ppStr "when an instance declared in module `", pp_mod, ppStr "' has been imported"])
911 pp_mod = ppBesides [ppStr "module `", ppPStr inst_mod, ppStr "'"]
913 nonBoxedPrimCCallErr clas inst_ty sty
914 = ppHang (ppStr "Instance isn't for a `boxed-primitive' type")
915 4 (ppBesides [ ppStr "class `", ppr sty clas, ppStr "' type `",
916 ppr sty inst_ty, ppStr "'"])
918 omitDefaultMethodWarn clas_op clas_name inst_ty sty
919 = ppCat [ppStr "Warning: Omitted default method for",
920 ppr sty clas_op, ppStr "in instance",
921 ppPStr clas_name, pprParendGenType sty inst_ty]
924 patMonoBindsCtxt pbind sty
925 = ppHang (ppStr "In a pattern binding:")
928 methodSigCtxt name ty sty
929 = ppHang (ppBesides [ppStr "When matching the definition of class method `",
930 ppr sty name, ppStr "' to its signature :" ])
933 bindSigCtxt method_ids sty
934 = ppHang (ppStr "When checking type signatures for: ")
935 4 (ppInterleave (ppStr ", ") (map (ppr sty) method_ids))
937 superClassSigCtxt sty
938 = ppStr "When checking superclass constraints on instance declaration"