2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[Inst]{The @Inst@ type: dictionaries or method instances}
10 pprDFuns, pprDictsTheta, pprDictsInFull, -- User error messages
11 showLIE, pprInst, pprInsts, pprInstInFull, -- Debugging messages
13 tidyInsts, tidyMoreInsts,
15 newDictsFromOld, newDicts, newDictsAtLoc, cloneDict,
16 newOverloadedLit, newIPDict,
17 newMethod, newMethodFromName, newMethodWithGivenTy,
18 tcInstClassOp, tcInstCall, tcInstStupidTheta,
19 tcSyntaxName, tcStdSyntaxName,
21 tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
22 ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
23 instLoc, getDictClassTys, dictPred,
25 lookupInst, LookupInstResult(..),
26 tcExtendLocalInstEnv, tcGetInstEnvs,
28 isDict, isClassDict, isMethod,
29 isLinearInst, linearInstType, isIPDict, isInheritableInst,
30 isTyVarDict, isStdClassTyVarDict, isMethodFor,
36 InstOrigin(..), InstLoc(..), pprInstLoc
39 #include "HsVersions.h"
41 import {-# SOURCE #-} TcExpr( tcCheckSigma )
42 import {-# SOURCE #-} TcUnify ( unifyTauTy ) -- Used in checkKind (sigh)
44 import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp )
45 import TcHsSyn ( TcId, TcIdSet,
46 mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId,
50 import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
51 import InstEnv ( DFunId, InstEnv, lookupInstEnv, checkFunDeps, extendInstEnv )
52 import TcIface ( loadImportedInsts )
53 import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType,
54 zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
56 import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcTyVar,
57 PredType(..), typeKind,
58 tcSplitForAllTys, tcSplitForAllTys,
59 tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy,
60 isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
61 tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
62 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
63 isClassPred, isTyVarClassPred, isLinearPred,
64 getClassPredTys, getClassPredTys_maybe, mkPredName,
65 isInheritablePred, isIPPred,
66 tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy,
67 pprPred, pprParendType, pprThetaArrow, pprTheta, pprClassPred
69 import Type ( substTy, substTys, substTyWith, substTheta, zipTopTvSubst )
70 import Unify ( matchTys )
71 import Kind ( isSubKind )
72 import HscTypes ( ExternalPackageState(..) )
73 import CoreFVs ( idFreeTyVars )
74 import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName )
75 import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
76 import PrelInfo ( isStandardClass, isNoDictClass )
77 import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, isHomePackageName, isInternalName )
78 import NameSet ( addOneToNameSet )
79 import Literal ( inIntRange )
80 import Var ( TyVar, tyVarKind )
81 import VarEnv ( TidyEnv, emptyTidyEnv, lookupVarEnv )
82 import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
83 import TysWiredIn ( floatDataCon, doubleDataCon )
84 import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
85 import BasicTypes( IPName(..), mapIPName, ipNameName )
86 import UniqSupply( uniqsFromSupply )
87 import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) )
88 import CmdLineOpts( DynFlags )
89 import Maybes ( isJust )
97 instName :: Inst -> Name
98 instName inst = idName (instToId inst)
100 instToId :: Inst -> TcId
101 instToId (Dict id _ _) = id
102 instToId (Method id _ _ _ _ _) = id
103 instToId (LitInst id _ _ _) = id
105 instLoc (Dict _ _ loc) = loc
106 instLoc (Method _ _ _ _ _ loc) = loc
107 instLoc (LitInst _ _ _ loc) = loc
109 dictPred (Dict _ pred _ ) = pred
110 dictPred inst = pprPanic "dictPred" (ppr inst)
112 getDictClassTys (Dict _ pred _) = getClassPredTys pred
114 -- fdPredsOfInst is used to get predicates that contain functional
115 -- dependencies *or* might do so. The "might do" part is because
116 -- a constraint (C a b) might have a superclass with FDs
117 -- Leaving these in is really important for the call to fdPredsOfInsts
118 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
119 -- which is supposed to be conservative
120 fdPredsOfInst (Dict _ pred _) = [pred]
121 fdPredsOfInst (Method _ _ _ theta _ _) = theta
122 fdPredsOfInst other = [] -- LitInsts etc
124 fdPredsOfInsts :: [Inst] -> [PredType]
125 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
127 isInheritableInst (Dict _ pred _) = isInheritablePred pred
128 isInheritableInst (Method _ _ _ theta _ _) = all isInheritablePred theta
129 isInheritableInst other = True
132 ipNamesOfInsts :: [Inst] -> [Name]
133 ipNamesOfInst :: Inst -> [Name]
134 -- Get the implicit parameters mentioned by these Insts
135 -- NB: ?x and %x get different Names
136 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
138 ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
139 ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
140 ipNamesOfInst other = []
142 tyVarsOfInst :: Inst -> TcTyVarSet
143 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
144 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
145 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
146 -- The id might have free type variables; in the case of
147 -- locally-overloaded class methods, for example
150 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
151 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
157 isDict :: Inst -> Bool
158 isDict (Dict _ _ _) = True
161 isClassDict :: Inst -> Bool
162 isClassDict (Dict _ pred _) = isClassPred pred
163 isClassDict other = False
165 isTyVarDict :: Inst -> Bool
166 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
167 isTyVarDict other = False
169 isIPDict :: Inst -> Bool
170 isIPDict (Dict _ pred _) = isIPPred pred
171 isIPDict other = False
173 isMethod :: Inst -> Bool
174 isMethod (Method _ _ _ _ _ _) = True
175 isMethod other = False
177 isMethodFor :: TcIdSet -> Inst -> Bool
178 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
179 isMethodFor ids inst = False
181 isLinearInst :: Inst -> Bool
182 isLinearInst (Dict _ pred _) = isLinearPred pred
183 isLinearInst other = False
184 -- We never build Method Insts that have
185 -- linear implicit paramters in them.
186 -- Hence no need to look for Methods
189 linearInstType :: Inst -> TcType -- %x::t --> t
190 linearInstType (Dict _ (IParam _ ty) _) = ty
193 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
194 Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
198 Two predicates which deal with the case where class constraints don't
199 necessarily result in bindings. The first tells whether an @Inst@
200 must be witnessed by an actual binding; the second tells whether an
201 @Inst@ can be generalised over.
204 instBindingRequired :: Inst -> Bool
205 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
206 instBindingRequired other = True
210 %************************************************************************
212 \subsection{Building dictionaries}
214 %************************************************************************
217 newDicts :: InstOrigin
221 = getInstLoc orig `thenM` \ loc ->
222 newDictsAtLoc loc theta
224 cloneDict :: Inst -> TcM Inst
225 cloneDict (Dict id ty loc) = newUnique `thenM` \ uniq ->
226 returnM (Dict (setIdUnique id uniq) ty loc)
228 newDictsFromOld :: Inst -> TcThetaType -> TcM [Inst]
229 newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
231 -- Local function, similar to newDicts,
232 -- but with slightly different interface
233 newDictsAtLoc :: InstLoc
236 newDictsAtLoc inst_loc theta
237 = newUniqueSupply `thenM` \ us ->
238 returnM (zipWith mk_dict (uniqsFromSupply us) theta)
240 mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred))
242 loc = instLocSrcLoc inst_loc
244 -- For vanilla implicit parameters, there is only one in scope
245 -- at any time, so we used to use the name of the implicit parameter itself
246 -- But with splittable implicit parameters there may be many in
247 -- scope, so we make up a new name.
248 newIPDict :: InstOrigin -> IPName Name -> Type
249 -> TcM (IPName Id, Inst)
250 newIPDict orig ip_name ty
251 = getInstLoc orig `thenM` \ inst_loc ->
252 newUnique `thenM` \ uniq ->
254 pred = IParam ip_name ty
255 name = mkPredName uniq (instLocSrcLoc inst_loc) pred
256 id = mkLocalId name (mkPredTy pred)
258 returnM (mapIPName (\n -> id) ip_name, Dict id pred inst_loc)
263 %************************************************************************
265 \subsection{Building methods (calls of overloaded functions)}
267 %************************************************************************
271 tcInstCall :: InstOrigin -> TcType -> TcM (ExprCoFn, [TcTyVar], TcType)
272 tcInstCall orig fun_ty -- fun_ty is usually a sigma-type
273 = do { (tyvars, theta, tau) <- tcInstType fun_ty
274 ; dicts <- newDicts orig theta
276 ; let inst_fn e = unLoc (mkHsDictApp (mkHsTyApp (noLoc e) (mkTyVarTys tyvars))
277 (map instToId dicts))
278 ; return (mkCoercion inst_fn, tyvars, tau) }
280 tcInstStupidTheta :: DataCon -> [TcType] -> TcM ()
281 -- Instantiate the "stupid theta" of the data con, and throw
282 -- the constraints into the constraint set
283 tcInstStupidTheta data_con inst_tys
287 = do { stupid_dicts <- newDicts (OccurrenceOf (dataConName data_con))
288 (substTheta tenv stupid_theta)
289 ; extendLIEs stupid_dicts }
291 stupid_theta = dataConStupidTheta data_con
292 tenv = zipTopTvSubst (dataConTyVars data_con) inst_tys
294 newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId
295 newMethodFromName origin ty name
296 = tcLookupId name `thenM` \ id ->
297 -- Use tcLookupId not tcLookupGlobalId; the method is almost
298 -- always a class op, but with -fno-implicit-prelude GHC is
299 -- meant to find whatever thing is in scope, and that may
300 -- be an ordinary function.
301 getInstLoc origin `thenM` \ loc ->
302 tcInstClassOp loc id [ty] `thenM` \ inst ->
303 extendLIE inst `thenM_`
304 returnM (instToId inst)
306 newMethodWithGivenTy orig id tys theta tau
307 = getInstLoc orig `thenM` \ loc ->
308 newMethod loc id tys theta tau `thenM` \ inst ->
309 extendLIE inst `thenM_`
310 returnM (instToId inst)
312 --------------------------------------------
313 -- tcInstClassOp, and newMethod do *not* drop the
314 -- Inst into the LIE; they just returns the Inst
315 -- This is important because they are used by TcSimplify
318 -- NB: the kind of the type variable to be instantiated
319 -- might be a sub-kind of the type to which it is applied,
320 -- notably when the latter is a type variable of kind ??
321 -- Hence the call to checkKind
322 -- A worry: is this needed anywhere else?
323 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
324 tcInstClassOp inst_loc sel_id tys
326 (tyvars,rho) = tcSplitForAllTys (idType sel_id)
327 rho_ty = ASSERT( length tyvars == length tys )
328 substTyWith tyvars tys rho
329 (preds,tau) = tcSplitPhiTy rho_ty
331 zipWithM_ checkKind tyvars tys `thenM_`
332 newMethod inst_loc sel_id tys preds tau
334 checkKind :: TyVar -> TcType -> TcM ()
335 -- Ensure that the type has a sub-kind of the tyvar
337 = do { ty1 <- zonkTcType ty
338 ; if typeKind ty1 `isSubKind` tyVarKind tv
341 { traceTc (text "checkKind: adding kind constraint" <+> ppr tv <+> ppr ty)
342 ; tv1 <- tcInstTyVar tv
343 ; unifyTauTy (mkTyVarTy tv1) ty1 }}
346 ---------------------------
347 newMethod inst_loc id tys theta tau
348 = newUnique `thenM` \ new_uniq ->
350 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
351 inst = Method meth_id id tys theta tau inst_loc
352 loc = instLocSrcLoc inst_loc
357 In newOverloadedLit we convert directly to an Int or Integer if we
358 know that's what we want. This may save some time, by not
359 temporarily generating overloaded literals, but it won't catch all
360 cases (the rest are caught in lookupInst).
363 newOverloadedLit :: InstOrigin
366 -> TcM (LHsExpr TcId)
367 newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
368 | fi /= fromIntegerName -- Do not generate a LitInst for rebindable syntax.
369 -- Reason: tcSyntaxName does unification
370 -- which is very inconvenient in tcSimplify
371 -- ToDo: noLoc sadness
372 = tcSyntaxName orig expected_ty (fromIntegerName, HsVar fi) `thenM` \ (_,expr) ->
373 mkIntegerLit i `thenM` \ integer_lit ->
374 returnM (mkHsApp (noLoc expr) integer_lit)
375 -- The mkHsApp will get the loc from the literal
376 | Just expr <- shortCutIntLit i expected_ty
380 = newLitInst orig lit expected_ty
382 newOverloadedLit orig lit@(HsFractional r fr) expected_ty
383 | fr /= fromRationalName -- c.f. HsIntegral case
384 = tcSyntaxName orig expected_ty (fromRationalName, HsVar fr) `thenM` \ (_,expr) ->
385 mkRatLit r `thenM` \ rat_lit ->
386 returnM (mkHsApp (noLoc expr) rat_lit)
387 -- The mkHsApp will get the loc from the literal
389 | Just expr <- shortCutFracLit r expected_ty
393 = newLitInst orig lit expected_ty
395 newLitInst :: InstOrigin -> HsOverLit -> TcType -> TcM (LHsExpr TcId)
396 newLitInst orig lit expected_ty
397 = getInstLoc orig `thenM` \ loc ->
398 newUnique `thenM` \ new_uniq ->
400 lit_inst = LitInst lit_id lit expected_ty loc
401 lit_id = mkSysLocal FSLIT("lit") new_uniq expected_ty
403 extendLIE lit_inst `thenM_`
404 returnM (L (instLocSrcSpan loc) (HsVar (instToId lit_inst)))
406 shortCutIntLit :: Integer -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-)
408 | isIntTy ty && inIntRange i -- Short cut for Int
409 = Just (noLoc (HsLit (HsInt i)))
410 | isIntegerTy ty -- Short cut for Integer
411 = Just (noLoc (HsLit (HsInteger i ty)))
412 | otherwise = Nothing
414 shortCutFracLit :: Rational -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-)
417 = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
419 = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
420 | otherwise = Nothing
422 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
424 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
425 getSrcSpanM `thenM` \ span ->
426 returnM (L span $ HsLit (HsInteger i integer_ty))
428 mkRatLit :: Rational -> TcM (LHsExpr TcId)
430 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
431 getSrcSpanM `thenM` \ span ->
432 returnM (L span $ HsLit (HsRat r rat_ty))
436 %************************************************************************
440 %************************************************************************
442 Zonking makes sure that the instance types are fully zonked,
443 but doesn't do the same for any of the Ids in an Inst. There's no
444 need, and it's a lot of extra work.
447 zonkInst :: Inst -> TcM Inst
448 zonkInst (Dict id pred loc)
449 = zonkTcPredType pred `thenM` \ new_pred ->
450 returnM (Dict id new_pred loc)
452 zonkInst (Method m id tys theta tau loc)
453 = zonkId id `thenM` \ new_id ->
454 -- Essential to zonk the id in case it's a local variable
455 -- Can't use zonkIdOcc because the id might itself be
456 -- an InstId, in which case it won't be in scope
458 zonkTcTypes tys `thenM` \ new_tys ->
459 zonkTcThetaType theta `thenM` \ new_theta ->
460 zonkTcType tau `thenM` \ new_tau ->
461 returnM (Method m new_id new_tys new_theta new_tau loc)
463 zonkInst (LitInst id lit ty loc)
464 = zonkTcType ty `thenM` \ new_ty ->
465 returnM (LitInst id lit new_ty loc)
467 zonkInsts insts = mappM zonkInst insts
471 %************************************************************************
473 \subsection{Printing}
475 %************************************************************************
477 ToDo: improve these pretty-printing things. The ``origin'' is really only
478 relevant in error messages.
481 instance Outputable Inst where
482 ppr inst = pprInst inst
484 pprDictsTheta :: [Inst] -> SDoc
485 -- Print in type-like fashion (Eq a, Show b)
486 pprDictsTheta dicts = pprTheta (map dictPred dicts)
488 pprDictsInFull :: [Inst] -> SDoc
489 -- Print in type-like fashion, but with source location
491 = vcat (map go dicts)
493 go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))]
495 pprInsts :: [Inst] -> SDoc
496 -- Debugging: print the evidence :: type
497 pprInsts insts = brackets (interpp'SP insts)
499 pprInst, pprInstInFull :: Inst -> SDoc
500 -- Debugging: print the evidence :: type
501 pprInst (LitInst id lit ty loc) = ppr id <+> dcolon <+> ppr ty
502 pprInst (Dict id pred loc) = ppr id <+> dcolon <+> pprPred pred
504 pprInst m@(Method inst_id id tys theta tau loc)
505 = ppr inst_id <+> dcolon <+>
506 braces (sep [ppr id <+> ptext SLIT("at"),
507 brackets (sep (map pprParendType tys))])
510 = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
512 pprDFuns :: [DFunId] -> SDoc
513 -- Prints the dfun as an instance declaration
514 pprDFuns dfuns = vcat [ hang (ppr (getSrcLoc dfun) <> colon)
515 2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta,
516 pprClassPred clas tys])
518 , let (_, theta, clas, tys) = tcSplitDFunTy (idType dfun) ]
519 -- Print without the for-all, which the programmer doesn't write
521 tidyInst :: TidyEnv -> Inst -> Inst
522 tidyInst env (LitInst u lit ty loc) = LitInst u lit (tidyType env ty) loc
523 tidyInst env (Dict u pred loc) = Dict u (tidyPred env pred) loc
524 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
526 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
527 -- This function doesn't assume that the tyvars are in scope
528 -- so it works like tidyOpenType, returning a TidyEnv
529 tidyMoreInsts env insts
530 = (env', map (tidyInst env') insts)
532 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
534 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
535 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
537 showLIE :: SDoc -> TcM () -- Debugging
539 = do { lie_var <- getLIEVar ;
540 lie <- readMutVar lie_var ;
541 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
545 %************************************************************************
547 Extending the instance environment
549 %************************************************************************
552 tcExtendLocalInstEnv :: [DFunId] -> TcM a -> TcM a
553 -- Add new locally-defined instances
554 tcExtendLocalInstEnv dfuns thing_inside
555 = do { traceDFuns dfuns
558 ; inst_env' <- foldlM (addInst dflags) (tcg_inst_env env) dfuns
559 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
560 tcg_inst_env = inst_env' }
561 ; setGblEnv env' thing_inside }
563 addInst :: DynFlags -> InstEnv -> DFunId -> TcM InstEnv
564 -- Check that the proposed new instance is OK,
565 -- and then add it to the home inst env
566 addInst dflags home_ie dfun
567 = do { -- Load imported instances, so that we report
568 -- duplicates correctly
569 let (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
570 ; pkg_ie <- loadImportedInsts cls tys
572 -- Check functional dependencies
573 ; case checkFunDeps (pkg_ie, home_ie) dfun of
574 Just dfuns -> funDepErr dfun dfuns
577 -- Check for duplicate instance decls
578 -- We instantiate the dfun type because the instance lookup
579 -- requires nice fresh types in the thing to be looked up
580 ; (tvs', _, tenv) <- tcInstTyVars tvs
581 ; let { tys' = substTys tenv tys
582 ; (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys'
583 ; dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
584 isJust (matchTys (mkVarSet tvs) tys' dup_tys)] }
585 -- Find memebers of the match list which
586 -- dfun itself matches. If the match is 2-way, it's a duplicate
588 dup_dfun : _ -> dupInstErr dfun dup_dfun
591 -- OK, now extend the envt
592 ; return (extendInstEnv home_ie dfun) }
596 = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
598 pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
602 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
603 2 (pprDFuns (dfun:dfuns)))
604 dupInstErr dfun dup_dfun
606 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
607 2 (pprDFuns [dfun, dup_dfun]))
609 addDictLoc dfun thing_inside
610 = setSrcSpan (mkSrcSpan loc loc) thing_inside
615 %************************************************************************
617 \subsection{Looking up Insts}
619 %************************************************************************
622 data LookupInstResult s
624 | SimpleInst (LHsExpr TcId) -- Just a variable, type application, or literal
625 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
627 lookupInst :: Inst -> TcM (LookupInstResult s)
628 -- It's important that lookupInst does not put any new stuff into
629 -- the LIE. Instead, any Insts needed by the lookup are returned in
630 -- the LookupInstResult, where they can be further processed by tcSimplify
635 lookupInst inst@(Method _ id tys theta _ loc)
636 = newDictsAtLoc loc theta `thenM` \ dicts ->
637 returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (L span (HsVar id)) tys) (map instToId dicts)))
639 span = instLocSrcSpan loc
643 -- Look for short cuts first: if the literal is *definitely* a
644 -- int, integer, float or a double, generate the real thing here.
645 -- This is essential (see nofib/spectral/nucleic).
646 -- [Same shortcut as in newOverloadedLit, but we
647 -- may have done some unification by now]
650 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
651 | Just expr <- shortCutIntLit i ty
652 = returnM (GenInst [] expr) -- GenInst, not SimpleInst, because
653 -- expr may be a constructor application
655 = ASSERT( from_integer_name == fromIntegerName ) -- A LitInst invariant
656 tcLookupId fromIntegerName `thenM` \ from_integer ->
657 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
658 mkIntegerLit i `thenM` \ integer_lit ->
659 returnM (GenInst [method_inst]
660 (mkHsApp (L (instLocSrcSpan loc)
661 (HsVar (instToId method_inst))) integer_lit))
663 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
664 | Just expr <- shortCutFracLit f ty
665 = returnM (GenInst [] expr)
668 = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
669 tcLookupId fromRationalName `thenM` \ from_rational ->
670 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
671 mkRatLit f `thenM` \ rat_lit ->
672 returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc)
673 (HsVar (instToId method_inst))) rat_lit))
676 lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
677 = do { pkg_ie <- loadImportedInsts clas tys
678 -- Suck in any instance decls that may be relevant
679 ; tcg_env <- getGblEnv
681 ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
682 ([(tenv, (_,_,dfun_id))], []) -> instantiate_dfun tenv dfun_id pred loc ;
683 (matches, unifs) -> do
684 { traceTc (text "lookupInst fail" <+> vcat [text "dict" <+> ppr pred,
685 text "matches" <+> ppr matches,
686 text "unifs" <+> ppr unifs])
687 ; return NoInstance } } }
688 -- In the case of overlap (multiple matches) we report
689 -- NoInstance here. That has the effect of making the
690 -- context-simplifier return the dict as an irreducible one.
691 -- Then it'll be given to addNoInstanceErrs, which will do another
692 -- lookupInstEnv to get the detailed info about what went wrong.
694 lookupInst (Dict _ _ _) = returnM NoInstance
697 instantiate_dfun tenv dfun_id pred loc
698 = -- tenv is a substitution that instantiates the dfun_id
699 -- to match the requested result type. However, the dfun
700 -- might have some tyvars that only appear in arguments
701 -- dfun :: forall a b. C a b, Ord b => D [a]
702 -- We instantiate b to a flexi type variable -- it'll presumably
703 -- become fixed later via functional dependencies
704 traceTc (text "lookupInst success" <+>
705 vcat [text "dict" <+> ppr pred,
706 text "witness" <+> ppr dfun_id <+> ppr (idType dfun_id) ]) `thenM_`
707 -- Record that this dfun is needed
708 record_dfun_usage dfun_id `thenM_`
710 -- It's possible that not all the tyvars are in
711 -- the substitution, tenv. For example:
712 -- instance C X a => D X where ...
713 -- (presumably there's a functional dependency in class C)
714 -- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
715 getStage `thenM` \ use_stage ->
716 checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
717 (topIdLvl dfun_id) use_stage `thenM_`
719 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
720 mk_ty_arg tv = case lookupVarEnv tenv tv of
721 Just ty -> returnM ty
722 Nothing -> tcInstTyVar tv `thenM` \ tc_tv ->
723 returnM (mkTyVarTy tc_tv)
725 mappM mk_ty_arg tyvars `thenM` \ ty_args ->
727 dfun_rho = substTy (zipTopTvSubst tyvars ty_args) rho
728 -- Since the tyvars are freshly made,
729 -- they cannot possibly be captured by
730 -- any existing for-alls. Hence zipTopTyVarSubst
731 (theta, _) = tcSplitPhiTy dfun_rho
732 ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id)) ty_args
735 returnM (SimpleInst ty_app)
737 newDictsAtLoc loc theta `thenM` \ dicts ->
739 rhs = mkHsDictApp ty_app (map instToId dicts)
741 returnM (GenInst dicts rhs)
743 record_dfun_usage dfun_id
744 | isInternalName dfun_name = return () -- From this module
745 | not (isHomePackageName dfun_name) = return () -- From another package package
746 | otherwise = getGblEnv `thenM` \ tcg_env ->
747 updMutVar (tcg_inst_uses tcg_env)
748 (`addOneToNameSet` idName dfun_id)
750 dfun_name = idName dfun_id
752 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
753 -- Gets both the external-package inst-env
754 -- and the home-pkg inst env (includes module being compiled)
755 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
756 return (eps_inst_env eps, tcg_inst_env env) }
761 %************************************************************************
765 %************************************************************************
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)
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 = tcStdSyntaxName orig ty std_nm
803 tcSyntaxName orig ty (std_nm, user_nm_expr)
804 = tcLookupId std_nm `thenM` \ std_id ->
806 -- C.f. newMethodAtLoc
807 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
808 sigma1 = substTyWith [tv] [ty] tau
809 -- Actually, the "tau-type" might be a sigma-type in the
810 -- case of locally-polymorphic methods.
812 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $
814 -- Check that the user-supplied thing has the
815 -- same type as the standard one.
816 -- Tiresome jiggling because tcCheckSigma takes a located expression
817 getSrcSpanM `thenM` \ span ->
818 tcCheckSigma (L span user_nm_expr) sigma1 `thenM` \ expr ->
819 returnM (std_nm, unLoc expr)
821 tcStdSyntaxName :: InstOrigin
822 -> TcType -- Type to instantiate it at
823 -> Name -- Standard name
824 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
826 tcStdSyntaxName orig ty std_nm
827 = newMethodFromName orig ty std_nm `thenM` \ id ->
828 returnM (std_nm, HsVar id)
830 syntaxNameCtxt name orig ty tidy_env
831 = getInstLoc orig `thenM` \ inst_loc ->
833 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
834 ptext SLIT("(needed by a syntactic construct)"),
835 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
836 nest 2 (pprInstLoc inst_loc)]
838 returnM (tidy_env, msg)