Inst.lhs 30.5 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
module Inst ( 
10
	Inst, 
11

12
	pprInstances, pprDictsTheta, pprDictsInFull,	-- User error messages
13 14
	showLIE, pprInst, pprInsts, pprInstInFull,	-- Debugging messages

15
	tidyInsts, tidyMoreInsts,
16

17 18 19
	newDictBndr, newDictBndrs, newDictBndrsO,
	instCall, instStupidTheta,
	cloneDict, 
20
	shortCutFracLit, shortCutIntLit, shortCutStringLit, newIPDict, 
21
	newMethod, newMethodFromName, newMethodWithGivenTy, 
22
	tcInstClassOp, 
23
	tcSyntaxName, isHsVar,
24

25
	tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, 
26
	ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
27
	getDictClassTys, dictPred,
28

29
	lookupSimpleInst, LookupInstResult(..), 
30
	tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
31

32 33 34
	isDict, isClassDict, isMethod, isImplicInst,
	isIPDict, isInheritableInst, isMethodOrLit,
	isTyVarDict, isMethodFor, getDefaultableDicts,
35

36
	zonkInst, zonkInsts,
37
	instToId, instToVar, instName,
38

39
	InstOrigin(..), InstLoc, pprInstLoc
40 41
    ) where

42
#include "HsVersions.h"
43

44
import {-# SOURCE #-}	TcExpr( tcPolyExpr )
45
import {-# SOURCE #-}	TcUnify( unifyType )
46

47
import FastString(FastString)
Simon Marlow's avatar
Simon Marlow committed
48 49
import HsSyn
import TcHsSyn
50
import TcRnMonad
Simon Marlow's avatar
Simon Marlow committed
51 52 53 54 55 56
import TcEnv
import InstEnv
import FunDeps
import TcMType
import TcType
import Type
57
import Class
Simon Marlow's avatar
Simon Marlow committed
58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77
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
import Maybes
78
import Util
79
import Outputable
80 81
\end{code}

82 83 84 85

Selection
~~~~~~~~~
\begin{code}
86
instName :: Inst -> Name
87
instName inst = Var.varName (instToVar inst)
88

89
instToId :: Inst -> TcId
90 91 92 93 94
instToId inst = ASSERT2( isId id, ppr inst ) id 
	      where
		id = instToVar inst

instToVar :: Inst -> Var
95 96 97 98 99
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})    
100
  | isEqPred pred = Var.mkCoVar nm (mkPredTy pred)
101
  | otherwise	  = mkLocalId nm (mkPredTy pred)
102 103 104 105 106 107 108 109 110 111 112 113
instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens,
		       tci_wanted = wanteds})
  = mkLocalId nm (mkImplicTy tvs givens wanteds)

instType :: Inst -> Type
instType (LitInst {tci_ty = ty}) = ty
instType (Method {tci_id = id}) = idType id
instType (Dict {tci_pred = pred}) = mkPredTy pred
instType imp@(ImplicInst {})      = mkImplicTy (tci_tyvars imp) (tci_given imp)	
					       (tci_wanted imp)

mkImplicTy tvs givens wanteds	-- The type of an implication constraint
simonpj@microsoft.com's avatar
q  
simonpj@microsoft.com committed
114 115
  = ASSERT( all isDict givens )
    -- pprTrace "mkImplicTy" (ppr givens) $
116 117 118 119 120 121
    mkForAllTys tvs $ 
    mkPhiTy (map dictPred givens) $
    if isSingleton wanteds then
	instType (head wanteds) 
    else
	mkTupleTy Boxed (length wanteds) (map instType wanteds)
122

123 124
dictPred (Dict {tci_pred = pred}) = pred
dictPred inst		          = pprPanic "dictPred" (ppr inst)
125

126 127
getDictClassTys (Dict {tci_pred = pred}) = getClassPredTys pred
getDictClassTys inst		         = pprPanic "getDictClassTys" (ppr inst)
128

129
-- fdPredsOfInst is used to get predicates that contain functional 
130 131 132 133 134
-- 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
135 136 137 138 139
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 {})		     = []
140 141 142 143

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

