Inst.lhs 22.4 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, 
9
	plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
10
	showLIE,
11

12
	Inst, 
13
	pprInst, pprInsts, pprInstsInFull, tidyInsts, tidyMoreInsts,
14

15
	newDictsFromOld, newDicts, cloneDict, 
16
	newOverloadedLit, newIPDict, 
17
18
	newMethod, newMethodFromName, newMethodWithGivenTy, 
	tcInstClassOp, tcInstCall, tcInstDataCon, tcSyntaxName,
19

20
	tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, 
21
	ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
22
	instLoc, getDictClassTys, dictPred,
23

24
	lookupInst, LookupInstResult(..),
25

26
	isDict, isClassDict, isMethod, 
27
	isLinearInst, linearInstType, isIPDict, isInheritableInst,
28
	isTyVarDict, isStdClassTyVarDict, isMethodFor, 
29
	instBindingRequired, instCanBeGeneralised,
30

31
	zonkInst, zonkInsts,
32
	instToId, instName,
33

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

37
#include "HsVersions.h"
38

39
40
import {-# SOURCE #-}	TcExpr( tcExpr )

41
import HsSyn	( HsLit(..), HsOverLit(..), HsExpr(..) )
42
import TcHsSyn	( TcExpr, TcId, TcIdSet, TypecheckedHsExpr,
43
		  mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
44
		)
45
import TcRnMonad
46
import TcEnv	( tcGetInstEnv, tcLookupId, tcLookupTyCon, checkWellStaged, topIdLvl )
47
import InstEnv	( InstLookupResult(..), lookupInstEnv )
48
import TcMType	( zonkTcType, zonkTcTypes, zonkTcPredType, zapToType,
49
		  zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
50
		)
51
import TcType	( Type, TcType, TcThetaType, TcTyVarSet,
52
		  SourceType(..), PredType, ThetaType, TyVarDetails(VanillaTv),
53
		  tcSplitForAllTys, tcSplitForAllTys, mkTyConApp,
54
		  tcSplitMethodTy, tcSplitPhiTy, mkGenTyConApp,
55
56
57
		  isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
		  tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
		  tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
58
		  isClassPred, isTyVarClassPred, isLinearPred, predHasFDs,
59
		  getClassPredTys, getClassPredTys_maybe, mkPredName,
60
		  isInheritablePred, isIPPred, 
61
		  tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy
62
		)
63
import CoreFVs	( idFreeTyVars )
64
import Class	( Class )
65
import DataCon	( DataCon,dataConSig )
66
import Id	( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
67
import PrelInfo	( isStandardClass, isCcallishClass, isNoDictClass )
68
import Name	( Name, mkMethodOcc, getOccName )
69
import PprType	( pprPred, pprParendType )	
70
import Subst	( emptyInScopeSet, mkSubst, substTy, substTyWith, substTheta, mkTyVarSubst )
71
import Literal	( inIntRange )
72
73
import Var	( TyVar )
import VarEnv	( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) )
74
import VarSet	( elemVarSet, emptyVarSet, unionVarSet )
75
import TysWiredIn ( floatDataCon, doubleDataCon )
76
import PrelNames( fromIntegerName, fromRationalName, rationalTyConName )
77
import BasicTypes( IPName(..), mapIPName, ipNameName )
78
import UniqSupply( uniqsFromSupply )
79
import Outputable
80
81
\end{code}

82
83
84
85

Selection
~~~~~~~~~
\begin{code}
86
87
88
instName :: Inst -> Name
instName inst = idName (instToId inst)

89
90
91
92
instToId :: Inst -> TcId
instToId (Dict id _ _)	       = id
instToId (Method id _ _ _ _ _) = id
instToId (LitInst id _ _ _)    = id
93

94
95
96
instLoc (Dict _ _         loc) = loc
instLoc (Method _ _ _ _ _ loc) = loc
instLoc (LitInst _ _ _    loc) = loc
97

98
99
100
dictPred (Dict _ pred _ ) = pred
dictPred inst		  = pprPanic "dictPred" (ppr inst)

101
getDictClassTys (Dict _ pred _) = getClassPredTys pred
102

103
104
105
106
107
108
109
110
111
112
113
114
115
-- fdPredsOfInst is used to get predicates that contain functional 
-- dependencies; i.e. should participate in improvement
fdPredsOfInst (Dict _ pred _) | predHasFDs pred = [pred]
			      | otherwise	= []
fdPredsOfInst (Method _ _ _ theta _ _) = filter predHasFDs theta
fdPredsOfInst other		       = []

fdPredsOfInsts :: [Inst] -> [PredType]
fdPredsOfInsts insts = concatMap fdPredsOfInst insts

isInheritableInst (Dict _ pred _) 	   = isInheritablePred pred
isInheritableInst (Method _ _ _ theta _ _) = all isInheritablePred theta
isInheritableInst other			   = True
116
117


118
119
120
ipNamesOfInsts :: [Inst] -> [Name]
ipNamesOfInst  :: Inst   -> [Name]
-- Get the implicit parameters mentioned by these Insts
121
-- NB: ?x and %x get different Names
122
123
ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]

