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,
47 InstOrigin(..), InstLoc, pprInstLoc,
49 mkWantedCo, mkGivenCo,
50 fromWantedCo, fromGivenCo,
51 eitherEqInst, mkEqInst, mkEqInsts, mkWantedEqInst,
52 finalizeEqInst, writeWantedCoercion,
53 eqInstType, updateEqInstCoercion,
55 eqInstLeftTy, eqInstRightTy
58 #include "HsVersions.h"
60 import {-# SOURCE #-} TcExpr( tcPolyExpr )
61 import {-# SOURCE #-} TcUnify( boxyUnify, unifyType )
63 import FastString(FastString)
85 import Var ( Var, TyVar )
106 instName :: Inst -> Name
107 instName (EqInst {tci_name = name}) = name
108 instName inst = Var.varName (instToVar inst)
110 instToId :: Inst -> TcId
111 instToId inst = WARN( not (isId id), ppr inst )
116 instToVar :: Inst -> Var
117 instToVar (LitInst {tci_name = nm, tci_ty = ty})
119 instToVar (Method {tci_id = id})
121 instToVar (Dict {tci_name = nm, tci_pred = pred})
122 | isEqPred pred = Var.mkCoVar nm (mkPredTy pred)
123 | otherwise = mkLocalId nm (mkPredTy pred)
124 instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens,
125 tci_wanted = wanteds})
126 = mkLocalId nm (mkImplicTy tvs givens wanteds)
127 instToVar i@(EqInst {})
128 = eitherEqInst i id (\(TyVarTy covar) -> covar)
130 instType :: Inst -> Type
131 instType (LitInst {tci_ty = ty}) = ty
132 instType (Method {tci_id = id}) = idType id
133 instType (Dict {tci_pred = pred}) = mkPredTy pred
134 instType imp@(ImplicInst {}) = mkImplicTy (tci_tyvars imp) (tci_given imp)
136 -- instType i@(EqInst {tci_co = co}) = eitherEqInst i TyVarTy id
137 instType (EqInst {tci_left = ty1, tci_right = ty2}) = mkPredTy (EqPred ty1 ty2)
139 mkImplicTy tvs givens wanteds -- The type of an implication constraint
140 = ASSERT( all isDict givens )
141 -- pprTrace "mkImplicTy" (ppr givens) $
142 -- See [Equational Constraints in Implication Constraints]
143 let dict_wanteds = filter (not . isEqInst) wanteds
146 mkPhiTy (map dictPred givens) $
147 if isSingleton dict_wanteds then
148 instType (head dict_wanteds)
150 mkTupleTy Boxed (length dict_wanteds) (map instType dict_wanteds)
152 dictPred (Dict {tci_pred = pred}) = pred
153 dictPred (EqInst {tci_left=ty1,tci_right=ty2}) = EqPred ty1 ty2
154 dictPred inst = pprPanic "dictPred" (ppr inst)
156 getDictClassTys (Dict {tci_pred = pred}) = getClassPredTys pred
157 getDictClassTys inst = pprPanic "getDictClassTys" (ppr inst)
159 -- fdPredsOfInst is used to get predicates that contain functional
160 -- dependencies *or* might do so. The "might do" part is because
161 -- a constraint (C a b) might have a superclass with FDs
162 -- Leaving these in is really important for the call to fdPredsOfInsts
163 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
164 -- which is supposed to be conservative
165 fdPredsOfInst (Dict {tci_pred = pred}) = [pred]
166 fdPredsOfInst (Method {tci_theta = theta}) = theta
167 fdPredsOfInst (ImplicInst {tci_given = gs,
168 tci_wanted = ws}) = fdPredsOfInsts (gs ++ ws)
169 fdPredsOfInst (LitInst {}) = []
170 fdPredsOfInst (EqInst {}) = []
172 fdPredsOfInsts :: [Inst] -> [PredType]
173 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
175 isInheritableInst (Dict {tci_pred = pred}) = isInheritablePred pred
176 isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta
177 isInheritableInst other = True
180 ---------------------------------
181 -- Get the implicit parameters mentioned by these Insts
182 -- NB: the results of these functions are insensitive to zonking
184 ipNamesOfInsts :: [Inst] -> [Name]
185 ipNamesOfInst :: Inst -> [Name]
186 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
188 ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
189 ipNamesOfInst (Method {tci_theta = theta}) = [ipNameName n | IParam n _ <- theta]
190 ipNamesOfInst other = []
192 ---------------------------------
193 tyVarsOfInst :: Inst -> TcTyVarSet
194 tyVarsOfInst (LitInst {tci_ty = ty}) = tyVarsOfType ty
195 tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
196 tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id
197 -- The id might have free type variables; in the case of
198 -- locally-overloaded class methods, for example
199 tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds})
200 = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds)
201 `minusVarSet` mkVarSet tvs
202 `unionVarSet` unionVarSets (map varTypeTyVars tvs)
203 -- Remember the free tyvars of a coercion
204 tyVarsOfInst (EqInst {tci_left = ty1, tci_right = ty2}) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
206 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
207 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
214 isAbstractableInst :: Inst -> Bool
215 isAbstractableInst inst = isDict inst || isEqInst inst
217 isEqInst :: Inst -> Bool
218 isEqInst (EqInst {}) = True
219 isEqInst other = False
221 isDict :: Inst -> Bool
222 isDict (Dict {}) = True
225 isClassDict :: Inst -> Bool
226 isClassDict (Dict {tci_pred = pred}) = isClassPred pred
227 isClassDict other = False
229 isTyVarDict :: Inst -> Bool
230 isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
231 isTyVarDict other = False
233 isIPDict :: Inst -> Bool
234 isIPDict (Dict {tci_pred = pred}) = isIPPred pred
235 isIPDict other = False
237 isImplicInst (ImplicInst {}) = True
238 isImplicInst other = False
240 isMethod :: Inst -> Bool
241 isMethod (Method {}) = True
242 isMethod other = False
244 isMethodFor :: TcIdSet -> Inst -> Bool
245 isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
246 isMethodFor ids inst = False
248 isMethodOrLit :: Inst -> Bool
249 isMethodOrLit (Method {}) = True
250 isMethodOrLit (LitInst {}) = True
251 isMethodOrLit other = False
255 %************************************************************************
257 \subsection{Building dictionaries}
259 %************************************************************************
261 -- newDictBndrs makes a dictionary at a binding site
262 -- instCall makes a dictionary at an occurrence site
263 -- and throws it into the LIE
267 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
268 newDictBndrsO orig theta = do { loc <- getInstLoc orig
269 ; newDictBndrs loc theta }
271 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
272 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
274 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
275 newDictBndr inst_loc pred@(EqPred ty1 ty2)
276 = do { uniq <- newUnique
277 ; let name = mkPredName uniq inst_loc pred
278 ; return (EqInst {tci_name = name,
282 tci_co = mkGivenCo $ TyVarTy (Var.mkCoVar name (PredTy pred))})
284 newDictBndr inst_loc pred
285 = do { uniq <- newUnique
286 ; let name = mkPredName uniq inst_loc pred
287 ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
290 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
291 -- Instantiate the constraints of a call
292 -- (instCall o tys theta)
293 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
294 -- (b) Throws these dictionaries into the LIE
295 -- (c) Returns an HsWrapper ([.] tys dicts)
297 instCall orig tys theta
298 = do { loc <- getInstLoc orig
299 ; dict_app <- instCallDicts loc theta
300 ; return (dict_app <.> mkWpTyApps tys) }
303 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
304 -- Similar to instCall, but only emit the constraints in the LIE
305 -- Used exclusively for the 'stupid theta' of a data constructor
306 instStupidTheta orig theta
307 = do { loc <- getInstLoc orig
308 ; _co <- instCallDicts loc theta -- Discard the coercion
312 instCallDicts :: InstLoc -> TcThetaType -> TcM HsWrapper
313 -- Instantiates the TcTheta, puts all constraints thereby generated
314 -- into the LIE, and returns a HsWrapper to enclose the call site.
315 -- This is the key place where equality predicates
316 -- are unleashed into the world
317 instCallDicts loc [] = return idHsWrapper
319 -- instCallDicts loc (EqPred ty1 ty2 : preds)
320 -- = do { unifyType ty1 ty2 -- For now, we insist that they unify right away
321 -- -- Later on, when we do associated types,
322 -- -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
323 -- ; (dicts, co_fn) <- instCallDicts loc preds
324 -- ; return (dicts, co_fn <.> WpTyApp ty1) }
325 -- -- We use type application to apply the function to the
326 -- -- coercion; here ty1 *is* the appropriate identity coercion
328 instCallDicts loc (EqPred ty1 ty2 : preds)
329 = do { traceTc (text "instCallDicts" <+> ppr (EqPred ty1 ty2))
330 ; coi <- boxyUnify ty1 ty2
331 -- ; coi <- unifyType ty1 ty2
332 ; let co = fromCoI coi ty1
333 ; co_fn <- instCallDicts loc preds
334 ; return (co_fn <.> WpTyApp co) }
336 instCallDicts loc (pred : preds)
337 = do { uniq <- newUnique
338 ; let name = mkPredName uniq loc pred
339 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
341 ; co_fn <- instCallDicts loc preds
342 ; return (co_fn <.> WpApp (instToId dict)) }
345 cloneDict :: Inst -> TcM Inst
346 cloneDict dict@(Dict nm ty loc) = do { uniq <- newUnique
347 ; return (dict {tci_name = setNameUnique nm uniq}) }
348 cloneDict eq@(EqInst {}) = return eq
349 cloneDict other = pprPanic "cloneDict" (ppr other)
351 -- For vanilla implicit parameters, there is only one in scope
352 -- at any time, so we used to use the name of the implicit parameter itself
353 -- But with splittable implicit parameters there may be many in
354 -- scope, so we make up a new namea.
355 newIPDict :: InstOrigin -> IPName Name -> Type
356 -> TcM (IPName Id, Inst)
357 newIPDict orig ip_name ty
358 = getInstLoc orig `thenM` \ inst_loc ->
359 newUnique `thenM` \ uniq ->
361 pred = IParam ip_name ty
362 name = mkPredName uniq inst_loc pred
363 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}
365 returnM (mapIPName (\n -> instToId dict) ip_name, dict)
370 mkPredName :: Unique -> InstLoc -> PredType -> Name
371 mkPredName uniq loc pred_ty
372 = mkInternalName uniq occ (instLocSpan loc)
374 occ = case pred_ty of
375 ClassP cls _ -> mkDictOcc (getOccName cls)
376 IParam ip _ -> getOccName (ipNameName ip)
377 EqPred ty _ -> mkEqPredCoOcc baseOcc
379 -- we use the outermost tycon of the lhs, if there is one, to
380 -- improve readability of Core code
381 baseOcc = case splitTyConApp_maybe ty of
382 Nothing -> mkOccName tcName "$"
383 Just (tc, _) -> getOccName tc
386 %************************************************************************
388 \subsection{Building methods (calls of overloaded functions)}
390 %************************************************************************
394 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
395 newMethodFromName origin ty name
396 = tcLookupId name `thenM` \ id ->
397 -- Use tcLookupId not tcLookupGlobalId; the method is almost
398 -- always a class op, but with -fno-implicit-prelude GHC is
399 -- meant to find whatever thing is in scope, and that may
400 -- be an ordinary function.
401 getInstLoc origin `thenM` \ loc ->
402 tcInstClassOp loc id [ty] `thenM` \ inst ->
403 extendLIE inst `thenM_`
404 returnM (instToId inst)
406 newMethodWithGivenTy orig id tys
407 = getInstLoc orig `thenM` \ loc ->
408 newMethod loc id tys `thenM` \ inst ->
409 extendLIE inst `thenM_`
410 returnM (instToId inst)
412 --------------------------------------------
413 -- tcInstClassOp, and newMethod do *not* drop the
414 -- Inst into the LIE; they just returns the Inst
415 -- This is important because they are used by TcSimplify
418 -- NB: the kind of the type variable to be instantiated
419 -- might be a sub-kind of the type to which it is applied,
420 -- notably when the latter is a type variable of kind ??
421 -- Hence the call to checkKind
422 -- A worry: is this needed anywhere else?
423 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
424 tcInstClassOp inst_loc sel_id tys
426 (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
428 zipWithM_ checkKind tyvars tys `thenM_`
429 newMethod inst_loc sel_id tys
431 checkKind :: TyVar -> TcType -> TcM ()
432 -- Ensure that the type has a sub-kind of the tyvar
435 -- ty1 <- zonkTcType ty
436 ; if typeKind ty1 `isSubKind` Var.tyVarKind tv
440 pprPanic "checkKind: adding kind constraint"
441 (vcat [ppr tv <+> ppr (Var.tyVarKind tv),
442 ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
444 -- do { tv1 <- tcInstTyVar tv
445 -- ; unifyType ty1 (mkTyVarTy tv1) } }
448 ---------------------------
449 newMethod inst_loc id tys
450 = newUnique `thenM` \ new_uniq ->
452 (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
453 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
454 inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
455 tci_theta = theta, tci_loc = inst_loc}
456 loc = instLocSpan inst_loc
462 shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
464 | isIntTy ty && inIntRange i -- Short cut for Int
465 = Just (HsLit (HsInt i))
466 | isIntegerTy ty -- Short cut for Integer
467 = Just (HsLit (HsInteger i ty))
468 | otherwise = Nothing
470 shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
473 = Just (mk_lit floatDataCon (HsFloatPrim f))
475 = Just (mk_lit doubleDataCon (HsDoublePrim f))
476 | otherwise = Nothing
478 mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
480 shortCutStringLit :: FastString -> TcType -> Maybe (HsExpr TcId)
481 shortCutStringLit s ty
482 | isStringTy ty -- Short cut for String
483 = Just (HsLit (HsString s))
484 | otherwise = Nothing
486 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
488 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
489 getSrcSpanM `thenM` \ span ->
490 returnM (L span $ HsLit (HsInteger i integer_ty))
492 mkRatLit :: Rational -> TcM (LHsExpr TcId)
494 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
495 getSrcSpanM `thenM` \ span ->
496 returnM (L span $ HsLit (HsRat r rat_ty))
498 mkStrLit :: FastString -> TcM (LHsExpr TcId)
500 = --tcMetaTy stringTyConName `thenM` \ string_ty ->
501 getSrcSpanM `thenM` \ span ->
502 returnM (L span $ HsLit (HsString s))
504 isHsVar :: HsExpr Name -> Name -> Bool
505 isHsVar (HsVar f) g = f==g
506 isHsVar other g = False
510 %************************************************************************
514 %************************************************************************
516 Zonking makes sure that the instance types are fully zonked.
519 zonkInst :: Inst -> TcM Inst
520 zonkInst dict@(Dict { tci_pred = pred})
521 = zonkTcPredType pred `thenM` \ new_pred ->
522 returnM (dict {tci_pred = new_pred})
524 zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta})
525 = zonkId id `thenM` \ new_id ->
526 -- Essential to zonk the id in case it's a local variable
527 -- Can't use zonkIdOcc because the id might itself be
528 -- an InstId, in which case it won't be in scope
530 zonkTcTypes tys `thenM` \ new_tys ->
531 zonkTcThetaType theta `thenM` \ new_theta ->
532 returnM (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
533 -- No need to zonk the tci_id
535 zonkInst lit@(LitInst {tci_ty = ty})
536 = zonkTcType ty `thenM` \ new_ty ->
537 returnM (lit {tci_ty = new_ty})
539 zonkInst implic@(ImplicInst {})
540 = ASSERT( all isImmutableTyVar (tci_tyvars implic) )
541 do { givens' <- zonkInsts (tci_given implic)
542 ; wanteds' <- zonkInsts (tci_wanted implic)
543 ; return (implic {tci_given = givens',tci_wanted = wanteds'}) }
545 zonkInst eqinst@(EqInst {tci_left = ty1, tci_right = ty2})
546 = do { co' <- eitherEqInst eqinst
547 (\covar -> return (mkWantedCo covar))
548 (\co -> zonkTcType co >>= \coercion -> return (mkGivenCo coercion))
549 ; ty1' <- zonkTcType ty1
550 ; ty2' <- zonkTcType ty2
551 ; return (eqinst {tci_co = co',tci_left=ty1',tci_right=ty2})
554 zonkInsts insts = mappM zonkInst insts
558 %************************************************************************
560 \subsection{Printing}
562 %************************************************************************
564 ToDo: improve these pretty-printing things. The ``origin'' is really only
565 relevant in error messages.
568 instance Outputable Inst where
569 ppr inst = pprInst inst
571 pprDictsTheta :: [Inst] -> SDoc
572 -- Print in type-like fashion (Eq a, Show b)
573 -- The Inst can be an implication constraint, but not a Method or LitInst
574 pprDictsTheta insts = parens (sep (punctuate comma (map (ppr . instType) insts)))
576 pprDictsInFull :: [Inst] -> SDoc
577 -- Print in type-like fashion, but with source location
579 = vcat (map go dicts)
581 go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
583 pprInsts :: [Inst] -> SDoc
584 -- Debugging: print the evidence :: type
585 pprInsts insts = brackets (interpp'SP insts)
587 pprInst, pprInstInFull :: Inst -> SDoc
588 -- Debugging: print the evidence :: type
589 pprInst i@(EqInst {tci_left = ty1, tci_right = ty2, tci_co = co})
591 (\covar -> text "Wanted" <+> ppr (TyVarTy covar) <+> dcolon <+> ppr (EqPred ty1 ty2))
592 (\co -> text "Given" <+> ppr co <+> dcolon <+> ppr (EqPred ty1 ty2))
593 pprInst inst = ppr (instName inst) <+> dcolon
594 <+> (braces (ppr (instType inst)) $$
595 ifPprDebug implic_stuff)
597 implic_stuff | isImplicInst inst = ppr (tci_reft inst)
600 pprInstInFull inst@(EqInst {}) = pprInst inst
601 pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
603 tidyInst :: TidyEnv -> Inst -> Inst
604 tidyInst env eq@(EqInst {tci_left = lty, tci_right = rty, tci_co = co}) =
605 eq { tci_left = tidyType env lty
606 , tci_right = tidyType env rty
607 , tci_co = either Left (Right . tidyType env) co
609 tidyInst env lit@(LitInst {tci_ty = ty}) = lit {tci_ty = tidyType env ty}
610 tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
611 tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
612 tidyInst env implic@(ImplicInst {})
613 = implic { tci_tyvars = tvs'
614 , tci_given = map (tidyInst env') (tci_given implic)
615 , tci_wanted = map (tidyInst env') (tci_wanted implic) }
617 (env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic)
619 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
620 -- This function doesn't assume that the tyvars are in scope
621 -- so it works like tidyOpenType, returning a TidyEnv
622 tidyMoreInsts env insts
623 = (env', map (tidyInst env') insts)
625 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
627 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
628 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
630 showLIE :: SDoc -> TcM () -- Debugging
632 = do { lie_var <- getLIEVar ;
633 lie <- readMutVar lie_var ;
634 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
638 %************************************************************************
640 Extending the instance environment
642 %************************************************************************
645 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
646 -- Add new locally-defined instances
647 tcExtendLocalInstEnv dfuns thing_inside
648 = do { traceDFuns dfuns
650 ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
651 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
652 tcg_inst_env = inst_env' }
653 ; setGblEnv env' thing_inside }
655 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
656 -- Check that the proposed new instance is OK,
657 -- and then add it to the home inst env
658 addLocalInst home_ie ispec
659 = do { -- Instantiate the dfun type so that we extend the instance
660 -- envt with completely fresh template variables
661 -- This is important because the template variables must
662 -- not overlap with anything in the things being looked up
663 -- (since we do unification).
664 -- We use tcInstSkolType because we don't want to allocate fresh
665 -- *meta* type variables.
666 let dfun = instanceDFunId ispec
667 ; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun)
668 ; let (cls, tys') = tcSplitDFunHead tau'
669 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
670 ispec' = setInstanceDFunId ispec dfun'
672 -- Load imported instances, so that we report
673 -- duplicates correctly
675 ; let inst_envs = (eps_inst_env eps, home_ie)
677 -- Check functional dependencies
678 ; case checkFunDeps inst_envs ispec' of
679 Just specs -> funDepErr ispec' specs
682 -- Check for duplicate instance decls
683 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
684 ; dup_ispecs = [ dup_ispec
685 | (dup_ispec, _) <- matches
686 , let (_,_,_,dup_tys) = instanceHead dup_ispec
687 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
688 -- Find memebers of the match list which ispec itself matches.
689 -- If the match is 2-way, it's a duplicate
691 dup_ispec : _ -> dupInstErr ispec' dup_ispec
694 -- OK, now extend the envt
695 ; return (extendInstEnv home_ie ispec') }
697 getOverlapFlag :: TcM OverlapFlag
699 = do { dflags <- getDOpts
700 ; let overlap_ok = dopt Opt_OverlappingInstances dflags
701 incoherent_ok = dopt Opt_IncoherentInstances dflags
702 overlap_flag | incoherent_ok = Incoherent
703 | overlap_ok = OverlapOk
704 | otherwise = NoOverlap
706 ; return overlap_flag }
709 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
711 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
712 -- Print the dfun name itself too
714 funDepErr ispec ispecs
716 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
717 2 (pprInstances (ispec:ispecs)))
718 dupInstErr ispec dup_ispec
720 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
721 2 (pprInstances [ispec, dup_ispec]))
723 addDictLoc ispec thing_inside
724 = setSrcSpan (mkSrcSpan loc loc) thing_inside
726 loc = getSrcLoc ispec
730 %************************************************************************
732 \subsection{Looking up Insts}
734 %************************************************************************
737 data LookupInstResult
739 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
741 lookupSimpleInst :: Inst -> TcM LookupInstResult
742 -- This is "simple" in that it returns NoInstance for implication constraints
744 -- It's important that lookupInst does not put any new stuff into
745 -- the LIE. Instead, any Insts needed by the lookup are returned in
746 -- the LookupInstResult, where they can be further processed by tcSimplify
748 lookupSimpleInst (EqInst {}) = return NoInstance
750 --------------------- Implications ------------------------
751 lookupSimpleInst (ImplicInst {}) = return NoInstance
753 --------------------- Methods ------------------------
754 lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
755 = do { (dict_app, dicts) <- getLIE $ instCallDicts loc theta
756 ; let co_fn = dict_app <.> mkWpTyApps tys
757 ; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
759 span = instLocSpan loc
761 --------------------- Literals ------------------------
762 -- Look for short cuts first: if the literal is *definitely* a
763 -- int, integer, float or a double, generate the real thing here.
764 -- This is essential (see nofib/spectral/nucleic).
765 -- [Same shortcut as in newOverloadedLit, but we
766 -- may have done some unification by now]
768 lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name, tci_ty = ty, tci_loc = loc})
769 | Just expr <- shortCutIntLit i ty
770 = returnM (GenInst [] (noLoc expr))
772 = ASSERT( from_integer_name `isHsVar` fromIntegerName ) -- A LitInst invariant
773 tcLookupId fromIntegerName `thenM` \ from_integer ->
774 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
775 mkIntegerLit i `thenM` \ integer_lit ->
776 returnM (GenInst [method_inst]
777 (mkHsApp (L (instLocSpan loc)
778 (HsVar (instToId method_inst))) integer_lit))
780 lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name, tci_ty = ty, tci_loc = loc})
781 | Just expr <- shortCutFracLit f ty
782 = returnM (GenInst [] (noLoc expr))
785 = ASSERT( from_rat_name `isHsVar` fromRationalName ) -- A LitInst invariant
786 tcLookupId fromRationalName `thenM` \ from_rational ->
787 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
788 mkRatLit f `thenM` \ rat_lit ->
789 returnM (GenInst [method_inst] (mkHsApp (L (instLocSpan loc)
790 (HsVar (instToId method_inst))) rat_lit))
792 lookupSimpleInst (LitInst {tci_lit = HsIsString s from_string_name, tci_ty = ty, tci_loc = loc})
793 | Just expr <- shortCutStringLit s ty
794 = returnM (GenInst [] (noLoc expr))
796 = ASSERT( from_string_name `isHsVar` fromStringName ) -- A LitInst invariant
797 tcLookupId fromStringName `thenM` \ from_string ->
798 tcInstClassOp loc from_string [ty] `thenM` \ method_inst ->
799 mkStrLit s `thenM` \ string_lit ->
800 returnM (GenInst [method_inst]
801 (mkHsApp (L (instLocSpan loc)
802 (HsVar (instToId method_inst))) string_lit))
804 --------------------- Dictionaries ------------------------
805 lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
806 = do { mb_result <- lookupPred pred
807 ; case mb_result of {
808 Nothing -> return NoInstance ;
809 Just (dfun_id, mb_inst_tys) -> do
811 { use_stage <- getStage
812 ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
813 (topIdLvl dfun_id) use_stage
815 -- It's possible that not all the tyvars are in
816 -- the substitution, tenv. For example:
817 -- instance C X a => D X where ...
818 -- (presumably there's a functional dependency in class C)
819 -- Hence mb_inst_tys :: Either TyVar TcType
821 ; let inst_tv (Left tv) = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
822 inst_tv (Right ty) = return ty
823 ; tys <- mappM inst_tv mb_inst_tys
825 (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
826 src_loc = instLocSpan loc
829 returnM (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
831 { (dict_app, dicts) <- getLIE $ instCallDicts loc theta -- !!!
832 ; let co_fn = dict_app <.> mkWpTyApps tys
833 ; returnM (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
837 lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
838 -- Look up a class constraint in the instance environment
839 lookupPred pred@(ClassP clas tys)
841 ; tcg_env <- getGblEnv
842 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
843 ; case lookupInstEnv inst_envs clas tys of {
844 ([(ispec, inst_tys)], [])
845 -> do { let dfun_id = is_dfun ispec
846 ; traceTc (text "lookupInst success" <+>
847 vcat [text "dict" <+> ppr pred,
848 text "witness" <+> ppr dfun_id
849 <+> ppr (idType dfun_id) ])
850 -- Record that this dfun is needed
851 ; record_dfun_usage dfun_id
852 ; return (Just (dfun_id, inst_tys)) } ;
855 -> do { traceTc (text "lookupInst fail" <+>
856 vcat [text "dict" <+> ppr pred,
857 text "matches" <+> ppr matches,
858 text "unifs" <+> ppr unifs])
859 -- In the case of overlap (multiple matches) we report
860 -- NoInstance here. That has the effect of making the
861 -- context-simplifier return the dict as an irreducible one.
862 -- Then it'll be given to addNoInstanceErrs, which will do another
863 -- lookupInstEnv to get the detailed info about what went wrong.
867 lookupPred ip_pred = return Nothing -- Implicit parameters
869 record_dfun_usage dfun_id
870 = do { hsc_env <- getTopEnv
871 ; let dfun_name = idName dfun_id
872 dfun_mod = nameModule dfun_name
873 ; if isInternalName dfun_name || -- Internal name => defined in this module
874 modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
875 then return () -- internal, or in another package
876 else do { tcg_env <- getGblEnv
877 ; updMutVar (tcg_inst_uses tcg_env)
878 (`addOneToNameSet` idName dfun_id) }}
881 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
882 -- Gets both the external-package inst-env
883 -- and the home-pkg inst env (includes module being compiled)
884 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
885 return (eps_inst_env eps, tcg_inst_env env) }
890 %************************************************************************
894 %************************************************************************
896 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
897 a do-expression. We have to find (>>) in the current environment, which is
898 done by the rename. Then we have to check that it has the same type as
899 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
902 (>>) :: HB m n mn => m a -> n b -> mn b
904 So the idea is to generate a local binding for (>>), thus:
906 let then72 :: forall a b. m a -> m b -> m b
907 then72 = ...something involving the user's (>>)...
909 ...the do-expression...
911 Now the do-expression can proceed using then72, which has exactly
914 In fact tcSyntaxName just generates the RHS for then72, because we only
915 want an actual binding in the do-expression case. For literals, we can
916 just use the expression inline.
919 tcSyntaxName :: InstOrigin
920 -> TcType -- Type to instantiate it at
921 -> (Name, HsExpr Name) -- (Standard name, user name)
922 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
923 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
924 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
925 -- So we do not call it from lookupInst, which is called from tcSimplify
927 tcSyntaxName orig ty (std_nm, HsVar user_nm)
929 = newMethodFromName orig ty std_nm `thenM` \ id ->
930 returnM (std_nm, HsVar id)
932 tcSyntaxName orig ty (std_nm, user_nm_expr)
933 = tcLookupId std_nm `thenM` \ std_id ->
935 -- C.f. newMethodAtLoc
936 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
937 sigma1 = substTyWith [tv] [ty] tau
938 -- Actually, the "tau-type" might be a sigma-type in the
939 -- case of locally-polymorphic methods.
941 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $
943 -- Check that the user-supplied thing has the
944 -- same type as the standard one.
945 -- Tiresome jiggling because tcCheckSigma takes a located expression
946 getSrcSpanM `thenM` \ span ->
947 tcPolyExpr (L span user_nm_expr) sigma1 `thenM` \ expr ->
948 returnM (std_nm, unLoc expr)
950 syntaxNameCtxt name orig ty tidy_env
951 = getInstLoc orig `thenM` \ inst_loc ->
953 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
954 ptext SLIT("(needed by a syntactic construct)"),
955 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
956 nest 2 (ptext SLIT("arising from") <+> pprInstLoc inst_loc)]
958 returnM (tidy_env, msg)
961 %************************************************************************
965 %************************************************************************
968 mkGivenCo :: Coercion -> Either TcTyVar Coercion
971 mkWantedCo :: TcTyVar -> Either TcTyVar Coercion
974 fromGivenCo :: Either TcTyVar Coercion -> Coercion
975 fromGivenCo (Right co) = co
976 fromGivenCo _ = panic "fromGivenCo: not a wanted coercion"
978 fromWantedCo :: String -> Either TcTyVar Coercion -> TcTyVar
979 fromWantedCo _ (Left covar) = covar
980 fromWantedCo msg _ = panic ("fromWantedCo: not a wanted coercion: " ++ msg)
982 eitherEqInst :: Inst -- given or wanted EqInst
983 -> (TcTyVar -> a) -- result if wanted
984 -> (Coercion -> a) -- result if given
986 eitherEqInst (EqInst {tci_co = either_co}) withWanted withGiven
988 Left covar -> withWanted covar
989 Right co -> withGiven co
991 mkEqInsts :: [PredType] -> [Either TcTyVar Coercion] -> TcM [Inst]
992 mkEqInsts preds cos = zipWithM mkEqInst preds cos
994 mkEqInst :: PredType -> Either TcTyVar Coercion -> TcM Inst
995 mkEqInst (EqPred ty1 ty2) co
996 = do { uniq <- newUnique
997 ; src_span <- getSrcSpanM
998 ; err_ctxt <- getErrCtxt
999 ; let loc = InstLoc EqOrigin src_span err_ctxt
1000 name = mkName uniq src_span
1001 inst = EqInst {tci_left = ty1, tci_right = ty2, tci_co = co, tci_loc = loc, tci_name = name}
1004 where mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span
1006 mkWantedEqInst :: PredType -> TcM Inst
1007 mkWantedEqInst pred@(EqPred ty1 ty2)
1008 = do { cotv <- newMetaTyVar TauTv (mkCoKind ty1 ty2)
1009 ; mkEqInst pred (Left cotv)
1013 -- We want to promote the wanted EqInst to a given EqInst
1014 -- in the signature context.
1015 -- This means we have to give the coercion a name
1016 -- and fill it in as its own name.
1019 -> TcM Inst -- given
1020 finalizeEqInst wanted@(EqInst {tci_left = ty1, tci_right = ty2, tci_name = name})
1021 = do { let var = Var.mkCoVar name (PredTy $ EqPred ty1 ty2)
1022 ; writeWantedCoercion wanted (TyVarTy var)
1023 ; let given = wanted { tci_co = mkGivenCo $ TyVarTy var }
1028 :: Inst -- wanted EqInst
1029 -> Coercion -- coercion to fill the hole with
1031 writeWantedCoercion wanted co
1032 = do { let cotv = fromWantedCo "writeWantedCoercion" $ tci_co wanted
1033 ; writeMetaTyVar cotv co
1036 eqInstType :: Inst -> TcType
1037 eqInstType inst = eitherEqInst inst mkTyVarTy id
1039 eqInstCoercion :: Inst -> Either TcTyVar Coercion
1040 eqInstCoercion = tci_co
1042 eqInstLeftTy, eqInstRightTy :: Inst -> TcType
1043 eqInstLeftTy = tci_left
1044 eqInstRightTy = tci_right
1046 updateEqInstCoercion :: (Either TcTyVar Coercion -> Either TcTyVar Coercion) -> Inst -> Inst
1047 updateEqInstCoercion f inst = inst {tci_co = f $ tci_co inst}