144 145 146
isInheritableInst (Dict {tci_pred = pred})     = isInheritablePred pred
isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta
isInheritableInst other			       = True
147 148


149 150 151 152
---------------------------------
-- Get the implicit parameters mentioned by these Insts
-- NB: the results of these functions are insensitive to zonking

153 154 155 156
ipNamesOfInsts :: [Inst] -> [Name]
ipNamesOfInst  :: Inst   -> [Name]
ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]

157 158 159
ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
ipNamesOfInst (Method {tci_theta = theta})   = [ipNameName n | IParam n _ <- theta]
ipNamesOfInst other		    	     = []
160

161
---------------------------------
162
tyVarsOfInst :: Inst -> TcTyVarSet
163 164
tyVarsOfInst (LitInst {tci_ty = ty})  = tyVarsOfType  ty
tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
165
tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id
166 167
				 -- The id might have free type variables; in the case of
				 -- locally-overloaded class methods, for example
168
tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds})
169 170 171 172
  = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds) 
    `minusVarSet` mkVarSet tvs
    `unionVarSet` unionVarSets (map varTypeTyVars tvs)
		-- Remember the free tyvars of a coercion
173

174 175
tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
176 177 178 179 180
\end{code}

Predicates
~~~~~~~~~~
\begin{code}
181
isDict :: Inst -> Bool
182 183
isDict (Dict {}) = True
isDict other	 = False
184

185
isClassDict :: Inst -> Bool
186 187
isClassDict (Dict {tci_pred = pred}) = isClassPred pred
isClassDict other	    	     = False
188 189

isTyVarDict :: Inst -> Bool
190 191
isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
isTyVarDict other	    	     = False
192

193
isIPDict :: Inst -> Bool
194 195
isIPDict (Dict {tci_pred = pred}) = isIPPred pred
isIPDict other		 	  = False
196

197 198 199
isImplicInst (ImplicInst {}) = True
isImplicInst other 	     = False

200
isMethod :: Inst -> Bool
201 202
isMethod (Method {}) = True
isMethod other	     = False
203

204
isMethodFor :: TcIdSet -> Inst -> Bool
205 206
isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
isMethodFor ids inst			= False
207

208 209 210 211 212
isMethodOrLit :: Inst -> Bool
isMethodOrLit (Method {})  = True
isMethodOrLit (LitInst {}) = True
isMethodOrLit other        = False
\end{code}
213

214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233
\begin{code}
getDefaultableDicts :: [Inst] -> ([(Inst, Class, TcTyVar)], TcTyVarSet)
-- Look for free dicts of the form (C tv), even inside implications
-- *and* the set of tyvars mentioned by all *other* constaints
-- This disgustingly ad-hoc function is solely to support defaulting
getDefaultableDicts insts
  = (concat ps, unionVarSets tvs)
  where
    (ps, tvs) = mapAndUnzip get insts
    get d@(Dict {tci_pred = ClassP cls [ty]})
	| Just tv <- tcGetTyVar_maybe ty = ([(d,cls,tv)], emptyVarSet)
	| otherwise		         = ([], tyVarsOfType ty)
    get (ImplicInst {tci_tyvars = tvs, tci_wanted = wanteds})
	= ([ up | up@(_,_,tv) <- ups, not (tv `elemVarSet` tv_set)],
	   ftvs `minusVarSet` tv_set)
	where
	   tv_set = mkVarSet tvs
	   (ups, ftvs) = getDefaultableDicts wanteds
    get inst = ([], tyVarsOfInst inst)
\end{code}
234

235 236 237 238 239
%************************************************************************
%*									*
\subsection{Building dictionaries}
%*									*
%************************************************************************
240

241 242 243
-- newDictBndrs makes a dictionary at a binding site
-- instCall makes a dictionary at an occurrence site
--	and throws it into the LIE
244

245 246 247 248 249
\begin{code}
----------------
newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
newDictBndrsO orig theta = do { loc <- getInstLoc orig
			      ; newDictBndrs loc theta }
250

251 252
newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
253

