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
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
19 pprInstances, pprDictsTheta, pprDictsInFull, -- User error messages
20 showLIE, pprInst, pprInsts, pprInstInFull, -- Debugging messages
22 tidyInsts, tidyMoreInsts,
24 newDictBndr, newDictBndrs, newDictBndrsO,
25 instCall, instStupidTheta,
27 newIPDict, newMethod, newMethodFromName, newMethodWithGivenTy,
29 tcSyntaxName, isHsVar,
31 tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
32 ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
33 getDictClassTys, dictPred,
35 lookupSimpleInst, LookupInstResult(..),
36 tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
38 isAbstractableInst, isEqInst,
39 isDict, isClassDict, isMethod, isImplicInst,
40 isIPDict, isInheritableInst, isMethodOrLit,
41 isTyVarDict, isMethodFor,
44 instToId, instToVar, instType, instName, instToDictBind,
47 InstOrigin(..), InstLoc, pprInstLoc,
49 mkWantedCo, mkGivenCo,
50 fromWantedCo, fromGivenCo,
51 eitherEqInst, mkEqInst, mkEqInsts, mkWantedEqInst,
52 finalizeEqInst, writeWantedCoercion,
53 eqInstType, updateEqInstCoercion,
54 eqInstCoercion, eqInstTys
57 #include "HsVersions.h"
59 import {-# SOURCE #-} TcExpr( tcPolyExpr )
60 import {-# SOURCE #-} TcUnify( boxyUnify, unifyType )
84 import Var ( Var, TyVar )
109 instName :: Inst -> Name
110 instName (EqInst {tci_name = name}) = name
111 instName inst = Var.varName (instToVar inst)
113 instToId :: Inst -> TcId
114 instToId inst = WARN( not (isId id), ppr inst )
119 instToVar :: Inst -> Var
120 instToVar (LitInst {tci_name = nm, tci_ty = ty})
122 instToVar (Method {tci_id = id})
124 instToVar (Dict {tci_name = nm, tci_pred = pred})
125 | isEqPred pred = Var.mkCoVar nm (mkPredTy pred)
126 | otherwise = mkLocalId nm (mkPredTy pred)
127 instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens,
128 tci_wanted = wanteds})
129 = mkLocalId nm (mkImplicTy tvs givens wanteds)
130 instToVar i@(EqInst {})
131 = eitherEqInst i id (\(TyVarTy covar) -> covar)
133 instType :: Inst -> Type
134 instType (LitInst {tci_ty = ty}) = ty
135 instType (Method {tci_id = id}) = idType id
136 instType (Dict {tci_pred = pred}) = mkPredTy pred
137 instType imp@(ImplicInst {}) = mkImplicTy (tci_tyvars imp) (tci_given imp)
139 -- instType i@(EqInst {tci_co = co}) = eitherEqInst i TyVarTy id
140 instType (EqInst {tci_left = ty1, tci_right = ty2}) = mkPredTy (EqPred ty1 ty2)
142 mkImplicTy tvs givens wanteds -- The type of an implication constraint
143 = ASSERT( all isAbstractableInst givens )
144 -- pprTrace "mkImplicTy" (ppr givens) $
145 -- See [Equational Constraints in Implication Constraints]
146 let dict_wanteds = filter (not . isEqInst) wanteds
149 mkPhiTy (map dictPred givens) $
150 if isSingleton dict_wanteds then
151 instType (head dict_wanteds)
153 mkTupleTy Boxed (length dict_wanteds) (map instType dict_wanteds)
155 dictPred (Dict {tci_pred = pred}) = pred
156 dictPred (EqInst {tci_left=ty1,tci_right=ty2}) = EqPred ty1 ty2
157 dictPred inst = pprPanic "dictPred" (ppr inst)
159 getDictClassTys (Dict {tci_pred = pred}) = getClassPredTys pred
160 getDictClassTys inst = pprPanic "getDictClassTys" (ppr inst)
162 -- fdPredsOfInst is used to get predicates that contain functional
163 -- dependencies *or* might do so. The "might do" part is because
164 -- a constraint (C a b) might have a superclass with FDs
165 -- Leaving these in is really important for the call to fdPredsOfInsts
166 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
167 -- which is supposed to be conservative
168 fdPredsOfInst (Dict {tci_pred = pred}) = [pred]
169 fdPredsOfInst (Method {tci_theta = theta}) = theta
170 fdPredsOfInst (ImplicInst {tci_given = gs,
171 tci_wanted = ws}) = fdPredsOfInsts (gs ++ ws)
172 fdPredsOfInst (LitInst {}) = []
173 fdPredsOfInst (EqInst {}) = []
175 fdPredsOfInsts :: [Inst] -> [PredType]
176 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
178 isInheritableInst (Dict {tci_pred = pred}) = isInheritablePred pred
179 isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta
180 isInheritableInst other = True
183 ---------------------------------
184 -- Get the implicit parameters mentioned by these Insts
185 -- NB: the results of these functions are insensitive to zonking
187 ipNamesOfInsts :: [Inst] -> [Name]
188 ipNamesOfInst :: Inst -> [Name]
189 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
191 ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
192 ipNamesOfInst (Method {tci_theta = theta}) = [ipNameName n | IParam n _ <- theta]
193 ipNamesOfInst other = []
195 ---------------------------------
196 tyVarsOfInst :: Inst -> TcTyVarSet
197 tyVarsOfInst (LitInst {tci_ty = ty}) = tyVarsOfType ty
198 tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
199 tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id
200 -- The id might have free type variables; in the case of
201 -- locally-overloaded class methods, for example
202 tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds})
203 = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds)
204 `minusVarSet` mkVarSet tvs
205 `unionVarSet` unionVarSets (map varTypeTyVars tvs)
206 -- Remember the free tyvars of a coercion
207 tyVarsOfInst (EqInst {tci_left = ty1, tci_right = ty2}) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
209 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
210 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
213 --------------------------
214 instToDictBind :: Inst -> LHsExpr TcId -> TcDictBinds
215 instToDictBind inst rhs
216 = unitBag (L (instSpan inst) (VarBind (instToId inst) rhs))
218 addInstToDictBind :: TcDictBinds -> Inst -> LHsExpr TcId -> TcDictBinds
219 addInstToDictBind binds inst rhs = binds `unionBags` instToDictBind inst rhs
226 isAbstractableInst :: Inst -> Bool
227 isAbstractableInst inst = isDict inst || isEqInst inst
229 isEqInst :: Inst -> Bool
230 isEqInst (EqInst {}) = True
231 isEqInst other = False
233 isDict :: Inst -> Bool
234 isDict (Dict {}) = True
237 isClassDict :: Inst -> Bool
238 isClassDict (Dict {tci_pred = pred}) = isClassPred pred
239 isClassDict other = False
241 isTyVarDict :: Inst -> Bool
242 isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
243 isTyVarDict other = False
245 isIPDict :: Inst -> Bool
246 isIPDict (Dict {tci_pred = pred}) = isIPPred pred
247 isIPDict other = False
249 isImplicInst (ImplicInst {}) = True
250 isImplicInst other = False
252 isMethod :: Inst -> Bool
253 isMethod (Method {}) = True
254 isMethod other = False
256 isMethodFor :: TcIdSet -> Inst -> Bool
257 isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
258 isMethodFor ids inst = False
260 isMethodOrLit :: Inst -> Bool
261 isMethodOrLit (Method {}) = True
262 isMethodOrLit (LitInst {}) = True
263 isMethodOrLit other = False
267 %************************************************************************
269 \subsection{Building dictionaries}
271 %************************************************************************
273 -- newDictBndrs makes a dictionary at a binding site
274 -- instCall makes a dictionary at an occurrence site
275 -- and throws it into the LIE
279 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
280 newDictBndrsO orig theta = do { loc <- getInstLoc orig
281 ; newDictBndrs loc theta }
283 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
284 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
286 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
287 newDictBndr inst_loc pred@(EqPred ty1 ty2)
288 = do { uniq <- newUnique
289 ; let name = mkPredName uniq inst_loc pred
290 ; return (EqInst {tci_name = name,
294 tci_co = mkGivenCo $ TyVarTy (Var.mkCoVar name (PredTy pred))})
296 newDictBndr inst_loc pred
297 = do { uniq <- newUnique
298 ; let name = mkPredName uniq inst_loc pred
299 ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
302 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
303 -- Instantiate the constraints of a call
304 -- (instCall o tys theta)
305 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
306 -- (b) Throws these dictionaries into the LIE
307 -- (c) Returns an HsWrapper ([.] tys dicts)
309 instCall orig tys theta
310 = do { loc <- getInstLoc orig
311 ; dict_app <- instCallDicts loc theta
312 ; return (dict_app <.> mkWpTyApps tys) }
315 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
316 -- Similar to instCall, but only emit the constraints in the LIE
317 -- Used exclusively for the 'stupid theta' of a data constructor
318 instStupidTheta orig theta
319 = do { loc <- getInstLoc orig
320 ; _co <- instCallDicts loc theta -- Discard the coercion
324 instCallDicts :: InstLoc -> TcThetaType -> TcM HsWrapper
325 -- Instantiates the TcTheta, puts all constraints thereby generated
326 -- into the LIE, and returns a HsWrapper to enclose the call site.
327 -- This is the key place where equality predicates
328 -- are unleashed into the world
329 instCallDicts loc [] = return idHsWrapper
331 -- instCallDicts loc (EqPred ty1 ty2 : preds)
332 -- = do { unifyType ty1 ty2 -- For now, we insist that they unify right away
333 -- -- Later on, when we do associated types,
334 -- -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
335 -- ; (dicts, co_fn) <- instCallDicts loc preds
336 -- ; return (dicts, co_fn <.> WpTyApp ty1) }
337 -- -- We use type application to apply the function to the
338 -- -- coercion; here ty1 *is* the appropriate identity coercion
340 instCallDicts loc (EqPred ty1 ty2 : preds)
341 = do { traceTc (text "instCallDicts" <+> ppr (EqPred ty1 ty2))
342 ; coi <- boxyUnify ty1 ty2
343 -- ; coi <- unifyType ty1 ty2
344 ; let co = fromCoI coi ty1
345 ; co_fn <- instCallDicts loc preds
346 ; return (co_fn <.> WpTyApp co) }
348 instCallDicts loc (pred : preds)
349 = do { uniq <- newUnique
350 ; let name = mkPredName uniq loc pred
351 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
353 ; co_fn <- instCallDicts loc preds
354 ; return (co_fn <.> WpApp (instToId dict)) }
357 cloneDict :: Inst -> TcM Inst
358 cloneDict dict@(Dict nm ty loc) = do { uniq <- newUnique
359 ; return (dict {tci_name = setNameUnique nm uniq}) }
360 cloneDict eq@(EqInst {}) = return eq
361 cloneDict other = pprPanic "cloneDict" (ppr other)
363 -- For vanilla implicit parameters, there is only one in scope
364 -- at any time, so we used to use the name of the implicit parameter itself
365 -- But with splittable implicit parameters there may be many in
366 -- scope, so we make up a new namea.
367 newIPDict :: InstOrigin -> IPName Name -> Type
368 -> TcM (IPName Id, Inst)
369 newIPDict orig ip_name ty = do
370 inst_loc <- getInstLoc orig
373 pred = IParam ip_name ty
374 name = mkPredName uniq inst_loc pred
375 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}
377 return (mapIPName (\n -> instToId dict) ip_name, dict)
382 mkPredName :: Unique -> InstLoc -> PredType -> Name
383 mkPredName uniq loc pred_ty
384 = mkInternalName uniq occ (instLocSpan loc)
386 occ = case pred_ty of
387 ClassP cls _ -> mkDictOcc (getOccName cls)
388 IParam ip _ -> getOccName (ipNameName ip)
389 EqPred ty _ -> mkEqPredCoOcc baseOcc
391 -- we use the outermost tycon of the lhs, if there is one, to
392 -- improve readability of Core code
393 baseOcc = case splitTyConApp_maybe ty of
394 Nothing -> mkOccName tcName "$"
395 Just (tc, _) -> getOccName tc
398 %************************************************************************
400 \subsection{Building methods (calls of overloaded functions)}
402 %************************************************************************
406 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
407 newMethodFromName origin ty name = do
408 id <- tcLookupId name
409 -- Use tcLookupId not tcLookupGlobalId; the method is almost
410 -- always a class op, but with -fno-implicit-prelude GHC is
411 -- meant to find whatever thing is in scope, and that may
412 -- be an ordinary function.
413 loc <- getInstLoc origin
414 inst <- tcInstClassOp loc id [ty]
416 return (instToId inst)
418 newMethodWithGivenTy orig id tys = do
419 loc <- getInstLoc orig
420 inst <- newMethod loc id tys
422 return (instToId inst)
424 --------------------------------------------
425 -- tcInstClassOp, and newMethod do *not* drop the
426 -- Inst into the LIE; they just returns the Inst
427 -- This is important because they are used by TcSimplify
430 -- NB: the kind of the type variable to be instantiated
431 -- might be a sub-kind of the type to which it is applied,
432 -- notably when the latter is a type variable of kind ??
433 -- Hence the call to checkKind
434 -- A worry: is this needed anywhere else?
435 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
436 tcInstClassOp inst_loc sel_id tys = do
438 (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
439 zipWithM_ checkKind tyvars tys
440 newMethod inst_loc sel_id tys
442 checkKind :: TyVar -> TcType -> TcM ()
443 -- Ensure that the type has a sub-kind of the tyvar
446 -- ty1 <- zonkTcType ty
447 ; if typeKind ty1 `isSubKind` Var.tyVarKind tv
451 pprPanic "checkKind: adding kind constraint"
452 (vcat [ppr tv <+> ppr (Var.tyVarKind tv),
453 ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
455 -- do { tv1 <- tcInstTyVar tv
456 -- ; unifyType ty1 (mkTyVarTy tv1) } }
459 ---------------------------
460 newMethod inst_loc id tys = do
461 new_uniq <- newUnique
463 (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
464 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
465 inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
466 tci_theta = theta, tci_loc = inst_loc}
467 loc = instLocSpan inst_loc
473 mkOverLit :: OverLitVal -> TcM HsLit
474 mkOverLit (HsIntegral i)
475 = do { integer_ty <- tcMetaTy integerTyConName
476 ; return (HsInteger i integer_ty) }
478 mkOverLit (HsFractional r)
479 = do { rat_ty <- tcMetaTy rationalTyConName
480 ; return (HsRat r rat_ty) }
482 mkOverLit (HsIsString s) = return (HsString s)
484 isHsVar :: HsExpr Name -> Name -> Bool
485 isHsVar (HsVar f) g = f==g
486 isHsVar other g = False
490 %************************************************************************
494 %************************************************************************
496 Zonking makes sure that the instance types are fully zonked.
499 zonkInst :: Inst -> TcM Inst
500 zonkInst dict@(Dict { tci_pred = pred}) = do
501 new_pred <- zonkTcPredType pred
502 return (dict {tci_pred = new_pred})
504 zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta}) = do
506 -- Essential to zonk the id in case it's a local variable
507 -- Can't use zonkIdOcc because the id might itself be
508 -- an InstId, in which case it won't be in scope
510 new_tys <- zonkTcTypes tys
511 new_theta <- zonkTcThetaType theta
512 return (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
513 -- No need to zonk the tci_id
515 zonkInst lit@(LitInst {tci_ty = ty}) = do
516 new_ty <- zonkTcType ty
517 return (lit {tci_ty = new_ty})
519 zonkInst implic@(ImplicInst {})
520 = ASSERT( all isImmutableTyVar (tci_tyvars implic) )
521 do { givens' <- zonkInsts (tci_given implic)
522 ; wanteds' <- zonkInsts (tci_wanted implic)
523 ; return (implic {tci_given = givens',tci_wanted = wanteds'}) }
525 zonkInst eqinst@(EqInst {tci_left = ty1, tci_right = ty2})
526 = do { co' <- eitherEqInst eqinst
527 (\covar -> return (mkWantedCo covar))
528 (\co -> liftM mkGivenCo $ zonkTcType co)
529 ; ty1' <- zonkTcType ty1
530 ; ty2' <- zonkTcType ty2
531 ; return (eqinst {tci_co = co', tci_left= ty1', tci_right = ty2' })
534 zonkInsts insts = mapM zonkInst insts
538 %************************************************************************
540 \subsection{Printing}
542 %************************************************************************
544 ToDo: improve these pretty-printing things. The ``origin'' is really only
545 relevant in error messages.
548 instance Outputable Inst where
549 ppr inst = pprInst inst
551 pprDictsTheta :: [Inst] -> SDoc
552 -- Print in type-like fashion (Eq a, Show b)
553 -- The Inst can be an implication constraint, but not a Method or LitInst
554 pprDictsTheta insts = parens (sep (punctuate comma (map (ppr . instType) insts)))
556 pprDictsInFull :: [Inst] -> SDoc
557 -- Print in type-like fashion, but with source location
559 = vcat (map go dicts)
561 go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
563 pprInsts :: [Inst] -> SDoc
564 -- Debugging: print the evidence :: type
565 pprInsts insts = brackets (interpp'SP insts)
567 pprInst, pprInstInFull :: Inst -> SDoc
568 -- Debugging: print the evidence :: type
569 pprInst i@(EqInst {tci_left = ty1, tci_right = ty2, tci_co = co})
571 (\covar -> text "Wanted" <+> ppr (TyVarTy covar) <+> dcolon <+> ppr (EqPred ty1 ty2))
572 (\co -> text "Given" <+> ppr co <+> dcolon <+> ppr (EqPred ty1 ty2))
573 pprInst inst = ppr name <> braces (pprUnique (getUnique name)) <+> dcolon
574 <+> braces (ppr (instType inst) <> implicWantedEqs)
578 | isImplicInst inst = text " &" <+>
579 ppr (filter isEqInst (tci_wanted inst))
582 pprInstInFull inst@(EqInst {}) = pprInst inst
583 pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
585 tidyInst :: TidyEnv -> Inst -> Inst
586 tidyInst env eq@(EqInst {tci_left = lty, tci_right = rty, tci_co = co}) =
587 eq { tci_left = tidyType env lty
588 , tci_right = tidyType env rty
589 , tci_co = either Left (Right . tidyType env) co
591 tidyInst env lit@(LitInst {tci_ty = ty}) = lit {tci_ty = tidyType env ty}
592 tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
593 tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
594 tidyInst env implic@(ImplicInst {})
595 = implic { tci_tyvars = tvs'
596 , tci_given = map (tidyInst env') (tci_given implic)
597 , tci_wanted = map (tidyInst env') (tci_wanted implic) }
599 (env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic)
601 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
602 -- This function doesn't assume that the tyvars are in scope
603 -- so it works like tidyOpenType, returning a TidyEnv
604 tidyMoreInsts env insts
605 = (env', map (tidyInst env') insts)
607 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
609 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
610 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
612 showLIE :: SDoc -> TcM () -- Debugging
614 = do { lie_var <- getLIEVar ;
615 lie <- readMutVar lie_var ;
616 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
620 %************************************************************************
622 Extending the instance environment
624 %************************************************************************
627 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
628 -- Add new locally-defined instances
629 tcExtendLocalInstEnv dfuns thing_inside
630 = do { traceDFuns dfuns
632 ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
633 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
634 tcg_inst_env = inst_env' }
635 ; setGblEnv env' thing_inside }
637 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
638 -- Check that the proposed new instance is OK,
639 -- and then add it to the home inst env
640 addLocalInst home_ie ispec
641 = do { -- Instantiate the dfun type so that we extend the instance
642 -- envt with completely fresh template variables
643 -- This is important because the template variables must
644 -- not overlap with anything in the things being looked up
645 -- (since we do unification).
646 -- We use tcInstSkolType because we don't want to allocate fresh
647 -- *meta* type variables.
648 let dfun = instanceDFunId ispec
649 ; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun)
650 ; let (cls, tys') = tcSplitDFunHead tau'
651 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
652 ispec' = setInstanceDFunId ispec dfun'
654 -- Load imported instances, so that we report
655 -- duplicates correctly
657 ; let inst_envs = (eps_inst_env eps, home_ie)
659 -- Check functional dependencies
660 ; case checkFunDeps inst_envs ispec' of
661 Just specs -> funDepErr ispec' specs
664 -- Check for duplicate instance decls
665 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
666 ; dup_ispecs = [ dup_ispec
667 | (dup_ispec, _) <- matches
668 , let (_,_,_,dup_tys) = instanceHead dup_ispec
669 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
670 -- Find memebers of the match list which ispec itself matches.
671 -- If the match is 2-way, it's a duplicate
673 dup_ispec : _ -> dupInstErr ispec' dup_ispec
676 -- OK, now extend the envt
677 ; return (extendInstEnv home_ie ispec') }
679 getOverlapFlag :: TcM OverlapFlag
681 = do { dflags <- getDOpts
682 ; let overlap_ok = dopt Opt_OverlappingInstances dflags
683 incoherent_ok = dopt Opt_IncoherentInstances dflags
684 overlap_flag | incoherent_ok = Incoherent
685 | overlap_ok = OverlapOk
686 | otherwise = NoOverlap
688 ; return overlap_flag }
691 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
693 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
694 -- Print the dfun name itself too
696 funDepErr ispec ispecs
698 addErr (hang (ptext (sLit "Functional dependencies conflict between instance declarations:"))
699 2 (pprInstances (ispec:ispecs)))
700 dupInstErr ispec dup_ispec
702 addErr (hang (ptext (sLit "Duplicate instance declarations:"))
703 2 (pprInstances [ispec, dup_ispec]))
705 addDictLoc ispec thing_inside
706 = setSrcSpan (mkSrcSpan loc loc) thing_inside
708 loc = getSrcLoc ispec
712 %************************************************************************
714 \subsection{Looking up Insts}
716 %************************************************************************
719 data LookupInstResult
721 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
723 lookupSimpleInst :: Inst -> TcM LookupInstResult
724 -- This is "simple" in that it returns NoInstance for implication constraints
726 -- It's important that lookupInst does not put any new stuff into
727 -- the LIE. Instead, any Insts needed by the lookup are returned in
728 -- the LookupInstResult, where they can be further processed by tcSimplify
730 lookupSimpleInst (EqInst {}) = return NoInstance
732 --------------------- Implications ------------------------
733 lookupSimpleInst (ImplicInst {}) = return NoInstance
735 --------------------- Methods ------------------------
736 lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
737 = do { (dict_app, dicts) <- getLIE $ instCallDicts loc theta
738 ; let co_fn = dict_app <.> mkWpTyApps tys
739 ; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
741 span = instLocSpan loc
743 --------------------- Literals ------------------------
744 -- Look for short cuts first: if the literal is *definitely* a
745 -- int, integer, float or a double, generate the real thing here.
746 -- This is essential (see nofib/spectral/nucleic).
747 -- [Same shortcut as in newOverloadedLit, but we
748 -- may have done some unification by now]
750 lookupSimpleInst (LitInst { tci_lit = lit@OverLit { ol_val = lit_val
751 , ol_rebindable = rebindable }
752 , tci_ty = ty, tci_loc = iloc})
754 | rebindable = panic "lookupSimpleInst" -- A LitInst invariant
756 | Just witness <- shortCutLit lit_val ty
757 = do { let lit' = lit { ol_witness = witness, ol_type = ty }
758 ; return (GenInst [] (L loc (HsOverLit lit'))) }
761 = do { hs_lit <- mkOverLit lit_val
762 ; from_thing <- tcLookupId (hsOverLitName lit_val)
763 -- Not rebindable, so hsOverLitName is the right thing
764 ; method_inst <- tcInstClassOp iloc from_thing [ty]
765 ; let witness = HsApp (L loc (HsVar (instToId method_inst)))
766 (L loc (HsLit hs_lit))
767 lit' = lit { ol_witness = witness, ol_type = ty }
768 ; return (GenInst [method_inst] (L loc (HsOverLit lit'))) }
770 loc = instLocSpan iloc
772 --------------------- Dictionaries ------------------------
773 lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
774 = do { mb_result <- lookupPred pred
775 ; case mb_result of {
776 Nothing -> return NoInstance ;
777 Just (dfun_id, mb_inst_tys) -> do
779 { use_stage <- getStage
780 ; checkWellStaged (ptext (sLit "instance for") <+> quotes (ppr pred))
781 (topIdLvl dfun_id) use_stage
783 -- It's possible that not all the tyvars are in
784 -- the substitution, tenv. For example:
785 -- instance C X a => D X where ...
786 -- (presumably there's a functional dependency in class C)
787 -- Hence mb_inst_tys :: Either TyVar TcType
789 ; let inst_tv (Left tv) = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
790 inst_tv (Right ty) = return ty
791 ; tys <- mapM inst_tv mb_inst_tys
793 (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
794 src_loc = instLocSpan loc
797 return (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
799 { (dict_app, dicts) <- getLIE $ instCallDicts loc theta -- !!!
800 ; let co_fn = dict_app <.> mkWpTyApps tys
801 ; return (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
805 lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
806 -- Look up a class constraint in the instance environment
807 lookupPred pred@(ClassP clas tys)
809 ; tcg_env <- getGblEnv
810 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
811 ; case lookupInstEnv inst_envs clas tys of {
812 ([(ispec, inst_tys)], [])
813 -> do { let dfun_id = is_dfun ispec
814 ; traceTc (text "lookupInst success" <+>
815 vcat [text "dict" <+> ppr pred,
816 text "witness" <+> ppr dfun_id
817 <+> ppr (idType dfun_id) ])
818 -- Record that this dfun is needed
819 ; record_dfun_usage dfun_id
820 ; return (Just (dfun_id, inst_tys)) } ;
823 -> do { traceTc (text "lookupInst fail" <+>
824 vcat [text "dict" <+> ppr pred,
825 text "matches" <+> ppr matches,
826 text "unifs" <+> ppr unifs])
827 -- In the case of overlap (multiple matches) we report
828 -- NoInstance here. That has the effect of making the
829 -- context-simplifier return the dict as an irreducible one.
830 -- Then it'll be given to addNoInstanceErrs, which will do another
831 -- lookupInstEnv to get the detailed info about what went wrong.
835 lookupPred ip_pred = return Nothing -- Implicit parameters
837 record_dfun_usage dfun_id
838 = do { hsc_env <- getTopEnv
839 ; let dfun_name = idName dfun_id
840 dfun_mod = nameModule dfun_name
841 ; if isInternalName dfun_name || -- Internal name => defined in this module
842 modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
843 then return () -- internal, or in another package
844 else do { tcg_env <- getGblEnv
845 ; updMutVar (tcg_inst_uses tcg_env)
846 (`addOneToNameSet` idName dfun_id) }}
849 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
850 -- Gets both the external-package inst-env
851 -- and the home-pkg inst env (includes module being compiled)
852 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
853 return (eps_inst_env eps, tcg_inst_env env) }
858 %************************************************************************
862 %************************************************************************
864 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
865 a do-expression. We have to find (>>) in the current environment, which is
866 done by the rename. Then we have to check that it has the same type as
867 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
870 (>>) :: HB m n mn => m a -> n b -> mn b
872 So the idea is to generate a local binding for (>>), thus:
874 let then72 :: forall a b. m a -> m b -> m b
875 then72 = ...something involving the user's (>>)...
877 ...the do-expression...
879 Now the do-expression can proceed using then72, which has exactly
882 In fact tcSyntaxName just generates the RHS for then72, because we only
883 want an actual binding in the do-expression case. For literals, we can
884 just use the expression inline.
887 tcSyntaxName :: InstOrigin
888 -> TcType -- Type to instantiate it at
889 -> (Name, HsExpr Name) -- (Standard name, user name)
890 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
891 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
892 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
893 -- So we do not call it from lookupInst, which is called from tcSimplify
895 tcSyntaxName orig ty (std_nm, HsVar user_nm)
897 = do id <- newMethodFromName orig ty std_nm
898 return (std_nm, HsVar id)
900 tcSyntaxName orig ty (std_nm, user_nm_expr) = do
901 std_id <- tcLookupId std_nm
903 -- C.f. newMethodAtLoc
904 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
905 sigma1 = substTyWith [tv] [ty] tau
906 -- Actually, the "tau-type" might be a sigma-type in the
907 -- case of locally-polymorphic methods.
909 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
911 -- Check that the user-supplied thing has the
912 -- same type as the standard one.
913 -- Tiresome jiggling because tcCheckSigma takes a located expression
915 expr <- tcPolyExpr (L span user_nm_expr) sigma1
916 return (std_nm, unLoc expr)
918 syntaxNameCtxt name orig ty tidy_env = do
919 inst_loc <- getInstLoc orig
921 msg = vcat [ptext (sLit "When checking that") <+> quotes (ppr name) <+>
922 ptext (sLit "(needed by a syntactic construct)"),
923 nest 2 (ptext (sLit "has the required type:") <+> ppr (tidyType tidy_env ty)),
924 nest 2 (ptext (sLit "arising from") <+> pprInstLoc inst_loc)]
926 return (tidy_env, msg)
929 %************************************************************************
933 %************************************************************************
936 mkGivenCo :: Coercion -> Either TcTyVar Coercion
939 mkWantedCo :: TcTyVar -> Either TcTyVar Coercion
942 fromGivenCo :: Either TcTyVar Coercion -> Coercion
943 fromGivenCo (Right co) = co
944 fromGivenCo _ = panic "fromGivenCo: not a wanted coercion"
946 fromWantedCo :: String -> Either TcTyVar Coercion -> TcTyVar
947 fromWantedCo _ (Left covar) = covar
948 fromWantedCo msg _ = panic ("fromWantedCo: not a wanted coercion: " ++ msg)
950 eitherEqInst :: Inst -- given or wanted EqInst
951 -> (TcTyVar -> a) -- result if wanted
952 -> (Coercion -> a) -- result if given
954 eitherEqInst (EqInst {tci_co = either_co}) withWanted withGiven
956 Left covar -> withWanted covar
957 Right co -> withGiven co
959 mkEqInsts :: [PredType] -> [Either TcTyVar Coercion] -> TcM [Inst]
960 mkEqInsts preds cos = zipWithM mkEqInst preds cos
962 mkEqInst :: PredType -> Either TcTyVar Coercion -> TcM Inst
963 mkEqInst (EqPred ty1 ty2) co
964 = do { uniq <- newUnique
965 ; src_span <- getSrcSpanM
966 ; err_ctxt <- getErrCtxt
967 ; let loc = InstLoc EqOrigin src_span err_ctxt
968 name = mkName uniq src_span
969 inst = EqInst {tci_left = ty1, tci_right = ty2, tci_co = co, tci_loc = loc, tci_name = name}
972 where mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span
974 mkWantedEqInst :: PredType -> TcM Inst
975 mkWantedEqInst pred@(EqPred ty1 ty2)
976 = do { cotv <- newMetaCoVar ty1 ty2
977 ; mkEqInst pred (Left cotv)
981 -- We want to promote the wanted EqInst to a given EqInst
982 -- in the signature context.
983 -- This means we have to give the coercion a name
984 -- and fill it in as its own name.
988 finalizeEqInst wanted@(EqInst {tci_left = ty1, tci_right = ty2, tci_name = name})
989 = do { let var = Var.mkCoVar name (PredTy $ EqPred ty1 ty2)
990 ; writeWantedCoercion wanted (TyVarTy var)
991 ; let given = wanted { tci_co = mkGivenCo $ TyVarTy var }
996 :: Inst -- wanted EqInst
997 -> Coercion -- coercion to fill the hole with
999 writeWantedCoercion wanted co
1000 = do { let cotv = fromWantedCo "writeWantedCoercion" $ tci_co wanted
1001 ; writeMetaTyVar cotv co
1004 eqInstType :: Inst -> TcType
1005 eqInstType inst = eitherEqInst inst mkTyVarTy id
1007 eqInstCoercion :: Inst -> Either TcTyVar Coercion
1008 eqInstCoercion = tci_co
1010 eqInstTys :: Inst -> (TcType, TcType)
1011 eqInstTys inst = (tci_left inst, tci_right inst)
1013 updateEqInstCoercion :: (Either TcTyVar Coercion -> Either TcTyVar Coercion) -> Inst -> Inst
1014 updateEqInstCoercion f inst = inst {tci_co = f $ tci_co inst}