Inst.lhs 22 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
4
5
6
%
\section[Inst]{The @Inst@ type: dictionaries or method instances}

\begin{code}
7
module Inst ( 
8
	LIE, emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE,
9
	plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
10

11
	Inst, 
12
	pprInst, pprInsts, pprInstsInFull, tidyInst, tidyInsts,
13

14
15
16
	newDictFromOld, newDicts, newClassDicts, newDictsAtLoc,
	newMethod, newMethodWithGivenTy, newOverloadedLit,
	newIPDict, instOverloadedFun,
17
18
	instantiateFdClassTys, instFunDeps, instFunDepsOfTheta,
	newFunDepFromDict,
19

20
	tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, instLoc, getDictClassTys,
21
	getDictPred_maybe, getMethodTheta_maybe,
22
23
24
	getFunDeps, getFunDepsOfLIE,
	getIPs, getIPsOfLIE,
	getAllFunDeps, getAllFunDepsOfLIE,
25

26
27
	lookupInst, lookupSimpleInst, LookupInstResult(..),

28
29
	isDict, isClassDict, isMethod,
	isTyVarDict, isStdClassTyVarDict, isMethodFor, notFunDep,
30
	instBindingRequired, instCanBeGeneralised,
31

32
33
	zonkInst, zonkInsts, zonkFunDeps, zonkTvFunDeps,
	instToId, instToIdBndr, ipToId,
34

35
	InstOrigin(..), InstLoc, pprInstLoc
36
37
    ) where

38
#include "HsVersions.h"
39

40
41
import HsSyn	( HsLit(..), HsOverLit(..), HsExpr(..) )
import RnHsSyn	( RenamedHsOverLit )
42
import TcHsSyn	( TcExpr, TcId, 
43
		  mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
44
		)
45
import TcMonad
46
import TcEnv	( TcIdSet, tcGetInstEnv, tcLookupGlobalId )
47
import InstEnv ( InstLookupResult(..), lookupInstEnv )
48
import TcType	( TcThetaType,
49
		  TcType, TcTauType, TcTyVarSet,
50
		  zonkTcTyVars, zonkTcType, zonkTcTypes, 
51
		  zonkTcThetaType
52
		)
53
import CoreFVs	( idFreeTyVars )
54
import Class	( Class, FunDep )
55
import FunDeps	( instantiateFdClassTys )
56
import Id	( Id, idType, mkUserLocal, mkSysLocal )
57
import PrelInfo	( isStandardClass, isCcallishClass, isNoDictClass )
58
import Name	( mkDictOcc, mkMethodOcc, mkIPOcc, getOccName, nameUnique )
59
import PprType	( pprPred )	
60
61
import Type	( Type, PredType(..), 
		  isTyVarTy, mkDictTy, mkPredTy,
62
		  splitForAllTys, splitSigmaTy, funArgTy,
63
		  splitMethodTy, splitRhoTy, classesOfPreds,
64
		  tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
65
		  tidyOpenType, tidyOpenTypes
66
		)
67
import Subst	( emptyInScopeSet, mkSubst, mkInScopeSet,
68
		  substTy, substClasses, mkTyVarSubst, mkTopTyVarSubst
69
		)
70
import Literal	( inIntRange )
71
import VarEnv	( TidyEnv, lookupSubstEnv, SubstResult(..) )
72
import VarSet	( elemVarSet, emptyVarSet, unionVarSet )
73
import TysWiredIn ( isIntTy,
74
75
		    floatDataCon, isFloatTy,
		    doubleDataCon, isDoubleTy,
76
		    isIntegerTy, voidTy
77
		  ) 
78
import PrelNames( Unique, hasKey, fromIntName, fromIntegerClassOpKey )
79
import Maybe	( catMaybes )
80
import Util	( thenCmp, zipWithEqual, mapAccumL )
81
import Bag
82
import Outputable
83
84
85
86
87
88
89
90
91
\end{code}

