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, newDictAtLoc, 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,
25 lookupInst, LookupInstResult(..), lookupPred,
26 tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
28 isDict, isClassDict, isMethod,
29 isLinearInst, linearInstType, isIPDict, isInheritableInst,
30 isTyVarDict, isMethodFor,
35 InstOrigin(..), InstLoc(..), pprInstLoc
38 #include "HsVersions.h"
40 import {-# SOURCE #-} TcExpr( tcPolyExpr )
42 import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp,
44 import TcHsSyn ( mkHsTyApp, mkHsDictApp, zonkId )
46 import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
47 import InstEnv ( DFunId, InstEnv, Instance(..), OverlapFlag(..),
48 lookupInstEnv, extendInstEnv, pprInstances,
49 instanceHead, instanceDFunId, setInstanceDFunId )
50 import FunDeps ( checkFunDeps )
51 import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zonkTcThetaType,
52 tcInstTyVar, tcInstSkolType
54 import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcPredType,
56 PredType(..), SkolemInfo(..), typeKind, mkSigmaTy,
57 tcSplitForAllTys, applyTys,
58 tcSplitPhiTy, tcSplitDFunHead,
59 isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
61 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
62 isClassPred, isTyVarClassPred, isLinearPred,
63 getClassPredTys, mkPredName,
64 isInheritablePred, isIPPred,
65 tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy,
66 pprPred, pprParendType, pprTheta
68 import Type ( TvSubst, substTy, substTyVar, substTyWith, substTheta, zipTopTvSubst,
69 notElemTvSubst, extendTvSubstList )
70 import Unify ( tcMatchTys )
71 import Module ( modulePackageId )
72 import Kind ( isSubKind )
73 import HscTypes ( ExternalPackageState(..), HscEnv(..) )
74 import CoreFVs ( idFreeTyVars )
75 import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName, dataConWrapId )
76 import Id ( Id, idName, idType, mkUserLocal, mkLocalId )
77 import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
78 isInternalName, setNameUnique )
79 import NameSet ( addOneToNameSet )
80 import Literal ( inIntRange )
81 import Var ( TyVar, tyVarKind, setIdType )
82 import VarEnv ( TidyEnv, emptyTidyEnv )
83 import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
84 import TysWiredIn ( floatDataCon, doubleDataCon )
85 import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
86 import BasicTypes( IPName(..), mapIPName, ipNameName )
87 import UniqSupply( uniqsFromSupply )
88 import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) )
89 import DynFlags ( DynFlag(..), DynFlags(..), dopt )
90 import Maybes ( isJust )
98 instName :: Inst -> Name
99 instName inst = idName (instToId inst)
101 instToId :: Inst -> TcId
102 instToId (LitInst nm _ ty _) = mkLocalId nm ty
103 instToId (Dict nm pred _) = mkLocalId nm (mkPredTy pred)
104 instToId (Method id _ _ _ _) = id
106 instLoc (Dict _ _ loc) = loc
107 instLoc (Method _ _ _ _ loc) = loc
108 instLoc (LitInst _ _ _ loc) = loc
110 dictPred (Dict _ pred _ ) = pred
111 dictPred inst = pprPanic "dictPred" (ppr inst)
113 getDictClassTys (Dict _ pred _) = getClassPredTys pred
115 -- fdPredsOfInst is used to get predicates that contain functional
116 -- dependencies *or* might do so. The "might do" part is because
117 -- a constraint (C a b) might have a superclass with FDs
118 -- Leaving these in is really important for the call to fdPredsOfInsts
119 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
120 -- which is supposed to be conservative
121 fdPredsOfInst (Dict _ pred _) = [pred]
122 fdPredsOfInst (Method _ _ _ theta _) = theta
123 fdPredsOfInst other = [] -- LitInsts etc
125 fdPredsOfInsts :: [Inst] -> [PredType]
126 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
128 isInheritableInst (Dict _ pred _) = isInheritablePred pred
129 isInheritableInst (Method _ _ _ theta _) = all isInheritablePred theta
130 isInheritableInst other = True
133 ipNamesOfInsts :: [Inst] -> [Name]
134 ipNamesOfInst :: Inst -> [Name]
135 -- Get the implicit parameters mentioned by these Insts
136 -- NB: ?x and %x get different Names
137 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
139 ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
140 ipNamesOfInst (Method _ _ _ theta _) = [ipNameName n | IParam n _ <- theta]
141 ipNamesOfInst other = []
143 tyVarsOfInst :: Inst -> TcTyVarSet
144 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
145 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
146 tyVarsOfInst (Method _ id tys _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
147 -- The id might have free type variables; in the case of
148 -- locally-overloaded class methods, for example
151 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
152 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
158 isDict :: Inst -> Bool
159 isDict (Dict _ _ _) = True
162 isClassDict :: Inst -> Bool
163 isClassDict (Dict _ pred _) = isClassPred pred
164 isClassDict other = False
166 isTyVarDict :: Inst -> Bool
167 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
168 isTyVarDict other = False
170 isIPDict :: Inst -> Bool
171 isIPDict (Dict _ pred _) = isIPPred pred
172 isIPDict other = False
174 isMethod :: Inst -> Bool
175 isMethod (Method {}) = True
176 isMethod other = False
178 isMethodFor :: TcIdSet -> Inst -> Bool
179 isMethodFor ids (Method uniq id tys _ loc) = id `elemVarSet` ids
180 isMethodFor ids inst = False
182 isLinearInst :: Inst -> Bool
183 isLinearInst (Dict _ pred _) = isLinearPred pred
184 isLinearInst other = False
185 -- We never build Method Insts that have
186 -- linear implicit paramters in them.
187 -- Hence no need to look for Methods
190 linearInstType :: Inst -> TcType -- %x::t --> t
191 linearInstType (Dict _ (IParam _ ty) _) = ty
196 %************************************************************************
198 \subsection{Building dictionaries}
200 %************************************************************************
203 newDicts :: InstOrigin
207 = getInstLoc orig `thenM` \ loc ->
208 newDictsAtLoc loc theta
210 cloneDict :: Inst -> TcM Inst
211 cloneDict (Dict nm ty loc) = newUnique `thenM` \ uniq ->
212 returnM (Dict (setNameUnique nm uniq) ty loc)
214 newDictAtLoc :: InstLoc -> TcPredType -> TcM Inst
215 newDictAtLoc inst_loc pred
216 = do { uniq <- newUnique
217 ; return (mkDict inst_loc uniq pred) }
219 newDictsAtLoc :: InstLoc -> TcThetaType -> TcM [Inst]
220 newDictsAtLoc inst_loc theta
221 = newUniqueSupply `thenM` \ us ->
222 returnM (zipWith (mkDict inst_loc) (uniqsFromSupply us) theta)
224 mkDict inst_loc uniq pred
225 = Dict name pred inst_loc
227 name = mkPredName uniq (instLocSrcLoc inst_loc) pred
229 -- For vanilla implicit parameters, there is only one in scope
230 -- at any time, so we used to use the name of the implicit parameter itself
231 -- But with splittable implicit parameters there may be many in
232 -- scope, so we make up a new name.
233 newIPDict :: InstOrigin -> IPName Name -> Type
234 -> TcM (IPName Id, Inst)
235 newIPDict orig ip_name ty
236 = getInstLoc orig `thenM` \ inst_loc ->
237 newUnique `thenM` \ uniq ->
239 pred = IParam ip_name ty
240 name = mkPredName uniq (instLocSrcLoc inst_loc) pred
241 dict = Dict name pred inst_loc
243 returnM (mapIPName (\n -> instToId dict) ip_name, dict)
248 %************************************************************************
250 \subsection{Building methods (calls of overloaded functions)}
252 %************************************************************************
256 tcInstStupidTheta :: DataCon -> [TcType] -> TcM ()
257 -- Instantiate the "stupid theta" of the data con, and throw
258 -- the constraints into the constraint set
259 tcInstStupidTheta data_con inst_tys
263 = do { stupid_dicts <- newDicts (OccurrenceOf (dataConName data_con))
264 (substTheta tenv stupid_theta)
265 ; extendLIEs stupid_dicts }
267 stupid_theta = dataConStupidTheta data_con
268 tenv = zipTopTvSubst (dataConTyVars data_con) inst_tys
270 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
271 newMethodFromName origin ty name
272 = tcLookupId name `thenM` \ id ->
273 -- Use tcLookupId not tcLookupGlobalId; the method is almost
274 -- always a class op, but with -fno-implicit-prelude GHC is
275 -- meant to find whatever thing is in scope, and that may
276 -- be an ordinary function.
277 getInstLoc origin `thenM` \ loc ->
278 tcInstClassOp loc id [ty] `thenM` \ inst ->
279 extendLIE inst `thenM_`
280 returnM (instToId inst)
282 newMethodWithGivenTy orig id tys
283 = getInstLoc orig `thenM` \ loc ->
284 newMethod loc id tys `thenM` \ inst ->
285 extendLIE inst `thenM_`
286 returnM (instToId inst)
288 --------------------------------------------
289 -- tcInstClassOp, and newMethod do *not* drop the
290 -- Inst into the LIE; they just returns the Inst
291 -- This is important because they are used by TcSimplify
294 -- NB: the kind of the type variable to be instantiated
295 -- might be a sub-kind of the type to which it is applied,
296 -- notably when the latter is a type variable of kind ??
297 -- Hence the call to checkKind
298 -- A worry: is this needed anywhere else?
299 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
300 tcInstClassOp inst_loc sel_id tys
302 (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
304 zipWithM_ checkKind tyvars tys `thenM_`
305 newMethod inst_loc sel_id tys
307 checkKind :: TyVar -> TcType -> TcM ()
308 -- Ensure that the type has a sub-kind of the tyvar
311 -- ty1 <- zonkTcType ty
312 ; if typeKind ty1 `isSubKind` tyVarKind tv
316 pprPanic "checkKind: adding kind constraint"
317 (vcat [ppr tv <+> ppr (tyVarKind tv),
318 ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
320 -- do { tv1 <- tcInstTyVar tv
321 -- ; unifyType ty1 (mkTyVarTy tv1) } }
324 ---------------------------
325 newMethod inst_loc id tys
326 = newUnique `thenM` \ new_uniq ->
328 (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
329 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
330 inst = Method meth_id id tys theta inst_loc
331 loc = instLocSrcLoc inst_loc
337 shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
339 | isIntTy ty && inIntRange i -- Short cut for Int
340 = Just (HsLit (HsInt i))
341 | isIntegerTy ty -- Short cut for Integer
342 = Just (HsLit (HsInteger i ty))
343 | otherwise = Nothing
345 shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
348 = Just (mk_lit floatDataCon (HsFloatPrim f))
350 = Just (mk_lit doubleDataCon (HsDoublePrim f))
351 | otherwise = Nothing
353 mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
355 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
357 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
358 getSrcSpanM `thenM` \ span ->
359 returnM (L span $ HsLit (HsInteger i integer_ty))
361 mkRatLit :: Rational -> TcM (LHsExpr TcId)
363 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
364 getSrcSpanM `thenM` \ span ->
365 returnM (L span $ HsLit (HsRat r rat_ty))
367 isHsVar :: HsExpr Name -> Name -> Bool
368 isHsVar (HsVar f) g = f==g
369 isHsVar other g = False
373 %************************************************************************
377 %************************************************************************
379 Zonking makes sure that the instance types are fully zonked.
382 zonkInst :: Inst -> TcM Inst
383 zonkInst (Dict name pred loc)
384 = zonkTcPredType pred `thenM` \ new_pred ->
385 returnM (Dict name new_pred loc)
387 zonkInst (Method m id tys theta loc)
388 = zonkId id `thenM` \ new_id ->
389 -- Essential to zonk the id in case it's a local variable
390 -- Can't use zonkIdOcc because the id might itself be
391 -- an InstId, in which case it won't be in scope
393 zonkTcTypes tys `thenM` \ new_tys ->
394 zonkTcThetaType theta `thenM` \ new_theta ->
395 returnM (Method m new_id new_tys new_theta loc)
397 zonkInst (LitInst nm lit ty loc)
398 = zonkTcType ty `thenM` \ new_ty ->
399 returnM (LitInst nm lit new_ty loc)
401 zonkInsts insts = mappM zonkInst insts
405 %************************************************************************
407 \subsection{Printing}
409 %************************************************************************
411 ToDo: improve these pretty-printing things. The ``origin'' is really only
412 relevant in error messages.
415 instance Outputable Inst where
416 ppr inst = pprInst inst
418 pprDictsTheta :: [Inst] -> SDoc
419 -- Print in type-like fashion (Eq a, Show b)
420 pprDictsTheta dicts = pprTheta (map dictPred dicts)
422 pprDictsInFull :: [Inst] -> SDoc
423 -- Print in type-like fashion, but with source location
425 = vcat (map go dicts)
427 go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))]
429 pprInsts :: [Inst] -> SDoc
430 -- Debugging: print the evidence :: type
431 pprInsts insts = brackets (interpp'SP insts)
433 pprInst, pprInstInFull :: Inst -> SDoc
434 -- Debugging: print the evidence :: type
435 pprInst (LitInst nm lit ty loc) = ppr nm <+> dcolon <+> ppr ty
436 pprInst (Dict nm pred loc) = ppr nm <+> dcolon <+> pprPred pred
438 pprInst m@(Method inst_id id tys theta loc)
439 = ppr inst_id <+> dcolon <+>
440 braces (sep [ppr id <+> ptext SLIT("at"),
441 brackets (sep (map pprParendType tys))])
444 = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
446 tidyInst :: TidyEnv -> Inst -> Inst
447 tidyInst env (LitInst nm lit ty loc) = LitInst nm lit (tidyType env ty) loc
448 tidyInst env (Dict nm pred loc) = Dict nm (tidyPred env pred) loc
449 tidyInst env (Method u id tys theta loc) = Method u id (tidyTypes env tys) theta loc
451 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
452 -- This function doesn't assume that the tyvars are in scope
453 -- so it works like tidyOpenType, returning a TidyEnv
454 tidyMoreInsts env insts
455 = (env', map (tidyInst env') insts)
457 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
459 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
460 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
462 showLIE :: SDoc -> TcM () -- Debugging
464 = do { lie_var <- getLIEVar ;
465 lie <- readMutVar lie_var ;
466 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
470 %************************************************************************
472 Extending the instance environment
474 %************************************************************************
477 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
478 -- Add new locally-defined instances
479 tcExtendLocalInstEnv dfuns thing_inside
480 = do { traceDFuns dfuns
482 ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
483 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
484 tcg_inst_env = inst_env' }
485 ; setGblEnv env' thing_inside }
487 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
488 -- Check that the proposed new instance is OK,
489 -- and then add it to the home inst env
490 addLocalInst home_ie ispec
491 = do { -- Instantiate the dfun type so that we extend the instance
492 -- envt with completely fresh template variables
493 -- This is important because the template variables must
494 -- not overlap with anything in the things being looked up
495 -- (since we do unification).
496 -- We use tcInstSkolType because we don't want to allocate fresh
497 -- *meta* type variables.
498 let dfun = instanceDFunId ispec
499 ; (tvs', theta', tau') <- tcInstSkolType (InstSkol dfun) (idType dfun)
500 ; let (cls, tys') = tcSplitDFunHead tau'
501 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
502 ispec' = setInstanceDFunId ispec dfun'
504 -- Load imported instances, so that we report
505 -- duplicates correctly
507 ; let inst_envs = (eps_inst_env eps, home_ie)
509 -- Check functional dependencies
510 ; case checkFunDeps inst_envs ispec' of
511 Just specs -> funDepErr ispec' specs
514 -- Check for duplicate instance decls
515 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
516 ; dup_ispecs = [ dup_ispec
517 | (_, dup_ispec) <- matches
518 , let (_,_,_,dup_tys) = instanceHead dup_ispec
519 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
520 -- Find memebers of the match list which ispec itself matches.
521 -- If the match is 2-way, it's a duplicate
523 dup_ispec : _ -> dupInstErr ispec' dup_ispec
526 -- OK, now extend the envt
527 ; return (extendInstEnv home_ie ispec') }
529 getOverlapFlag :: TcM OverlapFlag
531 = do { dflags <- getDOpts
532 ; let overlap_ok = dopt Opt_AllowOverlappingInstances dflags
533 incoherent_ok = dopt Opt_AllowIncoherentInstances dflags
534 overlap_flag | incoherent_ok = Incoherent
535 | overlap_ok = OverlapOk
536 | otherwise = NoOverlap
538 ; return overlap_flag }
541 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
543 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
544 -- Print the dfun name itself too
546 funDepErr ispec ispecs
548 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
549 2 (pprInstances (ispec:ispecs)))
550 dupInstErr ispec dup_ispec
552 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
553 2 (pprInstances [ispec, dup_ispec]))
555 addDictLoc ispec thing_inside
556 = setSrcSpan (mkSrcSpan loc loc) thing_inside
558 loc = getSrcLoc ispec
562 %************************************************************************
564 \subsection{Looking up Insts}
566 %************************************************************************
569 data LookupInstResult
571 | SimpleInst (LHsExpr TcId) -- Just a variable, type application, or literal
572 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
574 lookupInst :: Inst -> TcM LookupInstResult
575 -- It's important that lookupInst does not put any new stuff into
576 -- the LIE. Instead, any Insts needed by the lookup are returned in
577 -- the LookupInstResult, where they can be further processed by tcSimplify
582 lookupInst inst@(Method _ id tys theta loc)
583 = newDictsAtLoc loc theta `thenM` \ dicts ->
584 returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (L span (HsVar id)) tys) (map instToId dicts)))
586 span = instLocSrcSpan loc
590 -- Look for short cuts first: if the literal is *definitely* a
591 -- int, integer, float or a double, generate the real thing here.
592 -- This is essential (see nofib/spectral/nucleic).
593 -- [Same shortcut as in newOverloadedLit, but we
594 -- may have done some unification by now]
596 lookupInst inst@(LitInst _nm (HsIntegral i from_integer_name) ty loc)
597 | Just expr <- shortCutIntLit i ty
598 = returnM (GenInst [] (noLoc expr)) -- GenInst, not SimpleInst, because
599 -- expr may be a constructor application
601 = ASSERT( from_integer_name `isHsVar` fromIntegerName ) -- A LitInst invariant
602 tcLookupId fromIntegerName `thenM` \ from_integer ->
603 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
604 mkIntegerLit i `thenM` \ integer_lit ->
605 returnM (GenInst [method_inst]
606 (mkHsApp (L (instLocSrcSpan loc)
607 (HsVar (instToId method_inst))) integer_lit))
609 lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc)
610 | Just expr <- shortCutFracLit f ty
611 = returnM (GenInst [] (noLoc expr))
614 = ASSERT( from_rat_name `isHsVar` fromRationalName ) -- A LitInst invariant
615 tcLookupId fromRationalName `thenM` \ from_rational ->
616 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
617 mkRatLit f `thenM` \ rat_lit ->
618 returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc)
619 (HsVar (instToId method_inst))) rat_lit))
622 lookupInst (Dict _ pred loc)
623 = do { mb_result <- lookupPred pred
624 ; case mb_result of {
625 Nothing -> return NoInstance ;
626 Just (tenv, dfun_id) -> do
628 -- tenv is a substitution that instantiates the dfun_id
629 -- to match the requested result type.
631 -- We ASSUME that the dfun is quantified over the very same tyvars
632 -- that are bound by the tenv.
635 -- might have some tyvars that *only* appear in arguments
636 -- dfun :: forall a b. C a b, Ord b => D [a]
637 -- We instantiate b to a flexi type variable -- it'll presumably
638 -- become fixed later via functional dependencies
639 { use_stage <- getStage
640 ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
641 (topIdLvl dfun_id) use_stage
643 -- It's possible that not all the tyvars are in
644 -- the substitution, tenv. For example:
645 -- instance C X a => D X where ...
646 -- (presumably there's a functional dependency in class C)
647 -- Hence the open_tvs to instantiate any un-substituted tyvars.
648 ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
649 open_tvs = filter (`notElemTvSubst` tenv) tyvars
650 ; open_tvs' <- mappM tcInstTyVar open_tvs
652 tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
653 -- Since the open_tvs' are freshly made, they cannot possibly be captured by
654 -- any nested for-alls in rho. So the in-scope set is unchanged
655 dfun_rho = substTy tenv' rho
656 (theta, _) = tcSplitPhiTy dfun_rho
657 ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id))
658 (map (substTyVar tenv') tyvars)
660 returnM (SimpleInst ty_app)
662 { dicts <- newDictsAtLoc loc theta
663 ; let rhs = mkHsDictApp ty_app (map instToId dicts)
664 ; returnM (GenInst dicts rhs)
668 lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
669 -- Look up a class constraint in the instance environment
670 lookupPred pred@(ClassP clas tys)
672 ; tcg_env <- getGblEnv
673 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
674 ; case lookupInstEnv inst_envs clas tys of {
675 ([(tenv, ispec)], [])
676 -> do { let dfun_id = is_dfun ispec
677 ; traceTc (text "lookupInst success" <+>
678 vcat [text "dict" <+> ppr pred,
679 text "witness" <+> ppr dfun_id
680 <+> ppr (idType dfun_id) ])
681 -- Record that this dfun is needed
682 ; record_dfun_usage dfun_id
683 ; return (Just (tenv, dfun_id)) } ;
686 -> do { traceTc (text "lookupInst fail" <+>
687 vcat [text "dict" <+> ppr pred,
688 text "matches" <+> ppr matches,
689 text "unifs" <+> ppr unifs])
690 -- In the case of overlap (multiple matches) we report
691 -- NoInstance here. That has the effect of making the
692 -- context-simplifier return the dict as an irreducible one.
693 -- Then it'll be given to addNoInstanceErrs, which will do another
694 -- lookupInstEnv to get the detailed info about what went wrong.
698 lookupPred ip_pred = return Nothing
700 record_dfun_usage dfun_id
701 = do { hsc_env <- getTopEnv
702 ; let dfun_name = idName dfun_id
703 dfun_mod = nameModule dfun_name
704 ; if isInternalName dfun_name || -- Internal name => defined in this module
705 modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
706 then return () -- internal, or in another package
707 else do { tcg_env <- getGblEnv
708 ; updMutVar (tcg_inst_uses tcg_env)
709 (`addOneToNameSet` idName dfun_id) }}
712 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
713 -- Gets both the external-package inst-env
714 -- and the home-pkg inst env (includes module being compiled)
715 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
716 return (eps_inst_env eps, tcg_inst_env env) }
721 %************************************************************************
725 %************************************************************************
727 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
728 a do-expression. We have to find (>>) in the current environment, which is
729 done by the rename. Then we have to check that it has the same type as
730 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
733 (>>) :: HB m n mn => m a -> n b -> mn b
735 So the idea is to generate a local binding for (>>), thus:
737 let then72 :: forall a b. m a -> m b -> m b
738 then72 = ...something involving the user's (>>)...
740 ...the do-expression...
742 Now the do-expression can proceed using then72, which has exactly
745 In fact tcSyntaxName just generates the RHS for then72, because we only
746 want an actual binding in the do-expression case. For literals, we can
747 just use the expression inline.
750 tcSyntaxName :: InstOrigin
751 -> TcType -- Type to instantiate it at
752 -> (Name, HsExpr Name) -- (Standard name, user name)
753 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
754 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
755 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
756 -- So we do not call it from lookupInst, which is called from tcSimplify
758 tcSyntaxName orig ty (std_nm, HsVar user_nm)
760 = newMethodFromName orig ty std_nm `thenM` \ id ->
761 returnM (std_nm, HsVar id)
763 tcSyntaxName orig ty (std_nm, user_nm_expr)
764 = tcLookupId std_nm `thenM` \ std_id ->
766 -- C.f. newMethodAtLoc
767 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
768 sigma1 = substTyWith [tv] [ty] tau
769 -- Actually, the "tau-type" might be a sigma-type in the
770 -- case of locally-polymorphic methods.
772 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $
774 -- Check that the user-supplied thing has the
775 -- same type as the standard one.
776 -- Tiresome jiggling because tcCheckSigma takes a located expression
777 getSrcSpanM `thenM` \ span ->
778 tcPolyExpr (L span user_nm_expr) sigma1 `thenM` \ expr ->
779 returnM (std_nm, unLoc expr)
781 syntaxNameCtxt name orig ty tidy_env
782 = getInstLoc orig `thenM` \ inst_loc ->
784 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
785 ptext SLIT("(needed by a syntactic construct)"),
786 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
787 nest 2 (pprInstLoc inst_loc)]
789 returnM (tidy_env, msg)