2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[Inst]{The @Inst@ type: dictionaries or method instances}
10 pprDFuns, pprDictsTheta, pprDictsInFull, -- User error messages
11 showLIE, pprInst, pprInsts, pprInstInFull, -- Debugging messages
13 tidyInsts, tidyMoreInsts,
15 newDictsFromOld, newDicts, cloneDict,
16 newOverloadedLit, newIPDict,
17 newMethod, newMethodFromName, newMethodWithGivenTy,
18 tcInstClassOp, tcInstCall, tcInstDataCon,
19 tcSyntaxName, tcStdSyntaxName,
21 tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
22 ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
23 instLoc, getDictClassTys, dictPred,
25 lookupInst, LookupInstResult(..),
26 tcExtendLocalInstEnv, tcGetInstEnvs,
28 isDict, isClassDict, isMethod,
29 isLinearInst, linearInstType, isIPDict, isInheritableInst,
30 isTyVarDict, isStdClassTyVarDict, isMethodFor,
36 InstOrigin(..), InstLoc(..), pprInstLoc
39 #include "HsVersions.h"
41 import {-# SOURCE #-} TcExpr( tcCheckSigma )
42 import {-# SOURCE #-} TcUnify ( unifyTauTy ) -- Used in checkKind (sigh)
44 import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp )
45 import TcHsSyn ( TcId, TcIdSet,
46 mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId,
50 import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
51 import InstEnv ( DFunId, InstEnv, lookupInstEnv, checkFunDeps, extendInstEnv )
52 import TcIface ( loadImportedInsts )
53 import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType,
54 zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
56 import TcType ( Type, TcType, TcThetaType, TcTyVarSet,
57 PredType(..), TyVarDetails(VanillaTv), typeKind,
58 tcSplitForAllTys, tcSplitForAllTys, mkTyConApp,
59 tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy,
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, matchTys,
66 tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy,
67 pprPred, pprParendType, pprThetaArrow, pprTheta, pprClassPred
69 import Kind ( isSubKind )
70 import HscTypes ( ExternalPackageState(..) )
71 import CoreFVs ( idFreeTyVars )
72 import DataCon ( DataCon,dataConSig )
73 import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
74 import PrelInfo ( isStandardClass, isNoDictClass )
75 import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, isHomePackageName, isInternalName )
76 import NameSet ( addOneToNameSet )
77 import Subst ( substTy, substTyWith, substTheta, mkTopTyVarSubst )
78 import Literal ( inIntRange )
79 import Var ( TyVar, tyVarKind )
80 import VarEnv ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) )
81 import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
82 import TysWiredIn ( floatDataCon, doubleDataCon )
83 import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
84 import BasicTypes( IPName(..), mapIPName, ipNameName )
85 import UniqSupply( uniqsFromSupply )
86 import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) )
87 import CmdLineOpts( DynFlags, DynFlag( Opt_AllowUndecidableInstances ), dopt )
88 import Maybes ( isJust )
96 instName :: Inst -> Name
97 instName inst = idName (instToId inst)
99 instToId :: Inst -> TcId
100 instToId (Dict id _ _) = id
101 instToId (Method id _ _ _ _ _) = id
102 instToId (LitInst id _ _ _) = id
104 instLoc (Dict _ _ loc) = loc
105 instLoc (Method _ _ _ _ _ loc) = loc
106 instLoc (LitInst _ _ _ loc) = loc
108 dictPred (Dict _ pred _ ) = pred
109 dictPred inst = pprPanic "dictPred" (ppr inst)
111 getDictClassTys (Dict _ pred _) = getClassPredTys pred
113 -- fdPredsOfInst is used to get predicates that contain functional
114 -- dependencies *or* might do so. The "might do" part is because
115 -- a constraint (C a b) might have a superclass with FDs
116 -- Leaving these in is really important for the call to fdPredsOfInsts
117 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
118 -- which is supposed to be conservative
119 fdPredsOfInst (Dict _ pred _) = [pred]
120 fdPredsOfInst (Method _ _ _ theta _ _) = theta
121 fdPredsOfInst other = [] -- LitInsts etc
123 fdPredsOfInsts :: [Inst] -> [PredType]
124 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
126 isInheritableInst (Dict _ pred _) = isInheritablePred pred
127 isInheritableInst (Method _ _ _ theta _ _) = all isInheritablePred theta
128 isInheritableInst other = True
131 ipNamesOfInsts :: [Inst] -> [Name]
132 ipNamesOfInst :: Inst -> [Name]
133 -- Get the implicit parameters mentioned by these Insts
134 -- NB: ?x and %x get different Names
135 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
137 ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
138 ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
139 ipNamesOfInst other = []
141 tyVarsOfInst :: Inst -> TcTyVarSet
142 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
143 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
144 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
145 -- The id might have free type variables; in the case of
146 -- locally-overloaded class methods, for example
149 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
150 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
156 isDict :: Inst -> Bool
157 isDict (Dict _ _ _) = True
160 isClassDict :: Inst -> Bool
161 isClassDict (Dict _ pred _) = isClassPred pred
162 isClassDict other = False
164 isTyVarDict :: Inst -> Bool
165 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
166 isTyVarDict other = False
168 isIPDict :: Inst -> Bool
169 isIPDict (Dict _ pred _) = isIPPred pred
170 isIPDict other = False
172 isMethod :: Inst -> Bool
173 isMethod (Method _ _ _ _ _ _) = True
174 isMethod other = False
176 isMethodFor :: TcIdSet -> Inst -> Bool
177 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
178 isMethodFor ids inst = False
180 isLinearInst :: Inst -> Bool
181 isLinearInst (Dict _ pred _) = isLinearPred pred
182 isLinearInst other = False
183 -- We never build Method Insts that have
184 -- linear implicit paramters in them.
185 -- Hence no need to look for Methods
188 linearInstType :: Inst -> TcType -- %x::t --> t
189 linearInstType (Dict _ (IParam _ ty) _) = ty
192 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
193 Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
197 Two predicates which deal with the case where class constraints don't
198 necessarily result in bindings. The first tells whether an @Inst@
199 must be witnessed by an actual binding; the second tells whether an
200 @Inst@ can be generalised over.
203 instBindingRequired :: Inst -> Bool
204 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
205 instBindingRequired other = True
209 %************************************************************************
211 \subsection{Building dictionaries}
213 %************************************************************************
216 newDicts :: InstOrigin
220 = getInstLoc orig `thenM` \ loc ->
221 newDictsAtLoc loc theta
223 cloneDict :: Inst -> TcM Inst
224 cloneDict (Dict id ty loc) = newUnique `thenM` \ uniq ->
225 returnM (Dict (setIdUnique id uniq) ty loc)
227 newDictsFromOld :: Inst -> TcThetaType -> TcM [Inst]
228 newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
230 -- Local function, similar to newDicts,
231 -- but with slightly different interface
232 newDictsAtLoc :: InstLoc
235 newDictsAtLoc inst_loc theta
236 = newUniqueSupply `thenM` \ us ->
237 returnM (zipWith mk_dict (uniqsFromSupply us) theta)
239 mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred))
241 loc = instLocSrcLoc inst_loc
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 id = mkLocalId name (mkPredTy pred)
257 returnM (mapIPName (\n -> id) ip_name, Dict id pred inst_loc)
262 %************************************************************************
264 \subsection{Building methods (calls of overloaded functions)}
266 %************************************************************************
270 tcInstCall :: InstOrigin -> TcType -> TcM (ExprCoFn, TcType)
271 tcInstCall orig fun_ty -- fun_ty is usually a sigma-type
272 = tcInstType VanillaTv fun_ty `thenM` \ (tyvars, theta, tau) ->
273 newDicts orig theta `thenM` \ dicts ->
274 extendLIEs dicts `thenM_`
276 inst_fn e = DictApp (mkHsTyApp (noLoc e) (mkTyVarTys tyvars)) (map instToId dicts)
278 returnM (mkCoercion inst_fn, tau)
280 tcInstDataCon :: InstOrigin
281 -> TyVarDetails -- Use this for the existential tyvars
282 -- ExistTv when pattern-matching,
283 -- VanillaTv at a call of the constructor
285 -> TcM ([TcType], -- Types to instantiate at
286 [Inst], -- Existential dictionaries to apply to
287 [TcType], -- Argument types of constructor
288 TcType, -- Result type
289 [TyVar]) -- Existential tyvars
290 tcInstDataCon orig ex_tv_details data_con
292 (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con
293 -- We generate constraints for the stupid theta even when
294 -- pattern matching (as the Report requires)
296 mappM (tcInstTyVar VanillaTv) tvs `thenM` \ tvs' ->
297 mappM (tcInstTyVar ex_tv_details) ex_tvs `thenM` \ ex_tvs' ->
299 tv_tys' = mkTyVarTys tvs'
300 ex_tv_tys' = mkTyVarTys ex_tvs'
301 all_tys' = tv_tys' ++ ex_tv_tys'
303 tenv = mkTopTyVarSubst (tvs ++ ex_tvs) all_tys'
304 stupid_theta' = substTheta tenv stupid_theta
305 ex_theta' = substTheta tenv ex_theta
306 arg_tys' = map (substTy tenv) arg_tys
307 result_ty' = mkTyConApp tycon tv_tys'
309 newDicts orig stupid_theta' `thenM` \ stupid_dicts ->
310 newDicts orig ex_theta' `thenM` \ ex_dicts ->
312 -- Note that we return the stupid theta *only* in the LIE;
313 -- we don't otherwise use it at all
314 extendLIEs stupid_dicts `thenM_`
316 returnM (all_tys', ex_dicts, arg_tys', result_ty', ex_tvs')
318 newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId
319 newMethodFromName origin ty name
320 = tcLookupId name `thenM` \ id ->
321 -- Use tcLookupId not tcLookupGlobalId; the method is almost
322 -- always a class op, but with -fno-implicit-prelude GHC is
323 -- meant to find whatever thing is in scope, and that may
324 -- be an ordinary function.
325 getInstLoc origin `thenM` \ loc ->
326 tcInstClassOp loc id [ty] `thenM` \ inst ->
327 extendLIE inst `thenM_`
328 returnM (instToId inst)
330 newMethodWithGivenTy orig id tys theta tau
331 = getInstLoc orig `thenM` \ loc ->
332 newMethod loc id tys theta tau `thenM` \ inst ->
333 extendLIE inst `thenM_`
334 returnM (instToId inst)
336 --------------------------------------------
337 -- tcInstClassOp, and newMethod do *not* drop the
338 -- Inst into the LIE; they just returns the Inst
339 -- This is important because they are used by TcSimplify
342 -- NB: the kind of the type variable to be instantiated
343 -- might be a sub-kind of the type to which it is applied,
344 -- notably when the latter is a type variable of kind ??
345 -- Hence the call to checkKind
346 -- A worry: is this needed anywhere else?
347 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
348 tcInstClassOp inst_loc sel_id tys
350 (tyvars,rho) = tcSplitForAllTys (idType sel_id)
351 rho_ty = ASSERT( length tyvars == length tys )
352 substTyWith tyvars tys rho
353 (preds,tau) = tcSplitPhiTy rho_ty
355 zipWithM_ checkKind tyvars tys `thenM_`
356 newMethod inst_loc sel_id tys preds tau
358 checkKind :: TyVar -> TcType -> TcM ()
359 -- Ensure that the type has a sub-kind of the tyvar
361 = do { ty1 <- zonkTcType ty
362 ; if typeKind ty1 `isSubKind` tyVarKind tv
365 { traceTc (text "checkKind: adding kind constraint" <+> ppr tv <+> ppr ty)
366 ; tv1 <- tcInstTyVar VanillaTv tv
367 ; unifyTauTy (mkTyVarTy tv1) ty1 }}
370 ---------------------------
371 newMethod inst_loc id tys theta tau
372 = newUnique `thenM` \ new_uniq ->
374 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
375 inst = Method meth_id id tys theta tau inst_loc
376 loc = instLocSrcLoc inst_loc
381 In newOverloadedLit we convert directly to an Int or Integer if we
382 know that's what we want. This may save some time, by not
383 temporarily generating overloaded literals, but it won't catch all
384 cases (the rest are caught in lookupInst).
387 newOverloadedLit :: InstOrigin
390 -> TcM (LHsExpr TcId)
391 newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
392 | fi /= fromIntegerName -- Do not generate a LitInst for rebindable syntax.
393 -- Reason: tcSyntaxName does unification
394 -- which is very inconvenient in tcSimplify
395 -- ToDo: noLoc sadness
396 = tcSyntaxName orig expected_ty (fromIntegerName, HsVar fi) `thenM` \ (_,expr) ->
397 mkIntegerLit i `thenM` \ integer_lit ->
398 returnM (mkHsApp (noLoc expr) integer_lit)
399 -- The mkHsApp will get the loc from the literal
400 | Just expr <- shortCutIntLit i expected_ty
404 = newLitInst orig lit expected_ty
406 newOverloadedLit orig lit@(HsFractional r fr) expected_ty
407 | fr /= fromRationalName -- c.f. HsIntegral case
408 = tcSyntaxName orig expected_ty (fromRationalName, HsVar fr) `thenM` \ (_,expr) ->
409 mkRatLit r `thenM` \ rat_lit ->
410 returnM (mkHsApp (noLoc expr) rat_lit)
411 -- The mkHsApp will get the loc from the literal
413 | Just expr <- shortCutFracLit r expected_ty
417 = newLitInst orig lit expected_ty
419 newLitInst :: InstOrigin -> HsOverLit -> TcType -> TcM (LHsExpr TcId)
420 newLitInst orig lit expected_ty
421 = getInstLoc orig `thenM` \ loc ->
422 newUnique `thenM` \ new_uniq ->
424 lit_inst = LitInst lit_id lit expected_ty loc
425 lit_id = mkSysLocal FSLIT("lit") new_uniq expected_ty
427 extendLIE lit_inst `thenM_`
428 returnM (L (instLocSrcSpan loc) (HsVar (instToId lit_inst)))
430 shortCutIntLit :: Integer -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-)
432 | isIntTy ty && inIntRange i -- Short cut for Int
433 = Just (noLoc (HsLit (HsInt i)))
434 | isIntegerTy ty -- Short cut for Integer
435 = Just (noLoc (HsLit (HsInteger i ty)))
436 | otherwise = Nothing
438 shortCutFracLit :: Rational -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-)
441 = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
443 = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
444 | otherwise = Nothing
446 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
448 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
449 getSrcSpanM `thenM` \ span ->
450 returnM (L span $ HsLit (HsInteger i integer_ty))
452 mkRatLit :: Rational -> TcM (LHsExpr TcId)
454 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
455 getSrcSpanM `thenM` \ span ->
456 returnM (L span $ HsLit (HsRat r rat_ty))
460 %************************************************************************
464 %************************************************************************
466 Zonking makes sure that the instance types are fully zonked,
467 but doesn't do the same for any of the Ids in an Inst. There's no
468 need, and it's a lot of extra work.
471 zonkInst :: Inst -> TcM Inst
472 zonkInst (Dict id pred loc)
473 = zonkTcPredType pred `thenM` \ new_pred ->
474 returnM (Dict id new_pred loc)
476 zonkInst (Method m id tys theta tau loc)
477 = zonkId id `thenM` \ new_id ->
478 -- Essential to zonk the id in case it's a local variable
479 -- Can't use zonkIdOcc because the id might itself be
480 -- an InstId, in which case it won't be in scope
482 zonkTcTypes tys `thenM` \ new_tys ->
483 zonkTcThetaType theta `thenM` \ new_theta ->
484 zonkTcType tau `thenM` \ new_tau ->
485 returnM (Method m new_id new_tys new_theta new_tau loc)
487 zonkInst (LitInst id lit ty loc)
488 = zonkTcType ty `thenM` \ new_ty ->
489 returnM (LitInst id lit new_ty loc)
491 zonkInsts insts = mappM zonkInst insts
495 %************************************************************************
497 \subsection{Printing}
499 %************************************************************************
501 ToDo: improve these pretty-printing things. The ``origin'' is really only
502 relevant in error messages.
505 instance Outputable Inst where
506 ppr inst = pprInst inst
508 pprDictsTheta :: [Inst] -> SDoc
509 -- Print in type-like fashion (Eq a, Show b)
510 pprDictsTheta dicts = pprTheta (map dictPred dicts)
512 pprDictsInFull :: [Inst] -> SDoc
513 -- Print in type-like fashion, but with source location
515 = vcat (map go dicts)
517 go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))]
519 pprInsts :: [Inst] -> SDoc
520 -- Debugging: print the evidence :: type
521 pprInsts insts = brackets (interpp'SP insts)
523 pprInst, pprInstInFull :: Inst -> SDoc
524 -- Debugging: print the evidence :: type
525 pprInst (LitInst id lit ty loc) = ppr id <+> dcolon <+> ppr ty
526 pprInst (Dict id pred loc) = ppr id <+> dcolon <+> pprPred pred
528 pprInst m@(Method inst_id id tys theta tau loc)
529 = ppr inst_id <+> dcolon <+>
530 braces (sep [ppr id <+> ptext SLIT("at"),
531 brackets (sep (map pprParendType tys))])
534 = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
536 pprDFuns :: [DFunId] -> SDoc
537 -- Prints the dfun as an instance declaration
538 pprDFuns dfuns = vcat [ hang (ppr (getSrcLoc dfun) <> colon)
539 2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta,
540 pprClassPred clas tys])
542 , let (_, theta, clas, tys) = tcSplitDFunTy (idType dfun) ]
543 -- Print without the for-all, which the programmer doesn't write
545 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
547 tidyInst :: TidyEnv -> Inst -> Inst
548 tidyInst env (LitInst u lit ty loc) = LitInst u lit (tidyType env ty) loc
549 tidyInst env (Dict u pred loc) = Dict u (tidyPred env pred) loc
550 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
552 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
553 -- This function doesn't assume that the tyvars are in scope
554 -- so it works like tidyOpenType, returning a TidyEnv
555 tidyMoreInsts env insts
556 = (env', map (tidyInst env') insts)
558 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
560 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
561 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
563 showLIE :: SDoc -> TcM () -- Debugging
565 = do { lie_var <- getLIEVar ;
566 lie <- readMutVar lie_var ;
567 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
571 %************************************************************************
573 Extending the instance environment
575 %************************************************************************
578 tcExtendLocalInstEnv :: [DFunId] -> TcM a -> TcM a
579 -- Add new locally-defined instances
580 tcExtendLocalInstEnv dfuns thing_inside
581 = do { traceDFuns dfuns
584 ; inst_env' <- foldlM (addInst dflags) (tcg_inst_env env) dfuns
585 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
586 tcg_inst_env = inst_env' }
587 ; setGblEnv env' thing_inside }
589 addInst :: DynFlags -> InstEnv -> DFunId -> TcM InstEnv
590 -- Check that the proposed new instance is OK,
591 -- and then add it to the home inst env
592 addInst dflags home_ie dfun
593 = do { -- Load imported instances, so that we report
594 -- duplicates correctly
595 pkg_ie <- loadImportedInsts cls tys
597 -- Check functional dependencies
598 ; case checkFunDeps (pkg_ie, home_ie) dfun of
599 Just dfuns -> funDepErr dfun dfuns
602 -- Check for duplicate instance decls
603 ; let { (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys
604 ; dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
605 isJust (matchTys (mkVarSet tvs) tys dup_tys)] }
606 -- Find memebers of the match list which
607 -- dfun itself matches. If the match is 2-way, it's a duplicate
609 dup_dfun : _ -> dupInstErr dfun dup_dfun
612 -- OK, now extend the envt
613 ; return (extendInstEnv home_ie dfun) }
615 (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
618 = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
620 pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
624 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
625 2 (pprDFuns (dfun:dfuns)))
626 dupInstErr dfun dup_dfun
628 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
629 2 (pprDFuns [dfun, dup_dfun]))
631 addDictLoc dfun thing_inside
632 = addSrcSpan (mkSrcSpan loc loc) thing_inside
637 %************************************************************************
639 \subsection{Looking up Insts}
641 %************************************************************************
644 data LookupInstResult s
646 | SimpleInst (LHsExpr TcId) -- Just a variable, type application, or literal
647 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
649 lookupInst :: Inst -> TcM (LookupInstResult s)
650 -- It's important that lookupInst does not put any new stuff into
651 -- the LIE. Instead, any Insts needed by the lookup are returned in
652 -- the LookupInstResult, where they can be further processed by tcSimplify
657 lookupInst inst@(Method _ id tys theta _ loc)
658 = newDictsAtLoc loc theta `thenM` \ dicts ->
659 returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (L span (HsVar id)) tys) (map instToId dicts)))
661 span = instLocSrcSpan loc
665 -- Look for short cuts first: if the literal is *definitely* a
666 -- int, integer, float or a double, generate the real thing here.
667 -- This is essential (see nofib/spectral/nucleic).
668 -- [Same shortcut as in newOverloadedLit, but we
669 -- may have done some unification by now]
672 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
673 | Just expr <- shortCutIntLit i ty
674 = returnM (GenInst [] expr) -- GenInst, not SimpleInst, because
675 -- expr may be a constructor application
677 = ASSERT( from_integer_name == fromIntegerName ) -- A LitInst invariant
678 tcLookupId fromIntegerName `thenM` \ from_integer ->
679 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
680 mkIntegerLit i `thenM` \ integer_lit ->
681 returnM (GenInst [method_inst]
682 (mkHsApp (L (instLocSrcSpan loc)
683 (HsVar (instToId method_inst))) integer_lit))
685 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
686 | Just expr <- shortCutFracLit f ty
687 = returnM (GenInst [] expr)
690 = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
691 tcLookupId fromRationalName `thenM` \ from_rational ->
692 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
693 mkRatLit f `thenM` \ rat_lit ->
694 returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc)
695 (HsVar (instToId method_inst))) rat_lit))
698 lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
699 = do { pkg_ie <- loadImportedInsts clas tys
700 -- Suck in any instance decls that may be relevant
701 ; tcg_env <- getGblEnv
703 ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
704 ([(tenv, (_,_,dfun_id))], []) -> instantiate_dfun tenv dfun_id pred loc ;
705 (matches, unifs) -> do
706 { traceTc (text "lookupInst fail" <+> vcat [text "dict" <+> ppr pred,
707 text "matches" <+> ppr matches,
708 text "unifs" <+> ppr unifs])
709 ; return NoInstance } } }
710 -- In the case of overlap (multiple matches) we report
711 -- NoInstance here. That has the effect of making the
712 -- context-simplifier return the dict as an irreducible one.
713 -- Then it'll be given to addNoInstanceErrs, which will do another
714 -- lookupInstEnv to get the detailed info about what went wrong.
716 lookupInst (Dict _ _ _) = returnM NoInstance
719 instantiate_dfun tenv dfun_id pred loc
720 = traceTc (text "lookupInst success" <+>
721 vcat [text "dict" <+> ppr pred,
722 text "witness" <+> ppr dfun_id <+> ppr (idType dfun_id) ]) `thenM_`
723 -- Record that this dfun is needed
724 record_dfun_usage dfun_id `thenM_`
726 -- It's possible that not all the tyvars are in
727 -- the substitution, tenv. For example:
728 -- instance C X a => D X where ...
729 -- (presumably there's a functional dependency in class C)
730 -- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
731 getStage `thenM` \ use_stage ->
732 checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
733 (topIdLvl dfun_id) use_stage `thenM_`
735 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
736 mk_ty_arg tv = case lookupSubstEnv tenv tv of
737 Just (DoneTy ty) -> returnM ty
738 Nothing -> tcInstTyVar VanillaTv tv `thenM` \ tc_tv ->
739 returnM (mkTyVarTy tc_tv)
741 mappM mk_ty_arg tyvars `thenM` \ ty_args ->
743 dfun_rho = substTy (mkTopTyVarSubst tyvars ty_args) rho
744 -- Since the tyvars are freshly made,
745 -- they cannot possibly be captured by
746 -- any existing for-alls. Hence mkTopTyVarSubst
747 (theta, _) = tcSplitPhiTy dfun_rho
748 ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id)) ty_args
751 returnM (SimpleInst ty_app)
753 newDictsAtLoc loc theta `thenM` \ dicts ->
755 rhs = mkHsDictApp ty_app (map instToId dicts)
757 returnM (GenInst dicts rhs)
759 record_dfun_usage dfun_id
760 | isInternalName dfun_name = return () -- From this module
761 | not (isHomePackageName dfun_name) = return () -- From another package package
762 | otherwise = getGblEnv `thenM` \ tcg_env ->
763 updMutVar (tcg_inst_uses tcg_env)
764 (`addOneToNameSet` idName dfun_id)
766 dfun_name = idName dfun_id
768 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
769 -- Gets both the external-package inst-env
770 -- and the home-pkg inst env (includes module being compiled)
771 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
772 return (eps_inst_env eps, tcg_inst_env env) }
777 %************************************************************************
781 %************************************************************************
784 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
785 a do-expression. We have to find (>>) in the current environment, which is
786 done by the rename. Then we have to check that it has the same type as
787 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
790 (>>) :: HB m n mn => m a -> n b -> mn b
792 So the idea is to generate a local binding for (>>), thus:
794 let then72 :: forall a b. m a -> m b -> m b
795 then72 = ...something involving the user's (>>)...
797 ...the do-expression...
799 Now the do-expression can proceed using then72, which has exactly
802 In fact tcSyntaxName just generates the RHS for then72, because we only
803 want an actual binding in the do-expression case. For literals, we can
804 just use the expression inline.
807 tcSyntaxName :: InstOrigin
808 -> TcType -- Type to instantiate it at
809 -> (Name, HsExpr Name) -- (Standard name, user name)
810 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
812 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
813 -- So we do not call it from lookupInst, which is called from tcSimplify
815 tcSyntaxName orig ty (std_nm, HsVar user_nm)
817 = tcStdSyntaxName orig ty std_nm
819 tcSyntaxName orig ty (std_nm, user_nm_expr)
820 = tcLookupId std_nm `thenM` \ std_id ->
822 -- C.f. newMethodAtLoc
823 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
824 sigma1 = substTyWith [tv] [ty] tau
825 -- Actually, the "tau-type" might be a sigma-type in the
826 -- case of locally-polymorphic methods.
828 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $
830 -- Check that the user-supplied thing has the
831 -- same type as the standard one.
832 -- Tiresome jiggling because tcCheckSigma takes a located expression
833 getSrcSpanM `thenM` \ span ->
834 tcCheckSigma (L span user_nm_expr) sigma1 `thenM` \ expr ->
835 returnM (std_nm, unLoc expr)
837 tcStdSyntaxName :: InstOrigin
838 -> TcType -- Type to instantiate it at
839 -> Name -- Standard name
840 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
842 tcStdSyntaxName orig ty std_nm
843 = newMethodFromName orig ty std_nm `thenM` \ id ->
844 returnM (std_nm, HsVar id)
846 syntaxNameCtxt name orig ty tidy_env
847 = getInstLoc orig `thenM` \ inst_loc ->
849 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
850 ptext SLIT("(needed by a syntactic construct)"),
851 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
852 nest 2 (pprInstLoc inst_loc)]
854 returnM (tidy_env, msg)