Inst.lhs 30.2 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, 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(..), lookupPred, 
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

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

81 82 83 84

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

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

instToVar :: Inst -> Var
94 95 96 97 98
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})    
99
  | isEqPred pred = Var.mkCoVar nm (mkPredTy pred)
100
  | otherwise	  = mkLocalId nm (mkPredTy pred)
101 102 103 104 105 106 107 108 109 110 111 112
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
113 114
  = ASSERT( all isDict givens )
    -- pprTrace "mkImplicTy" (ppr givens) $
115 116 117 118 119 120
    mkForAllTys tvs $ 
    mkPhiTy (map dictPred givens) $
    if isSingleton wanteds then
	instType (head wanteds) 
    else
	mkTupleTy Boxed (length wanteds) (map instType wanteds)
121

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

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

128
-- fdPredsOfInst is used to get predicates that contain functional 
129 130 131 132 133
-- dependencies *or* might do so.  The "might do" part is because
-- a constraint (C a b) might have a superclass with FDs
-- Leaving these in is really important for the call to fdPredsOfInsts
-- in TcSimplify.inferLoop, because the result is fed to 'grow',
-- which is supposed to be conservative
134 135 136 137 138
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 {})		     = []
139 140 141 142

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

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


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

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

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

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

170

171 172
tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
173 174 175 176 177
\end{code}

Predicates
~~~~~~~~~~
\begin{code}
178
isDict :: Inst -> Bool
179 180
isDict (Dict {}) = True
isDict other	 = False
181

182
isClassDict :: Inst -> Bool
183 184
isClassDict (Dict {tci_pred = pred}) = isClassPred pred
isClassDict other	    	     = False
185 186

isTyVarDict :: Inst -> Bool
187 188
isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
isTyVarDict other	    	     = False
189

190
isIPDict :: Inst -> Bool
191 192
isIPDict (Dict {tci_pred = pred}) = isIPPred pred
isIPDict other		 	  = False
193

194 195 196
isImplicInst (ImplicInst {}) = True
isImplicInst other 	     = False

197
isMethod :: Inst -> Bool
198 199
isMethod (Method {}) = True
isMethod other	     = False
200

201
isMethodFor :: TcIdSet -> Inst -> Bool
202 203
isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
isMethodFor ids inst			= False
204

205 206 207 208 209
isMethodOrLit :: Inst -> Bool
isMethodOrLit (Method {})  = True
isMethodOrLit (LitInst {}) = True
isMethodOrLit other        = False
\end{code}
210

211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230
\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}
231

232 233 234 235 236
%************************************************************************
%*									*
\subsection{Building dictionaries}
%*									*
%************************************************************************
237

238 239 240
-- newDictBndrs makes a dictionary at a binding site
-- instCall makes a dictionary at an occurrence site
--	and throws it into the LIE
241

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

248 249
newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
250

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

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

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

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

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

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
289
				-- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
290
	; (dicts, co_fn) <- instCallDicts loc preds
291
	; return (dicts, co_fn <.> WpTyApp ty1) }
292 293 294 295 296
	-- 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
297
	; let name = mkPredName uniq loc pred 
298
	      dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
299
	; (dicts, co_fn) <- instCallDicts loc preds
300
	; return (dict:dicts, co_fn <.> WpApp (instToId dict)) }
301 302 303

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

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


326 327 328 329 330 331
\begin{code}
mkPredName :: Unique -> InstLoc -> PredType -> Name
mkPredName uniq loc pred_ty
  = mkInternalName uniq occ (srcSpanStart (instLocSpan loc))
  where
    occ = case pred_ty of
332 333 334 335 336 337 338 339 340 341
	    ClassP cls _ -> mkDictOcc (getOccName cls)
	    IParam ip  _ -> getOccName (ipNameName ip)
	    EqPred ty  _ -> mkEqPredCoOcc baseOcc
	      where
		-- we use the outermost tycon of the lhs, which must be a type
		-- function, as the base name for an equality
	        baseOcc = case splitTyConApp_maybe ty of
			    Nothing      -> 
			      pprPanic "Inst.mkPredName:" (ppr ty)
                            Just (tc, _) -> getOccName tc
342
\end{code}
343

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

350

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

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

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

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

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

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


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

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

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

438
mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
439 440
mkIntegerLit i
  = tcMetaTy integerTyConName 	`thenM` \ integer_ty ->
441 442
    getSrcSpanM			`thenM` \ span -> 
    returnM (L span $ HsLit (HsInteger i integer_ty))
443

444
mkRatLit :: Rational -> TcM (LHsExpr TcId)
445
mkRatLit r
446
  = tcMetaTy rationalTyConName 	`thenM` \ rat_ty ->
