Inst.lhs 36.1 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
%
Simon Marlow's avatar
Simon Marlow committed
5
6

The @Inst@ type: dictionaries or method instances
7
8

\begin{code}
9
{-# OPTIONS -w #-}
10
11
12
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
13
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
14
15
-- for details

16
module Inst ( 
17
	Inst, 
18

19
	pprInstances, pprDictsTheta, pprDictsInFull,	-- User error messages
20
21
	showLIE, pprInst, pprInsts, pprInstInFull,	-- Debugging messages

22
	tidyInsts, tidyMoreInsts,
23

24
25
26
	newDictBndr, newDictBndrs, newDictBndrsO,
	instCall, instStupidTheta,
	cloneDict, 
27
	shortCutFracLit, shortCutIntLit, shortCutStringLit, newIPDict, 
28
	newMethod, newMethodFromName, newMethodWithGivenTy, 
29
	tcInstClassOp, 
30
	tcSyntaxName, isHsVar,
31

32
	tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, 
33
	ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
34
	getDictClassTys, dictPred,
35

36
	lookupSimpleInst, LookupInstResult(..), 
37
	tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
38

39
	isAbstractableInst, isEqInst,
40
41
	isDict, isClassDict, isMethod, isImplicInst,
	isIPDict, isInheritableInst, isMethodOrLit,
42
	isTyVarDict, isMethodFor, 
43

44
	zonkInst, zonkInsts,
45
46
	instToId, instToVar, instType, instName, instToDictBind,
	addInstToDictBind,
47

48
49
50
51
	InstOrigin(..), InstLoc, pprInstLoc,

	mkWantedCo, mkGivenCo,
	fromWantedCo, fromGivenCo,
52
	eitherEqInst, mkEqInst, mkEqInsts, mkWantedEqInst,
53
54
	finalizeEqInst, writeWantedCoercion,
	eqInstType, updateEqInstCoercion,
55
	eqInstCoercion,	eqInstTys
56
57
    ) where

58
#include "HsVersions.h"
59

60
import {-# SOURCE #-}	TcExpr( tcPolyExpr )
61
import {-# SOURCE #-}	TcUnify( boxyUnify, unifyType )
62

63
import FastString(FastString)
Simon Marlow's avatar
Simon Marlow committed
64
65
import HsSyn
import TcHsSyn
66
import TcRnMonad
Simon Marlow's avatar
Simon Marlow committed
67
68
69
70
71
72
import TcEnv
import InstEnv
import FunDeps
import TcMType
import TcType
import Type
73
74
import TypeRep
import Class
Simon Marlow's avatar
Simon Marlow committed
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
import Unify
import Module
import Coercion
import HscTypes
import CoreFVs
import DataCon
import Id
import Name
import NameSet
import Literal
import Var      ( Var, TyVar )
import qualified Var
import VarEnv
import VarSet
import TysWiredIn
import PrelNames
import BasicTypes
import SrcLoc
import DynFlags
94
import Bag
Simon Marlow's avatar
Simon Marlow committed
95
import Maybes
96
import Util
97
import Unique
98
import Outputable
99
import Data.List
100
101
import TypeRep
import Class
102
103

import Control.Monad ( liftM )
104
105
\end{code}

106
107
108
109

Selection
~~~~~~~~~
\begin{code}
110
instName :: Inst -> Name
111
instName (EqInst {tci_name = name}) = name
112
instName inst = Var.varName (instToVar inst)
113

114
instToId :: Inst -> TcId
115
116
instToId inst = WARN( not (isId id), ppr inst ) 
	      id 
117
118
119
120
	      where
		id = instToVar inst

instToVar :: Inst -> Var
121
122
123
124
125
instToVar (LitInst {tci_name = nm, tci_ty = ty})
  = mkLocalId nm ty
instToVar (Method {tci_id = id}) 
  = id
instToVar (Dict {tci_name = nm, tci_pred = pred})    
126
  | isEqPred pred = Var.mkCoVar nm (mkPredTy pred)
127
  | otherwise	  = mkLocalId nm (mkPredTy pred)
128
129
130
instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens,
		       tci_wanted = wanteds})
  = mkLocalId nm (mkImplicTy tvs givens wanteds)
131
132
instToVar i@(EqInst {})
  = eitherEqInst i id (\(TyVarTy covar) -> covar)
133
134

instType :: Inst -> Type
135
136
instType (LitInst {tci_ty = ty})  = ty
instType (Method {tci_id = id})   = idType id
137
138
139
instType (Dict {tci_pred = pred}) = mkPredTy pred
instType imp@(ImplicInst {})      = mkImplicTy (tci_tyvars imp) (tci_given imp)	
					       (tci_wanted imp)
140
141
-- instType i@(EqInst {tci_co = co}) = eitherEqInst i TyVarTy id
instType (EqInst {tci_left = ty1, tci_right = ty2}) = mkPredTy (EqPred ty1 ty2)
142
143

mkImplicTy tvs givens wanteds	-- The type of an implication constraint
144
  = ASSERT( all isAbstractableInst givens )
simonpj@microsoft.com's avatar
q    
simonpj@microsoft.com committed
145
    -- pprTrace "mkImplicTy" (ppr givens) $
146
147
148
149
150
151
152
153
154
    -- See [Equational Constraints in Implication Constraints]
    let dict_wanteds = filter (not . isEqInst) wanteds
    in 
      mkForAllTys tvs $ 
      mkPhiTy (map dictPred givens) $
      if isSingleton dict_wanteds then
  	instType (head dict_wanteds) 
      else
  	mkTupleTy Boxed (length dict_wanteds) (map instType dict_wanteds)
155

156
dictPred (Dict {tci_pred = pred}) = pred
157
dictPred (EqInst {tci_left=ty1,tci_right=ty2}) = EqPred ty1 ty2
158
dictPred inst		          = pprPanic "dictPred" (ppr inst)
159

160
161
getDictClassTys (Dict {tci_pred = pred}) = getClassPredTys pred
getDictClassTys inst		         = pprPanic "getDictClassTys" (ppr inst)
162

163
-- fdPredsOfInst is used to get predicates that contain functional 
164
165
166
167
168
-- 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
169
170
171
172
173
fdPredsOfInst (Dict {tci_pred = pred}) 	     = [pred]
fdPredsOfInst (Method {tci_theta = theta})   = theta
fdPredsOfInst (ImplicInst {tci_given = gs, 
			   tci_wanted = ws}) = fdPredsOfInsts (gs ++ ws)
fdPredsOfInst (LitInst {})		     = []
174
fdPredsOfInst (EqInst {})		     = []
175
176
177
178

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

179
180
181
isInheritableInst (Dict {tci_pred = pred})     = isInheritablePred pred
isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta
isInheritableInst other			       = True
182
183


184
185
186
187
---------------------------------
-- Get the implicit parameters mentioned by these Insts
-- NB: the results of these functions are insensitive to zonking

188
189
190
191
ipNamesOfInsts :: [Inst] -> [Name]
ipNamesOfInst  :: Inst   -> [Name]
ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]

