2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[Inst]{The @Inst@ type: dictionaries or method instances}
11 pprInst, pprInsts, pprDFuns, pprDictsTheta, pprDictsInFull,
12 tidyInsts, tidyMoreInsts,
14 newDictsFromOld, newDicts, cloneDict,
15 newOverloadedLit, newIPDict,
16 newMethod, newMethodFromName, newMethodWithGivenTy,
17 tcInstClassOp, tcInstCall, tcInstDataCon,
18 tcSyntaxName, tcStdSyntaxName,
20 tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
21 ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
22 instLoc, getDictClassTys, dictPred,
24 lookupInst, LookupInstResult(..),
25 tcExtendLocalInstEnv, tcGetInstEnvs,
27 isDict, isClassDict, isMethod,
28 isLinearInst, linearInstType, isIPDict, isInheritableInst,
29 isTyVarDict, isStdClassTyVarDict, isMethodFor,
35 InstOrigin(..), InstLoc(..), pprInstLoc
38 #include "HsVersions.h"
40 import {-# SOURCE #-} TcExpr( tcCheckSigma )
41 import {-# SOURCE #-} TcUnify ( unifyTauTy ) -- Used in checkKind (sigh)
43 import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp )
44 import TcHsSyn ( TcId, TcIdSet,
45 mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId,
49 import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
50 import InstEnv ( DFunId, InstEnv, lookupInstEnv, checkFunDeps, extendInstEnv )
51 import TcIface ( loadImportedInsts )
52 import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType,
53 zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
55 import TcType ( Type, TcType, TcThetaType, TcTyVarSet,
56 PredType(..), TyVarDetails(VanillaTv), typeKind,
57 tcSplitForAllTys, tcSplitForAllTys, mkTyConApp,
58 tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy,
59 isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
60 tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
61 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
62 isClassPred, isTyVarClassPred, isLinearPred,
63 getClassPredTys, getClassPredTys_maybe, mkPredName,
64 isInheritablePred, isIPPred, matchTys,
65 tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy,
66 pprPred, pprParendType, pprThetaArrow, pprTheta, pprClassPred
68 import Kind ( isSubKind )
69 import HscTypes ( ExternalPackageState(..) )
70 import CoreFVs ( idFreeTyVars )
71 import DataCon ( DataCon,dataConSig )
72 import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
73 import PrelInfo ( isStandardClass, isNoDictClass )
74 import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, isHomePackageName, isInternalName )
75 import NameSet ( addOneToNameSet )
76 import Subst ( substTy, substTyWith, substTheta, mkTyVarSubst )
77 import Literal ( inIntRange )
78 import Var ( TyVar, tyVarKind )
79 import VarEnv ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) )
80 import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
81 import TysWiredIn ( floatDataCon, doubleDataCon )
82 import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
83 import BasicTypes( IPName(..), mapIPName, ipNameName )
84 import UniqSupply( uniqsFromSupply )
85 import SrcLoc ( mkSrcSpan, noLoc, Located(..) )
86 import CmdLineOpts( DynFlags, DynFlag( Opt_AllowUndecidableInstances ), dopt )
87 import Maybes ( isJust )
95 instName :: Inst -> Name
96 instName inst = idName (instToId inst)
98 instToId :: Inst -> TcId
99 instToId (Dict id _ _) = id
100 instToId (Method id _ _ _ _ _) = id
101 instToId (LitInst id _ _ _) = id
103 instLoc (Dict _ _ loc) = loc
104 instLoc (Method _ _ _ _ _ loc) = loc
105 instLoc (LitInst _ _ _ loc) = loc
107 dictPred (Dict _ pred _ ) = pred
108 dictPred inst = pprPanic "dictPred" (ppr inst)
110 getDictClassTys (Dict _ pred _) = getClassPredTys pred
112 -- fdPredsOfInst is used to get predicates that contain functional
113 -- dependencies *or* might do so. The "might do" part is because
114 -- a constraint (C a b) might have a superclass with FDs
115 -- Leaving these in is really important for the call to fdPredsOfInsts
116 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
117 -- which is supposed to be conservative
118 fdPredsOfInst (Dict _ pred _) = [pred]
119 fdPredsOfInst (Method _ _ _ theta _ _) = theta
120 fdPredsOfInst other = [] -- LitInsts etc
122 fdPredsOfInsts :: [Inst] -> [PredType]
123 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
125 isInheritableInst (Dict _ pred _) = isInheritablePred pred
126 isInheritableInst (Method _ _ _ theta _ _) = all isInheritablePred theta
127 isInheritableInst other = True
130 ipNamesOfInsts :: [Inst] -> [Name]
131 ipNamesOfInst :: Inst -> [Name]
132 -- Get the implicit parameters mentioned by these Insts
133 -- NB: ?x and %x get different Names
134 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
136 ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
137 ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
138 ipNamesOfInst other = []
140 tyVarsOfInst :: Inst -> TcTyVarSet
141 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
142 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
143 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
144 -- The id might have free type variables; in the case of
145 -- locally-overloaded class methods, for example
148 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
149 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
155 isDict :: Inst -> Bool
156 isDict (Dict _ _ _) = True
159 isClassDict :: Inst -> Bool
160 isClassDict (Dict _ pred _) = isClassPred pred
161 isClassDict other = False
163 isTyVarDict :: Inst -> Bool
164 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
165 isTyVarDict other = False
167 isIPDict :: Inst -> Bool
168 isIPDict (Dict _ pred _) = isIPPred pred
169 isIPDict other = False
171 isMethod :: Inst -> Bool
172 isMethod (Method _ _ _ _ _ _) = True
173 isMethod other = False
175 isMethodFor :: TcIdSet -> Inst -> Bool
176 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
177 isMethodFor ids inst = False
179 isLinearInst :: Inst -> Bool
180 isLinearInst (Dict _ pred _) = isLinearPred pred
181 isLinearInst other = False
182 -- We never build Method Insts that have
183 -- linear implicit paramters in them.
184 -- Hence no need to look for Methods
187 linearInstType :: Inst -> TcType -- %x::t --> t
188 linearInstType (Dict _ (IParam _ ty) _) = ty
191 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
192 Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
196 Two predicates which deal with the case where class constraints don't
197 necessarily result in bindings. The first tells whether an @Inst@
198 must be witnessed by an actual binding; the second tells whether an
199 @Inst@ can be generalised over.
202 instBindingRequired :: Inst -> Bool
203 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
204 instBindingRequired other = True
208 %************************************************************************
210 \subsection{Building dictionaries}
212 %************************************************************************
215 newDicts :: InstOrigin
219 = getInstLoc orig `thenM` \ loc ->
220 newDictsAtLoc loc theta
222 cloneDict :: Inst -> TcM Inst
223 cloneDict (Dict id ty loc) = newUnique `thenM` \ uniq ->
224 returnM (Dict (setIdUnique id uniq) ty loc)
226 newDictsFromOld :: Inst -> TcThetaType -> TcM [Inst]
227 newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
229 -- Local function, similar to newDicts,
230 -- but with slightly different interface
231 newDictsAtLoc :: InstLoc
234 newDictsAtLoc inst_loc theta
235 = newUniqueSupply `thenM` \ us ->
236 returnM (zipWith mk_dict (uniqsFromSupply us) theta)
238 mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred))
240 loc = instLocSrcLoc inst_loc
242 -- For vanilla implicit parameters, there is only one in scope
243 -- at any time, so we used to use the name of the implicit parameter itself
244 -- But with splittable implicit parameters there may be many in
245 -- scope, so we make up a new name.
246 newIPDict :: InstOrigin -> IPName Name -> Type
247 -> TcM (IPName Id, Inst)
248 newIPDict orig ip_name ty
249 = getInstLoc orig `thenM` \ inst_loc ->
250 newUnique `thenM` \ uniq ->
252 pred = IParam ip_name ty
253 name = mkPredName uniq (instLocSrcLoc inst_loc) pred
254 id = mkLocalId name (mkPredTy pred)
256 returnM (mapIPName (\n -> id) ip_name, Dict id pred inst_loc)
261 %************************************************************************
263 \subsection{Building methods (calls of overloaded functions)}
265 %************************************************************************
269 tcInstCall :: InstOrigin -> TcType -> TcM (ExprCoFn, TcType)
270 tcInstCall orig fun_ty -- fun_ty is usually a sigma-type
271 = tcInstType VanillaTv fun_ty `thenM` \ (tyvars, theta, tau) ->
272 newDicts orig theta `thenM` \ dicts ->
273 extendLIEs dicts `thenM_`
275 inst_fn e = DictApp (mkHsTyApp (noLoc e) (mkTyVarTys tyvars)) (map instToId dicts)
277 returnM (mkCoercion inst_fn, tau)
279 tcInstDataCon :: InstOrigin -> DataCon
280 -> TcM ([TcType], -- Types to instantiate at
281 [Inst], -- Existential dictionaries to apply to
282 [TcType], -- Argument types of constructor
283 TcType, -- Result type
284 [TyVar]) -- Existential tyvars
285 tcInstDataCon orig data_con
287 (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con
288 -- We generate constraints for the stupid theta even when
289 -- pattern matching (as the Report requires)
291 tcInstTyVars VanillaTv (tvs ++ ex_tvs) `thenM` \ (all_tvs', ty_args', tenv) ->
293 stupid_theta' = substTheta tenv stupid_theta
294 ex_theta' = substTheta tenv ex_theta
295 arg_tys' = map (substTy tenv) arg_tys
297 n_normal_tvs = length tvs
298 ex_tvs' = drop n_normal_tvs all_tvs'
299 result_ty = mkTyConApp tycon (take n_normal_tvs ty_args')
301 newDicts orig stupid_theta' `thenM` \ stupid_dicts ->
302 newDicts orig ex_theta' `thenM` \ ex_dicts ->
304 -- Note that we return the stupid theta *only* in the LIE;
305 -- we don't otherwise use it at all
306 extendLIEs stupid_dicts `thenM_`
308 returnM (ty_args', ex_dicts, arg_tys', result_ty, ex_tvs')
310 newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId
311 newMethodFromName origin ty name
312 = tcLookupId name `thenM` \ id ->
313 -- Use tcLookupId not tcLookupGlobalId; the method is almost
314 -- always a class op, but with -fno-implicit-prelude GHC is
315 -- meant to find whatever thing is in scope, and that may
316 -- be an ordinary function.
317 getInstLoc origin `thenM` \ loc ->
318 tcInstClassOp loc id [ty] `thenM` \ inst ->
319 extendLIE inst `thenM_`
320 returnM (instToId inst)
322 newMethodWithGivenTy orig id tys theta tau
323 = getInstLoc orig `thenM` \ loc ->
324 newMethod loc id tys theta tau `thenM` \ inst ->
325 extendLIE inst `thenM_`
326 returnM (instToId inst)
328 --------------------------------------------
329 -- tcInstClassOp, and newMethod do *not* drop the
330 -- Inst into the LIE; they just returns the Inst
331 -- This is important because they are used by TcSimplify
334 -- NB: the kind of the type variable to be instantiated
335 -- might be a sub-kind of the type to which it is applied,
336 -- notably when the latter is a type variable of kind ??
337 -- Hence the call to checkKind
338 -- A worry: is this needed anywhere else?
339 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
340 tcInstClassOp inst_loc sel_id tys
342 (tyvars,rho) = tcSplitForAllTys (idType sel_id)
343 rho_ty = ASSERT( length tyvars == length tys )
344 substTyWith tyvars tys rho
345 (preds,tau) = tcSplitPhiTy rho_ty
347 zipWithM_ checkKind tyvars tys `thenM_`
348 newMethod inst_loc sel_id tys preds tau
350 checkKind :: TyVar -> TcType -> TcM ()
351 -- Ensure that the type has a sub-kind of the tyvar
353 = do { ty1 <- zonkTcType ty
354 ; if typeKind ty1 `isSubKind` tyVarKind tv
357 { traceTc (text "checkKind: adding kind constraint" <+> ppr tv <+> ppr ty)
358 ; tv1 <- tcInstTyVar VanillaTv tv
359 ; unifyTauTy (mkTyVarTy tv1) ty1 }}
362 ---------------------------
363 newMethod inst_loc id tys theta tau
364 = newUnique `thenM` \ new_uniq ->
366 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
367 inst = Method meth_id id tys theta tau inst_loc
368 loc = instLocSrcLoc inst_loc
373 In newOverloadedLit we convert directly to an Int or Integer if we
374 know that's what we want. This may save some time, by not
375 temporarily generating overloaded literals, but it won't catch all
376 cases (the rest are caught in lookupInst).
379 newOverloadedLit :: InstOrigin
382 -> TcM (LHsExpr TcId)
383 newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
384 | fi /= fromIntegerName -- Do not generate a LitInst for rebindable syntax.
385 -- Reason: tcSyntaxName does unification
386 -- which is very inconvenient in tcSimplify
387 -- ToDo: noLoc sadness
388 = tcSyntaxName orig expected_ty (fromIntegerName, noLoc (HsVar fi)) `thenM` \ (_,expr) ->
389 mkIntegerLit i `thenM` \ integer_lit ->
390 returnM (mkHsApp expr integer_lit)
392 | Just expr <- shortCutIntLit i expected_ty
396 = newLitInst orig lit expected_ty
398 newOverloadedLit orig lit@(HsFractional r fr) expected_ty
399 | fr /= fromRationalName -- c.f. HsIntegral case
400 = tcSyntaxName orig expected_ty (fromRationalName, noLoc (HsVar fr)) `thenM` \ (_,expr) ->
401 mkRatLit r `thenM` \ rat_lit ->
402 returnM (mkHsApp expr rat_lit)
404 | Just expr <- shortCutFracLit r expected_ty
408 = newLitInst orig lit expected_ty
410 newLitInst :: InstOrigin -> HsOverLit -> TcType -> TcM (LHsExpr TcId)
411 newLitInst orig lit expected_ty
412 = getInstLoc orig `thenM` \ loc ->
413 newUnique `thenM` \ new_uniq ->
415 lit_inst = LitInst lit_id lit expected_ty loc
416 lit_id = mkSysLocal FSLIT("lit") new_uniq expected_ty
418 extendLIE lit_inst `thenM_`
419 returnM (L (instLocSrcSpan loc) (HsVar (instToId lit_inst)))
421 shortCutIntLit :: Integer -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-)
423 | isIntTy ty && inIntRange i -- Short cut for Int
424 = Just (noLoc (HsLit (HsInt i)))
425 | isIntegerTy ty -- Short cut for Integer
426 = Just (noLoc (HsLit (HsInteger i ty)))
427 | otherwise = Nothing
429 shortCutFracLit :: Rational -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-)
432 = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
434 = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
435 | otherwise = Nothing
437 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
439 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
440 getSrcSpanM `thenM` \ span ->
441 returnM (L span $ HsLit (HsInteger i integer_ty))
443 mkRatLit :: Rational -> TcM (LHsExpr TcId)
445 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
446 getSrcSpanM `thenM` \ span ->
447 returnM (L span $ HsLit (HsRat r rat_ty))
451 %************************************************************************
455 %************************************************************************
457 Zonking makes sure that the instance types are fully zonked,
458 but doesn't do the same for any of the Ids in an Inst. There's no
459 need, and it's a lot of extra work.
462 zonkInst :: Inst -> TcM Inst
463 zonkInst (Dict id pred loc)
464 = zonkTcPredType pred `thenM` \ new_pred ->
465 returnM (Dict id new_pred loc)
467 zonkInst (Method m id tys theta tau loc)
468 = zonkId id `thenM` \ new_id ->
469 -- Essential to zonk the id in case it's a local variable
470 -- Can't use zonkIdOcc because the id might itself be
471 -- an InstId, in which case it won't be in scope
473 zonkTcTypes tys `thenM` \ new_tys ->
474 zonkTcThetaType theta `thenM` \ new_theta ->
475 zonkTcType tau `thenM` \ new_tau ->
476 returnM (Method m new_id new_tys new_theta new_tau loc)
478 zonkInst (LitInst id lit ty loc)
479 = zonkTcType ty `thenM` \ new_ty ->
480 returnM (LitInst id lit new_ty loc)
482 zonkInsts insts = mappM zonkInst insts
486 %************************************************************************
488 \subsection{Printing}
490 %************************************************************************
492 ToDo: improve these pretty-printing things. The ``origin'' is really only
493 relevant in error messages.
496 instance Outputable Inst where
497 ppr inst = pprInst inst
499 pprDictsTheta :: [Inst] -> SDoc
500 -- Print in type-like fashion (Eq a, Show b)
501 pprDictsTheta dicts = pprTheta (map dictPred dicts)
503 pprDictsInFull :: [Inst] -> SDoc
504 -- Print in type-like fashion, but with source location
506 = vcat (map go dicts)
508 go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))]
510 pprInsts :: [Inst] -> SDoc
511 -- Debugging: print the evidence :: type
512 pprInsts insts = brackets (interpp'SP insts)
514 pprInst, pprInstInFull :: Inst -> SDoc
515 -- Debugging: print the evidence :: type
516 pprInst (LitInst id lit ty loc) = ppr id <+> dcolon <+> ppr ty
517 pprInst (Dict id pred loc) = ppr id <+> dcolon <+> pprPred pred
519 pprInst m@(Method inst_id id tys theta tau loc)
520 = ppr inst_id <+> dcolon <+>
521 braces (sep [ppr id <+> ptext SLIT("at"),
522 brackets (sep (map pprParendType tys))])
525 = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
527 pprDFuns :: [DFunId] -> SDoc
528 -- Prints the dfun as an instance declaration
529 pprDFuns dfuns = vcat [ hang (ppr (getSrcLoc dfun) <> colon)
530 2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta,
531 pprClassPred clas tys])
533 , let (_, theta, clas, tys) = tcSplitDFunTy (idType dfun) ]
534 -- Print without the for-all, which the programmer doesn't write
536 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
538 tidyInst :: TidyEnv -> Inst -> Inst
539 tidyInst env (LitInst u lit ty loc) = LitInst u lit (tidyType env ty) loc
540 tidyInst env (Dict u pred loc) = Dict u (tidyPred env pred) loc
541 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
543 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
544 -- This function doesn't assume that the tyvars are in scope
545 -- so it works like tidyOpenType, returning a TidyEnv
546 tidyMoreInsts env insts
547 = (env', map (tidyInst env') insts)
549 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
551 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
552 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
554 showLIE :: SDoc -> TcM () -- Debugging
556 = do { lie_var <- getLIEVar ;
557 lie <- readMutVar lie_var ;
558 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
562 %************************************************************************
564 Extending the instance environment
566 %************************************************************************
569 tcExtendLocalInstEnv :: [DFunId] -> TcM a -> TcM a
570 -- Add new locally-defined instances
571 tcExtendLocalInstEnv dfuns thing_inside
572 = do { traceDFuns dfuns
575 ; inst_env' <- foldlM (addInst dflags) (tcg_inst_env env) dfuns
576 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
577 tcg_inst_env = inst_env' }
578 ; setGblEnv env' thing_inside }
580 addInst :: DynFlags -> InstEnv -> DFunId -> TcM InstEnv
581 -- Check that the proposed new instance is OK,
582 -- and then add it to the home inst env
583 addInst dflags home_ie dfun
584 = do { -- Load imported instances, so that we report
585 -- duplicates correctly
586 pkg_ie <- loadImportedInsts cls tys
588 -- Check functional dependencies
589 ; case checkFunDeps (pkg_ie, home_ie) dfun of
590 Just dfuns -> funDepErr dfun dfuns
593 -- Check for duplicate instance decls
594 ; let { (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys
595 ; dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
596 isJust (matchTys (mkVarSet tvs) tys dup_tys)] }
597 -- Find memebers of the match list which
598 -- dfun itself matches. If the match is 2-way, it's a duplicate
600 dup_dfun : _ -> dupInstErr dfun dup_dfun
603 -- OK, now extend the envt
604 ; return (extendInstEnv home_ie dfun) }
606 (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
609 = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
611 pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
615 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
616 2 (pprDFuns (dfun:dfuns)))
617 dupInstErr dfun dup_dfun
619 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
620 2 (pprDFuns [dfun, dup_dfun]))
622 addDictLoc dfun thing_inside
623 = addSrcSpan (mkSrcSpan loc loc) thing_inside
628 %************************************************************************
630 \subsection{Looking up Insts}
632 %************************************************************************
635 data LookupInstResult s
637 | SimpleInst (LHsExpr TcId) -- Just a variable, type application, or literal
638 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
640 lookupInst :: Inst -> TcM (LookupInstResult s)
641 -- It's important that lookupInst does not put any new stuff into
642 -- the LIE. Instead, any Insts needed by the lookup are returned in
643 -- the LookupInstResult, where they can be further processed by tcSimplify
648 lookupInst inst@(Method _ id tys theta _ loc)
649 = newDictsAtLoc loc theta `thenM` \ dicts ->
650 returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (L span (HsVar id)) tys) (map instToId dicts)))
652 span = instLocSrcSpan loc
656 -- Look for short cuts first: if the literal is *definitely* a
657 -- int, integer, float or a double, generate the real thing here.
658 -- This is essential (see nofib/spectral/nucleic).
659 -- [Same shortcut as in newOverloadedLit, but we
660 -- may have done some unification by now]
663 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
664 | Just expr <- shortCutIntLit i ty
665 = returnM (GenInst [] expr) -- GenInst, not SimpleInst, because
666 -- expr may be a constructor application
668 = ASSERT( from_integer_name == fromIntegerName ) -- A LitInst invariant
669 tcLookupId fromIntegerName `thenM` \ from_integer ->
670 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
671 mkIntegerLit i `thenM` \ integer_lit ->
672 returnM (GenInst [method_inst]
673 (mkHsApp (L (instLocSrcSpan loc)
674 (HsVar (instToId method_inst))) integer_lit))
676 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
677 | Just expr <- shortCutFracLit f ty
678 = returnM (GenInst [] expr)
681 = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
682 tcLookupId fromRationalName `thenM` \ from_rational ->
683 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
684 mkRatLit f `thenM` \ rat_lit ->
685 returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc)
686 (HsVar (instToId method_inst))) rat_lit))
689 lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
690 = do { dflags <- getDOpts
691 ; if all tcIsTyVarTy tys &&
692 not (dopt Opt_AllowUndecidableInstances dflags)
693 -- Common special case; no lookup
694 -- NB: tcIsTyVarTy... don't look through newtypes!
695 -- Don't take this short cut if we allow undecidable instances
696 -- because we might have "instance T a where ...".
697 -- [That means we need -fallow-undecidable-instances in the
698 -- client module, as well as the module with the instance decl.]
699 then return NoInstance
702 { pkg_ie <- loadImportedInsts clas tys
703 -- Suck in any instance decls that may be relevant
704 ; tcg_env <- getGblEnv
705 ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
706 ([(tenv, (_,_,dfun_id))], []) -> instantiate_dfun tenv dfun_id pred loc ;
707 (matches, unifs) -> do
708 { traceTc (text "lookupInst" <+> vcat [text "matches" <+> ppr matches,
709 text "unifs" <+> ppr unifs])
710 ; return NoInstance } } } }
711 -- In the case of overlap (multiple matches) we report
712 -- NoInstance here. That has the effect of making the
713 -- context-simplifier return the dict as an irreducible one.
714 -- Then it'll be given to addNoInstanceErrs, which will do another
715 -- lookupInstEnv to get the detailed info about what went wrong.
717 lookupInst (Dict _ _ _) = returnM NoInstance
720 instantiate_dfun tenv dfun_id pred loc
721 = -- Record that this dfun is needed
722 record_dfun_usage dfun_id `thenM_`
724 -- It's possible that not all the tyvars are in
725 -- the substitution, tenv. For example:
726 -- instance C X a => D X where ...
727 -- (presumably there's a functional dependency in class C)
728 -- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
729 getStage `thenM` \ use_stage ->
730 checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
731 (topIdLvl dfun_id) use_stage `thenM_`
733 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
734 mk_ty_arg tv = case lookupSubstEnv tenv tv of
735 Just (DoneTy ty) -> returnM ty
736 Nothing -> tcInstTyVar VanillaTv tv `thenM` \ tc_tv ->
737 returnM (mkTyVarTy tc_tv)
739 mappM mk_ty_arg tyvars `thenM` \ ty_args ->
741 dfun_rho = substTy (mkTyVarSubst tyvars ty_args) rho
742 (theta, _) = tcSplitPhiTy dfun_rho
743 ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id)) ty_args
746 returnM (SimpleInst ty_app)
748 newDictsAtLoc loc theta `thenM` \ dicts ->
750 rhs = mkHsDictApp ty_app (map instToId dicts)
752 returnM (GenInst dicts rhs)
754 record_dfun_usage dfun_id
755 | isInternalName dfun_name = return () -- From this module
756 | not (isHomePackageName dfun_name) = return () -- From another package package
757 | otherwise = getGblEnv `thenM` \ tcg_env ->
758 updMutVar (tcg_inst_uses tcg_env)
759 (`addOneToNameSet` idName dfun_id)
761 dfun_name = idName dfun_id
763 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
764 -- Gets both the home-pkg inst env (includes module being compiled)
765 -- and the external-package inst-env
766 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
767 return (tcg_inst_env env, eps_inst_env eps) }
772 %************************************************************************
776 %************************************************************************
779 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
780 a do-expression. We have to find (>>) in the current environment, which is
781 done by the rename. Then we have to check that it has the same type as
782 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
785 (>>) :: HB m n mn => m a -> n b -> mn b
787 So the idea is to generate a local binding for (>>), thus:
789 let then72 :: forall a b. m a -> m b -> m b
790 then72 = ...something involving the user's (>>)...
792 ...the do-expression...
794 Now the do-expression can proceed using then72, which has exactly
797 In fact tcSyntaxName just generates the RHS for then72, because we only
798 want an actual binding in the do-expression case. For literals, we can
799 just use the expression inline.
802 tcSyntaxName :: InstOrigin
803 -> TcType -- Type to instantiate it at
804 -> (Name, LHsExpr Name) -- (Standard name, user name)
805 -> TcM (Name, LHsExpr TcId) -- (Standard name, suitable expression)
807 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
808 -- So we do not call it from lookupInst, which is called from tcSimplify
810 tcSyntaxName orig ty (std_nm, L span (HsVar user_nm))
812 = addSrcSpan span (tcStdSyntaxName orig ty std_nm)
814 tcSyntaxName orig ty (std_nm, user_nm_expr)
815 = tcLookupId std_nm `thenM` \ std_id ->
817 -- C.f. newMethodAtLoc
818 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
819 tau1 = substTyWith [tv] [ty] tau
820 -- Actually, the "tau-type" might be a sigma-type in the
821 -- case of locally-polymorphic methods.
823 addErrCtxtM (syntaxNameCtxt user_nm_expr orig tau1) $
825 -- Check that the user-supplied thing has the
826 -- same type as the standard one
827 tcCheckSigma user_nm_expr tau1 `thenM` \ expr ->
828 returnM (std_nm, expr)
830 tcStdSyntaxName :: InstOrigin
831 -> TcType -- Type to instantiate it at
832 -> Name -- Standard name
833 -> TcM (Name, LHsExpr TcId) -- (Standard name, suitable expression)
835 tcStdSyntaxName orig ty std_nm
836 = newMethodFromName orig ty std_nm `thenM` \ id ->
837 getSrcSpanM `thenM` \ span ->
838 returnM (std_nm, L span (HsVar id))
840 syntaxNameCtxt name orig ty tidy_env
841 = getInstLoc orig `thenM` \ inst_loc ->
843 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
844 ptext SLIT("(needed by a syntactic construct)"),
845 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
846 nest 2 (pprInstLoc inst_loc)]
848 returnM (tidy_env, msg)