%************************************************************************
%*									*
\subsection[Inst-collections]{LIE: a collection of Insts}
%*									*
%************************************************************************

\begin{code}
92
type LIE = Bag Inst
93

94
isEmptyLIE	  = isEmptyBag
95
96
emptyLIE          = emptyBag
unitLIE inst 	  = unitBag inst
97
mkLIE insts	  = listToBag insts
98
99
plusLIE lie1 lie2 = lie1 `unionBags` lie2
consLIE inst lie  = inst `consBag` lie
100
plusLIEs lies	  = unionManyBags lies
101
102
lieToList	  = bagToList
listToLIE	  = listToBag
103

104
zonkLIE :: LIE -> NF_TcM LIE
105
zonkLIE lie = mapBagNF_Tc zonkInst lie
sof's avatar
sof committed
106

107
pprInsts :: [Inst] -> SDoc
108
pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
sof's avatar
sof committed
109
110


111
112
pprInstsInFull insts
  = vcat (map go insts)
sof's avatar
sof committed
113
  where
114
    go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
\end{code}

%************************************************************************
%*									*
\subsection[Inst-types]{@Inst@ types}
%*									*
%************************************************************************

An @Inst@ is either a dictionary, an instance of an overloaded
literal, or an instance of an overloaded value.  We call the latter a
``method'' even though it may not correspond to a class operation.
For example, we might have an instance of the @double@ function at
type Int, represented by

	Method 34 doubleId [Int] origin

\begin{code}
132
data Inst
133
134
  = Dict
	Unique
135
	TcPredType
136
	InstLoc
137
138
139
140

  | Method
	Unique

141
	TcId	-- The overloaded function
142
143
144
145
146
147
			-- This function will be a global, local, or ClassOpId;
			--   inside instance decls (only) it can also be an InstId!
			-- The id needn't be completely polymorphic.
			-- You'll probably find its name (for documentation purposes)
			--	  inside the InstOrigin

148
	[TcType]	-- The types to which its polymorphic tyvars
149
150
151
			--	should be instantiated.
			-- These types must saturate the Id's foralls.

152
	TcThetaType	-- The (types of the) dictionaries to which the function
153
154
			-- must be applied to get the method

155
	TcTauType	-- The type of the method
156

157
	InstLoc
158

159
160
161
	-- INVARIANT: in (Method u f tys theta tau loc)
	--	type of (f tys dicts(from theta)) = tau

162
163
  | LitInst
	Unique
164
165
	RenamedHsOverLit	-- The literal from the occurrence site
	TcType			-- The type at which the literal is used
166
	InstLoc
167

168
  | FunDep
169
	Unique
170
	Class		-- the class from which this arises
171
	[FunDep TcType]
172
	InstLoc
173
174
175
176
177
178
179
180
181
\end{code}

Ordering
~~~~~~~~
@Insts@ are ordered by their class/type info, rather than by their
unique.  This allows the context-reduction mechanism to use standard finite
maps to do their stuff.

\begin{code}
182
instance Ord Inst where
183
184
  compare = cmpInst

185
instance Eq Inst where
186
187
188
189
  (==) i1 i2 = case i1 `cmpInst` i2 of
	         EQ    -> True
		 other -> False

190
191
192
193
194
195
196
cmpInst (Dict _ pred1 _)     	  (Dict _ pred2 _)	    = (pred1 `compare` pred2)
cmpInst (Dict _ _ _)	     	  other 		    = LT

cmpInst (Method _ _ _ _ _ _) 	  (Dict _ _ _)	  	    = GT
cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2)
cmpInst (Method _ _ _ _ _ _)      other			    = LT

197
cmpInst (LitInst _ lit1 ty1 _)	  (LitInst _ lit2 ty2 _)    = (lit1 `compare` lit2) `thenCmp` (ty1 `compare` ty2)
198
cmpInst (LitInst _ _ _ _)	  (FunDep _ _ _ _)	    = LT
199
200
cmpInst (LitInst _ _ _ _)	  other 		    = GT

