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 Coercion ( isEqPred )
75 import HscTypes ( ExternalPackageState(..), HscEnv(..) )
76 import CoreFVs ( idFreeTyVars )
77 import DataCon ( DataCon, dataConStupidTheta, dataConName,
78 dataConWrapId, dataConUnivTyVars )
79 import Id ( Id, idName, idType, mkUserLocal, mkLocalId )
80 import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
81 isInternalName, setNameUnique )
82 import NameSet ( addOneToNameSet )
83 import Literal ( inIntRange )
84 import Var ( Var, TyVar, tyVarKind, setIdType, mkTyVar )
85 import VarEnv ( TidyEnv, emptyTidyEnv )
86 import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
87 import TysWiredIn ( floatDataCon, doubleDataCon )
88 import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
89 import BasicTypes( IPName(..), mapIPName, ipNameName )
90 import UniqSupply( uniqsFromSupply )
91 import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) )
92 import DynFlags ( DynFlag(..), DynFlags(..), dopt )
93 import Maybes ( isJust )
101 mkInstCoFn :: [TcType] -> [Inst] -> ExprCoFn
102 mkInstCoFn tys dicts = CoApps (map instToId dicts) <.> CoTyApps tys
104 instName :: Inst -> Name
105 instName inst = idName (instToId inst)
107 instToId :: Inst -> TcId
108 instToId inst = ASSERT2( isId id, ppr inst ) id
112 instToVar :: Inst -> Var
113 instToVar (LitInst nm _ ty _) = mkLocalId nm ty
114 instToVar (Method id _ _ _ _) = id
115 instToVar (Dict nm pred _)
116 | isEqPred pred = mkTyVar nm (mkPredTy pred)
117 | otherwise = mkLocalId nm (mkPredTy pred)
119 instLoc (Dict _ _ loc) = loc
120 instLoc (Method _ _ _ _ loc) = loc
121 instLoc (LitInst _ _ _ loc) = loc
123 dictPred (Dict _ pred _ ) = pred
124 dictPred inst = pprPanic "dictPred" (ppr inst)
126 getDictClassTys (Dict _ pred _) = getClassPredTys pred
128 -- fdPredsOfInst is used to get predicates that contain functional
129 -- dependencies *or* might do so. The "might do" part is because
130 -- a constraint (C a b) might have a superclass with FDs
131 -- Leaving these in is really important for the call to fdPredsOfInsts
132 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
133 -- which is supposed to be conservative
134 fdPredsOfInst (Dict _ pred _) = [pred]
135 fdPredsOfInst (Method _ _ _ theta _) = theta
136 fdPredsOfInst other = [] -- LitInsts etc
138 fdPredsOfInsts :: [Inst] -> [PredType]
139 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
141 isInheritableInst (Dict _ pred _) = isInheritablePred pred
142 isInheritableInst (Method _ _ _ theta _) = all isInheritablePred theta
143 isInheritableInst other = True
146 ipNamesOfInsts :: [Inst] -> [Name]
147 ipNamesOfInst :: Inst -> [Name]
148 -- Get the implicit parameters mentioned by these Insts
149 -- NB: ?x and %x get different Names
150 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
152 ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
153 ipNamesOfInst (Method _ _ _ theta _) = [ipNameName n | IParam n _ <- theta]
154 ipNamesOfInst other = []
156 tyVarsOfInst :: Inst -> TcTyVarSet
157 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
158 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
159 tyVarsOfInst (Method _ id tys _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
160 -- The id might have free type variables; in the case of
161 -- locally-overloaded class methods, for example
164 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
165 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
171 isDict :: Inst -> Bool
172 isDict (Dict _ _ _) = True
175 isClassDict :: Inst -> Bool
176 isClassDict (Dict _ pred _) = isClassPred pred
177 isClassDict other = False
179 isTyVarDict :: Inst -> Bool
180 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
181 isTyVarDict other = False
183 isIPDict :: Inst -> Bool
184 isIPDict (Dict _ pred _) = isIPPred pred
185 isIPDict other = False
187 isMethod :: Inst -> Bool
188 isMethod (Method {}) = True
189 isMethod other = False
191 isMethodFor :: TcIdSet -> Inst -> Bool
192 isMethodFor ids (Method uniq id tys _ loc) = id `elemVarSet` ids
193 isMethodFor ids inst = False
195 isLinearInst :: Inst -> Bool
196 isLinearInst (Dict _ pred _) = isLinearPred pred
197 isLinearInst other = False
198 -- We never build Method Insts that have
199 -- linear implicit paramters in them.
200 -- Hence no need to look for Methods
203 linearInstType :: Inst -> TcType -- %x::t --> t
204 linearInstType (Dict _ (IParam _ ty) _) = ty
209 %************************************************************************
211 \subsection{Building dictionaries}
213 %************************************************************************
216 newDicts :: InstOrigin
220 = getInstLoc orig `thenM` \ loc ->
221 newDictsAtLoc loc theta
223 cloneDict :: Inst -> TcM Inst -- Only used for linear implicit params
224 cloneDict (Dict nm ty loc) = newUnique `thenM` \ uniq ->
225 returnM (Dict (setNameUnique nm uniq) ty loc)
227 newDictsAtLoc :: InstLoc -> TcThetaType -> TcM [Inst]
228 newDictsAtLoc inst_loc theta = mapM (newDictAtLoc inst_loc) theta
231 newDictOcc :: InstLoc -> TcPredType -> TcM Inst
232 newDictOcc inst_loc (EqPred ty1 ty2)
233 = do { unifyType ty1 ty2 -- We insist that they unify right away
234 ; return ty1 } -- And return the relexive coercion
236 newDictAtLoc inst_loc pred
237 = do { uniq <- newUnique
238 ; let name = mkPredName uniq (instLocSrcLoc inst_loc) pred
239 ; return (Dict name pred inst_loc) }
241 -- For vanilla implicit parameters, there is only one in scope
242 -- at any time, so we used to use the name of the implicit parameter itself
243 -- But with splittable implicit parameters there may be many in
244 -- scope, so we make up a new namea.
245 newIPDict :: InstOrigin -> IPName Name -> Type
246 -> TcM (IPName Id, Inst)
247 newIPDict orig ip_name ty
248 = getInstLoc orig `thenM` \ inst_loc ->
249 newUnique `thenM` \ uniq ->
251 pred = IParam ip_name ty
252 name = mkPredName uniq (instLocSrcLoc inst_loc) pred
253 dict = Dict name pred inst_loc
255 returnM (mapIPName (\n -> instToId dict) ip_name, dict)
260 %************************************************************************
262 \subsection{Building methods (calls of overloaded functions)}
264 %************************************************************************
268 tcInstStupidTheta :: DataCon -> [TcType] -> TcM ()
269 -- Instantiate the "stupid theta" of the data con, and throw
270 -- the constraints into the constraint set
271 tcInstStupidTheta data_con inst_tys
275 = do { stupid_dicts <- newDicts (OccurrenceOf (dataConName data_con))
276 (substTheta tenv stupid_theta)
277 ; extendLIEs stupid_dicts }
279 stupid_theta = dataConStupidTheta data_con
280 tenv = zipTopTvSubst (dataConUnivTyVars data_con) inst_tys
282 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
283 newMethodFromName origin ty name
284 = tcLookupId name `thenM` \ id ->
285 -- Use tcLookupId not tcLookupGlobalId; the method is almost
286 -- always a class op, but with -fno-implicit-prelude GHC is
287 -- meant to find whatever thing is in scope, and that may
288 -- be an ordinary function.
289 getInstLoc origin `thenM` \ loc ->
290 tcInstClassOp loc id [ty] `thenM` \ inst ->
291 extendLIE inst `thenM_`
292 returnM (instToId inst)
294 newMethodWithGivenTy orig id tys
295 = getInstLoc orig `thenM` \ loc ->
296 newMethod loc id tys `thenM` \ inst ->
297 extendLIE inst `thenM_`
298 returnM (instToId inst)
300 --------------------------------------------
301 -- tcInstClassOp, and newMethod do *not* drop the
302 -- Inst into the LIE; they just returns the Inst
303 -- This is important because they are used by TcSimplify
306 -- NB: the kind of the type variable to be instantiated
307 -- might be a sub-kind of the type to which it is applied,
308 -- notably when the latter is a type variable of kind ??
309 -- Hence the call to checkKind
310 -- A worry: is this needed anywhere else?
311 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
312 tcInstClassOp inst_loc sel_id tys
314 (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
316 zipWithM_ checkKind tyvars tys `thenM_`
317 newMethod inst_loc sel_id tys
319 checkKind :: TyVar -> TcType -> TcM ()
320 -- Ensure that the type has a sub-kind of the tyvar
323 -- ty1 <- zonkTcType ty
324 ; if typeKind ty1 `isSubKind` tyVarKind tv
328 pprPanic "checkKind: adding kind constraint"
329 (vcat [ppr tv <+> ppr (tyVarKind tv),
330 ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
332 -- do { tv1 <- tcInstTyVar tv
333 -- ; unifyType ty1 (mkTyVarTy tv1) } }
336 ---------------------------
337 newMethod inst_loc id tys
338 = newUnique `thenM` \ new_uniq ->
340 (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
341 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
342 inst = Method meth_id id tys theta inst_loc
343 loc = instLocSrcLoc inst_loc
349 shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
351 | isIntTy ty && inIntRange i -- Short cut for Int
352 = Just (HsLit (HsInt i))
353 | isIntegerTy ty -- Short cut for Integer
354 = Just (HsLit (HsInteger i ty))
355 | otherwise = Nothing
357 shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
360 = Just (mk_lit floatDataCon (HsFloatPrim f))
362 = Just (mk_lit doubleDataCon (HsDoublePrim f))
363 | otherwise = Nothing
365 mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
367 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
369 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
370 getSrcSpanM `thenM` \ span ->
371 returnM (L span $ HsLit (HsInteger i integer_ty))
373 mkRatLit :: Rational -> TcM (LHsExpr TcId)
375 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
376 getSrcSpanM `thenM` \ span ->
377 returnM (L span $ HsLit (HsRat r rat_ty))
379 isHsVar :: HsExpr Name -> Name -> Bool
380 isHsVar (HsVar f) g = f==g
381 isHsVar other g = False
385 %************************************************************************
389 %************************************************************************
391 Zonking makes sure that the instance types are fully zonked.
394 zonkInst :: Inst -> TcM Inst
395 zonkInst (Dict name pred loc)
396 = zonkTcPredType pred `thenM` \ new_pred ->
397 returnM (Dict name new_pred loc)
399 zonkInst (Method m id tys theta loc)
400 = zonkId id `thenM` \ new_id ->
401 -- Essential to zonk the id in case it's a local variable
402 -- Can't use zonkIdOcc because the id might itself be
403 -- an InstId, in which case it won't be in scope
405 zonkTcTypes tys `thenM` \ new_tys ->
406 zonkTcThetaType theta `thenM` \ new_theta ->
407 returnM (Method m new_id new_tys new_theta loc)
409 zonkInst (LitInst nm lit ty loc)
410 = zonkTcType ty `thenM` \ new_ty ->
411 returnM (LitInst nm lit new_ty loc)
413 zonkInsts insts = mappM zonkInst insts
417 %************************************************************************
419 \subsection{Printing}
421 %************************************************************************
423 ToDo: improve these pretty-printing things. The ``origin'' is really only
424 relevant in error messages.
427 instance Outputable Inst where
428 ppr inst = pprInst inst
430 pprDictsTheta :: [Inst] -> SDoc
431 -- Print in type-like fashion (Eq a, Show b)
432 pprDictsTheta dicts = pprTheta (map dictPred dicts)
434 pprDictsInFull :: [Inst] -> SDoc
435 -- Print in type-like fashion, but with source location
437 = vcat (map go dicts)
439 go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))]
441 pprInsts :: [Inst] -> SDoc
442 -- Debugging: print the evidence :: type
443 pprInsts insts = brackets (interpp'SP insts)
445 pprInst, pprInstInFull :: Inst -> SDoc
446 -- Debugging: print the evidence :: type
447 pprInst (LitInst nm lit ty loc) = ppr nm <+> dcolon <+> ppr ty
448 pprInst (Dict nm pred loc) = ppr nm <+> dcolon <+> pprPred pred
450 pprInst m@(Method inst_id id tys theta loc)
451 = ppr inst_id <+> dcolon <+>
452 braces (sep [ppr id <+> ptext SLIT("at"),
453 brackets (sep (map pprParendType tys))])
456 = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
458 tidyInst :: TidyEnv -> Inst -> Inst
459 tidyInst env (LitInst nm lit ty loc) = LitInst nm lit (tidyType env ty) loc
460 tidyInst env (Dict nm pred loc) = Dict nm (tidyPred env pred) loc
461 tidyInst env (Method u id tys theta loc) = Method u id (tidyTypes env tys) theta loc
463 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
464 -- This function doesn't assume that the tyvars are in scope
465 -- so it works like tidyOpenType, returning a TidyEnv
466 tidyMoreInsts env insts
467 = (env', map (tidyInst env') insts)
469 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
471 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
472 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
474 showLIE :: SDoc -> TcM () -- Debugging
476 = do { lie_var <- getLIEVar ;
477 lie <- readMutVar lie_var ;
478 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
482 %************************************************************************
484 Extending the instance environment
486 %************************************************************************
489 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
490 -- Add new locally-defined instances
491 tcExtendLocalInstEnv dfuns thing_inside
492 = do { traceDFuns dfuns
494 ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
495 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
496 tcg_inst_env = inst_env' }
497 ; setGblEnv env' thing_inside }
499 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
500 -- Check that the proposed new instance is OK,
501 -- and then add it to the home inst env
502 addLocalInst home_ie ispec
503 = do { -- Instantiate the dfun type so that we extend the instance
504 -- envt with completely fresh template variables
505 -- This is important because the template variables must
506 -- not overlap with anything in the things being looked up
507 -- (since we do unification).
508 -- We use tcInstSkolType because we don't want to allocate fresh
509 -- *meta* type variables.
510 let dfun = instanceDFunId ispec
511 ; (tvs', theta', tau') <- tcInstSkolType (InstSkol dfun) (idType dfun)
512 ; let (cls, tys') = tcSplitDFunHead tau'
513 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
514 ispec' = setInstanceDFunId ispec dfun'
516 -- Load imported instances, so that we report
517 -- duplicates correctly
519 ; let inst_envs = (eps_inst_env eps, home_ie)
521 -- Check functional dependencies
522 ; case checkFunDeps inst_envs ispec' of
523 Just specs -> funDepErr ispec' specs
526 -- Check for duplicate instance decls
527 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
528 ; dup_ispecs = [ dup_ispec
529 | (_, dup_ispec) <- matches
530 , let (_,_,_,dup_tys) = instanceHead dup_ispec
531 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
532 -- Find memebers of the match list which ispec itself matches.
533 -- If the match is 2-way, it's a duplicate
535 dup_ispec : _ -> dupInstErr ispec' dup_ispec
538 -- OK, now extend the envt
539 ; return (extendInstEnv home_ie ispec') }
541 getOverlapFlag :: TcM OverlapFlag
543 = do { dflags <- getDOpts
544 ; let overlap_ok = dopt Opt_AllowOverlappingInstances dflags
545 incoherent_ok = dopt Opt_AllowIncoherentInstances dflags
546 overlap_flag | incoherent_ok = Incoherent
547 | overlap_ok = OverlapOk
548 | otherwise = NoOverlap
550 ; return overlap_flag }
553 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
555 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
556 -- Print the dfun name itself too
558 funDepErr ispec ispecs
560 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
561 2 (pprInstances (ispec:ispecs)))
562 dupInstErr ispec dup_ispec
564 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
565 2 (pprInstances [ispec, dup_ispec]))
567 addDictLoc ispec thing_inside
568 = setSrcSpan (mkSrcSpan loc loc) thing_inside
570 loc = getSrcLoc ispec
574 %************************************************************************
576 \subsection{Looking up Insts}
578 %************************************************************************
581 data LookupInstResult
583 | SimpleInst (LHsExpr TcId) -- Just a variable, type application, or literal
584 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
586 lookupInst :: Inst -> TcM LookupInstResult
587 -- It's important that lookupInst does not put any new stuff into
588 -- the LIE. Instead, any Insts needed by the lookup are returned in
589 -- the LookupInstResult, where they can be further processed by tcSimplify
594 lookupInst inst@(Method _ id tys theta loc)
595 = do { dicts <- newDictsAtLoc loc theta
596 ; let co_fn = mkInstCoFn tys dicts
597 ; return (GenInst dicts (L span $ HsCoerce co_fn (HsVar id))) }
599 span = instLocSrcSpan loc
603 -- Look for short cuts first: if the literal is *definitely* a
604 -- int, integer, float or a double, generate the real thing here.
605 -- This is essential (see nofib/spectral/nucleic).
606 -- [Same shortcut as in newOverloadedLit, but we
607 -- may have done some unification by now]
609 lookupInst inst@(LitInst _nm (HsIntegral i from_integer_name) ty loc)
610 | Just expr <- shortCutIntLit i ty
611 = returnM (GenInst [] (noLoc expr)) -- GenInst, not SimpleInst, because
612 -- expr may be a constructor application
614 = ASSERT( from_integer_name `isHsVar` fromIntegerName ) -- A LitInst invariant
615 tcLookupId fromIntegerName `thenM` \ from_integer ->
616 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
617 mkIntegerLit i `thenM` \ integer_lit ->
618 returnM (GenInst [method_inst]
619 (mkHsApp (L (instLocSrcSpan loc)
620 (HsVar (instToId method_inst))) integer_lit))
622 lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc)
623 | Just expr <- shortCutFracLit f ty
624 = returnM (GenInst [] (noLoc expr))
627 = ASSERT( from_rat_name `isHsVar` fromRationalName ) -- A LitInst invariant
628 tcLookupId fromRationalName `thenM` \ from_rational ->
629 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
630 mkRatLit f `thenM` \ rat_lit ->
631 returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc)
632 (HsVar (instToId method_inst))) rat_lit))
635 lookupInst (Dict _ pred loc)
636 = do { mb_result <- lookupPred pred
637 ; case mb_result of {
638 Nothing -> return NoInstance ;
639 Just (tenv, dfun_id) -> do
641 -- tenv is a substitution that instantiates the dfun_id
642 -- to match the requested result type.
644 -- We ASSUME that the dfun is quantified over the very same tyvars
645 -- that are bound by the tenv.
648 -- might have some tyvars that *only* appear in arguments
649 -- dfun :: forall a b. C a b, Ord b => D [a]
650 -- We instantiate b to a flexi type variable -- it'll presumably
651 -- become fixed later via functional dependencies
652 { use_stage <- getStage
653 ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
654 (topIdLvl dfun_id) use_stage
656 -- It's possible that not all the tyvars are in
657 -- the substitution, tenv. For example:
658 -- instance C X a => D X where ...
659 -- (presumably there's a functional dependency in class C)
660 -- Hence the open_tvs to instantiate any un-substituted tyvars.
661 ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
662 open_tvs = filter (`notElemTvSubst` tenv) tyvars
663 ; open_tvs' <- mappM tcInstTyVar open_tvs
665 tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
666 -- Since the open_tvs' are freshly made, they cannot possibly be captured by
667 -- any nested for-alls in rho. So the in-scope set is unchanged
668 dfun_rho = substTy tenv' rho
669 (theta, _) = tcSplitPhiTy dfun_rho
670 src_loc = instLocSrcSpan loc
672 tys = map (substTyVar tenv') tyvars
674 returnM (SimpleInst (L src_loc $ HsCoerce (CoTyApps tys) dfun))
676 { dicts <- newDictsAtLoc loc theta
677 ; let co_fn = mkInstCoFn tys dicts
678 ; returnM (GenInst dicts (L src_loc $ HsCoerce co_fn dfun))
682 lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
683 -- Look up a class constraint in the instance environment
684 lookupPred pred@(ClassP clas tys)
686 ; tcg_env <- getGblEnv
687 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
688 ; case lookupInstEnv inst_envs clas tys of {
689 ([(tenv, ispec)], [])
690 -> do { let dfun_id = is_dfun ispec
691 ; traceTc (text "lookupInst success" <+>
692 vcat [text "dict" <+> ppr pred,
693 text "witness" <+> ppr dfun_id
694 <+> ppr (idType dfun_id) ])
695 -- Record that this dfun is needed
696 ; record_dfun_usage dfun_id
697 ; return (Just (tenv, dfun_id)) } ;
700 -> do { traceTc (text "lookupInst fail" <+>
701 vcat [text "dict" <+> ppr pred,
702 text "matches" <+> ppr matches,
703 text "unifs" <+> ppr unifs])
704 -- In the case of overlap (multiple matches) we report
705 -- NoInstance here. That has the effect of making the
706 -- context-simplifier return the dict as an irreducible one.
707 -- Then it'll be given to addNoInstanceErrs, which will do another
708 -- lookupInstEnv to get the detailed info about what went wrong.
712 lookupPred ip_pred = return Nothing
714 record_dfun_usage dfun_id
715 = do { hsc_env <- getTopEnv
716 ; let dfun_name = idName dfun_id
717 dfun_mod = nameModule dfun_name
718 ; if isInternalName dfun_name || -- Internal name => defined in this module
719 modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
720 then return () -- internal, or in another package
721 else do { tcg_env <- getGblEnv
722 ; updMutVar (tcg_inst_uses tcg_env)
723 (`addOneToNameSet` idName dfun_id) }}
726 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
727 -- Gets both the external-package inst-env
728 -- and the home-pkg inst env (includes module being compiled)
729 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
730 return (eps_inst_env eps, tcg_inst_env env) }
735 %************************************************************************
739 %************************************************************************
741 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
742 a do-expression. We have to find (>>) in the current environment, which is
743 done by the rename. Then we have to check that it has the same type as
744 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
747 (>>) :: HB m n mn => m a -> n b -> mn b
749 So the idea is to generate a local binding for (>>), thus:
751 let then72 :: forall a b. m a -> m b -> m b
752 then72 = ...something involving the user's (>>)...
754 ...the do-expression...
756 Now the do-expression can proceed using then72, which has exactly
759 In fact tcSyntaxName just generates the RHS for then72, because we only
760 want an actual binding in the do-expression case. For literals, we can
761 just use the expression inline.
764 tcSyntaxName :: InstOrigin
765 -> TcType -- Type to instantiate it at
766 -> (Name, HsExpr Name) -- (Standard name, user name)
767 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
768 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
769 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
770 -- So we do not call it from lookupInst, which is called from tcSimplify
772 tcSyntaxName orig ty (std_nm, HsVar user_nm)
774 = newMethodFromName orig ty std_nm `thenM` \ id ->
775 returnM (std_nm, HsVar id)
777 tcSyntaxName orig ty (std_nm, user_nm_expr)
778 = tcLookupId std_nm `thenM` \ std_id ->
780 -- C.f. newMethodAtLoc
781 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
782 sigma1 = substTyWith [tv] [ty] tau
783 -- Actually, the "tau-type" might be a sigma-type in the
784 -- case of locally-polymorphic methods.
786 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $
788 -- Check that the user-supplied thing has the
789 -- same type as the standard one.
790 -- Tiresome jiggling because tcCheckSigma takes a located expression
791 getSrcSpanM `thenM` \ span ->
792 tcPolyExpr (L span user_nm_expr) sigma1 `thenM` \ expr ->
793 returnM (std_nm, unLoc expr)
795 syntaxNameCtxt name orig ty tidy_env
796 = getInstLoc orig `thenM` \ inst_loc ->
798 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
799 ptext SLIT("(needed by a syntactic construct)"),
800 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
801 nest 2 (pprInstLoc inst_loc)]
803 returnM (tidy_env, msg)