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 ( mkHsTyApp, mkHsDictApp, zonkId,
50 import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
51 import InstEnv ( DFunId, InstEnv, Instance(..), OverlapFlag(..),
52 lookupInstEnv, extendInstEnv, pprInstances,
53 instanceHead, instanceDFunId, setInstanceDFunId )
54 import FunDeps ( checkFunDeps )
55 import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zonkTcThetaType,
56 tcInstTyVar, tcInstType, tcSkolType
58 import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcTyVar, TcPredType,
59 PredType(..), SkolemInfo(..), typeKind, mkSigmaTy,
60 tcSplitForAllTys, mkFunTy,
61 tcSplitPhiTy, tcSplitDFunHead,
62 isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
63 mkPredTy, mkTyVarTy, mkTyVarTys,
64 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
65 isClassPred, isTyVarClassPred, isLinearPred,
66 getClassPredTys, mkPredName,
67 isInheritablePred, isIPPred,
68 tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy,
69 pprPred, pprParendType, pprTheta
71 import Type ( TvSubst, substTy, substTyVar, substTyWith, substTheta, zipTopTvSubst,
72 notElemTvSubst, extendTvSubstList )
73 import Unify ( tcMatchTys )
74 import Kind ( isSubKind )
75 import Packages ( isHomeModule )
76 import HscTypes ( ExternalPackageState(..) )
77 import CoreFVs ( idFreeTyVars )
78 import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName, dataConWrapId )
79 import Id ( Id, idName, idType, mkUserLocal, mkLocalId )
80 import PrelInfo ( isNoDictClass )
81 import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
82 isInternalName, setNameUnique, mkSystemVarName )
83 import NameSet ( addOneToNameSet )
84 import Literal ( inIntRange )
85 import Var ( TyVar, tyVarKind, setIdType )
86 import VarEnv ( TidyEnv, emptyTidyEnv )
87 import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
88 import TysWiredIn ( floatDataCon, doubleDataCon )
89 import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
90 import BasicTypes( IPName(..), mapIPName, ipNameName )
91 import UniqSupply( uniqsFromSupply )
92 import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) )
93 import DynFlags ( DynFlag(..), dopt )
94 import Maybes ( isJust )
102 instName :: Inst -> Name
103 instName inst = idName (instToId inst)
105 instToId :: Inst -> TcId
106 instToId (LitInst nm _ ty _) = mkLocalId nm ty
107 instToId (Dict nm pred _) = mkLocalId nm (mkPredTy pred)
108 instToId (Method id _ _ _ _ _) = id
110 instLoc (Dict _ _ loc) = loc
111 instLoc (Method _ _ _ _ _ loc) = loc
112 instLoc (LitInst _ _ _ loc) = loc
114 dictPred (Dict _ pred _ ) = pred
115 dictPred inst = pprPanic "dictPred" (ppr inst)
117 getDictClassTys (Dict _ pred _) = getClassPredTys pred
119 -- fdPredsOfInst is used to get predicates that contain functional
120 -- dependencies *or* might do so. The "might do" part is because
121 -- a constraint (C a b) might have a superclass with FDs
122 -- Leaving these in is really important for the call to fdPredsOfInsts
123 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
124 -- which is supposed to be conservative
125 fdPredsOfInst (Dict _ pred _) = [pred]
126 fdPredsOfInst (Method _ _ _ theta _ _) = theta
127 fdPredsOfInst other = [] -- LitInsts etc
129 fdPredsOfInsts :: [Inst] -> [PredType]
130 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
132 isInheritableInst (Dict _ pred _) = isInheritablePred pred
133 isInheritableInst (Method _ _ _ theta _ _) = all isInheritablePred theta
134 isInheritableInst other = True
137 ipNamesOfInsts :: [Inst] -> [Name]
138 ipNamesOfInst :: Inst -> [Name]
139 -- Get the implicit parameters mentioned by these Insts
140 -- NB: ?x and %x get different Names
141 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
143 ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
144 ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
145 ipNamesOfInst other = []
147 tyVarsOfInst :: Inst -> TcTyVarSet
148 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
149 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
150 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
151 -- The id might have free type variables; in the case of
152 -- locally-overloaded class methods, for example
155 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
156 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
162 isDict :: Inst -> Bool
163 isDict (Dict _ _ _) = True
166 isClassDict :: Inst -> Bool
167 isClassDict (Dict _ pred _) = isClassPred pred
168 isClassDict other = False
170 isTyVarDict :: Inst -> Bool
171 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
172 isTyVarDict other = False
174 isIPDict :: Inst -> Bool
175 isIPDict (Dict _ pred _) = isIPPred pred
176 isIPDict other = False
178 isMethod :: Inst -> Bool
179 isMethod (Method _ _ _ _ _ _) = True
180 isMethod other = False
182 isMethodFor :: TcIdSet -> Inst -> Bool
183 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
184 isMethodFor ids inst = False
186 isLinearInst :: Inst -> Bool
187 isLinearInst (Dict _ pred _) = isLinearPred pred
188 isLinearInst other = False
189 -- We never build Method Insts that have
190 -- linear implicit paramters in them.
191 -- Hence no need to look for Methods
194 linearInstType :: Inst -> TcType -- %x::t --> t
195 linearInstType (Dict _ (IParam _ ty) _) = ty
198 Two predicates which deal with the case where class constraints don't
199 necessarily result in bindings. The first tells whether an @Inst@
200 must be witnessed by an actual binding; the second tells whether an
201 @Inst@ can be generalised over.
204 instBindingRequired :: Inst -> Bool
205 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
206 instBindingRequired other = True
210 %************************************************************************
212 \subsection{Building dictionaries}
214 %************************************************************************
217 newDicts :: InstOrigin
221 = getInstLoc orig `thenM` \ loc ->
222 newDictsAtLoc loc theta
224 cloneDict :: Inst -> TcM Inst
225 cloneDict (Dict nm ty loc) = newUnique `thenM` \ uniq ->
226 returnM (Dict (setNameUnique nm uniq) ty loc)
228 newDictAtLoc :: InstLoc -> TcPredType -> TcM Inst
229 newDictAtLoc inst_loc pred
230 = do { uniq <- newUnique
231 ; return (mkDict inst_loc uniq pred) }
233 newDictsAtLoc :: InstLoc -> TcThetaType -> TcM [Inst]
234 newDictsAtLoc inst_loc theta
235 = newUniqueSupply `thenM` \ us ->
236 returnM (zipWith (mkDict inst_loc) (uniqsFromSupply us) theta)
238 mkDict inst_loc uniq pred
239 = Dict name pred inst_loc
241 name = mkPredName uniq (instLocSrcLoc inst_loc) pred
243 -- For vanilla implicit parameters, there is only one in scope
244 -- at any time, so we used to use the name of the implicit parameter itself
245 -- But with splittable implicit parameters there may be many in
246 -- scope, so we make up a new name.
247 newIPDict :: InstOrigin -> IPName Name -> Type
248 -> TcM (IPName Id, Inst)
249 newIPDict orig ip_name ty
250 = getInstLoc orig `thenM` \ inst_loc ->
251 newUnique `thenM` \ uniq ->
253 pred = IParam ip_name ty
254 name = mkPredName uniq (instLocSrcLoc inst_loc) pred
255 dict = Dict name pred inst_loc
257 returnM (mapIPName (\n -> instToId dict) ip_name, dict)
262 %************************************************************************
264 \subsection{Building methods (calls of overloaded functions)}
266 %************************************************************************
270 tcInstCall :: InstOrigin -> TcType -> TcM (ExprCoFn, [TcTyVar], TcType)
271 tcInstCall orig fun_ty -- fun_ty is usually a sigma-type
272 = do { (tyvars, theta, tau) <- tcInstType fun_ty
273 ; dicts <- newDicts orig theta
275 ; let inst_fn e = unLoc (mkHsDictApp (mkHsTyApp (noLoc e) (mkTyVarTys tyvars))
276 (map instToId dicts))
277 ; return (mkCoercion inst_fn, tyvars, tau) }
279 tcInstStupidTheta :: DataCon -> [TcType] -> TcM ()
280 -- Instantiate the "stupid theta" of the data con, and throw
281 -- the constraints into the constraint set
282 tcInstStupidTheta data_con inst_tys
286 = do { stupid_dicts <- newDicts (OccurrenceOf (dataConName data_con))
287 (substTheta tenv stupid_theta)
288 ; extendLIEs stupid_dicts }
290 stupid_theta = dataConStupidTheta data_con
291 tenv = zipTopTvSubst (dataConTyVars data_con) inst_tys
293 newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId
294 newMethodFromName origin ty name
295 = tcLookupId name `thenM` \ id ->
296 -- Use tcLookupId not tcLookupGlobalId; the method is almost
297 -- always a class op, but with -fno-implicit-prelude GHC is
298 -- meant to find whatever thing is in scope, and that may
299 -- be an ordinary function.
300 getInstLoc origin `thenM` \ loc ->
301 tcInstClassOp loc id [ty] `thenM` \ inst ->
302 extendLIE inst `thenM_`
303 returnM (instToId inst)
305 newMethodWithGivenTy orig id tys theta tau
306 = getInstLoc orig `thenM` \ loc ->
307 newMethod loc id tys theta tau `thenM` \ inst ->
308 extendLIE inst `thenM_`
309 returnM (instToId inst)
311 --------------------------------------------
312 -- tcInstClassOp, and newMethod do *not* drop the
313 -- Inst into the LIE; they just returns the Inst
314 -- This is important because they are used by TcSimplify
317 -- NB: the kind of the type variable to be instantiated
318 -- might be a sub-kind of the type to which it is applied,
319 -- notably when the latter is a type variable of kind ??
320 -- Hence the call to checkKind
321 -- A worry: is this needed anywhere else?
322 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
323 tcInstClassOp inst_loc sel_id tys
325 (tyvars,rho) = tcSplitForAllTys (idType sel_id)
326 rho_ty = ASSERT( length tyvars == length tys )
327 substTyWith tyvars tys rho
328 (preds,tau) = tcSplitPhiTy rho_ty
330 zipWithM_ checkKind tyvars tys `thenM_`
331 newMethod inst_loc sel_id tys preds tau
333 checkKind :: TyVar -> TcType -> TcM ()
334 -- Ensure that the type has a sub-kind of the tyvar
336 = do { ty1 <- zonkTcType ty
337 ; if typeKind ty1 `isSubKind` tyVarKind tv
340 { traceTc (text "checkKind: adding kind constraint" <+> ppr tv <+> ppr ty)
341 ; tv1 <- tcInstTyVar tv
342 ; unifyTauTy (mkTyVarTy tv1) ty1 }}
345 ---------------------------
346 newMethod inst_loc id tys theta tau
347 = newUnique `thenM` \ new_uniq ->
349 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
350 inst = Method meth_id id tys theta tau inst_loc
351 loc = instLocSrcLoc inst_loc
356 In tcOverloadedLit we convert directly to an Int or Integer if we
357 know that's what we want. This may save some time, by not
358 temporarily generating overloaded literals, but it won't catch all
359 cases (the rest are caught in lookupInst).
362 tcOverloadedLit :: InstOrigin
365 -> TcM (HsOverLit TcId)
366 tcOverloadedLit orig lit@(HsIntegral i fi) expected_ty
367 | not (fi `isHsVar` fromIntegerName) -- Do not generate a LitInst for rebindable syntax.
368 -- Reason: If we do, tcSimplify will call lookupInst, which
369 -- will call tcSyntaxName, which does unification,
370 -- which tcSimplify doesn't like
371 -- ToDo: noLoc sadness
372 = do { integer_ty <- tcMetaTy integerTyConName
373 ; fi' <- tcSyntaxOp orig fi (mkFunTy integer_ty expected_ty)
374 ; return (HsIntegral i (HsApp (noLoc fi') (nlHsLit (HsInteger i integer_ty)))) }
376 | Just expr <- shortCutIntLit i expected_ty
377 = return (HsIntegral i expr)
380 = do { expr <- newLitInst orig lit expected_ty
381 ; return (HsIntegral i expr) }
383 tcOverloadedLit orig lit@(HsFractional r fr) expected_ty
384 | not (fr `isHsVar` fromRationalName) -- c.f. HsIntegral case
385 = do { rat_ty <- tcMetaTy rationalTyConName
386 ; fr' <- tcSyntaxOp orig fr (mkFunTy rat_ty expected_ty)
387 ; return (HsFractional r (HsApp (noLoc fr') (nlHsLit (HsRat r rat_ty)))) }
389 | Just expr <- shortCutFracLit r expected_ty
390 = return (HsFractional r expr)
393 = do { expr <- newLitInst orig lit expected_ty
394 ; return (HsFractional r expr) }
396 newLitInst :: InstOrigin -> HsOverLit Name -> TcType -> TcM (HsExpr TcId)
397 newLitInst orig lit expected_ty -- Make a LitInst
398 = do { loc <- getInstLoc orig
399 ; new_uniq <- newUnique
401 lit_nm = mkSystemVarName new_uniq FSLIT("lit")
402 lit_inst = LitInst lit_nm lit expected_ty loc
404 ; return (HsVar (instToId lit_inst)) }
406 shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
408 | isIntTy ty && inIntRange i -- Short cut for Int
409 = Just (HsLit (HsInt i))
410 | isIntegerTy ty -- Short cut for Integer
411 = Just (HsLit (HsInteger i ty))
412 | otherwise = Nothing
414 shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
417 = Just (mk_lit floatDataCon (HsFloatPrim f))
419 = Just (mk_lit doubleDataCon (HsDoublePrim f))
420 | otherwise = Nothing
422 mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
424 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
426 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
427 getSrcSpanM `thenM` \ span ->
428 returnM (L span $ HsLit (HsInteger i integer_ty))
430 mkRatLit :: Rational -> TcM (LHsExpr TcId)
432 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
433 getSrcSpanM `thenM` \ span ->
434 returnM (L span $ HsLit (HsRat r rat_ty))
436 isHsVar :: HsExpr Name -> Name -> Bool
437 isHsVar (HsVar f) g = f==g
438 isHsVar other g = False
442 %************************************************************************
446 %************************************************************************
448 Zonking makes sure that the instance types are fully zonked.
451 zonkInst :: Inst -> TcM Inst
452 zonkInst (Dict name pred loc)
453 = zonkTcPredType pred `thenM` \ new_pred ->
454 returnM (Dict name new_pred loc)
456 zonkInst (Method m id tys theta tau loc)
457 = zonkId id `thenM` \ new_id ->
458 -- Essential to zonk the id in case it's a local variable
459 -- Can't use zonkIdOcc because the id might itself be
460 -- an InstId, in which case it won't be in scope
462 zonkTcTypes tys `thenM` \ new_tys ->
463 zonkTcThetaType theta `thenM` \ new_theta ->
464 zonkTcType tau `thenM` \ new_tau ->
465 returnM (Method m new_id new_tys new_theta new_tau loc)
467 zonkInst (LitInst nm lit ty loc)
468 = zonkTcType ty `thenM` \ new_ty ->
469 returnM (LitInst nm lit new_ty loc)
471 zonkInsts insts = mappM zonkInst insts
475 %************************************************************************
477 \subsection{Printing}
479 %************************************************************************
481 ToDo: improve these pretty-printing things. The ``origin'' is really only
482 relevant in error messages.
485 instance Outputable Inst where
486 ppr inst = pprInst inst
488 pprDictsTheta :: [Inst] -> SDoc
489 -- Print in type-like fashion (Eq a, Show b)
490 pprDictsTheta dicts = pprTheta (map dictPred dicts)
492 pprDictsInFull :: [Inst] -> SDoc
493 -- Print in type-like fashion, but with source location
495 = vcat (map go dicts)
497 go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))]
499 pprInsts :: [Inst] -> SDoc
500 -- Debugging: print the evidence :: type
501 pprInsts insts = brackets (interpp'SP insts)
503 pprInst, pprInstInFull :: Inst -> SDoc
504 -- Debugging: print the evidence :: type
505 pprInst (LitInst nm lit ty loc) = ppr nm <+> dcolon <+> ppr ty
506 pprInst (Dict nm pred loc) = ppr nm <+> dcolon <+> pprPred pred
508 pprInst m@(Method inst_id id tys theta tau loc)
509 = ppr inst_id <+> dcolon <+>
510 braces (sep [ppr id <+> ptext SLIT("at"),
511 brackets (sep (map pprParendType tys))])
514 = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
516 tidyInst :: TidyEnv -> Inst -> Inst
517 tidyInst env (LitInst nm lit ty loc) = LitInst nm lit (tidyType env ty) loc
518 tidyInst env (Dict nm pred loc) = Dict nm (tidyPred env pred) loc
519 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
521 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
522 -- This function doesn't assume that the tyvars are in scope
523 -- so it works like tidyOpenType, returning a TidyEnv
524 tidyMoreInsts env insts
525 = (env', map (tidyInst env') insts)
527 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
529 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
530 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
532 showLIE :: SDoc -> TcM () -- Debugging
534 = do { lie_var <- getLIEVar ;
535 lie <- readMutVar lie_var ;
536 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
540 %************************************************************************
542 Extending the instance environment
544 %************************************************************************
547 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
548 -- Add new locally-defined instances
549 tcExtendLocalInstEnv dfuns thing_inside
550 = do { traceDFuns dfuns
552 ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
553 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
554 tcg_inst_env = inst_env' }
555 ; setGblEnv env' thing_inside }
557 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
558 -- Check that the proposed new instance is OK,
559 -- and then add it to the home inst env
560 addLocalInst home_ie ispec
561 = do { -- Instantiate the dfun type so that we extend the instance
562 -- envt with completely fresh template variables
563 -- This is important because the template variables must
564 -- not overlap with anything in the things being looked up
565 -- (since we do unification).
566 -- We use tcSkolType because we don't want to allocate fresh
567 -- *meta* type variables.
568 let dfun = instanceDFunId ispec
569 ; (tvs', theta', tau') <- tcSkolType (InstSkol dfun) (idType dfun)
570 ; let (cls, tys') = tcSplitDFunHead tau'
571 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
572 ispec' = setInstanceDFunId ispec dfun'
574 -- Load imported instances, so that we report
575 -- duplicates correctly
577 ; let inst_envs = (eps_inst_env eps, home_ie)
579 -- Check functional dependencies
580 ; case checkFunDeps inst_envs ispec' of
581 Just specs -> funDepErr ispec' specs
584 -- Check for duplicate instance decls
585 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
586 ; dup_ispecs = [ dup_ispec
587 | (_, dup_ispec) <- matches
588 , let (_,_,_,dup_tys) = instanceHead dup_ispec
589 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
590 -- Find memebers of the match list which ispec itself matches.
591 -- If the match is 2-way, it's a duplicate
593 dup_ispec : _ -> dupInstErr ispec' dup_ispec
596 -- OK, now extend the envt
597 ; return (extendInstEnv home_ie ispec') }
599 getOverlapFlag :: TcM OverlapFlag
601 = do { dflags <- getDOpts
602 ; let overlap_ok = dopt Opt_AllowOverlappingInstances dflags
603 incoherent_ok = dopt Opt_AllowIncoherentInstances dflags
604 overlap_flag | incoherent_ok = Incoherent
605 | overlap_ok = OverlapOk
606 | otherwise = NoOverlap
608 ; return overlap_flag }
611 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
613 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
614 -- Print the dfun name itself too
616 funDepErr ispec ispecs
618 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
619 2 (pprInstances (ispec:ispecs)))
620 dupInstErr ispec dup_ispec
622 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
623 2 (pprInstances [ispec, dup_ispec]))
625 addDictLoc ispec thing_inside
626 = setSrcSpan (mkSrcSpan loc loc) thing_inside
628 loc = getSrcLoc ispec
632 %************************************************************************
634 \subsection{Looking up Insts}
636 %************************************************************************
639 data LookupInstResult
641 | SimpleInst (LHsExpr TcId) -- Just a variable, type application, or literal
642 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
644 lookupInst :: Inst -> TcM LookupInstResult
645 -- It's important that lookupInst does not put any new stuff into
646 -- the LIE. Instead, any Insts needed by the lookup are returned in
647 -- the LookupInstResult, where they can be further processed by tcSimplify
652 lookupInst inst@(Method _ id tys theta _ loc)
653 = newDictsAtLoc loc theta `thenM` \ dicts ->
654 returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (L span (HsVar id)) tys) (map instToId dicts)))
656 span = instLocSrcSpan loc
660 -- Look for short cuts first: if the literal is *definitely* a
661 -- int, integer, float or a double, generate the real thing here.
662 -- This is essential (see nofib/spectral/nucleic).
663 -- [Same shortcut as in newOverloadedLit, but we
664 -- may have done some unification by now]
666 lookupInst inst@(LitInst _nm (HsIntegral i from_integer_name) ty loc)
667 | Just expr <- shortCutIntLit i ty
668 = returnM (GenInst [] (noLoc expr)) -- GenInst, not SimpleInst, because
669 -- expr may be a constructor application
671 = ASSERT( from_integer_name `isHsVar` fromIntegerName ) -- A LitInst invariant
672 tcLookupId fromIntegerName `thenM` \ from_integer ->
673 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
674 mkIntegerLit i `thenM` \ integer_lit ->
675 returnM (GenInst [method_inst]
676 (mkHsApp (L (instLocSrcSpan loc)
677 (HsVar (instToId method_inst))) integer_lit))
679 lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc)
680 | Just expr <- shortCutFracLit f ty
681 = returnM (GenInst [] (noLoc expr))
684 = ASSERT( from_rat_name `isHsVar` fromRationalName ) -- A LitInst invariant
685 tcLookupId fromRationalName `thenM` \ from_rational ->
686 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
687 mkRatLit f `thenM` \ rat_lit ->
688 returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc)
689 (HsVar (instToId method_inst))) rat_lit))
692 lookupInst (Dict _ pred loc)
693 = do { mb_result <- lookupPred pred
694 ; case mb_result of {
695 Nothing -> return NoInstance ;
696 Just (tenv, dfun_id) -> do
698 -- tenv is a substitution that instantiates the dfun_id
699 -- to match the requested result type.
701 -- We ASSUME that the dfun is quantified over the very same tyvars
702 -- that are bound by the tenv.
705 -- might have some tyvars that *only* appear in arguments
706 -- dfun :: forall a b. C a b, Ord b => D [a]
707 -- We instantiate b to a flexi type variable -- it'll presumably
708 -- become fixed later via functional dependencies
709 { use_stage <- getStage
710 ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
711 (topIdLvl dfun_id) use_stage
713 -- It's possible that not all the tyvars are in
714 -- the substitution, tenv. For example:
715 -- instance C X a => D X where ...
716 -- (presumably there's a functional dependency in class C)
717 -- Hence the open_tvs to instantiate any un-substituted tyvars.
718 ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
719 open_tvs = filter (`notElemTvSubst` tenv) tyvars
720 ; open_tvs' <- mappM tcInstTyVar open_tvs
722 tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
723 -- Since the open_tvs' are freshly made, they cannot possibly be captured by
724 -- any nested for-alls in rho. So the in-scope set is unchanged
725 dfun_rho = substTy tenv' rho
726 (theta, _) = tcSplitPhiTy dfun_rho
727 ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id))
728 (map (substTyVar tenv') tyvars)
730 returnM (SimpleInst ty_app)
732 { dicts <- newDictsAtLoc loc theta
733 ; let rhs = mkHsDictApp ty_app (map instToId dicts)
734 ; returnM (GenInst dicts rhs)
738 lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
739 -- Look up a class constraint in the instance environment
740 lookupPred pred@(ClassP clas tys)
742 ; tcg_env <- getGblEnv
743 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
744 ; case lookupInstEnv inst_envs clas tys of {
745 ([(tenv, ispec)], [])
746 -> do { let dfun_id = is_dfun ispec
747 ; traceTc (text "lookupInst success" <+>
748 vcat [text "dict" <+> ppr pred,
749 text "witness" <+> ppr dfun_id
750 <+> ppr (idType dfun_id) ])
751 -- Record that this dfun is needed
752 ; record_dfun_usage dfun_id
753 ; return (Just (tenv, dfun_id)) } ;
756 -> do { traceTc (text "lookupInst fail" <+>
757 vcat [text "dict" <+> ppr pred,
758 text "matches" <+> ppr matches,
759 text "unifs" <+> ppr unifs])
760 -- In the case of overlap (multiple matches) we report
761 -- NoInstance here. That has the effect of making the
762 -- context-simplifier return the dict as an irreducible one.
763 -- Then it'll be given to addNoInstanceErrs, which will do another
764 -- lookupInstEnv to get the detailed info about what went wrong.
768 lookupPred ip_pred = return Nothing
770 record_dfun_usage dfun_id
771 = do { gbl <- getGblEnv
772 ; let dfun_name = idName dfun_id
773 dfun_mod = nameModule dfun_name
774 ; if isInternalName dfun_name || -- Internal name => defined in this module
775 not (isHomeModule (tcg_home_mods gbl) dfun_mod)
776 then return () -- internal, or in another package
777 else do { tcg_env <- getGblEnv
778 ; updMutVar (tcg_inst_uses tcg_env)
779 (`addOneToNameSet` idName dfun_id) }}
782 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
783 -- Gets both the external-package inst-env
784 -- and the home-pkg inst env (includes module being compiled)
785 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
786 return (eps_inst_env eps, tcg_inst_env env) }
791 %************************************************************************
795 %************************************************************************
797 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
798 a do-expression. We have to find (>>) in the current environment, which is
799 done by the rename. Then we have to check that it has the same type as
800 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
803 (>>) :: HB m n mn => m a -> n b -> mn b
805 So the idea is to generate a local binding for (>>), thus:
807 let then72 :: forall a b. m a -> m b -> m b
808 then72 = ...something involving the user's (>>)...
810 ...the do-expression...
812 Now the do-expression can proceed using then72, which has exactly
815 In fact tcSyntaxName just generates the RHS for then72, because we only
816 want an actual binding in the do-expression case. For literals, we can
817 just use the expression inline.
820 tcSyntaxName :: InstOrigin
821 -> TcType -- Type to instantiate it at
822 -> (Name, HsExpr Name) -- (Standard name, user name)
823 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
824 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
825 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
826 -- So we do not call it from lookupInst, which is called from tcSimplify
828 tcSyntaxName orig ty (std_nm, HsVar user_nm)
830 = newMethodFromName orig ty std_nm `thenM` \ id ->
831 returnM (std_nm, HsVar id)
833 tcSyntaxName orig ty (std_nm, user_nm_expr)
834 = tcLookupId std_nm `thenM` \ std_id ->
836 -- C.f. newMethodAtLoc
837 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
838 sigma1 = substTyWith [tv] [ty] tau
839 -- Actually, the "tau-type" might be a sigma-type in the
840 -- case of locally-polymorphic methods.
842 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $
844 -- Check that the user-supplied thing has the
845 -- same type as the standard one.
846 -- Tiresome jiggling because tcCheckSigma takes a located expression
847 getSrcSpanM `thenM` \ span ->
848 tcCheckSigma (L span user_nm_expr) sigma1 `thenM` \ expr ->
849 returnM (std_nm, unLoc expr)
851 syntaxNameCtxt name orig ty tidy_env
852 = getInstLoc orig `thenM` \ inst_loc ->
854 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
855 ptext SLIT("(needed by a syntactic construct)"),
856 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
857 nest 2 (pprInstLoc inst_loc)]
859 returnM (tidy_env, msg)