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 shortCutFracLit, shortCutIntLit, shortCutStringLit, newIPDict,
28 newMethod, newMethodFromName, newMethodWithGivenTy,
30 tcSyntaxName, isHsVar,
32 tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
33 ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
34 getDictClassTys, dictPred,
36 lookupSimpleInst, LookupInstResult(..),
37 tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
39 isAbstractableInst, isEqInst,
40 isDict, isClassDict, isMethod, isImplicInst,
41 isIPDict, isInheritableInst, isMethodOrLit,
42 isTyVarDict, isMethodFor,
45 instToId, instToVar, instType, instName, instToDictBind,
48 InstOrigin(..), InstLoc, pprInstLoc,
50 mkWantedCo, mkGivenCo,
51 fromWantedCo, fromGivenCo,
52 eitherEqInst, mkEqInst, mkEqInsts, mkWantedEqInst,
53 finalizeEqInst, writeWantedCoercion,
54 eqInstType, updateEqInstCoercion,
55 eqInstCoercion, eqInstTys
58 #include "HsVersions.h"
60 import {-# SOURCE #-} TcExpr( tcPolyExpr )
61 import {-# SOURCE #-} TcUnify( boxyUnify, unifyType )
63 import FastString(FastString)
85 import Var ( Var, TyVar )
103 import Control.Monad ( liftM )
110 instName :: Inst -> Name
111 instName (EqInst {tci_name = name}) = name
112 instName inst = Var.varName (instToVar inst)
114 instToId :: Inst -> TcId
115 instToId inst = WARN( not (isId id), ppr inst )
120 instToVar :: Inst -> Var
121 instToVar (LitInst {tci_name = nm, tci_ty = ty})
123 instToVar (Method {tci_id = id})
125 instToVar (Dict {tci_name = nm, tci_pred = pred})
126 | isEqPred pred = Var.mkCoVar nm (mkPredTy pred)
127 | otherwise = mkLocalId nm (mkPredTy pred)
128 instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens,
129 tci_wanted = wanteds})
130 = mkLocalId nm (mkImplicTy tvs givens wanteds)
131 instToVar i@(EqInst {})
132 = eitherEqInst i id (\(TyVarTy covar) -> covar)
134 instType :: Inst -> Type
135 instType (LitInst {tci_ty = ty}) = ty
136 instType (Method {tci_id = id}) = idType id
137 instType (Dict {tci_pred = pred}) = mkPredTy pred
138 instType imp@(ImplicInst {}) = mkImplicTy (tci_tyvars imp) (tci_given imp)
140 -- instType i@(EqInst {tci_co = co}) = eitherEqInst i TyVarTy id
141 instType (EqInst {tci_left = ty1, tci_right = ty2}) = mkPredTy (EqPred ty1 ty2)
143 mkImplicTy tvs givens wanteds -- The type of an implication constraint
144 = ASSERT( all isAbstractableInst givens )
145 -- pprTrace "mkImplicTy" (ppr givens) $
146 -- See [Equational Constraints in Implication Constraints]
147 let dict_wanteds = filter (not . isEqInst) wanteds
150 mkPhiTy (map dictPred givens) $
151 if isSingleton dict_wanteds then
152 instType (head dict_wanteds)
154 mkTupleTy Boxed (length dict_wanteds) (map instType dict_wanteds)
156 dictPred (Dict {tci_pred = pred}) = pred
157 dictPred (EqInst {tci_left=ty1,tci_right=ty2}) = EqPred ty1 ty2
158 dictPred inst = pprPanic "dictPred" (ppr inst)
160 getDictClassTys (Dict {tci_pred = pred}) = getClassPredTys pred
161 getDictClassTys inst = pprPanic "getDictClassTys" (ppr inst)
163 -- fdPredsOfInst is used to get predicates that contain functional
164 -- dependencies *or* might do so. The "might do" part is because
165 -- a constraint (C a b) might have a superclass with FDs
166 -- Leaving these in is really important for the call to fdPredsOfInsts
167 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
168 -- which is supposed to be conservative
169 fdPredsOfInst (Dict {tci_pred = pred}) = [pred]
170 fdPredsOfInst (Method {tci_theta = theta}) = theta
171 fdPredsOfInst (ImplicInst {tci_given = gs,
172 tci_wanted = ws}) = fdPredsOfInsts (gs ++ ws)
173 fdPredsOfInst (LitInst {}) = []
174 fdPredsOfInst (EqInst {}) = []
176 fdPredsOfInsts :: [Inst] -> [PredType]
177 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
179 isInheritableInst (Dict {tci_pred = pred}) = isInheritablePred pred
180 isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta
181 isInheritableInst other = True
184 ---------------------------------
185 -- Get the implicit parameters mentioned by these Insts
186 -- NB: the results of these functions are insensitive to zonking
188 ipNamesOfInsts :: [Inst] -> [Name]
189 ipNamesOfInst :: Inst -> [Name]
190 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
192 ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
193 ipNamesOfInst (Method {tci_theta = theta}) = [ipNameName n | IParam n _ <- theta]
194 ipNamesOfInst other = []
196 ---------------------------------
197 tyVarsOfInst :: Inst -> TcTyVarSet
198 tyVarsOfInst (LitInst {tci_ty = ty}) = tyVarsOfType ty
199 tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
200 tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id
201 -- The id might have free type variables; in the case of
202 -- locally-overloaded class methods, for example
203 tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds})
204 = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds)
205 `minusVarSet` mkVarSet tvs
206 `unionVarSet` unionVarSets (map varTypeTyVars tvs)
207 -- Remember the free tyvars of a coercion
208 tyVarsOfInst (EqInst {tci_left = ty1, tci_right = ty2}) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
210 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
211 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
214 --------------------------
215 instToDictBind :: Inst -> LHsExpr TcId -> TcDictBinds
216 instToDictBind inst rhs
217 = unitBag (L (instSpan inst) (VarBind (instToId inst) rhs))
219 addInstToDictBind :: TcDictBinds -> Inst -> LHsExpr TcId -> TcDictBinds
220 addInstToDictBind binds inst rhs = binds `unionBags` instToDictBind inst rhs
227 isAbstractableInst :: Inst -> Bool
228 isAbstractableInst inst = isDict inst || isEqInst inst
230 isEqInst :: Inst -> Bool
231 isEqInst (EqInst {}) = True
232 isEqInst other = False
234 isDict :: Inst -> Bool
235 isDict (Dict {}) = True
238 isClassDict :: Inst -> Bool
239 isClassDict (Dict {tci_pred = pred}) = isClassPred pred
240 isClassDict other = False
242 isTyVarDict :: Inst -> Bool
243 isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
244 isTyVarDict other = False
246 isIPDict :: Inst -> Bool
247 isIPDict (Dict {tci_pred = pred}) = isIPPred pred
248 isIPDict other = False
250 isImplicInst (ImplicInst {}) = True
251 isImplicInst other = False
253 isMethod :: Inst -> Bool
254 isMethod (Method {}) = True
255 isMethod other = False
257 isMethodFor :: TcIdSet -> Inst -> Bool
258 isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
259 isMethodFor ids inst = False
261 isMethodOrLit :: Inst -> Bool
262 isMethodOrLit (Method {}) = True
263 isMethodOrLit (LitInst {}) = True
264 isMethodOrLit other = False
268 %************************************************************************
270 \subsection{Building dictionaries}
272 %************************************************************************
274 -- newDictBndrs makes a dictionary at a binding site
275 -- instCall makes a dictionary at an occurrence site
276 -- and throws it into the LIE
280 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
281 newDictBndrsO orig theta = do { loc <- getInstLoc orig
282 ; newDictBndrs loc theta }
284 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
285 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
287 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
288 newDictBndr inst_loc pred@(EqPred ty1 ty2)
289 = do { uniq <- newUnique
290 ; let name = mkPredName uniq inst_loc pred
291 ; return (EqInst {tci_name = name,
295 tci_co = mkGivenCo $ TyVarTy (Var.mkCoVar name (PredTy pred))})
297 newDictBndr inst_loc pred
298 = do { uniq <- newUnique
299 ; let name = mkPredName uniq inst_loc pred
300 ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
303 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
304 -- Instantiate the constraints of a call
305 -- (instCall o tys theta)
306 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
307 -- (b) Throws these dictionaries into the LIE
308 -- (c) Returns an HsWrapper ([.] tys dicts)
310 instCall orig tys theta
311 = do { loc <- getInstLoc orig
312 ; dict_app <- instCallDicts loc theta
313 ; return (dict_app <.> mkWpTyApps tys) }
316 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
317 -- Similar to instCall, but only emit the constraints in the LIE
318 -- Used exclusively for the 'stupid theta' of a data constructor
319 instStupidTheta orig theta
320 = do { loc <- getInstLoc orig
321 ; _co <- instCallDicts loc theta -- Discard the coercion
325 instCallDicts :: InstLoc -> TcThetaType -> TcM HsWrapper
326 -- Instantiates the TcTheta, puts all constraints thereby generated
327 -- into the LIE, and returns a HsWrapper to enclose the call site.
328 -- This is the key place where equality predicates
329 -- are unleashed into the world
330 instCallDicts loc [] = return idHsWrapper
332 -- instCallDicts loc (EqPred ty1 ty2 : preds)
333 -- = do { unifyType ty1 ty2 -- For now, we insist that they unify right away
334 -- -- Later on, when we do associated types,
335 -- -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
336 -- ; (dicts, co_fn) <- instCallDicts loc preds
337 -- ; return (dicts, co_fn <.> WpTyApp ty1) }
338 -- -- We use type application to apply the function to the
339 -- -- coercion; here ty1 *is* the appropriate identity coercion
341 instCallDicts loc (EqPred ty1 ty2 : preds)
342 = do { traceTc (text "instCallDicts" <+> ppr (EqPred ty1 ty2))
343 ; coi <- boxyUnify ty1 ty2
344 -- ; coi <- unifyType ty1 ty2
345 ; let co = fromCoI coi ty1
346 ; co_fn <- instCallDicts loc preds
347 ; return (co_fn <.> WpTyApp co) }
349 instCallDicts loc (pred : preds)
350 = do { uniq <- newUnique
351 ; let name = mkPredName uniq loc pred
352 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
354 ; co_fn <- instCallDicts loc preds
355 ; return (co_fn <.> WpApp (instToId dict)) }
358 cloneDict :: Inst -> TcM Inst
359 cloneDict dict@(Dict nm ty loc) = do { uniq <- newUnique
360 ; return (dict {tci_name = setNameUnique nm uniq}) }
361 cloneDict eq@(EqInst {}) = return eq
362 cloneDict other = pprPanic "cloneDict" (ppr other)
364 -- For vanilla implicit parameters, there is only one in scope
365 -- at any time, so we used to use the name of the implicit parameter itself
366 -- But with splittable implicit parameters there may be many in
367 -- scope, so we make up a new namea.
368 newIPDict :: InstOrigin -> IPName Name -> Type
369 -> TcM (IPName Id, Inst)
370 newIPDict orig ip_name ty
371 = getInstLoc orig `thenM` \ inst_loc ->
372 newUnique `thenM` \ uniq ->
374 pred = IParam ip_name ty
375 name = mkPredName uniq inst_loc pred
376 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}
378 returnM (mapIPName (\n -> instToId dict) ip_name, dict)
383 mkPredName :: Unique -> InstLoc -> PredType -> Name
384 mkPredName uniq loc pred_ty
385 = mkInternalName uniq occ (instLocSpan loc)
387 occ = case pred_ty of
388 ClassP cls _ -> mkDictOcc (getOccName cls)
389 IParam ip _ -> getOccName (ipNameName ip)
390 EqPred ty _ -> mkEqPredCoOcc baseOcc
392 -- we use the outermost tycon of the lhs, if there is one, to
393 -- improve readability of Core code
394 baseOcc = case splitTyConApp_maybe ty of
395 Nothing -> mkOccName tcName "$"
396 Just (tc, _) -> getOccName tc
399 %************************************************************************
401 \subsection{Building methods (calls of overloaded functions)}
403 %************************************************************************
407 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
408 newMethodFromName origin ty name
409 = tcLookupId name `thenM` \ id ->
410 -- Use tcLookupId not tcLookupGlobalId; the method is almost
411 -- always a class op, but with -fno-implicit-prelude GHC is
412 -- meant to find whatever thing is in scope, and that may
413 -- be an ordinary function.
414 getInstLoc origin `thenM` \ loc ->
415 tcInstClassOp loc id [ty] `thenM` \ inst ->
416 extendLIE inst `thenM_`
417 returnM (instToId inst)
419 newMethodWithGivenTy orig id tys
420 = getInstLoc orig `thenM` \ loc ->
421 newMethod loc id tys `thenM` \ inst ->
422 extendLIE inst `thenM_`
423 returnM (instToId inst)
425 --------------------------------------------
426 -- tcInstClassOp, and newMethod do *not* drop the
427 -- Inst into the LIE; they just returns the Inst
428 -- This is important because they are used by TcSimplify
431 -- NB: the kind of the type variable to be instantiated
432 -- might be a sub-kind of the type to which it is applied,
433 -- notably when the latter is a type variable of kind ??
434 -- Hence the call to checkKind
435 -- A worry: is this needed anywhere else?
436 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
437 tcInstClassOp inst_loc sel_id tys
439 (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
441 zipWithM_ checkKind tyvars tys `thenM_`
442 newMethod inst_loc sel_id tys
444 checkKind :: TyVar -> TcType -> TcM ()
445 -- Ensure that the type has a sub-kind of the tyvar
448 -- ty1 <- zonkTcType ty
449 ; if typeKind ty1 `isSubKind` Var.tyVarKind tv
453 pprPanic "checkKind: adding kind constraint"
454 (vcat [ppr tv <+> ppr (Var.tyVarKind tv),
455 ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
457 -- do { tv1 <- tcInstTyVar tv
458 -- ; unifyType ty1 (mkTyVarTy tv1) } }
461 ---------------------------
462 newMethod inst_loc id tys
463 = newUnique `thenM` \ new_uniq ->
465 (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
466 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
467 inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
468 tci_theta = theta, tci_loc = inst_loc}
469 loc = instLocSpan inst_loc
475 shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
477 | isIntTy ty && inIntRange i -- Short cut for Int
478 = Just (HsLit (HsInt i))
479 | isIntegerTy ty -- Short cut for Integer
480 = Just (HsLit (HsInteger i ty))
481 | otherwise = Nothing
483 shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
486 = Just (mk_lit floatDataCon (HsFloatPrim f))
488 = Just (mk_lit doubleDataCon (HsDoublePrim f))
489 | otherwise = Nothing
491 mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
493 shortCutStringLit :: FastString -> TcType -> Maybe (HsExpr TcId)
494 shortCutStringLit s ty
495 | isStringTy ty -- Short cut for String
496 = Just (HsLit (HsString s))
497 | otherwise = Nothing
499 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
501 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
502 getSrcSpanM `thenM` \ span ->
503 returnM (L span $ HsLit (HsInteger i integer_ty))
505 mkRatLit :: Rational -> TcM (LHsExpr TcId)
507 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
508 getSrcSpanM `thenM` \ span ->
509 returnM (L span $ HsLit (HsRat r rat_ty))
511 mkStrLit :: FastString -> TcM (LHsExpr TcId)
513 = --tcMetaTy stringTyConName `thenM` \ string_ty ->
514 getSrcSpanM `thenM` \ span ->
515 returnM (L span $ HsLit (HsString s))
517 isHsVar :: HsExpr Name -> Name -> Bool
518 isHsVar (HsVar f) g = f==g
519 isHsVar other g = False
523 %************************************************************************
527 %************************************************************************
529 Zonking makes sure that the instance types are fully zonked.
532 zonkInst :: Inst -> TcM Inst
533 zonkInst dict@(Dict { tci_pred = pred})
534 = zonkTcPredType pred `thenM` \ new_pred ->
535 returnM (dict {tci_pred = new_pred})
537 zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta})
538 = zonkId id `thenM` \ new_id ->
539 -- Essential to zonk the id in case it's a local variable
540 -- Can't use zonkIdOcc because the id might itself be
541 -- an InstId, in which case it won't be in scope
543 zonkTcTypes tys `thenM` \ new_tys ->
544 zonkTcThetaType theta `thenM` \ new_theta ->
545 returnM (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
546 -- No need to zonk the tci_id
548 zonkInst lit@(LitInst {tci_ty = ty})
549 = zonkTcType ty `thenM` \ new_ty ->
550 returnM (lit {tci_ty = new_ty})
552 zonkInst implic@(ImplicInst {})
553 = ASSERT( all isImmutableTyVar (tci_tyvars implic) )
554 do { givens' <- zonkInsts (tci_given implic)
555 ; wanteds' <- zonkInsts (tci_wanted implic)
556 ; return (implic {tci_given = givens',tci_wanted = wanteds'}) }
558 zonkInst eqinst@(EqInst {tci_left = ty1, tci_right = ty2})
559 = do { co' <- eitherEqInst eqinst
560 (\covar -> return (mkWantedCo covar))
561 (\co -> liftM mkGivenCo $ zonkTcType co)
562 ; ty1' <- zonkTcType ty1
563 ; ty2' <- zonkTcType ty2
564 ; return (eqinst {tci_co = co', tci_left= ty1', tci_right = ty2' })
567 zonkInsts insts = mappM zonkInst insts
571 %************************************************************************
573 \subsection{Printing}
575 %************************************************************************
577 ToDo: improve these pretty-printing things. The ``origin'' is really only
578 relevant in error messages.
581 instance Outputable Inst where
582 ppr inst = pprInst inst
584 pprDictsTheta :: [Inst] -> SDoc
585 -- Print in type-like fashion (Eq a, Show b)
586 -- The Inst can be an implication constraint, but not a Method or LitInst
587 pprDictsTheta insts = parens (sep (punctuate comma (map (ppr . instType) insts)))
589 pprDictsInFull :: [Inst] -> SDoc
590 -- Print in type-like fashion, but with source location
592 = vcat (map go dicts)
594 go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
596 pprInsts :: [Inst] -> SDoc
597 -- Debugging: print the evidence :: type
598 pprInsts insts = brackets (interpp'SP insts)
600 pprInst, pprInstInFull :: Inst -> SDoc
601 -- Debugging: print the evidence :: type
602 pprInst i@(EqInst {tci_left = ty1, tci_right = ty2, tci_co = co})
604 (\covar -> text "Wanted" <+> ppr (TyVarTy covar) <+> dcolon <+> ppr (EqPred ty1 ty2))
605 (\co -> text "Given" <+> ppr co <+> dcolon <+> ppr (EqPred ty1 ty2))
606 pprInst inst = ppr name <> braces (pprUnique (getUnique name)) <+> dcolon
607 <+> (braces (ppr (instType inst) <> implicWantedEqs) $$
608 ifPprDebug implic_stuff)
611 (implic_stuff, implicWantedEqs)
612 | isImplicInst inst = (ppr (tci_reft inst),
614 ppr (filter isEqInst (tci_wanted inst)))
615 | otherwise = (empty, empty)
617 pprInstInFull inst@(EqInst {}) = pprInst inst
618 pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
620 tidyInst :: TidyEnv -> Inst -> Inst
621 tidyInst env eq@(EqInst {tci_left = lty, tci_right = rty, tci_co = co}) =
622 eq { tci_left = tidyType env lty
623 , tci_right = tidyType env rty
624 , tci_co = either Left (Right . tidyType env) co
626 tidyInst env lit@(LitInst {tci_ty = ty}) = lit {tci_ty = tidyType env ty}
627 tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
628 tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
629 tidyInst env implic@(ImplicInst {})
630 = implic { tci_tyvars = tvs'
631 , tci_given = map (tidyInst env') (tci_given implic)
632 , tci_wanted = map (tidyInst env') (tci_wanted implic) }
634 (env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic)
636 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
637 -- This function doesn't assume that the tyvars are in scope
638 -- so it works like tidyOpenType, returning a TidyEnv
639 tidyMoreInsts env insts
640 = (env', map (tidyInst env') insts)
642 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
644 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
645 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
647 showLIE :: SDoc -> TcM () -- Debugging
649 = do { lie_var <- getLIEVar ;
650 lie <- readMutVar lie_var ;
651 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
655 %************************************************************************
657 Extending the instance environment
659 %************************************************************************
662 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
663 -- Add new locally-defined instances
664 tcExtendLocalInstEnv dfuns thing_inside
665 = do { traceDFuns dfuns
667 ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
668 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
669 tcg_inst_env = inst_env' }
670 ; setGblEnv env' thing_inside }
672 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
673 -- Check that the proposed new instance is OK,
674 -- and then add it to the home inst env
675 addLocalInst home_ie ispec
676 = do { -- Instantiate the dfun type so that we extend the instance
677 -- envt with completely fresh template variables
678 -- This is important because the template variables must
679 -- not overlap with anything in the things being looked up
680 -- (since we do unification).
681 -- We use tcInstSkolType because we don't want to allocate fresh
682 -- *meta* type variables.
683 let dfun = instanceDFunId ispec
684 ; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun)
685 ; let (cls, tys') = tcSplitDFunHead tau'
686 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
687 ispec' = setInstanceDFunId ispec dfun'
689 -- Load imported instances, so that we report
690 -- duplicates correctly
692 ; let inst_envs = (eps_inst_env eps, home_ie)
694 -- Check functional dependencies
695 ; case checkFunDeps inst_envs ispec' of
696 Just specs -> funDepErr ispec' specs
699 -- Check for duplicate instance decls
700 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
701 ; dup_ispecs = [ dup_ispec
702 | (dup_ispec, _) <- matches
703 , let (_,_,_,dup_tys) = instanceHead dup_ispec
704 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
705 -- Find memebers of the match list which ispec itself matches.
706 -- If the match is 2-way, it's a duplicate
708 dup_ispec : _ -> dupInstErr ispec' dup_ispec
711 -- OK, now extend the envt
712 ; return (extendInstEnv home_ie ispec') }
714 getOverlapFlag :: TcM OverlapFlag
716 = do { dflags <- getDOpts
717 ; let overlap_ok = dopt Opt_OverlappingInstances dflags
718 incoherent_ok = dopt Opt_IncoherentInstances dflags
719 overlap_flag | incoherent_ok = Incoherent
720 | overlap_ok = OverlapOk
721 | otherwise = NoOverlap
723 ; return overlap_flag }
726 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
728 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
729 -- Print the dfun name itself too
731 funDepErr ispec ispecs
733 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
734 2 (pprInstances (ispec:ispecs)))
735 dupInstErr ispec dup_ispec
737 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
738 2 (pprInstances [ispec, dup_ispec]))
740 addDictLoc ispec thing_inside
741 = setSrcSpan (mkSrcSpan loc loc) thing_inside
743 loc = getSrcLoc ispec
747 %************************************************************************
749 \subsection{Looking up Insts}
751 %************************************************************************
754 data LookupInstResult
756 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
758 lookupSimpleInst :: Inst -> TcM LookupInstResult
759 -- This is "simple" in that it returns NoInstance for implication constraints
761 -- It's important that lookupInst does not put any new stuff into
762 -- the LIE. Instead, any Insts needed by the lookup are returned in
763 -- the LookupInstResult, where they can be further processed by tcSimplify
765 lookupSimpleInst (EqInst {}) = return NoInstance
767 --------------------- Implications ------------------------
768 lookupSimpleInst (ImplicInst {}) = return NoInstance
770 --------------------- Methods ------------------------
771 lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
772 = do { (dict_app, dicts) <- getLIE $ instCallDicts loc theta
773 ; let co_fn = dict_app <.> mkWpTyApps tys
774 ; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
776 span = instLocSpan loc
778 --------------------- Literals ------------------------
779 -- Look for short cuts first: if the literal is *definitely* a
780 -- int, integer, float or a double, generate the real thing here.
781 -- This is essential (see nofib/spectral/nucleic).
782 -- [Same shortcut as in newOverloadedLit, but we
783 -- may have done some unification by now]
785 lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name _, tci_ty = ty, tci_loc = loc})
786 | Just expr <- shortCutIntLit i ty
787 = returnM (GenInst [] (noLoc expr))
789 = ASSERT( from_integer_name `isHsVar` fromIntegerName ) -- A LitInst invariant
790 tcLookupId fromIntegerName `thenM` \ from_integer ->
791 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
792 mkIntegerLit i `thenM` \ integer_lit ->
793 returnM (GenInst [method_inst]
794 (mkHsApp (L (instLocSpan loc)
795 (HsVar (instToId method_inst))) integer_lit))
797 lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name _, tci_ty = ty, tci_loc = loc})
798 | Just expr <- shortCutFracLit f ty
799 = returnM (GenInst [] (noLoc expr))
802 = ASSERT( from_rat_name `isHsVar` fromRationalName ) -- A LitInst invariant
803 tcLookupId fromRationalName `thenM` \ from_rational ->
804 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
805 mkRatLit f `thenM` \ rat_lit ->
806 returnM (GenInst [method_inst] (mkHsApp (L (instLocSpan loc)
807 (HsVar (instToId method_inst))) rat_lit))
809 lookupSimpleInst (LitInst {tci_lit = HsIsString s from_string_name _, tci_ty = ty, tci_loc = loc})
810 | Just expr <- shortCutStringLit s ty
811 = returnM (GenInst [] (noLoc expr))
813 = ASSERT( from_string_name `isHsVar` fromStringName ) -- A LitInst invariant
814 tcLookupId fromStringName `thenM` \ from_string ->
815 tcInstClassOp loc from_string [ty] `thenM` \ method_inst ->
816 mkStrLit s `thenM` \ string_lit ->
817 returnM (GenInst [method_inst]
818 (mkHsApp (L (instLocSpan loc)
819 (HsVar (instToId method_inst))) string_lit))
821 --------------------- Dictionaries ------------------------
822 lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
823 = do { mb_result <- lookupPred pred
824 ; case mb_result of {
825 Nothing -> return NoInstance ;
826 Just (dfun_id, mb_inst_tys) -> do
828 { use_stage <- getStage
829 ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
830 (topIdLvl dfun_id) use_stage
832 -- It's possible that not all the tyvars are in
833 -- the substitution, tenv. For example:
834 -- instance C X a => D X where ...
835 -- (presumably there's a functional dependency in class C)
836 -- Hence mb_inst_tys :: Either TyVar TcType
838 ; let inst_tv (Left tv) = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
839 inst_tv (Right ty) = return ty
840 ; tys <- mappM inst_tv mb_inst_tys
842 (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
843 src_loc = instLocSpan loc
846 returnM (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
848 { (dict_app, dicts) <- getLIE $ instCallDicts loc theta -- !!!
849 ; let co_fn = dict_app <.> mkWpTyApps tys
850 ; returnM (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
854 lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
855 -- Look up a class constraint in the instance environment
856 lookupPred pred@(ClassP clas tys)
858 ; tcg_env <- getGblEnv
859 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
860 ; case lookupInstEnv inst_envs clas tys of {
861 ([(ispec, inst_tys)], [])
862 -> do { let dfun_id = is_dfun ispec
863 ; traceTc (text "lookupInst success" <+>
864 vcat [text "dict" <+> ppr pred,
865 text "witness" <+> ppr dfun_id
866 <+> ppr (idType dfun_id) ])
867 -- Record that this dfun is needed
868 ; record_dfun_usage dfun_id
869 ; return (Just (dfun_id, inst_tys)) } ;
872 -> do { traceTc (text "lookupInst fail" <+>
873 vcat [text "dict" <+> ppr pred,
874 text "matches" <+> ppr matches,
875 text "unifs" <+> ppr unifs])
876 -- In the case of overlap (multiple matches) we report
877 -- NoInstance here. That has the effect of making the
878 -- context-simplifier return the dict as an irreducible one.
879 -- Then it'll be given to addNoInstanceErrs, which will do another
880 -- lookupInstEnv to get the detailed info about what went wrong.
884 lookupPred ip_pred = return Nothing -- Implicit parameters
886 record_dfun_usage dfun_id
887 = do { hsc_env <- getTopEnv
888 ; let dfun_name = idName dfun_id
889 dfun_mod = nameModule dfun_name
890 ; if isInternalName dfun_name || -- Internal name => defined in this module
891 modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
892 then return () -- internal, or in another package
893 else do { tcg_env <- getGblEnv
894 ; updMutVar (tcg_inst_uses tcg_env)
895 (`addOneToNameSet` idName dfun_id) }}
898 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
899 -- Gets both the external-package inst-env
900 -- and the home-pkg inst env (includes module being compiled)
901 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
902 return (eps_inst_env eps, tcg_inst_env env) }
907 %************************************************************************
911 %************************************************************************
913 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
914 a do-expression. We have to find (>>) in the current environment, which is
915 done by the rename. Then we have to check that it has the same type as
916 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
919 (>>) :: HB m n mn => m a -> n b -> mn b
921 So the idea is to generate a local binding for (>>), thus:
923 let then72 :: forall a b. m a -> m b -> m b
924 then72 = ...something involving the user's (>>)...
926 ...the do-expression...
928 Now the do-expression can proceed using then72, which has exactly
931 In fact tcSyntaxName just generates the RHS for then72, because we only
932 want an actual binding in the do-expression case. For literals, we can
933 just use the expression inline.
936 tcSyntaxName :: InstOrigin
937 -> TcType -- Type to instantiate it at
938 -> (Name, HsExpr Name) -- (Standard name, user name)
939 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
940 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
941 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
942 -- So we do not call it from lookupInst, which is called from tcSimplify
944 tcSyntaxName orig ty (std_nm, HsVar user_nm)
946 = newMethodFromName orig ty std_nm `thenM` \ id ->
947 returnM (std_nm, HsVar id)
949 tcSyntaxName orig ty (std_nm, user_nm_expr)
950 = tcLookupId std_nm `thenM` \ std_id ->
952 -- C.f. newMethodAtLoc
953 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
954 sigma1 = substTyWith [tv] [ty] tau
955 -- Actually, the "tau-type" might be a sigma-type in the
956 -- case of locally-polymorphic methods.
958 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $
960 -- Check that the user-supplied thing has the
961 -- same type as the standard one.
962 -- Tiresome jiggling because tcCheckSigma takes a located expression
963 getSrcSpanM `thenM` \ span ->
964 tcPolyExpr (L span user_nm_expr) sigma1 `thenM` \ expr ->
965 returnM (std_nm, unLoc expr)
967 syntaxNameCtxt name orig ty tidy_env
968 = getInstLoc orig `thenM` \ inst_loc ->
970 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
971 ptext SLIT("(needed by a syntactic construct)"),
972 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
973 nest 2 (ptext SLIT("arising from") <+> pprInstLoc inst_loc)]
975 returnM (tidy_env, msg)
978 %************************************************************************
982 %************************************************************************
985 mkGivenCo :: Coercion -> Either TcTyVar Coercion
988 mkWantedCo :: TcTyVar -> Either TcTyVar Coercion
991 fromGivenCo :: Either TcTyVar Coercion -> Coercion
992 fromGivenCo (Right co) = co
993 fromGivenCo _ = panic "fromGivenCo: not a wanted coercion"
995 fromWantedCo :: String -> Either TcTyVar Coercion -> TcTyVar
996 fromWantedCo _ (Left covar) = covar
997 fromWantedCo msg _ = panic ("fromWantedCo: not a wanted coercion: " ++ msg)
999 eitherEqInst :: Inst -- given or wanted EqInst
1000 -> (TcTyVar -> a) -- result if wanted
1001 -> (Coercion -> a) -- result if given
1003 eitherEqInst (EqInst {tci_co = either_co}) withWanted withGiven
1005 Left covar -> withWanted covar
1006 Right co -> withGiven co
1008 mkEqInsts :: [PredType] -> [Either TcTyVar Coercion] -> TcM [Inst]
1009 mkEqInsts preds cos = zipWithM mkEqInst preds cos
1011 mkEqInst :: PredType -> Either TcTyVar Coercion -> TcM Inst
1012 mkEqInst (EqPred ty1 ty2) co
1013 = do { uniq <- newUnique
1014 ; src_span <- getSrcSpanM
1015 ; err_ctxt <- getErrCtxt
1016 ; let loc = InstLoc EqOrigin src_span err_ctxt
1017 name = mkName uniq src_span
1018 inst = EqInst {tci_left = ty1, tci_right = ty2, tci_co = co, tci_loc = loc, tci_name = name}
1021 where mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span
1023 mkWantedEqInst :: PredType -> TcM Inst
1024 mkWantedEqInst pred@(EqPred ty1 ty2)
1025 = do { cotv <- newMetaCoVar ty1 ty2
1026 ; mkEqInst pred (Left cotv)
1030 -- We want to promote the wanted EqInst to a given EqInst
1031 -- in the signature context.
1032 -- This means we have to give the coercion a name
1033 -- and fill it in as its own name.
1036 -> TcM Inst -- given
1037 finalizeEqInst wanted@(EqInst {tci_left = ty1, tci_right = ty2, tci_name = name})
1038 = do { let var = Var.mkCoVar name (PredTy $ EqPred ty1 ty2)
1039 ; writeWantedCoercion wanted (TyVarTy var)
1040 ; let given = wanted { tci_co = mkGivenCo $ TyVarTy var }
1045 :: Inst -- wanted EqInst
1046 -> Coercion -- coercion to fill the hole with
1048 writeWantedCoercion wanted co
1049 = do { let cotv = fromWantedCo "writeWantedCoercion" $ tci_co wanted
1050 ; writeMetaTyVar cotv co
1053 eqInstType :: Inst -> TcType
1054 eqInstType inst = eitherEqInst inst mkTyVarTy id
1056 eqInstCoercion :: Inst -> Either TcTyVar Coercion
1057 eqInstCoercion = tci_co
1059 eqInstTys :: Inst -> (TcType, TcType)
1060 eqInstTys inst = (tci_left inst, tci_right inst)
1062 updateEqInstCoercion :: (Either TcTyVar Coercion -> Either TcTyVar Coercion) -> Inst -> Inst
1063 updateEqInstCoercion f inst = inst {tci_co = f $ tci_co inst}