192
193
194
ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
ipNamesOfInst (Method {tci_theta = theta})   = [ipNameName n | IParam n _ <- theta]
ipNamesOfInst other		    	     = []
195

196
---------------------------------
197
tyVarsOfInst :: Inst -> TcTyVarSet
198
199
tyVarsOfInst (LitInst {tci_ty = ty})  = tyVarsOfType  ty
tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
200
tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id
201
202
				 -- The id might have free type variables; in the case of
				 -- locally-overloaded class methods, for example
203
tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds})
204
205
206
207
  = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds) 
    `minusVarSet` mkVarSet tvs
    `unionVarSet` unionVarSets (map varTypeTyVars tvs)
		-- Remember the free tyvars of a coercion
208
tyVarsOfInst (EqInst {tci_left = ty1, tci_right = ty2}) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
209

210
211
tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
212
213
214
215
216
217
218
219
220


--------------------------
instToDictBind :: Inst -> LHsExpr TcId -> TcDictBinds
instToDictBind inst rhs 
  = unitBag (L (instSpan inst) (VarBind (instToId inst) rhs))

addInstToDictBind :: TcDictBinds -> Inst -> LHsExpr TcId -> TcDictBinds
addInstToDictBind binds inst rhs = binds `unionBags` instToDictBind inst rhs
221
222
223
224
225
\end{code}

Predicates
~~~~~~~~~~
\begin{code}
226
227
228
229
230
231
232
233

isAbstractableInst :: Inst -> Bool
isAbstractableInst inst = isDict inst || isEqInst inst

isEqInst :: Inst -> Bool
isEqInst (EqInst {}) = True
isEqInst other       = False

234
isDict :: Inst -> Bool
235
236
isDict (Dict {}) = True
isDict other	 = False
237

238
isClassDict :: Inst -> Bool
239
240
isClassDict (Dict {tci_pred = pred}) = isClassPred pred
isClassDict other	    	     = False
241
242

isTyVarDict :: Inst -> Bool
243
244
isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
isTyVarDict other	    	     = False
245

246
isIPDict :: Inst -> Bool
247
248
isIPDict (Dict {tci_pred = pred}) = isIPPred pred
isIPDict other		 	  = False
249

250
251
252
isImplicInst (ImplicInst {}) = True
isImplicInst other 	     = False

253
isMethod :: Inst -> Bool
254
255
isMethod (Method {}) = True
isMethod other	     = False
256

257
isMethodFor :: TcIdSet -> Inst -> Bool
258
259
isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
isMethodFor ids inst			= False
260

261
262
263
264
265
isMethodOrLit :: Inst -> Bool
isMethodOrLit (Method {})  = True
isMethodOrLit (LitInst {}) = True
isMethodOrLit other        = False
\end{code}
266

267

