Inst.lhs 27.2 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
	Inst, 
9

10
	pprInstances, pprDictsTheta, pprDictsInFull,	-- User error messages
11
12
	showLIE, pprInst, pprInsts, pprInstInFull,	-- Debugging messages

13
	tidyInsts, tidyMoreInsts,
14

15
	newDicts, newDictsAtLoc, cloneDict, 
16
	shortCutFracLit, shortCutIntLit, newIPDict, 
17
	newMethod, newMethodFromName, newMethodWithGivenTy, 
18
19
	tcInstClassOp, tcInstStupidTheta,
	tcSyntaxName, isHsVar,
20

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

25
	mkInstCoFn, 
26
	lookupInst, LookupInstResult(..), lookupPred, 
27
	tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
28

29
	isDict, isClassDict, isMethod, 
30
	isLinearInst, linearInstType, isIPDict, isInheritableInst,
31
	isTyVarDict, isMethodFor, 
32

33
	zonkInst, zonkInsts,
34
	instToId, instToVar, instName,
35

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

39
#include "HsVersions.h"
40

41
import {-# SOURCE #-}	TcExpr( tcPolyExpr )
42

43
import HsSyn	( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp,
44
45
		  ExprCoFn(..), (<.>), nlHsLit, nlHsVar )
import TcHsSyn	( zonkId )
46
import TcRnMonad
47
import TcEnv	( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
48
49
50
51
import InstEnv	( DFunId, InstEnv, Instance(..), OverlapFlag(..),
		  lookupInstEnv, extendInstEnv, pprInstances, 
		  instanceHead, instanceDFunId, setInstanceDFunId )
import FunDeps	( checkFunDeps )
52
import TcMType	( zonkTcType, zonkTcTypes, zonkTcPredType, zonkTcThetaType, 
53
		  tcInstTyVar, tcInstSkolType
54
		)
55
56
import TcType	( Type, TcType, TcThetaType, TcTyVarSet, TcPredType,
		  BoxyRhoType,
57
		  PredType(..), SkolemInfo(..), typeKind, mkSigmaTy,
58
		  tcSplitForAllTys, applyTys, 
59
		  tcSplitPhiTy, tcSplitDFunHead,
60
		  isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
61
		  mkPredTy, mkTyVarTys,
62
		  tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
63
		  isClassPred, isTyVarClassPred, isLinearPred, 
64
		  getClassPredTys, mkPredName,
65
		  isInheritablePred, isIPPred, 
66
		  tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy, 
67
		  pprPred, pprParendType, pprTheta 
68
		)
69
70
import Type	( TvSubst, substTy, substTyVar, substTyWith, substTheta, zipTopTvSubst,
		  notElemTvSubst, extendTvSubstList )
71
import Unify	( tcMatchTys )
Simon Marlow's avatar
Simon Marlow committed
72
import Module	( modulePackageId )
73
import {- Kind parts of -} Type	( isSubKind )
74
import Coercion ( isEqPred )
Simon Marlow's avatar
Simon Marlow committed
75
import HscTypes	( ExternalPackageState(..), HscEnv(..) )
76
import CoreFVs	( idFreeTyVars )
77
78
import DataCon	( DataCon, dataConStupidTheta, dataConName, 
                  dataConWrapId, dataConUnivTyVars )
79
import Id	( Id, idName, idType, mkUserLocal, mkLocalId, isId )
80
import Name	( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
81
		  isInternalName, setNameUnique )
82
import NameSet	( addOneToNameSet )
83
import Literal	( inIntRange )
84
import Var	( Var, TyVar, tyVarKind, setIdType, mkTyVar )
85
import VarEnv	( TidyEnv, emptyTidyEnv )
86
import VarSet	( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
87
import TysWiredIn ( floatDataCon, doubleDataCon )
88
import PrelNames	( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
89
import BasicTypes( IPName(..), mapIPName, ipNameName )
90
import UniqSupply( uniqsFromSupply )
91
import SrcLoc	( mkSrcSpan, noLoc, unLoc, Located(..) )
Simon Marlow's avatar
Simon Marlow committed
92
import DynFlags	( DynFlag(..), DynFlags(..), dopt )
93
import Maybes	( isJust )
94
import Outputable
95
96
\end{code}

97
98
99
100

Selection
~~~~~~~~~
\begin{code}
101
102
103
mkInstCoFn :: [TcType] -> [Inst] -> ExprCoFn
mkInstCoFn tys dicts = CoApps (map instToId dicts) <.> CoTyApps tys

104
105
106
instName :: Inst -> Name
instName inst = idName (instToId inst)

107
instToId :: Inst -> TcId
108
109
110
111
112
113
114
115
116
117
instToId inst = ASSERT2( isId id, ppr inst ) id 
	      where
		id = instToVar inst

instToVar :: Inst -> Var
instToVar (LitInst nm _ ty _) = mkLocalId nm ty
instToVar (Method id _ _ _ _) = id
instToVar (Dict nm pred _)    
  | isEqPred pred = mkTyVar nm (mkPredTy pred)
  | otherwise	  = mkLocalId nm (mkPredTy pred)
118

119
120
121
instLoc (Dict _ _       loc) = loc
instLoc (Method _ _ _ _ loc) = loc
instLoc (LitInst _ _ _  loc) = loc
122

123
124
125
dictPred (Dict _ pred _ ) = pred
dictPred inst		  = pprPanic "dictPred" (ppr inst)

126
getDictClassTys (Dict _ pred _) = getClassPredTys pred
127

128
-- fdPredsOfInst is used to get predicates that contain functional 
129
130
131
132
133
-- dependencies *or* might do so.  The "might do" part is because
-- a constraint (C a b) might have a superclass with FDs
-- Leaving these in is really important for the call to fdPredsOfInsts
-- in TcSimplify.inferLoop, because the result is fed to 'grow',
-- which is supposed to be conservative
134
135
136
fdPredsOfInst (Dict _ pred _) 	     = [pred]
fdPredsOfInst (Method _ _ _ theta _) = theta
fdPredsOfInst other		     = []	-- LitInsts etc
137
138
139
140

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

141
142
143
isInheritableInst (Dict _ pred _) 	 = isInheritablePred pred
isInheritableInst (Method _ _ _ theta _) = all isInheritablePred theta
isInheritableInst other			 = True
144
145


146
147
148
ipNamesOfInsts :: [Inst] -> [Name]
ipNamesOfInst  :: Inst   -> [Name]
-- Get the implicit parameters mentioned by these Insts
149
-- NB: ?x and %x get different Names
150
151
ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]

152
153
154
ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
ipNamesOfInst (Method _ _ _ theta _)  = [ipNameName n | IParam n _ <- theta]
ipNamesOfInst other		      = []
155

156
tyVarsOfInst :: Inst -> TcTyVarSet
157
158
159
tyVarsOfInst (LitInst _ _ ty _)    = tyVarsOfType  ty
tyVarsOfInst (Dict _ pred _)       = tyVarsOfPred pred
tyVarsOfInst (Method _ id tys _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
160
					 -- The id might have free type variables; in the case of
161
					 -- locally-overloaded class methods, for example
162

163

164
165
tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
166
167
168
169
170
\end{code}

Predicates
~~~~~~~~~~
\begin{code}
171
isDict :: Inst -> Bool
172
isDict (Dict _ _ _) = True
173
isDict other	    = False
174

175
isClassDict :: Inst -> Bool
176
177
178
179
180
181
isClassDict (Dict _ pred _) = isClassPred pred
isClassDict other	    = False

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

183
184
185
186
isIPDict :: Inst -> Bool
isIPDict (Dict _ pred _) = isIPPred pred
isIPDict other		 = False

187
isMethod :: Inst -> Bool
188
189
isMethod (Method {}) = True
isMethod other	     = False
190

191
isMethodFor :: TcIdSet -> Inst -> Bool
192
193
isMethodFor ids (Method uniq id tys _ loc) = id `elemVarSet` ids
isMethodFor ids inst			   = False
194

195
196
197
198
199
200
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
201
	-- See TcExpr.tcId 
202
203
204

linearInstType :: Inst -> TcType	-- %x::t  -->  t
linearInstType (Dict _ (IParam _ ty) _) = ty
205
206
\end{code}

207

208

209
210
211
212
213
%************************************************************************
%*									*
\subsection{Building dictionaries}
%*									*
%************************************************************************
214
215

\begin{code}
216
217
newDicts :: InstOrigin
	 -> TcThetaType
218
	 -> TcM [Inst]
219
newDicts orig theta
220
  = getInstLoc orig		`thenM` \ loc ->
221
    newDictsAtLoc loc theta
222

223
cloneDict :: Inst -> TcM Inst	-- Only used for linear implicit params
224
225
cloneDict (Dict nm ty loc) = newUnique	`thenM` \ uniq ->
			     returnM (Dict (setNameUnique nm uniq) ty loc)
226

227
newDictsAtLoc :: InstLoc -> TcThetaType -> TcM [Inst]
228
229
230
231
232
233
234
235
236
237
238
239
newDictsAtLoc inst_loc theta = mapM (newDictAtLoc inst_loc) theta

{-
newDictOcc :: InstLoc -> TcPredType -> TcM Inst
newDictOcc inst_loc (EqPred ty1 ty2)
  = do	{ unifyType ty1 ty2	-- We insist that they unify right away
	; return ty1 }		-- And return the relexive coercion
-}
newDictAtLoc inst_loc pred
  = do 	{ uniq <- newUnique 
	; let name = mkPredName uniq (instLocSrcLoc inst_loc) pred 
	; return (Dict name pred inst_loc) }
240

241
242
243
-- 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 
244
-- scope, so we make up a new namea.
245
newIPDict :: InstOrigin -> IPName Name -> Type 
246
	  -> TcM (IPName Id, Inst)
247
newIPDict orig ip_name ty
248
  = getInstLoc orig			`thenM` \ inst_loc ->
249
    newUnique				`thenM` \ uniq ->
250
251
    let
	pred = IParam ip_name ty
252
        name = mkPredName uniq (instLocSrcLoc inst_loc) pred 
253
	dict = Dict name pred inst_loc
254
    in
255
    returnM (mapIPName (\n -> instToId dict) ip_name, dict)
256
257
258
\end{code}


259

260
261
262
263
264
265
%************************************************************************
%*									*
\subsection{Building methods (calls of overloaded functions)}
%*									*
%************************************************************************

266

267
\begin{code}
268
269
270
271
272
273
274
275
276
277
278
279
tcInstStupidTheta :: DataCon -> [TcType] -> TcM ()
-- Instantiate the "stupid theta" of the data con, and throw 
-- the constraints into the constraint set
tcInstStupidTheta data_con inst_tys
  | null stupid_theta
  = return ()
  | otherwise
  = do	{ stupid_dicts <- newDicts (OccurrenceOf (dataConName data_con))
				   (substTheta tenv stupid_theta)
	; extendLIEs stupid_dicts }
  where
    stupid_theta = dataConStupidTheta data_con
280
    tenv = zipTopTvSubst (dataConUnivTyVars data_con) inst_tys
281

282
newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
283
newMethodFromName origin ty name
284
  = tcLookupId name		`thenM` \ id ->
285
286
287
288
	-- 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. 
289
290
291
292
    getInstLoc origin		`thenM` \ loc ->
    tcInstClassOp loc id [ty]	`thenM` \ inst ->
    extendLIE inst		`thenM_`
    returnM (instToId inst)
293

294
295
296
297
newMethodWithGivenTy orig id tys
  = getInstLoc orig		`thenM` \ loc ->
    newMethod loc id tys	`thenM` \ inst ->
    extendLIE inst		`thenM_`
298
    returnM (instToId inst)
299
300

--------------------------------------------
301
-- tcInstClassOp, and newMethod do *not* drop the 
302
303
304
-- Inst into the LIE; they just returns the Inst
-- This is important because they are used by TcSimplify
-- to simplify Insts
305

306
307
308
309
310
-- NB: the kind of the type variable to be instantiated
--     might be a sub-kind of the type to which it is applied,
--     notably when the latter is a type variable of kind ??
--     Hence the call to checkKind
-- A worry: is this needed anywhere else?
311
312
313
tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
tcInstClassOp inst_loc sel_id tys
  = let
314
	(tyvars, _rho) = tcSplitForAllTys (idType sel_id)
315
    in
316
    zipWithM_ checkKind tyvars tys	`thenM_` 
317
    newMethod inst_loc sel_id tys
318

319
320
321
checkKind :: TyVar -> TcType -> TcM ()
-- Ensure that the type has a sub-kind of the tyvar
checkKind tv ty
322
323
  = do	{ let ty1 = ty 
		-- ty1 <- zonkTcType ty
324
325
	; if typeKind ty1 `isSubKind` tyVarKind tv
	  then return ()
326
327
328
329
330
331
332
333
	  else 

    pprPanic "checkKind: adding kind constraint" 
	     (vcat [ppr tv <+> ppr (tyVarKind tv), 
	            ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
	}
--    do	{ tv1 <- tcInstTyVar tv
--	; unifyType ty1 (mkTyVarTy tv1) } }
334
335


336
---------------------------
337
newMethod inst_loc id tys
338
  = newUnique		`thenM` \ new_uniq ->
339
    let
340
341
342
343
	(theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
	meth_id	    = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
	inst        = Method meth_id id tys theta inst_loc
	loc         = instLocSrcLoc inst_loc
344
    in
345
    returnM inst
346
347
348
\end{code}

\begin{code}
349
shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
350
shortCutIntLit i ty
351
  | isIntTy ty && inIntRange i 		-- Short cut for Int
352
  = Just (HsLit (HsInt i))
353
  | isIntegerTy ty 			-- Short cut for Integer
354
  = Just (HsLit (HsInteger i ty))
355
  | otherwise = Nothing
356

357
shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
358
359
shortCutFracLit f ty
  | isFloatTy ty 
360
  = Just (mk_lit floatDataCon (HsFloatPrim f))
361
  | isDoubleTy ty
362
  = Just (mk_lit doubleDataCon (HsDoublePrim f))
363
  | otherwise = Nothing
364
365
  where
    mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
366

367
mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
368
369
mkIntegerLit i
  = tcMetaTy integerTyConName 	`thenM` \ integer_ty ->
370
371
    getSrcSpanM			`thenM` \ span -> 
    returnM (L span $ HsLit (HsInteger i integer_ty))
372

373
mkRatLit :: Rational -> TcM (LHsExpr TcId)
374
mkRatLit r
375
  = tcMetaTy rationalTyConName 	`thenM` \ rat_ty ->
376
377
    getSrcSpanM			`thenM` \ span -> 
    returnM (L span $ HsLit (HsRat r rat_ty))
378
379
380
381

isHsVar :: HsExpr Name -> Name -> Bool
isHsVar (HsVar f) g = f==g
isHsVar other 	  g = False
382
383
384
\end{code}


385
386
387
388
389
%************************************************************************
%*									*
\subsection{Zonking}
%*									*
%************************************************************************
390

391
Zonking makes sure that the instance types are fully zonked.
392
393

\begin{code}
394
zonkInst :: Inst -> TcM Inst
395
zonkInst (Dict name pred loc)
396
  = zonkTcPredType pred			`thenM` \ new_pred ->
397
    returnM (Dict name new_pred loc)
398

399
zonkInst (Method m id tys theta loc) 
400
  = zonkId id			`thenM` \ new_id ->
401
402
403
404
	-- 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

405
406
    zonkTcTypes tys		`thenM` \ new_tys ->
    zonkTcThetaType theta	`thenM` \ new_theta ->
407
    returnM (Method m new_id new_tys new_theta loc)
408

409
zonkInst (LitInst nm lit ty loc)
410
  = zonkTcType ty			`thenM` \ new_ty ->
411
    returnM (LitInst nm lit new_ty loc)
412

413
zonkInsts insts = mappM zonkInst insts
414
415
416
\end{code}


417
418
419
420
421
422
%************************************************************************
%*									*
\subsection{Printing}
%*									*
%************************************************************************

423
424
425
426
ToDo: improve these pretty-printing things.  The ``origin'' is really only
relevant in error messages.

\begin{code}
427
instance Outputable Inst where
428
    ppr inst = pprInst inst
sof's avatar
sof committed
429

430
431
432
pprDictsTheta :: [Inst] -> SDoc
-- Print in type-like fashion (Eq a, Show b)
pprDictsTheta dicts = pprTheta (map dictPred dicts)
433

434
435
436
437
pprDictsInFull :: [Inst] -> SDoc
-- Print in type-like fashion, but with source location
pprDictsInFull dicts 
  = vcat (map go dicts)
438
  where
439
    go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))]
440

441
442
443
pprInsts :: [Inst] -> SDoc
-- Debugging: print the evidence :: type
pprInsts insts  = brackets (interpp'SP insts)
sof's avatar
sof committed
444

445
446
pprInst, pprInstInFull :: Inst -> SDoc
-- Debugging: print the evidence :: type
447
448
pprInst (LitInst nm lit ty loc) = ppr nm <+> dcolon <+> ppr ty
pprInst (Dict nm pred loc)      = ppr nm <+> dcolon <+> pprPred pred
sof's avatar
sof committed
449

450
pprInst m@(Method inst_id id tys theta loc)
451
452
453
  = ppr inst_id <+> dcolon <+> 
	braces (sep [ppr id <+> ptext SLIT("at"),
		     brackets (sep (map pprParendType tys))])
454

455
456
pprInstInFull inst
  = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
457

458
tidyInst :: TidyEnv -> Inst -> Inst
459
460
461
tidyInst env (LitInst nm lit ty loc) 	 = LitInst nm lit (tidyType env ty) loc
tidyInst env (Dict nm pred loc)     	 = Dict nm (tidyPred env pred) loc
tidyInst env (Method u id tys theta loc) = Method u id (tidyTypes env tys) theta loc
462

463
tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
464
465
-- This function doesn't assume that the tyvars are in scope
-- so it works like tidyOpenType, returning a TidyEnv
466
467
tidyMoreInsts env insts
  = (env', map (tidyInst env') insts)
468
  where
469
470
471
472
    env' = tidyFreeTyVars env (tyVarsOfInsts insts)

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

474
showLIE :: SDoc -> TcM ()	-- Debugging
475
476
477
showLIE str
  = do { lie_var <- getLIEVar ;
	 lie <- readMutVar lie_var ;
478
	 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
479
480
481
\end{code}


482
483
484
485
486
487
488
%************************************************************************
%*									*
	Extending the instance environment
%*									*
%************************************************************************

\begin{code}
489
tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
490
491
492
493
  -- Add new locally-defined instances
tcExtendLocalInstEnv dfuns thing_inside
 = do { traceDFuns dfuns
      ; env <- getGblEnv
494
      ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
495
496
497
      ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
			 tcg_inst_env = inst_env' }
      ; setGblEnv env' thing_inside }
498

499
addLocalInst :: InstEnv -> Instance -> TcM InstEnv
500
501
-- Check that the proposed new instance is OK, 
-- and then add it to the home inst env
502
addLocalInst home_ie ispec
503
504
  = do	{ 	-- Instantiate the dfun type so that we extend the instance
		-- envt with completely fresh template variables
505
506
507
		-- This is important because the template variables must
		-- not overlap with anything in the things being looked up
		-- (since we do unification).  
508
		-- We use tcInstSkolType because we don't want to allocate fresh
509
		--  *meta* type variables.  
510
	  let dfun = instanceDFunId ispec
511
	; (tvs', theta', tau') <- tcInstSkolType (InstSkol dfun) (idType dfun)
512
513
	; let	(cls, tys') = tcSplitDFunHead tau'
		dfun' 	    = setIdType dfun (mkSigmaTy tvs' theta' tau')	    
514
	  	ispec'      = setInstanceDFunId ispec dfun'
515
516

		-- Load imported instances, so that we report
517
		-- duplicates correctly
518
519
	; eps <- getEps
	; let inst_envs = (eps_inst_env eps, home_ie)
520
521

		-- Check functional dependencies
522
523
	; case checkFunDeps inst_envs ispec' of
		Just specs -> funDepErr ispec' specs
524
		Nothing    -> return ()
525
526

		-- Check for duplicate instance decls
527
528
529
530
531
532
533
534
535
536
	; let { (matches, _) = lookupInstEnv inst_envs cls tys'
	      ;	dup_ispecs = [ dup_ispec 
			     | (_, dup_ispec) <- matches
			     , let (_,_,_,dup_tys) = instanceHead dup_ispec
			     , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
		-- Find memebers of the match list which ispec itself matches.
		-- If the match is 2-way, it's a duplicate
	; case dup_ispecs of
	    dup_ispec : _ -> dupInstErr ispec' dup_ispec
	    []            -> return ()
537
538

		-- OK, now extend the envt
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
	; return (extendInstEnv home_ie ispec') }

getOverlapFlag :: TcM OverlapFlag
getOverlapFlag 
  = do 	{ dflags <- getDOpts
	; let overlap_ok    = dopt Opt_AllowOverlappingInstances dflags
	      incoherent_ok = dopt Opt_AllowIncoherentInstances  dflags
	      overlap_flag | incoherent_ok = Incoherent
			   | overlap_ok    = OverlapOk
			   | otherwise     = NoOverlap
			   
	; return overlap_flag }

traceDFuns ispecs
  = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
554
  where
555
556
    pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
	-- Print the dfun name itself too
557

558
559
funDepErr ispec ispecs
  = addDictLoc ispec $
560
    addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
561
562
563
	       2 (pprInstances (ispec:ispecs)))
dupInstErr ispec dup_ispec
  = addDictLoc ispec $
564
    addErr (hang (ptext SLIT("Duplicate instance declarations:"))
565
	       2 (pprInstances [ispec, dup_ispec]))
566

567
addDictLoc ispec thing_inside
568
  = setSrcSpan (mkSrcSpan loc loc) thing_inside
569
  where
570
   loc = getSrcLoc ispec
571
\end{code}
572
    
573

574
575
%************************************************************************
%*									*
576
\subsection{Looking up Insts}
577
578
579
580
%*									*
%************************************************************************

\begin{code}
581
data LookupInstResult
582
  = NoInstance
583
584
  | SimpleInst (LHsExpr TcId)		-- Just a variable, type application, or literal
  | GenInst    [Inst] (LHsExpr TcId)	-- The expression and its needed insts
585

586
lookupInst :: Inst -> TcM LookupInstResult
587
588
589
-- 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
590
591
592
593


-- Methods

594
lookupInst inst@(Method _ id tys theta loc)
595
596
597
  = do	{ dicts <- newDictsAtLoc loc theta
	; let co_fn = mkInstCoFn tys dicts
	; return (GenInst dicts (L span $ HsCoerce co_fn (HsVar id))) }
598
599
  where
    span = instLocSrcSpan loc
600
601
602

-- Literals

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

609
lookupInst inst@(LitInst _nm (HsIntegral i from_integer_name) ty loc)
610
  | Just expr <- shortCutIntLit i ty
611
  = returnM (GenInst [] (noLoc expr))	-- GenInst, not SimpleInst, because 
612
					-- expr may be a constructor application
613
  | otherwise
614
  = ASSERT( from_integer_name `isHsVar` fromIntegerName )	-- A LitInst invariant
615
    tcLookupId fromIntegerName			`thenM` \ from_integer ->
616
    tcInstClassOp loc from_integer [ty]		`thenM` \ method_inst ->
617
    mkIntegerLit i				`thenM` \ integer_lit ->
618
    returnM (GenInst [method_inst]
619
620
		     (mkHsApp (L (instLocSrcSpan loc)
			   	 (HsVar (instToId method_inst))) integer_lit))
621

622
lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc)
623
  | Just expr <- shortCutFracLit f ty
624
  = returnM (GenInst [] (noLoc expr))
625
626

  | otherwise
627
  = ASSERT( from_rat_name `isHsVar` fromRationalName )	-- A LitInst invariant
628
    tcLookupId fromRationalName			`thenM` \ from_rational ->
629
    tcInstClassOp loc from_rational [ty]	`thenM` \ method_inst ->
630
    mkRatLit f					`thenM` \ rat_lit ->
631
632
    returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc) 
					       (HsVar (instToId method_inst))) rat_lit))
633
634

-- Dictionaries
635
636
637
638
639
lookupInst (Dict _ pred loc)
  = do 	{ mb_result <- lookupPred pred
	; case mb_result of {
	    Nothing -> return NoInstance ;
	    Just (tenv, dfun_id) -> do
640

641
    -- tenv is a substitution that instantiates the dfun_id 
642
643
644
645
646
647
648
    -- to match the requested result type.   
    -- 
    -- We ASSUME that the dfun is quantified over the very same tyvars 
    -- that are bound by the tenv.
    -- 
    -- However, the dfun
    -- might have some tyvars that *only* appear in arguments
649
650
651
    --	dfun :: forall a b. C a b, Ord b => D [a]
    -- We instantiate b to a flexi type variable -- it'll presumably
    -- become fixed later via functional dependencies
652
653
654
    { use_stage <- getStage
    ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
    		      (topIdLvl dfun_id) use_stage
655

656
657
658
659
 	-- 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)
660
	-- Hence the open_tvs to instantiate any un-substituted tyvars.	
661
662
663
664
    ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
	  open_tvs      = filter (`notElemTvSubst` tenv) tyvars
    ; open_tvs' <- mappM tcInstTyVar open_tvs
    ; let
665
 	tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
666
		-- Since the open_tvs' are freshly made, they cannot possibly be captured by
667
668
		-- any nested for-alls in rho.  So the in-scope set is unchanged
    	dfun_rho   = substTy tenv' rho
669
    	(theta, _) = tcSplitPhiTy dfun_rho
670
671
672
	src_loc	   = instLocSrcSpan loc
	dfun	   = HsVar dfun_id
	tys	   = map (substTyVar tenv') tyvars
673
    ; if null theta then
674
    	returnM (SimpleInst (L src_loc $ HsCoerce (CoTyApps tys) dfun))
675
676
      else do
    { dicts <- newDictsAtLoc loc theta
677
678
    ; let co_fn = mkInstCoFn tys dicts
    ; returnM (GenInst dicts (L src_loc $ HsCoerce co_fn dfun))
679
680
681
682
683
684
    }}}}

---------------
lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
-- Look up a class constraint in the instance environment
lookupPred pred@(ClassP clas tys)
685
  = do	{ eps     <- getEps
686
	; tcg_env <- getGblEnv
687
688
689
690
691
	; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
	; case lookupInstEnv inst_envs clas tys of {
	    ([(tenv, ispec)], []) 
		-> do	{ let dfun_id = is_dfun ispec
			; traceTc (text "lookupInst success" <+> 
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
				   vcat [text "dict" <+> ppr pred, 
				         text "witness" <+> ppr dfun_id
					 <+> ppr (idType dfun_id) ])
				-- Record that this dfun is needed
			; record_dfun_usage dfun_id
			; return (Just (tenv, dfun_id)) } ;

     	    (matches, unifs)
		-> do	{ traceTc (text "lookupInst fail" <+> 
				   vcat [text "dict" <+> ppr pred,
				   	 text "matches" <+> ppr matches,
				   	 text "unifs" <+> ppr unifs])
		-- In the case of overlap (multiple matches) we report
		-- NoInstance here.  That has the effect of making the 
		-- context-simplifier return the dict as an irreducible one.
		-- Then it'll be given to addNoInstanceErrs, which will do another
		-- lookupInstEnv to get the detailed info about what went wrong.
			; return Nothing }
	}}

lookupPred ip_pred = return Nothing

record_dfun_usage dfun_id 
Simon Marlow's avatar
Simon Marlow committed
715
  = do	{ hsc_env <- getTopEnv
716
717
	; let  dfun_name = idName dfun_id
	       dfun_mod  = nameModule dfun_name
718
	; if isInternalName dfun_name ||    -- Internal name => defined in this module
Simon Marlow's avatar
Simon Marlow committed
719
	     modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
720
721
722
723
724
	  then return () -- internal, or in another package
	   else do { tcg_env <- getGblEnv
	  	   ; updMutVar (tcg_inst_uses tcg_env)
			       (`addOneToNameSet` idName dfun_id) }}

725
726

tcGetInstEnvs :: TcM (InstEnv, InstEnv)
727
728
-- Gets both the external-package inst-env
-- and the home-pkg inst env (includes module being compiled)
729
tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
730
		     return (eps_inst_env eps, tcg_inst_env env) }
731
732
\end{code}

733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764


%************************************************************************
%*									*
		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
765
	     -> TcType			-- Type to instantiate it at
766
767
	     -> (Name, HsExpr Name)	-- (Standard name, user name)
	     -> TcM (Name, HsExpr TcId)	-- (Standard name, suitable expression)
768
--	*** NOW USED ONLY FOR CmdTop (sigh) ***
769
770
771
-- NB: tcSyntaxName calls tcExpr, and hence can do unification.
-- So we do not call it from lookupInst, which is called from tcSimplify

772
tcSyntaxName orig ty (std_nm, HsVar user_nm)
773
  | std_nm == user_nm
774
775
  = newMethodFromName orig ty std_nm	`thenM` \ id ->
    returnM (std_nm, HsVar id)
776

777
tcSyntaxName orig ty (std_nm, user_nm_expr)
778
  = tcLookupId std_nm		`thenM` \ std_id ->
779
780
781
    let	
	-- C.f. newMethodAtLoc
	([tv], _, tau)  = tcSplitSigmaTy (idType std_id)
782
 	sigma1		= substTyWith [tv] [ty] tau
783
784
	-- Actually, the "tau-type" might be a sigma-type in the
	-- case of locally-polymorphic methods.
785
    in
786
    addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1)	$
787
788

	-- Check that the user-supplied thing has the
789
790
791
	-- same type as the standard one.  
	-- Tiresome jiggling because tcCheckSigma takes a located expression
    getSrcSpanM					`thenM` \ span -> 
792
    tcPolyExpr (L span user_nm_expr) sigma1	`thenM` \ expr ->
793
    returnM (std_nm, unLoc expr)
794
795

syntaxNameCtxt name orig ty tidy_env
796
  = getInstLoc orig		`thenM` \ inst_loc ->
797
798
799
800
801
802
    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
803
    returnM (tidy_env, msg)
804
\end{code}