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, Qual, ArithSeqInfo, Fake,
23 PolyType(..), MonoType )
24 import RnHsSyn ( RenamedHsBinds(..), RenamedMonoBinds(..),
25 RenamedInstDecl(..), RenamedFixityDecl(..),
26 RenamedSig(..), RenamedSpecInstSig(..),
27 RnName(..){-incl instance Outputable-}
29 import TcHsSyn ( TcIdOcc(..), TcHsBinds(..),
30 TcMonoBinds(..), TcExpr(..), tcIdType,
32 mkHsDictLam, mkHsDictApp )
36 import GenSpecEtc ( checkSigTyVars )
37 import Inst ( Inst, InstOrigin(..), InstanceMapper(..),
38 newDicts, newMethod, LIE(..), emptyLIE, plusLIE )
39 import TcBinds ( tcPragmaSigs )
40 import TcDeriv ( tcDeriving )
41 import TcEnv ( tcLookupClass, tcTyVarScope, newLocalId )
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, tcSimplifyThetas )
48 import TcType ( TcType(..), TcTyVar(..),
49 tcInstSigTyVars, tcInstType, tcInstTheta
51 import Unify ( unifyTauTy )
54 import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
55 concatBag, foldBag, bagToList )
56 import CmdLineOpts ( opt_GlasgowExts, opt_CompilingPrelude,
57 opt_OmitDefaultInstanceMethods,
58 opt_SpecialiseOverloaded )
59 import Class ( GenClass, GenClassOp,
60 isCcallishClass, getClassBigSig,
61 getClassOps, getClassOpLocalType )
62 import CoreUtils ( escErrorMsg )
63 import Id ( GenId, idType, isDefaultMethodId_maybe )
64 import ListSetOps ( minusList )
65 import Maybes ( maybeToBool, expectJust )
66 import Name ( getLocalName, origName, nameOf )
67 import PrelInfo ( pAT_ERROR_ID )
68 import PrelMods ( pRELUDE )
69 import PprType ( GenType, GenTyVar, GenClass, GenClassOp, TyCon,
74 import RnUtils ( RnEnv(..) )
75 import TyCon ( derivedFor )
76 import Type ( GenType(..), ThetaType(..), mkTyVarTys,
77 splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy,
78 getTyCon_maybe, maybeBoxedPrimType )
79 import TyVar ( GenTyVar, mkTyVarSet )
80 import TysWiredIn ( stringTy )
81 import Unique ( Unique )
85 Typechecking instance declarations is done in two passes. The first
86 pass, made by @tcInstDecls1@, collects information to be used in the
89 This pre-processed info includes the as-yet-unprocessed bindings
90 inside the instance declaration. These are type-checked in the second
91 pass, when the class-instance envs and GVE contain all the info from
92 all the instance and value decls. Indeed that's the reason we need
93 two passes over the instance decls.
96 Here is the overall algorithm.
97 Assume that we have an instance declaration
99 instance c => k (t tvs) where b
103 $LIE_c$ is the LIE for the context of class $c$
105 $betas_bar$ is the free variables in the class method type, excluding the
108 $LIE_cop$ is the LIE constraining a particular class method
110 $tau_cop$ is the tau type of a class method
112 $LIE_i$ is the LIE for the context of instance $i$
114 $X$ is the instance constructor tycon
116 $gammas_bar$ is the set of type variables of the instance
118 $LIE_iop$ is the LIE for a particular class method instance
120 $tau_iop$ is the tau type for this instance of a class method
122 $alpha$ is the class variable
124 $LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
126 $tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
129 ToDo: Update the list above with names actually in the code.
133 First, make the LIEs for the class and instance contexts, which means
134 instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
135 and make LIElistI and LIEI.
137 Then process each method in turn.
139 order the instance methods according to the ordering of the class methods
141 express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
143 Create final dictionary function from bindings generated already
145 df = lambda inst_tyvars
152 in <op1,op2,...,opn,sd1,...,sdm>
154 Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
155 and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
159 tcInstDecls1 :: Bag RenamedInstDecl
160 -> [RenamedSpecInstSig]
161 -> Module -- module name for deriving
162 -> RnEnv -- for renaming derivings
163 -> [RenamedFixityDecl] -- fixities for deriving
164 -> TcM s (Bag InstInfo,
168 tcInstDecls1 inst_decls specinst_sigs mod_name rn_env fixities
169 = -- Do the ordinary instance declarations
170 mapBagNF_Tc (tcInstDecl1 mod_name) inst_decls
171 `thenNF_Tc` \ inst_info_bags ->
173 decl_inst_info = concatBag inst_info_bags
175 -- Handle "derived" instances; note that we only do derivings
176 -- for things in this module; we ignore deriving decls from
177 -- interfaces! We pass fixities, because they may be used
178 -- in deriving Read and Show.
179 tcDeriving mod_name rn_env decl_inst_info fixities
180 `thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) ->
183 inst_info = deriv_inst_info `unionBags` decl_inst_info
186 -- Handle specialise instance pragmas
187 tcSpecInstSigs inst_info specinst_sigs
188 `thenTc` \ spec_inst_info ->
191 spec_inst_info = emptyBag -- For now
193 full_inst_info = inst_info `unionBags` spec_inst_info
195 returnTc (full_inst_info, deriv_binds, ddump_deriv)
198 tcInstDecl1 :: FAST_STRING -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
202 poly_ty@(HsForAllTy tyvar_names context inst_ty)
204 from_here inst_mod uprags pragmas src_loc)
205 = -- Prime error recovery, set source location
206 recoverNF_Tc (returnNF_Tc emptyBag) $
207 tcAddSrcLoc src_loc $
210 tcLookupClass class_name `thenNF_Tc` \ (clas_kind, clas) ->
215 -- Typecheck the context and instance type
216 tcTyVarScope (map de_rn tyvar_names) (\ tyvars ->
217 tcContext context `thenTc` \ theta ->
218 tcMonoTypeKind inst_ty `thenTc` \ (tau_kind, tau) ->
219 unifyKind clas_kind tau_kind `thenTc_`
220 returnTc (tyvars, theta, tau)
221 ) `thenTc` \ (inst_tyvars, inst_theta, inst_tau) ->
223 -- Check for respectable instance type
224 scrutiniseInstanceType from_here clas inst_tau
225 `thenTc` \ (inst_tycon,arg_tys) ->
227 -- Deal with the case where we are deriving
228 -- and importing the same instance
229 if (not from_here && (clas `derivedFor` inst_tycon)
230 && all isTyVarTy arg_tys)
232 if not opt_CompilingPrelude && maybeToBool inst_mod &&
233 mod_name == expectJust "inst_mod" inst_mod
235 -- Imported instance came from this module;
236 -- discard and derive fresh instance
239 -- Imported instance declared in another module;
240 -- report duplicate instance error
241 failTc (derivingWhenInstanceImportedErr inst_mod clas inst_tycon)
244 -- Make the dfun id and constant-method ids
245 mkInstanceRelatedIds from_here inst_mod pragmas
246 clas inst_tyvars inst_tau inst_theta uprags
247 `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
249 returnTc (unitBag (InstInfo clas inst_tyvars inst_tau inst_theta
250 dfun_theta dfun_id const_meth_ids
251 binds from_here inst_mod src_loc uprags))
255 %************************************************************************
257 \subsection{Type-checking instance declarations, pass 2}
259 %************************************************************************
262 tcInstDecls2 :: Bag InstInfo
263 -> NF_TcM s (LIE s, TcHsBinds s)
265 tcInstDecls2 inst_decls
266 = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyBinds)) inst_decls
268 combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
269 tc2 `thenNF_Tc` \ (lie2, binds2) ->
270 returnNF_Tc (lie1 `plusLIE` lie2,
271 binds1 `ThenBinds` binds2)
275 ======= New documentation starts here (Sept 92) ==============
277 The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
278 the dictionary function for this instance declaration. For example
280 instance Foo a => Foo [a] where
284 might generate something like
286 dfun.Foo.List dFoo_a = let op1 x = ...
292 HOWEVER, if the instance decl has no context, then it returns a
293 bigger @HsBinds@ with declarations for each method. For example
295 instance Foo [a] where
301 dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
302 const.Foo.op1.List a x = ...
303 const.Foo.op2.List a y = ...
305 This group may be mutually recursive, because (for example) there may
306 be no method supplied for op2 in which case we'll get
308 const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
310 that is, the default method applied to the dictionary at this type.
312 What we actually produce in either case is:
314 AbsBinds [a] [dfun_theta_dicts]
315 [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
316 { d = (sd1,sd2, ..., op1, op2, ...)
321 The "maybe" says that we only ask AbsBinds to make global constant methods
322 if the dfun_theta is empty.
325 For an instance declaration, say,
327 instance (C1 a, C2 b) => C (T a b) where
330 where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
331 function whose type is
333 (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
335 Notice that we pass it the superclass dictionaries at the instance type; this
336 is the ``Mark Jones optimisation''. The stuff before the "=>" here
337 is the @dfun_theta@ below.
339 First comes the easy case of a non-local instance decl.
342 tcInstDecl2 :: InstInfo
343 -> NF_TcM s (LIE s, TcHsBinds s)
345 tcInstDecl2 (InstInfo _ _ _ _ _ _ _ _ False{-import-} _ _ _)
346 = returnNF_Tc (emptyLIE, EmptyBinds)
348 tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
349 inst_decl_theta dfun_theta
350 dfun_id const_meth_ids monobinds
351 True{-here-} inst_mod locn uprags)
352 = -- Prime error recovery
353 recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds)) $
356 -- Get the class signature
357 tcInstSigTyVars inst_tyvars `thenNF_Tc` \ (inst_tyvars', _, tenv) ->
360 super_classes, sc_sel_ids,
361 class_ops, op_sel_ids, defm_ids) = getClassBigSig clas
363 tcInstType tenv inst_ty `thenNF_Tc` \ inst_ty' ->
364 tcInstTheta tenv dfun_theta `thenNF_Tc` \ dfun_theta' ->
365 tcInstTheta tenv inst_decl_theta `thenNF_Tc` \ inst_decl_theta' ->
367 sc_theta' = super_classes `zip` (repeat inst_ty')
368 origin = InstanceDeclOrigin
369 mk_method sel_id = newMethodId sel_id inst_ty' origin locn
371 -- Create dictionary Ids from the specified instance contexts.
372 newDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) ->
373 newDicts origin dfun_theta' `thenNF_Tc` \ (dfun_arg_dicts, dfun_arg_dicts_ids) ->
374 newDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) ->
375 newDicts origin [(clas,inst_ty')] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
377 -- Create method variables
378 mapAndUnzipNF_Tc mk_method op_sel_ids `thenNF_Tc` \ (meth_insts_s, meth_ids) ->
380 -- Collect available Insts
382 avail_insts -- These insts are in scope; quite a few, eh?
383 = unionManyBags (this_dict : dfun_arg_dicts : meth_insts_s)
386 = if opt_OmitDefaultInstanceMethods then
387 makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty' clas inst_mod
389 makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty' this_dict_id
391 processInstBinds mk_method_expr inst_tyvars' avail_insts meth_ids monobinds
392 `thenTc` \ (insts_needed, method_mbinds) ->
394 -- Create the dict and method binds
396 = VarMonoBind this_dict_id (Dictionary sc_dict_ids meth_ids)
398 dict_and_method_binds
399 = dict_bind `AndMonoBinds` method_mbinds
401 inst_tyvars_set' = mkTyVarSet inst_tyvars'
403 -- Check the overloading constraints of the methods and superclasses
404 tcAddErrCtxt (bindSigCtxt meth_ids) (
406 inst_tyvars_set' -- Local tyvars
408 (sc_dicts `unionBags` insts_needed) -- Need to get defns for all these
409 ) `thenTc` \ (const_lie, super_binds) ->
411 -- Check that we *could* construct the superclass dictionaries,
412 -- even though we are *actually* going to pass the superclass dicts in;
413 -- the check ensures that the caller will never have a problem building
415 tcAddErrCtxt superClassSigCtxt (
417 inst_tyvars_set' -- Local tyvars
418 inst_decl_dicts -- The instance dictionaries available
419 sc_dicts -- The superclass dicationaries reqd
421 -- Ignore the result; we're only doing
422 -- this to make sure it can be done.
424 -- Now process any SPECIALIZE pragmas for the methods
426 spec_sigs = [ s | s@(SpecSig _ _ _ _) <- uprags ]
428 tcPragmaSigs spec_sigs `thenTc` \ (_, spec_binds, spec_lie) ->
430 -- Complete the binding group, adding any spec_binds
435 ((this_dict_id, RealId dfun_id)
436 : (meth_ids `zip` (map RealId const_meth_ids)))
437 -- const_meth_ids will often be empty
439 (RecBind dict_and_method_binds)
445 returnTc (const_lie `plusLIE` spec_lie, inst_binds)
448 @mkMethodId@ manufactures an id for a local method.
449 It's rather turgid stuff, because there are two cases:
451 (a) For methods with no local polymorphism, we can make an Inst of the
452 class-op selector function and a corresp InstId;
453 which is good because then other methods which call
454 this one will do so directly.
456 (b) For methods with local polymorphism, we can't do this. For example,
459 op :: (Num b) => a -> b -> a
461 Here the type of the class-op-selector is
463 forall a b. (Foo a, Num b) => a -> b -> a
465 The locally defined method at (say) type Float will have type
467 forall b. (Num b) => Float -> b -> Float
469 and the one is not an instance of the other.
471 So for these we just make a local (non-Inst) id with a suitable type.
476 newMethodId sel_id inst_ty origin loc
477 = let (sel_tyvars,sel_theta,sel_tau) = splitSigmaTy (idType sel_id)
478 (_:meth_theta) = sel_theta -- The local theta is all except the
479 -- first element of the context
482 -- Ah! a selector for a class op with no local polymorphism
483 -- Build an Inst for this
484 [clas_tyvar] -> newMethod origin (RealId sel_id) [inst_ty]
486 -- Ho! a selector for a class op with local polymorphism.
487 -- Just make a suitably typed local id for this
488 (clas_tyvar:local_tyvars) ->
489 tcInstType [(clas_tyvar,inst_ty)]
490 (mkSigmaTy local_tyvars meth_theta sel_tau)
491 `thenNF_Tc` \ method_ty ->
492 newLocalId (getLocalName sel_id) method_ty `thenNF_Tc` \ meth_id ->
493 returnNF_Tc (emptyLIE, meth_id)
496 The next function makes a default method which calls the global default method, at
497 the appropriate instance type.
499 See the notes under default decls in TcClassDcl.lhs.
502 makeInstanceDeclDefaultMethodExpr
509 -> NF_TcM s (TcExpr s)
511 makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty this_dict tag
512 = newDicts origin op_theta `thenNF_Tc` \ (op_lie,op_dicts) ->
514 -- def_op_id = /\ op_tyvars -> \ op_dicts ->
515 -- defm_id inst_ty op_tyvars this_dict op_dicts
517 mkHsTyLam op_tyvars (
518 mkHsDictLam op_dicts (
519 mkHsDictApp (mkHsTyApp (HsVar (RealId defm_id))
520 (inst_ty : mkTyVarTys op_tyvars))
521 (this_dict : op_dicts)
525 meth_id = meth_ids !! idx
526 defm_id = defm_ids !! idx
527 (op_tyvars, op_theta, op_tau) = splitSigmaTy (tcIdType meth_id)
529 makeInstanceDeclNoDefaultExpr
537 -> NF_TcM s (TcExpr s)
539 makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty clas inst_mod tag
540 = newDicts origin op_theta `thenNF_Tc` \ (op_lie, op_dicts) ->
542 -- Produce a warning if the default instance method
543 -- has been omitted when one exists in the class
544 warnTc (not err_defm_ok)
545 (omitDefaultMethodWarn clas_op clas_name inst_ty)
547 returnNF_Tc (mkHsTyLam op_tyvars (
548 mkHsDictLam op_dicts (
549 HsApp (mkHsTyApp (HsVar (RealId pAT_ERROR_ID)) [op_tau])
550 (HsLitOut (HsString (_PK_ error_msg)) stringTy))))
553 meth_id = meth_ids !! idx
554 clas_op = (getClassOps clas) !! idx
555 defm_id = defm_ids !! idx
556 (op_tyvars,op_theta,op_tau) = splitSigmaTy (tcIdType meth_id)
558 Just (_, _, err_defm_ok) = isDefaultMethodId_maybe defm_id
560 error_msg = "%E" -- => No explicit method for \"
561 ++ escErrorMsg error_str
563 mod_str = case inst_mod of { Nothing -> pRELUDE; Just m -> m }
565 error_str = _UNPK_ mod_str ++ "." ++ _UNPK_ clas_name ++ "."
566 ++ (ppShow 80 (ppr PprForUser inst_ty)) ++ "."
567 ++ (ppShow 80 (ppr PprForUser clas_op)) ++ "\""
569 clas_name = nameOf (origName clas)
573 %************************************************************************
575 \subsection{Processing each method}
577 %************************************************************************
579 @processInstBinds@ returns a @MonoBinds@ which binds
580 all the method ids (which are passed in). It is used
581 - both for instance decls,
582 - and to compile the default-method declarations in a class decl.
584 Any method ids which don't have a binding have a suitable default
585 binding created for them. The actual right-hand side used is
586 created using a function which is passed in, because the right thing to
587 do differs between instance and class decls.
591 :: (Int -> NF_TcM s (TcExpr s)) -- Function to make default method
592 -> [TcTyVar s] -- Tyvars for this instance decl
593 -> LIE s -- available Insts
594 -> [TcIdOcc s] -- Local method ids in tag order
595 -- (instance tyvars are free in their types)
597 -> TcM s (LIE s, -- These are required
600 processInstBinds mk_default_method_rhs inst_tyvars avail_insts method_ids monobinds
602 -- Process the explicitly-given method bindings
603 processInstBinds1 inst_tyvars avail_insts method_ids monobinds
604 `thenTc` \ (tags, insts_needed_in_methods, method_binds) ->
606 -- Find the methods not handled, and make default method bindings for them.
608 unmentioned_tags = [1.. length method_ids] `minusList` tags
610 mapNF_Tc mk_default_method unmentioned_tags
611 `thenNF_Tc` \ default_bind_list ->
613 returnTc (insts_needed_in_methods,
614 foldr AndMonoBinds method_binds default_bind_list)
616 -- From a tag construct us the passed-in function to construct
617 -- the binding for the default method
618 mk_default_method tag = mk_default_method_rhs tag `thenNF_Tc` \ rhs ->
619 returnNF_Tc (VarMonoBind (method_ids !! (tag-1)) rhs)
624 :: [TcTyVar s] -- Tyvars for this instance decl
625 -> LIE s -- available Insts
626 -> [TcIdOcc s] -- Local method ids in tag order (instance tyvars are free),
628 -> TcM s ([Int], -- Class-op tags accounted for
629 LIE s, -- These are required
632 processInstBinds1 inst_tyvars avail_insts method_ids EmptyMonoBinds
633 = returnTc ([], emptyLIE, EmptyMonoBinds)
635 processInstBinds1 inst_tyvars avail_insts method_ids (AndMonoBinds mb1 mb2)
636 = processInstBinds1 inst_tyvars avail_insts method_ids mb1
637 `thenTc` \ (op_tags1,dicts1,method_binds1) ->
638 processInstBinds1 inst_tyvars avail_insts method_ids mb2
639 `thenTc` \ (op_tags2,dicts2,method_binds2) ->
640 returnTc (op_tags1 ++ op_tags2,
641 dicts1 `unionBags` dicts2,
642 AndMonoBinds method_binds1 method_binds2)
646 processInstBinds1 inst_tyvars avail_insts method_ids mbind
648 -- Find what class op is being defined here. The complication is
649 -- that we could have a PatMonoBind or a FunMonoBind. If the
650 -- former, it should only bind a single variable, or else we're in
651 -- trouble (I'm not sure what the static semantics of methods
652 -- defined in a pattern binding with multiple patterns is!)
653 -- Renamer has reduced us to these two cases.
655 (op,locn) = case mbind of
656 FunMonoBind op _ _ locn -> (op, locn)
657 PatMonoBind (VarPatIn op) _ locn -> (op, locn)
659 occ = getLocalName op
660 origin = InstanceDeclOrigin
664 -- Make a method id for the method
665 let tag = panic "processInstBinds1:getTagFromClassOpName"{-getTagFromClassOpName op-}
666 method_id = method_ids !! (tag-1)
668 method_ty = tcIdType method_id
669 (method_tyvars, method_theta, method_tau) = splitSigmaTy method_ty
671 newDicts origin method_theta `thenNF_Tc` \ (method_dicts,method_dict_ids) ->
673 case (method_tyvars, method_dict_ids) of
675 ([],[]) -> -- The simple case; no local polymorphism or overloading in the method
677 -- Type check the method itself
678 tcMethodBind method_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
679 returnTc ([tag], lieIop, mbind')
681 other -> -- It's a locally-polymorphic and/or overloaded method; UGH!
683 -- Make a new id for (a) the local, non-overloaded method
684 -- and (b) the locally-overloaded method
685 -- The latter is needed just so we can return an AbsBinds wrapped
686 -- up inside a MonoBinds.
688 newLocalId occ method_tau `thenNF_Tc` \ local_id ->
689 newLocalId occ method_ty `thenNF_Tc` \ copy_id ->
691 inst_method_tyvars = inst_tyvars ++ method_tyvars
693 -- Typecheck the method
694 tcMethodBind local_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
696 -- Check the overloading part of the signature.
697 -- Simplify everything fully, even though some
698 -- constraints could "really" be left to the next
699 -- level out. The case which forces this is
701 -- class Foo a where { op :: Bar a => a -> a }
703 -- Here we must simplify constraints on "a" to catch all
704 -- the Bar-ish things.
705 tcAddErrCtxt (methodSigCtxt op method_ty) (
707 (mkTyVarSet inst_method_tyvars)
708 (method_dicts `plusLIE` avail_insts)
710 ) `thenTc` \ (f_dicts, dict_binds) ->
714 VarMonoBind method_id
719 [(local_id, copy_id)]
726 tcMethodBind :: TcIdOcc s -> TcType s -> RenamedMonoBinds
727 -> TcM s (TcMonoBinds s, LIE s)
729 tcMethodBind meth_id meth_ty (FunMonoBind name inf matches locn)
730 = tcMatchesFun name meth_ty matches `thenTc` \ (rhs', lie) ->
731 returnTc (FunMonoBind meth_id inf rhs' locn, lie)
733 tcMethodBind meth_id meth_ty pbind@(PatMonoBind pat grhss_and_binds locn)
734 -- pat is sure to be a (VarPatIn op)
735 = tcAddErrCtxt (patMonoBindsCtxt pbind) $
736 tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds', lie, rhs_ty) ->
737 unifyTauTy meth_ty rhs_ty `thenTc_`
738 returnTc (PatMonoBind (VarPat meth_id) grhss_and_binds' locn, lie)
742 %************************************************************************
744 \subsection{Type-checking specialise instance pragmas}
746 %************************************************************************
750 tcSpecInstSigs :: E -> CE -> TCE
751 -> Bag InstInfo -- inst decls seen (declared and derived)
752 -> [RenamedSpecInstSig] -- specialise instance upragmas
753 -> TcM (Bag InstInfo) -- new, overlapped, inst decls
755 tcSpecInstSigs e ce tce inst_infos []
758 tcSpecInstSigs e ce tce inst_infos sigs
759 = buildInstanceEnvs inst_infos `thenTc` \ inst_mapper ->
760 tc_inst_spec_sigs inst_mapper sigs `thenNF_Tc` \ spec_inst_infos ->
761 returnTc spec_inst_infos
763 tc_inst_spec_sigs inst_mapper []
764 = returnNF_Tc emptyBag
765 tc_inst_spec_sigs inst_mapper (sig:sigs)
766 = tcSpecInstSig e ce tce inst_infos inst_mapper sig `thenNF_Tc` \ info_sig ->
767 tc_inst_spec_sigs inst_mapper sigs `thenNF_Tc` \ info_sigs ->
768 returnNF_Tc (info_sig `unionBags` info_sigs)
770 tcSpecInstSig :: E -> CE -> TCE
773 -> RenamedSpecInstSig
774 -> NF_TcM (Bag InstInfo)
776 tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc)
777 = recoverTc emptyBag (
778 tcAddSrcLoc src_loc (
780 clas = lookupCE ce class_name -- Renamer ensures this can't fail
782 -- Make some new type variables, named as in the specialised instance type
783 ty_names = extractMonoTyNames ???is_tyvarish_name??? ty
784 (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names
786 babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
787 `thenTc` \ inst_ty ->
789 maybe_tycon = case maybeAppDataTyCon inst_ty of
790 Just (tc,_,_) -> Just tc
793 maybe_unspec_inst = lookup_unspec_inst clas maybe_tycon inst_infos
795 -- Check that we have a local instance declaration to specialise
796 checkMaybeTc maybe_unspec_inst
797 (specInstUnspecInstNotFoundErr clas inst_ty src_loc) `thenTc_`
799 -- Create tvs to substitute for tmpls while simplifying the context
800 copyTyVars inst_tmpls `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) ->
802 Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta
803 _ _ _ binds True{-from here-} mod _ uprag) = maybe_unspec_inst
805 subst = case matchTy unspec_inst_ty inst_ty of
807 Nothing -> panic "tcSpecInstSig:matchTy"
809 subst_theta = instantiateThetaTy subst unspec_theta
810 subst_tv_theta = instantiateThetaTy tv_e subst_theta
812 mk_spec_origin clas ty
813 = InstanceSpecOrigin inst_mapper clas ty src_loc
815 tcSimplifyThetas mk_spec_origin subst_tv_theta
816 `thenTc` \ simpl_tv_theta ->
818 simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ]
820 tv_tmpl_map = inst_tv_tys `zipEqual` inst_tmpl_tys
821 tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv
823 mkInstanceRelatedIds e True{-from here-} mod NoInstancePragmas src_loc
824 clas inst_tmpls inst_ty simpl_theta uprag
825 `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
827 getSwitchCheckerTc `thenNF_Tc` \ sw_chkr ->
828 (if sw_chkr SpecialiseTrace then
829 pprTrace "Specialised Instance: "
830 (ppAboves [ppCat [if null simpl_theta then ppNil else ppr PprDebug simpl_theta,
831 if null simpl_theta then ppNil else ppStr "=>",
833 pprParendGenType PprDebug inst_ty],
834 ppCat [ppStr " derived from:",
835 if null unspec_theta then ppNil else ppr PprDebug unspec_theta,
836 if null unspec_theta then ppNil else ppStr "=>",
838 pprParendGenType PprDebug unspec_inst_ty]])
841 returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
842 dfun_theta dfun_id const_meth_ids
843 binds True{-from here-} mod src_loc uprag))
847 lookup_unspec_inst clas maybe_tycon inst_infos
848 = case filter (match_info match_inst_ty) (bagToList inst_infos) of
850 (info:_) -> Just info
852 match_info match_ty (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _)
853 = from_here && clas == inst_clas &&
854 match_ty inst_ty && is_plain_instance inst_ty
856 match_inst_ty = case maybe_tycon of
857 Just tycon -> match_tycon tycon
860 match_tycon tycon inst_ty = case (maybeAppDataTyCon inst_ty) of
861 Just (inst_tc,_,_) -> tycon == inst_tc
864 match_fun inst_ty = isFunType inst_ty
867 is_plain_instance inst_ty
868 = case (maybeAppDataTyCon inst_ty) of
869 Just (_,tys,_) -> all isTyVarTemplateTy tys
870 Nothing -> case maybeUnpackFunTy inst_ty of
871 Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res
872 Nothing -> error "TcInstDecls:is_plain_instance"
877 Checking for a decent instance type
878 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
879 @scrutiniseInstanceType@ checks the type {\em and} its syntactic constraints:
880 it must normally look like: @instance Foo (Tycon a b c ...) ...@
882 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
883 flag is on, or (2)~the instance is imported (they must have been
884 compiled elsewhere). In these cases, we let them go through anyway.
886 We can also have instances for functions: @instance Foo (a -> b) ...@.
889 scrutiniseInstanceType from_here clas inst_tau
891 | not (maybeToBool inst_tycon_maybe)
892 = failTc (instTypeErr inst_tau)
894 -- IMPORTED INSTANCES ARE OK (but see tcInstDecl1)
896 = returnTc (inst_tycon,arg_tys)
899 | not (all isTyVarTy arg_tys ||
902 = failTc (instTypeErr inst_tau)
905 -- It is obviously illegal to have an explicit instance
906 -- for something that we are also planning to `derive'
907 -- Though we can have an explicit instance which is more
908 -- specific than the derived instance
909 | clas `derivedFor` inst_tycon
910 && all isTyVarTy arg_tys
911 = failTc (derivingWhenInstanceExistsErr clas inst_tycon)
914 -- A user declaration of a CCallable/CReturnable instance
915 -- must be for a "boxed primitive" type.
917 && not opt_CompilingPrelude -- which allows anything
918 && maybeToBool (maybeBoxedPrimType inst_tau)
919 = failTc (nonBoxedPrimCCallErr clas inst_tau)
922 = returnTc (inst_tycon,arg_tys)
925 (possible_tycon, arg_tys) = splitAppTy inst_tau
926 inst_tycon_maybe = getTyCon_maybe possible_tycon
927 inst_tycon = expectJust "tcInstDecls1:inst_tycon" inst_tycon_maybe
934 SynTy tc _ _ -> ppBesides [ppStr "The type synonym `", ppr sty tc, rest_of_msg]
935 TyVarTy tv -> ppBesides [ppStr "The type variable `", ppr sty tv, rest_of_msg]
936 other -> ppBesides [ppStr "The type `", ppr sty ty, rest_of_msg]
938 rest_of_msg = ppStr "' cannot be used as an instance type."
940 derivingWhenInstanceExistsErr clas tycon sty
941 = ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"])
942 4 (ppStr "when an explicit instance exists")
944 derivingWhenInstanceImportedErr inst_mod clas tycon sty
945 = ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"])
946 4 (ppBesides [ppStr "when an instance declared in module `", pp_mod, ppStr "' has been imported"])
948 pp_mod = case inst_mod of
949 Nothing -> ppPStr SLIT("the standard Prelude")
950 Just m -> ppBesides [ppStr "module `", ppPStr m, ppStr "'"]
952 nonBoxedPrimCCallErr clas inst_ty sty
953 = ppHang (ppStr "Instance isn't for a `boxed-primitive' type")
954 4 (ppBesides [ ppStr "class `", ppr sty clas, ppStr "' type `",
955 ppr sty inst_ty, ppStr "'"])
957 omitDefaultMethodWarn clas_op clas_name inst_ty sty
958 = ppCat [ppStr "Warning: Omitted default method for",
959 ppr sty clas_op, ppStr "in instance",
960 ppPStr clas_name, pprParendGenType sty inst_ty]
963 patMonoBindsCtxt pbind sty
964 = ppHang (ppStr "In a pattern binding:")
967 methodSigCtxt name ty sty
968 = ppHang (ppBesides [ppStr "When matching the definition of class method `",
969 ppr sty name, ppStr "' to its signature :" ])
972 bindSigCtxt method_ids sty
973 = ppHang (ppStr "When checking type signatures for: ")
974 4 (ppInterleave (ppStr ", ") (map (ppr sty) method_ids))
976 superClassSigCtxt sty
977 = ppStr "When checking superclass constraints on instance declaration"