2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[TcInstDecls]{Typechecking instance declarations}
7 #include "HsVersions.h"
10 tcInstDecls1, tcInstDecls2,
12 buildInstanceEnvs, processInstBinds,
17 IMPORT_Trace -- ToDo:rm debugging
21 import TcMonad -- typechecking monad machinery
22 import TcMonadFns ( newDicts, newMethod, newLocalWithGivenTy,
23 newClassOpLocals, copyTyVars,
24 applyTcSubstAndCollectTyVars
26 import AbsSyn -- the stuff being typechecked
29 import BackSubst ( applyTcSubstToBinds )
30 import Bag ( emptyBag, unitBag, unionBags, bagToList )
31 import CE ( lookupCE, CE(..) )
32 import CmdLineOpts ( GlobalSwitch(..) )
33 import GenSpecEtc ( checkSigTyVars )
34 import E ( mkE, getE_CE, getE_TCE, growE_LVE, tvOfE, LVE(..), E )
35 import Errors ( dupInstErr, derivingWhenInstanceExistsErr,
36 preludeInstanceErr, nonBoxedPrimCCallErr,
37 specInstUnspecInstNotFoundErr,
38 Error(..), UnifyErrContext(..)
40 import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
41 import Id -- lots of things
42 import IdInfo -- ditto
43 import Inst ( Inst, InstOrigin(..) )
45 import Maybes ( catMaybes, mkLookupFun, maybeToBool, Maybe(..) )
46 import Name ( getTagFromClassOpName )
47 import NameTypes ( fromPrelude )
48 import LIE ( nullLIE, mkLIE, unMkLIE, plusLIE, LIE )
49 import ListSetOps ( minusList )
50 import TCE ( TCE(..), UniqFM )
51 import TVE ( mkTVE, TVE(..) )
52 import Spec ( specTy )
53 import TcContext ( tcContext )
54 import TcGRHSs ( tcGRHSsAndBinds )
55 import TcMatches ( tcMatchesFun )
56 import TcMonoType ( tcInstanceType )
57 import TcPragmas ( tcDictFunPragmas, tcGenPragmas )
58 import TcSimplify ( tcSimplifyAndCheck, tcSimplifyThetas )
59 import Unify ( unifyTauTy )
60 import Unique ( cCallableClassKey, cReturnableClassKey )
64 Typechecking instance declarations is done in two passes. The first
65 pass, made by @tcInstDecls1@,
66 collects information to be used in the second pass.
68 This pre-processed info includes the as-yet-unprocessed bindings
69 inside the instance declaration. These are type-checked in the second
70 pass, when the class-instance envs and GVE contain all the info from
71 all the instance and value decls. Indeed that's the reason we need
72 two passes over the instance decls.
74 instance c => k (t tvs) where b
80 [TyVarTemplate] -- Type variables, tvs
81 UniType -- The type at which the class is being
83 ThetaType -- inst_decl_theta: the original context from the
84 -- instance declaration. It constrains (some of)
85 -- the TyVarTemplates above
86 ThetaType -- dfun_theta: the inst_decl_theta, plus one
87 -- element for each superclass; the "Mark
88 -- Jones optimisation"
90 [Id] -- Constant methods (either all or none)
91 RenamedMonoBinds -- Bindings, b
92 Bool -- True <=> local instance decl
93 FAST_STRING -- Name of module where this instance was
95 SrcLoc -- Source location assoc'd with this instance's defn
96 [RenamedSig] -- User pragmas recorded for generating specilaised instances
100 Here is the overall algorithm. Assume that
104 $LIE_c$ is the LIE for the context of class $c$
106 $betas_bar$ is the free variables in the class method type, excluding the
109 $LIE_cop$ is the LIE constraining a particular class method
111 $tau_cop$ is the tau type of a class method
113 $LIE_i$ is the LIE for the context of instance $i$
115 $X$ is the instance constructor tycon
117 $gammas_bar$ is the set of type variables of the instance
119 $LIE_iop$ is the LIE for a particular class method instance
121 $tau_iop$ is the tau type for this instance of a class method
123 $alpha$ is the class variable
125 $LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
127 $tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
130 ToDo: Update the list above with names actually in the code.
134 First, make the LIEs for the class and instance contexts, which means
135 instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
136 and make LIElistI and LIEI.
138 Then process each method in turn.
140 order the instance methods according to the ordering of the class methods
142 express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
144 Create final dictionary function from bindings generated already
146 df = lambda inst_tyvars
153 in <op1,op2,...,opn,sd1,...,sdm>
155 Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
156 and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
160 tcInstDecls1 :: E -> CE -> TCE -> [RenamedInstDecl] -> NF_TcM (Bag InstInfo)
162 tcInstDecls1 e ce tce [] = returnNF_Tc emptyBag
164 tcInstDecls1 e ce tce (inst_decl : rest)
165 = tc_inst_1 inst_decl `thenNF_Tc` \ infos1 ->
166 tcInstDecls1 e ce tce rest `thenNF_Tc` \ infos2 ->
167 returnNF_Tc (infos1 `unionBags` infos2)
169 tc_inst_1 (InstDecl context class_name ty binds from_here modname imod uprags pragmas src_loc)
171 -- Prime error recovery and substitution pruning
173 addSrcLocTc src_loc (
176 clas = lookupCE ce class_name -- Renamer ensures this can't fail
178 for_ccallable_or_creturnable
179 = class_name == cCallableClass || class_name == cReturnableClass
181 cCallableClass = PreludeClass cCallableClassKey bottom
182 cReturnableClass = PreludeClass cReturnableClassKey bottom
183 bottom = panic "for_ccallable_etc"
185 -- Make some new type variables, named as in the instance type
186 ty_names = extractMonoTyNames (==) ty
187 (tve,inst_tyvars,_) = mkTVE ty_names
189 -- Check the instance type, including its syntactic constraints
190 babyTcMtoTcM (tcInstanceType ce tce tve from_here src_loc ty)
191 `thenTc` \ inst_ty ->
193 -- DEAL WITH THE INSTANCE CONTEXT
194 babyTcMtoTcM (tcContext ce tce tve context) `thenTc` \ theta ->
196 -- SOME BORING AND TURGID CHECKING:
198 inst_for_function_type = isFunType inst_ty
199 -- sigh; it happens; must avoid tickling inst_tycon
201 inst_tycon_maybe = getUniDataTyCon_maybe inst_ty
203 inst_tycon = case inst_tycon_maybe of
205 Nothing -> panic "tcInstDecls1:inst_tycon"
207 -------------------------------------------------------------
208 -- It is illegal for a normal user's module to declare an
209 -- instance for a Prelude-class/Prelude-type instance:
210 checkTc (from_here -- really an inst decl in this module
211 && fromPreludeCore clas -- prelude class
212 && (inst_for_function_type -- prelude type
213 || fromPreludeCore inst_tycon)
214 && not (fromPrelude modname) -- we aren't compiling a Prelude mod
216 (preludeInstanceErr clas inst_ty src_loc) `thenTc_`
218 -------------------------------------------------------------
219 -- It is obviously illegal to have an explicit instance
220 -- for something that we are also planning to `derive'.
221 -- Note that an instance decl coming in from outside
222 -- is probably just telling us about the derived instance
223 -- (ToDo: actually check, if possible), so we mustn't flag
226 && not inst_for_function_type
227 && clas `derivedFor` inst_tycon)
228 (derivingWhenInstanceExistsErr clas inst_tycon) `thenTc_`
230 -------------------------------------------------------------
231 -- A user declaration of a _CCallable/_CReturnable instance
232 -- must be for a "boxed primitive" type.
233 getSwitchCheckerTc `thenNF_Tc` \ sw_chkr ->
234 checkTc (for_ccallable_or_creturnable
235 && from_here -- instance defined here
236 && not (sw_chkr CompilingPrelude) -- which allows anything
237 && (inst_for_function_type || -- a *function*??? hah!
238 not (maybeToBool (maybeBoxedPrimType inst_ty)))) -- naughty, naughty
239 (nonBoxedPrimCCallErr clas inst_ty src_loc) `thenTc_`
241 -- END OF TURGIDITY; back to real fun
242 -------------------------------------------------------------
244 if (not inst_for_function_type && clas `derivedFor` inst_tycon) then
245 -- Don't use this InstDecl; tcDeriv will make the
246 -- InstInfo to be used in later processing.
250 -- Make the dfun id and constant-method ids
251 mkInstanceRelatedIds e
252 from_here pragmas src_loc
253 clas inst_tyvars inst_ty theta uprags
254 `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
257 InstInfo clas inst_tyvars inst_ty theta
258 dfun_theta dfun_id const_meth_ids
259 binds from_here modname src_loc uprags
265 Common bit of code shared with @tcDeriving@:
267 mkInstanceRelatedIds e
268 from_here inst_pragmas locn
270 inst_tyvars inst_ty inst_decl_theta uprags
271 = getUniqueTc `thenNF_Tc` \ uniq ->
273 (class_tyvar, super_classes, _, class_ops, _, _) = getClassBigSig clas
275 super_class_theta = super_classes `zip` (repeat inst_ty)
278 dfun_theta = case inst_decl_theta of
280 [] -> [] -- If inst_decl_theta is empty, then we don't
281 -- want to have any dict arguments, so that we can
282 -- expose the constant methods.
284 other -> inst_decl_theta ++ super_class_theta
285 -- Otherwise we pass the superclass dictionaries to
286 -- the dictionary function; the Mark Jones optimisation.
288 dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_ty)
290 fixNF_Tc ( \ rec_dfun_id ->
292 tcDictFunPragmas e dfun_ty rec_dfun_id inst_pragmas
293 ) `thenNF_Tc` \ dfun_id_info ->
295 returnNF_Tc (mkDictFunId uniq clas inst_ty dfun_ty from_here dfun_id_info)
296 ) `thenNF_Tc` \ dfun_id ->
298 -- Make the constant-method ids, if there are no type variables involved
299 (if not (null inst_tyvars) -- ToDo: could also do this if theta is null...
304 inline_mes = [ getTagFromClassOpName v | (InlineSig v _ _) <- uprags ]
306 mk_const_meth op uniq
310 meth_ty from_here info
312 is_elem = isIn "mkInstanceRelatedIds"
314 info = if tag `is_elem` inline_mes
315 then noIdInfo `addInfo_UF` (iWantToBeINLINEd UnfoldAlways)
318 tenv = [(class_tyvar, inst_ty)]
319 tag = getClassOpTag op
320 op_ty = getClassOpLocalType op
321 meth_ty = instantiateTy tenv op_ty
322 -- If you move to a null-theta version, you need a
323 -- mkForallTy inst_tyvars here
325 mk_constm_w_info (op, u, (name, prags)) -- ToDo: chk name?
326 = fixNF_Tc ( \ rec_constm_id ->
328 babyTcMtoNF_TcM (tcGenPragmas e (Just meth_ty) rec_constm_id prags)
329 `thenNF_Tc` \ id_info ->
331 returnNF_Tc (mkConstMethodId u clas op inst_ty meth_ty
335 tenv = [(class_tyvar, inst_ty)]
336 op_ty = getClassOpLocalType op
337 meth_ty = instantiateTy tenv op_ty
340 getUniquesTc (length class_ops) `thenNF_Tc` \ constm_uniqs ->
341 (case inst_pragmas of
342 ConstantInstancePragma _ name_pragma_pairs ->
343 mapNF_Tc mk_constm_w_info (zip3 class_ops constm_uniqs name_pragma_pairs)
345 other_inst_pragmas ->
346 returnNF_Tc (zipWith mk_const_meth class_ops constm_uniqs)
348 ) `thenNF_Tc` \ const_meth_ids ->
350 returnTc (dfun_id, dfun_theta, const_meth_ids)
354 %************************************************************************
356 \subsection{Converting instance info into suitable InstEnvs}
358 %************************************************************************
361 buildInstanceEnvs :: Bag InstInfo
362 -> TcM InstanceMapper
364 buildInstanceEnvs info
366 cmp :: InstInfo -> InstInfo -> TAG_
367 (InstInfo c1 _ _ _ _ _ _ _ _ _ _ _) `cmp` (InstInfo c2 _ _ _ _ _ _ _ _ _ _ _)
368 = if c1 == c2 then EQ_ else if c1 < c2 then LT_ else GT_
370 info_by_class = equivClasses cmp (bagToList info)
372 mapTc buildInstanceEnv info_by_class `thenTc` \ inst_env_entries ->
374 class_lookup_maybe_fn
376 -> Maybe (ClassInstEnv, (ClassOp -> SpecEnv))
380 class_lookup_maybe_fn = mkLookupFun (==) inst_env_entries
383 = case class_lookup_maybe_fn c of
384 Nothing -> (nullMEnv, \ o -> nullSpecEnv)
387 returnTc class_lookup_fn
391 buildInstanceEnv :: [InstInfo] -- Non-empty, and all for same class
392 -> TcM (Class, (ClassInstEnv, (ClassOp -> SpecEnv)))
394 buildInstanceEnv inst_infos@(info_for_one@(InstInfo clas _ _ _ _ _ _ _ _ _ _ _) : rest)
396 ops = getClassOps clas
397 no_of_ops = length ops
399 foldlTc addClassInstance
400 (nullMEnv, nOfThem no_of_ops nullSpecEnv)
401 inst_infos `thenTc` \ (class_inst_env, op_inst_envs) ->
403 class_op_maybe_fn :: ClassOp -> Maybe SpecEnv
404 class_op_fn :: ClassOp -> SpecEnv
406 class_op_maybe_fn = mkLookupFun (==) (ops `zip` op_inst_envs)
407 -- They compare by ClassOp tags
409 = case class_op_maybe_fn op of
410 Nothing -> nullSpecEnv
413 returnTc (clas, (class_inst_env, class_op_fn))
418 :: (ClassInstEnv, [SpecEnv])
420 -> TcM (ClassInstEnv, [SpecEnv]) -- One SpecEnv for each class op
423 (class_inst_env, op_spec_envs)
424 (InstInfo clas inst_tyvars inst_ty inst_decl_theta dfun_theta dfun_id const_meth_ids _ _ _ src_loc _)
425 = -- Insert into the class_inst_env first
426 checkMaybeErrTc (addClassInst clas class_inst_env inst_ty dfun_id inst_tyvars dfun_theta src_loc)
427 dupInstErr `thenTc` \ class_inst_env' ->
429 -- Adding the classop instances can't fail if the class instance itself didn't
430 op_spec_envs' = case const_meth_ids of
432 other -> zipWith add_const_meth op_spec_envs const_meth_ids
434 returnTc (class_inst_env', op_spec_envs')
436 add_const_meth spec_env meth_id
437 = addOneToSpecEnv spec_env (SpecInfo (Just inst_ty:nothings) 1 meth_id)
439 (const_meth_tyvars,_) = splitForalls (getIdUniType meth_id)
440 nothings = [Nothing | _ <- const_meth_tyvars]
441 -- This only works if the constant method id only has its local polymorphism.
442 -- If you want to have constant methods for
443 -- instance Foo (a,b,c) where
445 -- then the constant method will be polymorphic in a,b,c, and
446 -- the SpecInfo will need to be elaborated.
450 %************************************************************************
452 \subsection{Type-checking instance declarations, pass 2}
454 %************************************************************************
459 -> NF_TcM (LIE, TypecheckedBinds)
461 tcInstDecls2 e inst_decls
463 -- Get type variables free in environment. Sadly, there may be
464 -- some, because of the dreaded monomorphism restriction
465 free_tyvars = tvOfE e
467 tcInstDecls2_help e free_tyvars (bagToList inst_decls)
469 tcInstDecls2_help e free_tyvars [] = returnNF_Tc (nullLIE, EmptyBinds)
471 tcInstDecls2_help e free_tyvars (inst_decl:inst_decls)
472 = tcInstDecl2 e free_tyvars inst_decl `thenNF_Tc` \ (lie1, binds1) ->
473 tcInstDecls2_help e free_tyvars inst_decls `thenNF_Tc` \ (lie2, binds2) ->
474 returnNF_Tc (lie1 `plusLIE` lie2, binds1 `ThenBinds` binds2)
478 ======= New documentation starts here (Sept 92) ==============
480 The main purpose of @tcInstDecl2@ is to return a @Binds@ which defines
481 the dictionary function for this instance declaration. For example
483 instance Foo a => Foo [a] where
487 might generate something like
489 dfun.Foo.List dFoo_a = let op1 x = ...
495 HOWEVER, if the instance decl has no type variables, then it returns a
496 bigger @Binds@ with declarations for each method. For example
498 instance Foo Int where
504 dfun.Foo.Int = Dict [Foo.op1.Int, Foo.op2.Int]
508 This group may be mutually recursive, because (for example) there may
509 be no method supplied for op2 in which case we'll get
511 Foo.op2.Int = default.Foo.op2 dfun.Foo.Int
513 that is, the default method applied to the dictionary at this type.
517 -> [TyVar] -- Free in the environment
519 -> NF_TcM (LIE, TypecheckedBinds)
522 First comes the easy case of a non-local instance decl.
525 tcInstDecl2 e free_tyvars (InstInfo _ _ _ _ _ _ _ _ False{-not this module-} _ _ _)
526 = returnNF_Tc (nullLIE, EmptyBinds)
529 Now the case of a general local instance. For an instance declaration, say,
531 instance (C1 a, C2 b) => C (T a b) where
534 where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
535 function whose type is
537 (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
539 Notice that we pass it the superclass dictionaries at the instance type; this
540 is the ``Mark Jones optimisation''. The stuff before the "=>" here
541 is the @dfun_theta@ below.
546 (InstInfo clas template_tyvars inst_ty_tmpl inst_decl_theta dfun_theta
547 dfun_id const_meth_ids monobinds True{-from here-} _ locn _)
549 origin = InstanceDeclOrigin locn
551 recoverTc (nullLIE, EmptyBinds) (
553 pruneSubstTc free_tyvars (
555 -- Get the class signature
557 super_classes, sc_sel_ids,
558 class_ops, op_sel_ids, defm_ids) = getClassBigSig clas
560 -- Prime error recovery and substitution pruning. Instantiate
561 -- dictionaries from the specified instance context. These
562 -- dicts will be passed into the dictionary-construction
564 copyTyVars template_tyvars `thenNF_Tc` \ (inst_env, inst_tyvars, inst_tyvar_tys) ->
566 inst_ty = instantiateTy inst_env inst_ty_tmpl
568 inst_decl_theta' = instantiateThetaTy inst_env inst_decl_theta
569 dfun_theta' = instantiateThetaTy inst_env dfun_theta
570 sc_theta' = super_classes `zip` (repeat inst_ty)
572 newDicts origin sc_theta' `thenNF_Tc` \ sc_dicts' ->
573 newDicts origin dfun_theta' `thenNF_Tc` \ dfun_arg_dicts' ->
574 newDicts origin inst_decl_theta' `thenNF_Tc` \ inst_decl_dicts' ->
576 sc_dicts'_ids = map mkInstId sc_dicts'
577 dfun_arg_dicts'_ids = map mkInstId dfun_arg_dicts'
579 -- Instantiate the dictionary being constructed
580 -- and the dictionary-construction function
581 newDicts origin [(clas,inst_ty)] `thenNF_Tc` \ [this_dict] ->
583 this_dict_id = mkInstId this_dict
585 -- Instantiate method variables
586 listNF_Tc [ newMethodId sel_id inst_ty origin locn
587 | sel_id <- op_sel_ids
588 ] `thenNF_Tc` \ method_ids ->
590 method_insts = catMaybes (map isInstId_maybe method_ids)
591 -- Extract Insts from those method ids which have them (most do)
592 -- See notes on newMethodId
594 -- Collect available dictionaries
595 let avail_insts = -- These insts are in scope; quite a few, eh?
600 processInstBinds e free_tyvars
601 (makeInstanceDeclDefaultMethodExpr origin this_dict_id class_ops defm_ids inst_ty)
602 inst_tyvars avail_insts method_ids monobinds
603 `thenTc` \ (insts_needed, method_mbinds) ->
604 -- Complete the binding group
606 = VarMonoBind this_dict_id (Dictionary sc_dicts'_ids method_ids)
607 dict_and_method_binds
608 = this_dict_bind `AndMonoBinds` method_mbinds
610 -- Check the overloading constraints of the methods and superclasses
611 -- The global tyvars must be a fixed point of the substitution
612 applyTcSubstAndCollectTyVars free_tyvars `thenNF_Tc` \ real_free_tyvars ->
615 real_free_tyvars -- Global tyvars
616 inst_tyvars -- Local tyvars
618 (sc_dicts' ++ insts_needed) -- Need to get defns for all these
619 (BindSigCtxt method_ids)
620 `thenTc` \ (const_insts, super_binds) ->
622 -- Check that we *could* construct the superclass dictionaries,
623 -- even though we are *actually* going to pass the superclass dicts in;
624 -- the check ensures that the caller will never have a problem building
627 False -- Doesn't matter; more efficient this way
628 real_free_tyvars -- Global tyvars
629 inst_tyvars -- Local tyvars
630 inst_decl_dicts' -- The instance dictionaries available
631 sc_dicts' -- The superclass dicationaries reqd
634 -- Ignore the result; we're only doing
635 -- this to make sure it can be done.
637 -- Create the dictionary function binding itself
642 ((this_dict_id,dfun_id) : (method_ids `zip` const_meth_ids))
643 -- const_meth_ids will often be empty
645 (RecBind dict_and_method_binds)
649 applyTcSubstToBinds inst_binds `thenNF_Tc` \ final_inst_binds ->
651 returnTc (mkLIE const_insts, final_inst_binds)
655 @mkMethodId@ manufactures an id for a local method.
656 It's rather turgid stuff, because there are two cases:
658 (a) For methods with no local polymorphism, we can make an Inst of the
659 class-op selector function and a corresp InstId;
660 which is good because then other methods which call
661 this one will do so directly.
663 (b) For methods with local polymorphism, we can't do this. For example,
666 op :: (Num b) => a -> b -> a
668 Here the type of the class-op-selector is
670 forall a b. (Foo a, Num b) => a -> b -> a
672 The locally defined method at (say) type Float will have type
674 forall b. (Num b) => Float -> b -> Float
676 and the one is not an instance of the other.
678 So for these we just make a local (non-Inst) id with a suitable type.
683 newMethodId sel_id inst_ty origin loc
684 = let (sel_tyvars,sel_theta,sel_tau) = splitType (getIdUniType sel_id)
685 (_:meth_theta) = sel_theta -- The local theta is all except the
686 -- first element of the context
689 -- Ah! a selector for a class op with no local polymorphism
690 -- Build an Inst for this
691 [clas_tyvar] -> newMethod origin sel_id [inst_ty] `thenNF_Tc` \ inst ->
692 returnNF_Tc (mkInstId inst)
694 -- Ho! a selector for a class op with local polymorphism.
695 -- Just make a suitably typed local id for this
696 (clas_tyvar:local_tyvars) ->
698 method_ty = instantiateTy [(clas_tyvar,inst_ty)]
699 (mkSigmaTy local_tyvars meth_theta sel_tau)
701 getUniqueTc `thenNF_Tc` \ uniq ->
702 returnNF_Tc (mkUserLocal (getOccurrenceName sel_id) uniq method_ty loc)
705 This function makes a default method which calls the global default method, at
706 the appropriate instance type.
708 See the notes under default decls in TcClassDcl.lhs.
711 makeInstanceDeclDefaultMethodExpr
718 -> NF_TcM TypecheckedExpr
720 makeInstanceDeclDefaultMethodExpr origin this_dict_id class_ops defm_ids inst_ty tag
722 (tyvar_tmpls, local_theta, _) = splitType (getClassOpLocalType class_op)
724 copyTyVars tyvar_tmpls `thenNF_Tc` \ (inst_env, tyvars, tys) ->
726 inst_theta = instantiateThetaTy inst_env local_theta
728 newDicts origin inst_theta `thenNF_Tc` \ local_dict_insts ->
730 local_dicts = map mkInstId local_dict_insts
734 mkDictLam local_dicts (
735 mkDictApp (mkTyApp (Var defm_id)
737 (this_dict_id:local_dicts)))
741 class_op = class_ops !! idx
742 defm_id = defm_ids !! idx
746 %************************************************************************
748 \subsection{Processing each method}
750 %************************************************************************
752 @processInstBinds@ returns a @MonoBinds@ which binds
753 all the method ids (which are passed in). It is used
754 - both for instance decls,
755 - and to compile the default-method declarations in a class decl.
757 Any method ids which don't have a binding have a suitable default
758 binding created for them. The actual right-hand side used is
759 created using a function which is passed in, because the right thing to
760 do differs between instance and class decls.
765 -> [TyVar] -- Free in envt
767 -> (Int -> NF_TcM TypecheckedExpr) -- Function to make
770 -> [TyVar] -- Tyvars for this instance decl
772 -> [Inst] -- available Insts
774 -> [Id] -- Local method ids
775 -- (instance tyvars are free
780 -> TcM ([Inst], -- These are required
781 TypecheckedMonoBinds)
783 processInstBinds e free_tyvars mk_method_expr inst_tyvars
784 avail_insts method_ids monobinds
786 -- Process the explicitly-given method bindings
787 processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids monobinds
788 `thenTc` (\ (tags, insts_needed_in_methods, method_binds) ->
790 -- Find the methods not handled, and make default method bindings for them.
791 let unmentioned_tags = [1.. length method_ids] `minusList` tags
793 makeDefaultMethods mk_method_expr unmentioned_tags method_ids
794 `thenNF_Tc` (\ default_monobinds ->
796 returnTc (insts_needed_in_methods,
797 method_binds `AndMonoBinds` default_monobinds)
804 -> [TyVar] -- Global free tyvars
805 -> [TyVar] -- Tyvars for this instance decl
806 -> [Inst] -- available Insts
807 -> [Id] -- Local method ids (instance tyvars are free),
810 -> TcM ([Int], -- Class-op tags accounted for
811 [Inst], -- These are required
812 TypecheckedMonoBinds)
814 processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids EmptyMonoBinds
815 = returnTc ([], [], EmptyMonoBinds)
817 processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids (AndMonoBinds mb1 mb2)
818 = processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids mb1
819 `thenTc` \ (op_tags1,dicts1,method_binds1) ->
820 processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids mb2
821 `thenTc` \ (op_tags2,dicts2,method_binds2) ->
822 returnTc (op_tags1 ++ op_tags2,
824 AndMonoBinds method_binds1 method_binds2)
828 processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids mbind
830 -- Find what class op is being defined here. The complication is
831 -- that we could have a PatMonoBind or a FunMonoBind. If the
832 -- former, it should only bind a single variable, or else we're in
833 -- trouble (I'm not sure what the static semantics of methods
834 -- defined in a pattern binding with multiple patterns is!)
835 -- Renamer has reduced us to these two cases.
837 (op,locn) = case mbind of
838 FunMonoBind op _ locn -> (op, locn)
839 PatMonoBind (VarPatIn op) _ locn -> (op, locn)
841 origin = InstanceDeclOrigin locn
845 -- Make a method id for the method
846 let tag = getTagFromClassOpName op
847 method_id = method_ids !! (tag-1)
848 method_ty = getIdUniType method_id
850 specTy origin method_ty `thenNF_Tc` \ (method_tyvars, method_dicts, method_tau) ->
853 case (method_tyvars, method_dicts) of
855 ([],[]) -> -- The simple case; no local polymorphism or overloading in the method
857 -- Type check the method itself
858 tcMethodBind e method_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
860 -- Make sure that the instance tyvars havn't been
861 -- unified with each other or with the method tyvars.
862 -- The global tyvars must be a fixed point of the substitution
863 applyTcSubstAndCollectTyVars free_tyvars `thenNF_Tc` \ real_free_tyvars ->
864 checkSigTyVars real_free_tyvars inst_tyvars method_tau method_tau
865 (MethodSigCtxt op method_tau) `thenTc_`
867 returnTc ([tag], unMkLIE lieIop, mbind')
869 other -> -- It's a locally-polymorphic and/or overloaded method; UGH!
871 -- Make a new id for (a) the local, non-overloaded method
872 -- and (b) the locally-overloaded method
873 -- The latter is needed just so we can return an AbsBinds wrapped
874 -- up inside a MonoBinds.
875 newLocalWithGivenTy op method_tau `thenNF_Tc` \ local_meth_id ->
876 newLocalWithGivenTy op method_ty `thenNF_Tc` \ copy_meth_id ->
878 -- Typecheck the method
879 tcMethodBind e local_meth_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
881 -- Make sure that the instance tyvars haven't been
882 -- unified with each other or with the method tyvars.
883 -- The global tyvars must be a fixed point of the substitution
884 applyTcSubstAndCollectTyVars free_tyvars `thenNF_Tc` \ real_free_tyvars ->
885 checkSigTyVars real_free_tyvars (method_tyvars ++ inst_tyvars) method_tau method_tau
886 (MethodSigCtxt op method_tau) `thenTc_`
888 -- Check the overloading part of the signature.
889 -- Simplify everything fully, even though some
890 -- constraints could "really" be left to the next
891 -- level out. The case which forces this is
893 -- class Foo a where { op :: Bar a => a -> a }
895 -- Here we must simplify constraints on "a" to catch all
896 -- the Bar-ish things.
898 False -- Not top level
900 (inst_tyvars ++ method_tyvars)
901 (method_dicts ++ avail_insts)
903 (MethodSigCtxt op method_ty) `thenTc` \ (f_dicts, dict_binds) ->
907 VarMonoBind method_id
911 (map mkInstId method_dicts)
912 [(local_meth_id, copy_meth_id)]
920 tcMethodBind :: E -> Id -> UniType -> RenamedMonoBinds
921 -> TcM (TypecheckedMonoBinds, LIE)
923 tcMethodBind e meth_id meth_ty (FunMonoBind name matches locn)
925 tcMatchesFun e name meth_ty matches `thenTc` \ (rhs', lie) ->
926 returnTc (FunMonoBind meth_id rhs' locn, lie)
929 tcMethodBind e meth_id meth_ty (PatMonoBind pat grhss_and_binds locn)
930 -- pat is sure to be a (VarPatIn op)
932 tcGRHSsAndBinds e grhss_and_binds `thenTc` \ (grhss_and_binds', lie, rhs_ty) ->
933 unifyTauTy meth_ty rhs_ty (PatMonoBindsCtxt pat grhss_and_binds) `thenTc_`
934 returnTc (PatMonoBind (VarPat meth_id) grhss_and_binds' locn, lie)
939 Creates bindings for the default methods, being the application of the
940 appropriate global default method to the type of this instance decl.
944 :: (Int -> NF_TcM TypecheckedExpr) -- Function to make
946 -> [Int] -- Tags for methods required
947 -> [Id] -- Method names to bind, in tag order
948 -> NF_TcM TypecheckedMonoBinds
951 makeDefaultMethods mk_method_expr [] method_ids
952 = returnNF_Tc EmptyMonoBinds
954 makeDefaultMethods mk_method_expr (tag:tags) method_ids
955 = mk_method_expr tag `thenNF_Tc` \ rhs ->
956 makeDefaultMethods mk_method_expr tags method_ids `thenNF_Tc` \ meth_binds ->
958 returnNF_Tc ((VarMonoBind method_id rhs) `AndMonoBinds` meth_binds)
960 method_id = method_ids !! (tag-1)
963 %************************************************************************
965 \subsection{Type-checking specialise instance pragmas}
967 %************************************************************************
970 tcSpecInstSigs :: E -> CE -> TCE
971 -> Bag InstInfo -- inst decls seen (declared and derived)
972 -> [RenamedSpecialisedInstanceSig] -- specialise instance upragmas
973 -> TcM (Bag InstInfo) -- new, overlapped, inst decls
975 tcSpecInstSigs e ce tce inst_infos []
978 tcSpecInstSigs e ce tce inst_infos sigs
979 = buildInstanceEnvs inst_infos `thenTc` \ inst_mapper ->
980 tc_inst_spec_sigs inst_mapper sigs `thenNF_Tc` \ spec_inst_infos ->
981 returnTc spec_inst_infos
983 tc_inst_spec_sigs inst_mapper []
984 = returnNF_Tc emptyBag
985 tc_inst_spec_sigs inst_mapper (sig:sigs)
986 = tcSpecInstSig e ce tce inst_infos inst_mapper sig `thenNF_Tc` \ info_sig ->
987 tc_inst_spec_sigs inst_mapper sigs `thenNF_Tc` \ info_sigs ->
988 returnNF_Tc (info_sig `unionBags` info_sigs)
990 tcSpecInstSig :: E -> CE -> TCE
993 -> RenamedSpecialisedInstanceSig
994 -> NF_TcM (Bag InstInfo)
996 tcSpecInstSig e ce tce inst_infos inst_mapper (InstSpecSig class_name ty src_loc)
997 = recoverTc emptyBag (
998 addSrcLocTc src_loc (
1000 clas = lookupCE ce class_name -- Renamer ensures this can't fail
1002 -- Make some new type variables, named as in the specialised instance type
1003 ty_names = extractMonoTyNames (==) ty
1004 (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names
1006 babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
1007 `thenTc` \ inst_ty ->
1009 tycon = case getUniDataTyCon_maybe inst_ty of
1011 Nothing -> panic "tcSpecInstSig:inst_tycon"
1013 maybe_unspec_inst = lookup_unspec_inst clas tycon inst_infos
1015 -- Check that we have a local instance declaration to specialise
1016 checkMaybeTc maybe_unspec_inst
1017 (specInstUnspecInstNotFoundErr clas inst_ty src_loc) `thenTc_`
1019 -- Create tvs to substitute for tmpls while simplifying the context
1020 copyTyVars inst_tmpls `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) ->
1022 Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta
1023 _ _ _ binds True{-from here-} mod _ uprag) = maybe_unspec_inst
1025 subst = case matchTy unspec_inst_ty inst_ty of
1027 Nothing -> panic "tcSpecInstSig:matchTy"
1029 subst_theta = instantiateThetaTy subst unspec_theta
1030 subst_tv_theta = instantiateThetaTy tv_e subst_theta
1032 mk_spec_origin clas ty
1033 = InstanceSpecOrigin inst_mapper clas ty src_loc
1035 tcSimplifyThetas mk_spec_origin subst_tv_theta
1036 `thenTc` \ simpl_tv_theta ->
1038 simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ]
1040 tv_tmpl_map = inst_tv_tys `zipEqual` inst_tmpl_tys
1041 tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv
1043 mkInstanceRelatedIds e True{-from here-} NoInstancePragmas src_loc
1044 clas inst_tmpls inst_ty simpl_theta uprag
1045 `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
1047 getSwitchCheckerTc `thenNF_Tc` \ sw_chkr ->
1048 (if sw_chkr SpecialiseTrace then
1049 pprTrace "Specialised Instance: "
1050 (ppAboves [ppCat [if null simpl_theta then ppNil else ppr PprDebug simpl_theta,
1051 if null simpl_theta then ppNil else ppStr "=>",
1053 pprParendUniType PprDebug inst_ty],
1054 ppCat [ppStr " derived from:",
1055 if null unspec_theta then ppNil else ppr PprDebug unspec_theta,
1056 if null unspec_theta then ppNil else ppStr "=>",
1058 pprParendUniType PprDebug unspec_inst_ty]])
1061 returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
1062 dfun_theta dfun_id const_meth_ids
1063 binds True{-from here-} mod src_loc uprag))
1067 lookup_unspec_inst clas tycon inst_infos
1068 = case filter match_info (bagToList inst_infos) of
1070 (info:_) -> Just info
1072 match_info (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _)
1073 = from_here && clas == inst_clas && inst_ty_matches_tycon
1075 inst_ty_matches_tycon = case (getUniDataTyCon_maybe inst_ty) of
1076 Just (inst_tc,tys,_) -> tycon == inst_tc && all isTyVarTemplateTy tys