124
125
ipNamesOfInst (Dict _ (IParam n _) _)  = [ipNameName n]
ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
126
ipNamesOfInst other		       = []
127

128
tyVarsOfInst :: Inst -> TcTyVarSet
129
tyVarsOfInst (LitInst _ _ ty _)      = tyVarsOfType  ty
130
tyVarsOfInst (Dict _ pred _)         = tyVarsOfPred pred
131
tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
132
					 -- The id might have free type variables; in the case of
133
					 -- locally-overloaded class methods, for example
134

135

136
137
tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
138
139
140
141
142
\end{code}

Predicates
~~~~~~~~~~
\begin{code}
143
isDict :: Inst -> Bool
144
isDict (Dict _ _ _) = True
145
isDict other	    = False
146

147
isClassDict :: Inst -> Bool
148
149
150
151
152
153
isClassDict (Dict _ pred _) = isClassPred pred
isClassDict other	    = False

isTyVarDict :: Inst -> Bool
isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
isTyVarDict other	    = False
154

155
156
157
158
isIPDict :: Inst -> Bool
isIPDict (Dict _ pred _) = isIPPred pred
isIPDict other		 = False

159
160
161
isMethod :: Inst -> Bool
isMethod (Method _ _ _ _ _ _) = True
isMethod other		      = False
162

163
isMethodFor :: TcIdSet -> Inst -> Bool
164
165
isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
isMethodFor ids inst			     = False
166

167
168
169
170
171
172
isLinearInst :: Inst -> Bool
isLinearInst (Dict _ pred _) = isLinearPred pred
isLinearInst other	     = False
	-- We never build Method Insts that have
	-- linear implicit paramters in them.
	-- Hence no need to look for Methods
173
	-- See TcExpr.tcId 
174
175
176
177
178

linearInstType :: Inst -> TcType	-- %x::t  -->  t
linearInstType (Dict _ (IParam _ ty) _) = ty


179
isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
180
					Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
181
					other		  -> False
182
183
184
185
186
187
188
189
\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}
190
instBindingRequired :: Inst -> Bool
191
192
instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
instBindingRequired other		       = True
193

194
instCanBeGeneralised :: Inst -> Bool
195
196
instCanBeGeneralised (Dict _ (ClassP clas _) _) = not (isCcallishClass clas)
instCanBeGeneralised other		        = True
197
198
\end{code}

199

200
201
202
203
204
%************************************************************************
%*									*
\subsection{Building dictionaries}
%*									*
%************************************************************************
205
206

\begin{code}
207
208
newDicts :: InstOrigin
	 -> TcThetaType
209
	 -> TcM [Inst]
210
newDicts orig theta
211
  = getInstLoc orig		`thenM` \ loc ->
212
    newDictsAtLoc loc theta
213

214
215
216
cloneDict :: Inst -> TcM Inst
cloneDict (Dict id ty loc) = newUnique	`thenM` \ uniq ->
			     returnM (Dict (setIdUnique id uniq) ty loc)
217

218
newDictsFromOld :: Inst -> TcThetaType -> TcM [Inst]
219
newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
220

221
222
-- Local function, similar to newDicts, 
-- but with slightly different interface
223
newDictsAtLoc :: InstLoc
224
 	      -> TcThetaType
225
	      -> TcM [Inst]
226
newDictsAtLoc inst_loc theta
227
228
  = newUniqueSupply		`thenM` \ us ->
    returnM (zipWith mk_dict (uniqsFromSupply us) theta)
229
  where
230
231
232
    mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred))
			     pred inst_loc
    loc = instLocSrcLoc inst_loc
233

234
235
236
237
238
-- For vanilla implicit parameters, there is only one in scope
-- at any time, so we used to use the name of the implicit parameter itself
-- But with splittable implicit parameters there may be many in 
-- scope, so we make up a new name.
newIPDict :: InstOrigin -> IPName Name -> Type 
239
	  -> TcM (IPName Id, Inst)
