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, zonkTcThetaType,
54 tcInstTyVar, tcInstType, tcSkolType
56 import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcTyVar, TcPredType,
57 PredType(..), SkolemInfo(..), typeKind, mkSigmaTy,
58 tcSplitForAllTys, tcSplitForAllTys,
59 tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy, tcSplitDFunHead,
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 ( TvSubst, substTy, substTyVar, substTyWith, substTheta, zipTopTvSubst,
70 notElemTvSubst, extendTvSubstList )
71 import Unify ( tcMatchTys )
72 import Kind ( isSubKind )
73 import Packages ( isHomeModule )
74 import HscTypes ( ExternalPackageState(..) )
75 import CoreFVs ( idFreeTyVars )
76 import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName )
77 import Id ( Id, idName, idType, mkUserLocal, mkLocalId )
78 import PrelInfo ( isStandardClass, isNoDictClass )
79 import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
80 isInternalName, setNameUnique, mkSystemVarNameEncoded )
81 import NameSet ( addOneToNameSet )
82 import Literal ( inIntRange )
83 import Var ( TyVar, tyVarKind, setIdType )
84 import VarEnv ( TidyEnv, emptyTidyEnv )
85 import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
86 import TysWiredIn ( floatDataCon, doubleDataCon )
87 import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
88 import BasicTypes( IPName(..), mapIPName, ipNameName )
89 import UniqSupply( uniqsFromSupply )
90 import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) )
91 import CmdLineOpts( DynFlags )
92 import Maybes ( isJust )
100 instName :: Inst -> Name
101 instName inst = idName (instToId inst)
103 instToId :: Inst -> TcId
104 instToId (LitInst nm _ ty _) = mkLocalId nm ty
105 instToId (Dict nm pred _) = mkLocalId nm (mkPredTy pred)
106 instToId (Method id _ _ _ _ _) = id
108 instLoc (Dict _ _ loc) = loc
109 instLoc (Method _ _ _ _ _ loc) = loc
110 instLoc (LitInst _ _ _ loc) = loc
112 dictPred (Dict _ pred _ ) = pred
113 dictPred inst = pprPanic "dictPred" (ppr inst)
115 getDictClassTys (Dict _ pred _) = getClassPredTys pred
117 -- fdPredsOfInst is used to get predicates that contain functional
118 -- dependencies *or* might do so. The "might do" part is because
119 -- a constraint (C a b) might have a superclass with FDs
120 -- Leaving these in is really important for the call to fdPredsOfInsts
121 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
122 -- which is supposed to be conservative
123 fdPredsOfInst (Dict _ pred _) = [pred]
124 fdPredsOfInst (Method _ _ _ theta _ _) = theta
125 fdPredsOfInst other = [] -- LitInsts etc
127 fdPredsOfInsts :: [Inst] -> [PredType]
128 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
130 isInheritableInst (Dict _ pred _) = isInheritablePred pred
131 isInheritableInst (Method _ _ _ theta _ _) = all isInheritablePred theta
132 isInheritableInst other = True
135 ipNamesOfInsts :: [Inst] -> [Name]
136 ipNamesOfInst :: Inst -> [Name]
137 -- Get the implicit parameters mentioned by these Insts
138 -- NB: ?x and %x get different Names
139 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
141 ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
142 ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
143 ipNamesOfInst other = []
145 tyVarsOfInst :: Inst -> TcTyVarSet
146 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
147 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
148 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
149 -- The id might have free type variables; in the case of
150 -- locally-overloaded class methods, for example
153 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
154 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
160 isDict :: Inst -> Bool
161 isDict (Dict _ _ _) = True
164 isClassDict :: Inst -> Bool
165 isClassDict (Dict _ pred _) = isClassPred pred
166 isClassDict other = False
168 isTyVarDict :: Inst -> Bool
169 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
170 isTyVarDict other = False
172 isIPDict :: Inst -> Bool
173 isIPDict (Dict _ pred _) = isIPPred pred
174 isIPDict other = False
176 isMethod :: Inst -> Bool
177 isMethod (Method _ _ _ _ _ _) = True
178 isMethod other = False
180 isMethodFor :: TcIdSet -> Inst -> Bool
181 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
182 isMethodFor ids inst = False
184 isLinearInst :: Inst -> Bool
185 isLinearInst (Dict _ pred _) = isLinearPred pred
186 isLinearInst other = False
187 -- We never build Method Insts that have
188 -- linear implicit paramters in them.
189 -- Hence no need to look for Methods
192 linearInstType :: Inst -> TcType -- %x::t --> t
193 linearInstType (Dict _ (IParam _ ty) _) = ty
196 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
197 Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
201 Two predicates which deal with the case where class constraints don't
202 necessarily result in bindings. The first tells whether an @Inst@
203 must be witnessed by an actual binding; the second tells whether an
204 @Inst@ can be generalised over.
207 instBindingRequired :: Inst -> Bool
208 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
209 instBindingRequired other = True
213 %************************************************************************
215 \subsection{Building dictionaries}
217 %************************************************************************
220 newDicts :: InstOrigin
224 = getInstLoc orig `thenM` \ loc ->
225 newDictsAtLoc loc theta
227 cloneDict :: Inst -> TcM Inst
228 cloneDict (Dict nm ty loc) = newUnique `thenM` \ uniq ->
229 returnM (Dict (setNameUnique nm uniq) ty loc)
231 newDictsFromOld :: Inst -> TcThetaType -> TcM [Inst]
232 newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
234 -- Local function, similar to newDicts,
235 -- but with slightly different interface
236 newDictsAtLoc :: InstLoc
239 newDictsAtLoc inst_loc theta
240 = newUniqueSupply `thenM` \ us ->
241 returnM (zipWith mk_dict (uniqsFromSupply us) theta)
243 mk_dict uniq pred = Dict (mkPredName uniq loc pred)
245 loc = instLocSrcLoc inst_loc
247 -- For vanilla implicit parameters, there is only one in scope
248 -- at any time, so we used to use the name of the implicit parameter itself
249 -- But with splittable implicit parameters there may be many in
250 -- scope, so we make up a new name.
251 newIPDict :: InstOrigin -> IPName Name -> Type
252 -> TcM (IPName Id, Inst)
253 newIPDict orig ip_name ty
254 = getInstLoc orig `thenM` \ inst_loc ->
255 newUnique `thenM` \ uniq ->
257 pred = IParam ip_name ty
258 name = mkPredName uniq (instLocSrcLoc inst_loc) pred
259 dict = Dict name pred inst_loc
261 returnM (mapIPName (\n -> instToId dict) ip_name, dict)
266 %************************************************************************
268 \subsection{Building methods (calls of overloaded functions)}
270 %************************************************************************
274 tcInstCall :: InstOrigin -> TcType -> TcM (ExprCoFn, [TcTyVar], TcType)
275 tcInstCall orig fun_ty -- fun_ty is usually a sigma-type
276 = do { (tyvars, theta, tau) <- tcInstType fun_ty
277 ; dicts <- newDicts orig theta
279 ; let inst_fn e = unLoc (mkHsDictApp (mkHsTyApp (noLoc e) (mkTyVarTys tyvars))
280 (map instToId dicts))
281 ; return (mkCoercion inst_fn, tyvars, tau) }
283 tcInstStupidTheta :: DataCon -> [TcType] -> TcM ()
284 -- Instantiate the "stupid theta" of the data con, and throw
285 -- the constraints into the constraint set
286 tcInstStupidTheta data_con inst_tys
290 = do { stupid_dicts <- newDicts (OccurrenceOf (dataConName data_con))
291 (substTheta tenv stupid_theta)
292 ; extendLIEs stupid_dicts }
294 stupid_theta = dataConStupidTheta data_con
295 tenv = zipTopTvSubst (dataConTyVars data_con) inst_tys
297 newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId
298 newMethodFromName origin ty name
299 = tcLookupId name `thenM` \ id ->
300 -- Use tcLookupId not tcLookupGlobalId; the method is almost
301 -- always a class op, but with -fno-implicit-prelude GHC is
302 -- meant to find whatever thing is in scope, and that may
303 -- be an ordinary function.
304 getInstLoc origin `thenM` \ loc ->
305 tcInstClassOp loc id [ty] `thenM` \ inst ->
306 extendLIE inst `thenM_`
307 returnM (instToId inst)
309 newMethodWithGivenTy orig id tys theta tau
310 = getInstLoc orig `thenM` \ loc ->
311 newMethod loc id tys theta tau `thenM` \ inst ->
312 extendLIE inst `thenM_`
313 returnM (instToId inst)
315 --------------------------------------------
316 -- tcInstClassOp, and newMethod do *not* drop the
317 -- Inst into the LIE; they just returns the Inst
318 -- This is important because they are used by TcSimplify
321 -- NB: the kind of the type variable to be instantiated
322 -- might be a sub-kind of the type to which it is applied,
323 -- notably when the latter is a type variable of kind ??
324 -- Hence the call to checkKind
325 -- A worry: is this needed anywhere else?
326 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
327 tcInstClassOp inst_loc sel_id tys
329 (tyvars,rho) = tcSplitForAllTys (idType sel_id)
330 rho_ty = ASSERT( length tyvars == length tys )
331 substTyWith tyvars tys rho
332 (preds,tau) = tcSplitPhiTy rho_ty
334 zipWithM_ checkKind tyvars tys `thenM_`
335 newMethod inst_loc sel_id tys preds tau
337 checkKind :: TyVar -> TcType -> TcM ()
338 -- Ensure that the type has a sub-kind of the tyvar
340 = do { ty1 <- zonkTcType ty
341 ; if typeKind ty1 `isSubKind` tyVarKind tv
344 { traceTc (text "checkKind: adding kind constraint" <+> ppr tv <+> ppr ty)
345 ; tv1 <- tcInstTyVar tv
346 ; unifyTauTy (mkTyVarTy tv1) ty1 }}
349 ---------------------------
350 newMethod inst_loc id tys theta tau
351 = newUnique `thenM` \ new_uniq ->
353 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
354 inst = Method meth_id id tys theta tau inst_loc
355 loc = instLocSrcLoc inst_loc
360 In newOverloadedLit we convert directly to an Int or Integer if we
361 know that's what we want. This may save some time, by not
362 temporarily generating overloaded literals, but it won't catch all
363 cases (the rest are caught in lookupInst).
366 newOverloadedLit :: InstOrigin
369 -> TcM (LHsExpr TcId)
370 newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
371 | fi /= fromIntegerName -- Do not generate a LitInst for rebindable syntax.
372 -- Reason: tcSyntaxName does unification
373 -- which is very inconvenient in tcSimplify
374 -- ToDo: noLoc sadness
375 = tcSyntaxName orig expected_ty (fromIntegerName, HsVar fi) `thenM` \ (_,expr) ->
376 mkIntegerLit i `thenM` \ integer_lit ->
377 returnM (mkHsApp (noLoc expr) integer_lit)
378 -- The mkHsApp will get the loc from the literal
379 | Just expr <- shortCutIntLit i expected_ty
383 = newLitInst orig lit expected_ty
385 newOverloadedLit orig lit@(HsFractional r fr) expected_ty
386 | fr /= fromRationalName -- c.f. HsIntegral case
387 = tcSyntaxName orig expected_ty (fromRationalName, HsVar fr) `thenM` \ (_,expr) ->
388 mkRatLit r `thenM` \ rat_lit ->
389 returnM (mkHsApp (noLoc expr) rat_lit)
390 -- The mkHsApp will get the loc from the literal
392 | Just expr <- shortCutFracLit r expected_ty
396 = newLitInst orig lit expected_ty
398 newLitInst :: InstOrigin -> HsOverLit -> TcType -> TcM (LHsExpr TcId)
399 newLitInst orig lit expected_ty
400 = getInstLoc orig `thenM` \ loc ->
401 newUnique `thenM` \ new_uniq ->
403 lit_nm = mkSystemVarNameEncoded new_uniq FSLIT("lit")
404 -- The "encoded" bit means that we don't need to z-encode
405 -- the string every time we call this!
406 lit_inst = LitInst lit_nm lit expected_ty loc
408 extendLIE lit_inst `thenM_`
409 returnM (L (instLocSrcSpan loc) (HsVar (instToId lit_inst)))
411 shortCutIntLit :: Integer -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-)
413 | isIntTy ty && inIntRange i -- Short cut for Int
414 = Just (noLoc (HsLit (HsInt i)))
415 | isIntegerTy ty -- Short cut for Integer
416 = Just (noLoc (HsLit (HsInteger i ty)))
417 | otherwise = Nothing
419 shortCutFracLit :: Rational -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-)
422 = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
424 = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
425 | otherwise = Nothing
427 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
429 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
430 getSrcSpanM `thenM` \ span ->
431 returnM (L span $ HsLit (HsInteger i integer_ty))
433 mkRatLit :: Rational -> TcM (LHsExpr TcId)
435 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
436 getSrcSpanM `thenM` \ span ->
437 returnM (L span $ HsLit (HsRat r rat_ty))
441 %************************************************************************
445 %************************************************************************
447 Zonking makes sure that the instance types are fully zonked.
450 zonkInst :: Inst -> TcM Inst
451 zonkInst (Dict name pred loc)
452 = zonkTcPredType pred `thenM` \ new_pred ->
453 returnM (Dict name new_pred loc)
455 zonkInst (Method m id tys theta tau loc)
456 = zonkId id `thenM` \ new_id ->
457 -- Essential to zonk the id in case it's a local variable
458 -- Can't use zonkIdOcc because the id might itself be
459 -- an InstId, in which case it won't be in scope
461 zonkTcTypes tys `thenM` \ new_tys ->
462 zonkTcThetaType theta `thenM` \ new_theta ->
463 zonkTcType tau `thenM` \ new_tau ->
464 returnM (Method m new_id new_tys new_theta new_tau loc)
466 zonkInst (LitInst nm lit ty loc)
467 = zonkTcType ty `thenM` \ new_ty ->
468 returnM (LitInst nm lit new_ty loc)
470 zonkInsts insts = mappM zonkInst insts
474 %************************************************************************
476 \subsection{Printing}
478 %************************************************************************
480 ToDo: improve these pretty-printing things. The ``origin'' is really only
481 relevant in error messages.
484 instance Outputable Inst where
485 ppr inst = pprInst inst
487 pprDictsTheta :: [Inst] -> SDoc
488 -- Print in type-like fashion (Eq a, Show b)
489 pprDictsTheta dicts = pprTheta (map dictPred dicts)
491 pprDictsInFull :: [Inst] -> SDoc
492 -- Print in type-like fashion, but with source location
494 = vcat (map go dicts)
496 go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))]
498 pprInsts :: [Inst] -> SDoc
499 -- Debugging: print the evidence :: type
500 pprInsts insts = brackets (interpp'SP insts)
502 pprInst, pprInstInFull :: Inst -> SDoc
503 -- Debugging: print the evidence :: type
504 pprInst (LitInst nm lit ty loc) = ppr nm <+> dcolon <+> ppr ty
505 pprInst (Dict nm pred loc) = ppr nm <+> dcolon <+> pprPred pred
507 pprInst m@(Method inst_id id tys theta tau loc)
508 = ppr inst_id <+> dcolon <+>
509 braces (sep [ppr id <+> ptext SLIT("at"),
510 brackets (sep (map pprParendType tys))])
513 = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
515 pprDFuns :: [DFunId] -> SDoc
516 -- Prints the dfun as an instance declaration
517 pprDFuns dfuns = vcat [ hang (ppr (getSrcLoc dfun) <> colon)
518 2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta,
519 pprClassPred clas tys])
521 , let (_, theta, clas, tys) = tcSplitDFunTy (idType dfun) ]
522 -- Print without the for-all, which the programmer doesn't write
524 tidyInst :: TidyEnv -> Inst -> Inst
525 tidyInst env (LitInst nm lit ty loc) = LitInst nm lit (tidyType env ty) loc
526 tidyInst env (Dict nm pred loc) = Dict nm (tidyPred env pred) loc
527 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
529 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
530 -- This function doesn't assume that the tyvars are in scope
531 -- so it works like tidyOpenType, returning a TidyEnv
532 tidyMoreInsts env insts
533 = (env', map (tidyInst env') insts)
535 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
537 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
538 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
540 showLIE :: SDoc -> TcM () -- Debugging
542 = do { lie_var <- getLIEVar ;
543 lie <- readMutVar lie_var ;
544 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
548 %************************************************************************
550 Extending the instance environment
552 %************************************************************************
555 tcExtendLocalInstEnv :: [DFunId] -> TcM a -> TcM a
556 -- Add new locally-defined instances
557 tcExtendLocalInstEnv dfuns thing_inside
558 = do { traceDFuns dfuns
561 ; inst_env' <- foldlM (addInst dflags) (tcg_inst_env env) dfuns
562 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
563 tcg_inst_env = inst_env' }
564 ; setGblEnv env' thing_inside }
566 addInst :: DynFlags -> InstEnv -> DFunId -> TcM InstEnv
567 -- Check that the proposed new instance is OK,
568 -- and then add it to the home inst env
569 addInst dflags home_ie dfun
570 = do { -- Instantiate the dfun type so that we extend the instance
571 -- envt with completely fresh template variables
572 -- This is important because the template variables must
573 -- not overlap with anything in the things being looked up
574 -- (since we do unification).
575 -- We use tcSkolType because we don't want to allocate fresh
576 -- *meta* type variables.
577 (tvs', theta', tau') <- tcSkolType (InstSkol dfun) (idType dfun)
578 ; let (cls, tys') = tcSplitDFunHead tau'
579 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
581 -- Load imported instances, so that we report
582 -- duplicates correctly
583 ; pkg_ie <- loadImportedInsts cls tys'
585 -- Check functional dependencies
586 ; case checkFunDeps (pkg_ie, home_ie) dfun' of
587 Just dfuns -> funDepErr dfun dfuns
590 -- Check for duplicate instance decls
591 ; let { (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys'
592 ; dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
593 isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
594 -- Find memebers of the match list which
595 -- dfun itself matches. If the match is 2-way, it's a duplicate
597 dup_dfun : _ -> dupInstErr dfun dup_dfun
600 -- OK, now extend the envt
601 ; return (extendInstEnv home_ie dfun') }
605 = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
607 pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
611 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
612 2 (pprDFuns (dfun:dfuns)))
613 dupInstErr dfun dup_dfun
615 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
616 2 (pprDFuns [dfun, dup_dfun]))
618 addDictLoc dfun thing_inside
619 = setSrcSpan (mkSrcSpan loc loc) thing_inside
625 %************************************************************************
627 \subsection{Looking up Insts}
629 %************************************************************************
632 data LookupInstResult
634 | SimpleInst (LHsExpr TcId) -- Just a variable, type application, or literal
635 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
637 lookupInst :: Inst -> TcM LookupInstResult
638 -- It's important that lookupInst does not put any new stuff into
639 -- the LIE. Instead, any Insts needed by the lookup are returned in
640 -- the LookupInstResult, where they can be further processed by tcSimplify
645 lookupInst inst@(Method _ id tys theta _ loc)
646 = newDictsAtLoc loc theta `thenM` \ dicts ->
647 returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (L span (HsVar id)) tys) (map instToId dicts)))
649 span = instLocSrcSpan loc
653 -- Look for short cuts first: if the literal is *definitely* a
654 -- int, integer, float or a double, generate the real thing here.
655 -- This is essential (see nofib/spectral/nucleic).
656 -- [Same shortcut as in newOverloadedLit, but we
657 -- may have done some unification by now]
660 lookupInst inst@(LitInst _nm (HsIntegral i from_integer_name) ty loc)
661 | Just expr <- shortCutIntLit i ty
662 = returnM (GenInst [] expr) -- GenInst, not SimpleInst, because
663 -- expr may be a constructor application
665 = ASSERT( from_integer_name == fromIntegerName ) -- A LitInst invariant
666 tcLookupId fromIntegerName `thenM` \ from_integer ->
667 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
668 mkIntegerLit i `thenM` \ integer_lit ->
669 returnM (GenInst [method_inst]
670 (mkHsApp (L (instLocSrcSpan loc)
671 (HsVar (instToId method_inst))) integer_lit))
673 lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc)
674 | Just expr <- shortCutFracLit f ty
675 = returnM (GenInst [] expr)
678 = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
679 tcLookupId fromRationalName `thenM` \ from_rational ->
680 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
681 mkRatLit f `thenM` \ rat_lit ->
682 returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc)
683 (HsVar (instToId method_inst))) rat_lit))
686 lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
687 = do { pkg_ie <- loadImportedInsts clas tys
688 -- Suck in any instance decls that may be relevant
689 ; tcg_env <- getGblEnv
691 ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
692 ([(tenv, (_,_,dfun_id))], []) -> instantiate_dfun tenv dfun_id pred loc ;
693 (matches, unifs) -> do
694 { traceTc (text "lookupInst fail" <+> vcat [text "dict" <+> ppr pred,
695 text "matches" <+> ppr matches,
696 text "unifs" <+> ppr unifs])
697 ; return NoInstance } } }
698 -- In the case of overlap (multiple matches) we report
699 -- NoInstance here. That has the effect of making the
700 -- context-simplifier return the dict as an irreducible one.
701 -- Then it'll be given to addNoInstanceErrs, which will do another
702 -- lookupInstEnv to get the detailed info about what went wrong.
704 lookupInst (Dict _ _ _) = returnM NoInstance
707 instantiate_dfun :: TvSubst -> DFunId -> TcPredType -> InstLoc -> TcM LookupInstResult
708 instantiate_dfun tenv dfun_id pred loc
709 = -- tenv is a substitution that instantiates the dfun_id
710 -- to match the requested result type.
712 -- We ASSUME that the dfun is quantified over the very same tyvars
713 -- that are bound by the tenv.
716 -- might have some tyvars that *only* appear in arguments
717 -- dfun :: forall a b. C a b, Ord b => D [a]
718 -- We instantiate b to a flexi type variable -- it'll presumably
719 -- become fixed later via functional dependencies
720 traceTc (text "lookupInst success" <+>
721 vcat [text "dict" <+> ppr pred,
722 text "witness" <+> ppr dfun_id <+> ppr (idType dfun_id) ]) `thenM_`
723 -- Record that this dfun is needed
724 record_dfun_usage dfun_id `thenM_`
726 getStage `thenM` \ use_stage ->
727 checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
728 (topIdLvl dfun_id) use_stage `thenM_`
730 -- It's possible that not all the tyvars are in
731 -- the substitution, tenv. For example:
732 -- instance C X a => D X where ...
733 -- (presumably there's a functional dependency in class C)
734 -- Hence the open_tvs to instantiate any un-substituted tyvars.
736 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
737 open_tvs = filter (`notElemTvSubst` tenv) tyvars
739 mappM tcInstTyVar open_tvs `thenM` \ open_tvs' ->
741 tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
742 -- Since the open_tvs' are freshly made, they cannot possibly be captured by
743 -- any nested for-alls in rho. So the in-scope set is unchanged
744 dfun_rho = substTy tenv' rho
745 (theta, _) = tcSplitPhiTy dfun_rho
746 ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id))
747 (map (substTyVar tenv') tyvars)
750 returnM (SimpleInst ty_app)
752 newDictsAtLoc loc theta `thenM` \ dicts ->
754 rhs = mkHsDictApp ty_app (map instToId dicts)
756 returnM (GenInst dicts rhs)
758 record_dfun_usage dfun_id = do
760 let dfun_name = idName dfun_id
761 dfun_mod = nameModule dfun_name
762 if isInternalName dfun_name || not (isHomeModule dflags dfun_mod)
763 then return () -- internal, or in another package
764 else do tcg_env <- getGblEnv
765 updMutVar (tcg_inst_uses tcg_env)
766 (`addOneToNameSet` idName dfun_id)
768 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
769 -- Gets both the external-package inst-env
770 -- and the home-pkg inst env (includes module being compiled)
771 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
772 return (eps_inst_env eps, tcg_inst_env env) }
777 %************************************************************************
781 %************************************************************************
784 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
785 a do-expression. We have to find (>>) in the current environment, which is
786 done by the rename. Then we have to check that it has the same type as
787 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
790 (>>) :: HB m n mn => m a -> n b -> mn b
792 So the idea is to generate a local binding for (>>), thus:
794 let then72 :: forall a b. m a -> m b -> m b
795 then72 = ...something involving the user's (>>)...
797 ...the do-expression...
799 Now the do-expression can proceed using then72, which has exactly
802 In fact tcSyntaxName just generates the RHS for then72, because we only
803 want an actual binding in the do-expression case. For literals, we can
804 just use the expression inline.
807 tcSyntaxName :: InstOrigin
808 -> TcType -- Type to instantiate it at
809 -> (Name, HsExpr Name) -- (Standard name, user name)
810 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
812 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
813 -- So we do not call it from lookupInst, which is called from tcSimplify
815 tcSyntaxName orig ty (std_nm, HsVar user_nm)
817 = tcStdSyntaxName orig ty std_nm
819 tcSyntaxName orig ty (std_nm, user_nm_expr)
820 = tcLookupId std_nm `thenM` \ std_id ->
822 -- C.f. newMethodAtLoc
823 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
824 sigma1 = substTyWith [tv] [ty] tau
825 -- Actually, the "tau-type" might be a sigma-type in the
826 -- case of locally-polymorphic methods.
828 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $
830 -- Check that the user-supplied thing has the
831 -- same type as the standard one.
832 -- Tiresome jiggling because tcCheckSigma takes a located expression
833 getSrcSpanM `thenM` \ span ->
834 tcCheckSigma (L span user_nm_expr) sigma1 `thenM` \ expr ->
835 returnM (std_nm, unLoc expr)
837 tcStdSyntaxName :: InstOrigin
838 -> TcType -- Type to instantiate it at
839 -> Name -- Standard name
840 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
842 tcStdSyntaxName orig ty std_nm
843 = newMethodFromName orig ty std_nm `thenM` \ id ->
844 returnM (std_nm, HsVar id)
846 syntaxNameCtxt name orig ty tidy_env
847 = getInstLoc orig `thenM` \ inst_loc ->
849 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
850 ptext SLIT("(needed by a syntactic construct)"),
851 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
852 nest 2 (pprInstLoc inst_loc)]
854 returnM (tidy_env, msg)