268
269
270
271
272
%************************************************************************
%*									*
\subsection{Building dictionaries}
%*									*
%************************************************************************
273

274
275
276
-- newDictBndrs makes a dictionary at a binding site
-- instCall makes a dictionary at an occurrence site
--	and throws it into the LIE
277

278
279
280
281
282
\begin{code}
----------------
newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
newDictBndrsO orig theta = do { loc <- getInstLoc orig
			      ; newDictBndrs loc theta }
283

284
285
newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
286

287
newDictBndr :: InstLoc -> TcPredType -> TcM Inst
288
289
290
291
292
293
294
295
296
newDictBndr inst_loc pred@(EqPred ty1 ty2)
  = do { uniq <- newUnique 
	; let name = mkPredName uniq inst_loc pred 
	; return (EqInst {tci_name  = name, 
			  tci_loc   = inst_loc, 
			  tci_left  = ty1, 
			  tci_right = ty2, 
			  tci_co    = mkGivenCo $ TyVarTy (Var.mkCoVar name (PredTy pred))})
       }
297
newDictBndr inst_loc pred
298
  = do 	{ uniq <- newUnique 
299
	; let name = mkPredName uniq inst_loc pred 
300
	; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
301

302
----------------
303
instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
304
305
306
307
-- Instantiate the constraints of a call
--	(instCall o tys theta)
-- (a) Makes fresh dictionaries as necessary for the constraints (theta)
-- (b) Throws these dictionaries into the LIE
308
-- (c) Returns an HsWrapper ([.] tys dicts)
309
310
311

instCall orig tys theta 
  = do	{ loc <- getInstLoc orig
312
	; dict_app <- instCallDicts loc theta
313
	; return (dict_app <.> mkWpTyApps tys) }
314
315
316
317
318
319
320

----------------
instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
-- Similar to instCall, but only emit the constraints in the LIE
-- Used exclusively for the 'stupid theta' of a data constructor
instStupidTheta orig theta
  = do	{ loc <- getInstLoc orig
321
322
	; _co <- instCallDicts loc theta	-- Discard the coercion
	; return () }
323
324

----------------
325
326
327
instCallDicts :: InstLoc -> TcThetaType -> TcM HsWrapper
-- Instantiates the TcTheta, puts all constraints thereby generated
-- into the LIE, and returns a HsWrapper to enclose the call site.
328
329
-- This is the key place where equality predicates 
-- are unleashed into the world
330
331
332
333
334
335
336
337
338
339
instCallDicts loc [] = return idHsWrapper

-- instCallDicts loc (EqPred ty1 ty2 : preds)
--   = do  { unifyType ty1 ty2	-- For now, we insist that they unify right away 
-- 				-- Later on, when we do associated types, 
-- 				-- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
-- 	; (dicts, co_fn) <- instCallDicts loc preds
-- 	; return (dicts, co_fn <.> WpTyApp ty1) }
-- 	-- We use type application to apply the function to the 
-- 	-- coercion; here ty1 *is* the appropriate identity coercion
340
341

instCallDicts loc (EqPred ty1 ty2 : preds)
342
343
344
345
346
347
  = do  { traceTc (text "instCallDicts" <+> ppr (EqPred ty1 ty2))
	; coi <- boxyUnify ty1 ty2
--	; coi <- unifyType ty1 ty2
	; let co = fromCoI coi ty1
	; co_fn <- instCallDicts loc preds
	; return (co_fn <.> WpTyApp co) }
348
349
350

instCallDicts loc (pred : preds)
  = do	{ uniq <- newUnique
351
	; let name = mkPredName uniq loc pred 
352
	      dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
353
354
355
	; extendLIE dict
	; co_fn <- instCallDicts loc preds
	; return (co_fn <.> WpApp (instToId dict)) }
356
357

-------------
358
cloneDict :: Inst -> TcM Inst
359
360
cloneDict dict@(Dict nm ty loc) = do { uniq <- newUnique
				     ; return (dict {tci_name = setNameUnique nm uniq}) }
361
cloneDict eq@(EqInst {})	= return eq
362
cloneDict other = pprPanic "cloneDict" (ppr other)
363

364
365
366
-- 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 
367
-- scope, so we make up a new namea.
368
newIPDict :: InstOrigin -> IPName Name -> Type 
369
	  -> TcM (IPName Id, Inst)
370
newIPDict orig ip_name ty
371
  = getInstLoc orig			`thenM` \ inst_loc ->
372
    newUnique				`thenM` \ uniq ->
373
374
    let
	pred = IParam ip_name ty
375
        name = mkPredName uniq inst_loc pred 
376
	dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}
377
    in
378
    returnM (mapIPName (\n -> instToId dict) ip_name, dict)
379
380
381
\end{code}


382
383
384
\begin{code}
mkPredName :: Unique -> InstLoc -> PredType -> Name
mkPredName uniq loc pred_ty
385
  = mkInternalName uniq occ (instLocSpan loc)