201
202
cmpInst (FunDep _ clas1 fds1 _)   (FunDep _ clas2 fds2 _)   = (clas1 `compare` clas2) `thenCmp` (fds1 `compare` fds2)
cmpInst (FunDep _ _ _ _)	  other			    = GT
203

204
-- and they can only have HsInt or HsFracs in them.
205
206
207
208
209
210
\end{code}


Selection
~~~~~~~~~
\begin{code}
211
instLoc (Dict   u pred      loc) = loc
212
213
instLoc (Method u _ _ _ _   loc) = loc
instLoc (LitInst u lit ty   loc) = loc
214
instLoc (FunDep _ _ _	    loc) = loc
215

216
217
218
219
220
221
getDictPred_maybe (Dict _ p _) = Just p
getDictPred_maybe _	       = Nothing

getMethodTheta_maybe (Method _ _ _ theta _ _) = Just theta
getMethodTheta_maybe _			      = Nothing

222
getDictClassTys (Dict u (Class clas tys) _) = (clas, tys)
223

224
getFunDeps (FunDep _ clas fds _) = Just (clas, fds)
225
226
getFunDeps _ = Nothing

227
228
229
230
231
232
233
234
235
236
237
238
getFunDepsOfLIE lie = catMaybes (map getFunDeps (lieToList lie))

getIPsOfPred (IParam n ty) = [(n, ty)]
getIPsOfPred _             = []
getIPsOfTheta theta = concatMap getIPsOfPred theta

getIPs (Dict u (IParam n ty) loc) = [(n, ty)]
getIPs (Method u id _ theta t loc) = getIPsOfTheta theta
getIPs _ = []

getIPsOfLIE lie = concatMap getIPs (lieToList lie)

239
getAllFunDeps (FunDep _ clas fds _) = fds
240
241
242
243
getAllFunDeps inst = map (\(n,ty) -> ([], [ty])) (getIPs inst)

getAllFunDepsOfLIE lie = concat (map getAllFunDeps (lieToList lie))

244
tyVarsOfInst :: Inst -> TcTyVarSet
245
tyVarsOfInst (Dict _ pred _)         = tyVarsOfPred pred
246
tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
247
					 -- The id might have free type variables; in the case of
248
					 -- locally-overloaded class methods, for example
249
tyVarsOfInst (LitInst _ _ ty _)      = tyVarsOfType  ty
250
tyVarsOfInst (FunDep _ _ fds _)
251
252
  = foldr unionVarSet emptyVarSet (map tyVarsOfFd fds)
  where tyVarsOfFd (ts1, ts2) =
253
254
255
256
257
258
259
260
	    tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts2

tyVarsOfInsts insts
  = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts)

tyVarsOfLIE lie
  = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts)
  where insts = lieToList lie
261
262
263
264
265
\end{code}

Predicates
~~~~~~~~~~
\begin{code}
266
isDict :: Inst -> Bool
267
isDict (Dict _ _ _) = True
268
isDict other	    = False
269

270
271
isClassDict :: Inst -> Bool
isClassDict (Dict _ (Class _ _) _) = True
272
273
274
275
276
isClassDict other		   = False

isMethod :: Inst -> Bool
isMethod (Method _ _ _ _ _ _) = True
isMethod other		      = False
277

278
isMethodFor :: TcIdSet -> Inst -> Bool
279
280
isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
isMethodFor ids inst			     = False
281

282
isTyVarDict :: Inst -> Bool
283
284
isTyVarDict (Dict _ (Class _ tys) _) = all isTyVarTy tys
isTyVarDict other		     = False
285

286
287
288
289
isStdClassTyVarDict (Dict _ (Class clas [ty]) _)
  = isStandardClass clas && isTyVarTy ty
isStdClassTyVarDict other
  = False
290
291