447 448
    getSrcSpanM			`thenM` \ span -> 
    returnM (L span $ HsLit (HsRat r rat_ty))
449 450 451 452

isHsVar :: HsExpr Name -> Name -> Bool
isHsVar (HsVar f) g = f==g
isHsVar other 	  g = False
453 454 455
\end{code}


456 457 458 459 460
%************************************************************************
%*									*
\subsection{Zonking}
%*									*
%************************************************************************
461

462
Zonking makes sure that the instance types are fully zonked.
463 464

\begin{code}
465
zonkInst :: Inst -> TcM Inst
466
zonkInst dict@(Dict { tci_pred = pred})
467
  = zonkTcPredType pred			`thenM` \ new_pred ->
468
    returnM (dict {tci_pred = new_pred})
469

470
zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta}) 
471
  = zonkId id			`thenM` \ new_id ->
472 473 474 475
	-- 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

476 477
    zonkTcTypes tys		`thenM` \ new_tys ->
    zonkTcThetaType theta	`thenM` \ new_theta ->
478 479
    returnM (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
	-- No need to zonk the tci_id
480

481
zonkInst lit@(LitInst {tci_ty = ty})
482
  = zonkTcType ty			`thenM` \ new_ty ->
483
    returnM (lit {tci_ty = new_ty})
484

485 486 487 488 489 490
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'}) }

491
zonkInsts insts = mappM zonkInst insts
492 493 494
\end{code}


495 496 497 498 499 500
%************************************************************************
%*									*
\subsection{Printing}
%*									*
%************************************************************************

501 502 503 504
ToDo: improve these pretty-printing things.  The ``origin'' is really only
relevant in error messages.

\begin{code}
505
instance Outputable Inst where
506
    ppr inst = pprInst inst
sof's avatar
sof committed
507

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

513 514 515 516
pprDictsInFull :: [Inst] -> SDoc
-- Print in type-like fashion, but with source location
pprDictsInFull dicts 
  = vcat (map go dicts)
517
  where
518
    go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
519

520 521
pprInsts :: [Inst] -> SDoc
-- Debugging: print the evidence :: type
522
pprInsts insts = brackets (interpp'SP insts)
sof's avatar
sof committed
523

524 525
pprInst, pprInstInFull :: Inst -> SDoc
-- Debugging: print the evidence :: type
526 527 528 529 530 531
pprInst inst = ppr (instName inst) <+> dcolon 
		<+> (braces (ppr (instType inst)) $$
		     ifPprDebug implic_stuff)
  where
    implic_stuff | isImplicInst inst = ppr (tci_reft inst)
		 | otherwise	     = empty
532

533
pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
534

535
tidyInst :: TidyEnv -> Inst -> Inst
536 537 538
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}
539 540 541 542 543 544
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)
545

546
tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
547 548
-- This function doesn't assume that the tyvars are in scope
-- so it works like tidyOpenType, returning a TidyEnv
549 550
tidyMoreInsts env insts
  = (env', map (tidyInst env') insts)
551
  where
552 553 554 555
    env' = tidyFreeTyVars env (tyVarsOfInsts insts)

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

557
showLIE :: SDoc -> TcM ()	-- Debugging
558 559 560
showLIE str
  = do { lie_var <- getLIEVar ;
	 lie <- readMutVar lie_var ;
561
	 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
562 563 564
\end{code}


565 566 567 568 569 570 571
%************************************************************************
%*									*
	Extending the instance environment
%*									*
%************************************************************************

\begin{code}
572
tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
573 574 575 576
  -- Add new locally-defined instances
tcExtendLocalInstEnv dfuns thing_inside
 = do { traceDFuns dfuns
      ; env <- getGblEnv
577
      ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
578 579 580
      ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
			 tcg_inst_env = inst_env' }
      ; setGblEnv env' thing_inside }
581

582
addLocalInst :: InstEnv -> Instance -> TcM InstEnv
583 584
-- Check that the proposed new instance is OK, 
-- and then add it to the home inst env
585
addLocalInst home_ie ispec
586 587
  = do	{ 	-- Instantiate the dfun type so that we extend the instance
		-- envt with completely fresh template variables
588 589 590
		-- This is important because the template variables must
		-- not overlap with anything in the things being looked up
		-- (since we do unification).  
591
		-- We use tcInstSkolType because we don't want to allocate fresh
592
		--  *meta* type variables.  
593
	  let dfun = instanceDFunId ispec
594
	; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun)
595 596
	; let	(cls, tys') = tcSplitDFunHead tau'
		dfun' 	    = setIdType dfun (mkSigmaTy tvs' theta' tau')	    
597
	  	ispec'      = setInstanceDFunId ispec dfun'
598 599

		-- Load imported instances, so that we report
600
		-- duplicates correctly
601 602
	; eps <- getEps
	; let inst_envs = (eps_inst_env eps, home_ie)
603 604

		-- Check functional dependencies
605 606
	; case checkFunDeps inst_envs ispec' of
		Just specs -> funDepErr ispec' specs
607
		Nothing    -> return ()
608 609

		-- Check for duplicate instance decls
610 611 612 613 614 615 616 617 618 619
	; let { (matches, _) = lookupInstEnv inst_envs cls tys'
	      ;	dup_ispecs = [ dup_ispec 
			     | (_, dup_ispec) <- matches
			     , let (_,_,_,dup_tys) = instanceHead dup_ispec
			     , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
		-- Find memebers of the match list which ispec itself matches.
		-- If the match is 2-way, it's a duplicate
	; case dup_ispecs of
	    dup_ispec : _ -> dupInstErr ispec' dup_ispec
	    []            -> return ()
620 621

		-- OK, now extend the envt
622 623 624 625 626 627 628 629 630 631 632 633 634 635 636
	; 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)))
637
  where
638 639
    pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
	-- Print the dfun name itself too
640

641 642
funDepErr ispec ispecs
  = addDictLoc ispec $
643
    addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
644 645 646
	       2 (pprInstances (ispec:ispecs)))
