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 Outputable
98
import Data.List
99
100
import TypeRep
import Class
101
102

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

105
106
107
108

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

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

instToVar :: Inst -> Var
120
121
122
123
124
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})    
125
  | isEqPred pred = Var.mkCoVar nm (mkPredTy pred)
126
  | otherwise	  = mkLocalId nm (mkPredTy pred)
127
128
129
instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens,
		       tci_wanted = wanteds})
  = mkLocalId nm (mkImplicTy tvs givens wanteds)
130
131
instToVar i@(EqInst {})
  = eitherEqInst i id (\(TyVarTy covar) -> covar)
132
133

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

mkImplicTy tvs givens wanteds	-- The type of an implication constraint
143
  = ASSERT( all isAbstractableInst givens )
simonpj@microsoft.com's avatar
q    
simonpj@microsoft.com committed
144
    -- pprTrace "mkImplicTy" (ppr givens) $
145
146
147
148
149
150
151
152
153
    -- 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)
154

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

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

162
-- fdPredsOfInst is used to get predicates that contain functional 
163
164
165
166
167
-- 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
168
169
170
171
172
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 {})		     = []
173
fdPredsOfInst (EqInst {})		     = []
174
175
176
177

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

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


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

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

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

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

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


--------------------------
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
220
221
222
223
224
\end{code}

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

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

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

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

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

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

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

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

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

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

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

266

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

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

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

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

286
newDictBndr :: InstLoc -> TcPredType -> TcM Inst
287
288
289
290
291
292
293
294
295
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))})
       }
296
newDictBndr inst_loc pred
297
  = do 	{ uniq <- newUnique 
298
	; let name = mkPredName uniq inst_loc pred 
299
	; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
300

301
----------------
302
instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
303
304
305
306
-- 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
307
-- (c) Returns an HsWrapper ([.] tys dicts)
308
309
310

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

----------------
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
320
321
	; _co <- instCallDicts loc theta	-- Discard the coercion
	; return () }
322
323

----------------
324
325
326
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.
327
328
-- This is the key place where equality predicates 
-- are unleashed into the world
329
330
331
332
333
334
335
336
337
338
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
339
340

instCallDicts loc (EqPred ty1 ty2 : preds)
341
342
343
344
345
346
  = 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) }
347
348
349

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

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

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


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

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

404

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

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

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

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

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

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


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

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

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

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

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

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

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

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


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

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

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

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

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

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

551
552
553
554
555
556
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'}) }

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

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


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

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

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

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

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

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

599
600
pprInst, pprInstInFull :: Inst -> SDoc
-- Debugging: print the evidence :: type
601
602
603
604
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))
605
pprInst inst = ppr (instName inst) <+> dcolon 
606
		<+> (braces (ppr (instType inst) <> implicWantedEqs) $$
607
608
		     ifPprDebug implic_stuff)
  where
609
610
611
612
613
    (implic_stuff, implicWantedEqs) 
      | isImplicInst inst = (ppr (tci_reft inst),
                            text " &" <+> 
                            ppr (filter isEqInst (tci_wanted inst)))
      | otherwise	  = (empty, empty)
614

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

618
tidyInst :: TidyEnv -> Inst -> Inst
619
620
621
622
623
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
     }
624
625
626
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}
627
628
629
630
631
632
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)
633

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

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

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


653
654
655
656
657
658
659
%************************************************************************
%*									*
	Extending the instance environment
%*									*
%************************************************************************

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

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

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

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

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

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

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

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

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

745
746
%************************************************************************
%*									*
747
\subsection{Looking up Insts}
748
749
750
751
%*									*
%************************************************************************

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

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

759
760
761
-- 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
762

763
764
lookupSimpleInst (EqInst {}) = return NoInstance

765
--------------------- Implications ------------------------
766
lookupSimpleInst (ImplicInst {}) = return NoInstance
767

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

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

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

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

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

807
lookupSimpleInst (LitInst {tci_lit = HsIsString s from_string_name _, tci_ty = ty, tci_loc = loc})
808
809
810
811
812
813
814
815
816
817
818
  | 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))

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

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

830
831
832
833
 	-- 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)
834
835
836
837
838
	-- 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
839
    ; let
840
    	(theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
841
	src_loc	   = instLocSpan loc
842
	dfun	   = HsVar dfun_id
843
    ; if null theta then
844
    	returnM (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
845
      else do
846
    { (dict_app, dicts) <- getLIE $ instCallDicts loc theta -- !!!
847
848
    ; let co_fn = dict_app <.> mkWpTyApps tys
    ; returnM (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
849
850
851
    }}}}

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

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

882
lookupPred ip_pred = return Nothing	-- Implicit parameters
883
884

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

895
896

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

903
904
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


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

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

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

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

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

%************************************************************************
%*									*
		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)

997
998
999
1000
eitherEqInst :: Inst 	            -- given or wanted EqInst
	     -> (TcTyVar  -> a)     -- 	result if wanted
	     -> (Coercion -> a)     --	result if given
	     -> a		
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
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

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