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 newDicts, newDictAtLoc, newDictsAtLoc, cloneDict,
16 tcOverloadedLit, newIPDict,
17 newMethod, newMethodFromName, newMethodWithGivenTy,
18 tcInstClassOp, tcInstCall, tcInstStupidTheta,
21 tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
22 ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
23 instLoc, getDictClassTys, dictPred,
25 lookupInst, LookupInstResult(..), lookupPred,
26 tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
28 isDict, isClassDict, isMethod,
29 isLinearInst, linearInstType, isIPDict, isInheritableInst,
30 isTyVarDict, isMethodFor,
36 InstOrigin(..), InstLoc(..), pprInstLoc
39 #include "HsVersions.h"
41 import {-# SOURCE #-} TcExpr( tcCheckSigma, tcSyntaxOp )
42 import {-# SOURCE #-} TcUnify ( unifyTauTy ) -- Used in checkKind (sigh)
44 import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp,
46 import TcHsSyn ( TcId, TcIdSet,
47 mkHsTyApp, mkHsDictApp, zonkId,
51 import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
52 import InstEnv ( DFunId, InstEnv, Instance(..), OverlapFlag(..),
53 lookupInstEnv, extendInstEnv, pprInstances,
54 instanceHead, instanceDFunId, setInstanceDFunId )
55 import FunDeps ( checkFunDeps )
56 import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zonkTcThetaType,
57 tcInstTyVar, tcInstType, tcSkolType
59 import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcTyVar, TcPredType,
60 PredType(..), SkolemInfo(..), typeKind, mkSigmaTy,
61 tcSplitForAllTys, mkFunTy,
62 tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunHead,
63 isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
64 mkPredTy, mkTyVarTy, mkTyVarTys,
65 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
66 isClassPred, isTyVarClassPred, isLinearPred,
67 getClassPredTys, getClassPredTys_maybe, mkPredName,
68 isInheritablePred, isIPPred,
69 tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy,
70 pprPred, pprParendType, pprTheta
72 import Type ( TvSubst, substTy, substTyVar, substTyWith, substTheta, zipTopTvSubst,
73 notElemTvSubst, extendTvSubstList )
74 import Unify ( tcMatchTys )
75 import Kind ( isSubKind )
76 import Packages ( isHomeModule )
77 import HscTypes ( ExternalPackageState(..) )
78 import CoreFVs ( idFreeTyVars )
79 import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName, dataConWrapId )
80 import Id ( Id, idName, idType, mkUserLocal, mkLocalId )
81 import PrelInfo ( isStandardClass, isNoDictClass )
82 import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
83 isInternalName, setNameUnique, mkSystemVarNameEncoded )
84 import NameSet ( addOneToNameSet )
85 import Literal ( inIntRange )
86 import Var ( TyVar, tyVarKind, setIdType )
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 UniqSupply( uniqsFromSupply )
93 import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) )
94 import DynFlags ( DynFlag(..), dopt )
95 import Maybes ( isJust )
103 instName :: Inst -> Name
104 instName inst = idName (instToId inst)
106 instToId :: Inst -> TcId
107 instToId (LitInst nm _ ty _) = mkLocalId nm ty
108 instToId (Dict nm pred _) = mkLocalId nm (mkPredTy pred)
109 instToId (Method id _ _ _ _ _) = id
111 instLoc (Dict _ _ loc) = loc
112 instLoc (Method _ _ _ _ _ loc) = loc
113 instLoc (LitInst _ _ _ loc) = loc
115 dictPred (Dict _ pred _ ) = pred
116 dictPred inst = pprPanic "dictPred" (ppr inst)
118 getDictClassTys (Dict _ pred _) = getClassPredTys pred
120 -- fdPredsOfInst is used to get predicates that contain functional
121 -- dependencies *or* might do so. The "might do" part is because
122 -- a constraint (C a b) might have a superclass with FDs
123 -- Leaving these in is really important for the call to fdPredsOfInsts
124 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
125 -- which is supposed to be conservative
126 fdPredsOfInst (Dict _ pred _) = [pred]
127 fdPredsOfInst (Method _ _ _ theta _ _) = theta
128 fdPredsOfInst other = [] -- LitInsts etc
130 fdPredsOfInsts :: [Inst] -> [PredType]
131 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
133 isInheritableInst (Dict _ pred _) = isInheritablePred pred
134 isInheritableInst (Method _ _ _ theta _ _) = all isInheritablePred theta
135 isInheritableInst other = True
138 ipNamesOfInsts :: [Inst] -> [Name]
139 ipNamesOfInst :: Inst -> [Name]
140 -- Get the implicit parameters mentioned by these Insts
141 -- NB: ?x and %x get different Names
142 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
144 ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
145 ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
146 ipNamesOfInst other = []
148 tyVarsOfInst :: Inst -> TcTyVarSet
149 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
150 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
151 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
152 -- The id might have free type variables; in the case of
153 -- locally-overloaded class methods, for example
156 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
157 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
163 isDict :: Inst -> Bool
164 isDict (Dict _ _ _) = True
167 isClassDict :: Inst -> Bool
168 isClassDict (Dict _ pred _) = isClassPred pred
169 isClassDict other = False
171 isTyVarDict :: Inst -> Bool
172 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
173 isTyVarDict other = False
175 isIPDict :: Inst -> Bool
176 isIPDict (Dict _ pred _) = isIPPred pred
177 isIPDict other = False
179 isMethod :: Inst -> Bool
180 isMethod (Method _ _ _ _ _ _) = True
181 isMethod other = False
183 isMethodFor :: TcIdSet -> Inst -> Bool
184 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
185 isMethodFor ids inst = False
187 isLinearInst :: Inst -> Bool
188 isLinearInst (Dict _ pred _) = isLinearPred pred
189 isLinearInst other = False
190 -- We never build Method Insts that have
191 -- linear implicit paramters in them.
192 -- Hence no need to look for Methods
195 linearInstType :: Inst -> TcType -- %x::t --> t
196 linearInstType (Dict _ (IParam _ ty) _) = ty
199 Two predicates which deal with the case where class constraints don't
200 necessarily result in bindings. The first tells whether an @Inst@
201 must be witnessed by an actual binding; the second tells whether an
202 @Inst@ can be generalised over.
205 instBindingRequired :: Inst -> Bool
206 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
207 instBindingRequired other = True
211 %************************************************************************
213 \subsection{Building dictionaries}
215 %************************************************************************
218 newDicts :: InstOrigin
222 = getInstLoc orig `thenM` \ loc ->
223 newDictsAtLoc loc theta
225 cloneDict :: Inst -> TcM Inst
226 cloneDict (Dict nm ty loc) = newUnique `thenM` \ uniq ->
227 returnM (Dict (setNameUnique nm uniq) ty loc)
229 newDictAtLoc :: InstLoc -> TcPredType -> TcM Inst
230 newDictAtLoc inst_loc pred
231 = do { uniq <- newUnique
232 ; return (mkDict inst_loc uniq pred) }
234 newDictsAtLoc :: InstLoc -> TcThetaType -> TcM [Inst]
235 newDictsAtLoc inst_loc theta
236 = newUniqueSupply `thenM` \ us ->
237 returnM (zipWith (mkDict inst_loc) (uniqsFromSupply us) theta)
239 mkDict inst_loc uniq pred
240 = Dict name pred inst_loc
242 name = mkPredName uniq (instLocSrcLoc inst_loc) pred
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 dict = Dict name pred inst_loc
258 returnM (mapIPName (\n -> instToId dict) ip_name, dict)
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 tcOverloadedLit 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 tcOverloadedLit :: InstOrigin
366 -> TcM (HsOverLit TcId)
367 tcOverloadedLit orig lit@(HsIntegral i fi) expected_ty
368 | not (fi `isHsVar` fromIntegerName) -- Do not generate a LitInst for rebindable syntax.
369 -- Reason: If we do, tcSimplify will call lookupInst, which
370 -- will call tcSyntaxName, which does unification,
371 -- which tcSimplify doesn't like
372 -- ToDo: noLoc sadness
373 = do { integer_ty <- tcMetaTy integerTyConName
374 ; fi' <- tcSyntaxOp orig fi (mkFunTy integer_ty expected_ty)
375 ; return (HsIntegral i (HsApp (noLoc fi') (nlHsLit (HsInteger i integer_ty)))) }
377 | Just expr <- shortCutIntLit i expected_ty
378 = return (HsIntegral i expr)
381 = do { expr <- newLitInst orig lit expected_ty
382 ; return (HsIntegral i expr) }
384 tcOverloadedLit orig lit@(HsFractional r fr) expected_ty
385 | not (fr `isHsVar` fromRationalName) -- c.f. HsIntegral case
386 = do { rat_ty <- tcMetaTy rationalTyConName
387 ; fr' <- tcSyntaxOp orig fr (mkFunTy rat_ty expected_ty)
388 ; return (HsFractional r (HsApp (noLoc fr') (nlHsLit (HsRat r rat_ty)))) }
390 | Just expr <- shortCutFracLit r expected_ty
391 = return (HsFractional r expr)
394 = do { expr <- newLitInst orig lit expected_ty
395 ; return (HsFractional r expr) }
397 newLitInst :: InstOrigin -> HsOverLit Name -> TcType -> TcM (HsExpr TcId)
398 newLitInst orig lit expected_ty -- Make a LitInst
399 = do { loc <- getInstLoc orig
400 ; new_uniq <- newUnique
402 lit_nm = mkSystemVarNameEncoded new_uniq FSLIT("lit")
403 -- The "encoded" bit means that we don't need to
404 -- z-encode the string every time we call this!
405 lit_inst = LitInst lit_nm lit expected_ty loc
407 ; return (HsVar (instToId lit_inst)) }
409 shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
411 | isIntTy ty && inIntRange i -- Short cut for Int
412 = Just (HsLit (HsInt i))
413 | isIntegerTy ty -- Short cut for Integer
414 = Just (HsLit (HsInteger i ty))
415 | otherwise = Nothing
417 shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
420 = Just (mk_lit floatDataCon (HsFloatPrim f))
422 = Just (mk_lit doubleDataCon (HsDoublePrim f))
423 | otherwise = Nothing
425 mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
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))
439 isHsVar :: HsExpr Name -> Name -> Bool
440 isHsVar (HsVar f) g = f==g
441 isHsVar other g = False
445 %************************************************************************
449 %************************************************************************
451 Zonking makes sure that the instance types are fully zonked.
454 zonkInst :: Inst -> TcM Inst
455 zonkInst (Dict name pred loc)
456 = zonkTcPredType pred `thenM` \ new_pred ->
457 returnM (Dict name new_pred loc)
459 zonkInst (Method m id tys theta tau loc)
460 = zonkId id `thenM` \ new_id ->
461 -- Essential to zonk the id in case it's a local variable
462 -- Can't use zonkIdOcc because the id might itself be
463 -- an InstId, in which case it won't be in scope
465 zonkTcTypes tys `thenM` \ new_tys ->
466 zonkTcThetaType theta `thenM` \ new_theta ->
467 zonkTcType tau `thenM` \ new_tau ->
468 returnM (Method m new_id new_tys new_theta new_tau loc)
470 zonkInst (LitInst nm lit ty loc)
471 = zonkTcType ty `thenM` \ new_ty ->
472 returnM (LitInst nm lit new_ty loc)
474 zonkInsts insts = mappM zonkInst insts
478 %************************************************************************
480 \subsection{Printing}
482 %************************************************************************
484 ToDo: improve these pretty-printing things. The ``origin'' is really only
485 relevant in error messages.
488 instance Outputable Inst where
489 ppr inst = pprInst inst
491 pprDictsTheta :: [Inst] -> SDoc
492 -- Print in type-like fashion (Eq a, Show b)
493 pprDictsTheta dicts = pprTheta (map dictPred dicts)
495 pprDictsInFull :: [Inst] -> SDoc
496 -- Print in type-like fashion, but with source location
498 = vcat (map go dicts)
500 go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))]
502 pprInsts :: [Inst] -> SDoc
503 -- Debugging: print the evidence :: type
504 pprInsts insts = brackets (interpp'SP insts)
506 pprInst, pprInstInFull :: Inst -> SDoc
507 -- Debugging: print the evidence :: type
508 pprInst (LitInst nm lit ty loc) = ppr nm <+> dcolon <+> ppr ty
509 pprInst (Dict nm pred loc) = ppr nm <+> dcolon <+> pprPred pred
511 pprInst m@(Method inst_id id tys theta tau loc)
512 = ppr inst_id <+> dcolon <+>
513 braces (sep [ppr id <+> ptext SLIT("at"),
514 brackets (sep (map pprParendType tys))])
517 = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
519 tidyInst :: TidyEnv -> Inst -> Inst
520 tidyInst env (LitInst nm lit ty loc) = LitInst nm lit (tidyType env ty) loc
521 tidyInst env (Dict nm pred loc) = Dict nm (tidyPred env pred) loc
522 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
524 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
525 -- This function doesn't assume that the tyvars are in scope
526 -- so it works like tidyOpenType, returning a TidyEnv
527 tidyMoreInsts env insts
528 = (env', map (tidyInst env') insts)
530 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
532 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
533 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
535 showLIE :: SDoc -> TcM () -- Debugging
537 = do { lie_var <- getLIEVar ;
538 lie <- readMutVar lie_var ;
539 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
543 %************************************************************************
545 Extending the instance environment
547 %************************************************************************
550 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
551 -- Add new locally-defined instances
552 tcExtendLocalInstEnv dfuns thing_inside
553 = do { traceDFuns dfuns
555 ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
556 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
557 tcg_inst_env = inst_env' }
558 ; setGblEnv env' thing_inside }
560 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
561 -- Check that the proposed new instance is OK,
562 -- and then add it to the home inst env
563 addLocalInst home_ie ispec
564 = do { -- Instantiate the dfun type so that we extend the instance
565 -- envt with completely fresh template variables
566 -- This is important because the template variables must
567 -- not overlap with anything in the things being looked up
568 -- (since we do unification).
569 -- We use tcSkolType because we don't want to allocate fresh
570 -- *meta* type variables.
571 let dfun = instanceDFunId ispec
572 ; (tvs', theta', tau') <- tcSkolType (InstSkol dfun) (idType dfun)
573 ; let (cls, tys') = tcSplitDFunHead tau'
574 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
575 ispec' = setInstanceDFunId ispec dfun'
577 -- Load imported instances, so that we report
578 -- duplicates correctly
580 ; let inst_envs = (eps_inst_env eps, home_ie)
582 -- Check functional dependencies
583 ; case checkFunDeps inst_envs ispec' of
584 Just specs -> funDepErr ispec' specs
587 -- Check for duplicate instance decls
588 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
589 ; dup_ispecs = [ dup_ispec
590 | (_, dup_ispec) <- matches
591 , let (_,_,_,dup_tys) = instanceHead dup_ispec
592 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
593 -- Find memebers of the match list which ispec itself matches.
594 -- If the match is 2-way, it's a duplicate
596 dup_ispec : _ -> dupInstErr ispec' dup_ispec
599 -- OK, now extend the envt
600 ; return (extendInstEnv home_ie ispec') }
602 getOverlapFlag :: TcM OverlapFlag
604 = do { dflags <- getDOpts
605 ; let overlap_ok = dopt Opt_AllowOverlappingInstances dflags
606 incoherent_ok = dopt Opt_AllowIncoherentInstances dflags
607 overlap_flag | incoherent_ok = Incoherent
608 | overlap_ok = OverlapOk
609 | otherwise = NoOverlap
611 ; return overlap_flag }
614 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
616 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
617 -- Print the dfun name itself too
619 funDepErr ispec ispecs
621 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
622 2 (pprInstances (ispec:ispecs)))
623 dupInstErr ispec dup_ispec
625 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
626 2 (pprInstances [ispec, dup_ispec]))
628 addDictLoc ispec thing_inside
629 = setSrcSpan (mkSrcSpan loc loc) thing_inside
631 loc = getSrcLoc ispec
635 %************************************************************************
637 \subsection{Looking up Insts}
639 %************************************************************************
642 data LookupInstResult
644 | SimpleInst (LHsExpr TcId) -- Just a variable, type application, or literal
645 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
647 lookupInst :: Inst -> TcM LookupInstResult
648 -- It's important that lookupInst does not put any new stuff into
649 -- the LIE. Instead, any Insts needed by the lookup are returned in
650 -- the LookupInstResult, where they can be further processed by tcSimplify
655 lookupInst inst@(Method _ id tys theta _ loc)
656 = newDictsAtLoc loc theta `thenM` \ dicts ->
657 returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (L span (HsVar id)) tys) (map instToId dicts)))
659 span = instLocSrcSpan loc
663 -- Look for short cuts first: if the literal is *definitely* a
664 -- int, integer, float or a double, generate the real thing here.
665 -- This is essential (see nofib/spectral/nucleic).
666 -- [Same shortcut as in newOverloadedLit, but we
667 -- may have done some unification by now]
669 lookupInst inst@(LitInst _nm (HsIntegral i from_integer_name) ty loc)
670 | Just expr <- shortCutIntLit i ty
671 = returnM (GenInst [] (noLoc expr)) -- GenInst, not SimpleInst, because
672 -- expr may be a constructor application
674 = ASSERT( from_integer_name `isHsVar` fromIntegerName ) -- A LitInst invariant
675 tcLookupId fromIntegerName `thenM` \ from_integer ->
676 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
677 mkIntegerLit i `thenM` \ integer_lit ->
678 returnM (GenInst [method_inst]
679 (mkHsApp (L (instLocSrcSpan loc)
680 (HsVar (instToId method_inst))) integer_lit))
682 lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc)
683 | Just expr <- shortCutFracLit f ty
684 = returnM (GenInst [] (noLoc expr))
687 = ASSERT( from_rat_name `isHsVar` fromRationalName ) -- A LitInst invariant
688 tcLookupId fromRationalName `thenM` \ from_rational ->
689 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
690 mkRatLit f `thenM` \ rat_lit ->
691 returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc)
692 (HsVar (instToId method_inst))) rat_lit))
695 lookupInst (Dict _ pred loc)
696 = do { mb_result <- lookupPred pred
697 ; case mb_result of {
698 Nothing -> return NoInstance ;
699 Just (tenv, dfun_id) -> do
701 -- tenv is a substitution that instantiates the dfun_id
702 -- to match the requested result type.
704 -- We ASSUME that the dfun is quantified over the very same tyvars
705 -- that are bound by the tenv.
708 -- might have some tyvars that *only* appear in arguments
709 -- dfun :: forall a b. C a b, Ord b => D [a]
710 -- We instantiate b to a flexi type variable -- it'll presumably
711 -- become fixed later via functional dependencies
712 { use_stage <- getStage
713 ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
714 (topIdLvl dfun_id) use_stage
716 -- It's possible that not all the tyvars are in
717 -- the substitution, tenv. For example:
718 -- instance C X a => D X where ...
719 -- (presumably there's a functional dependency in class C)
720 -- Hence the open_tvs to instantiate any un-substituted tyvars.
721 ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
722 open_tvs = filter (`notElemTvSubst` tenv) tyvars
723 ; open_tvs' <- mappM tcInstTyVar open_tvs
725 tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
726 -- Since the open_tvs' are freshly made, they cannot possibly be captured by
727 -- any nested for-alls in rho. So the in-scope set is unchanged
728 dfun_rho = substTy tenv' rho
729 (theta, _) = tcSplitPhiTy dfun_rho
730 ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id))
731 (map (substTyVar tenv') tyvars)
733 returnM (SimpleInst ty_app)
735 { dicts <- newDictsAtLoc loc theta
736 ; let rhs = mkHsDictApp ty_app (map instToId dicts)
737 ; returnM (GenInst dicts rhs)
741 lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
742 -- Look up a class constraint in the instance environment
743 lookupPred pred@(ClassP clas tys)
745 ; tcg_env <- getGblEnv
746 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
747 ; case lookupInstEnv inst_envs clas tys of {
748 ([(tenv, ispec)], [])
749 -> do { let dfun_id = is_dfun ispec
750 ; traceTc (text "lookupInst success" <+>
751 vcat [text "dict" <+> ppr pred,
752 text "witness" <+> ppr dfun_id
753 <+> ppr (idType dfun_id) ])
754 -- Record that this dfun is needed
755 ; record_dfun_usage dfun_id
756 ; return (Just (tenv, dfun_id)) } ;
759 -> do { traceTc (text "lookupInst fail" <+>
760 vcat [text "dict" <+> ppr pred,
761 text "matches" <+> ppr matches,
762 text "unifs" <+> ppr unifs])
763 -- In the case of overlap (multiple matches) we report
764 -- NoInstance here. That has the effect of making the
765 -- context-simplifier return the dict as an irreducible one.
766 -- Then it'll be given to addNoInstanceErrs, which will do another
767 -- lookupInstEnv to get the detailed info about what went wrong.
771 lookupPred ip_pred = return Nothing
773 record_dfun_usage dfun_id
774 = do { gbl <- getGblEnv
775 ; let dfun_name = idName dfun_id
776 dfun_mod = nameModule dfun_name
777 ; if isInternalName dfun_name || -- Internal name => defined in this module
778 not (isHomeModule (tcg_home_mods gbl) dfun_mod)
779 then return () -- internal, or in another package
780 else do { tcg_env <- getGblEnv
781 ; updMutVar (tcg_inst_uses tcg_env)
782 (`addOneToNameSet` idName dfun_id) }}
785 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
786 -- Gets both the external-package inst-env
787 -- and the home-pkg inst env (includes module being compiled)
788 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
789 return (eps_inst_env eps, tcg_inst_env env) }
794 %************************************************************************
798 %************************************************************************
800 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
801 a do-expression. We have to find (>>) in the current environment, which is
802 done by the rename. Then we have to check that it has the same type as
803 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
806 (>>) :: HB m n mn => m a -> n b -> mn b
808 So the idea is to generate a local binding for (>>), thus:
810 let then72 :: forall a b. m a -> m b -> m b
811 then72 = ...something involving the user's (>>)...
813 ...the do-expression...
815 Now the do-expression can proceed using then72, which has exactly
818 In fact tcSyntaxName just generates the RHS for then72, because we only
819 want an actual binding in the do-expression case. For literals, we can
820 just use the expression inline.
823 tcSyntaxName :: InstOrigin
824 -> TcType -- Type to instantiate it at
825 -> (Name, HsExpr Name) -- (Standard name, user name)
826 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
827 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
828 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
829 -- So we do not call it from lookupInst, which is called from tcSimplify
831 tcSyntaxName orig ty (std_nm, HsVar user_nm)
833 = newMethodFromName orig ty std_nm `thenM` \ id ->
834 returnM (std_nm, HsVar id)
836 tcSyntaxName orig ty (std_nm, user_nm_expr)
837 = tcLookupId std_nm `thenM` \ std_id ->
839 -- C.f. newMethodAtLoc
840 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
841 sigma1 = substTyWith [tv] [ty] tau
842 -- Actually, the "tau-type" might be a sigma-type in the
843 -- case of locally-polymorphic methods.
845 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $
847 -- Check that the user-supplied thing has the
848 -- same type as the standard one.
849 -- Tiresome jiggling because tcCheckSigma takes a located expression
850 getSrcSpanM `thenM` \ span ->
851 tcCheckSigma (L span user_nm_expr) sigma1 `thenM` \ expr ->
852 returnM (std_nm, unLoc expr)
854 syntaxNameCtxt name orig ty tidy_env
855 = getInstLoc orig `thenM` \ inst_loc ->
857 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
858 ptext SLIT("(needed by a syntactic construct)"),
859 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
860 nest 2 (pprInstLoc inst_loc)]
862 returnM (tidy_env, msg)