2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
4 \section[InstEnv]{Instance environments}
7 #include "HsVersions.h"
10 -- these types could use some abstractification (??? ToDo)
11 ClassInstEnv(..), -- OLD: IdInstEnv(..),
13 MethodInstInfo(..), -- needs to be exported? (ToDo)
14 InstanceMapper(..), -- widely-used synonym
16 -- instMethod, instTemplate, -- no need to export
17 addClassInst, {- NOT USED addConstMethInst, -}
19 lookupClassInstAtSimpleType,
23 MatchEnv(..), -- mk more abstract (??? ToDo)
25 -- mkMEnv, lookupMEnv, matchMEnv, insertMEnv, -- no need to export
27 -- and to make the interface self-sufficient...
28 Class, ClassOp, CoreExpr, Expr, TypecheckedPat, Id,
29 Inst, InstOrigin, Maybe, MaybeErr, TyVarTemplate, TyCon,
30 UniType, SplitUniqSupply, SpecInfo, SpecEnv
33 IMPORT_Trace -- ToDo: rm (debugging)
35 import AbsPrel ( intTyCon, --wordTyCon, addrTyCon,
36 floatTyCon, doubleTyCon, charDataCon, intDataCon,
37 wordDataCon, addrDataCon, floatDataCon,
39 intPrimTyCon, doublePrimTyCon
41 import AbsSyn -- TypecheckedExpr, etc.
46 import Maybes -- most of it
47 import Outputable ( isExported )
48 import PlainCore -- PlainCoreExpr, etc.
50 import PrimKind -- rather grubby import (ToDo?)
55 %************************************************************************
57 \subsection[InstEnv-types]{Type declarations}
59 %************************************************************************
63 = Class -> (ClassInstEnv, ClassOp -> SpecEnv)
66 = MatchEnv UniType InstTemplate -- Instances of dicts
70 Id -- A fully polymorphic Id; it is the function
71 -- which produces the Id instance or dict from
72 -- the pieces specified by the rest of the
73 -- template. Its SrcLoc tells where the
74 -- instance was defined.
75 [UniType] -- Apply it to these types, suitably instantiated
76 [InstTy] -- and instances of these things
78 type MethodInstInfo = (Id, [UniType], InstTemplate) -- Specifies a method instance
81 There is an important consistency constraint between the @MatchEnv@s
82 in and the @InstTemplate@s inside them: the @UniType@(s) which is/are
83 the key for the @MatchEnv@ must contain only @TyVarTemplates@, and
84 these must be a superset of the @TyVarTemplates@ mentioned in the
85 corresponding @InstTemplate@.
87 Reason: the lookup process matches the key against the desired value,
88 returning a substitution which is used to instantiate the template.
92 = DictTy Class UniType
93 | MethodTy Id [UniType]
96 MkInstTemplate f tvs insts
98 says that, given a particular mapping of type variables tvs to some
99 types tys, the value which is the required instance is
101 f tys (insts [tys/tvs])
104 @instMethod@ is used if there is no instance for a method; then it is
105 expressed in terms of the corresponding dictionary (or possibly, in a
106 wired-in case only, dictionaries).
109 instMethod :: SplitUniqSupply
112 -> (TypecheckedExpr, [Inst])
114 instMethod uniqs orig id tys
115 = (mkDictApp (mkTyApp (Var id) tys) dicts,
118 (tyvars, theta, tau_ty) = splitType (getIdUniType id)
119 tenv = tyvars `zipEqual` tys
120 insts = mk_dict_insts uniqs theta
121 dicts = map mkInstId insts
123 mk_dict_insts us [] = []
124 mk_dict_insts us ((clas, ty) : rest)
125 = case splitUniqSupply us of { (s1, s2) ->
126 (Dict (getSUnique s1) clas (instantiateTauTy tenv ty) orig)
127 : mk_dict_insts s2 rest
131 @instTemplate@ is used if there is an instance for a method or dictionary.
134 instTemplate :: SplitUniqSupply
136 -> [(TyVarTemplate, UniType)]
138 -> (TypecheckedExpr, [Inst])
140 instTemplate uniqs orig tenv (MkInstTemplate id ty_tmpls inst_tys)
141 = (mkDictApp (mkTyApp (Var id) ty_args) ids, -- ToDo: not strictly a dict app
142 -- for Method inst_tys
145 ty_args = map (instantiateTy tenv) ty_tmpls
146 insts = mk_insts uniqs inst_tys
147 ids = map mkInstId insts
150 mk_insts us (inst_ty : rest)
151 = case splitUniqSupply us of { (s1, s2) ->
156 DictTy clas ty -> Dict uniq clas (instantiateTy tenv ty) orig
157 MethodTy id tys -> Method uniq id (map (instantiateTy tenv) tys) orig
163 %************************************************************************
165 \subsection[InstEnv-adding]{Adding new class instances}
167 %************************************************************************
169 @addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@ based on
170 information from a single instance declaration. It complains about
171 any overlap with an existing instance.
173 Notice that we manufacture the @DictFunId@ and @ConstMethodId@s from
174 scratch here, rather than passing them in. This means a small amount
175 of duplication (no big deal) and that we can't attach a single
176 canonical unfolding; but they don't have a slot for unfoldings
177 anyway... This could be improved. (We do, however, snaffle in the
178 pragma info from the interface...)
184 fop :: Ord b => a -> b -> b -> a
186 instance Foo Int where
187 fop x y z = if y<z then x else fop x z y
189 instance Foo a => Foo [a] where
191 fop (x:xs) y z = [fop x y z]
195 For the Int instance we add to the ??? envt
197 (ClassOpId Foo fop) |--> [Int,b] |--> InstTemplate (ConstMethodId Foo fop Int) [b] [Ord b]
200 If there are no type variables, @addClassInstance@ adds constant
201 instances for those class ops not mentioned in the class-op details
202 (possibly using the pragma info that was passed in). This MUST
203 be the same decision as that by @tcInstDecls2@ about whether to
204 generate constant methods. NB: A slightly more permissive version
205 would base the decision on the context being empty, but there is
206 slightly more admin associated and the benefits are very slight; the
207 context is seldom empty unless there are no tyvars involved.
209 Note: the way of specifying class-op instance details is INADEQUATE
210 for polymorphic class ops. That just means you can't specify clever
211 instances for them via this function.
215 :: Class -- class in question (for err msg only)
216 -> ClassInstEnv -- Incoming envt
217 -> UniType -- The instance type
218 -> Id -- Dict fun id to apply
219 -> [TyVarTemplate] -- Types to which (after instantiation) to apply the dfun
220 -> ThetaType -- Dicts to which to apply the dfun
221 -> SrcLoc -- associated SrcLoc (for err msg only)
223 ClassInstEnv -- Success
224 (Class, (UniType, SrcLoc), -- Failure: the overlapping pair
227 addClassInst clas inst_env inst_ty dfun_id inst_tyvars dfun_theta locn
228 = case (insertMEnv matchTy inst_env inst_ty dict_template) of
229 Succeeded inst_env' -> Succeeded inst_env'
230 Failed (ty', MkInstTemplate id' _ _)
231 -> Failed (clas, (inst_ty, locn), (ty', getSrcLoc id'))
233 dict_template = MkInstTemplate dfun_id
234 (map mkTyVarTemplateTy inst_tyvars)
235 (unzipWith DictTy dfun_theta)
238 ============ NOT USED =============
239 @addConstMethInst@ panics on overlap, because @addClassInst@ has already found
243 addConstMethInst :: IdInstEnv
244 -> UniType -- The instance type
245 -> Id -- The constant method
246 -> [TyVarTemplate] -- Apply method to these (as above)
249 addConstMethInst inst_env inst_ty meth_id inst_tyvars
250 = case (insertMEnv matchTys inst_env [inst_ty] template) of
251 Succeeded inst_env' -> inst_env'
252 Failed (tys', MkInstTemplate id' _ _) ->
253 pprPanic "addConstMethInst:"
254 (ppSep [ppr PprDebug meth_id,
255 ppr PprDebug inst_ty,
258 template = MkInstTemplate meth_id (map mkTyVarTemplateTy inst_tyvars) []
259 -- Constant method just needs to be applied to tyvars
260 -- (which are usually empty)
263 @mkIdInstEnv@ is useful in the simple case where we've a list of
264 @(types, id)@ pairs; the \tr{id} is the \tr{types} specialisation of
265 some other Id (in which the resulting IdInstEnv will doubtless be
266 embedded. There's no messing about with type variables or
271 mkIdInstEnv :: [([TauType],Id)] -> IdInstEnv
273 mkIdInstEnv [] = nullMEnv
274 mkIdInstEnv ((tys,id) : rest)
276 inst_env = mkIdInstEnv rest
278 case (insertMEnv matchTys inst_env tys template) of
279 Succeeded inst_env' -> inst_env'
280 Failed _ -> panic "Failed in mkIdInstEnv"
282 template = MkInstTemplate id [] []
286 %************************************************************************
288 \subsection[InstEnv-lookup]{Performing lookup}
290 %************************************************************************
293 lookupInst :: SplitUniqSupply
295 -> Maybe (TypecheckedExpr,
298 lookupInst uniqs (Dict _ clas ty orig)
299 = if isTyVarTy ty then
300 Nothing -- No instances of a class at a type variable
302 case (lookupMEnv matchTy inst_env ty) of
304 Just (_,tenv,templ) -> Just (instTemplate uniqs orig tenv templ)
309 -- During deriving and instance specialisation operations
310 -- we can't get the instances of the class from inside the
311 -- class, because the latter ain't ready yet. Instead we
312 -- find a mapping from classes to envts inside the dict origin.
313 -- (A Simon hack [WDP])
315 DerivingOrigin inst_mapper _ _ _ _ -> fst (inst_mapper clas)
317 InstanceSpecOrigin inst_mapper _ _ _ -> fst (inst_mapper clas)
319 -- Usually we just get the instances of the class from
320 -- inside the class itself.
322 other -> getClassInstEnv clas
324 lookupInst uniqs (Method _ id tys orig)
325 = if (all isTyVarTy tys) then
326 general_case -- Instance types are all type variables, so there can't be
327 -- a special instance for this method
329 else -- Get the inst env from the Id, and look up in it
330 case (lookupSpecEnv (getIdSpecialisation id) tys) of
331 Nothing -> general_case
332 Just (spec_id, types_left, num_dicts_to_toss)
333 -> Just (instMethod uniqs orig spec_id types_left)
335 general_case = Just (instMethod uniqs orig id tys)
338 Now "overloaded" literals: the plain truth is that the compiler
339 is intimately familiar w/ the types Int, Integer, Float, and Double;
340 for everything else, we actually conjure up an appropriately-applied
341 fromInteger/fromRational, as the Haskell report suggests.
344 lookupInst uniqs (LitInst u (OverloadedIntegral i from_int from_integer) ty orig)
346 case (getUniDataTyCon_maybe ty) of -- this way is *unflummoxed* by synonyms
348 | tycon == intPrimTyCon -> (intprim_lit, [])
349 | tycon == doublePrimTyCon -> (doubleprim_lit, [])
350 | tycon == intTyCon -> (int_lit, [])
351 | tycon == doubleTyCon -> (double_lit, [])
352 | tycon == floatTyCon -> (float_lit, [])
353 -- | tycon == wordTyCon -> (word_lit, [])
354 -- | tycon == addrTyCon -> (addr_lit, [])
358 if (i >= toInteger minInt && i <= toInteger maxInt) then
359 -- It's overloaded but small enough to fit into an Int
361 let u2 = getSUnique uniqs
362 method = Method u2 from_int [ty] orig
364 (App (Var (mkInstId method)) int_lit, [method])
367 -- Alas, it is overloaded and a big literal!
369 let u2 = getSUnique uniqs
370 method = Method u2 from_integer [ty] orig
372 (App (Var (mkInstId method)) (Lit (IntLit i)), [method])
375 #if __GLASGOW_HASKELL__ <= 22
376 iD = ((fromInteger i) :: Double)
378 iD = ((fromInteger i) :: Rational)
380 intprim_lit = Lit (IntPrimLit i)
381 doubleprim_lit = Lit (DoublePrimLit iD)
382 int_lit = App (Var intDataCon) intprim_lit
383 double_lit = App (Var doubleDataCon) doubleprim_lit
384 float_lit = App (Var floatDataCon) (Lit (FloatPrimLit iD))
385 -- word_lit = App (Var wordDataCon) intprim_lit
386 -- addr_lit = App (Var addrDataCon) intprim_lit
388 lookupInst uniqs (LitInst u (OverloadedFractional f from_rational) ty orig)
390 case (getUniDataTyCon_maybe ty) of -- this way is *unflummoxed* by synonyms
392 | tycon == doublePrimTyCon -> (doubleprim_lit, [])
393 | tycon == doubleTyCon -> (double_lit, [])
394 | tycon == floatTyCon -> (float_lit, [])
396 _ {-otherwise-} -> -- gotta fromRational it...
397 --pprTrace "lookupInst:fractional lit ty?:" (ppr PprDebug ty) (
399 u2 = getSUnique uniqs
400 method = Method u2 from_rational [ty] orig
402 (App (Var (mkInstId method)) (Lit (FracLit f)), [method])
406 #if __GLASGOW_HASKELL__ <= 22
407 fD = ((fromRational f) :: Double)
411 doubleprim_lit = Lit (DoublePrimLit fD)
412 double_lit = App (Var doubleDataCon) doubleprim_lit
413 float_lit = App (Var floatDataCon) (Lit (FloatPrimLit fD))
416 There is a second, simpler interface, when you want an instance of a
417 class at a given nullary type constructor. It just returns the
418 appropriate dictionary if it exists. It is used only when resolving
419 ambiguous dictionaries.
422 lookupClassInstAtSimpleType :: Class -> UniType -> Maybe Id
424 lookupClassInstAtSimpleType clas ty
425 = case (lookupMEnv matchTy (getClassInstEnv clas) ty) of
427 Just (_,_,MkInstTemplate dict [] []) -> Just dict
430 Notice in the above that the type constructors in the default list
431 should all have arity zero, so there should be no type variables
432 or thetas in the instance declaration.
434 There's yet a third interface for Insts which need no binding.
435 They are used to record constraints on type variables, notably
436 for CCall arguments and results.
439 lookupNoBindInst :: SplitUniqSupply
443 lookupNoBindInst uniqs (Dict _ clas ty orig)
444 = if isTyVarTy ty then
445 Nothing -- No instances of a class at a type variable
447 case (lookupMEnv matchTy inst_env ty) of
449 Just (_,tenv,templ) ->
450 case (instTemplate uniqs orig tenv templ) of
453 -- The idea here is that the expression built by
454 -- instTemplate isn't relevant; indeed, it might well
455 -- be a place-holder bottom value.
457 inst_env = getClassInstEnv clas
461 mkInstSpecEnv :: Class -- class
462 -> UniType -- instance type
463 -> [TyVarTemplate] -- instance tyvars
464 -> ThetaType -- superclasses dicts
465 -> SpecEnv -- specenv for dfun of instance
467 mkInstSpecEnv clas inst_ty inst_tvs inst_theta
468 = mkSpecEnv (catMaybes (map maybe_spec_info matches))
470 matches = matchMEnv matchTy (getClassInstEnv clas) inst_ty
472 maybe_spec_info (_, match_info, MkInstTemplate dfun _ [])
473 = Just (SpecInfo (map (assocMaybe match_info) inst_tvs) (length inst_theta) dfun)
474 maybe_spec_info (_, match_info, _)
479 %************************************************************************
481 \subsection[MatchEnv]{Matching environments}
483 %************************************************************************
485 ``Matching'' environments allow you to bind a template to a value;
486 when you look up in it, you supply a value which is matched against
490 type MatchEnv key value = [(key, value)]
493 For now we just use association lists. The list is maintained sorted
494 in order of {\em decreasing specificness} of @key@, so that the first
495 match will be the most specific.
498 nullMEnv :: MatchEnv a b
501 mkMEnv :: [(key, value)] -> MatchEnv key value
505 @lookupMEnv@ looks up in a @MatchEnv@.
506 It simply takes the first match, should be the most specific.
509 lookupMEnv :: (key {- template -} -> -- Matching function
510 key {- instance -} ->
512 -> MatchEnv key value -- The envt
514 -> Maybe (key, -- Template
515 match_info, -- Match info returned by matching fn
518 lookupMEnv key_match alist key
522 find ((tpl, val) : rest)
523 = case key_match tpl key of
525 Just match_info -> Just (tpl, match_info, val)
528 @matchEnv@ returns all more specidfic matches in a @MatchEnv@,
532 matchMEnv :: (key {- template -} -> -- Matching function
533 key {- instance -} ->
535 -> MatchEnv key value -- The envt
538 match_info, -- Match info returned by matching fn
541 matchMEnv key_match alist key
545 match ((tpl, val) : rest)
546 = case key_match tpl key of
547 Nothing -> case key_match key tpl of
548 Nothing -> match rest
549 Just match_info -> (tpl, match_info, val) : match rest
553 @insertMEnv@ extends a match environment, checking for overlaps.
556 insertMEnv :: (key {- template -} -> -- Matching function
557 key {- instance -} ->
559 -> MatchEnv key value -- Envt
560 -> key -> value -- New item
561 -> MaybeErr (MatchEnv key value) -- Success...
562 (key, value) -- Failure: Offending overlap
564 insertMEnv match_fn alist key value
567 -- insert has to put the new item in BEFORE any keys which are
568 -- LESS SPECIFIC than the new key, and AFTER any keys which are
569 -- MORE SPECIFIC The list is maintained in specific-ness order, so
570 -- we just stick it in either last, or just before the first key
571 -- of which the new key is an instance. We check for overlap at
574 insert [] = returnMaB [(key, value)]
575 insert ((t,v) : rest)
576 = case (match_fn t key) of
578 -- New key is not an instance of this existing one, so
579 -- continue down the list.
580 insert rest `thenMaB` (\ rest' ->
581 returnMaB ((t,v):rest') )
584 -- New key *is* an instance of the old one, so check the
585 -- other way round in case of identity.
587 case (match_fn key t) of
588 Just _ -> failMaB (t,v)
591 Nothing -> returnMaB ((key,value):(t,v):rest)
592 -- All ok; insert here