2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 The @Inst@ type: dictionaries or method instances
12 pprInstances, pprDictsTheta, pprDictsInFull, -- User error messages
13 showLIE, pprInst, pprInsts, pprInstInFull, -- Debugging messages
15 tidyInsts, tidyMoreInsts,
17 newDictBndr, newDictBndrs, newDictBndrsO,
18 instCall, instStupidTheta,
20 newIPDict, newMethod, newMethodFromName, newMethodWithGivenTy,
22 tcSyntaxName, isHsVar,
24 tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
25 ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
26 getDictClassTys, dictPred,
28 lookupSimpleInst, LookupInstResult(..),
29 tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
31 isAbstractableInst, isEqInst,
32 isDict, isClassDict, isMethod, isImplicInst,
33 isIPDict, isInheritableInst, isMethodOrLit,
34 isTyVarDict, isMethodFor,
37 instToId, instToVar, instType, instName, instToDictBind,
40 InstOrigin(..), InstLoc, pprInstLoc,
42 mkWantedCo, mkGivenCo,
43 fromWantedCo, fromGivenCo,
44 eitherEqInst, mkEqInst, mkEqInsts, mkWantedEqInst,
45 finalizeEqInst, writeWantedCoercion,
46 eqInstType, updateEqInstCoercion,
47 eqInstCoercion, eqInstTys
50 #include "HsVersions.h"
52 import {-# SOURCE #-} TcExpr( tcPolyExpr )
53 import {-# SOURCE #-} TcUnify( boxyUnify {- , unifyType -} )
76 import Var ( Var, TyVar )
98 instName :: Inst -> Name
99 instName (EqInst {tci_name = name}) = name
100 instName inst = Var.varName (instToVar inst)
102 instToId :: Inst -> TcId
103 instToId inst = WARN( not (isId id), ppr inst )
108 instToVar :: Inst -> Var
109 instToVar (LitInst {tci_name = nm, tci_ty = ty})
111 instToVar (Method {tci_id = id})
113 instToVar (Dict {tci_name = nm, tci_pred = pred})
114 | isEqPred pred = Var.mkCoVar nm (mkPredTy pred)
115 | otherwise = mkLocalId nm (mkPredTy pred)
116 instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens,
117 tci_wanted = wanteds})
118 = mkLocalId nm (mkImplicTy tvs givens wanteds)
119 instToVar i@(EqInst {})
120 = eitherEqInst i id (\(TyVarTy covar) -> covar)
122 instType :: Inst -> Type
123 instType (LitInst {tci_ty = ty}) = ty
124 instType (Method {tci_id = id}) = idType id
125 instType (Dict {tci_pred = pred}) = mkPredTy pred
126 instType imp@(ImplicInst {}) = mkImplicTy (tci_tyvars imp) (tci_given imp)
128 -- instType i@(EqInst {tci_co = co}) = eitherEqInst i TyVarTy id
129 instType (EqInst {tci_left = ty1, tci_right = ty2}) = mkPredTy (EqPred ty1 ty2)
131 mkImplicTy :: [TyVar] -> [Inst] -> [Inst] -> Type
132 mkImplicTy tvs givens wanteds -- The type of an implication constraint
133 = ASSERT( all isAbstractableInst givens )
134 -- pprTrace "mkImplicTy" (ppr givens) $
135 -- See [Equational Constraints in Implication Constraints]
136 let dict_wanteds = filter (not . isEqInst) wanteds
139 mkPhiTy (map dictPred givens) $
140 mkBigCoreTupTy (map instType dict_wanteds)
142 dictPred :: Inst -> TcPredType
143 dictPred (Dict {tci_pred = pred}) = pred
144 dictPred (EqInst {tci_left=ty1,tci_right=ty2}) = EqPred ty1 ty2
145 dictPred inst = pprPanic "dictPred" (ppr inst)
147 getDictClassTys :: Inst -> (Class, [Type])
148 getDictClassTys (Dict {tci_pred = pred}) = getClassPredTys pred
149 getDictClassTys inst = pprPanic "getDictClassTys" (ppr inst)
151 -- fdPredsOfInst is used to get predicates that contain functional
152 -- dependencies *or* might do so. The "might do" part is because
153 -- a constraint (C a b) might have a superclass with FDs
154 -- Leaving these in is really important for the call to fdPredsOfInsts
155 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
156 -- which is supposed to be conservative
157 fdPredsOfInst :: Inst -> [TcPredType]
158 fdPredsOfInst (Dict {tci_pred = pred}) = [pred]
159 fdPredsOfInst (Method {tci_theta = theta}) = theta
160 fdPredsOfInst (ImplicInst {tci_given = gs,
161 tci_wanted = ws}) = fdPredsOfInsts (gs ++ ws)
162 fdPredsOfInst (LitInst {}) = []
163 fdPredsOfInst (EqInst {}) = []
165 fdPredsOfInsts :: [Inst] -> [PredType]
166 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
168 isInheritableInst :: Inst -> Bool
169 isInheritableInst (Dict {tci_pred = pred}) = isInheritablePred pred
170 isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta
171 isInheritableInst _ = True
174 ---------------------------------
175 -- Get the implicit parameters mentioned by these Insts
176 -- NB: the results of these functions are insensitive to zonking
178 ipNamesOfInsts :: [Inst] -> [Name]
179 ipNamesOfInst :: Inst -> [Name]
180 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
182 ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
183 ipNamesOfInst (Method {tci_theta = theta}) = [ipNameName n | IParam n _ <- theta]
186 ---------------------------------
187 tyVarsOfInst :: Inst -> TcTyVarSet
188 tyVarsOfInst (LitInst {tci_ty = ty}) = tyVarsOfType ty
189 tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
190 tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id
191 -- The id might have free type variables; in the case of
192 -- locally-overloaded class methods, for example
193 tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds})
194 = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds)
195 `minusVarSet` mkVarSet tvs
196 `unionVarSet` unionVarSets (map varTypeTyVars tvs)
197 -- Remember the free tyvars of a coercion
198 tyVarsOfInst (EqInst {tci_left = ty1, tci_right = ty2}) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
200 tyVarsOfInsts :: [Inst] -> VarSet
201 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
202 tyVarsOfLIE :: Bag Inst -> VarSet
203 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
206 --------------------------
207 instToDictBind :: Inst -> LHsExpr TcId -> TcDictBinds
208 instToDictBind inst rhs
209 = unitBag (L (instSpan inst) (VarBind (instToId inst) rhs))
211 addInstToDictBind :: TcDictBinds -> Inst -> LHsExpr TcId -> TcDictBinds
212 addInstToDictBind binds inst rhs = binds `unionBags` instToDictBind inst rhs
219 isAbstractableInst :: Inst -> Bool
220 isAbstractableInst inst = isDict inst || isEqInst inst
222 isEqInst :: Inst -> Bool
223 isEqInst (EqInst {}) = True
226 isDict :: Inst -> Bool
227 isDict (Dict {}) = True
230 isClassDict :: Inst -> Bool
231 isClassDict (Dict {tci_pred = pred}) = isClassPred pred
232 isClassDict _ = False
234 isTyVarDict :: Inst -> Bool
235 isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
236 isTyVarDict _ = False
238 isIPDict :: Inst -> Bool
239 isIPDict (Dict {tci_pred = pred}) = isIPPred pred
242 isImplicInst :: Inst -> Bool
243 isImplicInst (ImplicInst {}) = True
244 isImplicInst _ = False
246 isMethod :: Inst -> Bool
247 isMethod (Method {}) = True
250 isMethodFor :: TcIdSet -> Inst -> Bool
251 isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
252 isMethodFor _ _ = False
254 isMethodOrLit :: Inst -> Bool
255 isMethodOrLit (Method {}) = True
256 isMethodOrLit (LitInst {}) = True
257 isMethodOrLit _ = False
261 %************************************************************************
263 \subsection{Building dictionaries}
265 %************************************************************************
267 -- newDictBndrs makes a dictionary at a binding site
268 -- instCall makes a dictionary at an occurrence site
269 -- and throws it into the LIE
273 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
274 newDictBndrsO orig theta = do { loc <- getInstLoc orig
275 ; newDictBndrs loc theta }
277 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
278 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
280 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
281 newDictBndr inst_loc pred@(EqPred ty1 ty2)
282 = do { uniq <- newUnique
283 ; let name = mkPredName uniq inst_loc pred
284 ; return (EqInst {tci_name = name,
288 tci_co = mkGivenCo $ TyVarTy (Var.mkCoVar name (PredTy pred))})
290 newDictBndr inst_loc pred
291 = do { uniq <- newUnique
292 ; let name = mkPredName uniq inst_loc pred
293 ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
296 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
297 -- Instantiate the constraints of a call
298 -- (instCall o tys theta)
299 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
300 -- (b) Throws these dictionaries into the LIE
301 -- (c) Returns an HsWrapper ([.] tys dicts)
303 instCall orig tys theta
304 = do { loc <- getInstLoc orig
305 ; dict_app <- instCallDicts loc theta
306 ; return (dict_app <.> mkWpTyApps tys) }
309 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
310 -- Similar to instCall, but only emit the constraints in the LIE
311 -- Used exclusively for the 'stupid theta' of a data constructor
312 instStupidTheta orig theta
313 = do { loc <- getInstLoc orig
314 ; _co <- instCallDicts loc theta -- Discard the coercion
318 instCallDicts :: InstLoc -> TcThetaType -> TcM HsWrapper
319 -- Instantiates the TcTheta, puts all constraints thereby generated
320 -- into the LIE, and returns a HsWrapper to enclose the call site.
321 -- This is the key place where equality predicates
322 -- are unleashed into the world
323 instCallDicts _ [] = return idHsWrapper
325 -- instCallDicts loc (EqPred ty1 ty2 : preds)
326 -- = do { unifyType ty1 ty2 -- For now, we insist that they unify right away
327 -- -- Later on, when we do associated types,
328 -- -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
329 -- ; (dicts, co_fn) <- instCallDicts loc preds
330 -- ; return (dicts, co_fn <.> WpTyApp ty1) }
331 -- -- We use type application to apply the function to the
332 -- -- coercion; here ty1 *is* the appropriate identity coercion
334 instCallDicts loc (EqPred ty1 ty2 : preds)
335 = do { traceTc (text "instCallDicts" <+> ppr (EqPred ty1 ty2))
336 ; coi <- boxyUnify ty1 ty2
337 -- ; coi <- unifyType ty1 ty2
338 ; let co = fromCoI coi ty1
339 ; co_fn <- instCallDicts loc preds
340 ; return (co_fn <.> WpTyApp co) }
342 instCallDicts loc (pred : preds)
343 = do { uniq <- newUnique
344 ; let name = mkPredName uniq loc pred
345 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
347 ; co_fn <- instCallDicts loc preds
348 ; return (co_fn <.> WpApp (instToId dict)) }
351 cloneDict :: Inst -> TcM Inst
352 cloneDict dict@(Dict nm _ _) = do { uniq <- newUnique
353 ; return (dict {tci_name = setNameUnique nm uniq}) }
354 cloneDict eq@(EqInst {}) = return eq
355 cloneDict other = pprPanic "cloneDict" (ppr other)
357 -- For vanilla implicit parameters, there is only one in scope
358 -- at any time, so we used to use the name of the implicit parameter itself
359 -- But with splittable implicit parameters there may be many in
360 -- scope, so we make up a new namea.
361 newIPDict :: InstOrigin -> IPName Name -> Type
362 -> TcM (IPName Id, Inst)
363 newIPDict orig ip_name ty = do
364 inst_loc <- getInstLoc orig
367 pred = IParam ip_name ty
368 name = mkPredName uniq inst_loc pred
369 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}
371 return (mapIPName (\_ -> instToId dict) ip_name, dict)
376 mkPredName :: Unique -> InstLoc -> PredType -> Name
377 mkPredName uniq loc pred_ty
378 = mkInternalName uniq occ (instLocSpan loc)
380 occ = case pred_ty of
381 ClassP cls _ -> mkDictOcc (getOccName cls)
382 IParam ip _ -> getOccName (ipNameName ip)
383 EqPred ty _ -> mkEqPredCoOcc baseOcc
385 -- we use the outermost tycon of the lhs, if there is one, to
386 -- improve readability of Core code
387 baseOcc = case splitTyConApp_maybe ty of
388 Nothing -> mkOccName tcName "$"
389 Just (tc, _) -> getOccName tc
392 %************************************************************************
394 \subsection{Building methods (calls of overloaded functions)}
396 %************************************************************************
400 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
401 newMethodFromName origin ty name = do
402 id <- tcLookupId name
403 -- Use tcLookupId not tcLookupGlobalId; the method is almost
404 -- always a class op, but with -fno-implicit-prelude GHC is
405 -- meant to find whatever thing is in scope, and that may
406 -- be an ordinary function.
407 loc <- getInstLoc origin
408 inst <- tcInstClassOp loc id [ty]
410 return (instToId inst)
412 newMethodWithGivenTy :: InstOrigin -> Id -> [Type] -> TcRn TcId
413 newMethodWithGivenTy orig id tys = do
414 loc <- getInstLoc orig
415 inst <- newMethod loc id tys
417 return (instToId inst)
419 --------------------------------------------
420 -- tcInstClassOp, and newMethod do *not* drop the
421 -- Inst into the LIE; they just returns the Inst
422 -- This is important because they are used by TcSimplify
425 -- NB: the kind of the type variable to be instantiated
426 -- might be a sub-kind of the type to which it is applied,
427 -- notably when the latter is a type variable of kind ??
428 -- Hence the call to checkKind
429 -- A worry: is this needed anywhere else?
430 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
431 tcInstClassOp inst_loc sel_id tys = do
433 (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
434 zipWithM_ checkKind tyvars tys
435 newMethod inst_loc sel_id tys
437 checkKind :: TyVar -> TcType -> TcM ()
438 -- Ensure that the type has a sub-kind of the tyvar
441 -- ty1 <- zonkTcType ty
442 ; if typeKind ty1 `isSubKind` Var.tyVarKind tv
446 pprPanic "checkKind: adding kind constraint"
447 (vcat [ppr tv <+> ppr (Var.tyVarKind tv),
448 ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
450 -- do { tv1 <- tcInstTyVar tv
451 -- ; unifyType ty1 (mkTyVarTy tv1) } }
454 ---------------------------
455 newMethod :: InstLoc -> Id -> [Type] -> TcRn Inst
456 newMethod inst_loc id tys = do
457 new_uniq <- newUnique
459 (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
460 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
461 inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
462 tci_theta = theta, tci_loc = inst_loc}
463 loc = instLocSpan inst_loc
469 mkOverLit :: OverLitVal -> TcM HsLit
470 mkOverLit (HsIntegral i)
471 = do { integer_ty <- tcMetaTy integerTyConName
472 ; return (HsInteger i integer_ty) }
474 mkOverLit (HsFractional r)
475 = do { rat_ty <- tcMetaTy rationalTyConName
476 ; return (HsRat r rat_ty) }
478 mkOverLit (HsIsString s) = return (HsString s)
480 isHsVar :: HsExpr Name -> Name -> Bool
481 isHsVar (HsVar f) g = f == g
486 %************************************************************************
490 %************************************************************************
492 Zonking makes sure that the instance types are fully zonked.
495 zonkInst :: Inst -> TcM Inst
496 zonkInst dict@(Dict { tci_pred = pred}) = do
497 new_pred <- zonkTcPredType pred
498 return (dict {tci_pred = new_pred})
500 zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta}) = do
502 -- Essential to zonk the id in case it's a local variable
503 -- Can't use zonkIdOcc because the id might itself be
504 -- an InstId, in which case it won't be in scope
506 new_tys <- zonkTcTypes tys
507 new_theta <- zonkTcThetaType theta
508 return (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
509 -- No need to zonk the tci_id
511 zonkInst lit@(LitInst {tci_ty = ty}) = do
512 new_ty <- zonkTcType ty
513 return (lit {tci_ty = new_ty})
515 zonkInst implic@(ImplicInst {})
516 = ASSERT( all isImmutableTyVar (tci_tyvars implic) )
517 do { givens' <- zonkInsts (tci_given implic)
518 ; wanteds' <- zonkInsts (tci_wanted implic)
519 ; return (implic {tci_given = givens',tci_wanted = wanteds'}) }
521 zonkInst eqinst@(EqInst {tci_left = ty1, tci_right = ty2})
522 = do { co' <- eitherEqInst eqinst
523 (\covar -> return (mkWantedCo covar))
524 (\co -> liftM mkGivenCo $ zonkTcType co)
525 ; ty1' <- zonkTcType ty1
526 ; ty2' <- zonkTcType ty2
527 ; return (eqinst {tci_co = co', tci_left= ty1', tci_right = ty2' })
530 zonkInsts :: [Inst] -> TcRn [Inst]
531 zonkInsts insts = mapM zonkInst insts
535 %************************************************************************
537 \subsection{Printing}
539 %************************************************************************
541 ToDo: improve these pretty-printing things. The ``origin'' is really only
542 relevant in error messages.
545 instance Outputable Inst where
546 ppr inst = pprInst inst
548 pprDictsTheta :: [Inst] -> SDoc
549 -- Print in type-like fashion (Eq a, Show b)
550 -- The Inst can be an implication constraint, but not a Method or LitInst
551 pprDictsTheta insts = parens (sep (punctuate comma (map (ppr . instType) insts)))
553 pprDictsInFull :: [Inst] -> SDoc
554 -- Print in type-like fashion, but with source location
556 = vcat (map go dicts)
558 go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
560 pprInsts :: [Inst] -> SDoc
561 -- Debugging: print the evidence :: type
562 pprInsts insts = brackets (interpp'SP insts)
564 pprInst, pprInstInFull :: Inst -> SDoc
565 -- Debugging: print the evidence :: type
566 pprInst i@(EqInst {tci_left = ty1, tci_right = ty2})
568 (\covar -> text "Wanted" <+> ppr (TyVarTy covar) <+> dcolon <+> ppr (EqPred ty1 ty2))
569 (\co -> text "Given" <+> ppr co <+> dcolon <+> ppr (EqPred ty1 ty2))
570 pprInst inst = ppr name <> braces (pprUnique (getUnique name)) <+> dcolon
571 <+> braces (ppr (instType inst) <> implicWantedEqs)
575 | isImplicInst inst = text " &" <+>
576 ppr (filter isEqInst (tci_wanted inst))
579 pprInstInFull inst@(EqInst {}) = pprInst inst
580 pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
582 tidyInst :: TidyEnv -> Inst -> Inst
583 tidyInst env eq@(EqInst {tci_left = lty, tci_right = rty, tci_co = co}) =
584 eq { tci_left = tidyType env lty
585 , tci_right = tidyType env rty
586 , tci_co = either Left (Right . tidyType env) co
588 tidyInst env lit@(LitInst {tci_ty = ty}) = lit {tci_ty = tidyType env ty}
589 tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
590 tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
591 tidyInst env implic@(ImplicInst {})
592 = implic { tci_tyvars = tvs'
593 , tci_given = map (tidyInst env') (tci_given implic)
594 , tci_wanted = map (tidyInst env') (tci_wanted implic) }
596 (env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic)
598 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
599 -- This function doesn't assume that the tyvars are in scope
600 -- so it works like tidyOpenType, returning a TidyEnv
601 tidyMoreInsts env insts
602 = (env', map (tidyInst env') insts)
604 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
606 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
607 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
609 showLIE :: SDoc -> TcM () -- Debugging
611 = do { lie_var <- getLIEVar ;
612 lie <- readMutVar lie_var ;
613 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
617 %************************************************************************
619 Extending the instance environment
621 %************************************************************************
624 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
625 -- Add new locally-defined instances
626 tcExtendLocalInstEnv dfuns thing_inside
627 = do { traceDFuns dfuns
629 ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
630 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
631 tcg_inst_env = inst_env' }
632 ; setGblEnv env' thing_inside }
634 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
635 -- Check that the proposed new instance is OK,
636 -- and then add it to the home inst env
637 addLocalInst home_ie ispec
638 = do { -- Instantiate the dfun type so that we extend the instance
639 -- envt with completely fresh template variables
640 -- This is important because the template variables must
641 -- not overlap with anything in the things being looked up
642 -- (since we do unification).
643 -- We use tcInstSkolType because we don't want to allocate fresh
644 -- *meta* type variables.
645 let dfun = instanceDFunId ispec
646 ; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun)
647 ; let (cls, tys') = tcSplitDFunHead tau'
648 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
649 ispec' = setInstanceDFunId ispec dfun'
651 -- Load imported instances, so that we report
652 -- duplicates correctly
654 ; let inst_envs = (eps_inst_env eps, home_ie)
656 -- Check functional dependencies
657 ; case checkFunDeps inst_envs ispec' of
658 Just specs -> funDepErr ispec' specs
661 -- Check for duplicate instance decls
662 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
663 ; dup_ispecs = [ dup_ispec
664 | (dup_ispec, _) <- matches
665 , let (_,_,_,dup_tys) = instanceHead dup_ispec
666 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
667 -- Find memebers of the match list which ispec itself matches.
668 -- If the match is 2-way, it's a duplicate
670 dup_ispec : _ -> dupInstErr ispec' dup_ispec
673 -- OK, now extend the envt
674 ; return (extendInstEnv home_ie ispec') }
676 getOverlapFlag :: TcM OverlapFlag
678 = do { dflags <- getDOpts
679 ; let overlap_ok = dopt Opt_OverlappingInstances dflags
680 incoherent_ok = dopt Opt_IncoherentInstances dflags
681 overlap_flag | incoherent_ok = Incoherent
682 | overlap_ok = OverlapOk
683 | otherwise = NoOverlap
685 ; return overlap_flag }
687 traceDFuns :: [Instance] -> TcRn ()
689 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
691 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
692 -- Print the dfun name itself too
694 funDepErr :: Instance -> [Instance] -> TcRn ()
695 funDepErr ispec ispecs
697 addErr (hang (ptext (sLit "Functional dependencies conflict between instance declarations:"))
698 2 (pprInstances (ispec:ispecs)))
699 dupInstErr :: Instance -> Instance -> TcRn ()
700 dupInstErr ispec dup_ispec
702 addErr (hang (ptext (sLit "Duplicate instance declarations:"))
703 2 (pprInstances [ispec, dup_ispec]))
705 addDictLoc :: Instance -> TcRn a -> TcRn a
706 addDictLoc ispec thing_inside
707 = setSrcSpan (mkSrcSpan loc loc) thing_inside
709 loc = getSrcLoc ispec
713 %************************************************************************
715 \subsection{Looking up Insts}
717 %************************************************************************
720 data LookupInstResult
722 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
724 lookupSimpleInst :: Inst -> TcM LookupInstResult
725 -- This is "simple" in that it returns NoInstance for implication constraints
727 -- It's important that lookupInst does not put any new stuff into
728 -- the LIE. Instead, any Insts needed by the lookup are returned in
729 -- the LookupInstResult, where they can be further processed by tcSimplify
731 lookupSimpleInst (EqInst {}) = return NoInstance
733 --------------------- Implications ------------------------
734 lookupSimpleInst (ImplicInst {}) = return NoInstance
736 --------------------- Methods ------------------------
737 lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
738 = do { (dict_app, dicts) <- getLIE $ instCallDicts loc theta
739 ; let co_fn = dict_app <.> mkWpTyApps tys
740 ; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
742 span = instLocSpan loc
744 --------------------- Literals ------------------------
745 -- Look for short cuts first: if the literal is *definitely* a
746 -- int, integer, float or a double, generate the real thing here.
747 -- This is essential (see nofib/spectral/nucleic).
748 -- [Same shortcut as in newOverloadedLit, but we
749 -- may have done some unification by now]
751 lookupSimpleInst (LitInst { tci_lit = lit@OverLit { ol_val = lit_val
752 , ol_rebindable = rebindable }
753 , tci_ty = ty, tci_loc = iloc})
754 | debugIsOn && rebindable = panic "lookupSimpleInst" -- A LitInst invariant
755 | Just witness <- shortCutLit lit_val ty
756 = do { let lit' = lit { ol_witness = witness, ol_type = ty }
757 ; return (GenInst [] (L loc (HsOverLit lit'))) }
760 = do { hs_lit <- mkOverLit lit_val
761 ; from_thing <- tcLookupId (hsOverLitName lit_val)
762 -- Not rebindable, so hsOverLitName is the right thing
763 ; method_inst <- tcInstClassOp iloc from_thing [ty]
764 ; let witness = HsApp (L loc (HsVar (instToId method_inst)))
765 (L loc (HsLit hs_lit))
766 lit' = lit { ol_witness = witness, ol_type = ty }
767 ; return (GenInst [method_inst] (L loc (HsOverLit lit'))) }
769 loc = instLocSpan iloc
771 --------------------- Dictionaries ------------------------
772 lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
773 = do { mb_result <- lookupPred pred
774 ; case mb_result of {
775 Nothing -> return NoInstance ;
776 Just (dfun_id, mb_inst_tys) -> do
778 { use_stage <- getStage
779 ; checkWellStaged (ptext (sLit "instance for") <+> quotes (ppr pred))
780 (topIdLvl dfun_id) use_stage
782 -- It's possible that not all the tyvars are in
783 -- the substitution, tenv. For example:
784 -- instance C X a => D X where ...
785 -- (presumably there's a functional dependency in class C)
786 -- Hence mb_inst_tys :: Either TyVar TcType
788 ; let inst_tv (Left tv) = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
789 inst_tv (Right ty) = return ty
790 ; tys <- mapM inst_tv mb_inst_tys
792 (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
793 src_loc = instLocSpan loc
796 return (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
798 { (dict_app, dicts) <- getLIE $ instCallDicts loc theta -- !!!
799 ; let co_fn = dict_app <.> mkWpTyApps tys
800 ; return (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
804 lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
805 -- Look up a class constraint in the instance environment
806 lookupPred pred@(ClassP clas tys)
808 ; tcg_env <- getGblEnv
809 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
810 ; case lookupInstEnv inst_envs clas tys of {
811 ([(ispec, inst_tys)], [])
812 -> do { let dfun_id = is_dfun ispec
813 ; traceTc (text "lookupInst success" <+>
814 vcat [text "dict" <+> ppr pred,
815 text "witness" <+> ppr dfun_id
816 <+> ppr (idType dfun_id) ])
817 -- Record that this dfun is needed
818 ; record_dfun_usage dfun_id
819 ; return (Just (dfun_id, inst_tys)) } ;
822 -> do { traceTc (text "lookupInst fail" <+>
823 vcat [text "dict" <+> ppr pred,
824 text "matches" <+> ppr matches,
825 text "unifs" <+> ppr unifs])
826 -- In the case of overlap (multiple matches) we report
827 -- NoInstance here. That has the effect of making the
828 -- context-simplifier return the dict as an irreducible one.
829 -- Then it'll be given to addNoInstanceErrs, which will do another
830 -- lookupInstEnv to get the detailed info about what went wrong.
834 lookupPred (IParam {}) = return Nothing -- Implicit parameters
835 lookupPred (EqPred {}) = panic "lookupPred EqPred"
837 record_dfun_usage :: Id -> TcRn ()
838 record_dfun_usage dfun_id
839 = do { hsc_env <- getTopEnv
840 ; let dfun_name = idName dfun_id
841 dfun_mod = nameModule dfun_name
842 ; if isInternalName dfun_name || -- Internal name => defined in this module
843 modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
844 then return () -- internal, or in another package
845 else do { tcg_env <- getGblEnv
846 ; updMutVar (tcg_inst_uses tcg_env)
847 (`addOneToNameSet` idName dfun_id) }}
850 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
851 -- Gets both the external-package inst-env
852 -- and the home-pkg inst env (includes module being compiled)
853 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
854 return (eps_inst_env eps, tcg_inst_env env) }
859 %************************************************************************
863 %************************************************************************
865 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
866 a do-expression. We have to find (>>) in the current environment, which is
867 done by the rename. Then we have to check that it has the same type as
868 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
871 (>>) :: HB m n mn => m a -> n b -> mn b
873 So the idea is to generate a local binding for (>>), thus:
875 let then72 :: forall a b. m a -> m b -> m b
876 then72 = ...something involving the user's (>>)...
878 ...the do-expression...
880 Now the do-expression can proceed using then72, which has exactly
883 In fact tcSyntaxName just generates the RHS for then72, because we only
884 want an actual binding in the do-expression case. For literals, we can
885 just use the expression inline.
888 tcSyntaxName :: InstOrigin
889 -> TcType -- Type to instantiate it at
890 -> (Name, HsExpr Name) -- (Standard name, user name)
891 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
892 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
893 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
894 -- So we do not call it from lookupInst, which is called from tcSimplify
896 tcSyntaxName orig ty (std_nm, HsVar user_nm)
898 = do id <- newMethodFromName orig ty std_nm
899 return (std_nm, HsVar id)
901 tcSyntaxName orig ty (std_nm, user_nm_expr) = do
902 std_id <- tcLookupId std_nm
904 -- C.f. newMethodAtLoc
905 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
906 sigma1 = substTyWith [tv] [ty] tau
907 -- Actually, the "tau-type" might be a sigma-type in the
908 -- case of locally-polymorphic methods.
910 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
912 -- Check that the user-supplied thing has the
913 -- same type as the standard one.
914 -- Tiresome jiggling because tcCheckSigma takes a located expression
916 expr <- tcPolyExpr (L span user_nm_expr) sigma1
917 return (std_nm, unLoc expr)
919 syntaxNameCtxt :: HsExpr Name -> InstOrigin -> Type -> TidyEnv
920 -> TcRn (TidyEnv, SDoc)
921 syntaxNameCtxt name orig ty tidy_env = do
922 inst_loc <- getInstLoc orig
924 msg = vcat [ptext (sLit "When checking that") <+> quotes (ppr name) <+>
925 ptext (sLit "(needed by a syntactic construct)"),
926 nest 2 (ptext (sLit "has the required type:") <+> ppr (tidyType tidy_env ty)),
927 nest 2 (ptext (sLit "arising from") <+> pprInstLoc inst_loc)]
929 return (tidy_env, msg)
932 %************************************************************************
936 %************************************************************************
939 mkGivenCo :: Coercion -> Either TcTyVar Coercion
942 mkWantedCo :: TcTyVar -> Either TcTyVar Coercion
945 fromGivenCo :: Either TcTyVar Coercion -> Coercion
946 fromGivenCo (Right co) = co
947 fromGivenCo _ = panic "fromGivenCo: not a wanted coercion"
949 fromWantedCo :: String -> Either TcTyVar Coercion -> TcTyVar
950 fromWantedCo _ (Left covar) = covar
951 fromWantedCo msg _ = panic ("fromWantedCo: not a wanted coercion: " ++ msg)
953 eitherEqInst :: Inst -- given or wanted EqInst
954 -> (TcTyVar -> a) -- result if wanted
955 -> (Coercion -> a) -- result if given
957 eitherEqInst (EqInst {tci_co = either_co}) withWanted withGiven
959 Left covar -> withWanted covar
960 Right co -> withGiven co
961 eitherEqInst i _ _ = pprPanic "eitherEqInst" (ppr i)
963 mkEqInsts :: [PredType] -> [Either TcTyVar Coercion] -> TcM [Inst]
964 mkEqInsts preds cos = zipWithM mkEqInst preds cos
966 mkEqInst :: PredType -> Either TcTyVar Coercion -> TcM Inst
967 mkEqInst (EqPred ty1 ty2) co
968 = do { uniq <- newUnique
969 ; src_span <- getSrcSpanM
970 ; err_ctxt <- getErrCtxt
971 ; let loc = InstLoc EqOrigin src_span err_ctxt
972 name = mkName uniq src_span
973 inst = EqInst {tci_left = ty1, tci_right = ty2, tci_co = co, tci_loc = loc, tci_name = name}
976 where mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span
977 mkEqInst pred _ = pprPanic "mkEqInst" (ppr pred)
979 mkWantedEqInst :: PredType -> TcM Inst
980 mkWantedEqInst pred@(EqPred ty1 ty2)
981 = do { cotv <- newMetaCoVar ty1 ty2
982 ; mkEqInst pred (Left cotv)
984 mkWantedEqInst pred = pprPanic "mkWantedEqInst" (ppr pred)
987 -- We want to promote the wanted EqInst to a given EqInst
988 -- in the signature context.
989 -- This means we have to give the coercion a name
990 -- and fill it in as its own name.
994 finalizeEqInst wanted@(EqInst {tci_left = ty1, tci_right = ty2, tci_name = name})
995 = do { let var = Var.mkCoVar name (PredTy $ EqPred ty1 ty2)
996 ; writeWantedCoercion wanted (TyVarTy var)
997 ; let given = wanted { tci_co = mkGivenCo $ TyVarTy var }
1000 finalizeEqInst i = pprPanic "finalizeEqInst" (ppr i)
1003 :: Inst -- wanted EqInst
1004 -> Coercion -- coercion to fill the hole with
1006 writeWantedCoercion wanted co
1007 = do { let cotv = fromWantedCo "writeWantedCoercion" $ tci_co wanted
1008 ; writeMetaTyVar cotv co
1011 eqInstType :: Inst -> TcType
1012 eqInstType inst = eitherEqInst inst mkTyVarTy id
1014 eqInstCoercion :: Inst -> Either TcTyVar Coercion
1015 eqInstCoercion = tci_co
1017 eqInstTys :: Inst -> (TcType, TcType)
1018 eqInstTys inst = (tci_left inst, tci_right inst)
1020 updateEqInstCoercion :: (Either TcTyVar Coercion -> Either TcTyVar Coercion) -> Inst -> Inst
1021 updateEqInstCoercion f inst = inst {tci_co = f $ tci_co inst}