notFunDep :: Inst -> Bool
292
293
notFunDep (FunDep _ _ _ _) = False
notFunDep other		   = True
294
295
296
297
298
299
300
301
\end{code}

Two predicates which deal with the case where class constraints don't
necessarily result in bindings.  The first tells whether an @Inst@
must be witnessed by an actual binding; the second tells whether an
@Inst@ can be generalised over.

\begin{code}
302
instBindingRequired :: Inst -> Bool
303
304
305
instBindingRequired (Dict _ (Class clas _) _) = not (isNoDictClass clas)
instBindingRequired (Dict _ (IParam _ _) _)   = False
instBindingRequired other		      = True
306

307
instCanBeGeneralised :: Inst -> Bool
308
309
instCanBeGeneralised (Dict _ (Class clas _) _) = not (isCcallishClass clas)
instCanBeGeneralised other		       = True
310
311
\end{code}

312

313
314
315
316
Construction
~~~~~~~~~~~~

\begin{code}
317
318
newDicts :: InstOrigin
	 -> TcThetaType
319
	 -> NF_TcM (LIE, [TcId])
320
newDicts orig theta
321
322
  = tcGetInstLoc orig		`thenNF_Tc` \ loc ->
    newDictsAtLoc loc theta	`thenNF_Tc` \ (dicts, ids) ->
323
324
    returnNF_Tc (listToBag dicts, ids)

325
326
newClassDicts :: InstOrigin
	      -> [(Class,[TcType])]
327
	      -> NF_TcM (LIE, [TcId])
328
329
330
newClassDicts orig theta
  = newDicts orig (map (uncurry Class) theta)

331
332
-- Local function, similar to newDicts, 
-- but with slightly different interface
333
newDictsAtLoc :: InstLoc
334
 	      -> TcThetaType
335
	      -> NF_TcM ([Inst], [TcId])
336
newDictsAtLoc loc theta =
337
338
 tcGetUniques (length theta)		`thenNF_Tc` \ new_uniqs ->
 let
339
  mk_dict u pred = Dict u pred loc
340
341
342
  dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
 in
 returnNF_Tc (dicts, map instToId dicts)
343

344
newDictFromOld :: Inst -> Class -> [TcType] -> NF_TcM Inst
345
newDictFromOld (Dict _ _ loc) clas tys
346
  = tcGetUnique	      `thenNF_Tc` \ uniq ->
347
    returnNF_Tc (Dict uniq (Class clas tys) loc)
348
349


350
351
352
newMethod :: InstOrigin
	  -> TcId
	  -> [TcType]
353
	  -> NF_TcM (LIE, TcId)
354
newMethod orig id tys
355
  =   	-- Get the Id type and instantiate it at the specified types
356
    let
357
	(tyvars, rho) = splitForAllTys (idType id)
358
	rho_ty	      = substTy (mkTyVarSubst tyvars tys) rho
359
	(pred, tau)  = splitMethodTy rho_ty
360
    in
361
    newMethodWithGivenTy orig id tys [pred] tau	`thenNF_Tc` \ meth_inst ->
362
    returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
363

364
365
instOverloadedFun orig v arg_tys theta tau
-- This is where we introduce new functional dependencies into the LIE
366
  = newMethodWithGivenTy orig v arg_tys theta tau	`thenNF_Tc` \ inst ->
367
    instFunDeps orig theta				`thenNF_Tc` \ fds ->
368
    returnNF_Tc (instToId inst, mkLIE (inst : fds))
369
370

instFunDeps orig theta
371
372
  = tcGetUnique		`thenNF_Tc` \ uniq ->
    tcGetInstLoc orig	`thenNF_Tc` \ loc ->
373
    let ifd (Class clas tys) =
374
	    let fds = instantiateFdClassTys clas tys in
375
	    if null fds then Nothing else Just (FunDep uniq clas fds loc)
376
	ifd _ = Nothing
377
    in returnNF_Tc (catMaybes (map ifd theta))