254 255
newDictBndr :: InstLoc -> TcPredType -> TcM Inst
newDictBndr inst_loc pred
256
  = do 	{ uniq <- newUnique 
257
	; let name = mkPredName uniq inst_loc pred 
258
	; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
259

260
----------------
261
instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
262 263 264 265
-- 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
266
-- (c) Eeturns an HsWrapper ([.] tys dicts)
267 268 269 270 271

instCall orig tys theta 
  = do	{ loc <- getInstLoc orig
	; (dicts, dict_app) <- instCallDicts loc theta
	; extendLIEs dicts
272
	; return (dict_app <.> mkWpTyApps tys) }
273 274 275 276 277 278 279 280 281 282 283

----------------
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
	; (dicts, _) <- instCallDicts loc theta
	; extendLIEs dicts }

----------------
284
instCallDicts :: InstLoc -> TcThetaType -> TcM ([Inst], HsWrapper)
285 286
-- This is the key place where equality predicates 
-- are unleashed into the world
287
instCallDicts loc [] = return ([], idHsWrapper)
288 289 290 291

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, 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
292
				-- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
293
	; (dicts, co_fn) <- instCallDicts loc preds
294
	; return (dicts, co_fn <.> WpTyApp ty1) }
295 296 297 298 299
	-- We use type application to apply the function to the 
	-- coercion; here ty1 *is* the appropriate identity coercion

instCallDicts loc (pred : preds)
  = do	{ uniq <- newUnique
300
	; let name = mkPredName uniq loc pred 
301
	      dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
302
	; (dicts, co_fn) <- instCallDicts loc preds
303
	; return (dict:dicts, co_fn <.> WpApp (instToId dict)) }
304 305 306

-------------
cloneDict :: Inst -> TcM Inst	-- Only used for linear implicit params
307 308 309
cloneDict dict@(Dict nm ty loc) = do { uniq <- newUnique
				     ; return (dict {tci_name = setNameUnique nm uniq}) }
cloneDict other = pprPanic "cloneDict" (ppr other)
310

311 312 313
-- 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 
314
-- scope, so we make up a new namea.
315
newIPDict :: InstOrigin -> IPName Name -> Type 
316
	  -> TcM (IPName Id, Inst)
317
newIPDict orig ip_name ty
318
  = getInstLoc orig			`thenM` \ inst_loc ->
319
    newUnique				`thenM` \ uniq ->
320 321
    let
	pred = IParam ip_name ty
322
        name = mkPredName uniq inst_loc pred 
323
	dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}
324
    in
325
    returnM (mapIPName (\n -> instToId dict) ip_name, dict)
326 327 328
\end{code}


329 330 331
\begin{code}
mkPredName :: Unique -> InstLoc -> PredType -> Name
mkPredName uniq loc pred_ty
332
  = mkInternalName uniq occ (instLocSpan loc)
333 334
  where
    occ = case pred_ty of
335 336 337 338
	    ClassP cls _ -> mkDictOcc (getOccName cls)
	    IParam ip  _ -> getOccName (ipNameName ip)
	    EqPred ty  _ -> mkEqPredCoOcc baseOcc
	      where
339 340
		-- we use the outermost tycon of the lhs, if there is one, to
		-- improve readability of Core code
341
	        baseOcc = case splitTyConApp_maybe ty of
342
			    Nothing      -> mkOccName tcName "$"
343
                            Just (tc, _) -> getOccName tc
344
\end{code}
345

346 347 348 349 350 351
%************************************************************************
%*									*
\subsection{Building methods (calls of overloaded functions)}
%*									*
%************************************************************************

352

353
\begin{code}
354
newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
355
newMethodFromName origin ty name
356
  = tcLookupId name		`thenM` \ id ->
357 358 359 360
	-- 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. 
361 362 363 364
    getInstLoc origin		`thenM` \ loc ->
    tcInstClassOp loc id [ty]	`thenM` \ inst ->
    extendLIE inst		`thenM_`
    returnM (instToId inst)
365

366 367 368 369
newMethodWithGivenTy orig id tys
  = getInstLoc orig		`thenM` \ loc ->
    newMethod loc id tys	`thenM` \ inst ->
    extendLIE inst		`thenM_`
370
    returnM (instToId inst)
371 372

