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 isLinearInst, linearInstType, 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 ExprCoFn(..), (<.>), mkCoTyApps, idCoercion,
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, isLinearPred,
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
193 isLinearInst :: Inst -> Bool
194 isLinearInst (Dict _ pred _) = isLinearPred pred
195 isLinearInst other = False
196 -- We never build Method Insts that have
197 -- linear implicit paramters in them.
198 -- Hence no need to look for Methods
201 linearInstType :: Inst -> TcType -- %x::t --> t
202 linearInstType (Dict _ (IParam _ ty) _) = ty
207 %************************************************************************
209 \subsection{Building dictionaries}
211 %************************************************************************
213 -- newDictBndrs makes a dictionary at a binding site
214 -- instCall makes a dictionary at an occurrence site
215 -- and throws it into the LIE
219 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
220 newDictBndrsO orig theta = do { loc <- getInstLoc orig
221 ; newDictBndrs loc theta }
223 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
224 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
226 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
227 newDictBndr inst_loc pred
228 = do { uniq <- newUnique
229 ; let name = mkPredName uniq (instLocSrcLoc inst_loc) pred
230 ; return (Dict name pred inst_loc) }
233 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM ExprCoFn
234 -- Instantiate the constraints of a call
235 -- (instCall o tys theta)
236 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
237 -- (b) Throws these dictionaries into the LIE
238 -- (c) Eeturns an ExprCoFn ([.] tys dicts)
240 instCall orig tys theta
241 = do { loc <- getInstLoc orig
242 ; (dicts, dict_app) <- instCallDicts loc theta
244 ; return (dict_app <.> mkCoTyApps tys) }
247 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
248 -- Similar to instCall, but only emit the constraints in the LIE
249 -- Used exclusively for the 'stupid theta' of a data constructor
250 instStupidTheta orig theta
251 = do { loc <- getInstLoc orig
252 ; (dicts, _) <- instCallDicts loc theta
256 instCallDicts :: InstLoc -> TcThetaType -> TcM ([Inst], ExprCoFn)
257 -- This is the key place where equality predicates
258 -- are unleashed into the world
259 instCallDicts loc [] = return ([], idCoercion)
261 instCallDicts loc (EqPred ty1 ty2 : preds)
262 = do { unifyType ty1 ty2 -- For now, we insist that they unify right away
263 -- Later on, when we do associated types,
264 -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
265 ; (dicts, co_fn) <- instCallDicts loc preds
266 ; return (dicts, co_fn <.> CoTyApp ty1) }
267 -- We use type application to apply the function to the
268 -- coercion; here ty1 *is* the appropriate identity coercion
270 instCallDicts loc (pred : preds)
271 = do { uniq <- newUnique
272 ; let name = mkPredName uniq (instLocSrcLoc loc) pred
273 dict = Dict name pred loc
274 ; (dicts, co_fn) <- instCallDicts loc preds
275 ; return (dict:dicts, co_fn <.> CoApp (instToId dict)) }
278 cloneDict :: Inst -> TcM Inst -- Only used for linear implicit params
279 cloneDict (Dict nm ty loc) = newUnique `thenM` \ uniq ->
280 returnM (Dict (setNameUnique nm uniq) ty loc)
282 -- For vanilla implicit parameters, there is only one in scope
283 -- at any time, so we used to use the name of the implicit parameter itself
284 -- But with splittable implicit parameters there may be many in
285 -- scope, so we make up a new namea.
286 newIPDict :: InstOrigin -> IPName Name -> Type
287 -> TcM (IPName Id, Inst)
288 newIPDict orig ip_name ty
289 = getInstLoc orig `thenM` \ inst_loc ->
290 newUnique `thenM` \ uniq ->
292 pred = IParam ip_name ty
293 name = mkPredName uniq (instLocSrcLoc inst_loc) pred
294 dict = Dict name pred inst_loc
296 returnM (mapIPName (\n -> instToId dict) ip_name, dict)
301 %************************************************************************
303 \subsection{Building methods (calls of overloaded functions)}
305 %************************************************************************
309 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
310 newMethodFromName origin ty name
311 = tcLookupId name `thenM` \ id ->
312 -- Use tcLookupId not tcLookupGlobalId; the method is almost
313 -- always a class op, but with -fno-implicit-prelude GHC is
314 -- meant to find whatever thing is in scope, and that may
315 -- be an ordinary function.
316 getInstLoc origin `thenM` \ loc ->
317 tcInstClassOp loc id [ty] `thenM` \ inst ->
318 extendLIE inst `thenM_`
319 returnM (instToId inst)
321 newMethodWithGivenTy orig id tys
322 = getInstLoc orig `thenM` \ loc ->
323 newMethod loc id tys `thenM` \ inst ->
324 extendLIE inst `thenM_`
325 returnM (instToId inst)
327 --------------------------------------------
328 -- tcInstClassOp, and newMethod do *not* drop the
329 -- Inst into the LIE; they just returns the Inst
330 -- This is important because they are used by TcSimplify
333 -- NB: the kind of the type variable to be instantiated
334 -- might be a sub-kind of the type to which it is applied,
335 -- notably when the latter is a type variable of kind ??
336 -- Hence the call to checkKind
337 -- A worry: is this needed anywhere else?
338 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
339 tcInstClassOp inst_loc sel_id tys
341 (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
343 zipWithM_ checkKind tyvars tys `thenM_`
344 newMethod inst_loc sel_id tys
346 checkKind :: TyVar -> TcType -> TcM ()
347 -- Ensure that the type has a sub-kind of the tyvar
350 -- ty1 <- zonkTcType ty
351 ; if typeKind ty1 `isSubKind` tyVarKind tv
355 pprPanic "checkKind: adding kind constraint"
356 (vcat [ppr tv <+> ppr (tyVarKind tv),
357 ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
359 -- do { tv1 <- tcInstTyVar tv
360 -- ; unifyType ty1 (mkTyVarTy tv1) } }
363 ---------------------------
364 newMethod inst_loc id tys
365 = newUnique `thenM` \ new_uniq ->
367 (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
368 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
369 inst = Method meth_id id tys theta inst_loc
370 loc = instLocSrcLoc inst_loc
376 shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
378 | isIntTy ty && inIntRange i -- Short cut for Int
379 = Just (HsLit (HsInt i))
380 | isIntegerTy ty -- Short cut for Integer
381 = Just (HsLit (HsInteger i ty))
382 | otherwise = Nothing
384 shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
387 = Just (mk_lit floatDataCon (HsFloatPrim f))
389 = Just (mk_lit doubleDataCon (HsDoublePrim f))
390 | otherwise = Nothing
392 mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
394 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
396 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
397 getSrcSpanM `thenM` \ span ->
398 returnM (L span $ HsLit (HsInteger i integer_ty))
400 mkRatLit :: Rational -> TcM (LHsExpr TcId)
402 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
403 getSrcSpanM `thenM` \ span ->
404 returnM (L span $ HsLit (HsRat r rat_ty))
406 isHsVar :: HsExpr Name -> Name -> Bool
407 isHsVar (HsVar f) g = f==g
408 isHsVar other g = False
412 %************************************************************************
416 %************************************************************************
418 Zonking makes sure that the instance types are fully zonked.
421 zonkInst :: Inst -> TcM Inst
422 zonkInst (Dict name pred loc)
423 = zonkTcPredType pred `thenM` \ new_pred ->
424 returnM (Dict name new_pred loc)
426 zonkInst (Method m id tys theta loc)
427 = zonkId id `thenM` \ new_id ->
428 -- Essential to zonk the id in case it's a local variable
429 -- Can't use zonkIdOcc because the id might itself be
430 -- an InstId, in which case it won't be in scope
432 zonkTcTypes tys `thenM` \ new_tys ->
433 zonkTcThetaType theta `thenM` \ new_theta ->
434 returnM (Method m new_id new_tys new_theta loc)
436 zonkInst (LitInst nm lit ty loc)
437 = zonkTcType ty `thenM` \ new_ty ->
438 returnM (LitInst nm lit new_ty loc)
440 zonkInsts insts = mappM zonkInst insts
444 %************************************************************************
446 \subsection{Printing}
448 %************************************************************************
450 ToDo: improve these pretty-printing things. The ``origin'' is really only
451 relevant in error messages.
454 instance Outputable Inst where
455 ppr inst = pprInst inst
457 pprDictsTheta :: [Inst] -> SDoc
458 -- Print in type-like fashion (Eq a, Show b)
459 pprDictsTheta dicts = pprTheta (map dictPred dicts)
461 pprDictsInFull :: [Inst] -> SDoc
462 -- Print in type-like fashion, but with source location
464 = vcat (map go dicts)
466 go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))]
468 pprInsts :: [Inst] -> SDoc
469 -- Debugging: print the evidence :: type
470 pprInsts insts = brackets (interpp'SP insts)
472 pprInst, pprInstInFull :: Inst -> SDoc
473 -- Debugging: print the evidence :: type
474 pprInst (LitInst nm lit ty loc) = ppr nm <+> dcolon <+> ppr ty
475 pprInst (Dict nm pred loc) = ppr nm <+> dcolon <+> pprPred pred
477 pprInst m@(Method inst_id id tys theta loc)
478 = ppr inst_id <+> dcolon <+>
479 braces (sep [ppr id <+> ptext SLIT("at"),
480 brackets (sep (map pprParendType tys))])
483 = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
485 tidyInst :: TidyEnv -> Inst -> Inst
486 tidyInst env (LitInst nm lit ty loc) = LitInst nm lit (tidyType env ty) loc
487 tidyInst env (Dict nm pred loc) = Dict nm (tidyPred env pred) loc
488 tidyInst env (Method u id tys theta loc) = Method u id (tidyTypes env tys) theta loc
490 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
491 -- This function doesn't assume that the tyvars are in scope
492 -- so it works like tidyOpenType, returning a TidyEnv
493 tidyMoreInsts env insts
494 = (env', map (tidyInst env') insts)
496 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
498 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
499 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
501 showLIE :: SDoc -> TcM () -- Debugging
503 = do { lie_var <- getLIEVar ;
504 lie <- readMutVar lie_var ;
505 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
509 %************************************************************************
511 Extending the instance environment
513 %************************************************************************
516 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
517 -- Add new locally-defined instances
518 tcExtendLocalInstEnv dfuns thing_inside
519 = do { traceDFuns dfuns
521 ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
522 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
523 tcg_inst_env = inst_env' }
524 ; setGblEnv env' thing_inside }
526 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
527 -- Check that the proposed new instance is OK,
528 -- and then add it to the home inst env
529 addLocalInst home_ie ispec
530 = do { -- Instantiate the dfun type so that we extend the instance
531 -- envt with completely fresh template variables
532 -- This is important because the template variables must
533 -- not overlap with anything in the things being looked up
534 -- (since we do unification).
535 -- We use tcInstSkolType because we don't want to allocate fresh
536 -- *meta* type variables.
537 let dfun = instanceDFunId ispec
538 ; (tvs', theta', tau') <- tcInstSkolType (InstSkol dfun) (idType dfun)
539 ; let (cls, tys') = tcSplitDFunHead tau'
540 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
541 ispec' = setInstanceDFunId ispec dfun'
543 -- Load imported instances, so that we report
544 -- duplicates correctly
546 ; let inst_envs = (eps_inst_env eps, home_ie)
548 -- Check functional dependencies
549 ; case checkFunDeps inst_envs ispec' of
550 Just specs -> funDepErr ispec' specs
553 -- Check for duplicate instance decls
554 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
555 ; dup_ispecs = [ dup_ispec
556 | (_, dup_ispec) <- matches
557 , let (_,_,_,dup_tys) = instanceHead dup_ispec
558 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
559 -- Find memebers of the match list which ispec itself matches.
560 -- If the match is 2-way, it's a duplicate
562 dup_ispec : _ -> dupInstErr ispec' dup_ispec
565 -- OK, now extend the envt
566 ; return (extendInstEnv home_ie ispec') }
568 getOverlapFlag :: TcM OverlapFlag
570 = do { dflags <- getDOpts
571 ; let overlap_ok = dopt Opt_AllowOverlappingInstances dflags
572 incoherent_ok = dopt Opt_AllowIncoherentInstances dflags
573 overlap_flag | incoherent_ok = Incoherent
574 | overlap_ok = OverlapOk
575 | otherwise = NoOverlap
577 ; return overlap_flag }
580 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
582 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
583 -- Print the dfun name itself too
585 funDepErr ispec ispecs
587 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
588 2 (pprInstances (ispec:ispecs)))
589 dupInstErr ispec dup_ispec
591 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
592 2 (pprInstances [ispec, dup_ispec]))
594 addDictLoc ispec thing_inside
595 = setSrcSpan (mkSrcSpan loc loc) thing_inside
597 loc = getSrcLoc ispec
601 %************************************************************************
603 \subsection{Looking up Insts}
605 %************************************************************************
608 data LookupInstResult
610 | SimpleInst (LHsExpr TcId) -- Just a variable, type application, or literal
611 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
613 lookupInst :: Inst -> TcM LookupInstResult
614 -- It's important that lookupInst does not put any new stuff into
615 -- the LIE. Instead, any Insts needed by the lookup are returned in
616 -- the LookupInstResult, where they can be further processed by tcSimplify
621 lookupInst inst@(Method _ id tys theta loc)
622 = do { (dicts, dict_app) <- instCallDicts loc theta
623 ; let co_fn = dict_app <.> mkCoTyApps tys
624 ; return (GenInst dicts (L span $ HsCoerce co_fn (HsVar id))) }
626 span = instLocSrcSpan loc
630 -- Look for short cuts first: if the literal is *definitely* a
631 -- int, integer, float or a double, generate the real thing here.
632 -- This is essential (see nofib/spectral/nucleic).
633 -- [Same shortcut as in newOverloadedLit, but we
634 -- may have done some unification by now]
636 lookupInst inst@(LitInst _nm (HsIntegral i from_integer_name) ty loc)
637 | Just expr <- shortCutIntLit i ty
638 = returnM (GenInst [] (noLoc expr)) -- GenInst, not SimpleInst, because
639 -- expr may be a constructor application
641 = ASSERT( from_integer_name `isHsVar` fromIntegerName ) -- A LitInst invariant
642 tcLookupId fromIntegerName `thenM` \ from_integer ->
643 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
644 mkIntegerLit i `thenM` \ integer_lit ->
645 returnM (GenInst [method_inst]
646 (mkHsApp (L (instLocSrcSpan loc)
647 (HsVar (instToId method_inst))) integer_lit))
649 lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc)
650 | Just expr <- shortCutFracLit f ty
651 = returnM (GenInst [] (noLoc expr))
654 = ASSERT( from_rat_name `isHsVar` fromRationalName ) -- A LitInst invariant
655 tcLookupId fromRationalName `thenM` \ from_rational ->
656 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
657 mkRatLit f `thenM` \ rat_lit ->
658 returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc)
659 (HsVar (instToId method_inst))) rat_lit))
662 lookupInst (Dict _ pred loc)
663 = do { mb_result <- lookupPred pred
664 ; case mb_result of {
665 Nothing -> return NoInstance ;
666 Just (tenv, dfun_id) -> do
668 -- tenv is a substitution that instantiates the dfun_id
669 -- to match the requested result type.
671 -- We ASSUME that the dfun is quantified over the very same tyvars
672 -- that are bound by the tenv.
675 -- might have some tyvars that *only* appear in arguments
676 -- dfun :: forall a b. C a b, Ord b => D [a]
677 -- We instantiate b to a flexi type variable -- it'll presumably
678 -- become fixed later via functional dependencies
679 { use_stage <- getStage
680 ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
681 (topIdLvl dfun_id) use_stage
683 -- It's possible that not all the tyvars are in
684 -- the substitution, tenv. For example:
685 -- instance C X a => D X where ...
686 -- (presumably there's a functional dependency in class C)
687 -- Hence the open_tvs to instantiate any un-substituted tyvars.
688 ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
689 open_tvs = filter (`notElemTvSubst` tenv) tyvars
690 ; open_tvs' <- mappM tcInstTyVar open_tvs
692 tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
693 -- Since the open_tvs' are freshly made, they cannot possibly be captured by
694 -- any nested for-alls in rho. So the in-scope set is unchanged
695 dfun_rho = substTy tenv' rho
696 (theta, _) = tcSplitPhiTy dfun_rho
697 src_loc = instLocSrcSpan loc
699 tys = map (substTyVar tenv') tyvars
701 returnM (SimpleInst (L src_loc $ HsCoerce (mkCoTyApps tys) dfun))
703 { (dicts, dict_app) <- instCallDicts loc theta
704 ; let co_fn = dict_app <.> mkCoTyApps tys
705 ; returnM (GenInst dicts (L src_loc $ HsCoerce co_fn dfun))
709 lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
710 -- Look up a class constraint in the instance environment
711 lookupPred pred@(ClassP clas tys)
713 ; tcg_env <- getGblEnv
714 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
715 ; case lookupInstEnv inst_envs clas tys of {
716 ([(tenv, ispec)], [])
717 -> do { let dfun_id = is_dfun ispec
718 ; traceTc (text "lookupInst success" <+>
719 vcat [text "dict" <+> ppr pred,
720 text "witness" <+> ppr dfun_id
721 <+> ppr (idType dfun_id) ])
722 -- Record that this dfun is needed
723 ; record_dfun_usage dfun_id
724 ; return (Just (tenv, dfun_id)) } ;
727 -> do { traceTc (text "lookupInst fail" <+>
728 vcat [text "dict" <+> ppr pred,
729 text "matches" <+> ppr matches,
730 text "unifs" <+> ppr unifs])
731 -- In the case of overlap (multiple matches) we report
732 -- NoInstance here. That has the effect of making the
733 -- context-simplifier return the dict as an irreducible one.
734 -- Then it'll be given to addNoInstanceErrs, which will do another
735 -- lookupInstEnv to get the detailed info about what went wrong.
739 lookupPred ip_pred = return Nothing
741 record_dfun_usage dfun_id
742 = do { hsc_env <- getTopEnv
743 ; let dfun_name = idName dfun_id
744 dfun_mod = nameModule dfun_name
745 ; if isInternalName dfun_name || -- Internal name => defined in this module
746 modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
747 then return () -- internal, or in another package
748 else do { tcg_env <- getGblEnv
749 ; updMutVar (tcg_inst_uses tcg_env)
750 (`addOneToNameSet` idName dfun_id) }}
753 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
754 -- Gets both the external-package inst-env
755 -- and the home-pkg inst env (includes module being compiled)
756 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
757 return (eps_inst_env eps, tcg_inst_env env) }
762 %************************************************************************
766 %************************************************************************
768 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
769 a do-expression. We have to find (>>) in the current environment, which is
770 done by the rename. Then we have to check that it has the same type as
771 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
774 (>>) :: HB m n mn => m a -> n b -> mn b
776 So the idea is to generate a local binding for (>>), thus:
778 let then72 :: forall a b. m a -> m b -> m b
779 then72 = ...something involving the user's (>>)...
781 ...the do-expression...
783 Now the do-expression can proceed using then72, which has exactly
786 In fact tcSyntaxName just generates the RHS for then72, because we only
787 want an actual binding in the do-expression case. For literals, we can
788 just use the expression inline.
791 tcSyntaxName :: InstOrigin
792 -> TcType -- Type to instantiate it at
793 -> (Name, HsExpr Name) -- (Standard name, user name)
794 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
795 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
796 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
797 -- So we do not call it from lookupInst, which is called from tcSimplify
799 tcSyntaxName orig ty (std_nm, HsVar user_nm)
801 = newMethodFromName orig ty std_nm `thenM` \ id ->
802 returnM (std_nm, HsVar id)
804 tcSyntaxName orig ty (std_nm, user_nm_expr)
805 = tcLookupId std_nm `thenM` \ std_id ->
807 -- C.f. newMethodAtLoc
808 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
809 sigma1 = substTyWith [tv] [ty] tau
810 -- Actually, the "tau-type" might be a sigma-type in the
811 -- case of locally-polymorphic methods.
813 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $
815 -- Check that the user-supplied thing has the
816 -- same type as the standard one.
817 -- Tiresome jiggling because tcCheckSigma takes a located expression
818 getSrcSpanM `thenM` \ span ->
819 tcPolyExpr (L span user_nm_expr) sigma1 `thenM` \ expr ->
820 returnM (std_nm, unLoc expr)
822 syntaxNameCtxt name orig ty tidy_env
823 = getInstLoc orig `thenM` \ inst_loc ->
825 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
826 ptext SLIT("(needed by a syntactic construct)"),
827 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
828 nest 2 (pprInstLoc inst_loc)]
830 returnM (tidy_env, msg)