378

379
380
instFunDepsOfTheta theta
  = let ifd (Class clas tys) = instantiateFdClassTys clas tys
381
	ifd (IParam n ty)    = [([], [ty])]
382
383
    in concat (map ifd theta)

384
newMethodWithGivenTy orig id tys theta tau
385
  = tcGetInstLoc orig	`thenNF_Tc` \ loc ->
386
387
388
389
390
    newMethodWith id tys theta tau loc

newMethodWith id tys theta tau loc
  = tcGetUnique		`thenNF_Tc` \ new_uniq ->
    returnNF_Tc (Method new_uniq id tys theta tau loc)
391

392
newMethodAtLoc :: InstLoc
393
	       -> Id -> [TcType]
394
	       -> NF_TcM (Inst, TcId)
395
newMethodAtLoc loc real_id tys		-- Local function, similar to newMethod but with 
396
					-- slightly different interface
397
  =   	-- Get the Id type and instantiate it at the specified types
398
    tcGetUnique					`thenNF_Tc` \ new_uniq ->
399
    let
400
401
	(tyvars,rho) = splitForAllTys (idType real_id)
	rho_ty	      = ASSERT( length tyvars == length tys )
402
			substTy (mkTopTyVarSubst tyvars tys) rho
403
	(theta, tau)  = splitRhoTy rho_ty
404
	meth_inst     = Method new_uniq real_id tys theta tau loc
405
406
    in
    returnNF_Tc (meth_inst, instToId meth_inst)
407
408
409
410
411
412
\end{code}

In newOverloadedLit we convert directly to an Int or Integer if we
know that's what we want.  This may save some time, by not
temporarily generating overloaded literals, but it won't catch all
cases (the rest are caught in lookupInst).
413

414
\begin{code}
415
newOverloadedLit :: InstOrigin
416
		 -> RenamedHsOverLit
417
		 -> TcType
418
		 -> NF_TcM (TcExpr, LIE)
419
newOverloadedLit orig (HsIntegral i _) ty
sof's avatar
sof committed
420
421
422
423
424
425
426
  | isIntTy ty && inIntRange i		-- Short cut for Int
  = returnNF_Tc (int_lit, emptyLIE)

  | isIntegerTy ty 			-- Short cut for Integer
  = returnNF_Tc (integer_lit, emptyLIE)

  where
427
428
    int_lit     = HsLit (HsInt i)
    integer_lit = HsLit (HsInteger i)
429

sof's avatar
sof committed
430
newOverloadedLit orig lit ty		-- The general case
431
  = tcGetInstLoc orig		`thenNF_Tc` \ loc ->
432
433
    tcGetUnique			`thenNF_Tc` \ new_uniq ->
    let
434
	lit_inst = LitInst new_uniq lit ty loc
435
    in
sof's avatar
sof committed
436
    returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
437
438
\end{code}

439
440
\begin{code}
newFunDepFromDict dict
441
  | isClassDict dict
442
443
444
445
446
447
  = tcGetUnique		`thenNF_Tc` \ uniq ->
    let (clas, tys) = getDictClassTys dict
	fds = instantiateFdClassTys clas tys
	inst = FunDep uniq clas fds (instLoc dict)
    in
	if null fds then returnNF_Tc Nothing else returnNF_Tc (Just inst)
448
449
  | otherwise
  = returnNF_Tc Nothing
450
451
\end{code}

452
453
454
455
456
457
\begin{code}
newIPDict name ty loc
  = tcGetUnique		`thenNF_Tc` \ new_uniq ->
    let d = Dict new_uniq (IParam name ty) loc in
    returnNF_Tc d
\end{code}
458
459

\begin{code}
460
461
instToId :: Inst -> TcId
instToId inst = instToIdBndr inst
462

463
instToIdBndr :: Inst -> TcId
464
465
instToIdBndr (Dict u (Class clas tys) (_,loc,_))
  = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas tys) loc