--------------------------------------------
373
-- tcInstClassOp, and newMethod do *not* drop the 
374 375 376
-- Inst into the LIE; they just returns the Inst
-- This is important because they are used by TcSimplify
-- to simplify Insts
377

378 379 380 381 382
-- 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?
383 384 385
tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
tcInstClassOp inst_loc sel_id tys
  = let
386
	(tyvars, _rho) = tcSplitForAllTys (idType sel_id)
387
    in
388
    zipWithM_ checkKind tyvars tys	`thenM_` 
389
    newMethod inst_loc sel_id tys
390

391 392 393
checkKind :: TyVar -> TcType -> TcM ()
-- Ensure that the type has a sub-kind of the tyvar
checkKind tv ty
394 395
  = do	{ let ty1 = ty 
		-- ty1 <- zonkTcType ty
Simon Marlow's avatar
Simon Marlow committed
396
	; if typeKind ty1 `isSubKind` Var.tyVarKind tv
397
	  then return ()
398 399 400
	  else 

    pprPanic "checkKind: adding kind constraint" 
Simon Marlow's avatar
Simon Marlow committed
401
	     (vcat [ppr tv <+> ppr (Var.tyVarKind tv), 
402 403 404 405
	            ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
	}
--    do	{ tv1 <- tcInstTyVar tv
--	; unifyType ty1 (mkTyVarTy tv1) } }
406 407


408
---------------------------
409
newMethod inst_loc id tys
410
  = newUnique		`thenM` \ new_uniq ->
411
    let
412 413
	(theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
	meth_id	    = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
414 415
	inst        = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
			      tci_theta = theta, tci_loc = inst_loc}
416
	loc         = instLocSpan inst_loc
417
    in
418
    returnM inst
419 420 421
\end{code}

\begin{code}
422
shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
423
shortCutIntLit i ty
424
  | isIntTy ty && inIntRange i 		-- Short cut for Int
425
  = Just (HsLit (HsInt i))
426
  | isIntegerTy ty 			-- Short cut for Integer
427
  = Just (HsLit (HsInteger i ty))
428
  | otherwise = Nothing
429

430
shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
431 432
shortCutFracLit f ty
  | isFloatTy ty 
433
  = Just (mk_lit floatDataCon (HsFloatPrim f))
434
  | isDoubleTy ty
435
  = Just (mk_lit doubleDataCon (HsDoublePrim f))
436
  | otherwise = Nothing
437 438
  where
    mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
439

440 441 442 443 444 445
shortCutStringLit :: FastString -> TcType -> Maybe (HsExpr TcId)
shortCutStringLit s ty
  | isStringTy ty 			-- Short cut for String
  = Just (HsLit (HsString s))
  | otherwise = Nothing

446
mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
447 448
mkIntegerLit i
  = tcMetaTy integerTyConName 	`thenM` \ integer_ty ->
449 450
    getSrcSpanM			`thenM` \ span -> 
    returnM (L span $ HsLit (HsInteger i integer_ty))
451

452
mkRatLit :: Rational -> TcM (LHsExpr TcId)
453
mkRatLit r
454
  = tcMetaTy rationalTyConName 	`thenM` \ rat_ty ->
455 456
    getSrcSpanM			`thenM` \ span -> 
    returnM (L span $ HsLit (HsRat r rat_ty))
457

458 459 460 461 462 463
mkStrLit :: FastString -> TcM (LHsExpr TcId)
mkStrLit s
  = --tcMetaTy stringTyConName 	`thenM` \ string_ty ->
    getSrcSpanM			`thenM` \ span -> 
    returnM (L span $ HsLit (HsString s))

464 465 466
isHsVar :: HsExpr Name -> Name -> Bool
isHsVar (HsVar f) g = f==g
isHsVar other 	  g = False
467 468 469
\end{code}


470 471 472 473 474
%************************************************************************
%*									*
\subsection{Zonking}
%*									*
%************************************************************************
475

476
Zonking makes sure that the instance types are fully zonked.
477 478

\begin{code}
479
zonkInst :: Inst -> TcM Inst
480
zonkInst dict@(Dict { tci_pred = pred})
481
  = zonkTcPredType pred			`thenM` \ new_pred ->
482
    returnM (dict {tci_pred = new_pred})
483

484
zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta}) 
485
  = zonkId id			`thenM` \ new_id ->
