2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[Inst]{The @Inst@ type: dictionaries or method instances}
10 pprInstances, pprDictsTheta, pprDictsInFull, -- User error messages
11 showLIE, pprInst, pprInsts, pprInstInFull, -- Debugging messages
13 tidyInsts, tidyMoreInsts,
15 newDicts, newDictsAtLoc, cloneDict,
16 shortCutFracLit, shortCutIntLit, newIPDict,
17 newMethod, newMethodFromName, newMethodWithGivenTy,
18 tcInstClassOp, tcInstStupidTheta,
19 tcSyntaxName, isHsVar,
21 tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
22 ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
23 instLoc, getDictClassTys, dictPred,
26 lookupInst, LookupInstResult(..), lookupPred,
27 tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
29 isDict, isClassDict, isMethod,
30 isLinearInst, linearInstType, isIPDict, isInheritableInst,
31 isTyVarDict, isMethodFor,
34 instToId, instToVar, instName,
36 InstOrigin(..), InstLoc(..), pprInstLoc
39 #include "HsVersions.h"
41 import {-# SOURCE #-} TcExpr( tcPolyExpr )
43 import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp,
44 ExprCoFn(..), (<.>), nlHsLit, nlHsVar )
45 import TcHsSyn ( zonkId )
47 import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
48 import InstEnv ( DFunId, InstEnv, Instance(..), OverlapFlag(..),
49 lookupInstEnv, extendInstEnv, pprInstances,
50 instanceHead, instanceDFunId, setInstanceDFunId )
51 import FunDeps ( checkFunDeps )
52 import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zonkTcThetaType,
53 tcInstTyVar, tcInstSkolType
55 import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcPredType,
57 PredType(..), SkolemInfo(..), typeKind, mkSigmaTy,
58 tcSplitForAllTys, applyTys,
59 tcSplitPhiTy, tcSplitDFunHead,
60 isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
62 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
63 isClassPred, isTyVarClassPred, isLinearPred,
64 getClassPredTys, mkPredName,
65 isInheritablePred, isIPPred,
66 tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy,
67 pprPred, pprParendType, pprTheta
69 import Type ( TvSubst, substTy, substTyVar, substTyWith, substTheta, zipTopTvSubst,
70 notElemTvSubst, extendTvSubstList )
71 import Unify ( tcMatchTys )
72 import Module ( modulePackageId )
73 import {- Kind parts of -} Type ( isSubKind )
74 import HscTypes ( ExternalPackageState(..), HscEnv(..) )
75 import CoreFVs ( idFreeTyVars )
76 import DataCon ( DataCon, dataConStupidTheta, dataConName,
77 dataConWrapId, dataConUnivTyVars )
78 import Id ( Id, idName, idType, mkUserLocal, mkLocalId )
79 import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
80 isInternalName, setNameUnique )
81 import NameSet ( addOneToNameSet )
82 import Literal ( inIntRange )
83 import Var ( TyVar, tyVarKind, setIdType )
84 import VarEnv ( TidyEnv, emptyTidyEnv )
85 import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
86 import TysWiredIn ( floatDataCon, doubleDataCon )
87 import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
88 import BasicTypes( IPName(..), mapIPName, ipNameName )
89 import UniqSupply( uniqsFromSupply )
90 import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) )
91 import DynFlags ( DynFlag(..), DynFlags(..), dopt )
92 import Maybes ( isJust )
100 mkInstCoFn :: [TcType] -> [Inst] -> ExprCoFn
101 mkInstCoFn tys dicts = CoApps (map instToId dicts) <.> CoTyApps tys
103 instName :: Inst -> Name
104 instName inst = idName (instToId inst)
106 instToId :: Inst -> TcId
107 instToId inst = ASSERT2( isId id, ppr inst ) id
111 instToVar :: Inst -> Var
112 instToVar (LitInst nm _ ty _) = mkLocalId nm ty
113 instToVar (Method id _ _ _ _) = id
114 instToVar (Dict nm pred _)
115 | isEqPred pred = mkTyVar nm (mkPredTy pred)
116 | otherwise = mkLocalId nm (mkPredTy pred)
118 instLoc (Dict _ _ loc) = loc
119 instLoc (Method _ _ _ _ loc) = loc
120 instLoc (LitInst _ _ _ loc) = loc
122 dictPred (Dict _ pred _ ) = pred
123 dictPred inst = pprPanic "dictPred" (ppr inst)
125 getDictClassTys (Dict _ pred _) = getClassPredTys pred
127 -- fdPredsOfInst is used to get predicates that contain functional
128 -- dependencies *or* might do so. The "might do" part is because
129 -- a constraint (C a b) might have a superclass with FDs
130 -- Leaving these in is really important for the call to fdPredsOfInsts
131 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
132 -- which is supposed to be conservative
133 fdPredsOfInst (Dict _ pred _) = [pred]
134 fdPredsOfInst (Method _ _ _ theta _) = theta
135 fdPredsOfInst other = [] -- LitInsts etc
137 fdPredsOfInsts :: [Inst] -> [PredType]
138 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
140 isInheritableInst (Dict _ pred _) = isInheritablePred pred
141 isInheritableInst (Method _ _ _ theta _) = all isInheritablePred theta
142 isInheritableInst other = True
145 ipNamesOfInsts :: [Inst] -> [Name]
146 ipNamesOfInst :: Inst -> [Name]
147 -- Get the implicit parameters mentioned by these Insts
148 -- NB: ?x and %x get different Names
149 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
151 ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
152 ipNamesOfInst (Method _ _ _ theta _) = [ipNameName n | IParam n _ <- theta]
153 ipNamesOfInst other = []
155 tyVarsOfInst :: Inst -> TcTyVarSet
156 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
157 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
158 tyVarsOfInst (Method _ id tys _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
159 -- The id might have free type variables; in the case of
160 -- locally-overloaded class methods, for example
163 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
164 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
170 isDict :: Inst -> Bool
171 isDict (Dict _ _ _) = True
174 isClassDict :: Inst -> Bool
175 isClassDict (Dict _ pred _) = isClassPred pred
176 isClassDict other = False
178 isTyVarDict :: Inst -> Bool
179 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
180 isTyVarDict other = False
182 isIPDict :: Inst -> Bool
183 isIPDict (Dict _ pred _) = isIPPred pred
184 isIPDict other = False
186 isMethod :: Inst -> Bool
187 isMethod (Method {}) = True
188 isMethod other = False
190 isMethodFor :: TcIdSet -> Inst -> Bool
191 isMethodFor ids (Method uniq id tys _ loc) = id `elemVarSet` ids
192 isMethodFor ids inst = False
194 isLinearInst :: Inst -> Bool
195 isLinearInst (Dict _ pred _) = isLinearPred pred
196 isLinearInst other = False
197 -- We never build Method Insts that have
198 -- linear implicit paramters in them.
199 -- Hence no need to look for Methods
202 linearInstType :: Inst -> TcType -- %x::t --> t
203 linearInstType (Dict _ (IParam _ ty) _) = ty
208 %************************************************************************
210 \subsection{Building dictionaries}
212 %************************************************************************
215 newDicts :: InstOrigin
219 = getInstLoc orig `thenM` \ loc ->
220 newDictsAtLoc loc theta
222 cloneDict :: Inst -> TcM Inst -- Only used for linear implicit params
223 cloneDict (Dict nm ty loc) = newUnique `thenM` \ uniq ->
224 returnM (Dict (setNameUnique nm uniq) ty loc)
226 newDictsAtLoc :: InstLoc -> TcThetaType -> TcM [Inst]
227 newDictsAtLoc inst_loc theta = mapM (newDictAtLoc inst_loc) theta
230 newDictOcc :: InstLoc -> TcPredType -> TcM Inst
231 newDictOcc inst_loc (EqPred ty1 ty2)
232 = do { unifyType ty1 ty2 -- We insist that they unify right away
233 ; return ty1 } -- And return the relexive coercion
235 newDictAtLoc inst_loc pred
236 = do { uniq <- newUnique
237 ; let name = mkPredName uniq (instLocSrcLoc inst_loc) pred
238 ; return (Dict name pred inst_loc) }
240 -- For vanilla implicit parameters, there is only one in scope
241 -- at any time, so we used to use the name of the implicit parameter itself
242 -- But with splittable implicit parameters there may be many in
243 -- scope, so we make up a new namea.
244 newIPDict :: InstOrigin -> IPName Name -> Type
245 -> TcM (IPName Id, Inst)
246 newIPDict orig ip_name ty
247 = getInstLoc orig `thenM` \ inst_loc ->
248 newUnique `thenM` \ uniq ->
250 pred = IParam ip_name ty
251 name = mkPredName uniq (instLocSrcLoc inst_loc) pred
252 dict = Dict name pred inst_loc
254 returnM (mapIPName (\n -> instToId dict) ip_name, dict)
259 %************************************************************************
261 \subsection{Building methods (calls of overloaded functions)}
263 %************************************************************************
267 tcInstStupidTheta :: DataCon -> [TcType] -> TcM ()
268 -- Instantiate the "stupid theta" of the data con, and throw
269 -- the constraints into the constraint set
270 tcInstStupidTheta data_con inst_tys
274 = do { stupid_dicts <- newDicts (OccurrenceOf (dataConName data_con))
275 (substTheta tenv stupid_theta)
276 ; extendLIEs stupid_dicts }
278 stupid_theta = dataConStupidTheta data_con
279 tenv = zipTopTvSubst (dataConUnivTyVars data_con) inst_tys
281 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
282 newMethodFromName origin ty name
283 = tcLookupId name `thenM` \ id ->
284 -- Use tcLookupId not tcLookupGlobalId; the method is almost
285 -- always a class op, but with -fno-implicit-prelude GHC is
286 -- meant to find whatever thing is in scope, and that may
287 -- be an ordinary function.
288 getInstLoc origin `thenM` \ loc ->
289 tcInstClassOp loc id [ty] `thenM` \ inst ->
290 extendLIE inst `thenM_`
291 returnM (instToId inst)
293 newMethodWithGivenTy orig id tys
294 = getInstLoc orig `thenM` \ loc ->
295 newMethod loc id tys `thenM` \ inst ->
296 extendLIE inst `thenM_`
297 returnM (instToId inst)
299 --------------------------------------------
300 -- tcInstClassOp, and newMethod do *not* drop the
301 -- Inst into the LIE; they just returns the Inst
302 -- This is important because they are used by TcSimplify
305 -- NB: the kind of the type variable to be instantiated
306 -- might be a sub-kind of the type to which it is applied,
307 -- notably when the latter is a type variable of kind ??
308 -- Hence the call to checkKind
309 -- A worry: is this needed anywhere else?
310 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
311 tcInstClassOp inst_loc sel_id tys
313 (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
315 zipWithM_ checkKind tyvars tys `thenM_`
316 newMethod inst_loc sel_id tys
318 checkKind :: TyVar -> TcType -> TcM ()
319 -- Ensure that the type has a sub-kind of the tyvar
322 -- ty1 <- zonkTcType ty
323 ; if typeKind ty1 `isSubKind` tyVarKind tv
327 pprPanic "checkKind: adding kind constraint"
328 (vcat [ppr tv <+> ppr (tyVarKind tv),
329 ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
331 -- do { tv1 <- tcInstTyVar tv
332 -- ; unifyType ty1 (mkTyVarTy tv1) } }
335 ---------------------------
336 newMethod inst_loc id tys
337 = newUnique `thenM` \ new_uniq ->
339 (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
340 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
341 inst = Method meth_id id tys theta inst_loc
342 loc = instLocSrcLoc inst_loc
348 shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
350 | isIntTy ty && inIntRange i -- Short cut for Int
351 = Just (HsLit (HsInt i))
352 | isIntegerTy ty -- Short cut for Integer
353 = Just (HsLit (HsInteger i ty))
354 | otherwise = Nothing
356 shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
359 = Just (mk_lit floatDataCon (HsFloatPrim f))
361 = Just (mk_lit doubleDataCon (HsDoublePrim f))
362 | otherwise = Nothing
364 mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
366 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
368 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
369 getSrcSpanM `thenM` \ span ->
370 returnM (L span $ HsLit (HsInteger i integer_ty))
372 mkRatLit :: Rational -> TcM (LHsExpr TcId)
374 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
375 getSrcSpanM `thenM` \ span ->
376 returnM (L span $ HsLit (HsRat r rat_ty))
378 isHsVar :: HsExpr Name -> Name -> Bool
379 isHsVar (HsVar f) g = f==g
380 isHsVar other g = False
384 %************************************************************************
388 %************************************************************************
390 Zonking makes sure that the instance types are fully zonked.
393 zonkInst :: Inst -> TcM Inst
394 zonkInst (Dict name pred loc)
395 = zonkTcPredType pred `thenM` \ new_pred ->
396 returnM (Dict name new_pred loc)
398 zonkInst (Method m id tys theta loc)
399 = zonkId id `thenM` \ new_id ->
400 -- Essential to zonk the id in case it's a local variable
401 -- Can't use zonkIdOcc because the id might itself be
402 -- an InstId, in which case it won't be in scope
404 zonkTcTypes tys `thenM` \ new_tys ->
405 zonkTcThetaType theta `thenM` \ new_theta ->
406 returnM (Method m new_id new_tys new_theta loc)
408 zonkInst (LitInst nm lit ty loc)
409 = zonkTcType ty `thenM` \ new_ty ->
410 returnM (LitInst nm lit new_ty loc)
412 zonkInsts insts = mappM zonkInst insts
416 %************************************************************************
418 \subsection{Printing}
420 %************************************************************************
422 ToDo: improve these pretty-printing things. The ``origin'' is really only
423 relevant in error messages.
426 instance Outputable Inst where
427 ppr inst = pprInst inst
429 pprDictsTheta :: [Inst] -> SDoc
430 -- Print in type-like fashion (Eq a, Show b)
431 pprDictsTheta dicts = pprTheta (map dictPred dicts)
433 pprDictsInFull :: [Inst] -> SDoc
434 -- Print in type-like fashion, but with source location
436 = vcat (map go dicts)
438 go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))]
440 pprInsts :: [Inst] -> SDoc
441 -- Debugging: print the evidence :: type
442 pprInsts insts = brackets (interpp'SP insts)
444 pprInst, pprInstInFull :: Inst -> SDoc
445 -- Debugging: print the evidence :: type
446 pprInst (LitInst nm lit ty loc) = ppr nm <+> dcolon <+> ppr ty
447 pprInst (Dict nm pred loc) = ppr nm <+> dcolon <+> pprPred pred
449 pprInst m@(Method inst_id id tys theta loc)
450 = ppr inst_id <+> dcolon <+>
451 braces (sep [ppr id <+> ptext SLIT("at"),
452 brackets (sep (map pprParendType tys))])
455 = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
457 tidyInst :: TidyEnv -> Inst -> Inst
458 tidyInst env (LitInst nm lit ty loc) = LitInst nm lit (tidyType env ty) loc
459 tidyInst env (Dict nm pred loc) = Dict nm (tidyPred env pred) loc
460 tidyInst env (Method u id tys theta loc) = Method u id (tidyTypes env tys) theta loc
462 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
463 -- This function doesn't assume that the tyvars are in scope
464 -- so it works like tidyOpenType, returning a TidyEnv
465 tidyMoreInsts env insts
466 = (env', map (tidyInst env') insts)
468 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
470 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
471 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
473 showLIE :: SDoc -> TcM () -- Debugging
475 = do { lie_var <- getLIEVar ;
476 lie <- readMutVar lie_var ;
477 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
481 %************************************************************************
483 Extending the instance environment
485 %************************************************************************
488 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
489 -- Add new locally-defined instances
490 tcExtendLocalInstEnv dfuns thing_inside
491 = do { traceDFuns dfuns
493 ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
494 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
495 tcg_inst_env = inst_env' }
496 ; setGblEnv env' thing_inside }
498 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
499 -- Check that the proposed new instance is OK,
500 -- and then add it to the home inst env
501 addLocalInst home_ie ispec
502 = do { -- Instantiate the dfun type so that we extend the instance
503 -- envt with completely fresh template variables
504 -- This is important because the template variables must
505 -- not overlap with anything in the things being looked up
506 -- (since we do unification).
507 -- We use tcInstSkolType because we don't want to allocate fresh
508 -- *meta* type variables.
509 let dfun = instanceDFunId ispec
510 ; (tvs', theta', tau') <- tcInstSkolType (InstSkol dfun) (idType dfun)
511 ; let (cls, tys') = tcSplitDFunHead tau'
512 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
513 ispec' = setInstanceDFunId ispec dfun'
515 -- Load imported instances, so that we report
516 -- duplicates correctly
518 ; let inst_envs = (eps_inst_env eps, home_ie)
520 -- Check functional dependencies
521 ; case checkFunDeps inst_envs ispec' of
522 Just specs -> funDepErr ispec' specs
525 -- Check for duplicate instance decls
526 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
527 ; dup_ispecs = [ dup_ispec
528 | (_, dup_ispec) <- matches
529 , let (_,_,_,dup_tys) = instanceHead dup_ispec
530 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
531 -- Find memebers of the match list which ispec itself matches.
532 -- If the match is 2-way, it's a duplicate
534 dup_ispec : _ -> dupInstErr ispec' dup_ispec
537 -- OK, now extend the envt
538 ; return (extendInstEnv home_ie ispec') }
540 getOverlapFlag :: TcM OverlapFlag
542 = do { dflags <- getDOpts
543 ; let overlap_ok = dopt Opt_AllowOverlappingInstances dflags
544 incoherent_ok = dopt Opt_AllowIncoherentInstances dflags
545 overlap_flag | incoherent_ok = Incoherent
546 | overlap_ok = OverlapOk
547 | otherwise = NoOverlap
549 ; return overlap_flag }
552 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
554 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
555 -- Print the dfun name itself too
557 funDepErr ispec ispecs
559 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
560 2 (pprInstances (ispec:ispecs)))
561 dupInstErr ispec dup_ispec
563 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
564 2 (pprInstances [ispec, dup_ispec]))
566 addDictLoc ispec thing_inside
567 = setSrcSpan (mkSrcSpan loc loc) thing_inside
569 loc = getSrcLoc ispec
573 %************************************************************************
575 \subsection{Looking up Insts}
577 %************************************************************************
580 data LookupInstResult
582 | SimpleInst (LHsExpr TcId) -- Just a variable, type application, or literal
583 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
585 lookupInst :: Inst -> TcM LookupInstResult
586 -- It's important that lookupInst does not put any new stuff into
587 -- the LIE. Instead, any Insts needed by the lookup are returned in
588 -- the LookupInstResult, where they can be further processed by tcSimplify
593 lookupInst inst@(Method _ id tys theta loc)
594 = do { dicts <- newDictsAtLoc loc theta
595 ; let co_fn = mkInstCoFn tys dicts
596 ; return (GenInst dicts (L span $ HsCoerce co_fn (HsVar id))) }
598 span = instLocSrcSpan loc
602 -- Look for short cuts first: if the literal is *definitely* a
603 -- int, integer, float or a double, generate the real thing here.
604 -- This is essential (see nofib/spectral/nucleic).
605 -- [Same shortcut as in newOverloadedLit, but we
606 -- may have done some unification by now]
608 lookupInst inst@(LitInst _nm (HsIntegral i from_integer_name) ty loc)
609 | Just expr <- shortCutIntLit i ty
610 = returnM (GenInst [] (noLoc expr)) -- GenInst, not SimpleInst, because
611 -- expr may be a constructor application
613 = ASSERT( from_integer_name `isHsVar` fromIntegerName ) -- A LitInst invariant
614 tcLookupId fromIntegerName `thenM` \ from_integer ->
615 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
616 mkIntegerLit i `thenM` \ integer_lit ->
617 returnM (GenInst [method_inst]
618 (mkHsApp (L (instLocSrcSpan loc)
619 (HsVar (instToId method_inst))) integer_lit))
621 lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc)
622 | Just expr <- shortCutFracLit f ty
623 = returnM (GenInst [] (noLoc expr))
626 = ASSERT( from_rat_name `isHsVar` fromRationalName ) -- A LitInst invariant
627 tcLookupId fromRationalName `thenM` \ from_rational ->
628 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
629 mkRatLit f `thenM` \ rat_lit ->
630 returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc)
631 (HsVar (instToId method_inst))) rat_lit))
634 lookupInst (Dict _ pred loc)
635 = do { mb_result <- lookupPred pred
636 ; case mb_result of {
637 Nothing -> return NoInstance ;
638 Just (tenv, dfun_id) -> do
640 -- tenv is a substitution that instantiates the dfun_id
641 -- to match the requested result type.
643 -- We ASSUME that the dfun is quantified over the very same tyvars
644 -- that are bound by the tenv.
647 -- might have some tyvars that *only* appear in arguments
648 -- dfun :: forall a b. C a b, Ord b => D [a]
649 -- We instantiate b to a flexi type variable -- it'll presumably
650 -- become fixed later via functional dependencies
651 { use_stage <- getStage
652 ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
653 (topIdLvl dfun_id) use_stage
655 -- It's possible that not all the tyvars are in
656 -- the substitution, tenv. For example:
657 -- instance C X a => D X where ...
658 -- (presumably there's a functional dependency in class C)
659 -- Hence the open_tvs to instantiate any un-substituted tyvars.
660 ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
661 open_tvs = filter (`notElemTvSubst` tenv) tyvars
662 ; open_tvs' <- mappM tcInstTyVar open_tvs
664 tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
665 -- Since the open_tvs' are freshly made, they cannot possibly be captured by
666 -- any nested for-alls in rho. So the in-scope set is unchanged
667 dfun_rho = substTy tenv' rho
668 (theta, _) = tcSplitPhiTy dfun_rho
669 src_loc = instLocSrcSpan loc
671 tys = map (substTyVar tenv') tyvars
673 returnM (SimpleInst (L src_loc $ HsCoerce (CoTyApps tys) dfun))
675 { dicts <- newDictsAtLoc loc theta
676 ; let co_fn = mkInstCoFn tys dicts
677 ; returnM (GenInst dicts (L src_loc $ HsCoerce co_fn dfun))
681 lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
682 -- Look up a class constraint in the instance environment
683 lookupPred pred@(ClassP clas tys)
685 ; tcg_env <- getGblEnv
686 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
687 ; case lookupInstEnv inst_envs clas tys of {
688 ([(tenv, ispec)], [])
689 -> do { let dfun_id = is_dfun ispec
690 ; traceTc (text "lookupInst success" <+>
691 vcat [text "dict" <+> ppr pred,
692 text "witness" <+> ppr dfun_id
693 <+> ppr (idType dfun_id) ])
694 -- Record that this dfun is needed
695 ; record_dfun_usage dfun_id
696 ; return (Just (tenv, dfun_id)) } ;
699 -> do { traceTc (text "lookupInst fail" <+>
700 vcat [text "dict" <+> ppr pred,
701 text "matches" <+> ppr matches,
702 text "unifs" <+> ppr unifs])
703 -- In the case of overlap (multiple matches) we report
704 -- NoInstance here. That has the effect of making the
705 -- context-simplifier return the dict as an irreducible one.
706 -- Then it'll be given to addNoInstanceErrs, which will do another
707 -- lookupInstEnv to get the detailed info about what went wrong.
711 lookupPred ip_pred = return Nothing
713 record_dfun_usage dfun_id
714 = do { hsc_env <- getTopEnv
715 ; let dfun_name = idName dfun_id
716 dfun_mod = nameModule dfun_name
717 ; if isInternalName dfun_name || -- Internal name => defined in this module
718 modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
719 then return () -- internal, or in another package
720 else do { tcg_env <- getGblEnv
721 ; updMutVar (tcg_inst_uses tcg_env)
722 (`addOneToNameSet` idName dfun_id) }}
725 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
726 -- Gets both the external-package inst-env
727 -- and the home-pkg inst env (includes module being compiled)
728 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
729 return (eps_inst_env eps, tcg_inst_env env) }
734 %************************************************************************
738 %************************************************************************
740 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
741 a do-expression. We have to find (>>) in the current environment, which is
742 done by the rename. Then we have to check that it has the same type as
743 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
746 (>>) :: HB m n mn => m a -> n b -> mn b
748 So the idea is to generate a local binding for (>>), thus:
750 let then72 :: forall a b. m a -> m b -> m b
751 then72 = ...something involving the user's (>>)...
753 ...the do-expression...
755 Now the do-expression can proceed using then72, which has exactly
758 In fact tcSyntaxName just generates the RHS for then72, because we only
759 want an actual binding in the do-expression case. For literals, we can
760 just use the expression inline.
763 tcSyntaxName :: InstOrigin
764 -> TcType -- Type to instantiate it at
765 -> (Name, HsExpr Name) -- (Standard name, user name)
766 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
767 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
768 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
769 -- So we do not call it from lookupInst, which is called from tcSimplify
771 tcSyntaxName orig ty (std_nm, HsVar user_nm)
773 = newMethodFromName orig ty std_nm `thenM` \ id ->
774 returnM (std_nm, HsVar id)
776 tcSyntaxName orig ty (std_nm, user_nm_expr)
777 = tcLookupId std_nm `thenM` \ std_id ->
779 -- C.f. newMethodAtLoc
780 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
781 sigma1 = substTyWith [tv] [ty] tau
782 -- Actually, the "tau-type" might be a sigma-type in the
783 -- case of locally-polymorphic methods.
785 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $
787 -- Check that the user-supplied thing has the
788 -- same type as the standard one.
789 -- Tiresome jiggling because tcCheckSigma takes a located expression
790 getSrcSpanM `thenM` \ span ->
791 tcPolyExpr (L span user_nm_expr) sigma1 `thenM` \ expr ->
792 returnM (std_nm, unLoc expr)
794 syntaxNameCtxt name orig ty tidy_env
795 = getInstLoc orig `thenM` \ inst_loc ->
797 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
798 ptext SLIT("(needed by a syntactic construct)"),
799 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
800 nest 2 (pprInstLoc inst_loc)]
802 returnM (tidy_env, msg)