466
instToIdBndr (Dict u (IParam n ty) (_,loc,_))
467
  = ipToId n ty loc
468

469
instToIdBndr (Method u id tys theta tau (_,loc,_))
470
  = mkUserLocal (mkMethodOcc (getOccName id)) u tau loc
471

472
instToIdBndr (LitInst u list ty loc)
473
  = mkSysLocal SLIT("lit") u ty
474

475
476
instToIdBndr (FunDep u clas fds _)
  = mkSysLocal SLIT("FunDep") u voidTy
477
478
479

ipToId n ty loc
  = mkUserLocal (mkIPOcc (getOccName n)) (nameUnique n) (mkPredTy (IParam n ty)) loc
480
481
482
483
484
485
486
487
488
489
\end{code}


Zonking
~~~~~~~
Zonking makes sure that the instance types are fully zonked,
but doesn't do the same for the Id in a Method.  There's no
need, and it's a lot of extra work.

\begin{code}
490
zonkPred :: TcPredType -> NF_TcM TcPredType
491
492
493
494
495
496
497
zonkPred (Class clas tys)
  = zonkTcTypes tys			`thenNF_Tc` \ new_tys ->
    returnNF_Tc (Class clas new_tys)
zonkPred (IParam n ty)
  = zonkTcType ty			`thenNF_Tc` \ new_ty ->
    returnNF_Tc (IParam n new_ty)

498
zonkInst :: Inst -> NF_TcM Inst
499
500
501
zonkInst (Dict u pred loc)
  = zonkPred pred			`thenNF_Tc` \ new_pred ->
    returnNF_Tc (Dict u new_pred loc)
502

503
zonkInst (Method u id tys theta tau loc) 
504
505
506
507
508
  = zonkId id			`thenNF_Tc` \ new_id ->
	-- Essential to zonk the id in case it's a local variable
	-- Can't use zonkIdOcc because the id might itself be
	-- an InstId, in which case it won't be in scope

509
510
511
    zonkTcTypes tys		`thenNF_Tc` \ new_tys ->
    zonkTcThetaType theta	`thenNF_Tc` \ new_theta ->
    zonkTcType tau		`thenNF_Tc` \ new_tau ->
512
    returnNF_Tc (Method u new_id new_tys new_theta new_tau loc)
513

514
zonkInst (LitInst u lit ty loc)
515
  = zonkTcType ty			`thenNF_Tc` \ new_ty ->
516
    returnNF_Tc (LitInst u lit new_ty loc)
517

518
zonkInst (FunDep u clas fds loc)
519
  = zonkFunDeps fds			`thenNF_Tc` \ fds' ->
520
    returnNF_Tc (FunDep u clas fds' loc)
521

522
523
zonkInsts insts = mapNF_Tc zonkInst insts

524
525
526
527
528
529
zonkFunDeps fds = mapNF_Tc zonkFd fds
  where
  zonkFd (ts1, ts2)
    = zonkTcTypes ts1			`thenNF_Tc` \ ts1' ->
      zonkTcTypes ts2			`thenNF_Tc` \ ts2' ->
      returnNF_Tc (ts1', ts2')
530
531
532
533
534
535
536

zonkTvFunDeps fds = mapNF_Tc zonkFd fds
  where
  zonkFd (tvs1, tvs2)
    = zonkTcTyVars tvs1			`thenNF_Tc` \ tvs1' ->
      zonkTcTyVars tvs2			`thenNF_Tc` \ tvs2' ->
      returnNF_Tc (tvs1', tvs2')
537
538
539
540
541
542
543
544
545
\end{code}


Printing
~~~~~~~~
ToDo: improve these pretty-printing things.  The ``origin'' is really only
relevant in error messages.

\begin{code}
546
instance Outputable Inst where
547
    ppr inst = pprInst inst
sof's avatar
sof committed
548

549
pprInst (LitInst u lit ty loc)
550
  = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
sof's avatar
sof committed
551

552
pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
sof's avatar
sof committed
553

554
pprInst m@(Method u id tys theta tau loc)
555
  = hsep [ppr id, ptext SLIT("at"), 
556
	  brackets (interppSP tys) {- ,
557
558
	  ptext SLIT("theta"), ppr theta,
	  ptext SLIT("tau"), ppr tau
559
	  show_uniq u,
560
	  ppr (instToId m) -}]
561

562
pprInst (FunDep _ clas fds loc)
563
  = hsep [ppr clas, ppr fds]
564

565
566
567
568
569
570
571
572
573
574
tidyPred :: TidyEnv -> TcPredType -> (TidyEnv, TcPredType)
tidyPred env (Class clas tys)
  = (env', Class clas tys')
  where
    (env', tys') = tidyOpenTypes env tys
tidyPred env (IParam n ty)
  = (env', IParam n ty')
  where
    (env', ty') = tidyOpenType env ty

575
tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst)
576
577
tidyInst env (LitInst u lit ty loc)
  = (env', LitInst u lit ty' loc)