486 487 488 489
	-- 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

490 491
    zonkTcTypes tys		`thenM` \ new_tys ->
    zonkTcThetaType theta	`thenM` \ new_theta ->
492 493
    returnM (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
	-- No need to zonk the tci_id
494

495
zonkInst lit@(LitInst {tci_ty = ty})
496
  = zonkTcType ty			`thenM` \ new_ty ->
497
    returnM (lit {tci_ty = new_ty})
498

499 500 501 502 503 504
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'}) }

505
zonkInsts insts = mappM zonkInst insts
506 507 508
\end{code}


509 510 511 512 513 514
%************************************************************************
%*									*
\subsection{Printing}
%*									*
%************************************************************************

515 516 517 518
ToDo: improve these pretty-printing things.  The ``origin'' is really only
relevant in error messages.

\begin{code}
519
instance Outputable Inst where
520
    ppr inst = pprInst inst
sof's avatar
sof committed
521

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

527 528 529 530
pprDictsInFull :: [Inst] -> SDoc
-- Print in type-like fashion, but with source location
pprDictsInFull dicts 
  = vcat (map go dicts)
531
  where
532
    go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
533

534 535
pprInsts :: [Inst] -> SDoc
-- Debugging: print the evidence :: type
536
pprInsts insts = brackets (interpp'SP insts)
sof's avatar
sof committed
537

538 539
pprInst, pprInstInFull :: Inst -> SDoc
-- Debugging: print the evidence :: type
540 541 542 543 544 545
pprInst inst = ppr (instName inst) <+> dcolon 
		<+> (braces (ppr (instType inst)) $$
		     ifPprDebug implic_stuff)
  where
    implic_stuff | isImplicInst inst = ppr (tci_reft inst)
		 | otherwise	     = empty
546

547
pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
548

549
tidyInst :: TidyEnv -> Inst -> Inst
550 551 552
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}
553 554 555 556 557 558
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)
559

560
tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
561 562
-- This function doesn't assume that the tyvars are in scope
-- so it works like tidyOpenType, returning a TidyEnv
563 564
tidyMoreInsts env insts
  = (env', map (tidyInst env') insts)
565
  where
566 567 568 569
    env' = tidyFreeTyVars env (tyVarsOfInsts insts)

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

571
showLIE :: SDoc -> TcM ()	-- Debugging
572 573 574
showLIE str
  = do { lie_var <- getLIEVar ;
	 lie <- readMutVar lie_var ;
575
	 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
576 577 578
\end{code}


579 580 581 582 583 584 585
%************************************************************************
%*									*
	Extending the instance environment
%*									*
%************************************************************************

\begin{code}
586
tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
587 588 589 590
  -- Add new locally-defined instances
tcExtendLocalInstEnv dfuns thing_inside
 = do { traceDFuns dfuns
      ; env <- getGblEnv
591
      ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
592 593 594
      ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
			 tcg_inst_env = inst_env' }
      ; setGblEnv env' thing_inside }
595

596
addLocalInst :: InstEnv -> Instance -> TcM InstEnv
597 598
-- Check that the proposed new instance is OK, 
-- and then add it to the home inst env
599
addLocalInst home_ie ispec
600 601
  = do	{ 	-- Instantiate the dfun type so that we extend the instance
		-- envt with completely fresh template variables
602 603 604
		-- This is important because the template variables must
		-- not overlap with anything in the things being looked up
		-- (since we do unification).  
605
		-- We use tcInstSkolType because we don't want to allocate fresh
606
		--  *meta* type variables.  
607
	  let dfun = instanceDFunId ispec
608
	; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun)
609 610
	; let	(cls, tys') = tcSplitDFunHead tau'
		dfun' 	    = setIdType dfun (mkSigmaTy tvs' theta' tau')	    
611
	  	ispec'      = setInstanceDFunId ispec dfun'
612 613

		-- Load imported instances, so that we report
614
		-- duplicates correctly
615 616
	; eps <- getEps
	; let inst_envs = (eps_inst_env eps, home_ie)
617 618

		-- Check functional dependencies
619 620
	; case checkFunDeps inst_envs ispec' of
		Just specs -> funDepErr ispec' specs
621
		Nothing    -> return ()
622 623

		-- Check for duplicate instance decls
624 625
	; let { (matches, _) = lookupInstEnv inst_envs cls tys'
	      ;	dup_ispecs = [ dup_ispec 
626
			     | (dup_ispec, _) <- matches
627 628 629 630 631 632 633
			     , 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 ()
634 635

		-- OK, now extend the envt
636 637 638 639 640 641 642 643 644 645 646 647 648 649 650
	; 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)))
651
  where
652 653
    pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
	-- Print the dfun name itself too
654

655 656
funDepErr ispec ispecs
  = addDictLoc ispec $
657
    addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
658 659 660
	       2 (pprInstances (ispec:ispecs)))