dupInstErr ispec dup_ispec
  = addDictLoc ispec $
647
    addErr (hang (ptext SLIT("Duplicate instance declarations:"))
648
	       2 (pprInstances [ispec, dup_ispec]))
649

650
addDictLoc ispec thing_inside
651
  = setSrcSpan (mkSrcSpan loc loc) thing_inside
652
  where
653
   loc = getSrcLoc ispec
654
\end{code}
655
    
656

657 658
%************************************************************************
%*									*
659
\subsection{Looking up Insts}
660 661 662 663
%*									*
%************************************************************************

\begin{code}
664
data LookupInstResult
665
  = NoInstance
666 667 668 669
  | 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
670

671 672 673
-- 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
674

675
--------------------- Implications ------------------------
676
lookupSimpleInst (ImplicInst {}) = return NoInstance
677

678 679
--------------------- Methods ------------------------
lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
680
  = do	{ (dicts, dict_app) <- instCallDicts loc theta
681 682
	; let co_fn = dict_app <.> mkWpTyApps tys
	; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
683
  where
684
    span = instLocSpan loc
685

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

693
lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name, tci_ty = ty, tci_loc = loc})
694
  | Just expr <- shortCutIntLit i ty
695
  = returnM (GenInst [] (noLoc expr))
696
  | otherwise
697
  = ASSERT( from_integer_name `isHsVar` fromIntegerName )	-- A LitInst invariant
698
    tcLookupId fromIntegerName			`thenM` \ from_integer ->
699
    tcInstClassOp loc from_integer [ty]		`thenM` \ method_inst ->
700
    mkIntegerLit i				`thenM` \ integer_lit ->
701
    returnM (GenInst [method_inst]
702
		     (mkHsApp (L (instLocSpan loc)
703
			   	 (HsVar (instToId method_inst))) integer_lit))
704

705
lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name, tci_ty = ty, tci_loc = loc})
706
  | Just expr <- shortCutFracLit f ty
707
  = returnM (GenInst [] (noLoc expr))
708 709

  | otherwise
710
  = ASSERT( from_rat_name `isHsVar` fromRationalName )	-- A LitInst invariant
711
    tcLookupId fromRationalName			`thenM` \ from_rational ->
712
    tcInstClassOp loc from_rational [ty]	`thenM` \ method_inst ->
713
    mkRatLit f					`thenM` \ rat_lit ->
714
    returnM (GenInst [method_inst] (mkHsApp (L (instLocSpan loc) 
715
					       (HsVar (instToId method_inst))) rat_lit))
716