578
  where
579
    (env', ty') = tidyOpenType env ty
580

581
582
tidyInst env (Dict u pred loc)
  = (env', Dict u pred' loc)
583
  where
584
    (env', pred') = tidyPred env pred
585

586
587
tidyInst env (Method u id tys theta tau loc)
  = (env', Method u id tys' theta tau loc)
588
589
		-- Leave theta, tau alone cos we don't print them
  where
590
    (env', tys') = tidyOpenTypes env tys
591
592

-- this case shouldn't arise... (we never print fundeps)
593
tidyInst env fd@(FunDep _ clas fds loc)
594
595
  = (env, fd)

596
597
tidyInsts env insts = mapAccumL tidyInst env insts

598
show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
599
600
601
602
603
604
605
606
607
608
\end{code}


%************************************************************************
%*									*
\subsection[InstEnv-types]{Type declarations}
%*									*
%************************************************************************

\begin{code}
609
610
data LookupInstResult s
  = NoInstance
611
612
  | SimpleInst TcExpr		-- Just a variable, type application, or literal
  | GenInst    [Inst] TcExpr	-- The expression and its needed insts
613

614
lookupInst :: Inst 
615
	   -> NF_TcM (LookupInstResult s)
616
617
618

-- Dictionaries

619
lookupInst dict@(Dict _ (Class clas tys) loc)
620
621
  = tcGetInstEnv		`thenNF_Tc` \ inst_env ->
    case lookupInstEnv inst_env clas tys of
622

623
      FoundInst tenv dfun_id
624
	-> let
625
		subst	      = mkSubst (mkInScopeSet (tyVarsOfTypes tys)) tenv
626
		(tyvars, rho) = splitForAllTys (idType dfun_id)
627
628
		ty_args	      = map subst_tv tyvars
		dfun_rho      = substTy subst rho
629
		(theta, _)    = splitRhoTy dfun_rho
630
		ty_app        = mkHsTyApp (HsVar dfun_id) ty_args
631
632
633
		subst_tv tv   = case lookupSubstEnv tenv tv of
				   Just (DoneTy ty)  -> ty
					-- tenv should bind all the tyvars
634
	   in
635
636
637
	   if null theta then
		returnNF_Tc (SimpleInst ty_app)
	   else
638
	   newDictsAtLoc loc theta	`thenNF_Tc` \ (dicts, dict_ids) ->
639
	   let 
640
		rhs = mkHsDictApp ty_app dict_ids
641
	   in
642
	   returnNF_Tc (GenInst dicts rhs)
643

644
      other	-> returnNF_Tc NoInstance
645
lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
646
647
648

-- Methods

649
650
lookupInst inst@(Method _ id tys theta _ loc)
  = newDictsAtLoc loc theta		`thenNF_Tc` \ (dicts, dict_ids) ->
