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, 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, noLoc (HsVar fi)) `thenM` \ (_,expr) ->
397 mkIntegerLit i `thenM` \ integer_lit ->
398 returnM (mkHsApp expr integer_lit)
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, noLoc (HsVar fr)) `thenM` \ (_,expr) ->
409 mkRatLit r `thenM` \ rat_lit ->
410 returnM (mkHsApp expr rat_lit)
412 | Just expr <- shortCutFracLit r expected_ty
416 = newLitInst orig lit expected_ty
418 newLitInst :: InstOrigin -> HsOverLit -> TcType -> TcM (LHsExpr TcId)
419 newLitInst orig lit expected_ty
420 = getInstLoc orig `thenM` \ loc ->
421 newUnique `thenM` \ new_uniq ->
423 lit_inst = LitInst lit_id lit expected_ty loc
424 lit_id = mkSysLocal FSLIT("lit") new_uniq expected_ty
426 extendLIE lit_inst `thenM_`
427 returnM (L (instLocSrcSpan loc) (HsVar (instToId lit_inst)))
429 shortCutIntLit :: Integer -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-)
431 | isIntTy ty && inIntRange i -- Short cut for Int
432 = Just (noLoc (HsLit (HsInt i)))
433 | isIntegerTy ty -- Short cut for Integer
434 = Just (noLoc (HsLit (HsInteger i ty)))
435 | otherwise = Nothing
437 shortCutFracLit :: Rational -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-)
440 = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
442 = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
443 | otherwise = Nothing
445 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
447 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
448 getSrcSpanM `thenM` \ span ->
449 returnM (L span $ HsLit (HsInteger i integer_ty))
451 mkRatLit :: Rational -> TcM (LHsExpr TcId)
453 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
454 getSrcSpanM `thenM` \ span ->
455 returnM (L span $ HsLit (HsRat r rat_ty))
459 %************************************************************************
463 %************************************************************************
465 Zonking makes sure that the instance types are fully zonked,
466 but doesn't do the same for any of the Ids in an Inst. There's no
467 need, and it's a lot of extra work.
470 zonkInst :: Inst -> TcM Inst
471 zonkInst (Dict id pred loc)
472 = zonkTcPredType pred `thenM` \ new_pred ->
473 returnM (Dict id new_pred loc)
475 zonkInst (Method m id tys theta tau loc)
476 = zonkId id `thenM` \ new_id ->
477 -- Essential to zonk the id in case it's a local variable
478 -- Can't use zonkIdOcc because the id might itself be
479 -- an InstId, in which case it won't be in scope
481 zonkTcTypes tys `thenM` \ new_tys ->
482 zonkTcThetaType theta `thenM` \ new_theta ->
483 zonkTcType tau `thenM` \ new_tau ->
484 returnM (Method m new_id new_tys new_theta new_tau loc)
486 zonkInst (LitInst id lit ty loc)
487 = zonkTcType ty `thenM` \ new_ty ->
488 returnM (LitInst id lit new_ty loc)
490 zonkInsts insts = mappM zonkInst insts
494 %************************************************************************
496 \subsection{Printing}
498 %************************************************************************
500 ToDo: improve these pretty-printing things. The ``origin'' is really only
501 relevant in error messages.
504 instance Outputable Inst where
505 ppr inst = pprInst inst
507 pprDictsTheta :: [Inst] -> SDoc
508 -- Print in type-like fashion (Eq a, Show b)
509 pprDictsTheta dicts = pprTheta (map dictPred dicts)
511 pprDictsInFull :: [Inst] -> SDoc
512 -- Print in type-like fashion, but with source location
514 = vcat (map go dicts)
516 go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))]
518 pprInsts :: [Inst] -> SDoc
519 -- Debugging: print the evidence :: type
520 pprInsts insts = brackets (interpp'SP insts)
522 pprInst, pprInstInFull :: Inst -> SDoc
523 -- Debugging: print the evidence :: type
524 pprInst (LitInst id lit ty loc) = ppr id <+> dcolon <+> ppr ty
525 pprInst (Dict id pred loc) = ppr id <+> dcolon <+> pprPred pred
527 pprInst m@(Method inst_id id tys theta tau loc)
528 = ppr inst_id <+> dcolon <+>
529 braces (sep [ppr id <+> ptext SLIT("at"),
530 brackets (sep (map pprParendType tys))])
533 = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
535 pprDFuns :: [DFunId] -> SDoc
536 -- Prints the dfun as an instance declaration
537 pprDFuns dfuns = vcat [ hang (ppr (getSrcLoc dfun) <> colon)
538 2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta,
539 pprClassPred clas tys])
541 , let (_, theta, clas, tys) = tcSplitDFunTy (idType dfun) ]
542 -- Print without the for-all, which the programmer doesn't write
544 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
546 tidyInst :: TidyEnv -> Inst -> Inst
547 tidyInst env (LitInst u lit ty loc) = LitInst u lit (tidyType env ty) loc
548 tidyInst env (Dict u pred loc) = Dict u (tidyPred env pred) loc
549 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
551 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
552 -- This function doesn't assume that the tyvars are in scope
553 -- so it works like tidyOpenType, returning a TidyEnv
554 tidyMoreInsts env insts
555 = (env', map (tidyInst env') insts)
557 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
559 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
560 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
562 showLIE :: SDoc -> TcM () -- Debugging
564 = do { lie_var <- getLIEVar ;
565 lie <- readMutVar lie_var ;
566 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
570 %************************************************************************
572 Extending the instance environment
574 %************************************************************************
577 tcExtendLocalInstEnv :: [DFunId] -> TcM a -> TcM a
578 -- Add new locally-defined instances
579 tcExtendLocalInstEnv dfuns thing_inside
580 = do { traceDFuns dfuns
583 ; inst_env' <- foldlM (addInst dflags) (tcg_inst_env env) dfuns
584 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
585 tcg_inst_env = inst_env' }
586 ; setGblEnv env' thing_inside }
588 addInst :: DynFlags -> InstEnv -> DFunId -> TcM InstEnv
589 -- Check that the proposed new instance is OK,
590 -- and then add it to the home inst env
591 addInst dflags home_ie dfun
592 = do { -- Load imported instances, so that we report
593 -- duplicates correctly
594 pkg_ie <- loadImportedInsts cls tys
596 -- Check functional dependencies
597 ; case checkFunDeps (pkg_ie, home_ie) dfun of
598 Just dfuns -> funDepErr dfun dfuns
601 -- Check for duplicate instance decls
602 ; let { (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys
603 ; dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
604 isJust (matchTys (mkVarSet tvs) tys dup_tys)] }
605 -- Find memebers of the match list which
606 -- dfun itself matches. If the match is 2-way, it's a duplicate
608 dup_dfun : _ -> dupInstErr dfun dup_dfun
611 -- OK, now extend the envt
612 ; return (extendInstEnv home_ie dfun) }
614 (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
617 = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
619 pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
623 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
624 2 (pprDFuns (dfun:dfuns)))
625 dupInstErr dfun dup_dfun
627 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
628 2 (pprDFuns [dfun, dup_dfun]))
630 addDictLoc dfun thing_inside
631 = addSrcSpan (mkSrcSpan loc loc) thing_inside
636 %************************************************************************
638 \subsection{Looking up Insts}
640 %************************************************************************
643 data LookupInstResult s
645 | SimpleInst (LHsExpr TcId) -- Just a variable, type application, or literal
646 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
648 lookupInst :: Inst -> TcM (LookupInstResult s)
649 -- It's important that lookupInst does not put any new stuff into
650 -- the LIE. Instead, any Insts needed by the lookup are returned in
651 -- the LookupInstResult, where they can be further processed by tcSimplify
656 lookupInst inst@(Method _ id tys theta _ loc)
657 = newDictsAtLoc loc theta `thenM` \ dicts ->
658 returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (L span (HsVar id)) tys) (map instToId dicts)))
660 span = instLocSrcSpan loc
664 -- Look for short cuts first: if the literal is *definitely* a
665 -- int, integer, float or a double, generate the real thing here.
666 -- This is essential (see nofib/spectral/nucleic).
667 -- [Same shortcut as in newOverloadedLit, but we
668 -- may have done some unification by now]
671 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
672 | Just expr <- shortCutIntLit i ty
673 = returnM (GenInst [] expr) -- GenInst, not SimpleInst, because
674 -- expr may be a constructor application
676 = ASSERT( from_integer_name == fromIntegerName ) -- A LitInst invariant
677 tcLookupId fromIntegerName `thenM` \ from_integer ->
678 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
679 mkIntegerLit i `thenM` \ integer_lit ->
680 returnM (GenInst [method_inst]
681 (mkHsApp (L (instLocSrcSpan loc)
682 (HsVar (instToId method_inst))) integer_lit))
684 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
685 | Just expr <- shortCutFracLit f ty
686 = returnM (GenInst [] expr)
689 = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
690 tcLookupId fromRationalName `thenM` \ from_rational ->
691 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
692 mkRatLit f `thenM` \ rat_lit ->
693 returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc)
694 (HsVar (instToId method_inst))) rat_lit))
697 lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
698 = do { pkg_ie <- loadImportedInsts clas tys
699 -- Suck in any instance decls that may be relevant
700 ; tcg_env <- getGblEnv
702 ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
703 ([(tenv, (_,_,dfun_id))], []) -> instantiate_dfun tenv dfun_id pred loc ;
704 (matches, unifs) -> do
705 { traceTc (text "lookupInst fail" <+> vcat [text "dict" <+> ppr pred,
706 text "matches" <+> ppr matches,
707 text "unifs" <+> ppr unifs])
708 ; return NoInstance } } }
709 -- In the case of overlap (multiple matches) we report
710 -- NoInstance here. That has the effect of making the
711 -- context-simplifier return the dict as an irreducible one.
712 -- Then it'll be given to addNoInstanceErrs, which will do another
713 -- lookupInstEnv to get the detailed info about what went wrong.
715 lookupInst (Dict _ _ _) = returnM NoInstance
718 instantiate_dfun tenv dfun_id pred loc
719 = traceTc (text "lookupInst success" <+>
720 vcat [text "dict" <+> ppr pred,
721 text "witness" <+> ppr dfun_id <+> ppr (idType dfun_id) ]) `thenM_`
722 -- Record that this dfun is needed
723 record_dfun_usage dfun_id `thenM_`
725 -- It's possible that not all the tyvars are in
726 -- the substitution, tenv. For example:
727 -- instance C X a => D X where ...
728 -- (presumably there's a functional dependency in class C)
729 -- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
730 getStage `thenM` \ use_stage ->
731 checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
732 (topIdLvl dfun_id) use_stage `thenM_`
734 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
735 mk_ty_arg tv = case lookupSubstEnv tenv tv of
736 Just (DoneTy ty) -> returnM ty
737 Nothing -> tcInstTyVar VanillaTv tv `thenM` \ tc_tv ->
738 returnM (mkTyVarTy tc_tv)
740 mappM mk_ty_arg tyvars `thenM` \ ty_args ->
742 dfun_rho = substTy (mkTopTyVarSubst tyvars ty_args) rho
743 -- Since the tyvars are freshly made,
744 -- they cannot possibly be captured by
745 -- any existing for-alls. Hence mkTopTyVarSubst
746 (theta, _) = tcSplitPhiTy dfun_rho
747 ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id)) ty_args
750 returnM (SimpleInst ty_app)
752 newDictsAtLoc loc theta `thenM` \ dicts ->
754 rhs = mkHsDictApp ty_app (map instToId dicts)
756 returnM (GenInst dicts rhs)
758 record_dfun_usage dfun_id
759 | isInternalName dfun_name = return () -- From this module
760 | not (isHomePackageName dfun_name) = return () -- From another package package
761 | otherwise = getGblEnv `thenM` \ tcg_env ->
762 updMutVar (tcg_inst_uses tcg_env)
763 (`addOneToNameSet` idName dfun_id)
765 dfun_name = idName dfun_id
767 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
768 -- Gets both the home-pkg inst env (includes module being compiled)
769 -- and the external-package inst-env
770 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
771 return (tcg_inst_env env, eps_inst_env eps) }
776 %************************************************************************
780 %************************************************************************
783 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
784 a do-expression. We have to find (>>) in the current environment, which is
785 done by the rename. Then we have to check that it has the same type as
786 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
789 (>>) :: HB m n mn => m a -> n b -> mn b
791 So the idea is to generate a local binding for (>>), thus:
793 let then72 :: forall a b. m a -> m b -> m b
794 then72 = ...something involving the user's (>>)...
796 ...the do-expression...
798 Now the do-expression can proceed using then72, which has exactly
801 In fact tcSyntaxName just generates the RHS for then72, because we only
802 want an actual binding in the do-expression case. For literals, we can
803 just use the expression inline.
806 tcSyntaxName :: InstOrigin
807 -> TcType -- Type to instantiate it at
808 -> (Name, LHsExpr Name) -- (Standard name, user name)
809 -> TcM (Name, LHsExpr TcId) -- (Standard name, suitable expression)
811 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
812 -- So we do not call it from lookupInst, which is called from tcSimplify
814 tcSyntaxName orig ty (std_nm, L span (HsVar user_nm))
816 = addSrcSpan span (tcStdSyntaxName orig ty std_nm)
818 tcSyntaxName orig ty (std_nm, user_nm_expr)
819 = tcLookupId std_nm `thenM` \ std_id ->
821 -- C.f. newMethodAtLoc
822 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
823 tau1 = substTyWith [tv] [ty] tau
824 -- Actually, the "tau-type" might be a sigma-type in the
825 -- case of locally-polymorphic methods.
827 addErrCtxtM (syntaxNameCtxt user_nm_expr orig tau1) $
829 -- Check that the user-supplied thing has the
830 -- same type as the standard one
831 tcCheckSigma user_nm_expr tau1 `thenM` \ expr ->
832 returnM (std_nm, expr)
834 tcStdSyntaxName :: InstOrigin
835 -> TcType -- Type to instantiate it at
836 -> Name -- Standard name
837 -> TcM (Name, LHsExpr TcId) -- (Standard name, suitable expression)
839 tcStdSyntaxName orig ty std_nm
840 = newMethodFromName orig ty std_nm `thenM` \ id ->
841 getSrcSpanM `thenM` \ span ->
842 returnM (std_nm, L span (HsVar id))
844 syntaxNameCtxt name orig ty tidy_env
845 = getInstLoc orig `thenM` \ inst_loc ->
847 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
848 ptext SLIT("(needed by a syntactic construct)"),
849 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
850 nest 2 (pprInstLoc inst_loc)]
852 returnM (tidy_env, msg)