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 newDictBndr, newDictBndrs, newDictBndrsO,
16 instCall, instStupidTheta,
18 shortCutFracLit, shortCutIntLit, newIPDict,
19 newMethod, newMethodFromName, newMethodWithGivenTy,
21 tcSyntaxName, isHsVar,
23 tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
24 ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
25 instLoc, getDictClassTys, dictPred,
27 lookupInst, LookupInstResult(..), lookupPred,
28 tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
30 isDict, isClassDict, isMethod,
31 isIPDict, isInheritableInst,
32 isTyVarDict, isMethodFor,
35 instToId, instToVar, instName,
37 InstOrigin(..), InstLoc(..), pprInstLoc
40 #include "HsVersions.h"
42 import {-# SOURCE #-} TcExpr( tcPolyExpr )
43 import {-# SOURCE #-} TcUnify( unifyType )
45 import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp,
46 HsWrapper(..), (<.>), mkWpTyApps, idHsWrapper,
48 import TcHsSyn ( zonkId )
50 import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
51 import InstEnv ( DFunId, InstEnv, Instance(..), OverlapFlag(..),
52 lookupInstEnv, extendInstEnv, pprInstances,
53 instanceHead, instanceDFunId, setInstanceDFunId )
54 import FunDeps ( checkFunDeps )
55 import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zonkTcThetaType,
56 tcInstTyVar, tcInstSkolType
58 import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcPredType,
60 PredType(..), SkolemInfo(..), typeKind, mkSigmaTy,
61 tcSplitForAllTys, applyTys,
62 tcSplitPhiTy, tcSplitDFunHead,
63 isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
65 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
66 isClassPred, isTyVarClassPred,
67 getClassPredTys, mkPredName,
68 isInheritablePred, isIPPred,
69 tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy,
70 pprPred, pprParendType, pprTheta
72 import Type ( TvSubst, substTy, substTyVar, substTyWith,
73 notElemTvSubst, extendTvSubstList )
74 import Unify ( tcMatchTys )
75 import Module ( modulePackageId )
76 import {- Kind parts of -} Type ( isSubKind )
77 import Coercion ( isEqPred )
78 import HscTypes ( ExternalPackageState(..), HscEnv(..) )
79 import CoreFVs ( idFreeTyVars )
80 import DataCon ( dataConWrapId )
81 import Id ( Id, idName, idType, mkUserLocal, mkLocalId, isId )
82 import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
83 isInternalName, setNameUnique )
84 import NameSet ( addOneToNameSet )
85 import Literal ( inIntRange )
86 import Var ( Var, TyVar, tyVarKind, setIdType, isId, mkTyVar )
87 import VarEnv ( TidyEnv, emptyTidyEnv )
88 import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
89 import TysWiredIn ( floatDataCon, doubleDataCon )
90 import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
91 import BasicTypes( IPName(..), mapIPName, ipNameName )
92 import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) )
93 import DynFlags ( DynFlag(..), DynFlags(..), dopt )
94 import Maybes ( isJust )
102 instName :: Inst -> Name
103 instName inst = idName (instToId inst)
105 instToId :: Inst -> TcId
106 instToId inst = ASSERT2( isId id, ppr inst ) id
110 instToVar :: Inst -> Var
111 instToVar (LitInst nm _ ty _) = mkLocalId nm ty
112 instToVar (Method id _ _ _ _) = id
113 instToVar (Dict nm pred _)
114 | isEqPred pred = mkTyVar nm (mkPredTy pred)
115 | otherwise = mkLocalId nm (mkPredTy pred)
117 instLoc (Dict _ _ loc) = loc
118 instLoc (Method _ _ _ _ loc) = loc
119 instLoc (LitInst _ _ _ loc) = loc
121 dictPred (Dict _ pred _ ) = pred
122 dictPred inst = pprPanic "dictPred" (ppr inst)
124 getDictClassTys (Dict _ pred _) = getClassPredTys pred
126 -- fdPredsOfInst is used to get predicates that contain functional
127 -- dependencies *or* might do so. The "might do" part is because
128 -- a constraint (C a b) might have a superclass with FDs
129 -- Leaving these in is really important for the call to fdPredsOfInsts
130 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
131 -- which is supposed to be conservative
132 fdPredsOfInst (Dict _ pred _) = [pred]
133 fdPredsOfInst (Method _ _ _ theta _) = theta
134 fdPredsOfInst other = [] -- LitInsts etc
136 fdPredsOfInsts :: [Inst] -> [PredType]
137 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
139 isInheritableInst (Dict _ pred _) = isInheritablePred pred
140 isInheritableInst (Method _ _ _ theta _) = all isInheritablePred theta
141 isInheritableInst other = True
144 ipNamesOfInsts :: [Inst] -> [Name]
145 ipNamesOfInst :: Inst -> [Name]
146 -- Get the implicit parameters mentioned by these Insts
147 -- NB: ?x and %x get different Names
148 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
150 ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
151 ipNamesOfInst (Method _ _ _ theta _) = [ipNameName n | IParam n _ <- theta]
152 ipNamesOfInst other = []
154 tyVarsOfInst :: Inst -> TcTyVarSet
155 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
156 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
157 tyVarsOfInst (Method _ id tys _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
158 -- The id might have free type variables; in the case of
159 -- locally-overloaded class methods, for example
162 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
163 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
169 isDict :: Inst -> Bool
170 isDict (Dict _ _ _) = True
173 isClassDict :: Inst -> Bool
174 isClassDict (Dict _ pred _) = isClassPred pred
175 isClassDict other = False
177 isTyVarDict :: Inst -> Bool
178 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
179 isTyVarDict other = False
181 isIPDict :: Inst -> Bool
182 isIPDict (Dict _ pred _) = isIPPred pred
183 isIPDict other = False
185 isMethod :: Inst -> Bool
186 isMethod (Method {}) = True
187 isMethod other = False
189 isMethodFor :: TcIdSet -> Inst -> Bool
190 isMethodFor ids (Method uniq id tys _ loc) = id `elemVarSet` ids
191 isMethodFor ids inst = False
196 %************************************************************************
198 \subsection{Building dictionaries}
200 %************************************************************************
202 -- newDictBndrs makes a dictionary at a binding site
203 -- instCall makes a dictionary at an occurrence site
204 -- and throws it into the LIE
208 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
209 newDictBndrsO orig theta = do { loc <- getInstLoc orig
210 ; newDictBndrs loc theta }
212 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
213 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
215 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
216 newDictBndr inst_loc pred
217 = do { uniq <- newUnique
218 ; let name = mkPredName uniq (instLocSrcLoc inst_loc) pred
219 ; return (Dict name pred inst_loc) }
222 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
223 -- Instantiate the constraints of a call
224 -- (instCall o tys theta)
225 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
226 -- (b) Throws these dictionaries into the LIE
227 -- (c) Eeturns an HsWrapper ([.] tys dicts)
229 instCall orig tys theta
230 = do { loc <- getInstLoc orig
231 ; (dicts, dict_app) <- instCallDicts loc theta
233 ; return (dict_app <.> mkWpTyApps tys) }
236 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
237 -- Similar to instCall, but only emit the constraints in the LIE
238 -- Used exclusively for the 'stupid theta' of a data constructor
239 instStupidTheta orig theta
240 = do { loc <- getInstLoc orig
241 ; (dicts, _) <- instCallDicts loc theta
245 instCallDicts :: InstLoc -> TcThetaType -> TcM ([Inst], HsWrapper)
246 -- This is the key place where equality predicates
247 -- are unleashed into the world
248 instCallDicts loc [] = return ([], idHsWrapper)
250 instCallDicts loc (EqPred ty1 ty2 : preds)
251 = do { unifyType ty1 ty2 -- For now, we insist that they unify right away
252 -- Later on, when we do associated types,
253 -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
254 ; (dicts, co_fn) <- instCallDicts loc preds
255 ; return (dicts, co_fn <.> WpTyApp ty1) }
256 -- We use type application to apply the function to the
257 -- coercion; here ty1 *is* the appropriate identity coercion
259 instCallDicts loc (pred : preds)
260 = do { uniq <- newUnique
261 ; let name = mkPredName uniq (instLocSrcLoc loc) pred
262 dict = Dict name pred loc
263 ; (dicts, co_fn) <- instCallDicts loc preds
264 ; return (dict:dicts, co_fn <.> WpApp (instToId dict)) }
267 cloneDict :: Inst -> TcM Inst -- Only used for linear implicit params
268 cloneDict (Dict nm ty loc) = newUnique `thenM` \ uniq ->
269 returnM (Dict (setNameUnique nm uniq) ty loc)
271 -- For vanilla implicit parameters, there is only one in scope
272 -- at any time, so we used to use the name of the implicit parameter itself
273 -- But with splittable implicit parameters there may be many in
274 -- scope, so we make up a new namea.
275 newIPDict :: InstOrigin -> IPName Name -> Type
276 -> TcM (IPName Id, Inst)
277 newIPDict orig ip_name ty
278 = getInstLoc orig `thenM` \ inst_loc ->
279 newUnique `thenM` \ uniq ->
281 pred = IParam ip_name ty
282 name = mkPredName uniq (instLocSrcLoc inst_loc) pred
283 dict = Dict name pred inst_loc
285 returnM (mapIPName (\n -> instToId dict) ip_name, dict)
290 %************************************************************************
292 \subsection{Building methods (calls of overloaded functions)}
294 %************************************************************************
298 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
299 newMethodFromName origin ty name
300 = tcLookupId name `thenM` \ id ->
301 -- Use tcLookupId not tcLookupGlobalId; the method is almost
302 -- always a class op, but with -fno-implicit-prelude GHC is
303 -- meant to find whatever thing is in scope, and that may
304 -- be an ordinary function.
305 getInstLoc origin `thenM` \ loc ->
306 tcInstClassOp loc id [ty] `thenM` \ inst ->
307 extendLIE inst `thenM_`
308 returnM (instToId inst)
310 newMethodWithGivenTy orig id tys
311 = getInstLoc orig `thenM` \ loc ->
312 newMethod loc id tys `thenM` \ inst ->
313 extendLIE inst `thenM_`
314 returnM (instToId inst)
316 --------------------------------------------
317 -- tcInstClassOp, and newMethod do *not* drop the
318 -- Inst into the LIE; they just returns the Inst
319 -- This is important because they are used by TcSimplify
322 -- NB: the kind of the type variable to be instantiated
323 -- might be a sub-kind of the type to which it is applied,
324 -- notably when the latter is a type variable of kind ??
325 -- Hence the call to checkKind
326 -- A worry: is this needed anywhere else?
327 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
328 tcInstClassOp inst_loc sel_id tys
330 (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
332 zipWithM_ checkKind tyvars tys `thenM_`
333 newMethod inst_loc sel_id tys
335 checkKind :: TyVar -> TcType -> TcM ()
336 -- Ensure that the type has a sub-kind of the tyvar
339 -- ty1 <- zonkTcType ty
340 ; if typeKind ty1 `isSubKind` tyVarKind tv
344 pprPanic "checkKind: adding kind constraint"
345 (vcat [ppr tv <+> ppr (tyVarKind tv),
346 ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
348 -- do { tv1 <- tcInstTyVar tv
349 -- ; unifyType ty1 (mkTyVarTy tv1) } }
352 ---------------------------
353 newMethod inst_loc id tys
354 = newUnique `thenM` \ new_uniq ->
356 (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
357 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
358 inst = Method meth_id id tys theta inst_loc
359 loc = instLocSrcLoc inst_loc
365 shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
367 | isIntTy ty && inIntRange i -- Short cut for Int
368 = Just (HsLit (HsInt i))
369 | isIntegerTy ty -- Short cut for Integer
370 = Just (HsLit (HsInteger i ty))
371 | otherwise = Nothing
373 shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
376 = Just (mk_lit floatDataCon (HsFloatPrim f))
378 = Just (mk_lit doubleDataCon (HsDoublePrim f))
379 | otherwise = Nothing
381 mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
383 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
385 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
386 getSrcSpanM `thenM` \ span ->
387 returnM (L span $ HsLit (HsInteger i integer_ty))
389 mkRatLit :: Rational -> TcM (LHsExpr TcId)
391 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
392 getSrcSpanM `thenM` \ span ->
393 returnM (L span $ HsLit (HsRat r rat_ty))
395 isHsVar :: HsExpr Name -> Name -> Bool
396 isHsVar (HsVar f) g = f==g
397 isHsVar other g = False
401 %************************************************************************
405 %************************************************************************
407 Zonking makes sure that the instance types are fully zonked.
410 zonkInst :: Inst -> TcM Inst
411 zonkInst (Dict name pred loc)
412 = zonkTcPredType pred `thenM` \ new_pred ->
413 returnM (Dict name new_pred loc)
415 zonkInst (Method m id tys theta loc)
416 = zonkId id `thenM` \ new_id ->
417 -- Essential to zonk the id in case it's a local variable
418 -- Can't use zonkIdOcc because the id might itself be
419 -- an InstId, in which case it won't be in scope
421 zonkTcTypes tys `thenM` \ new_tys ->
422 zonkTcThetaType theta `thenM` \ new_theta ->
423 returnM (Method m new_id new_tys new_theta loc)
425 zonkInst (LitInst nm lit ty loc)
426 = zonkTcType ty `thenM` \ new_ty ->
427 returnM (LitInst nm lit new_ty loc)
429 zonkInsts insts = mappM zonkInst insts
433 %************************************************************************
435 \subsection{Printing}
437 %************************************************************************
439 ToDo: improve these pretty-printing things. The ``origin'' is really only
440 relevant in error messages.
443 instance Outputable Inst where
444 ppr inst = pprInst inst
446 pprDictsTheta :: [Inst] -> SDoc
447 -- Print in type-like fashion (Eq a, Show b)
448 pprDictsTheta dicts = pprTheta (map dictPred dicts)
450 pprDictsInFull :: [Inst] -> SDoc
451 -- Print in type-like fashion, but with source location
453 = vcat (map go dicts)
455 go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))]
457 pprInsts :: [Inst] -> SDoc
458 -- Debugging: print the evidence :: type
459 pprInsts insts = brackets (interpp'SP insts)
461 pprInst, pprInstInFull :: Inst -> SDoc
462 -- Debugging: print the evidence :: type
463 pprInst (LitInst nm lit ty loc) = ppr nm <+> dcolon <+> ppr ty
464 pprInst (Dict nm pred loc) = ppr nm <+> dcolon <+> pprPred pred
466 pprInst m@(Method inst_id id tys theta loc)
467 = ppr inst_id <+> dcolon <+>
468 braces (sep [ppr id <+> ptext SLIT("at"),
469 brackets (sep (map pprParendType tys))])
472 = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
474 tidyInst :: TidyEnv -> Inst -> Inst
475 tidyInst env (LitInst nm lit ty loc) = LitInst nm lit (tidyType env ty) loc
476 tidyInst env (Dict nm pred loc) = Dict nm (tidyPred env pred) loc
477 tidyInst env (Method u id tys theta loc) = Method u id (tidyTypes env tys) theta loc
479 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
480 -- This function doesn't assume that the tyvars are in scope
481 -- so it works like tidyOpenType, returning a TidyEnv
482 tidyMoreInsts env insts
483 = (env', map (tidyInst env') insts)
485 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
487 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
488 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
490 showLIE :: SDoc -> TcM () -- Debugging
492 = do { lie_var <- getLIEVar ;
493 lie <- readMutVar lie_var ;
494 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
498 %************************************************************************
500 Extending the instance environment
502 %************************************************************************
505 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
506 -- Add new locally-defined instances
507 tcExtendLocalInstEnv dfuns thing_inside
508 = do { traceDFuns dfuns
510 ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
511 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
512 tcg_inst_env = inst_env' }
513 ; setGblEnv env' thing_inside }
515 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
516 -- Check that the proposed new instance is OK,
517 -- and then add it to the home inst env
518 addLocalInst home_ie ispec
519 = do { -- Instantiate the dfun type so that we extend the instance
520 -- envt with completely fresh template variables
521 -- This is important because the template variables must
522 -- not overlap with anything in the things being looked up
523 -- (since we do unification).
524 -- We use tcInstSkolType because we don't want to allocate fresh
525 -- *meta* type variables.
526 let dfun = instanceDFunId ispec
527 ; (tvs', theta', tau') <- tcInstSkolType (InstSkol dfun) (idType dfun)
528 ; let (cls, tys') = tcSplitDFunHead tau'
529 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
530 ispec' = setInstanceDFunId ispec dfun'
532 -- Load imported instances, so that we report
533 -- duplicates correctly
535 ; let inst_envs = (eps_inst_env eps, home_ie)
537 -- Check functional dependencies
538 ; case checkFunDeps inst_envs ispec' of
539 Just specs -> funDepErr ispec' specs
542 -- Check for duplicate instance decls
543 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
544 ; dup_ispecs = [ dup_ispec
545 | (_, dup_ispec) <- matches
546 , let (_,_,_,dup_tys) = instanceHead dup_ispec
547 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
548 -- Find memebers of the match list which ispec itself matches.
549 -- If the match is 2-way, it's a duplicate
551 dup_ispec : _ -> dupInstErr ispec' dup_ispec
554 -- OK, now extend the envt
555 ; return (extendInstEnv home_ie ispec') }
557 getOverlapFlag :: TcM OverlapFlag
559 = do { dflags <- getDOpts
560 ; let overlap_ok = dopt Opt_AllowOverlappingInstances dflags
561 incoherent_ok = dopt Opt_AllowIncoherentInstances dflags
562 overlap_flag | incoherent_ok = Incoherent
563 | overlap_ok = OverlapOk
564 | otherwise = NoOverlap
566 ; return overlap_flag }
569 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
571 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
572 -- Print the dfun name itself too
574 funDepErr ispec ispecs
576 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
577 2 (pprInstances (ispec:ispecs)))
578 dupInstErr ispec dup_ispec
580 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
581 2 (pprInstances [ispec, dup_ispec]))
583 addDictLoc ispec thing_inside
584 = setSrcSpan (mkSrcSpan loc loc) thing_inside
586 loc = getSrcLoc ispec
590 %************************************************************************
592 \subsection{Looking up Insts}
594 %************************************************************************
597 data LookupInstResult
599 | SimpleInst (LHsExpr TcId) -- Just a variable, type application, or literal
600 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
602 lookupInst :: Inst -> TcM LookupInstResult
603 -- It's important that lookupInst does not put any new stuff into
604 -- the LIE. Instead, any Insts needed by the lookup are returned in
605 -- the LookupInstResult, where they can be further processed by tcSimplify
610 lookupInst inst@(Method _ id tys theta loc)
611 = do { (dicts, dict_app) <- instCallDicts loc theta
612 ; let co_fn = dict_app <.> mkWpTyApps tys
613 ; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
615 span = instLocSrcSpan loc
619 -- Look for short cuts first: if the literal is *definitely* a
620 -- int, integer, float or a double, generate the real thing here.
621 -- This is essential (see nofib/spectral/nucleic).
622 -- [Same shortcut as in newOverloadedLit, but we
623 -- may have done some unification by now]
625 lookupInst inst@(LitInst _nm (HsIntegral i from_integer_name) ty loc)
626 | Just expr <- shortCutIntLit i ty
627 = returnM (GenInst [] (noLoc expr)) -- GenInst, not SimpleInst, because
628 -- expr may be a constructor application
630 = ASSERT( from_integer_name `isHsVar` fromIntegerName ) -- A LitInst invariant
631 tcLookupId fromIntegerName `thenM` \ from_integer ->
632 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
633 mkIntegerLit i `thenM` \ integer_lit ->
634 returnM (GenInst [method_inst]
635 (mkHsApp (L (instLocSrcSpan loc)
636 (HsVar (instToId method_inst))) integer_lit))
638 lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc)
639 | Just expr <- shortCutFracLit f ty
640 = returnM (GenInst [] (noLoc expr))
643 = ASSERT( from_rat_name `isHsVar` fromRationalName ) -- A LitInst invariant
644 tcLookupId fromRationalName `thenM` \ from_rational ->
645 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
646 mkRatLit f `thenM` \ rat_lit ->
647 returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc)
648 (HsVar (instToId method_inst))) rat_lit))
651 lookupInst (Dict _ pred loc)
652 = do { mb_result <- lookupPred pred
653 ; case mb_result of {
654 Nothing -> return NoInstance ;
655 Just (tenv, dfun_id) -> do
657 -- tenv is a substitution that instantiates the dfun_id
658 -- to match the requested result type.
660 -- We ASSUME that the dfun is quantified over the very same tyvars
661 -- that are bound by the tenv.
664 -- might have some tyvars that *only* appear in arguments
665 -- dfun :: forall a b. C a b, Ord b => D [a]
666 -- We instantiate b to a flexi type variable -- it'll presumably
667 -- become fixed later via functional dependencies
668 { use_stage <- getStage
669 ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
670 (topIdLvl dfun_id) use_stage
672 -- It's possible that not all the tyvars are in
673 -- the substitution, tenv. For example:
674 -- instance C X a => D X where ...
675 -- (presumably there's a functional dependency in class C)
676 -- Hence the open_tvs to instantiate any un-substituted tyvars.
677 ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
678 open_tvs = filter (`notElemTvSubst` tenv) tyvars
679 ; open_tvs' <- mappM tcInstTyVar open_tvs
681 tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
682 -- Since the open_tvs' are freshly made, they cannot possibly be captured by
683 -- any nested for-alls in rho. So the in-scope set is unchanged
684 dfun_rho = substTy tenv' rho
685 (theta, _) = tcSplitPhiTy dfun_rho
686 src_loc = instLocSrcSpan loc
688 tys = map (substTyVar tenv') tyvars
690 returnM (SimpleInst (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
692 { (dicts, dict_app) <- instCallDicts loc theta
693 ; let co_fn = dict_app <.> mkWpTyApps tys
694 ; returnM (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
698 lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
699 -- Look up a class constraint in the instance environment
700 lookupPred pred@(ClassP clas tys)
702 ; tcg_env <- getGblEnv
703 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
704 ; case lookupInstEnv inst_envs clas tys of {
705 ([(tenv, ispec)], [])
706 -> do { let dfun_id = is_dfun ispec
707 ; traceTc (text "lookupInst success" <+>
708 vcat [text "dict" <+> ppr pred,
709 text "witness" <+> ppr dfun_id
710 <+> ppr (idType dfun_id) ])
711 -- Record that this dfun is needed
712 ; record_dfun_usage dfun_id
713 ; return (Just (tenv, dfun_id)) } ;
716 -> do { traceTc (text "lookupInst fail" <+>
717 vcat [text "dict" <+> ppr pred,
718 text "matches" <+> ppr matches,
719 text "unifs" <+> ppr unifs])
720 -- In the case of overlap (multiple matches) we report
721 -- NoInstance here. That has the effect of making the
722 -- context-simplifier return the dict as an irreducible one.
723 -- Then it'll be given to addNoInstanceErrs, which will do another
724 -- lookupInstEnv to get the detailed info about what went wrong.
728 lookupPred ip_pred = return Nothing
730 record_dfun_usage dfun_id
731 = do { hsc_env <- getTopEnv
732 ; let dfun_name = idName dfun_id
733 dfun_mod = nameModule dfun_name
734 ; if isInternalName dfun_name || -- Internal name => defined in this module
735 modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
736 then return () -- internal, or in another package
737 else do { tcg_env <- getGblEnv
738 ; updMutVar (tcg_inst_uses tcg_env)
739 (`addOneToNameSet` idName dfun_id) }}
742 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
743 -- Gets both the external-package inst-env
744 -- and the home-pkg inst env (includes module being compiled)
745 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
746 return (eps_inst_env eps, tcg_inst_env env) }
751 %************************************************************************
755 %************************************************************************
757 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
758 a do-expression. We have to find (>>) in the current environment, which is
759 done by the rename. Then we have to check that it has the same type as
760 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
763 (>>) :: HB m n mn => m a -> n b -> mn b
765 So the idea is to generate a local binding for (>>), thus:
767 let then72 :: forall a b. m a -> m b -> m b
768 then72 = ...something involving the user's (>>)...
770 ...the do-expression...
772 Now the do-expression can proceed using then72, which has exactly
775 In fact tcSyntaxName just generates the RHS for then72, because we only
776 want an actual binding in the do-expression case. For literals, we can
777 just use the expression inline.
780 tcSyntaxName :: InstOrigin
781 -> TcType -- Type to instantiate it at
782 -> (Name, HsExpr Name) -- (Standard name, user name)
783 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
784 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
785 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
786 -- So we do not call it from lookupInst, which is called from tcSimplify
788 tcSyntaxName orig ty (std_nm, HsVar user_nm)
790 = newMethodFromName orig ty std_nm `thenM` \ id ->
791 returnM (std_nm, HsVar id)
793 tcSyntaxName orig ty (std_nm, user_nm_expr)
794 = tcLookupId std_nm `thenM` \ std_id ->
796 -- C.f. newMethodAtLoc
797 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
798 sigma1 = substTyWith [tv] [ty] tau
799 -- Actually, the "tau-type" might be a sigma-type in the
800 -- case of locally-polymorphic methods.
802 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $
804 -- Check that the user-supplied thing has the
805 -- same type as the standard one.
806 -- Tiresome jiggling because tcCheckSigma takes a located expression
807 getSrcSpanM `thenM` \ span ->
808 tcPolyExpr (L span user_nm_expr) sigma1 `thenM` \ expr ->
809 returnM (std_nm, unLoc expr)
811 syntaxNameCtxt name orig ty tidy_env
812 = getInstLoc orig `thenM` \ inst_loc ->
814 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
815 ptext SLIT("(needed by a syntactic construct)"),
816 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
817 nest 2 (pprInstLoc inst_loc)]
819 returnM (tidy_env, msg)