651
    returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
652
653
654

-- Literals

655
lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
sof's avatar
sof committed
656
  | isIntTy ty && in_int_range			-- Short cut for Int
657
658
  = returnNF_Tc (GenInst [] int_lit)
	-- GenInst, not SimpleInst, because int_lit is actually a constructor application
sof's avatar
sof committed
659
660

  | isIntegerTy ty				-- Short cut for Integer
661
  = returnNF_Tc (GenInst [] integer_lit)
sof's avatar
sof committed
662

663
664
665
666
667
  | in_int_range 				-- It's overloaded but small enough to fit into an Int
  && from_integer_name `hasKey` fromIntegerClassOpKey	-- And it's the built-in prelude fromInteger
							-- (i.e. no funny business with user-defined
							--  packages of numeric classes)
  =	-- So we can use the Prelude fromInt 
668
    tcLookupGlobalId fromIntName		`thenNF_Tc` \ from_int ->
669
    newMethodAtLoc loc from_int [ty]		`thenNF_Tc` \ (method_inst, method_id) ->
670
    returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
sof's avatar
sof committed
671
672

  | otherwise   				-- Alas, it is overloaded and a big literal!
673
  = tcLookupGlobalId from_integer_name		`thenNF_Tc` \ from_integer ->
674
    newMethodAtLoc loc from_integer [ty]	`thenNF_Tc` \ (method_inst, method_id) ->
675
    returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
676
  where
sof's avatar
sof committed
677
    in_int_range   = inIntRange i
678
679
    integer_lit    = HsLit (HsInteger i)
    int_lit        = HsLit (HsInt i)
680

681
682
683
684
-- similar idea for overloaded floating point literals: if the literal is
-- *definitely* a float or a double, generate the real thing here.
-- This is essential  (see nofib/spectral/nucleic).

685
lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
686
687
688
689
  | isFloatTy ty    = returnNF_Tc (GenInst [] float_lit)
  | isDoubleTy ty   = returnNF_Tc (GenInst [] double_lit)

  | otherwise 
690
  = tcLookupGlobalId from_rat_name		`thenNF_Tc` \ from_rational ->
691
    newMethodAtLoc loc from_rational [ty]	`thenNF_Tc` \ (method_inst, method_id) ->
692
    let
693
	rational_ty  = funArgTy (idType method_id)
694
	rational_lit = HsLit (HsRat f rational_ty)
695
    in
696
    returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
697
698

  where
699
    floatprim_lit  = HsLit (HsFloatPrim f)
700
    float_lit      = mkHsConApp floatDataCon [] [floatprim_lit]
701
    doubleprim_lit = HsLit (HsDoublePrim f)
702
    double_lit     = mkHsConApp doubleDataCon [] [doubleprim_lit]
703

704
-- there are no `instances' of functional dependencies or implicit params
705

706
lookupInst _  = returnNF_Tc NoInstance
707

708
709
710
711
712
713
714
715
\end{code}

There is a second, simpler interface, when you want an instance of a
class at a given nullary type constructor.  It just returns the
appropriate dictionary if it exists.  It is used only when resolving
ambiguous dictionaries.

\begin{code}
716
lookupSimpleInst :: Class
717
		 -> [Type]				-- Look up (c,t)
718
	         -> NF_TcM (Maybe [(Class,[Type])])	-- Here are the needed (c,t)s
719

720
721
722
lookupSimpleInst clas tys
  = tcGetInstEnv		`thenNF_Tc` \ inst_env -> 
    case lookupInstEnv inst_env clas tys of
723
      FoundInst tenv dfun
724
	-> returnNF_Tc (Just (substClasses (mkSubst emptyInScopeSet tenv) theta'))
725
726
        where
	   (_, theta, _) = splitSigmaTy (idType dfun)
727
	   theta'	 = classesOfPreds theta
728
729

      other  -> returnNF_Tc Nothing
730
\end{code}
731
732