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, isStdClassTyVarDict, 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, tcSplitForAllTys, mkFunTy,
62 tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunHead,
63 isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
64 tcIsTyVarTy, 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 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
200 Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
204 Two predicates which deal with the case where class constraints don't
205 necessarily result in bindings. The first tells whether an @Inst@
206 must be witnessed by an actual binding; the second tells whether an
207 @Inst@ can be generalised over.
210 instBindingRequired :: Inst -> Bool
211 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
212 instBindingRequired other = True
216 %************************************************************************
218 \subsection{Building dictionaries}
220 %************************************************************************
223 newDicts :: InstOrigin
227 = getInstLoc orig `thenM` \ loc ->
228 newDictsAtLoc loc theta
230 cloneDict :: Inst -> TcM Inst
231 cloneDict (Dict nm ty loc) = newUnique `thenM` \ uniq ->
232 returnM (Dict (setNameUnique nm uniq) ty loc)
234 newDictAtLoc :: InstLoc -> TcPredType -> TcM Inst
235 newDictAtLoc inst_loc pred
236 = do { uniq <- newUnique
237 ; return (mkDict inst_loc uniq pred) }
239 newDictsAtLoc :: InstLoc -> TcThetaType -> TcM [Inst]
240 newDictsAtLoc inst_loc theta
241 = newUniqueSupply `thenM` \ us ->
242 returnM (zipWith (mkDict inst_loc) (uniqsFromSupply us) theta)
244 mkDict inst_loc uniq pred
245 = Dict name pred inst_loc
247 name = mkPredName uniq (instLocSrcLoc inst_loc) pred
249 -- For vanilla implicit parameters, there is only one in scope
250 -- at any time, so we used to use the name of the implicit parameter itself
251 -- But with splittable implicit parameters there may be many in
252 -- scope, so we make up a new name.
253 newIPDict :: InstOrigin -> IPName Name -> Type
254 -> TcM (IPName Id, Inst)
255 newIPDict orig ip_name ty
256 = getInstLoc orig `thenM` \ inst_loc ->
257 newUnique `thenM` \ uniq ->
259 pred = IParam ip_name ty
260 name = mkPredName uniq (instLocSrcLoc inst_loc) pred
261 dict = Dict name pred inst_loc
263 returnM (mapIPName (\n -> instToId dict) ip_name, dict)
268 %************************************************************************
270 \subsection{Building methods (calls of overloaded functions)}
272 %************************************************************************
276 tcInstCall :: InstOrigin -> TcType -> TcM (ExprCoFn, [TcTyVar], TcType)
277 tcInstCall orig fun_ty -- fun_ty is usually a sigma-type
278 = do { (tyvars, theta, tau) <- tcInstType fun_ty
279 ; dicts <- newDicts orig theta
281 ; let inst_fn e = unLoc (mkHsDictApp (mkHsTyApp (noLoc e) (mkTyVarTys tyvars))
282 (map instToId dicts))
283 ; return (mkCoercion inst_fn, tyvars, tau) }
285 tcInstStupidTheta :: DataCon -> [TcType] -> TcM ()
286 -- Instantiate the "stupid theta" of the data con, and throw
287 -- the constraints into the constraint set
288 tcInstStupidTheta data_con inst_tys
292 = do { stupid_dicts <- newDicts (OccurrenceOf (dataConName data_con))
293 (substTheta tenv stupid_theta)
294 ; extendLIEs stupid_dicts }
296 stupid_theta = dataConStupidTheta data_con
297 tenv = zipTopTvSubst (dataConTyVars data_con) inst_tys
299 newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId
300 newMethodFromName origin ty name
301 = tcLookupId name `thenM` \ id ->
302 -- Use tcLookupId not tcLookupGlobalId; the method is almost
303 -- always a class op, but with -fno-implicit-prelude GHC is
304 -- meant to find whatever thing is in scope, and that may
305 -- be an ordinary function.
306 getInstLoc origin `thenM` \ loc ->
307 tcInstClassOp loc id [ty] `thenM` \ inst ->
308 extendLIE inst `thenM_`
309 returnM (instToId inst)
311 newMethodWithGivenTy orig id tys theta tau
312 = getInstLoc orig `thenM` \ loc ->
313 newMethod loc id tys theta tau `thenM` \ inst ->
314 extendLIE inst `thenM_`
315 returnM (instToId inst)
317 --------------------------------------------
318 -- tcInstClassOp, and newMethod do *not* drop the
319 -- Inst into the LIE; they just returns the Inst
320 -- This is important because they are used by TcSimplify
323 -- NB: the kind of the type variable to be instantiated
324 -- might be a sub-kind of the type to which it is applied,
325 -- notably when the latter is a type variable of kind ??
326 -- Hence the call to checkKind
327 -- A worry: is this needed anywhere else?
328 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
329 tcInstClassOp inst_loc sel_id tys
331 (tyvars,rho) = tcSplitForAllTys (idType sel_id)
332 rho_ty = ASSERT( length tyvars == length tys )
333 substTyWith tyvars tys rho
334 (preds,tau) = tcSplitPhiTy rho_ty
336 zipWithM_ checkKind tyvars tys `thenM_`
337 newMethod inst_loc sel_id tys preds tau
339 checkKind :: TyVar -> TcType -> TcM ()
340 -- Ensure that the type has a sub-kind of the tyvar
342 = do { ty1 <- zonkTcType ty
343 ; if typeKind ty1 `isSubKind` tyVarKind tv
346 { traceTc (text "checkKind: adding kind constraint" <+> ppr tv <+> ppr ty)
347 ; tv1 <- tcInstTyVar tv
348 ; unifyTauTy (mkTyVarTy tv1) ty1 }}
351 ---------------------------
352 newMethod inst_loc id tys theta tau
353 = newUnique `thenM` \ new_uniq ->
355 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
356 inst = Method meth_id id tys theta tau inst_loc
357 loc = instLocSrcLoc inst_loc
362 In tcOverloadedLit we convert directly to an Int or Integer if we
363 know that's what we want. This may save some time, by not
364 temporarily generating overloaded literals, but it won't catch all
365 cases (the rest are caught in lookupInst).
368 tcOverloadedLit :: InstOrigin
371 -> TcM (HsOverLit TcId)
372 tcOverloadedLit orig lit@(HsIntegral i fi) expected_ty
373 | not (fi `isHsVar` fromIntegerName) -- Do not generate a LitInst for rebindable syntax.
374 -- Reason: If we do, tcSimplify will call lookupInst, which
375 -- will call tcSyntaxName, which does unification,
376 -- which tcSimplify doesn't like
377 -- ToDo: noLoc sadness
378 = do { integer_ty <- tcMetaTy integerTyConName
379 ; fi' <- tcSyntaxOp orig fi (mkFunTy integer_ty expected_ty)
380 ; return (HsIntegral i (HsApp (noLoc fi') (nlHsLit (HsInteger i integer_ty)))) }
382 | Just expr <- shortCutIntLit i expected_ty
383 = return (HsIntegral i expr)
386 = do { expr <- newLitInst orig lit expected_ty
387 ; return (HsIntegral i expr) }
389 tcOverloadedLit orig lit@(HsFractional r fr) expected_ty
390 | not (fr `isHsVar` fromRationalName) -- c.f. HsIntegral case
391 = do { rat_ty <- tcMetaTy rationalTyConName
392 ; fr' <- tcSyntaxOp orig fr (mkFunTy rat_ty expected_ty)
393 ; return (HsFractional r (HsApp (noLoc fr') (nlHsLit (HsRat r rat_ty)))) }
395 | Just expr <- shortCutFracLit r expected_ty
396 = return (HsFractional r expr)
399 = do { expr <- newLitInst orig lit expected_ty
400 ; return (HsFractional r expr) }
402 newLitInst :: InstOrigin -> HsOverLit Name -> TcType -> TcM (HsExpr TcId)
403 newLitInst orig lit expected_ty -- Make a LitInst
404 = do { loc <- getInstLoc orig
405 ; new_uniq <- newUnique
407 lit_nm = mkSystemVarNameEncoded new_uniq FSLIT("lit")
408 -- The "encoded" bit means that we don't need to
409 -- z-encode the string every time we call this!
410 lit_inst = LitInst lit_nm lit expected_ty loc
412 ; return (HsVar (instToId lit_inst)) }
414 shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
416 | isIntTy ty && inIntRange i -- Short cut for Int
417 = Just (HsLit (HsInt i))
418 | isIntegerTy ty -- Short cut for Integer
419 = Just (HsLit (HsInteger i ty))
420 | otherwise = Nothing
422 shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
425 = Just (mk_lit floatDataCon (HsFloatPrim f))
427 = Just (mk_lit doubleDataCon (HsDoublePrim f))
428 | otherwise = Nothing
430 mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
432 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
434 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
435 getSrcSpanM `thenM` \ span ->
436 returnM (L span $ HsLit (HsInteger i integer_ty))
438 mkRatLit :: Rational -> TcM (LHsExpr TcId)
440 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
441 getSrcSpanM `thenM` \ span ->
442 returnM (L span $ HsLit (HsRat r rat_ty))
444 isHsVar :: HsExpr Name -> Name -> Bool
445 isHsVar (HsVar f) g = f==g
446 isHsVar other g = False
450 %************************************************************************
454 %************************************************************************
456 Zonking makes sure that the instance types are fully zonked.
459 zonkInst :: Inst -> TcM Inst
460 zonkInst (Dict name pred loc)
461 = zonkTcPredType pred `thenM` \ new_pred ->
462 returnM (Dict name new_pred loc)
464 zonkInst (Method m id tys theta tau loc)
465 = zonkId id `thenM` \ new_id ->
466 -- Essential to zonk the id in case it's a local variable
467 -- Can't use zonkIdOcc because the id might itself be
468 -- an InstId, in which case it won't be in scope
470 zonkTcTypes tys `thenM` \ new_tys ->
471 zonkTcThetaType theta `thenM` \ new_theta ->
472 zonkTcType tau `thenM` \ new_tau ->
473 returnM (Method m new_id new_tys new_theta new_tau loc)
475 zonkInst (LitInst nm lit ty loc)
476 = zonkTcType ty `thenM` \ new_ty ->
477 returnM (LitInst nm lit new_ty loc)
479 zonkInsts insts = mappM zonkInst insts
483 %************************************************************************
485 \subsection{Printing}
487 %************************************************************************
489 ToDo: improve these pretty-printing things. The ``origin'' is really only
490 relevant in error messages.
493 instance Outputable Inst where
494 ppr inst = pprInst inst
496 pprDictsTheta :: [Inst] -> SDoc
497 -- Print in type-like fashion (Eq a, Show b)
498 pprDictsTheta dicts = pprTheta (map dictPred dicts)
500 pprDictsInFull :: [Inst] -> SDoc
501 -- Print in type-like fashion, but with source location
503 = vcat (map go dicts)
505 go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))]
507 pprInsts :: [Inst] -> SDoc
508 -- Debugging: print the evidence :: type
509 pprInsts insts = brackets (interpp'SP insts)
511 pprInst, pprInstInFull :: Inst -> SDoc
512 -- Debugging: print the evidence :: type
513 pprInst (LitInst nm lit ty loc) = ppr nm <+> dcolon <+> ppr ty
514 pprInst (Dict nm pred loc) = ppr nm <+> dcolon <+> pprPred pred
516 pprInst m@(Method inst_id id tys theta tau loc)
517 = ppr inst_id <+> dcolon <+>
518 braces (sep [ppr id <+> ptext SLIT("at"),
519 brackets (sep (map pprParendType tys))])
522 = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
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 :: [Instance] -> TcM a -> TcM a
556 -- Add new locally-defined instances
557 tcExtendLocalInstEnv dfuns thing_inside
558 = do { traceDFuns dfuns
560 ; inst_env' <- foldlM addLocalInst (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 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
566 -- Check that the proposed new instance is OK,
567 -- and then add it to the home inst env
568 addLocalInst home_ie ispec
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 let dfun = instanceDFunId ispec
577 ; (tvs', theta', tau') <- tcSkolType (InstSkol dfun) (idType dfun)
578 ; let (cls, tys') = tcSplitDFunHead tau'
579 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
580 ispec' = setInstanceDFunId ispec dfun'
582 -- Load imported instances, so that we report
583 -- duplicates correctly
585 ; let inst_envs = (eps_inst_env eps, home_ie)
587 -- Check functional dependencies
588 ; case checkFunDeps inst_envs ispec' of
589 Just specs -> funDepErr ispec' specs
592 -- Check for duplicate instance decls
593 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
594 ; dup_ispecs = [ dup_ispec
595 | (_, dup_ispec) <- matches
596 , let (_,_,_,dup_tys) = instanceHead dup_ispec
597 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
598 -- Find memebers of the match list which ispec itself matches.
599 -- If the match is 2-way, it's a duplicate
601 dup_ispec : _ -> dupInstErr ispec' dup_ispec
604 -- OK, now extend the envt
605 ; return (extendInstEnv home_ie ispec') }
607 getOverlapFlag :: TcM OverlapFlag
609 = do { dflags <- getDOpts
610 ; let overlap_ok = dopt Opt_AllowOverlappingInstances dflags
611 incoherent_ok = dopt Opt_AllowIncoherentInstances dflags
612 overlap_flag | incoherent_ok = Incoherent
613 | overlap_ok = OverlapOk
614 | otherwise = NoOverlap
616 ; return overlap_flag }
619 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
621 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
622 -- Print the dfun name itself too
624 funDepErr ispec ispecs
626 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
627 2 (pprInstances (ispec:ispecs)))
628 dupInstErr ispec dup_ispec
630 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
631 2 (pprInstances [ispec, dup_ispec]))
633 addDictLoc ispec thing_inside
634 = setSrcSpan (mkSrcSpan loc loc) thing_inside
636 loc = getSrcLoc ispec
640 %************************************************************************
642 \subsection{Looking up Insts}
644 %************************************************************************
647 data LookupInstResult
649 | SimpleInst (LHsExpr TcId) -- Just a variable, type application, or literal
650 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
652 lookupInst :: Inst -> TcM LookupInstResult
653 -- It's important that lookupInst does not put any new stuff into
654 -- the LIE. Instead, any Insts needed by the lookup are returned in
655 -- the LookupInstResult, where they can be further processed by tcSimplify
660 lookupInst inst@(Method _ id tys theta _ loc)
661 = newDictsAtLoc loc theta `thenM` \ dicts ->
662 returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (L span (HsVar id)) tys) (map instToId dicts)))
664 span = instLocSrcSpan loc
668 -- Look for short cuts first: if the literal is *definitely* a
669 -- int, integer, float or a double, generate the real thing here.
670 -- This is essential (see nofib/spectral/nucleic).
671 -- [Same shortcut as in newOverloadedLit, but we
672 -- may have done some unification by now]
674 lookupInst inst@(LitInst _nm (HsIntegral i from_integer_name) ty loc)
675 | Just expr <- shortCutIntLit i ty
676 = returnM (GenInst [] (noLoc expr)) -- GenInst, not SimpleInst, because
677 -- expr may be a constructor application
679 = ASSERT( from_integer_name `isHsVar` fromIntegerName ) -- A LitInst invariant
680 tcLookupId fromIntegerName `thenM` \ from_integer ->
681 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
682 mkIntegerLit i `thenM` \ integer_lit ->
683 returnM (GenInst [method_inst]
684 (mkHsApp (L (instLocSrcSpan loc)
685 (HsVar (instToId method_inst))) integer_lit))
687 lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc)
688 | Just expr <- shortCutFracLit f ty
689 = returnM (GenInst [] (noLoc expr))
692 = ASSERT( from_rat_name `isHsVar` fromRationalName ) -- A LitInst invariant
693 tcLookupId fromRationalName `thenM` \ from_rational ->
694 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
695 mkRatLit f `thenM` \ rat_lit ->
696 returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc)
697 (HsVar (instToId method_inst))) rat_lit))
700 lookupInst (Dict _ pred loc)
701 = do { mb_result <- lookupPred pred
702 ; case mb_result of {
703 Nothing -> return NoInstance ;
704 Just (tenv, dfun_id) -> do
706 -- tenv is a substitution that instantiates the dfun_id
707 -- to match the requested result type.
709 -- We ASSUME that the dfun is quantified over the very same tyvars
710 -- that are bound by the tenv.
713 -- might have some tyvars that *only* appear in arguments
714 -- dfun :: forall a b. C a b, Ord b => D [a]
715 -- We instantiate b to a flexi type variable -- it'll presumably
716 -- become fixed later via functional dependencies
717 { use_stage <- getStage
718 ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
719 (topIdLvl dfun_id) use_stage
721 -- It's possible that not all the tyvars are in
722 -- the substitution, tenv. For example:
723 -- instance C X a => D X where ...
724 -- (presumably there's a functional dependency in class C)
725 -- Hence the open_tvs to instantiate any un-substituted tyvars.
726 ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
727 open_tvs = filter (`notElemTvSubst` tenv) tyvars
728 ; open_tvs' <- mappM tcInstTyVar open_tvs
730 tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
731 -- Since the open_tvs' are freshly made, they cannot possibly be captured by
732 -- any nested for-alls in rho. So the in-scope set is unchanged
733 dfun_rho = substTy tenv' rho
734 (theta, _) = tcSplitPhiTy dfun_rho
735 ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id))
736 (map (substTyVar tenv') tyvars)
738 returnM (SimpleInst ty_app)
740 { dicts <- newDictsAtLoc loc theta
741 ; let rhs = mkHsDictApp ty_app (map instToId dicts)
742 ; returnM (GenInst dicts rhs)
746 lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
747 -- Look up a class constraint in the instance environment
748 lookupPred pred@(ClassP clas tys)
750 ; tcg_env <- getGblEnv
751 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
752 ; case lookupInstEnv inst_envs clas tys of {
753 ([(tenv, ispec)], [])
754 -> do { let dfun_id = is_dfun ispec
755 ; traceTc (text "lookupInst success" <+>
756 vcat [text "dict" <+> ppr pred,
757 text "witness" <+> ppr dfun_id
758 <+> ppr (idType dfun_id) ])
759 -- Record that this dfun is needed
760 ; record_dfun_usage dfun_id
761 ; return (Just (tenv, dfun_id)) } ;
764 -> do { traceTc (text "lookupInst fail" <+>
765 vcat [text "dict" <+> ppr pred,
766 text "matches" <+> ppr matches,
767 text "unifs" <+> ppr unifs])
768 -- In the case of overlap (multiple matches) we report
769 -- NoInstance here. That has the effect of making the
770 -- context-simplifier return the dict as an irreducible one.
771 -- Then it'll be given to addNoInstanceErrs, which will do another
772 -- lookupInstEnv to get the detailed info about what went wrong.
776 lookupPred ip_pred = return Nothing
778 record_dfun_usage dfun_id
779 = do { dflags <- getDOpts
780 ; let dfun_name = idName dfun_id
781 dfun_mod = nameModule dfun_name
782 ; if isInternalName dfun_name || -- Internal name => defined in this module
783 not (isHomeModule dflags dfun_mod)
784 then return () -- internal, or in another package
785 else do { tcg_env <- getGblEnv
786 ; updMutVar (tcg_inst_uses tcg_env)
787 (`addOneToNameSet` idName dfun_id) }}
790 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
791 -- Gets both the external-package inst-env
792 -- and the home-pkg inst env (includes module being compiled)
793 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
794 return (eps_inst_env eps, tcg_inst_env env) }
799 %************************************************************************
803 %************************************************************************
805 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
806 a do-expression. We have to find (>>) in the current environment, which is
807 done by the rename. Then we have to check that it has the same type as
808 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
811 (>>) :: HB m n mn => m a -> n b -> mn b
813 So the idea is to generate a local binding for (>>), thus:
815 let then72 :: forall a b. m a -> m b -> m b
816 then72 = ...something involving the user's (>>)...
818 ...the do-expression...
820 Now the do-expression can proceed using then72, which has exactly
823 In fact tcSyntaxName just generates the RHS for then72, because we only
824 want an actual binding in the do-expression case. For literals, we can
825 just use the expression inline.
828 tcSyntaxName :: InstOrigin
829 -> TcType -- Type to instantiate it at
830 -> (Name, HsExpr Name) -- (Standard name, user name)
831 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
832 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
833 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
834 -- So we do not call it from lookupInst, which is called from tcSimplify
836 tcSyntaxName orig ty (std_nm, HsVar user_nm)
838 = newMethodFromName orig ty std_nm `thenM` \ id ->
839 returnM (std_nm, HsVar id)
841 tcSyntaxName orig ty (std_nm, user_nm_expr)
842 = tcLookupId std_nm `thenM` \ std_id ->
844 -- C.f. newMethodAtLoc
845 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
846 sigma1 = substTyWith [tv] [ty] tau
847 -- Actually, the "tau-type" might be a sigma-type in the
848 -- case of locally-polymorphic methods.
850 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $
852 -- Check that the user-supplied thing has the
853 -- same type as the standard one.
854 -- Tiresome jiggling because tcCheckSigma takes a located expression
855 getSrcSpanM `thenM` \ span ->
856 tcCheckSigma (L span user_nm_expr) sigma1 `thenM` \ expr ->
857 returnM (std_nm, unLoc expr)
859 syntaxNameCtxt name orig ty tidy_env
860 = getInstLoc orig `thenM` \ inst_loc ->
862 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
863 ptext SLIT("(needed by a syntactic construct)"),
864 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
865 nest 2 (pprInstLoc inst_loc)]
867 returnM (tidy_env, msg)