240
newIPDict orig ip_name ty
241
  = getInstLoc orig			`thenM` \ inst_loc@(InstLoc _ loc _) ->
242
    newUnique				`thenM` \ uniq ->
243
244
245
246
    let
	pred = IParam ip_name ty
	id   = mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)
    in
247
    returnM (mapIPName (\n -> id) ip_name, Dict id pred inst_loc)
248
249
250
\end{code}


251

252
253
254
255
256
257
%************************************************************************
%*									*
\subsection{Building methods (calls of overloaded functions)}
%*									*
%************************************************************************

258

259
\begin{code}
260
tcInstCall :: InstOrigin  -> TcType -> TcM (TypecheckedHsExpr -> TypecheckedHsExpr, TcType)
261
tcInstCall orig fun_ty	-- fun_ty is usually a sigma-type
262
263
264
  = tcInstType VanillaTv fun_ty	`thenM` \ (tyvars, theta, tau) ->
    newDicts orig theta		`thenM` \ dicts ->
    extendLIEs dicts		`thenM_`
265
266
267
    let
	inst_fn e = mkHsDictApp (mkHsTyApp e (mkTyVarTys tyvars)) (map instToId dicts)
    in
268
269
270
271
272
273
274
275
    returnM (inst_fn, tau)

tcInstDataCon :: InstOrigin -> DataCon
	      -> TcM ([TcType],	-- Types to instantiate at
		      [Inst],	-- Existential dictionaries to apply to
		      [TcType],	-- Argument types of constructor
		      TcType,	-- Result type
		      [TyVar])	-- Existential tyvars