dupInstErr ispec dup_ispec
  = addDictLoc ispec $
661
    addErr (hang (ptext SLIT("Duplicate instance declarations:"))
662
	       2 (pprInstances [ispec, dup_ispec]))
663

664
addDictLoc ispec thing_inside
665
  = setSrcSpan (mkSrcSpan loc loc) thing_inside
666
  where
667
   loc = getSrcLoc ispec
668
\end{code}
669
    
670

671 672
%************************************************************************
%*									*
673
\subsection{Looking up Insts}
674 675 676 677
%*									*
%************************************************************************

\begin{code}
678
data LookupInstResult
679
  = NoInstance
680 681 682 683
  | GenInst [Inst] (LHsExpr TcId)	-- The expression and its needed insts

lookupSimpleInst :: Inst -> TcM LookupInstResult
-- This is "simple" in tthat it returns NoInstance for implication constraints
684

685 686 687
-- 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
688

689
--------------------- Implications ------------------------
690
lookupSimpleInst (ImplicInst {}) = return NoInstance
691

692 693
--------------------- Methods ------------------------
lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
694
  = do	{ (dicts, dict_app) <- instCallDicts loc theta
695 696
	; let co_fn = dict_app <.> mkWpTyApps tys
	; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
697
  where
698
    span = instLocSpan loc
699

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

707
lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name, tci_ty = ty, tci_loc = loc})
708
  | Just expr <- shortCutIntLit i ty
709
  = returnM (GenInst [] (noLoc expr))
710
  | otherwise
711
  = ASSERT( from_integer_name `isHsVar` fromIntegerName )	-- A LitInst invariant
712
    tcLookupId fromIntegerName			`thenM` \ from_integer ->
713
    tcInstClassOp loc from_integer [ty]		`thenM` \ method_inst ->
714
    mkIntegerLit i				`thenM` \ integer_lit ->
715
    returnM (GenInst [method_inst]
716
		     (mkHsApp (L (instLocSpan loc)
717
			   	 (HsVar (instToId method_inst))) integer_lit))
718

719
lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name, tci_ty = ty, tci_loc = loc})
720
  | Just expr <- shortCutFracLit f ty
721
  = returnM (GenInst [] (noLoc expr))
722 723

  | otherwise
724
  = ASSERT( from_rat_name `isHsVar` fromRationalName )	-- A LitInst invariant
725
    tcLookupId fromRationalName			`thenM` \ from_rational ->
726
    tcInstClassOp loc from_rational [ty]	`thenM` \ method_inst ->
727
    mkRatLit f					`thenM` \ rat_lit ->
728
    returnM (GenInst [method_inst] (mkHsApp (L (instLocSpan loc) 
729
					       (HsVar (instToId method_inst))) rat_lit))
730

731 732 733 734 735 736 737 738 739 740 741 742
lookupSimpleInst (LitInst {tci_lit = HsIsString s from_string_name, tci_ty = ty, tci_loc = loc})
  | 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))

