2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 The @Inst@ type: dictionaries or method instances
12 pprInstances, pprDictsTheta, pprDictsInFull, -- User error messages
13 showLIE, pprInst, pprInsts, pprInstInFull, -- Debugging messages
15 tidyInsts, tidyMoreInsts,
17 newDictBndr, newDictBndrs, newDictBndrsO,
18 instCall, instStupidTheta,
20 shortCutFracLit, shortCutIntLit, newIPDict,
21 newMethod, newMethodFromName, newMethodWithGivenTy,
23 tcSyntaxName, isHsVar,
25 tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
26 ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
27 instLoc, getDictClassTys, dictPred,
29 lookupInst, LookupInstResult(..), lookupPred,
30 tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
32 isDict, isClassDict, isMethod,
33 isIPDict, isInheritableInst,
34 isTyVarDict, isMethodFor,
37 instToId, instToVar, instName,
39 InstOrigin(..), InstLoc(..), pprInstLoc
42 #include "HsVersions.h"
44 import {-# SOURCE #-} TcExpr( tcPolyExpr )
45 import {-# SOURCE #-} TcUnify( unifyType )
66 import Var ( Var, TyVar )
83 instName :: Inst -> Name
84 instName inst = idName (instToId inst)
86 instToId :: Inst -> TcId
87 instToId inst = ASSERT2( isId id, ppr inst ) id
91 instToVar :: Inst -> Var
92 instToVar (LitInst {tci_name = nm, tci_ty = ty})
94 instToVar (Method {tci_id = id})
96 instToVar (Dict {tci_name = nm, tci_pred = pred})
97 | isEqPred pred = Var.mkCoVar nm (mkPredTy pred)
98 | otherwise = mkLocalId nm (mkPredTy pred)
100 instLoc inst = tci_loc inst
102 dictPred (Dict {tci_pred = pred}) = pred
103 dictPred inst = pprPanic "dictPred" (ppr inst)
105 getDictClassTys (Dict {tci_pred = pred}) = getClassPredTys pred
106 getDictClassTys inst = pprPanic "getDictClassTys" (ppr inst)
108 -- fdPredsOfInst is used to get predicates that contain functional
109 -- dependencies *or* might do so. The "might do" part is because
110 -- a constraint (C a b) might have a superclass with FDs
111 -- Leaving these in is really important for the call to fdPredsOfInsts
112 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
113 -- which is supposed to be conservative
114 fdPredsOfInst (Dict {tci_pred = pred}) = [pred]
115 fdPredsOfInst (Method {tci_theta = theta}) = theta
116 fdPredsOfInst other = [] -- LitInsts etc
118 fdPredsOfInsts :: [Inst] -> [PredType]
119 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
121 isInheritableInst (Dict {tci_pred = pred}) = isInheritablePred pred
122 isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta
123 isInheritableInst other = True
126 ipNamesOfInsts :: [Inst] -> [Name]
127 ipNamesOfInst :: Inst -> [Name]
128 -- Get the implicit parameters mentioned by these Insts
129 -- NB: ?x and %x get different Names
130 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
132 ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
133 ipNamesOfInst (Method {tci_theta = theta}) = [ipNameName n | IParam n _ <- theta]
134 ipNamesOfInst other = []
136 tyVarsOfInst :: Inst -> TcTyVarSet
137 tyVarsOfInst (LitInst {tci_ty = ty}) = tyVarsOfType ty
138 tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
139 tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
140 -- The id might have free type variables; in the case of
141 -- locally-overloaded class methods, for example
144 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
145 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
151 isDict :: Inst -> Bool
152 isDict (Dict {}) = True
155 isClassDict :: Inst -> Bool
156 isClassDict (Dict {tci_pred = pred}) = isClassPred pred
157 isClassDict other = False
159 isTyVarDict :: Inst -> Bool
160 isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
161 isTyVarDict other = False
163 isIPDict :: Inst -> Bool
164 isIPDict (Dict {tci_pred = pred}) = isIPPred pred
165 isIPDict other = False
167 isMethod :: Inst -> Bool
168 isMethod (Method {}) = True
169 isMethod other = False
171 isMethodFor :: TcIdSet -> Inst -> Bool
172 isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
173 isMethodFor ids inst = False
178 %************************************************************************
180 \subsection{Building dictionaries}
182 %************************************************************************
184 -- newDictBndrs makes a dictionary at a binding site
185 -- instCall makes a dictionary at an occurrence site
186 -- and throws it into the LIE
190 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
191 newDictBndrsO orig theta = do { loc <- getInstLoc orig
192 ; newDictBndrs loc theta }
194 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
195 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
197 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
198 newDictBndr inst_loc pred
199 = do { uniq <- newUnique
200 ; let name = mkPredName uniq (instLocSrcLoc inst_loc) pred
201 ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
204 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
205 -- Instantiate the constraints of a call
206 -- (instCall o tys theta)
207 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
208 -- (b) Throws these dictionaries into the LIE
209 -- (c) Eeturns an HsWrapper ([.] tys dicts)
211 instCall orig tys theta
212 = do { loc <- getInstLoc orig
213 ; (dicts, dict_app) <- instCallDicts loc theta
215 ; return (dict_app <.> mkWpTyApps tys) }
218 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
219 -- Similar to instCall, but only emit the constraints in the LIE
220 -- Used exclusively for the 'stupid theta' of a data constructor
221 instStupidTheta orig theta
222 = do { loc <- getInstLoc orig
223 ; (dicts, _) <- instCallDicts loc theta
227 instCallDicts :: InstLoc -> TcThetaType -> TcM ([Inst], HsWrapper)
228 -- This is the key place where equality predicates
229 -- are unleashed into the world
230 instCallDicts loc [] = return ([], idHsWrapper)
232 instCallDicts loc (EqPred ty1 ty2 : preds)
233 = do { unifyType ty1 ty2 -- For now, we insist that they unify right away
234 -- Later on, when we do associated types,
235 -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
236 ; (dicts, co_fn) <- instCallDicts loc preds
237 ; return (dicts, co_fn <.> WpTyApp ty1) }
238 -- We use type application to apply the function to the
239 -- coercion; here ty1 *is* the appropriate identity coercion
241 instCallDicts loc (pred : preds)
242 = do { uniq <- newUnique
243 ; let name = mkPredName uniq (instLocSrcLoc loc) pred
244 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
245 ; (dicts, co_fn) <- instCallDicts loc preds
246 ; return (dict:dicts, co_fn <.> WpApp (instToId dict)) }
249 cloneDict :: Inst -> TcM Inst -- Only used for linear implicit params
250 cloneDict dict@(Dict nm ty loc) = do { uniq <- newUnique
251 ; return (dict {tci_name = setNameUnique nm uniq}) }
252 cloneDict other = pprPanic "cloneDict" (ppr other)
254 -- For vanilla implicit parameters, there is only one in scope
255 -- at any time, so we used to use the name of the implicit parameter itself
256 -- But with splittable implicit parameters there may be many in
257 -- scope, so we make up a new namea.
258 newIPDict :: InstOrigin -> IPName Name -> Type
259 -> TcM (IPName Id, Inst)
260 newIPDict orig ip_name ty
261 = getInstLoc orig `thenM` \ inst_loc ->
262 newUnique `thenM` \ uniq ->
264 pred = IParam ip_name ty
265 name = mkPredName uniq (instLocSrcLoc inst_loc) pred
266 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}
268 returnM (mapIPName (\n -> instToId dict) ip_name, dict)
273 %************************************************************************
275 \subsection{Building methods (calls of overloaded functions)}
277 %************************************************************************
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` Var.tyVarKind tv
327 pprPanic "checkKind: adding kind constraint"
328 (vcat [ppr tv <+> ppr (Var.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 {tci_id = meth_id, tci_oid = id, tci_tys = tys,
342 tci_theta = theta, tci_loc = 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@(Dict { tci_pred = pred})
396 = zonkTcPredType pred `thenM` \ new_pred ->
397 returnM (dict {tci_pred = new_pred})
399 zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta})
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 (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
408 -- No need to zonk the tci_id
410 zonkInst lit@(LitInst {tci_ty = ty})
411 = zonkTcType ty `thenM` \ new_ty ->
412 returnM (lit {tci_ty = new_ty})
414 zonkInsts insts = mappM zonkInst insts
418 %************************************************************************
420 \subsection{Printing}
422 %************************************************************************
424 ToDo: improve these pretty-printing things. The ``origin'' is really only
425 relevant in error messages.
428 instance Outputable Inst where
429 ppr inst = pprInst inst
431 pprDictsTheta :: [Inst] -> SDoc
432 -- Print in type-like fashion (Eq a, Show b)
433 pprDictsTheta dicts = pprTheta (map dictPred dicts)
435 pprDictsInFull :: [Inst] -> SDoc
436 -- Print in type-like fashion, but with source location
438 = vcat (map go dicts)
440 go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))]
442 pprInsts :: [Inst] -> SDoc
443 -- Debugging: print the evidence :: type
444 pprInsts insts = brackets (interpp'SP insts)
446 pprInst, pprInstInFull :: Inst -> SDoc
447 -- Debugging: print the evidence :: type
448 pprInst (LitInst {tci_name = nm, tci_ty = ty}) = ppr nm <+> dcolon <+> ppr ty
449 pprInst (Dict {tci_name = nm, tci_pred = pred}) = ppr nm <+> dcolon <+> pprPred pred
451 pprInst (Method {tci_id = inst_id, tci_oid = id, tci_tys = tys})
452 = ppr inst_id <+> dcolon <+>
453 braces (sep [ppr id <+> ptext SLIT("at"),
454 brackets (sep (map pprParendType tys))])
457 = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
459 tidyInst :: TidyEnv -> Inst -> Inst
460 tidyInst env lit@(LitInst {tci_ty = ty}) = lit {tci_ty = tidyType env ty}
461 tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
462 tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
464 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
465 -- This function doesn't assume that the tyvars are in scope
466 -- so it works like tidyOpenType, returning a TidyEnv
467 tidyMoreInsts env insts
468 = (env', map (tidyInst env') insts)
470 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
472 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
473 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
475 showLIE :: SDoc -> TcM () -- Debugging
477 = do { lie_var <- getLIEVar ;
478 lie <- readMutVar lie_var ;
479 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
483 %************************************************************************
485 Extending the instance environment
487 %************************************************************************
490 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
491 -- Add new locally-defined instances
492 tcExtendLocalInstEnv dfuns thing_inside
493 = do { traceDFuns dfuns
495 ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
496 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
497 tcg_inst_env = inst_env' }
498 ; setGblEnv env' thing_inside }
500 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
501 -- Check that the proposed new instance is OK,
502 -- and then add it to the home inst env
503 addLocalInst home_ie ispec
504 = do { -- Instantiate the dfun type so that we extend the instance
505 -- envt with completely fresh template variables
506 -- This is important because the template variables must
507 -- not overlap with anything in the things being looked up
508 -- (since we do unification).
509 -- We use tcInstSkolType because we don't want to allocate fresh
510 -- *meta* type variables.
511 let dfun = instanceDFunId ispec
512 ; (tvs', theta', tau') <- tcInstSkolType (InstSkol dfun) (idType dfun)
513 ; let (cls, tys') = tcSplitDFunHead tau'
514 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
515 ispec' = setInstanceDFunId ispec dfun'
517 -- Load imported instances, so that we report
518 -- duplicates correctly
520 ; let inst_envs = (eps_inst_env eps, home_ie)
522 -- Check functional dependencies
523 ; case checkFunDeps inst_envs ispec' of
524 Just specs -> funDepErr ispec' specs
527 -- Check for duplicate instance decls
528 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
529 ; dup_ispecs = [ dup_ispec
530 | (_, dup_ispec) <- matches
531 , let (_,_,_,dup_tys) = instanceHead dup_ispec
532 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
533 -- Find memebers of the match list which ispec itself matches.
534 -- If the match is 2-way, it's a duplicate
536 dup_ispec : _ -> dupInstErr ispec' dup_ispec
539 -- OK, now extend the envt
540 ; return (extendInstEnv home_ie ispec') }
542 getOverlapFlag :: TcM OverlapFlag
544 = do { dflags <- getDOpts
545 ; let overlap_ok = dopt Opt_AllowOverlappingInstances dflags
546 incoherent_ok = dopt Opt_AllowIncoherentInstances dflags
547 overlap_flag | incoherent_ok = Incoherent
548 | overlap_ok = OverlapOk
549 | otherwise = NoOverlap
551 ; return overlap_flag }
554 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
556 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
557 -- Print the dfun name itself too
559 funDepErr ispec ispecs
561 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
562 2 (pprInstances (ispec:ispecs)))
563 dupInstErr ispec dup_ispec
565 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
566 2 (pprInstances [ispec, dup_ispec]))
568 addDictLoc ispec thing_inside
569 = setSrcSpan (mkSrcSpan loc loc) thing_inside
571 loc = getSrcLoc ispec
575 %************************************************************************
577 \subsection{Looking up Insts}
579 %************************************************************************
582 data LookupInstResult
584 | SimpleInst (LHsExpr TcId) -- Just a variable, type application, or literal
585 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
587 lookupInst :: Inst -> TcM LookupInstResult
588 -- It's important that lookupInst does not put any new stuff into
589 -- the LIE. Instead, any Insts needed by the lookup are returned in
590 -- the LookupInstResult, where they can be further processed by tcSimplify
595 lookupInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
596 = do { (dicts, dict_app) <- instCallDicts loc theta
597 ; let co_fn = dict_app <.> mkWpTyApps tys
598 ; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
600 span = instLocSrcSpan loc
604 -- Look for short cuts first: if the literal is *definitely* a
605 -- int, integer, float or a double, generate the real thing here.
606 -- This is essential (see nofib/spectral/nucleic).
607 -- [Same shortcut as in newOverloadedLit, but we
608 -- may have done some unification by now]
610 lookupInst (LitInst {tci_lit = HsIntegral i from_integer_name, tci_ty = ty, tci_loc = loc})
611 | Just expr <- shortCutIntLit i ty
612 = returnM (GenInst [] (noLoc expr)) -- GenInst, not SimpleInst, because
613 -- expr may be a constructor application
615 = ASSERT( from_integer_name `isHsVar` fromIntegerName ) -- A LitInst invariant
616 tcLookupId fromIntegerName `thenM` \ from_integer ->
617 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
618 mkIntegerLit i `thenM` \ integer_lit ->
619 returnM (GenInst [method_inst]
620 (mkHsApp (L (instLocSrcSpan loc)
621 (HsVar (instToId method_inst))) integer_lit))
623 lookupInst (LitInst {tci_lit = HsFractional f from_rat_name, tci_ty = ty, tci_loc = loc})
624 | Just expr <- shortCutFracLit f ty
625 = returnM (GenInst [] (noLoc expr))
628 = ASSERT( from_rat_name `isHsVar` fromRationalName ) -- A LitInst invariant
629 tcLookupId fromRationalName `thenM` \ from_rational ->
630 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
631 mkRatLit f `thenM` \ rat_lit ->
632 returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc)
633 (HsVar (instToId method_inst))) rat_lit))
636 lookupInst (Dict {tci_pred = pred, tci_loc = loc})
637 = do { mb_result <- lookupPred pred
638 ; case mb_result of {
639 Nothing -> return NoInstance ;
640 Just (tenv, dfun_id) -> do
642 -- tenv is a substitution that instantiates the dfun_id
643 -- to match the requested result type.
645 -- We ASSUME that the dfun is quantified over the very same tyvars
646 -- that are bound by the tenv.
649 -- might have some tyvars that *only* appear in arguments
650 -- dfun :: forall a b. C a b, Ord b => D [a]
651 -- We instantiate b to a flexi type variable -- it'll presumably
652 -- become fixed later via functional dependencies
653 { use_stage <- getStage
654 ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
655 (topIdLvl dfun_id) use_stage
657 -- It's possible that not all the tyvars are in
658 -- the substitution, tenv. For example:
659 -- instance C X a => D X where ...
660 -- (presumably there's a functional dependency in class C)
661 -- Hence the open_tvs to instantiate any un-substituted tyvars.
662 ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
663 open_tvs = filter (`notElemTvSubst` tenv) tyvars
664 ; open_tvs' <- mappM tcInstTyVar open_tvs
666 tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
667 -- Since the open_tvs' are freshly made, they cannot possibly be captured by
668 -- any nested for-alls in rho. So the in-scope set is unchanged
669 dfun_rho = substTy tenv' rho
670 (theta, _) = tcSplitPhiTy dfun_rho
671 src_loc = instLocSrcSpan loc
673 tys = map (substTyVar tenv') tyvars
675 returnM (SimpleInst (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
677 { (dicts, dict_app) <- instCallDicts loc theta
678 ; let co_fn = dict_app <.> mkWpTyApps tys
679 ; returnM (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
683 lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
684 -- Look up a class constraint in the instance environment
685 lookupPred pred@(ClassP clas tys)
687 ; tcg_env <- getGblEnv
688 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
689 ; case lookupInstEnv inst_envs clas tys of {
690 ([(tenv, ispec)], [])
691 -> do { let dfun_id = is_dfun ispec
692 ; traceTc (text "lookupInst success" <+>
693 vcat [text "dict" <+> ppr pred,
694 text "witness" <+> ppr dfun_id
695 <+> ppr (idType dfun_id) ])
696 -- Record that this dfun is needed
697 ; record_dfun_usage dfun_id
698 ; return (Just (tenv, dfun_id)) } ;
701 -> do { traceTc (text "lookupInst fail" <+>
702 vcat [text "dict" <+> ppr pred,
703 text "matches" <+> ppr matches,
704 text "unifs" <+> ppr unifs])
705 -- In the case of overlap (multiple matches) we report
706 -- NoInstance here. That has the effect of making the
707 -- context-simplifier return the dict as an irreducible one.
708 -- Then it'll be given to addNoInstanceErrs, which will do another
709 -- lookupInstEnv to get the detailed info about what went wrong.
713 lookupPred ip_pred = return Nothing
715 record_dfun_usage dfun_id
716 = do { hsc_env <- getTopEnv
717 ; let dfun_name = idName dfun_id
718 dfun_mod = nameModule dfun_name
719 ; if isInternalName dfun_name || -- Internal name => defined in this module
720 modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
721 then return () -- internal, or in another package
722 else do { tcg_env <- getGblEnv
723 ; updMutVar (tcg_inst_uses tcg_env)
724 (`addOneToNameSet` idName dfun_id) }}
727 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
728 -- Gets both the external-package inst-env
729 -- and the home-pkg inst env (includes module being compiled)
730 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
731 return (eps_inst_env eps, tcg_inst_env env) }
736 %************************************************************************
740 %************************************************************************
742 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
743 a do-expression. We have to find (>>) in the current environment, which is
744 done by the rename. Then we have to check that it has the same type as
745 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
748 (>>) :: HB m n mn => m a -> n b -> mn b
750 So the idea is to generate a local binding for (>>), thus:
752 let then72 :: forall a b. m a -> m b -> m b
753 then72 = ...something involving the user's (>>)...
755 ...the do-expression...
757 Now the do-expression can proceed using then72, which has exactly
760 In fact tcSyntaxName just generates the RHS for then72, because we only
761 want an actual binding in the do-expression case. For literals, we can
762 just use the expression inline.
765 tcSyntaxName :: InstOrigin
766 -> TcType -- Type to instantiate it at
767 -> (Name, HsExpr Name) -- (Standard name, user name)
768 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
769 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
770 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
771 -- So we do not call it from lookupInst, which is called from tcSimplify
773 tcSyntaxName orig ty (std_nm, HsVar user_nm)
775 = newMethodFromName orig ty std_nm `thenM` \ id ->
776 returnM (std_nm, HsVar id)
778 tcSyntaxName orig ty (std_nm, user_nm_expr)
779 = tcLookupId std_nm `thenM` \ std_id ->
781 -- C.f. newMethodAtLoc
782 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
783 sigma1 = substTyWith [tv] [ty] tau
784 -- Actually, the "tau-type" might be a sigma-type in the
785 -- case of locally-polymorphic methods.
787 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $
789 -- Check that the user-supplied thing has the
790 -- same type as the standard one.
791 -- Tiresome jiggling because tcCheckSigma takes a located expression
792 getSrcSpanM `thenM` \ span ->
793 tcPolyExpr (L span user_nm_expr) sigma1 `thenM` \ expr ->
794 returnM (std_nm, unLoc expr)
796 syntaxNameCtxt name orig ty tidy_env
797 = getInstLoc orig `thenM` \ inst_loc ->
799 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
800 ptext SLIT("(needed by a syntactic construct)"),
801 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
802 nest 2 (pprInstLoc inst_loc)]
804 returnM (tidy_env, msg)