386
387
  where
    occ = case pred_ty of
388
389
390
391
	    ClassP cls _ -> mkDictOcc (getOccName cls)
	    IParam ip  _ -> getOccName (ipNameName ip)
	    EqPred ty  _ -> mkEqPredCoOcc baseOcc
	      where
392
393
		-- we use the outermost tycon of the lhs, if there is one, to
		-- improve readability of Core code
394
	        baseOcc = case splitTyConApp_maybe ty of
395
			    Nothing      -> mkOccName tcName "$"
396
                            Just (tc, _) -> getOccName tc
397
\end{code}
398

399
400
401
402
403
404
%************************************************************************
%*									*
\subsection{Building methods (calls of overloaded functions)}
%*									*
%************************************************************************

405

406
\begin{code}
407
newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
408
newMethodFromName origin ty name
409
  = tcLookupId name		`thenM` \ id ->
410
411
412
413
	-- 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. 
414
415
416
417
    getInstLoc origin		`thenM` \ loc ->
    tcInstClassOp loc id [ty]	`thenM` \ inst ->
    extendLIE inst		`thenM_`
    returnM (instToId inst)
418

419
420
421
422
newMethodWithGivenTy orig id tys
  = getInstLoc orig		`thenM` \ loc ->
    newMethod loc id tys	`thenM` \ inst ->
    extendLIE inst		`thenM_`
423
    returnM (instToId inst)
424
425

--------------------------------------------
426
-- tcInstClassOp, and newMethod do *not* drop the 
427
428
429
-- Inst into the LIE; they just returns the Inst
-- This is important because they are used by TcSimplify
-- to simplify Insts
430

431
432
433
434
435
-- 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?
436
437
438
tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
tcInstClassOp inst_loc sel_id tys
  = let
439
	(tyvars, _rho) = tcSplitForAllTys (idType sel_id)
440
    in
441
    zipWithM_ checkKind tyvars tys	`thenM_` 
442
    newMethod inst_loc sel_id tys
443

444
445
446
checkKind :: TyVar -> TcType -> TcM ()
-- Ensure that the type has a sub-kind of the tyvar
checkKind tv ty
447
448
  = do	{ let ty1 = ty 
		-- ty1 <- zonkTcType ty
Simon Marlow's avatar
Simon Marlow committed
449
	; if typeKind ty1 `isSubKind` Var.tyVarKind tv
450
	  then return ()
451
452
453
	  else 

    pprPanic "checkKind: adding kind constraint" 
Simon Marlow's avatar
Simon Marlow committed
454
	     (vcat [ppr tv <+> ppr (Var.tyVarKind tv), 
455
456
457
458
	            ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
	}
--    do	{ tv1 <- tcInstTyVar tv
--	; unifyType ty1 (mkTyVarTy tv1) } }
459
460


461
---------------------------
462
newMethod inst_loc id tys
463
  = newUnique		`thenM` \ new_uniq ->
464
    let
465
466
	(theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
	meth_id	    = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
467
468
	inst        = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
			      tci_theta = theta, tci_loc = inst_loc}
469
	loc         = instLocSpan inst_loc
470
    in
471
    returnM inst
472
473
474
\end{code}

\begin{code}
475
shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
476
shortCutIntLit i ty
477
  | isIntTy ty && inIntRange i 		-- Short cut for Int
478
  = Just (HsLit (HsInt i))
479
  | isIntegerTy ty 			-- Short cut for Integer
480
  = Just (HsLit (HsInteger i ty))
481
  | otherwise = Nothing
482

483
shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
484
485
shortCutFracLit f ty
  | isFloatTy ty 
486
  = Just (mk_lit floatDataCon (HsFloatPrim f))
487
  | isDoubleTy ty
488
  = Just (mk_lit doubleDataCon (HsDoublePrim f))
489
  | otherwise = Nothing
490
491
  where
    mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
492

493
494
495
496
497
498
shortCutStringLit :: FastString -> TcType -> Maybe (HsExpr TcId)
shortCutStringLit s ty
  | isStringTy ty 			-- Short cut for String
  = Just (HsLit (HsString s))
  | otherwise = Nothing

499
mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
500
501
mkIntegerLit i
  = tcMetaTy integerTyConName 	`thenM` \ integer_ty ->
502
503
    getSrcSpanM			`thenM` \ span -> 
    returnM (L span $ HsLit (HsInteger i integer_ty))
504

505
mkRatLit :: Rational -> TcM (LHsExpr TcId)
506
mkRatLit r
507
  = tcMetaTy rationalTyConName 	`thenM` \ rat_ty ->
508
509
    getSrcSpanM			`thenM` \ span -> 
    returnM (L span $ HsLit (HsRat r rat_ty))
510

511
512
513
514
515
516
mkStrLit :: FastString -> TcM (LHsExpr TcId)
mkStrLit s
  = --tcMetaTy stringTyConName 	`thenM` \ string_ty ->
    getSrcSpanM			`thenM` \ span -> 
    returnM (L span $ HsLit (HsString s))

517
518
519
isHsVar :: HsExpr Name -> Name -> Bool
isHsVar (HsVar f) g = f==g
isHsVar other 	  g = False
520
521
522
\end{code}


523
524
525
526
527
%************************************************************************
%*									*
\subsection{Zonking}
%*									*
%************************************************************************
528

529
Zonking makes sure that the instance types are fully zonked.
530
531

\begin{code}
532
zonkInst :: Inst -> TcM Inst
533
zonkInst dict@(Dict { tci_pred = pred})
534
  = zonkTcPredType pred			`thenM` \ new_pred ->
535
    returnM (dict {tci_pred = new_pred})
536

537
zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta}) 
538
  = zonkId id			`thenM` \ new_id ->