743 744
--------------------- Dictionaries ------------------------
lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
745 746 747
  = do 	{ mb_result <- lookupPred pred
	; case mb_result of {
	    Nothing -> return NoInstance ;
748 749
	    Just (dfun_id, mb_inst_tys) -> do

750 751 752
    { use_stage <- getStage
    ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
    		      (topIdLvl dfun_id) use_stage
753

754 755 756 757
 	-- 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)
758 759 760 761 762
	-- 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
763
    ; let
764
    	(theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
765
	src_loc	   = instLocSpan loc
766
	dfun	   = HsVar dfun_id
767
    ; if null theta then
768
    	returnM (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
769
      else do
770
    { (dicts, dict_app) <- instCallDicts loc theta
771 772
    ; let co_fn = dict_app <.> mkWpTyApps tys
    ; returnM (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
773 774 775
    }}}}

---------------
776
lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
777 778
-- Look up a class constraint in the instance environment
lookupPred pred@(ClassP clas tys)
779
  = do	{ eps     <- getEps
780
	; tcg_env <- getGblEnv
781 782
	; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
	; case lookupInstEnv inst_envs clas tys of {
783
	    ([(ispec, inst_tys)], []) 
784 785
		-> do	{ let dfun_id = is_dfun ispec
			; traceTc (text "lookupInst success" <+> 
786 787 788 789 790
				   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
791
			; return (Just (dfun_id, inst_tys)) } ;
792 793 794 795 796 797 798 799 800 801 802 803 804 805

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

806
lookupPred ip_pred = return Nothing	-- Implicit parameters
807 808

record_dfun_usage dfun_id 
Simon Marlow's avatar
Simon Marlow committed
809
  = do	{ hsc_env <- getTopEnv
810 811
	; let  dfun_name = idName dfun_id
	       dfun_mod  = nameModule dfun_name
812
	; if isInternalName dfun_name ||    -- Internal name => defined in this module
Simon Marlow's avatar
Simon Marlow committed
813
	     modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
814 815 816 817 818
	  then return () -- internal, or in another package
	   else do { tcg_env <- getGblEnv
	  	   ; updMutVar (tcg_inst_uses tcg_env)
			       (`addOneToNameSet` idName dfun_id) }}

819 820

tcGetInstEnvs :: TcM (InstEnv, InstEnv)
821 822
-- Gets both the external-package inst-env
-- and the home-pkg inst env (includes module being compiled)
823
tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
824
		     return (eps_inst_env eps, tcg_inst_env env) }
825 826
\end{code}

827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858


%************************************************************************
%*									*
		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
859
	     -> TcType			-- Type to instantiate it at
860 861
	     -> (Name, HsExpr Name)	-- (Standard name, user name)
	     -> TcM (Name, HsExpr TcId)	-- (Standard name, suitable expression)
862
--	*** NOW USED ONLY FOR CmdTop (sigh) ***
863 864 865
-- NB: tcSyntaxName calls tcExpr, and hence can do unification.
-- So we do not call it from lookupInst, which is called from tcSimplify

866
tcSyntaxName orig ty (std_nm, HsVar user_nm)
867
  | std_nm == user_nm
868 869
  = newMethodFromName orig ty std_nm	`thenM` \ id ->
    returnM (std_nm, HsVar id)
870

871
tcSyntaxName orig ty (std_nm, user_nm_expr)
872
  = tcLookupId std_nm		`thenM` \ std_id ->
873 874 875
    let	
	-- C.f. newMethodAtLoc
	([tv], _, tau)  = tcSplitSigmaTy (idType std_id)
876
 	sigma1		= substTyWith [tv] [ty] tau
877 878
	-- Actually, the "tau-type" might be a sigma-type in the
	-- case of locally-polymorphic methods.
879
    in
880
    addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1)	$
881 882

	-- Check that the user-supplied thing has the
883 884 885
	-- same type as the standard one.  
	-- Tiresome jiggling because tcCheckSigma takes a located expression
    getSrcSpanM					`thenM` \ span -> 
886
    tcPolyExpr (L span user_nm_expr) sigma1	`thenM` \ expr ->
887
    returnM (std_nm, unLoc expr)
888 889

syntaxNameCtxt name orig ty tidy_env
890
  = getInstLoc orig		`thenM` \ inst_loc ->
891 892 893 894
    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)),
895
		    nest 2 (ptext SLIT("arising from") <+> pprInstLoc inst_loc)]
896
    in
897
    returnM (tidy_env, msg)
898
\end{code}