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 newDicts, newDictAtLoc, 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(..), lookupPred,
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 newDictAtLoc :: InstLoc -> TcPredType -> TcM Inst
232 newDictAtLoc inst_loc pred
233 = do { uniq <- newUnique
234 ; return (mkDict inst_loc uniq pred) }
236 newDictsAtLoc :: InstLoc -> TcThetaType -> TcM [Inst]
237 newDictsAtLoc inst_loc theta
238 = newUniqueSupply `thenM` \ us ->
239 returnM (zipWith (mkDict inst_loc) (uniqsFromSupply us) theta)
241 mkDict inst_loc uniq pred
242 = Dict name pred inst_loc
244 name = mkPredName uniq (instLocSrcLoc inst_loc) pred
246 -- For vanilla implicit parameters, there is only one in scope
247 -- at any time, so we used to use the name of the implicit parameter itself
248 -- But with splittable implicit parameters there may be many in
249 -- scope, so we make up a new name.
250 newIPDict :: InstOrigin -> IPName Name -> Type
251 -> TcM (IPName Id, Inst)
252 newIPDict orig ip_name ty
253 = getInstLoc orig `thenM` \ inst_loc ->
254 newUnique `thenM` \ uniq ->
256 pred = IParam ip_name ty
257 name = mkPredName uniq (instLocSrcLoc inst_loc) pred
258 dict = Dict name pred inst_loc
260 returnM (mapIPName (\n -> instToId dict) ip_name, dict)
265 %************************************************************************
267 \subsection{Building methods (calls of overloaded functions)}
269 %************************************************************************
273 tcInstCall :: InstOrigin -> TcType -> TcM (ExprCoFn, [TcTyVar], TcType)
274 tcInstCall orig fun_ty -- fun_ty is usually a sigma-type
275 = do { (tyvars, theta, tau) <- tcInstType fun_ty
276 ; dicts <- newDicts orig theta
278 ; let inst_fn e = unLoc (mkHsDictApp (mkHsTyApp (noLoc e) (mkTyVarTys tyvars))
279 (map instToId dicts))
280 ; return (mkCoercion inst_fn, tyvars, tau) }
282 tcInstStupidTheta :: DataCon -> [TcType] -> TcM ()
283 -- Instantiate the "stupid theta" of the data con, and throw
284 -- the constraints into the constraint set
285 tcInstStupidTheta data_con inst_tys
289 = do { stupid_dicts <- newDicts (OccurrenceOf (dataConName data_con))
290 (substTheta tenv stupid_theta)
291 ; extendLIEs stupid_dicts }
293 stupid_theta = dataConStupidTheta data_con
294 tenv = zipTopTvSubst (dataConTyVars data_con) inst_tys
296 newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId
297 newMethodFromName origin ty name
298 = tcLookupId name `thenM` \ id ->
299 -- Use tcLookupId not tcLookupGlobalId; the method is almost
300 -- always a class op, but with -fno-implicit-prelude GHC is
301 -- meant to find whatever thing is in scope, and that may
302 -- be an ordinary function.
303 getInstLoc origin `thenM` \ loc ->
304 tcInstClassOp loc id [ty] `thenM` \ inst ->
305 extendLIE inst `thenM_`
306 returnM (instToId inst)
308 newMethodWithGivenTy orig id tys theta tau
309 = getInstLoc orig `thenM` \ loc ->
310 newMethod loc id tys theta tau `thenM` \ inst ->
311 extendLIE inst `thenM_`
312 returnM (instToId inst)
314 --------------------------------------------
315 -- tcInstClassOp, and newMethod do *not* drop the
316 -- Inst into the LIE; they just returns the Inst
317 -- This is important because they are used by TcSimplify
320 -- NB: the kind of the type variable to be instantiated
321 -- might be a sub-kind of the type to which it is applied,
322 -- notably when the latter is a type variable of kind ??
323 -- Hence the call to checkKind
324 -- A worry: is this needed anywhere else?
325 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
326 tcInstClassOp inst_loc sel_id tys
328 (tyvars,rho) = tcSplitForAllTys (idType sel_id)
329 rho_ty = ASSERT( length tyvars == length tys )
330 substTyWith tyvars tys rho
331 (preds,tau) = tcSplitPhiTy rho_ty
333 zipWithM_ checkKind tyvars tys `thenM_`
334 newMethod inst_loc sel_id tys preds tau
336 checkKind :: TyVar -> TcType -> TcM ()
337 -- Ensure that the type has a sub-kind of the tyvar
339 = do { ty1 <- zonkTcType ty
340 ; if typeKind ty1 `isSubKind` tyVarKind tv
343 { traceTc (text "checkKind: adding kind constraint" <+> ppr tv <+> ppr ty)
344 ; tv1 <- tcInstTyVar tv
345 ; unifyTauTy (mkTyVarTy tv1) ty1 }}
348 ---------------------------
349 newMethod inst_loc id tys theta tau
350 = newUnique `thenM` \ new_uniq ->
352 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
353 inst = Method meth_id id tys theta tau inst_loc
354 loc = instLocSrcLoc inst_loc
359 In newOverloadedLit we convert directly to an Int or Integer if we
360 know that's what we want. This may save some time, by not
361 temporarily generating overloaded literals, but it won't catch all
362 cases (the rest are caught in lookupInst).
365 newOverloadedLit :: InstOrigin
368 -> TcM (LHsExpr TcId)
369 newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
370 | fi /= fromIntegerName -- Do not generate a LitInst for rebindable syntax.
371 -- Reason: tcSyntaxName does unification
372 -- which is very inconvenient in tcSimplify
373 -- ToDo: noLoc sadness
374 = tcSyntaxName orig expected_ty (fromIntegerName, HsVar fi) `thenM` \ (_,expr) ->
375 mkIntegerLit i `thenM` \ integer_lit ->
376 returnM (mkHsApp (noLoc expr) integer_lit)
377 -- The mkHsApp will get the loc from the literal
378 | Just expr <- shortCutIntLit i expected_ty
382 = newLitInst orig lit expected_ty
384 newOverloadedLit orig lit@(HsFractional r fr) expected_ty
385 | fr /= fromRationalName -- c.f. HsIntegral case
386 = tcSyntaxName orig expected_ty (fromRationalName, HsVar fr) `thenM` \ (_,expr) ->
387 mkRatLit r `thenM` \ rat_lit ->
388 returnM (mkHsApp (noLoc expr) rat_lit)
389 -- The mkHsApp will get the loc from the literal
391 | Just expr <- shortCutFracLit r expected_ty
395 = newLitInst orig lit expected_ty
397 newLitInst :: InstOrigin -> HsOverLit -> TcType -> TcM (LHsExpr TcId)
398 newLitInst orig lit expected_ty
399 = getInstLoc orig `thenM` \ loc ->
400 newUnique `thenM` \ new_uniq ->
402 lit_nm = mkSystemVarNameEncoded new_uniq FSLIT("lit")
403 -- The "encoded" bit means that we don't need to z-encode
404 -- the string every time we call this!
405 lit_inst = LitInst lit_nm lit expected_ty loc
407 extendLIE lit_inst `thenM_`
408 returnM (L (instLocSrcSpan loc) (HsVar (instToId lit_inst)))
410 shortCutIntLit :: Integer -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-)
412 | isIntTy ty && inIntRange i -- Short cut for Int
413 = Just (noLoc (HsLit (HsInt i)))
414 | isIntegerTy ty -- Short cut for Integer
415 = Just (noLoc (HsLit (HsInteger i ty)))
416 | otherwise = Nothing
418 shortCutFracLit :: Rational -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-)
421 = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
423 = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
424 | otherwise = Nothing
426 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
428 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
429 getSrcSpanM `thenM` \ span ->
430 returnM (L span $ HsLit (HsInteger i integer_ty))
432 mkRatLit :: Rational -> TcM (LHsExpr TcId)
434 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
435 getSrcSpanM `thenM` \ span ->
436 returnM (L span $ HsLit (HsRat r rat_ty))
440 %************************************************************************
444 %************************************************************************
446 Zonking makes sure that the instance types are fully zonked.
449 zonkInst :: Inst -> TcM Inst
450 zonkInst (Dict name pred loc)
451 = zonkTcPredType pred `thenM` \ new_pred ->
452 returnM (Dict name new_pred loc)
454 zonkInst (Method m id tys theta tau loc)
455 = zonkId id `thenM` \ new_id ->
456 -- Essential to zonk the id in case it's a local variable
457 -- Can't use zonkIdOcc because the id might itself be
458 -- an InstId, in which case it won't be in scope
460 zonkTcTypes tys `thenM` \ new_tys ->
461 zonkTcThetaType theta `thenM` \ new_theta ->
462 zonkTcType tau `thenM` \ new_tau ->
463 returnM (Method m new_id new_tys new_theta new_tau loc)
465 zonkInst (LitInst nm lit ty loc)
466 = zonkTcType ty `thenM` \ new_ty ->
467 returnM (LitInst nm lit new_ty loc)
469 zonkInsts insts = mappM zonkInst insts
473 %************************************************************************
475 \subsection{Printing}
477 %************************************************************************
479 ToDo: improve these pretty-printing things. The ``origin'' is really only
480 relevant in error messages.
483 instance Outputable Inst where
484 ppr inst = pprInst inst
486 pprDictsTheta :: [Inst] -> SDoc
487 -- Print in type-like fashion (Eq a, Show b)
488 pprDictsTheta dicts = pprTheta (map dictPred dicts)
490 pprDictsInFull :: [Inst] -> SDoc
491 -- Print in type-like fashion, but with source location
493 = vcat (map go dicts)
495 go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))]
497 pprInsts :: [Inst] -> SDoc
498 -- Debugging: print the evidence :: type
499 pprInsts insts = brackets (interpp'SP insts)
501 pprInst, pprInstInFull :: Inst -> SDoc
502 -- Debugging: print the evidence :: type
503 pprInst (LitInst nm lit ty loc) = ppr nm <+> dcolon <+> ppr ty
504 pprInst (Dict nm pred loc) = ppr nm <+> dcolon <+> pprPred pred
506 pprInst m@(Method inst_id id tys theta tau loc)
507 = ppr inst_id <+> dcolon <+>
508 braces (sep [ppr id <+> ptext SLIT("at"),
509 brackets (sep (map pprParendType tys))])
512 = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
514 pprDFuns :: [DFunId] -> SDoc
515 -- Prints the dfun as an instance declaration
516 pprDFuns dfuns = vcat [ hang (ppr (getSrcLoc dfun) <> colon)
517 2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta,
518 pprClassPred clas tys])
520 , let (_, theta, clas, tys) = tcSplitDFunTy (idType dfun) ]
521 -- Print without the for-all, which the programmer doesn't write
523 tidyInst :: TidyEnv -> Inst -> Inst
524 tidyInst env (LitInst nm lit ty loc) = LitInst nm lit (tidyType env ty) loc
525 tidyInst env (Dict nm pred loc) = Dict nm (tidyPred env pred) loc
526 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
528 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
529 -- This function doesn't assume that the tyvars are in scope
530 -- so it works like tidyOpenType, returning a TidyEnv
531 tidyMoreInsts env insts
532 = (env', map (tidyInst env') insts)
534 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
536 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
537 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
539 showLIE :: SDoc -> TcM () -- Debugging
541 = do { lie_var <- getLIEVar ;
542 lie <- readMutVar lie_var ;
543 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
547 %************************************************************************
549 Extending the instance environment
551 %************************************************************************
554 tcExtendLocalInstEnv :: [DFunId] -> TcM a -> TcM a
555 -- Add new locally-defined instances
556 tcExtendLocalInstEnv dfuns thing_inside
557 = do { traceDFuns dfuns
560 ; inst_env' <- foldlM (addInst dflags) (tcg_inst_env env) dfuns
561 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
562 tcg_inst_env = inst_env' }
563 ; setGblEnv env' thing_inside }
565 addInst :: DynFlags -> InstEnv -> DFunId -> TcM InstEnv
566 -- Check that the proposed new instance is OK,
567 -- and then add it to the home inst env
568 addInst dflags home_ie dfun
569 = do { -- Instantiate the dfun type so that we extend the instance
570 -- envt with completely fresh template variables
571 -- This is important because the template variables must
572 -- not overlap with anything in the things being looked up
573 -- (since we do unification).
574 -- We use tcSkolType because we don't want to allocate fresh
575 -- *meta* type variables.
576 (tvs', theta', tau') <- tcSkolType (InstSkol dfun) (idType dfun)
577 ; let (cls, tys') = tcSplitDFunHead tau'
578 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
580 -- Load imported instances, so that we report
581 -- duplicates correctly
582 ; pkg_ie <- loadImportedInsts cls tys'
584 -- Check functional dependencies
585 ; case checkFunDeps (pkg_ie, home_ie) dfun' of
586 Just dfuns -> funDepErr dfun dfuns
589 -- Check for duplicate instance decls
590 ; let { (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys'
591 ; dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
592 isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
593 -- Find memebers of the match list which
594 -- dfun itself matches. If the match is 2-way, it's a duplicate
596 dup_dfun : _ -> dupInstErr dfun dup_dfun
599 -- OK, now extend the envt
600 ; return (extendInstEnv home_ie dfun') }
604 = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
606 pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
610 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
611 2 (pprDFuns (dfun:dfuns)))
612 dupInstErr dfun dup_dfun
614 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
615 2 (pprDFuns [dfun, dup_dfun]))
617 addDictLoc dfun thing_inside
618 = setSrcSpan (mkSrcSpan loc loc) thing_inside
624 %************************************************************************
626 \subsection{Looking up Insts}
628 %************************************************************************
631 data LookupInstResult
633 | SimpleInst (LHsExpr TcId) -- Just a variable, type application, or literal
634 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
636 lookupInst :: Inst -> TcM LookupInstResult
637 -- It's important that lookupInst does not put any new stuff into
638 -- the LIE. Instead, any Insts needed by the lookup are returned in
639 -- the LookupInstResult, where they can be further processed by tcSimplify
644 lookupInst inst@(Method _ id tys theta _ loc)
645 = newDictsAtLoc loc theta `thenM` \ dicts ->
646 returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (L span (HsVar id)) tys) (map instToId dicts)))
648 span = instLocSrcSpan loc
652 -- Look for short cuts first: if the literal is *definitely* a
653 -- int, integer, float or a double, generate the real thing here.
654 -- This is essential (see nofib/spectral/nucleic).
655 -- [Same shortcut as in newOverloadedLit, but we
656 -- may have done some unification by now]
659 lookupInst inst@(LitInst _nm (HsIntegral i from_integer_name) ty loc)
660 | Just expr <- shortCutIntLit i ty
661 = returnM (GenInst [] expr) -- GenInst, not SimpleInst, because
662 -- expr may be a constructor application
664 = ASSERT( from_integer_name == fromIntegerName ) -- A LitInst invariant
665 tcLookupId fromIntegerName `thenM` \ from_integer ->
666 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
667 mkIntegerLit i `thenM` \ integer_lit ->
668 returnM (GenInst [method_inst]
669 (mkHsApp (L (instLocSrcSpan loc)
670 (HsVar (instToId method_inst))) integer_lit))
672 lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc)
673 | Just expr <- shortCutFracLit f ty
674 = returnM (GenInst [] expr)
677 = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
678 tcLookupId fromRationalName `thenM` \ from_rational ->
679 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
680 mkRatLit f `thenM` \ rat_lit ->
681 returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc)
682 (HsVar (instToId method_inst))) rat_lit))
685 lookupInst (Dict _ pred loc)
686 = do { mb_result <- lookupPred pred
687 ; case mb_result of {
688 Nothing -> return NoInstance ;
689 Just (tenv, dfun_id) -> do
691 -- tenv is a substitution that instantiates the dfun_id
692 -- to match the requested result type.
694 -- We ASSUME that the dfun is quantified over the very same tyvars
695 -- that are bound by the tenv.
698 -- might have some tyvars that *only* appear in arguments
699 -- dfun :: forall a b. C a b, Ord b => D [a]
700 -- We instantiate b to a flexi type variable -- it'll presumably
701 -- become fixed later via functional dependencies
702 { use_stage <- getStage
703 ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
704 (topIdLvl dfun_id) use_stage
706 -- It's possible that not all the tyvars are in
707 -- the substitution, tenv. For example:
708 -- instance C X a => D X where ...
709 -- (presumably there's a functional dependency in class C)
710 -- Hence the open_tvs to instantiate any un-substituted tyvars.
711 ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
712 open_tvs = filter (`notElemTvSubst` tenv) tyvars
713 ; open_tvs' <- mappM tcInstTyVar open_tvs
715 tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
716 -- Since the open_tvs' are freshly made, they cannot possibly be captured by
717 -- any nested for-alls in rho. So the in-scope set is unchanged
718 dfun_rho = substTy tenv' rho
719 (theta, _) = tcSplitPhiTy dfun_rho
720 ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id))
721 (map (substTyVar tenv') tyvars)
723 returnM (SimpleInst ty_app)
725 { dicts <- newDictsAtLoc loc theta
726 ; let rhs = mkHsDictApp ty_app (map instToId dicts)
727 ; returnM (GenInst dicts rhs)
731 lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
732 -- Look up a class constraint in the instance environment
733 lookupPred pred@(ClassP clas tys)
734 = do { pkg_ie <- loadImportedInsts clas tys
735 -- Suck in any instance decls that may be relevant
736 ; tcg_env <- getGblEnv
738 ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
739 ([(tenv, (_,_,dfun_id))], [])
740 -> do { traceTc (text "lookupInst success" <+>
741 vcat [text "dict" <+> ppr pred,
742 text "witness" <+> ppr dfun_id
743 <+> ppr (idType dfun_id) ])
744 -- Record that this dfun is needed
745 ; record_dfun_usage dfun_id
746 ; return (Just (tenv, dfun_id)) } ;
749 -> do { traceTc (text "lookupInst fail" <+>
750 vcat [text "dict" <+> ppr pred,
751 text "matches" <+> ppr matches,
752 text "unifs" <+> ppr unifs])
753 -- In the case of overlap (multiple matches) we report
754 -- NoInstance here. That has the effect of making the
755 -- context-simplifier return the dict as an irreducible one.
756 -- Then it'll be given to addNoInstanceErrs, which will do another
757 -- lookupInstEnv to get the detailed info about what went wrong.
761 lookupPred ip_pred = return Nothing
763 record_dfun_usage dfun_id
764 = do { dflags <- getDOpts
765 ; let dfun_name = idName dfun_id
766 dfun_mod = nameModule dfun_name
767 ; if isInternalName dfun_name || not (isHomeModule dflags dfun_mod)
768 then return () -- internal, or in another package
769 else do { tcg_env <- getGblEnv
770 ; updMutVar (tcg_inst_uses tcg_env)
771 (`addOneToNameSet` idName dfun_id) }}
774 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
775 -- Gets both the external-package inst-env
776 -- and the home-pkg inst env (includes module being compiled)
777 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
778 return (eps_inst_env eps, tcg_inst_env env) }
783 %************************************************************************
787 %************************************************************************
790 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
791 a do-expression. We have to find (>>) in the current environment, which is
792 done by the rename. Then we have to check that it has the same type as
793 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
796 (>>) :: HB m n mn => m a -> n b -> mn b
798 So the idea is to generate a local binding for (>>), thus:
800 let then72 :: forall a b. m a -> m b -> m b
801 then72 = ...something involving the user's (>>)...
803 ...the do-expression...
805 Now the do-expression can proceed using then72, which has exactly
808 In fact tcSyntaxName just generates the RHS for then72, because we only
809 want an actual binding in the do-expression case. For literals, we can
810 just use the expression inline.
813 tcSyntaxName :: InstOrigin
814 -> TcType -- Type to instantiate it at
815 -> (Name, HsExpr Name) -- (Standard name, user name)
816 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
818 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
819 -- So we do not call it from lookupInst, which is called from tcSimplify
821 tcSyntaxName orig ty (std_nm, HsVar user_nm)
823 = tcStdSyntaxName orig ty std_nm
825 tcSyntaxName orig ty (std_nm, user_nm_expr)
826 = tcLookupId std_nm `thenM` \ std_id ->
828 -- C.f. newMethodAtLoc
829 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
830 sigma1 = substTyWith [tv] [ty] tau
831 -- Actually, the "tau-type" might be a sigma-type in the
832 -- case of locally-polymorphic methods.
834 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $
836 -- Check that the user-supplied thing has the
837 -- same type as the standard one.
838 -- Tiresome jiggling because tcCheckSigma takes a located expression
839 getSrcSpanM `thenM` \ span ->
840 tcCheckSigma (L span user_nm_expr) sigma1 `thenM` \ expr ->
841 returnM (std_nm, unLoc expr)
843 tcStdSyntaxName :: InstOrigin
844 -> TcType -- Type to instantiate it at
845 -> Name -- Standard name
846 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
848 tcStdSyntaxName orig ty std_nm
849 = newMethodFromName orig ty std_nm `thenM` \ id ->
850 returnM (std_nm, HsVar id)
852 syntaxNameCtxt name orig ty tidy_env
853 = getInstLoc orig `thenM` \ inst_loc ->
855 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
856 ptext SLIT("(needed by a syntactic construct)"),
857 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
858 nest 2 (pprInstLoc inst_loc)]
860 returnM (tidy_env, msg)