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, newDictsAtLoc, cloneDict,
16 newOverloadedLit, newIPDict,
17 newMethod, newMethodFromName, newMethodWithGivenTy,
18 tcInstClassOp, tcInstCall, tcInstStupidTheta,
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, TcTyVar,
57 PredType(..), typeKind,
58 tcSplitForAllTys, tcSplitForAllTys,
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,
66 tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy,
67 pprPred, pprParendType, pprThetaArrow, pprTheta, pprClassPred
69 import Type ( substTy, substTys, substTyWith, substTheta, zipTopTvSubst )
70 import Unify ( matchTys )
71 import Kind ( isSubKind )
72 import HscTypes ( ExternalPackageState(..) )
73 import CoreFVs ( idFreeTyVars )
74 import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName )
75 import Id ( Id, idName, idType, mkUserLocal, mkLocalId )
76 import PrelInfo ( isStandardClass, isNoDictClass )
77 import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, isHomePackageName,
78 isInternalName, setNameUnique, mkSystemNameEncoded )
79 import NameSet ( addOneToNameSet )
80 import Literal ( inIntRange )
81 import Var ( TyVar, tyVarKind )
82 import VarEnv ( TidyEnv, emptyTidyEnv, lookupVarEnv )
83 import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
84 import TysWiredIn ( floatDataCon, doubleDataCon )
85 import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
86 import BasicTypes( IPName(..), mapIPName, ipNameName )
87 import UniqSupply( uniqsFromSupply )
88 import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) )
89 import CmdLineOpts( DynFlags )
90 import Maybes ( isJust )
98 instName :: Inst -> Name
99 instName inst = idName (instToId inst)
101 instToId :: Inst -> TcId
102 instToId (LitInst nm _ ty _) = mkLocalId nm ty
103 instToId (Dict nm pred _) = mkLocalId nm (mkPredTy pred)
104 instToId (Method id _ _ _ _ _) = id
106 instLoc (Dict _ _ loc) = loc
107 instLoc (Method _ _ _ _ _ loc) = loc
108 instLoc (LitInst _ _ _ loc) = loc
110 dictPred (Dict _ pred _ ) = pred
111 dictPred inst = pprPanic "dictPred" (ppr inst)
113 getDictClassTys (Dict _ pred _) = getClassPredTys pred
115 -- fdPredsOfInst is used to get predicates that contain functional
116 -- dependencies *or* might do so. The "might do" part is because
117 -- a constraint (C a b) might have a superclass with FDs
118 -- Leaving these in is really important for the call to fdPredsOfInsts
119 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
120 -- which is supposed to be conservative
121 fdPredsOfInst (Dict _ pred _) = [pred]
122 fdPredsOfInst (Method _ _ _ theta _ _) = theta
123 fdPredsOfInst other = [] -- LitInsts etc
125 fdPredsOfInsts :: [Inst] -> [PredType]
126 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
128 isInheritableInst (Dict _ pred _) = isInheritablePred pred
129 isInheritableInst (Method _ _ _ theta _ _) = all isInheritablePred theta
130 isInheritableInst other = True
133 ipNamesOfInsts :: [Inst] -> [Name]
134 ipNamesOfInst :: Inst -> [Name]
135 -- Get the implicit parameters mentioned by these Insts
136 -- NB: ?x and %x get different Names
137 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
139 ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
140 ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
141 ipNamesOfInst other = []
143 tyVarsOfInst :: Inst -> TcTyVarSet
144 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
145 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
146 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
147 -- The id might have free type variables; in the case of
148 -- locally-overloaded class methods, for example
151 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
152 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
158 isDict :: Inst -> Bool
159 isDict (Dict _ _ _) = True
162 isClassDict :: Inst -> Bool
163 isClassDict (Dict _ pred _) = isClassPred pred
164 isClassDict other = False
166 isTyVarDict :: Inst -> Bool
167 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
168 isTyVarDict other = False
170 isIPDict :: Inst -> Bool
171 isIPDict (Dict _ pred _) = isIPPred pred
172 isIPDict other = False
174 isMethod :: Inst -> Bool
175 isMethod (Method _ _ _ _ _ _) = True
176 isMethod other = False
178 isMethodFor :: TcIdSet -> Inst -> Bool
179 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
180 isMethodFor ids inst = False
182 isLinearInst :: Inst -> Bool
183 isLinearInst (Dict _ pred _) = isLinearPred pred
184 isLinearInst other = False
185 -- We never build Method Insts that have
186 -- linear implicit paramters in them.
187 -- Hence no need to look for Methods
190 linearInstType :: Inst -> TcType -- %x::t --> t
191 linearInstType (Dict _ (IParam _ ty) _) = ty
194 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
195 Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
199 Two predicates which deal with the case where class constraints don't
200 necessarily result in bindings. The first tells whether an @Inst@
201 must be witnessed by an actual binding; the second tells whether an
202 @Inst@ can be generalised over.
205 instBindingRequired :: Inst -> Bool
206 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
207 instBindingRequired other = True
211 %************************************************************************
213 \subsection{Building dictionaries}
215 %************************************************************************
218 newDicts :: InstOrigin
222 = getInstLoc orig `thenM` \ loc ->
223 newDictsAtLoc loc theta
225 cloneDict :: Inst -> TcM Inst
226 cloneDict (Dict nm ty loc) = newUnique `thenM` \ uniq ->
227 returnM (Dict (setNameUnique nm uniq) ty loc)
229 newDictsFromOld :: Inst -> TcThetaType -> TcM [Inst]
230 newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
232 -- Local function, similar to newDicts,
233 -- but with slightly different interface
234 newDictsAtLoc :: InstLoc
237 newDictsAtLoc inst_loc theta
238 = newUniqueSupply `thenM` \ us ->
239 returnM (zipWith mk_dict (uniqsFromSupply us) theta)
241 mk_dict uniq pred = Dict (mkPredName uniq loc pred)
243 loc = instLocSrcLoc inst_loc
245 -- For vanilla implicit parameters, there is only one in scope
246 -- at any time, so we used to use the name of the implicit parameter itself
247 -- But with splittable implicit parameters there may be many in
248 -- scope, so we make up a new name.
249 newIPDict :: InstOrigin -> IPName Name -> Type
250 -> TcM (IPName Id, Inst)
251 newIPDict orig ip_name ty
252 = getInstLoc orig `thenM` \ inst_loc ->
253 newUnique `thenM` \ uniq ->
255 pred = IParam ip_name ty
256 name = mkPredName uniq (instLocSrcLoc inst_loc) pred
257 dict = Dict name pred inst_loc
259 returnM (mapIPName (\n -> instToId dict) ip_name, dict)
264 %************************************************************************
266 \subsection{Building methods (calls of overloaded functions)}
268 %************************************************************************
272 tcInstCall :: InstOrigin -> TcType -> TcM (ExprCoFn, [TcTyVar], TcType)
273 tcInstCall orig fun_ty -- fun_ty is usually a sigma-type
274 = do { (tyvars, theta, tau) <- tcInstType fun_ty
275 ; dicts <- newDicts orig theta
277 ; let inst_fn e = unLoc (mkHsDictApp (mkHsTyApp (noLoc e) (mkTyVarTys tyvars))
278 (map instToId dicts))
279 ; return (mkCoercion inst_fn, tyvars, tau) }
281 tcInstStupidTheta :: DataCon -> [TcType] -> TcM ()
282 -- Instantiate the "stupid theta" of the data con, and throw
283 -- the constraints into the constraint set
284 tcInstStupidTheta data_con inst_tys
288 = do { stupid_dicts <- newDicts (OccurrenceOf (dataConName data_con))
289 (substTheta tenv stupid_theta)
290 ; extendLIEs stupid_dicts }
292 stupid_theta = dataConStupidTheta data_con
293 tenv = zipTopTvSubst (dataConTyVars data_con) inst_tys
295 newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId
296 newMethodFromName origin ty name
297 = tcLookupId name `thenM` \ id ->
298 -- Use tcLookupId not tcLookupGlobalId; the method is almost
299 -- always a class op, but with -fno-implicit-prelude GHC is
300 -- meant to find whatever thing is in scope, and that may
301 -- be an ordinary function.
302 getInstLoc origin `thenM` \ loc ->
303 tcInstClassOp loc id [ty] `thenM` \ inst ->
304 extendLIE inst `thenM_`
305 returnM (instToId inst)
307 newMethodWithGivenTy orig id tys theta tau
308 = getInstLoc orig `thenM` \ loc ->
309 newMethod loc id tys theta tau `thenM` \ inst ->
310 extendLIE inst `thenM_`
311 returnM (instToId inst)
313 --------------------------------------------
314 -- tcInstClassOp, and newMethod do *not* drop the
315 -- Inst into the LIE; they just returns the Inst
316 -- This is important because they are used by TcSimplify
319 -- NB: the kind of the type variable to be instantiated
320 -- might be a sub-kind of the type to which it is applied,
321 -- notably when the latter is a type variable of kind ??
322 -- Hence the call to checkKind
323 -- A worry: is this needed anywhere else?
324 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
325 tcInstClassOp inst_loc sel_id tys
327 (tyvars,rho) = tcSplitForAllTys (idType sel_id)
328 rho_ty = ASSERT( length tyvars == length tys )
329 substTyWith tyvars tys rho
330 (preds,tau) = tcSplitPhiTy rho_ty
332 zipWithM_ checkKind tyvars tys `thenM_`
333 newMethod inst_loc sel_id tys preds tau
335 checkKind :: TyVar -> TcType -> TcM ()
336 -- Ensure that the type has a sub-kind of the tyvar
338 = do { ty1 <- zonkTcType ty
339 ; if typeKind ty1 `isSubKind` tyVarKind tv
342 { traceTc (text "checkKind: adding kind constraint" <+> ppr tv <+> ppr ty)
343 ; tv1 <- tcInstTyVar tv
344 ; unifyTauTy (mkTyVarTy tv1) ty1 }}
347 ---------------------------
348 newMethod inst_loc id tys theta tau
349 = newUnique `thenM` \ new_uniq ->
351 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
352 inst = Method meth_id id tys theta tau inst_loc
353 loc = instLocSrcLoc inst_loc
358 In newOverloadedLit we convert directly to an Int or Integer if we
359 know that's what we want. This may save some time, by not
360 temporarily generating overloaded literals, but it won't catch all
361 cases (the rest are caught in lookupInst).
364 newOverloadedLit :: InstOrigin
367 -> TcM (LHsExpr TcId)
368 newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
369 | fi /= fromIntegerName -- Do not generate a LitInst for rebindable syntax.
370 -- Reason: tcSyntaxName does unification
371 -- which is very inconvenient in tcSimplify
372 -- ToDo: noLoc sadness
373 = tcSyntaxName orig expected_ty (fromIntegerName, HsVar fi) `thenM` \ (_,expr) ->
374 mkIntegerLit i `thenM` \ integer_lit ->
375 returnM (mkHsApp (noLoc expr) integer_lit)
376 -- The mkHsApp will get the loc from the literal
377 | Just expr <- shortCutIntLit i expected_ty
381 = newLitInst orig lit expected_ty
383 newOverloadedLit orig lit@(HsFractional r fr) expected_ty
384 | fr /= fromRationalName -- c.f. HsIntegral case
385 = tcSyntaxName orig expected_ty (fromRationalName, HsVar fr) `thenM` \ (_,expr) ->
386 mkRatLit r `thenM` \ rat_lit ->
387 returnM (mkHsApp (noLoc expr) rat_lit)
388 -- The mkHsApp will get the loc from the literal
390 | Just expr <- shortCutFracLit r expected_ty
394 = newLitInst orig lit expected_ty
396 newLitInst :: InstOrigin -> HsOverLit -> TcType -> TcM (LHsExpr TcId)
397 newLitInst orig lit expected_ty
398 = getInstLoc orig `thenM` \ loc ->
399 newUnique `thenM` \ new_uniq ->
401 lit_nm = mkSystemNameEncoded new_uniq FSLIT("lit")
402 -- The "encoded" bit means that we don't need to z-encode
403 -- the string every time we call this!
404 lit_inst = LitInst lit_nm lit expected_ty loc
406 extendLIE lit_inst `thenM_`
407 returnM (L (instLocSrcSpan loc) (HsVar (instToId lit_inst)))
409 shortCutIntLit :: Integer -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-)
411 | isIntTy ty && inIntRange i -- Short cut for Int
412 = Just (noLoc (HsLit (HsInt i)))
413 | isIntegerTy ty -- Short cut for Integer
414 = Just (noLoc (HsLit (HsInteger i ty)))
415 | otherwise = Nothing
417 shortCutFracLit :: Rational -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-)
420 = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
422 = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
423 | otherwise = Nothing
425 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
427 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
428 getSrcSpanM `thenM` \ span ->
429 returnM (L span $ HsLit (HsInteger i integer_ty))
431 mkRatLit :: Rational -> TcM (LHsExpr TcId)
433 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
434 getSrcSpanM `thenM` \ span ->
435 returnM (L span $ HsLit (HsRat r rat_ty))
439 %************************************************************************
443 %************************************************************************
445 Zonking makes sure that the instance types are fully zonked.
448 zonkInst :: Inst -> TcM Inst
449 zonkInst (Dict name pred loc)
450 = zonkTcPredType pred `thenM` \ new_pred ->
451 returnM (Dict name new_pred loc)
453 zonkInst (Method m id tys theta tau loc)
454 = zonkId id `thenM` \ new_id ->
455 -- Essential to zonk the id in case it's a local variable
456 -- Can't use zonkIdOcc because the id might itself be
457 -- an InstId, in which case it won't be in scope
459 zonkTcTypes tys `thenM` \ new_tys ->
460 zonkTcThetaType theta `thenM` \ new_theta ->
461 zonkTcType tau `thenM` \ new_tau ->
462 returnM (Method m new_id new_tys new_theta new_tau loc)
464 zonkInst (LitInst nm lit ty loc)
465 = zonkTcType ty `thenM` \ new_ty ->
466 returnM (LitInst nm lit new_ty loc)
468 zonkInsts insts = mappM zonkInst insts
472 %************************************************************************
474 \subsection{Printing}
476 %************************************************************************
478 ToDo: improve these pretty-printing things. The ``origin'' is really only
479 relevant in error messages.
482 instance Outputable Inst where
483 ppr inst = pprInst inst
485 pprDictsTheta :: [Inst] -> SDoc
486 -- Print in type-like fashion (Eq a, Show b)
487 pprDictsTheta dicts = pprTheta (map dictPred dicts)
489 pprDictsInFull :: [Inst] -> SDoc
490 -- Print in type-like fashion, but with source location
492 = vcat (map go dicts)
494 go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))]
496 pprInsts :: [Inst] -> SDoc
497 -- Debugging: print the evidence :: type
498 pprInsts insts = brackets (interpp'SP insts)
500 pprInst, pprInstInFull :: Inst -> SDoc
501 -- Debugging: print the evidence :: type
502 pprInst (LitInst nm lit ty loc) = ppr nm <+> dcolon <+> ppr ty
503 pprInst (Dict nm pred loc) = ppr nm <+> dcolon <+> pprPred pred
505 pprInst m@(Method inst_id id tys theta tau loc)
506 = ppr inst_id <+> dcolon <+>
507 braces (sep [ppr id <+> ptext SLIT("at"),
508 brackets (sep (map pprParendType tys))])
511 = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
513 pprDFuns :: [DFunId] -> SDoc
514 -- Prints the dfun as an instance declaration
515 pprDFuns dfuns = vcat [ hang (ppr (getSrcLoc dfun) <> colon)
516 2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta,
517 pprClassPred clas tys])
519 , let (_, theta, clas, tys) = tcSplitDFunTy (idType dfun) ]
520 -- Print without the for-all, which the programmer doesn't write
522 tidyInst :: TidyEnv -> Inst -> Inst
523 tidyInst env (LitInst nm lit ty loc) = LitInst nm lit (tidyType env ty) loc
524 tidyInst env (Dict nm pred loc) = Dict nm (tidyPred env pred) loc
525 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
527 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
528 -- This function doesn't assume that the tyvars are in scope
529 -- so it works like tidyOpenType, returning a TidyEnv
530 tidyMoreInsts env insts
531 = (env', map (tidyInst env') insts)
533 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
535 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
536 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
538 showLIE :: SDoc -> TcM () -- Debugging
540 = do { lie_var <- getLIEVar ;
541 lie <- readMutVar lie_var ;
542 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
546 %************************************************************************
548 Extending the instance environment
550 %************************************************************************
553 tcExtendLocalInstEnv :: [DFunId] -> TcM a -> TcM a
554 -- Add new locally-defined instances
555 tcExtendLocalInstEnv dfuns thing_inside
556 = do { traceDFuns dfuns
559 ; inst_env' <- foldlM (addInst dflags) (tcg_inst_env env) dfuns
560 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
561 tcg_inst_env = inst_env' }
562 ; setGblEnv env' thing_inside }
564 addInst :: DynFlags -> InstEnv -> DFunId -> TcM InstEnv
565 -- Check that the proposed new instance is OK,
566 -- and then add it to the home inst env
567 addInst dflags home_ie dfun
568 = do { -- Load imported instances, so that we report
569 -- duplicates correctly
570 let (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
571 ; pkg_ie <- loadImportedInsts cls tys
573 -- Check functional dependencies
574 ; case checkFunDeps (pkg_ie, home_ie) dfun of
575 Just dfuns -> funDepErr dfun dfuns
578 -- Check for duplicate instance decls
579 -- We instantiate the dfun type because the instance lookup
580 -- requires nice fresh types in the thing to be looked up
581 ; (tvs', _, tenv) <- tcInstTyVars tvs
582 ; let { tys' = substTys tenv tys
583 ; (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys'
584 ; dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
585 isJust (matchTys (mkVarSet tvs) tys' dup_tys)] }
586 -- Find memebers of the match list which
587 -- dfun itself matches. If the match is 2-way, it's a duplicate
589 dup_dfun : _ -> dupInstErr dfun dup_dfun
592 -- OK, now extend the envt
593 ; return (extendInstEnv home_ie dfun) }
597 = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
599 pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
603 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
604 2 (pprDFuns (dfun:dfuns)))
605 dupInstErr dfun dup_dfun
607 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
608 2 (pprDFuns [dfun, dup_dfun]))
610 addDictLoc dfun thing_inside
611 = setSrcSpan (mkSrcSpan loc loc) thing_inside
616 %************************************************************************
618 \subsection{Looking up Insts}
620 %************************************************************************
623 data LookupInstResult s
625 | SimpleInst (LHsExpr TcId) -- Just a variable, type application, or literal
626 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
628 lookupInst :: Inst -> TcM (LookupInstResult s)
629 -- It's important that lookupInst does not put any new stuff into
630 -- the LIE. Instead, any Insts needed by the lookup are returned in
631 -- the LookupInstResult, where they can be further processed by tcSimplify
636 lookupInst inst@(Method _ id tys theta _ loc)
637 = newDictsAtLoc loc theta `thenM` \ dicts ->
638 returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (L span (HsVar id)) tys) (map instToId dicts)))
640 span = instLocSrcSpan loc
644 -- Look for short cuts first: if the literal is *definitely* a
645 -- int, integer, float or a double, generate the real thing here.
646 -- This is essential (see nofib/spectral/nucleic).
647 -- [Same shortcut as in newOverloadedLit, but we
648 -- may have done some unification by now]
651 lookupInst inst@(LitInst _nm (HsIntegral i from_integer_name) ty loc)
652 | Just expr <- shortCutIntLit i ty
653 = returnM (GenInst [] expr) -- GenInst, not SimpleInst, because
654 -- expr may be a constructor application
656 = ASSERT( from_integer_name == fromIntegerName ) -- A LitInst invariant
657 tcLookupId fromIntegerName `thenM` \ from_integer ->
658 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
659 mkIntegerLit i `thenM` \ integer_lit ->
660 returnM (GenInst [method_inst]
661 (mkHsApp (L (instLocSrcSpan loc)
662 (HsVar (instToId method_inst))) integer_lit))
664 lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc)
665 | Just expr <- shortCutFracLit f ty
666 = returnM (GenInst [] expr)
669 = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
670 tcLookupId fromRationalName `thenM` \ from_rational ->
671 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
672 mkRatLit f `thenM` \ rat_lit ->
673 returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc)
674 (HsVar (instToId method_inst))) rat_lit))
677 lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
678 = do { pkg_ie <- loadImportedInsts clas tys
679 -- Suck in any instance decls that may be relevant
680 ; tcg_env <- getGblEnv
682 ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
683 ([(tenv, (_,_,dfun_id))], []) -> instantiate_dfun tenv dfun_id pred loc ;
684 (matches, unifs) -> do
685 { traceTc (text "lookupInst fail" <+> vcat [text "dict" <+> ppr pred,
686 text "matches" <+> ppr matches,
687 text "unifs" <+> ppr unifs])
688 ; return NoInstance } } }
689 -- In the case of overlap (multiple matches) we report
690 -- NoInstance here. That has the effect of making the
691 -- context-simplifier return the dict as an irreducible one.
692 -- Then it'll be given to addNoInstanceErrs, which will do another
693 -- lookupInstEnv to get the detailed info about what went wrong.
695 lookupInst (Dict _ _ _) = returnM NoInstance
698 instantiate_dfun tenv dfun_id pred loc
699 = -- tenv is a substitution that instantiates the dfun_id
700 -- to match the requested result type. However, the dfun
701 -- might have some tyvars that only appear in arguments
702 -- dfun :: forall a b. C a b, Ord b => D [a]
703 -- We instantiate b to a flexi type variable -- it'll presumably
704 -- become fixed later via functional dependencies
705 traceTc (text "lookupInst success" <+>
706 vcat [text "dict" <+> ppr pred,
707 text "witness" <+> ppr dfun_id <+> ppr (idType dfun_id) ]) `thenM_`
708 -- Record that this dfun is needed
709 record_dfun_usage dfun_id `thenM_`
711 -- It's possible that not all the tyvars are in
712 -- the substitution, tenv. For example:
713 -- instance C X a => D X where ...
714 -- (presumably there's a functional dependency in class C)
715 -- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
716 getStage `thenM` \ use_stage ->
717 checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
718 (topIdLvl dfun_id) use_stage `thenM_`
720 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
721 mk_ty_arg tv = case lookupVarEnv tenv tv of
722 Just ty -> returnM ty
723 Nothing -> tcInstTyVar tv `thenM` \ tc_tv ->
724 returnM (mkTyVarTy tc_tv)
726 mappM mk_ty_arg tyvars `thenM` \ ty_args ->
728 dfun_rho = substTy (zipTopTvSubst tyvars ty_args) rho
729 -- Since the tyvars are freshly made,
730 -- they cannot possibly be captured by
731 -- any existing for-alls. Hence zipTopTyVarSubst
732 (theta, _) = tcSplitPhiTy dfun_rho
733 ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id)) ty_args
736 returnM (SimpleInst ty_app)
738 newDictsAtLoc loc theta `thenM` \ dicts ->
740 rhs = mkHsDictApp ty_app (map instToId dicts)
742 returnM (GenInst dicts rhs)
744 record_dfun_usage dfun_id
745 | isInternalName dfun_name = return () -- From this module
746 | not (isHomePackageName dfun_name) = return () -- From another package package
747 | otherwise = getGblEnv `thenM` \ tcg_env ->
748 updMutVar (tcg_inst_uses tcg_env)
749 (`addOneToNameSet` idName dfun_id)
751 dfun_name = idName dfun_id
753 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
754 -- Gets both the external-package inst-env
755 -- and the home-pkg inst env (includes module being compiled)
756 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
757 return (eps_inst_env eps, tcg_inst_env env) }
762 %************************************************************************
766 %************************************************************************
769 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
770 a do-expression. We have to find (>>) in the current environment, which is
771 done by the rename. Then we have to check that it has the same type as
772 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
775 (>>) :: HB m n mn => m a -> n b -> mn b
777 So the idea is to generate a local binding for (>>), thus:
779 let then72 :: forall a b. m a -> m b -> m b
780 then72 = ...something involving the user's (>>)...
782 ...the do-expression...
784 Now the do-expression can proceed using then72, which has exactly
787 In fact tcSyntaxName just generates the RHS for then72, because we only
788 want an actual binding in the do-expression case. For literals, we can
789 just use the expression inline.
792 tcSyntaxName :: InstOrigin
793 -> TcType -- Type to instantiate it at
794 -> (Name, HsExpr Name) -- (Standard name, user name)
795 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
797 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
798 -- So we do not call it from lookupInst, which is called from tcSimplify
800 tcSyntaxName orig ty (std_nm, HsVar user_nm)
802 = tcStdSyntaxName orig ty std_nm
804 tcSyntaxName orig ty (std_nm, user_nm_expr)
805 = tcLookupId std_nm `thenM` \ std_id ->
807 -- C.f. newMethodAtLoc
808 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
809 sigma1 = substTyWith [tv] [ty] tau
810 -- Actually, the "tau-type" might be a sigma-type in the
811 -- case of locally-polymorphic methods.
813 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $
815 -- Check that the user-supplied thing has the
816 -- same type as the standard one.
817 -- Tiresome jiggling because tcCheckSigma takes a located expression
818 getSrcSpanM `thenM` \ span ->
819 tcCheckSigma (L span user_nm_expr) sigma1 `thenM` \ expr ->
820 returnM (std_nm, unLoc expr)
822 tcStdSyntaxName :: InstOrigin
823 -> TcType -- Type to instantiate it at
824 -> Name -- Standard name
825 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
827 tcStdSyntaxName orig ty std_nm
828 = newMethodFromName orig ty std_nm `thenM` \ id ->
829 returnM (std_nm, HsVar id)
831 syntaxNameCtxt name orig ty tidy_env
832 = getInstLoc orig `thenM` \ inst_loc ->
834 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
835 ptext SLIT("(needed by a syntactic construct)"),
836 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
837 nest 2 (pprInstLoc inst_loc)]
839 returnM (tidy_env, msg)