276
277
278
279
280
281
tcInstDataCon orig data_con
  = let 
	(tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con
	     -- We generate constraints for the stupid theta even when 
	     -- pattern matching (as the Report requires)
    in
282
    tcInstTyVars VanillaTv (tvs ++ ex_tvs)	`thenM` \ (all_tvs', ty_args', tenv) ->
283
284
285
286
287
    let
	stupid_theta' = substTheta tenv stupid_theta
	ex_theta'     = substTheta tenv ex_theta
	arg_tys'      = map (substTy tenv) arg_tys

288
289
290
	n_normal_tvs  = length tvs
	ex_tvs'       = drop n_normal_tvs all_tvs'
	result_ty     = mkTyConApp tycon (take n_normal_tvs ty_args')
291
    in
292
293
    newDicts orig stupid_theta'	`thenM` \ stupid_dicts ->
    newDicts orig ex_theta'	`thenM` \ ex_dicts ->
294
295
296

	-- Note that we return the stupid theta *only* in the LIE;
	-- we don't otherwise use it at all
297
298
299
    extendLIEs stupid_dicts	`thenM_`

    returnM (ty_args', ex_dicts, arg_tys', result_ty, ex_tvs')
300

301
newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId
302
newMethodFromName origin ty name
303
  = tcLookupId name		`thenM` \ id ->
304
305
306
307
	-- Use tcLookupId not tcLookupGlobalId; the method is almost
	-- always a class op, but with -fno-implicit-prelude GHC is
	-- meant to find whatever thing is in scope, and that may
	-- be an ordinary function. 
308
309
310
311
    getInstLoc origin		`thenM` \ loc ->
    tcInstClassOp loc id [ty]	`thenM` \ inst ->
    extendLIE inst		`thenM_`
    returnM (instToId inst)
312

313
newMethodWithGivenTy orig id tys theta tau
314
  = getInstLoc orig			`thenM` \ loc ->
315
    newMethod loc id tys theta tau	`thenM` \ inst ->
316
    extendLIE inst			`thenM_`
317
    returnM (instToId inst)
318
319

--------------------------------------------
320
-- tcInstClassOp, and newMethod do *not* drop the 
321
322
323
-- Inst into the LIE; they just returns the Inst
-- This is important because they are used by TcSimplify
-- to simplify Insts
324

325
326
327
tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
tcInstClassOp inst_loc sel_id tys
  = let
328
	(tyvars,rho) = tcSplitForAllTys (idType sel_id)
329
330
331
	rho_ty	     = ASSERT( length tyvars == length tys )
		       substTyWith tyvars tys rho
	(preds,tau)  = tcSplitPhiTy rho_ty
332
    in
333
    newMethod inst_loc sel_id tys preds tau
334

335
---------------------------
336
newMethod inst_loc id tys theta tau
337
  = newUnique		`thenM` \ new_uniq ->
338
339
    let
	meth_id	= mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
340
	inst    = Method meth_id id tys theta tau inst_loc
341
	loc     = instLocSrcLoc inst_loc
342
    in
343
    returnM inst
344
345
346
347
348
349
\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).
350

351
\begin{code}
352
newOverloadedLit :: InstOrigin
353
		 -> HsOverLit
354
		 -> TcType
355
		 -> TcM TcExpr
356
357
358
359
newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
  | fi /= fromIntegerName	-- Do not generate a LitInst for rebindable
				-- syntax.  Reason: tcSyntaxName does unification
				-- which is very inconvenient in tcSimplify
360
361
  = tcSyntaxName orig expected_ty fromIntegerName fi	`thenM` \ (expr, _) ->
    returnM (HsApp expr (HsLit (HsInteger i)))
362
363

  | Just expr <- shortCutIntLit i expected_ty 
364
  = returnM expr
365
366
367
368
369
370

  | otherwise
  = newLitInst orig lit expected_ty

newOverloadedLit orig lit@(HsFractional r fr) expected_ty
  | fr /= fromRationalName	-- c.f. HsIntegral case
371
372
373
  = tcSyntaxName orig expected_ty fromRationalName fr	`thenM` \ (expr, _) ->
    mkRatLit r						`thenM` \ rat_lit ->
    returnM (HsApp expr rat_lit)
374
375

  | Just expr <- shortCutFracLit r expected_ty 
376
  = returnM expr
sof's avatar
sof committed
377

378
  | otherwise
379
380
381
  = newLitInst orig lit expected_ty

newLitInst orig lit expected_ty
382
383
384
  = getInstLoc orig		`thenM` \ loc ->
    newUnique			`thenM` \ new_uniq ->
    zapToType expected_ty	`thenM_` 
385
386
	-- The expected type might be a 'hole' type variable, 
	-- in which case we must zap it to an ordinary type variable
387
    let
388
389
	lit_inst = LitInst lit_id lit expected_ty loc
	lit_id   = mkSysLocal FSLIT("lit") new_uniq expected_ty
390
    in
391
392
    extendLIE lit_inst		`thenM_`
    returnM (HsVar (instToId lit_inst))
393

394
395
396
shortCutIntLit :: Integer -> TcType -> Maybe TcExpr
shortCutIntLit i ty
  | isIntTy ty && inIntRange i 			-- Short cut for Int
397
  = Just (HsLit (HsInt i))
398
  | isIntegerTy ty 				-- Short cut for Integer
399
  = Just (HsLit (HsInteger i))
400
  | otherwise = Nothing
401

402
403
404
shortCutFracLit :: Rational -> TcType -> Maybe TcExpr
shortCutFracLit f ty
  | isFloatTy ty 
405
  = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
406
  | isDoubleTy ty
407
  = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
408
  | otherwise = Nothing
409

410
mkRatLit :: Rational -> TcM TcExpr
411
mkRatLit r
412
  = tcLookupTyCon rationalTyConName 			`thenM` \ rat_tc ->
413
414
415
    let
	rational_ty  = mkGenTyConApp rat_tc []
    in
416
    returnM (HsLit (HsRat r rational_ty))
417
418
419
\end{code}


420
421
422
423
424
%************************************************************************
%*									*
\subsection{Zonking}
%*									*
%************************************************************************
425
426

Zonking makes sure that the instance types are fully zonked,
427
but doesn't do the same for any of the Ids in an Inst.  There's no
428
429
430
need, and it's a lot of extra work.

\begin{code}
431
zonkInst :: Inst -> TcM Inst
432
zonkInst (Dict id pred loc)
433
434
  = zonkTcPredType pred			`thenM` \ new_pred ->
    returnM (Dict id new_pred loc)
435

436
zonkInst (Method m id tys theta tau loc) 
437
  = zonkId id			`thenM` \ new_id ->
438
439
440
441
	-- 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

442
443
444
445
    zonkTcTypes tys		`thenM` \ new_tys ->
    zonkTcThetaType theta	`thenM` \ new_theta ->
    zonkTcType tau		`thenM` \ new_tau ->
    returnM (Method m new_id new_tys new_theta new_tau loc)
446

447
zonkInst (LitInst id lit ty loc)
448
449
  = zonkTcType ty			`thenM` \ new_ty ->
    returnM (LitInst id lit new_ty loc)
450

451
zonkInsts insts = mappM zonkInst insts
452
453
454
\end{code}


455
456
457
458
459
460
%************************************************************************
%*									*
\subsection{Printing}
%*									*
%************************************************************************

461
462
463
464
ToDo: improve these pretty-printing things.  The ``origin'' is really only
relevant in error messages.

\begin{code}
465
instance Outputable Inst where
466
    ppr inst = pprInst inst
sof's avatar
sof committed
467

468
469
470
471
472
473
pprInsts :: [Inst] -> SDoc
pprInsts insts  = parens (sep (punctuate comma (map pprInst insts)))

pprInstsInFull insts
  = vcat (map go insts)
  where
474
    go inst = sep [quotes (ppr inst), nest 2 (pprInstLoc (instLoc inst))]
475

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

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

481
pprInst m@(Method u id tys theta tau loc)
482
  = hsep [ppr id, ptext SLIT("at"), 
483
	  brackets (sep (map pprParendType tys)) {- ,
484
485
	  ptext SLIT("theta"), ppr theta,
	  ptext SLIT("tau"), ppr tau
486
	  show_uniq u,
487
	  ppr (instToId m) -}]
488

489
show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
490

491
492
493
494
tidyInst :: TidyEnv -> Inst -> Inst
tidyInst env (LitInst u lit ty loc) 	     = LitInst u lit (tidyType env ty) loc
tidyInst env (Dict u pred loc)     	     = Dict u (tidyPred env pred) loc
tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
495

496
tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
497
498
-- This function doesn't assume that the tyvars are in scope
-- so it works like tidyOpenType, returning a TidyEnv
499
500
tidyMoreInsts env insts
  = (env', map (tidyInst env') insts)
501
  where
502
503
504
505
    env' = tidyFreeTyVars env (tyVarsOfInsts insts)

tidyInsts :: [Inst] -> (TidyEnv, [Inst])
tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
506

507
showLIE :: SDoc -> TcM ()	-- Debugging
508
509
510
showLIE str
  = do { lie_var <- getLIEVar ;
	 lie <- readMutVar lie_var ;
511
	 traceTc (str <+> pprInstsInFull (lieToList lie)) }
512
513
514
515
516
\end{code}


%************************************************************************
%*									*
517
\subsection{Looking up Insts}
518
519
520
521
%*									*
%************************************************************************

\begin{code}
522
523
data LookupInstResult s
  = NoInstance
524
525
  | SimpleInst TcExpr		-- Just a variable, type application, or literal
  | GenInst    [Inst] TcExpr	-- The expression and its needed insts
526

527
528
529
530
lookupInst :: Inst -> TcM (LookupInstResult s)
-- It's important that lookupInst does not put any new stuff into
-- the LIE.  Instead, any Insts needed by the lookup are returned in
-- the LookupInstResult, where they can be further processed by tcSimplify
531
532


533
-- Dictionaries
534
lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
535
536
  = getDOpts			`thenM` \ dflags ->
    tcGetInstEnv		`thenM` \ inst_env ->
537
    case lookupInstEnv dflags inst_env clas tys of
538

539
      FoundInst tenv dfun_id
540
541
542
543
544
	->	-- It's possible that not all the tyvars are in
		-- the substitution, tenv. For example:
		--	instance C X a => D X where ...
		-- (presumably there's a functional dependency in class C)
		-- Hence the mk_ty_arg to instantiate any un-substituted tyvars.	
545
546
547
548
	   getStage						`thenM` \ use_stage ->
	   checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
			   (topIdLvl dfun_id) use_stage		`thenM_`
	   traceTc (text "lookupInst" <+> ppr dfun_id <+> ppr (topIdLvl dfun_id) <+> ppr use_stage) `thenM_`
549
	   let
550
		(tyvars, rho) = tcSplitForAllTys (idType dfun_id)
551
		mk_ty_arg tv  = case lookupSubstEnv tenv tv of
552
553
554
				   Just (DoneTy ty) -> returnM ty
				   Nothing 	    -> tcInstTyVar VanillaTv tv `thenM` \ tc_tv ->
						       returnM (mkTyVarTy tc_tv)
555
	   in
556
	   mappM mk_ty_arg tyvars	`thenM` \ ty_args ->
557
	   let
558
		dfun_rho   = substTy (mkTyVarSubst tyvars ty_args) rho
559
		(theta, _) = tcSplitPhiTy dfun_rho
560
		ty_app     = mkHsTyApp (HsVar dfun_id) ty_args
561
	   in
562
	   if null theta then
563
		returnM (SimpleInst ty_app)
564
	   else
565
	   newDictsAtLoc loc theta	`thenM` \ dicts ->
566
	   let 
567
		rhs = mkHsDictApp ty_app (map instToId dicts)
568
	   in
569
	   returnM (GenInst dicts rhs)
570

571
      other	-> returnM NoInstance
572

573
lookupInst (Dict _ _ _)         = returnM NoInstance
574
575
576

-- Methods

577
lookupInst inst@(Method _ id tys theta _ loc)
578
579
  = newDictsAtLoc loc theta		`thenM` \ dicts ->
    returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
580
581
582

-- Literals

583
584
585
586
587
-- Look for short cuts first: if the literal is *definitely* a 
-- int, integer, float or a double, generate the real thing here.
-- This is essential  (see nofib/spectral/nucleic).
-- [Same shortcut as in newOverloadedLit, but we
--  may have done some unification by now] 		
sof's avatar
sof committed
588

589

590
591
lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
  | Just expr <- shortCutIntLit i ty
592
  = returnM (GenInst [] expr)	-- GenInst, not SimpleInst, because 
593
					-- expr may be a constructor application
594
595
  | otherwise
  = ASSERT( from_integer_name == fromIntegerName )	-- A LitInst invariant
596
    tcLookupId fromIntegerName			`thenM` \ from_integer ->
597
    tcInstClassOp loc from_integer [ty]		`thenM` \ method_inst ->
598
599
    returnM (GenInst [method_inst]
		     (HsApp (HsVar (instToId method_inst)) (HsLit (HsInteger i))))
600
601


602
lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
603
  | Just expr <- shortCutFracLit f ty
604
  = returnM (GenInst [] expr)
605
606
607

  | otherwise
  = ASSERT( from_rat_name == fromRationalName )	-- A LitInst invariant
608
    tcLookupId fromRationalName			`thenM` \ from_rational ->
609
    tcInstClassOp loc from_rational [ty]	`thenM` \ method_inst ->
610
611
    mkRatLit f					`thenM` \ rat_lit ->
    returnM (GenInst [method_inst] (HsApp (HsVar (instToId method_inst)) rat_lit))
612
613
\end{code}

614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646


%************************************************************************
%*									*
		Re-mappable syntax
%*									*
%************************************************************************


Suppose we are doing the -fno-implicit-prelude thing, and we encounter
a do-expression.  We have to find (>>) in the current environment, which is
done by the rename. Then we have to check that it has the same type as
Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had
this:

  (>>) :: HB m n mn => m a -> n b -> mn b

So the idea is to generate a local binding for (>>), thus:

	let then72 :: forall a b. m a -> m b -> m b
	    then72 = ...something involving the user's (>>)...
	in
	...the do-expression...

Now the do-expression can proceed using then72, which has exactly
the expected type.

In fact tcSyntaxName just generates the RHS for then72, because we only
want an actual binding in the do-expression case. For literals, we can 
just use the expression inline.

\begin{code}
tcSyntaxName :: InstOrigin
647
648
649
	     -> TcType			-- Type to instantiate it at
	     -> Name -> Name 		-- (Standard name, user name)
	     -> TcM (TcExpr, TcType)	-- Suitable expression with its type
650
651
652
653
654
655

-- NB: tcSyntaxName calls tcExpr, and hence can do unification.
-- So we do not call it from lookupInst, which is called from tcSimplify

tcSyntaxName orig ty std_nm user_nm
  | std_nm == user_nm
656
657
  = newMethodFromName orig ty std_nm	`thenM` \ id ->
    returnM (HsVar id, idType id)
658
659

  | otherwise
660
  = tcLookupId std_nm		`thenM` \ std_id ->
661
662
663
    let	
	-- C.f. newMethodAtLoc
	([tv], _, tau)  = tcSplitSigmaTy (idType std_id)
664
 	tau1		= substTyWith [tv] [ty] tau
665
    in
666
667
668
    addErrCtxtM (syntaxNameCtxt user_nm orig tau1)	$
    tcExpr (HsVar user_nm) tau1				`thenM` \ user_fn ->
    returnM (user_fn, tau1)
669
670

syntaxNameCtxt name orig ty tidy_env
671
  = getInstLoc orig		`thenM` \ inst_loc ->
672
673
674
675
676
677
    let
	msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+> 
				ptext SLIT("(needed by a syntactic construct)"),
		    nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
		    nest 2 (pprInstLoc inst_loc)]
    in
678
    returnM (tidy_env, msg)
679
\end{code}