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 newDicts, newDictAtLoc, newDictsAtLoc, cloneDict,
16 tcOverloadedLit, newIPDict,
17 newMethod, newMethodFromName, newMethodWithGivenTy,
18 tcInstClassOp, tcInstCall, tcInstStupidTheta,
21 tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
22 ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
23 instLoc, getDictClassTys, dictPred,
25 lookupInst, LookupInstResult(..), lookupPred,
26 tcExtendLocalInstEnv, tcGetInstEnvs,
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, tcSyntaxOp )
42 import {-# SOURCE #-} TcUnify ( unifyTauTy ) -- Used in checkKind (sigh)
44 import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp,
46 import TcHsSyn ( TcId, TcIdSet,
47 mkHsTyApp, mkHsDictApp, zonkId,
51 import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
52 import InstEnv ( DFunId, InstEnv, lookupInstEnv, checkFunDeps, extendInstEnv )
53 import TcIface ( loadImportedInsts )
54 import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zonkTcThetaType,
55 tcInstTyVar, tcInstType, tcSkolType
57 import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcTyVar, TcPredType,
58 PredType(..), SkolemInfo(..), Expected(..), typeKind, mkSigmaTy,
59 tcSplitForAllTys, tcSplitForAllTys, mkFunTy,
60 tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy, tcSplitDFunHead,
61 isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
62 tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
63 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
64 isClassPred, isTyVarClassPred, isLinearPred,
65 getClassPredTys, getClassPredTys_maybe, mkPredName,
66 isInheritablePred, isIPPred,
67 tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy,
68 pprPred, pprParendType, pprThetaArrow, pprTheta, pprClassPred
70 import Type ( TvSubst, substTy, substTyVar, substTyWith, substTheta, zipTopTvSubst,
71 notElemTvSubst, extendTvSubstList )
72 import Unify ( tcMatchTys )
73 import Kind ( isSubKind )
74 import Packages ( isHomeModule )
75 import HscTypes ( ExternalPackageState(..) )
76 import CoreFVs ( idFreeTyVars )
77 import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName, dataConWrapId )
78 import Id ( Id, idName, idType, mkUserLocal, mkLocalId )
79 import PrelInfo ( isStandardClass, isNoDictClass )
80 import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
81 isInternalName, setNameUnique, mkSystemVarNameEncoded )
82 import NameSet ( addOneToNameSet )
83 import Literal ( inIntRange )
84 import Var ( TyVar, tyVarKind, setIdType )
85 import VarEnv ( TidyEnv, emptyTidyEnv )
86 import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
87 import TysWiredIn ( floatDataCon, doubleDataCon )
88 import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
89 import BasicTypes( IPName(..), mapIPName, ipNameName )
90 import UniqSupply( uniqsFromSupply )
91 import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) )
92 import DynFlags( DynFlags )
93 import Maybes ( isJust )
101 instName :: Inst -> Name
102 instName inst = idName (instToId inst)
104 instToId :: Inst -> TcId
105 instToId (LitInst nm _ ty _) = mkLocalId nm ty
106 instToId (Dict nm pred _) = mkLocalId nm (mkPredTy pred)
107 instToId (Method id _ _ _ _ _) = id
109 instLoc (Dict _ _ loc) = loc
110 instLoc (Method _ _ _ _ _ loc) = loc
111 instLoc (LitInst _ _ _ loc) = loc
113 dictPred (Dict _ pred _ ) = pred
114 dictPred inst = pprPanic "dictPred" (ppr inst)
116 getDictClassTys (Dict _ pred _) = getClassPredTys pred
118 -- fdPredsOfInst is used to get predicates that contain functional
119 -- dependencies *or* might do so. The "might do" part is because
120 -- a constraint (C a b) might have a superclass with FDs
121 -- Leaving these in is really important for the call to fdPredsOfInsts
122 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
123 -- which is supposed to be conservative
124 fdPredsOfInst (Dict _ pred _) = [pred]
125 fdPredsOfInst (Method _ _ _ theta _ _) = theta
126 fdPredsOfInst other = [] -- LitInsts etc
128 fdPredsOfInsts :: [Inst] -> [PredType]
129 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
131 isInheritableInst (Dict _ pred _) = isInheritablePred pred
132 isInheritableInst (Method _ _ _ theta _ _) = all isInheritablePred theta
133 isInheritableInst other = True
136 ipNamesOfInsts :: [Inst] -> [Name]
137 ipNamesOfInst :: Inst -> [Name]
138 -- Get the implicit parameters mentioned by these Insts
139 -- NB: ?x and %x get different Names
140 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
142 ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
143 ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
144 ipNamesOfInst other = []
146 tyVarsOfInst :: Inst -> TcTyVarSet
147 tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
148 tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
149 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
150 -- The id might have free type variables; in the case of
151 -- locally-overloaded class methods, for example
154 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
155 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
161 isDict :: Inst -> Bool
162 isDict (Dict _ _ _) = True
165 isClassDict :: Inst -> Bool
166 isClassDict (Dict _ pred _) = isClassPred pred
167 isClassDict other = False
169 isTyVarDict :: Inst -> Bool
170 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
171 isTyVarDict other = False
173 isIPDict :: Inst -> Bool
174 isIPDict (Dict _ pred _) = isIPPred pred
175 isIPDict other = False
177 isMethod :: Inst -> Bool
178 isMethod (Method _ _ _ _ _ _) = True
179 isMethod other = False
181 isMethodFor :: TcIdSet -> Inst -> Bool
182 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
183 isMethodFor ids inst = False
185 isLinearInst :: Inst -> Bool
186 isLinearInst (Dict _ pred _) = isLinearPred pred
187 isLinearInst other = False
188 -- We never build Method Insts that have
189 -- linear implicit paramters in them.
190 -- Hence no need to look for Methods
193 linearInstType :: Inst -> TcType -- %x::t --> t
194 linearInstType (Dict _ (IParam _ ty) _) = ty
197 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
198 Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
202 Two predicates which deal with the case where class constraints don't
203 necessarily result in bindings. The first tells whether an @Inst@
204 must be witnessed by an actual binding; the second tells whether an
205 @Inst@ can be generalised over.
208 instBindingRequired :: Inst -> Bool
209 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
210 instBindingRequired other = True
214 %************************************************************************
216 \subsection{Building dictionaries}
218 %************************************************************************
221 newDicts :: InstOrigin
225 = getInstLoc orig `thenM` \ loc ->
226 newDictsAtLoc loc theta
228 cloneDict :: Inst -> TcM Inst
229 cloneDict (Dict nm ty loc) = newUnique `thenM` \ uniq ->
230 returnM (Dict (setNameUnique nm uniq) ty loc)
232 newDictAtLoc :: InstLoc -> TcPredType -> TcM Inst
233 newDictAtLoc inst_loc pred
234 = do { uniq <- newUnique
235 ; return (mkDict inst_loc uniq pred) }
237 newDictsAtLoc :: InstLoc -> TcThetaType -> TcM [Inst]
238 newDictsAtLoc inst_loc theta
239 = newUniqueSupply `thenM` \ us ->
240 returnM (zipWith (mkDict inst_loc) (uniqsFromSupply us) theta)
242 mkDict inst_loc uniq pred
243 = Dict name pred inst_loc
245 name = mkPredName uniq (instLocSrcLoc inst_loc) pred
247 -- For vanilla implicit parameters, there is only one in scope
248 -- at any time, so we used to use the name of the implicit parameter itself
249 -- But with splittable implicit parameters there may be many in
250 -- scope, so we make up a new name.
251 newIPDict :: InstOrigin -> IPName Name -> Type
252 -> TcM (IPName Id, Inst)
253 newIPDict orig ip_name ty
254 = getInstLoc orig `thenM` \ inst_loc ->
255 newUnique `thenM` \ uniq ->
257 pred = IParam ip_name ty
258 name = mkPredName uniq (instLocSrcLoc inst_loc) pred
259 dict = Dict name pred inst_loc
261 returnM (mapIPName (\n -> instToId dict) ip_name, dict)
266 %************************************************************************
268 \subsection{Building methods (calls of overloaded functions)}
270 %************************************************************************
274 tcInstCall :: InstOrigin -> TcType -> TcM (ExprCoFn, [TcTyVar], TcType)
275 tcInstCall orig fun_ty -- fun_ty is usually a sigma-type
276 = do { (tyvars, theta, tau) <- tcInstType fun_ty
277 ; dicts <- newDicts orig theta
279 ; let inst_fn e = unLoc (mkHsDictApp (mkHsTyApp (noLoc e) (mkTyVarTys tyvars))
280 (map instToId dicts))
281 ; return (mkCoercion inst_fn, tyvars, tau) }
283 tcInstStupidTheta :: DataCon -> [TcType] -> TcM ()
284 -- Instantiate the "stupid theta" of the data con, and throw
285 -- the constraints into the constraint set
286 tcInstStupidTheta data_con inst_tys
290 = do { stupid_dicts <- newDicts (OccurrenceOf (dataConName data_con))
291 (substTheta tenv stupid_theta)
292 ; extendLIEs stupid_dicts }
294 stupid_theta = dataConStupidTheta data_con
295 tenv = zipTopTvSubst (dataConTyVars data_con) inst_tys
297 newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId
298 newMethodFromName origin ty name
299 = tcLookupId name `thenM` \ id ->
300 -- Use tcLookupId not tcLookupGlobalId; the method is almost
301 -- always a class op, but with -fno-implicit-prelude GHC is
302 -- meant to find whatever thing is in scope, and that may
303 -- be an ordinary function.
304 getInstLoc origin `thenM` \ loc ->
305 tcInstClassOp loc id [ty] `thenM` \ inst ->
306 extendLIE inst `thenM_`
307 returnM (instToId inst)
309 newMethodWithGivenTy orig id tys theta tau
310 = getInstLoc orig `thenM` \ loc ->
311 newMethod loc id tys theta tau `thenM` \ inst ->
312 extendLIE inst `thenM_`
313 returnM (instToId inst)
315 --------------------------------------------
316 -- tcInstClassOp, and newMethod do *not* drop the
317 -- Inst into the LIE; they just returns the Inst
318 -- This is important because they are used by TcSimplify
321 -- NB: the kind of the type variable to be instantiated
322 -- might be a sub-kind of the type to which it is applied,
323 -- notably when the latter is a type variable of kind ??
324 -- Hence the call to checkKind
325 -- A worry: is this needed anywhere else?
326 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
327 tcInstClassOp inst_loc sel_id tys
329 (tyvars,rho) = tcSplitForAllTys (idType sel_id)
330 rho_ty = ASSERT( length tyvars == length tys )
331 substTyWith tyvars tys rho
332 (preds,tau) = tcSplitPhiTy rho_ty
334 zipWithM_ checkKind tyvars tys `thenM_`
335 newMethod inst_loc sel_id tys preds tau
337 checkKind :: TyVar -> TcType -> TcM ()
338 -- Ensure that the type has a sub-kind of the tyvar
340 = do { ty1 <- zonkTcType ty
341 ; if typeKind ty1 `isSubKind` tyVarKind tv
344 { traceTc (text "checkKind: adding kind constraint" <+> ppr tv <+> ppr ty)
345 ; tv1 <- tcInstTyVar tv
346 ; unifyTauTy (mkTyVarTy tv1) ty1 }}
349 ---------------------------
350 newMethod inst_loc id tys theta tau
351 = newUnique `thenM` \ new_uniq ->
353 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
354 inst = Method meth_id id tys theta tau inst_loc
355 loc = instLocSrcLoc inst_loc
360 In tcOverloadedLit we convert directly to an Int or Integer if we
361 know that's what we want. This may save some time, by not
362 temporarily generating overloaded literals, but it won't catch all
363 cases (the rest are caught in lookupInst).
366 tcOverloadedLit :: InstOrigin
369 -> TcM (HsOverLit TcId)
370 tcOverloadedLit orig lit@(HsIntegral i fi) expected_ty
371 | not (fi `isHsVar` fromIntegerName) -- Do not generate a LitInst for rebindable syntax.
372 -- Reason: If we do, tcSimplify will call lookupInst, which
373 -- will call tcSyntaxName, which does unification,
374 -- which tcSimplify doesn't like
375 -- ToDo: noLoc sadness
376 = do { integer_ty <- tcMetaTy integerTyConName
377 ; fi' <- tcSyntaxOp orig fi (mkFunTy integer_ty expected_ty)
378 ; return (HsIntegral i (HsApp (noLoc fi') (nlHsLit (HsInteger i integer_ty)))) }
380 | Just expr <- shortCutIntLit i expected_ty
381 = return (HsIntegral i expr)
384 = do { expr <- newLitInst orig lit expected_ty
385 ; return (HsIntegral i expr) }
387 tcOverloadedLit orig lit@(HsFractional r fr) expected_ty
388 | not (fr `isHsVar` fromRationalName) -- c.f. HsIntegral case
389 = do { rat_ty <- tcMetaTy rationalTyConName
390 ; fr' <- tcSyntaxOp orig fr (mkFunTy rat_ty expected_ty)
391 ; return (HsFractional r (HsApp (noLoc fr') (nlHsLit (HsRat r rat_ty)))) }
393 | Just expr <- shortCutFracLit r expected_ty
394 = return (HsFractional r expr)
397 = do { expr <- newLitInst orig lit expected_ty
398 ; return (HsFractional r expr) }
400 newLitInst :: InstOrigin -> HsOverLit Name -> TcType -> TcM (HsExpr TcId)
401 newLitInst orig lit expected_ty -- Make a LitInst
402 = do { loc <- getInstLoc orig
403 ; new_uniq <- newUnique
405 lit_nm = mkSystemVarNameEncoded new_uniq FSLIT("lit")
406 -- The "encoded" bit means that we don't need to
407 -- z-encode the string every time we call this!
408 lit_inst = LitInst lit_nm lit expected_ty loc
410 ; return (HsVar (instToId lit_inst)) }
412 shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
414 | isIntTy ty && inIntRange i -- Short cut for Int
415 = Just (HsLit (HsInt i))
416 | isIntegerTy ty -- Short cut for Integer
417 = Just (HsLit (HsInteger i ty))
418 | otherwise = Nothing
420 shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
423 = Just (mk_lit floatDataCon (HsFloatPrim f))
425 = Just (mk_lit doubleDataCon (HsDoublePrim f))
426 | otherwise = Nothing
428 mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
430 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
432 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
433 getSrcSpanM `thenM` \ span ->
434 returnM (L span $ HsLit (HsInteger i integer_ty))
436 mkRatLit :: Rational -> TcM (LHsExpr TcId)
438 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
439 getSrcSpanM `thenM` \ span ->
440 returnM (L span $ HsLit (HsRat r rat_ty))
442 isHsVar :: HsExpr Name -> Name -> Bool
443 isHsVar (HsVar f) g = f==g
444 isHsVar other g = False
448 %************************************************************************
452 %************************************************************************
454 Zonking makes sure that the instance types are fully zonked.
457 zonkInst :: Inst -> TcM Inst
458 zonkInst (Dict name pred loc)
459 = zonkTcPredType pred `thenM` \ new_pred ->
460 returnM (Dict name new_pred loc)
462 zonkInst (Method m id tys theta tau loc)
463 = zonkId id `thenM` \ new_id ->
464 -- Essential to zonk the id in case it's a local variable
465 -- Can't use zonkIdOcc because the id might itself be
466 -- an InstId, in which case it won't be in scope
468 zonkTcTypes tys `thenM` \ new_tys ->
469 zonkTcThetaType theta `thenM` \ new_theta ->
470 zonkTcType tau `thenM` \ new_tau ->
471 returnM (Method m new_id new_tys new_theta new_tau loc)
473 zonkInst (LitInst nm lit ty loc)
474 = zonkTcType ty `thenM` \ new_ty ->
475 returnM (LitInst nm lit new_ty loc)
477 zonkInsts insts = mappM zonkInst insts
481 %************************************************************************
483 \subsection{Printing}
485 %************************************************************************
487 ToDo: improve these pretty-printing things. The ``origin'' is really only
488 relevant in error messages.
491 instance Outputable Inst where
492 ppr inst = pprInst inst
494 pprDictsTheta :: [Inst] -> SDoc
495 -- Print in type-like fashion (Eq a, Show b)
496 pprDictsTheta dicts = pprTheta (map dictPred dicts)
498 pprDictsInFull :: [Inst] -> SDoc
499 -- Print in type-like fashion, but with source location
501 = vcat (map go dicts)
503 go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))]
505 pprInsts :: [Inst] -> SDoc
506 -- Debugging: print the evidence :: type
507 pprInsts insts = brackets (interpp'SP insts)
509 pprInst, pprInstInFull :: Inst -> SDoc
510 -- Debugging: print the evidence :: type
511 pprInst (LitInst nm lit ty loc) = ppr nm <+> dcolon <+> ppr ty
512 pprInst (Dict nm pred loc) = ppr nm <+> dcolon <+> pprPred pred
514 pprInst m@(Method inst_id id tys theta tau loc)
515 = ppr inst_id <+> dcolon <+>
516 braces (sep [ppr id <+> ptext SLIT("at"),
517 brackets (sep (map pprParendType tys))])
520 = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
522 pprDFuns :: [DFunId] -> SDoc
523 -- Prints the dfun as an instance declaration
524 pprDFuns dfuns = vcat [ hang (ppr (getSrcLoc dfun) <> colon)
525 2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta,
526 pprClassPred clas tys])
528 , let (_, theta, clas, tys) = tcSplitDFunTy (idType dfun) ]
529 -- Print without the for-all, which the programmer doesn't write
531 tidyInst :: TidyEnv -> Inst -> Inst
532 tidyInst env (LitInst nm lit ty loc) = LitInst nm lit (tidyType env ty) loc
533 tidyInst env (Dict nm pred loc) = Dict nm (tidyPred env pred) loc
534 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
536 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
537 -- This function doesn't assume that the tyvars are in scope
538 -- so it works like tidyOpenType, returning a TidyEnv
539 tidyMoreInsts env insts
540 = (env', map (tidyInst env') insts)
542 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
544 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
545 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
547 showLIE :: SDoc -> TcM () -- Debugging
549 = do { lie_var <- getLIEVar ;
550 lie <- readMutVar lie_var ;
551 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
555 %************************************************************************
557 Extending the instance environment
559 %************************************************************************
562 tcExtendLocalInstEnv :: [DFunId] -> TcM a -> TcM a
563 -- Add new locally-defined instances
564 tcExtendLocalInstEnv dfuns thing_inside
565 = do { traceDFuns dfuns
568 ; inst_env' <- foldlM (addInst dflags) (tcg_inst_env env) dfuns
569 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
570 tcg_inst_env = inst_env' }
571 ; setGblEnv env' thing_inside }
573 addInst :: DynFlags -> InstEnv -> DFunId -> TcM InstEnv
574 -- Check that the proposed new instance is OK,
575 -- and then add it to the home inst env
576 addInst dflags home_ie dfun
577 = do { -- Instantiate the dfun type so that we extend the instance
578 -- envt with completely fresh template variables
579 -- This is important because the template variables must
580 -- not overlap with anything in the things being looked up
581 -- (since we do unification).
582 -- We use tcSkolType because we don't want to allocate fresh
583 -- *meta* type variables.
584 (tvs', theta', tau') <- tcSkolType (InstSkol dfun) (idType dfun)
585 ; let (cls, tys') = tcSplitDFunHead tau'
586 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
588 -- Load imported instances, so that we report
589 -- duplicates correctly
590 ; pkg_ie <- loadImportedInsts cls tys'
592 -- Check functional dependencies
593 ; case checkFunDeps (pkg_ie, home_ie) dfun' of
594 Just dfuns -> funDepErr dfun dfuns
597 -- Check for duplicate instance decls
598 ; let { (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys'
599 ; dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
600 isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
601 -- Find memebers of the match list which
602 -- dfun itself matches. If the match is 2-way, it's a duplicate
604 dup_dfun : _ -> dupInstErr dfun dup_dfun
607 -- OK, now extend the envt
608 ; return (extendInstEnv home_ie dfun') }
612 = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
614 pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
618 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
619 2 (pprDFuns (dfun:dfuns)))
620 dupInstErr dfun dup_dfun
622 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
623 2 (pprDFuns [dfun, dup_dfun]))
625 addDictLoc dfun thing_inside
626 = setSrcSpan (mkSrcSpan loc loc) thing_inside
632 %************************************************************************
634 \subsection{Looking up Insts}
636 %************************************************************************
639 data LookupInstResult
641 | SimpleInst (LHsExpr TcId) -- Just a variable, type application, or literal
642 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
644 lookupInst :: Inst -> TcM LookupInstResult
645 -- It's important that lookupInst does not put any new stuff into
646 -- the LIE. Instead, any Insts needed by the lookup are returned in
647 -- the LookupInstResult, where they can be further processed by tcSimplify
652 lookupInst inst@(Method _ id tys theta _ loc)
653 = newDictsAtLoc loc theta `thenM` \ dicts ->
654 returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (L span (HsVar id)) tys) (map instToId dicts)))
656 span = instLocSrcSpan loc
660 -- Look for short cuts first: if the literal is *definitely* a
661 -- int, integer, float or a double, generate the real thing here.
662 -- This is essential (see nofib/spectral/nucleic).
663 -- [Same shortcut as in newOverloadedLit, but we
664 -- may have done some unification by now]
666 lookupInst inst@(LitInst _nm (HsIntegral i from_integer_name) ty loc)
667 | Just expr <- shortCutIntLit i ty
668 = returnM (GenInst [] (noLoc expr)) -- GenInst, not SimpleInst, because
669 -- expr may be a constructor application
671 = ASSERT( from_integer_name `isHsVar` fromIntegerName ) -- A LitInst invariant
672 tcLookupId fromIntegerName `thenM` \ from_integer ->
673 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
674 mkIntegerLit i `thenM` \ integer_lit ->
675 returnM (GenInst [method_inst]
676 (mkHsApp (L (instLocSrcSpan loc)
677 (HsVar (instToId method_inst))) integer_lit))
679 lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc)
680 | Just expr <- shortCutFracLit f ty
681 = returnM (GenInst [] (noLoc expr))
684 = ASSERT( from_rat_name `isHsVar` fromRationalName ) -- A LitInst invariant
685 tcLookupId fromRationalName `thenM` \ from_rational ->
686 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
687 mkRatLit f `thenM` \ rat_lit ->
688 returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc)
689 (HsVar (instToId method_inst))) rat_lit))
692 lookupInst (Dict _ pred loc)
693 = do { mb_result <- lookupPred pred
694 ; case mb_result of {
695 Nothing -> return NoInstance ;
696 Just (tenv, dfun_id) -> do
698 -- tenv is a substitution that instantiates the dfun_id
699 -- to match the requested result type.
701 -- We ASSUME that the dfun is quantified over the very same tyvars
702 -- that are bound by the tenv.
705 -- might have some tyvars that *only* appear in arguments
706 -- dfun :: forall a b. C a b, Ord b => D [a]
707 -- We instantiate b to a flexi type variable -- it'll presumably
708 -- become fixed later via functional dependencies
709 { use_stage <- getStage
710 ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
711 (topIdLvl dfun_id) use_stage
713 -- It's possible that not all the tyvars are in
714 -- the substitution, tenv. For example:
715 -- instance C X a => D X where ...
716 -- (presumably there's a functional dependency in class C)
717 -- Hence the open_tvs to instantiate any un-substituted tyvars.
718 ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
719 open_tvs = filter (`notElemTvSubst` tenv) tyvars
720 ; open_tvs' <- mappM tcInstTyVar open_tvs
722 tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
723 -- Since the open_tvs' are freshly made, they cannot possibly be captured by
724 -- any nested for-alls in rho. So the in-scope set is unchanged
725 dfun_rho = substTy tenv' rho
726 (theta, _) = tcSplitPhiTy dfun_rho
727 ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id))
728 (map (substTyVar tenv') tyvars)
730 returnM (SimpleInst ty_app)
732 { dicts <- newDictsAtLoc loc theta
733 ; let rhs = mkHsDictApp ty_app (map instToId dicts)
734 ; returnM (GenInst dicts rhs)
738 lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
739 -- Look up a class constraint in the instance environment
740 lookupPred pred@(ClassP clas tys)
741 = do { pkg_ie <- loadImportedInsts clas tys
742 -- Suck in any instance decls that may be relevant
743 ; tcg_env <- getGblEnv
745 ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
746 ([(tenv, (_,_,dfun_id))], [])
747 -> do { traceTc (text "lookupInst success" <+>
748 vcat [text "dict" <+> ppr pred,
749 text "witness" <+> ppr dfun_id
750 <+> ppr (idType dfun_id) ])
751 -- Record that this dfun is needed
752 ; record_dfun_usage dfun_id
753 ; return (Just (tenv, dfun_id)) } ;
756 -> do { traceTc (text "lookupInst fail" <+>
757 vcat [text "dict" <+> ppr pred,
758 text "matches" <+> ppr matches,
759 text "unifs" <+> ppr unifs])
760 -- In the case of overlap (multiple matches) we report
761 -- NoInstance here. That has the effect of making the
762 -- context-simplifier return the dict as an irreducible one.
763 -- Then it'll be given to addNoInstanceErrs, which will do another
764 -- lookupInstEnv to get the detailed info about what went wrong.
768 lookupPred ip_pred = return Nothing
770 record_dfun_usage dfun_id
771 = do { dflags <- getDOpts
772 ; let dfun_name = idName dfun_id
773 dfun_mod = nameModule dfun_name
774 ; if isInternalName dfun_name || not (isHomeModule dflags dfun_mod)
775 then return () -- internal, or in another package
776 else do { tcg_env <- getGblEnv
777 ; updMutVar (tcg_inst_uses tcg_env)
778 (`addOneToNameSet` idName dfun_id) }}
781 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
782 -- Gets both the external-package inst-env
783 -- and the home-pkg inst env (includes module being compiled)
784 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
785 return (eps_inst_env eps, tcg_inst_env env) }
790 %************************************************************************
794 %************************************************************************
796 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
797 a do-expression. We have to find (>>) in the current environment, which is
798 done by the rename. Then we have to check that it has the same type as
799 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
802 (>>) :: HB m n mn => m a -> n b -> mn b
804 So the idea is to generate a local binding for (>>), thus:
806 let then72 :: forall a b. m a -> m b -> m b
807 then72 = ...something involving the user's (>>)...
809 ...the do-expression...
811 Now the do-expression can proceed using then72, which has exactly
814 In fact tcSyntaxName just generates the RHS for then72, because we only
815 want an actual binding in the do-expression case. For literals, we can
816 just use the expression inline.
819 tcSyntaxName :: InstOrigin
820 -> TcType -- Type to instantiate it at
821 -> (Name, HsExpr Name) -- (Standard name, user name)
822 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
823 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
824 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
825 -- So we do not call it from lookupInst, which is called from tcSimplify
827 tcSyntaxName orig ty (std_nm, HsVar user_nm)
829 = newMethodFromName orig ty std_nm `thenM` \ id ->
830 returnM (std_nm, HsVar id)
832 tcSyntaxName orig ty (std_nm, user_nm_expr)
833 = tcLookupId std_nm `thenM` \ std_id ->
835 -- C.f. newMethodAtLoc
836 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
837 sigma1 = substTyWith [tv] [ty] tau
838 -- Actually, the "tau-type" might be a sigma-type in the
839 -- case of locally-polymorphic methods.
841 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $
843 -- Check that the user-supplied thing has the
844 -- same type as the standard one.
845 -- Tiresome jiggling because tcCheckSigma takes a located expression
846 getSrcSpanM `thenM` \ span ->
847 tcCheckSigma (L span user_nm_expr) sigma1 `thenM` \ expr ->
848 returnM (std_nm, unLoc expr)
850 syntaxNameCtxt name orig ty tidy_env
851 = getInstLoc orig `thenM` \ inst_loc ->
853 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
854 ptext SLIT("(needed by a syntactic construct)"),
855 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
856 nest 2 (pprInstLoc inst_loc)]
858 returnM (tidy_env, msg)