717 718
--------------------- Dictionaries ------------------------
lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
719 720 721 722
  = do 	{ mb_result <- lookupPred pred
	; case mb_result of {
	    Nothing -> return NoInstance ;
	    Just (tenv, dfun_id) -> do
723

724
    -- tenv is a substitution that instantiates the dfun_id 
725 726 727 728 729 730 731
    -- to match the requested result type.   
    -- 
    -- We ASSUME that the dfun is quantified over the very same tyvars 
    -- that are bound by the tenv.
    -- 
    -- However, the dfun
    -- might have some tyvars that *only* appear in arguments
732 733 734
    --	dfun :: forall a b. C a b, Ord b => D [a]
    -- We instantiate b to a flexi type variable -- it'll presumably
    -- become fixed later via functional dependencies
735 736 737
    { use_stage <- getStage
    ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
    		      (topIdLvl dfun_id) use_stage
738

739 740 741 742
 	-- 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)
743
	-- Hence the open_tvs to instantiate any un-substituted tyvars.	
744 745 746 747
    ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
	  open_tvs      = filter (`notElemTvSubst` tenv) tyvars
    ; open_tvs' <- mappM tcInstTyVar open_tvs
    ; let
748
 	tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
749
		-- Since the open_tvs' are freshly made, they cannot possibly be captured by
750 751
		-- any nested for-alls in rho.  So the in-scope set is unchanged
    	dfun_rho   = substTy tenv' rho
752
    	(theta, _) = tcSplitPhiTy dfun_rho
753
	src_loc	   = instLocSpan loc
754 755
	dfun	   = HsVar dfun_id
	tys	   = map (substTyVar tenv') tyvars
756
    ; if null theta then
757
    	returnM (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
758
      else do
759
    { (dicts, dict_app) <- instCallDicts loc theta
760 761
    ; let co_fn = dict_app <.> mkWpTyApps tys
    ; returnM (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
762 763 764 765 766 767
    }}}}

---------------
lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
-- Look up a class constraint in the instance environment
lookupPred pred@(ClassP clas tys)
768
  = do	{ eps     <- getEps
769
	; tcg_env <- getGblEnv
770 771 772 773 774
	; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
	; case lookupInstEnv inst_envs clas tys of {
	    ([(tenv, ispec)], []) 
		-> do	{ let dfun_id = is_dfun ispec
			; traceTc (text "lookupInst success" <+> 
775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794
				   vcat [text "dict" <+> ppr pred, 
				         text "witness" <+> ppr dfun_id
					 <+> ppr (idType dfun_id) ])
				-- Record that this dfun is needed
			; record_dfun_usage dfun_id
			; return (Just (tenv, dfun_id)) } ;

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

795
lookupPred ip_pred = return Nothing	-- Implicit parameters
796 797

record_dfun_usage dfun_id 
Simon Marlow's avatar
Simon Marlow committed
798
  = do	{ hsc_env <- getTopEnv
799 800
	; let  dfun_name = idName dfun_id
	       dfun_mod  = nameModule dfun_name
801
	; if isInternalName dfun_name ||    -- Internal name => defined in this module
Simon Marlow's avatar
Simon Marlow committed
802
	     modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
803 804 805 806 807
	  then return () -- internal, or in another package
	   else do { tcg_env <- getGblEnv
	  	   ; updMutVar (tcg_inst_uses tcg_env)
			       (`addOneToNameSet` idName dfun_id) }}

808 809

tcGetInstEnvs :: TcM (InstEnv, InstEnv)
810 811
-- Gets both the external-package inst-env
-- and the home-pkg inst env (includes module being compiled)
812
tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
813
		     return (eps_inst_env eps, tcg_inst_env env) }
814 815
\end{code}

816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847


%************************************************************************
%*									*
		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
848
	     -> TcType			-- Type to instantiate it at
849 850
	     -> (Name, HsExpr Name)	-- (Standard name, user name)
	     -> TcM (Name, HsExpr TcId)	-- (Standard name, suitable expression)
851
--	*** NOW USED ONLY FOR CmdTop (sigh) ***
852 853 854
-- NB: tcSyntaxName calls tcExpr, and hence can do unification.
-- So we do not call it from lookupInst, which is called from tcSimplify

855
tcSyntaxName orig ty (std_nm, HsVar user_nm)
856
  | std_nm == user_nm
857 858
  = newMethodFromName orig ty std_nm	`thenM` \ id ->
    returnM (std_nm, HsVar id)
859

860
tcSyntaxName orig ty (std_nm, user_nm_expr)
861
  = tcLookupId std_nm		`thenM` \ std_id ->
862 863 864
    let	
	-- C.f. newMethodAtLoc
	([tv], _, tau)  = tcSplitSigmaTy (idType std_id)
865
 	sigma1		= substTyWith [tv] [ty] tau
866 867
	-- Actually, the "tau-type" might be a sigma-type in the
	-- case of locally-polymorphic methods.
868
    in
869
    addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1)	$
870 871

	-- Check that the user-supplied thing has the
872 873 874
	-- same type as the standard one.  
	-- Tiresome jiggling because tcCheckSigma takes a located expression
    getSrcSpanM					`thenM` \ span -> 
875
    tcPolyExpr (L span user_nm_expr) sigma1	`thenM` \ expr ->
876
    returnM (std_nm, unLoc expr)
877 878

syntaxNameCtxt name orig ty tidy_env
879
  = getInstLoc orig		`thenM` \ inst_loc ->
880 881 882 883
    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)),
884
		    nest 2 (ptext SLIT("arising from") <+> pprInstLoc inst_loc)]
885
    in
886
    returnM (tidy_env, msg)
887
\end{code}