539
540
541
542
	-- 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

543
544
    zonkTcTypes tys		`thenM` \ new_tys ->
    zonkTcThetaType theta	`thenM` \ new_theta ->
545
546
    returnM (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
	-- No need to zonk the tci_id
547

548
zonkInst lit@(LitInst {tci_ty = ty})
549
  = zonkTcType ty			`thenM` \ new_ty ->
550
    returnM (lit {tci_ty = new_ty})
551

552
553
554
555
556
557
zonkInst implic@(ImplicInst {})
  = ASSERT( all isImmutableTyVar (tci_tyvars implic) )
    do 	{ givens'  <- zonkInsts (tci_given  implic)
	; wanteds' <- zonkInsts (tci_wanted implic)
	; return (implic {tci_given = givens',tci_wanted = wanteds'}) }

558
559
zonkInst eqinst@(EqInst {tci_left = ty1, tci_right = ty2})
  = do { co' <- eitherEqInst eqinst 
560
561
		  (\covar -> return (mkWantedCo covar)) 
		  (\co    -> liftM mkGivenCo $ zonkTcType co)
562
563
       ; ty1' <- zonkTcType ty1
       ; ty2' <- zonkTcType ty2
564
       ; return (eqinst {tci_co = co', tci_left= ty1', tci_right = ty2' })
565
566
       }

567
zonkInsts insts = mappM zonkInst insts
568
569
570
\end{code}


571
572
573
574
575
576
%************************************************************************
%*									*
\subsection{Printing}
%*									*
%************************************************************************

577
578
579
580
ToDo: improve these pretty-printing things.  The ``origin'' is really only
relevant in error messages.

\begin{code}
581
instance Outputable Inst where
582
    ppr inst = pprInst inst
sof's avatar
sof committed
583

584
585
pprDictsTheta :: [Inst] -> SDoc
-- Print in type-like fashion (Eq a, Show b)
586
587
-- The Inst can be an implication constraint, but not a Method or LitInst
pprDictsTheta insts = parens (sep (punctuate comma (map (ppr . instType) insts)))
588

589
590
591
592
pprDictsInFull :: [Inst] -> SDoc
-- Print in type-like fashion, but with source location
pprDictsInFull dicts 
  = vcat (map go dicts)
593
  where
594
    go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
595

596
597
pprInsts :: [Inst] -> SDoc
-- Debugging: print the evidence :: type
598
pprInsts insts = brackets (interpp'SP insts)
sof's avatar
sof committed
599

600
601
pprInst, pprInstInFull :: Inst -> SDoc
-- Debugging: print the evidence :: type
602
603
604
605
pprInst i@(EqInst {tci_left = ty1, tci_right = ty2, tci_co = co}) 
	= eitherEqInst i
		(\covar -> text "Wanted" <+> ppr (TyVarTy covar) <+> dcolon <+> ppr (EqPred ty1 ty2))
		(\co    -> text "Given"  <+> ppr co              <+> dcolon <+> ppr (EqPred ty1 ty2))
606
pprInst inst = ppr name <> braces (pprUnique (getUnique name)) <+> dcolon 
607
		<+> (braces (ppr (instType inst) <> implicWantedEqs) $$
608
609
		     ifPprDebug implic_stuff)
  where
610
    name = instName inst
611
612
613
614
615
    (implic_stuff, implicWantedEqs) 
      | isImplicInst inst = (ppr (tci_reft inst),
                            text " &" <+> 
                            ppr (filter isEqInst (tci_wanted inst)))
      | otherwise	  = (empty, empty)
616

617
pprInstInFull inst@(EqInst {}) = pprInst inst
618
pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
619

620
tidyInst :: TidyEnv -> Inst -> Inst
621
622
623
624
625
tidyInst env eq@(EqInst {tci_left = lty, tci_right = rty, tci_co = co}) =
  eq { tci_left  = tidyType env lty
     , tci_right = tidyType env rty
     , tci_co    = either Left (Right . tidyType env) co
     }
626
627
628
tidyInst env lit@(LitInst {tci_ty = ty})   = lit {tci_ty = tidyType env ty}
tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
629
630
631
632
633
634
tidyInst env implic@(ImplicInst {})
  = implic { tci_tyvars = tvs' 
	   , tci_given  = map (tidyInst env') (tci_given  implic)
	   , tci_wanted = map (tidyInst env') (tci_wanted implic) }
  where
    (env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic)
635

636
tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
637
638
-- This function doesn't assume that the tyvars are in scope
-- so it works like tidyOpenType, returning a TidyEnv
639
640
tidyMoreInsts env insts
  = (env', map (tidyInst env') insts)
641
  where
642
643
644
645
    env' = tidyFreeTyVars env (tyVarsOfInsts insts)

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

647
showLIE :: SDoc -> TcM ()	-- Debugging
648
649
650
showLIE str
  = do { lie_var <- getLIEVar ;
	 lie <- readMutVar lie_var ;
651
	 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
652
653
654
\end{code}


655
656
657
658
659
660
661
%************************************************************************
%*									*
	Extending the instance environment
%*									*
%************************************************************************

\begin{code}
662
tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
663
664
665
666
  -- Add new locally-defined instances
tcExtendLocalInstEnv dfuns thing_inside
 = do { traceDFuns dfuns
      ; env <- getGblEnv
667
      ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
668
669
670
      ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
			 tcg_inst_env = inst_env' }
      ; setGblEnv env' thing_inside }
671

672
addLocalInst :: InstEnv -> Instance -> TcM InstEnv
673
674
-- Check that the proposed new instance is OK, 
-- and then add it to the home inst env
675
addLocalInst home_ie ispec
676
677
  = do	{ 	-- Instantiate the dfun type so that we extend the instance
		-- envt with completely fresh template variables
678
679
680
		-- This is important because the template variables must
		-- not overlap with anything in the things being looked up
		-- (since we do unification).  
681
		-- We use tcInstSkolType because we don't want to allocate fresh
682
		--  *meta* type variables.  
683
	  let dfun = instanceDFunId ispec
684
	; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun)
685
686
	; let	(cls, tys') = tcSplitDFunHead tau'
		dfun' 	    = setIdType dfun (mkSigmaTy tvs' theta' tau')	    
687
	  	ispec'      = setInstanceDFunId ispec dfun'
688
689

		-- Load imported instances, so that we report
690
		-- duplicates correctly
691
692
	; eps <- getEps
	; let inst_envs = (eps_inst_env eps, home_ie)
693
694

		-- Check functional dependencies
695
696
	; case checkFunDeps inst_envs ispec' of
		Just specs -> funDepErr ispec' specs
697
		Nothing    -> return ()
698
699

		-- Check for duplicate instance decls
700
701
	; let { (matches, _) = lookupInstEnv inst_envs cls tys'
	      ;	dup_ispecs = [ dup_ispec 
702
			     | (dup_ispec, _) <- matches
703
704
705
706
707
708
709
			     , 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 ()
710
711

		-- OK, now extend the envt
712
713
714
715
716
	; return (extendInstEnv home_ie ispec') }

getOverlapFlag :: TcM OverlapFlag
getOverlapFlag 
  = do 	{ dflags <- getDOpts
717
718
	; let overlap_ok    = dopt Opt_OverlappingInstances dflags
	      incoherent_ok = dopt Opt_IncoherentInstances  dflags
719
720
721
722
723
724
725
726
	      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)))
727
  where
728
729
    pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
	-- Print the dfun name itself too
730

731
732
funDepErr ispec ispecs
  = addDictLoc ispec $
733
    addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
734
735
736
	       2 (pprInstances (ispec:ispecs)))
dupInstErr ispec dup_ispec
  = addDictLoc ispec $
737
    addErr (hang (ptext SLIT("Duplicate instance declarations:"))
738
	       2 (pprInstances [ispec, dup_ispec]))
739

740
addDictLoc ispec thing_inside
741
  = setSrcSpan (mkSrcSpan loc loc) thing_inside
742
  where
743
   loc = getSrcLoc ispec
744
\end{code}
745
    
746

747
748
%************************************************************************
%*									*
749
\subsection{Looking up Insts}
750
751
752
753
%*									*
%************************************************************************

\begin{code}
754
data LookupInstResult
755
  = NoInstance
756
757
758
  | GenInst [Inst] (LHsExpr TcId)	-- The expression and its needed insts

lookupSimpleInst :: Inst -> TcM LookupInstResult
Ian Lynagh's avatar
Ian Lynagh committed
759
-- This is "simple" in that it returns NoInstance for implication constraints
760

761
762
763
-- 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
764

765
766
lookupSimpleInst (EqInst {}) = return NoInstance

767
--------------------- Implications ------------------------
768
lookupSimpleInst (ImplicInst {}) = return NoInstance
769

770
771
--------------------- Methods ------------------------
lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
772
  = do	{ (dict_app, dicts) <- getLIE $ instCallDicts loc theta
773
774
	; let co_fn = dict_app <.> mkWpTyApps tys
	; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
775
  where
776
    span = instLocSpan loc
777

778
--------------------- Literals ------------------------
779
780
-- Look for short cuts first: if the literal is *definitely* a 
-- int, integer, float or a double, generate the real thing here.
781
-- This is essential (see nofib/spectral/nucleic).
782
783
-- [Same shortcut as in newOverloadedLit, but we
--  may have done some unification by now] 		
sof's avatar
sof committed
784

785
lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name _, tci_ty = ty, tci_loc = loc})
786
  | Just expr <- shortCutIntLit i ty
787
  = returnM (GenInst [] (noLoc expr))
788
  | otherwise
789
  = ASSERT( from_integer_name `isHsVar` fromIntegerName )	-- A LitInst invariant
790
    tcLookupId fromIntegerName			`thenM` \ from_integer ->
791
    tcInstClassOp loc from_integer [ty]		`thenM` \ method_inst ->
792
    mkIntegerLit i				`thenM` \ integer_lit ->
793
    returnM (GenInst [method_inst]
794
		     (mkHsApp (L (instLocSpan loc)
795
			   	 (HsVar (instToId method_inst))) integer_lit))
796

797
lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name _, tci_ty = ty, tci_loc = loc})
798
  | Just expr <- shortCutFracLit f ty
799
  = returnM (GenInst [] (noLoc expr))
800
801

  | otherwise
802
  = ASSERT( from_rat_name `isHsVar` fromRationalName )	-- A LitInst invariant
803
    tcLookupId fromRationalName			`thenM` \ from_rational ->
804
    tcInstClassOp loc from_rational [ty]	`thenM` \ method_inst ->
805
    mkRatLit f					`thenM` \ rat_lit ->
806
    returnM (GenInst [method_inst] (mkHsApp (L (instLocSpan loc) 
807
					       (HsVar (instToId method_inst))) rat_lit))
808

809
lookupSimpleInst (LitInst {tci_lit = HsIsString s from_string_name _, tci_ty = ty, tci_loc = loc})
810
811
812
813
814
815
816
817
818
819
820
  | Just expr <- shortCutStringLit s ty
  = returnM (GenInst [] (noLoc expr))
  | otherwise
  = ASSERT( from_string_name `isHsVar` fromStringName )	-- A LitInst invariant
    tcLookupId fromStringName			`thenM` \ from_string ->
    tcInstClassOp loc from_string [ty]		`thenM` \ method_inst ->
    mkStrLit s					`thenM` \ string_lit ->
    returnM (GenInst [method_inst]
		     (mkHsApp (L (instLocSpan loc)
			   	 (HsVar (instToId method_inst))) string_lit))

821
822
--------------------- Dictionaries ------------------------
lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
823
824
825
  = do 	{ mb_result <- lookupPred pred
	; case mb_result of {
	    Nothing -> return NoInstance ;
826
827
	    Just (dfun_id, mb_inst_tys) -> do

828
829
830
    { use_stage <- getStage
    ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
    		      (topIdLvl dfun_id) use_stage
831

832
833
834
835
 	-- 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)
836
837
838
839
840
	-- Hence mb_inst_tys :: Either TyVar TcType 

    ; let inst_tv (Left tv)  = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
	  inst_tv (Right ty) = return ty
    ; tys <- mappM inst_tv mb_inst_tys
841
    ; let
842
    	(theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
843
	src_loc	   = instLocSpan loc
844
	dfun	   = HsVar dfun_id
845
    ; if null theta then
846
    	returnM (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
847
      else do
848
    { (dict_app, dicts) <- getLIE $ instCallDicts loc theta -- !!!
849
850
    ; let co_fn = dict_app <.> mkWpTyApps tys
    ; returnM (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
851
852
853
    }}}}

---------------
854
lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
855
856
-- Look up a class constraint in the instance environment
lookupPred pred@(ClassP clas tys)
857
  = do	{ eps     <- getEps
858
	; tcg_env <- getGblEnv
859
860
	; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
	; case lookupInstEnv inst_envs clas tys of {
861
	    ([(ispec, inst_tys)], []) 
862
863
		-> do	{ let dfun_id = is_dfun ispec
			; traceTc (text "lookupInst success" <+> 
864
865
866
867
868
				   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
869
			; return (Just (dfun_id, inst_tys)) } ;
870
871
872
873
874
875
876
877
878
879
880
881
882
883

     	    (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 }
	}}

884
lookupPred ip_pred = return Nothing	-- Implicit parameters
885
886

record_dfun_usage dfun_id 
Simon Marlow's avatar
Simon Marlow committed
887
  = do	{ hsc_env <- getTopEnv
888
889
	; let  dfun_name = idName dfun_id
	       dfun_mod  = nameModule dfun_name
890
	; if isInternalName dfun_name ||    -- Internal name => defined in this module
Simon Marlow's avatar
Simon Marlow committed
891
	     modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
892
893
894
895
896
	  then return () -- internal, or in another package
	   else do { tcg_env <- getGblEnv
	  	   ; updMutVar (tcg_inst_uses tcg_env)
			       (`addOneToNameSet` idName dfun_id) }}

897
898

tcGetInstEnvs :: TcM (InstEnv, InstEnv)
899
900
-- Gets both the external-package inst-env
-- and the home-pkg inst env (includes module being compiled)
901
tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
902
		     return (eps_inst_env eps, tcg_inst_env env) }
903
904
\end{code}

905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936


%************************************************************************
%*									*
		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
937
	     -> TcType			-- Type to instantiate it at
938
939
	     -> (Name, HsExpr Name)	-- (Standard name, user name)
	     -> TcM (Name, HsExpr TcId)	-- (Standard name, suitable expression)
940
--	*** NOW USED ONLY FOR CmdTop (sigh) ***
941
942
943
-- NB: tcSyntaxName calls tcExpr, and hence can do unification.
-- So we do not call it from lookupInst, which is called from tcSimplify

944
tcSyntaxName orig ty (std_nm, HsVar user_nm)
945
  | std_nm == user_nm
946
947
  = newMethodFromName orig ty std_nm	`thenM` \ id ->
    returnM (std_nm, HsVar id)
948

949
tcSyntaxName orig ty (std_nm, user_nm_expr)
950
  = tcLookupId std_nm		`thenM` \ std_id ->
951
952
953
    let	
	-- C.f. newMethodAtLoc
	([tv], _, tau)  = tcSplitSigmaTy (idType std_id)
954
 	sigma1		= substTyWith [tv] [ty] tau
955
956
	-- Actually, the "tau-type" might be a sigma-type in the
	-- case of locally-polymorphic methods.
957
    in
958
    addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1)	$
959
960

	-- Check that the user-supplied thing has the
961
962
963
	-- same type as the standard one.  
	-- Tiresome jiggling because tcCheckSigma takes a located expression
    getSrcSpanM					`thenM` \ span -> 
964
    tcPolyExpr (L span user_nm_expr) sigma1	`thenM` \ expr ->
965
    returnM (std_nm, unLoc expr)
966
967

syntaxNameCtxt name orig ty tidy_env
968
  = getInstLoc orig		`thenM` \ inst_loc ->
969
970
971
972
    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)),
973
		    nest 2 (ptext SLIT("arising from") <+> pprInstLoc inst_loc)]
974
    in
975
    returnM (tidy_env, msg)
976
\end{code}
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998

%************************************************************************
%*									*
		EqInsts
%*									*
%************************************************************************

\begin{code}
mkGivenCo   :: Coercion -> Either TcTyVar Coercion
mkGivenCo   =  Right

mkWantedCo  :: TcTyVar  -> Either TcTyVar Coercion
mkWantedCo  =  Left

fromGivenCo :: Either TcTyVar Coercion -> Coercion
fromGivenCo (Right co) 	 = co
fromGivenCo _		 = panic "fromGivenCo: not a wanted coercion"

fromWantedCo :: String -> Either TcTyVar Coercion -> TcTyVar
fromWantedCo _ (Left covar) = covar
fromWantedCo msg _	    = panic ("fromWantedCo: not a wanted coercion: " ++ msg)

999
1000
1001
1002
eitherEqInst :: Inst 	            -- given or wanted EqInst
	     -> (TcTyVar  -> a)     -- 	result if wanted
	     -> (Coercion -> a)     --	result if given
	     -> a		
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
eitherEqInst (EqInst {tci_co = either_co}) withWanted withGiven
	= case either_co of
		Left  covar -> withWanted covar
		Right co    -> withGiven  co

mkEqInsts :: [PredType] -> [Either TcTyVar Coercion] -> TcM [Inst]
mkEqInsts preds cos = zipWithM mkEqInst preds cos

mkEqInst :: PredType -> Either TcTyVar Coercion -> TcM Inst
mkEqInst (EqPred ty1 ty2) co
	= do { uniq <- newUnique
	     ; src_span <- getSrcSpanM
	     ; err_ctxt <- getErrCtxt
	     ; let loc  = InstLoc EqOrigin src_span err_ctxt
	           name = mkName uniq src_span
	           inst = EqInst {tci_left = ty1, tci_right = ty2, tci_co = co, tci_loc = loc, tci_name = name} 
	     ; return inst
	     }
	where mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span

1023
1024
mkWantedEqInst :: PredType -> TcM Inst
mkWantedEqInst pred@(EqPred ty1 ty2)
1025
  = do { cotv <- newMetaCoVar ty1 ty2
1026
1027
1028
       ; mkEqInst pred (Left cotv)
       }

1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
-- type inference:
--	We want to promote the wanted EqInst to a given EqInst
--	in the signature context.
--	This means we have to give the coercion a name
--	and fill it in as its own name.
finalizeEqInst 
	:: Inst			-- wanted
	-> TcM Inst		-- given
finalizeEqI