2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 The @Inst@ type: dictionaries or method instances
12 pprInstances, pprDictsTheta, pprDictsInFull, -- User error messages
13 showLIE, pprInst, pprInsts, pprInstInFull, -- Debugging messages
15 tidyInsts, tidyMoreInsts,
17 newDictBndr, newDictBndrs, newDictBndrsO,
18 instCall, instStupidTheta,
20 shortCutFracLit, shortCutIntLit, newIPDict,
21 newMethod, newMethodFromName, newMethodWithGivenTy,
23 tcSyntaxName, isHsVar,
25 tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
26 ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
27 getDictClassTys, dictPred,
29 lookupSimpleInst, LookupInstResult(..), lookupPred,
30 tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
32 isDict, isClassDict, isMethod, isImplicInst,
33 isIPDict, isInheritableInst, isMethodOrLit,
34 isTyVarDict, isMethodFor, getDefaultableDicts,
37 instToId, instToVar, instName,
39 InstOrigin(..), InstLoc, pprInstLoc
42 #include "HsVersions.h"
44 import {-# SOURCE #-} TcExpr( tcPolyExpr )
45 import {-# SOURCE #-} TcUnify( unifyType )
67 import Var ( Var, TyVar )
85 instName :: Inst -> Name
86 instName inst = Var.varName (instToVar inst)
88 instToId :: Inst -> TcId
89 instToId inst = ASSERT2( isId id, ppr inst ) id
93 instToVar :: Inst -> Var
94 instToVar (LitInst {tci_name = nm, tci_ty = ty})
96 instToVar (Method {tci_id = id})
98 instToVar (Dict {tci_name = nm, tci_pred = pred})
99 | isEqPred pred = Var.mkCoVar nm (mkPredTy pred)
100 | otherwise = mkLocalId nm (mkPredTy pred)
101 instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens,
102 tci_wanted = wanteds})
103 = mkLocalId nm (mkImplicTy tvs givens wanteds)
105 instType :: Inst -> Type
106 instType (LitInst {tci_ty = ty}) = ty
107 instType (Method {tci_id = id}) = idType id
108 instType (Dict {tci_pred = pred}) = mkPredTy pred
109 instType imp@(ImplicInst {}) = mkImplicTy (tci_tyvars imp) (tci_given imp)
112 mkImplicTy tvs givens wanteds -- The type of an implication constraint
113 = ASSERT( all isDict givens )
114 -- pprTrace "mkImplicTy" (ppr givens) $
116 mkPhiTy (map dictPred givens) $
117 if isSingleton wanteds then
118 instType (head wanteds)
120 mkTupleTy Boxed (length wanteds) (map instType wanteds)
122 dictPred (Dict {tci_pred = pred}) = pred
123 dictPred inst = pprPanic "dictPred" (ppr inst)
125 getDictClassTys (Dict {tci_pred = pred}) = getClassPredTys pred
126 getDictClassTys inst = pprPanic "getDictClassTys" (ppr inst)
128 -- fdPredsOfInst is used to get predicates that contain functional
129 -- dependencies *or* might do so. The "might do" part is because
130 -- a constraint (C a b) might have a superclass with FDs
131 -- Leaving these in is really important for the call to fdPredsOfInsts
132 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
133 -- which is supposed to be conservative
134 fdPredsOfInst (Dict {tci_pred = pred}) = [pred]
135 fdPredsOfInst (Method {tci_theta = theta}) = theta
136 fdPredsOfInst (ImplicInst {tci_given = gs,
137 tci_wanted = ws}) = fdPredsOfInsts (gs ++ ws)
138 fdPredsOfInst (LitInst {}) = []
140 fdPredsOfInsts :: [Inst] -> [PredType]
141 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
143 isInheritableInst (Dict {tci_pred = pred}) = isInheritablePred pred
144 isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta
145 isInheritableInst other = True
148 ---------------------------------
149 -- Get the implicit parameters mentioned by these Insts
150 -- NB: the results of these functions are insensitive to zonking
152 ipNamesOfInsts :: [Inst] -> [Name]
153 ipNamesOfInst :: Inst -> [Name]
154 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
156 ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
157 ipNamesOfInst (Method {tci_theta = theta}) = [ipNameName n | IParam n _ <- theta]
158 ipNamesOfInst other = []
160 ---------------------------------
161 tyVarsOfInst :: Inst -> TcTyVarSet
162 tyVarsOfInst (LitInst {tci_ty = ty}) = tyVarsOfType ty
163 tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
164 tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id
165 -- The id might have free type variables; in the case of
166 -- locally-overloaded class methods, for example
167 tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds})
168 = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds)
169 `minusVarSet` mkVarSet tvs
170 `unionVarSet` unionVarSets (map varTypeTyVars tvs)
171 -- Remember the free tyvars of a coercion
173 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
174 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
180 isDict :: Inst -> Bool
181 isDict (Dict {}) = True
184 isClassDict :: Inst -> Bool
185 isClassDict (Dict {tci_pred = pred}) = isClassPred pred
186 isClassDict other = False
188 isTyVarDict :: Inst -> Bool
189 isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
190 isTyVarDict other = False
192 isIPDict :: Inst -> Bool
193 isIPDict (Dict {tci_pred = pred}) = isIPPred pred
194 isIPDict other = False
196 isImplicInst (ImplicInst {}) = True
197 isImplicInst other = False
199 isMethod :: Inst -> Bool
200 isMethod (Method {}) = True
201 isMethod other = False
203 isMethodFor :: TcIdSet -> Inst -> Bool
204 isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
205 isMethodFor ids inst = False
207 isMethodOrLit :: Inst -> Bool
208 isMethodOrLit (Method {}) = True
209 isMethodOrLit (LitInst {}) = True
210 isMethodOrLit other = False
214 getDefaultableDicts :: [Inst] -> ([(Inst, Class, TcTyVar)], TcTyVarSet)
215 -- Look for free dicts of the form (C tv), even inside implications
216 -- *and* the set of tyvars mentioned by all *other* constaints
217 -- This disgustingly ad-hoc function is solely to support defaulting
218 getDefaultableDicts insts
219 = (concat ps, unionVarSets tvs)
221 (ps, tvs) = mapAndUnzip get insts
222 get d@(Dict {tci_pred = ClassP cls [ty]})
223 | Just tv <- tcGetTyVar_maybe ty = ([(d,cls,tv)], emptyVarSet)
224 | otherwise = ([], tyVarsOfType ty)
225 get (ImplicInst {tci_tyvars = tvs, tci_wanted = wanteds})
226 = ([ up | up@(_,_,tv) <- ups, not (tv `elemVarSet` tv_set)],
227 ftvs `minusVarSet` tv_set)
229 tv_set = mkVarSet tvs
230 (ups, ftvs) = getDefaultableDicts wanteds
231 get inst = ([], tyVarsOfInst inst)
234 %************************************************************************
236 \subsection{Building dictionaries}
238 %************************************************************************
240 -- newDictBndrs makes a dictionary at a binding site
241 -- instCall makes a dictionary at an occurrence site
242 -- and throws it into the LIE
246 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
247 newDictBndrsO orig theta = do { loc <- getInstLoc orig
248 ; newDictBndrs loc theta }
250 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
251 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
253 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
254 newDictBndr inst_loc pred
255 = do { uniq <- newUnique
256 ; let name = mkPredName uniq inst_loc pred
257 ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
260 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
261 -- Instantiate the constraints of a call
262 -- (instCall o tys theta)
263 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
264 -- (b) Throws these dictionaries into the LIE
265 -- (c) Eeturns an HsWrapper ([.] tys dicts)
267 instCall orig tys theta
268 = do { loc <- getInstLoc orig
269 ; (dicts, dict_app) <- instCallDicts loc theta
271 ; return (dict_app <.> mkWpTyApps tys) }
274 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
275 -- Similar to instCall, but only emit the constraints in the LIE
276 -- Used exclusively for the 'stupid theta' of a data constructor
277 instStupidTheta orig theta
278 = do { loc <- getInstLoc orig
279 ; (dicts, _) <- instCallDicts loc theta
283 instCallDicts :: InstLoc -> TcThetaType -> TcM ([Inst], HsWrapper)
284 -- This is the key place where equality predicates
285 -- are unleashed into the world
286 instCallDicts loc [] = return ([], idHsWrapper)
288 instCallDicts loc (EqPred ty1 ty2 : preds)
289 = do { unifyType ty1 ty2 -- For now, we insist that they unify right away
290 -- Later on, when we do associated types,
291 -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
292 ; (dicts, co_fn) <- instCallDicts loc preds
293 ; return (dicts, co_fn <.> WpTyApp ty1) }
294 -- We use type application to apply the function to the
295 -- coercion; here ty1 *is* the appropriate identity coercion
297 instCallDicts loc (pred : preds)
298 = do { uniq <- newUnique
299 ; let name = mkPredName uniq loc pred
300 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
301 ; (dicts, co_fn) <- instCallDicts loc preds
302 ; return (dict:dicts, co_fn <.> WpApp (instToId dict)) }
305 cloneDict :: Inst -> TcM Inst -- Only used for linear implicit params
306 cloneDict dict@(Dict nm ty loc) = do { uniq <- newUnique
307 ; return (dict {tci_name = setNameUnique nm uniq}) }
308 cloneDict other = pprPanic "cloneDict" (ppr other)
310 -- For vanilla implicit parameters, there is only one in scope
311 -- at any time, so we used to use the name of the implicit parameter itself
312 -- But with splittable implicit parameters there may be many in
313 -- scope, so we make up a new namea.
314 newIPDict :: InstOrigin -> IPName Name -> Type
315 -> TcM (IPName Id, Inst)
316 newIPDict orig ip_name ty
317 = getInstLoc orig `thenM` \ inst_loc ->
318 newUnique `thenM` \ uniq ->
320 pred = IParam ip_name ty
321 name = mkPredName uniq inst_loc pred
322 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}
324 returnM (mapIPName (\n -> instToId dict) ip_name, dict)
329 mkPredName :: Unique -> InstLoc -> PredType -> Name
330 mkPredName uniq loc pred_ty
331 = mkInternalName uniq occ (srcSpanStart (instLocSpan loc))
333 occ = case pred_ty of
334 ClassP cls _ -> mkDictOcc (getOccName cls)
335 IParam ip _ -> getOccName (ipNameName ip)
336 EqPred ty _ -> mkEqPredCoOcc baseOcc
338 -- we use the outermost tycon of the lhs, if there is one, to
339 -- improve readability of Core code
340 baseOcc = case splitTyConApp_maybe ty of
341 Nothing -> mkOccName tcName "$"
342 Just (tc, _) -> getOccName tc
345 %************************************************************************
347 \subsection{Building methods (calls of overloaded functions)}
349 %************************************************************************
353 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
354 newMethodFromName origin ty name
355 = tcLookupId name `thenM` \ id ->
356 -- Use tcLookupId not tcLookupGlobalId; the method is almost
357 -- always a class op, but with -fno-implicit-prelude GHC is
358 -- meant to find whatever thing is in scope, and that may
359 -- be an ordinary function.
360 getInstLoc origin `thenM` \ loc ->
361 tcInstClassOp loc id [ty] `thenM` \ inst ->
362 extendLIE inst `thenM_`
363 returnM (instToId inst)
365 newMethodWithGivenTy orig id tys
366 = getInstLoc orig `thenM` \ loc ->
367 newMethod loc id tys `thenM` \ inst ->
368 extendLIE inst `thenM_`
369 returnM (instToId inst)
371 --------------------------------------------
372 -- tcInstClassOp, and newMethod do *not* drop the
373 -- Inst into the LIE; they just returns the Inst
374 -- This is important because they are used by TcSimplify
377 -- NB: the kind of the type variable to be instantiated
378 -- might be a sub-kind of the type to which it is applied,
379 -- notably when the latter is a type variable of kind ??
380 -- Hence the call to checkKind
381 -- A worry: is this needed anywhere else?
382 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
383 tcInstClassOp inst_loc sel_id tys
385 (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
387 zipWithM_ checkKind tyvars tys `thenM_`
388 newMethod inst_loc sel_id tys
390 checkKind :: TyVar -> TcType -> TcM ()
391 -- Ensure that the type has a sub-kind of the tyvar
394 -- ty1 <- zonkTcType ty
395 ; if typeKind ty1 `isSubKind` Var.tyVarKind tv
399 pprPanic "checkKind: adding kind constraint"
400 (vcat [ppr tv <+> ppr (Var.tyVarKind tv),
401 ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
403 -- do { tv1 <- tcInstTyVar tv
404 -- ; unifyType ty1 (mkTyVarTy tv1) } }
407 ---------------------------
408 newMethod inst_loc id tys
409 = newUnique `thenM` \ new_uniq ->
411 (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
412 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
413 inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
414 tci_theta = theta, tci_loc = inst_loc}
415 loc = srcSpanStart (instLocSpan inst_loc)
421 shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
423 | isIntTy ty && inIntRange i -- Short cut for Int
424 = Just (HsLit (HsInt i))
425 | isIntegerTy ty -- Short cut for Integer
426 = Just (HsLit (HsInteger i ty))
427 | otherwise = Nothing
429 shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
432 = Just (mk_lit floatDataCon (HsFloatPrim f))
434 = Just (mk_lit doubleDataCon (HsDoublePrim f))
435 | otherwise = Nothing
437 mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
439 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
441 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
442 getSrcSpanM `thenM` \ span ->
443 returnM (L span $ HsLit (HsInteger i integer_ty))
445 mkRatLit :: Rational -> TcM (LHsExpr TcId)
447 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
448 getSrcSpanM `thenM` \ span ->
449 returnM (L span $ HsLit (HsRat r rat_ty))
451 isHsVar :: HsExpr Name -> Name -> Bool
452 isHsVar (HsVar f) g = f==g
453 isHsVar other g = False
457 %************************************************************************
461 %************************************************************************
463 Zonking makes sure that the instance types are fully zonked.
466 zonkInst :: Inst -> TcM Inst
467 zonkInst dict@(Dict { tci_pred = pred})
468 = zonkTcPredType pred `thenM` \ new_pred ->
469 returnM (dict {tci_pred = new_pred})
471 zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta})
472 = zonkId id `thenM` \ new_id ->
473 -- Essential to zonk the id in case it's a local variable
474 -- Can't use zonkIdOcc because the id might itself be
475 -- an InstId, in which case it won't be in scope
477 zonkTcTypes tys `thenM` \ new_tys ->
478 zonkTcThetaType theta `thenM` \ new_theta ->
479 returnM (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
480 -- No need to zonk the tci_id
482 zonkInst lit@(LitInst {tci_ty = ty})
483 = zonkTcType ty `thenM` \ new_ty ->
484 returnM (lit {tci_ty = new_ty})
486 zonkInst implic@(ImplicInst {})
487 = ASSERT( all isImmutableTyVar (tci_tyvars implic) )
488 do { givens' <- zonkInsts (tci_given implic)
489 ; wanteds' <- zonkInsts (tci_wanted implic)
490 ; return (implic {tci_given = givens',tci_wanted = wanteds'}) }
492 zonkInsts insts = mappM zonkInst insts
496 %************************************************************************
498 \subsection{Printing}
500 %************************************************************************
502 ToDo: improve these pretty-printing things. The ``origin'' is really only
503 relevant in error messages.
506 instance Outputable Inst where
507 ppr inst = pprInst inst
509 pprDictsTheta :: [Inst] -> SDoc
510 -- Print in type-like fashion (Eq a, Show b)
511 -- The Inst can be an implication constraint, but not a Method or LitInst
512 pprDictsTheta insts = parens (sep (punctuate comma (map (ppr . instType) insts)))
514 pprDictsInFull :: [Inst] -> SDoc
515 -- Print in type-like fashion, but with source location
517 = vcat (map go dicts)
519 go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
521 pprInsts :: [Inst] -> SDoc
522 -- Debugging: print the evidence :: type
523 pprInsts insts = brackets (interpp'SP insts)
525 pprInst, pprInstInFull :: Inst -> SDoc
526 -- Debugging: print the evidence :: type
527 pprInst inst = ppr (instName inst) <+> dcolon
528 <+> (braces (ppr (instType inst)) $$
529 ifPprDebug implic_stuff)
531 implic_stuff | isImplicInst inst = ppr (tci_reft inst)
534 pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
536 tidyInst :: TidyEnv -> Inst -> Inst
537 tidyInst env lit@(LitInst {tci_ty = ty}) = lit {tci_ty = tidyType env ty}
538 tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
539 tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
540 tidyInst env implic@(ImplicInst {})
541 = implic { tci_tyvars = tvs'
542 , tci_given = map (tidyInst env') (tci_given implic)
543 , tci_wanted = map (tidyInst env') (tci_wanted implic) }
545 (env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic)
547 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
548 -- This function doesn't assume that the tyvars are in scope
549 -- so it works like tidyOpenType, returning a TidyEnv
550 tidyMoreInsts env insts
551 = (env', map (tidyInst env') insts)
553 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
555 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
556 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
558 showLIE :: SDoc -> TcM () -- Debugging
560 = do { lie_var <- getLIEVar ;
561 lie <- readMutVar lie_var ;
562 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
566 %************************************************************************
568 Extending the instance environment
570 %************************************************************************
573 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
574 -- Add new locally-defined instances
575 tcExtendLocalInstEnv dfuns thing_inside
576 = do { traceDFuns dfuns
578 ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
579 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
580 tcg_inst_env = inst_env' }
581 ; setGblEnv env' thing_inside }
583 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
584 -- Check that the proposed new instance is OK,
585 -- and then add it to the home inst env
586 addLocalInst home_ie ispec
587 = do { -- Instantiate the dfun type so that we extend the instance
588 -- envt with completely fresh template variables
589 -- This is important because the template variables must
590 -- not overlap with anything in the things being looked up
591 -- (since we do unification).
592 -- We use tcInstSkolType because we don't want to allocate fresh
593 -- *meta* type variables.
594 let dfun = instanceDFunId ispec
595 ; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun)
596 ; let (cls, tys') = tcSplitDFunHead tau'
597 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
598 ispec' = setInstanceDFunId ispec dfun'
600 -- Load imported instances, so that we report
601 -- duplicates correctly
603 ; let inst_envs = (eps_inst_env eps, home_ie)
605 -- Check functional dependencies
606 ; case checkFunDeps inst_envs ispec' of
607 Just specs -> funDepErr ispec' specs
610 -- Check for duplicate instance decls
611 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
612 ; dup_ispecs = [ dup_ispec
613 | (_, dup_ispec) <- matches
614 , let (_,_,_,dup_tys) = instanceHead dup_ispec
615 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
616 -- Find memebers of the match list which ispec itself matches.
617 -- If the match is 2-way, it's a duplicate
619 dup_ispec : _ -> dupInstErr ispec' dup_ispec
622 -- OK, now extend the envt
623 ; return (extendInstEnv home_ie ispec') }
625 getOverlapFlag :: TcM OverlapFlag
627 = do { dflags <- getDOpts
628 ; let overlap_ok = dopt Opt_AllowOverlappingInstances dflags
629 incoherent_ok = dopt Opt_AllowIncoherentInstances dflags
630 overlap_flag | incoherent_ok = Incoherent
631 | overlap_ok = OverlapOk
632 | otherwise = NoOverlap
634 ; return overlap_flag }
637 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
639 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
640 -- Print the dfun name itself too
642 funDepErr ispec ispecs
644 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
645 2 (pprInstances (ispec:ispecs)))
646 dupInstErr ispec dup_ispec
648 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
649 2 (pprInstances [ispec, dup_ispec]))
651 addDictLoc ispec thing_inside
652 = setSrcSpan (mkSrcSpan loc loc) thing_inside
654 loc = getSrcLoc ispec
658 %************************************************************************
660 \subsection{Looking up Insts}
662 %************************************************************************
665 data LookupInstResult
667 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
669 lookupSimpleInst :: Inst -> TcM LookupInstResult
670 -- This is "simple" in tthat it returns NoInstance for implication constraints
672 -- It's important that lookupInst does not put any new stuff into
673 -- the LIE. Instead, any Insts needed by the lookup are returned in
674 -- the LookupInstResult, where they can be further processed by tcSimplify
676 --------------------- Implications ------------------------
677 lookupSimpleInst (ImplicInst {}) = return NoInstance
679 --------------------- Methods ------------------------
680 lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
681 = do { (dicts, dict_app) <- instCallDicts loc theta
682 ; let co_fn = dict_app <.> mkWpTyApps tys
683 ; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
685 span = instLocSpan loc
687 --------------------- Literals ------------------------
688 -- Look for short cuts first: if the literal is *definitely* a
689 -- int, integer, float or a double, generate the real thing here.
690 -- This is essential (see nofib/spectral/nucleic).
691 -- [Same shortcut as in newOverloadedLit, but we
692 -- may have done some unification by now]
694 lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name, tci_ty = ty, tci_loc = loc})
695 | Just expr <- shortCutIntLit i ty
696 = returnM (GenInst [] (noLoc expr))
698 = ASSERT( from_integer_name `isHsVar` fromIntegerName ) -- A LitInst invariant
699 tcLookupId fromIntegerName `thenM` \ from_integer ->
700 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
701 mkIntegerLit i `thenM` \ integer_lit ->
702 returnM (GenInst [method_inst]
703 (mkHsApp (L (instLocSpan loc)
704 (HsVar (instToId method_inst))) integer_lit))
706 lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name, tci_ty = ty, tci_loc = loc})
707 | Just expr <- shortCutFracLit f ty
708 = returnM (GenInst [] (noLoc expr))
711 = ASSERT( from_rat_name `isHsVar` fromRationalName ) -- A LitInst invariant
712 tcLookupId fromRationalName `thenM` \ from_rational ->
713 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
714 mkRatLit f `thenM` \ rat_lit ->
715 returnM (GenInst [method_inst] (mkHsApp (L (instLocSpan loc)
716 (HsVar (instToId method_inst))) rat_lit))
718 --------------------- Dictionaries ------------------------
719 lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
720 = do { mb_result <- lookupPred pred
721 ; case mb_result of {
722 Nothing -> return NoInstance ;
723 Just (tenv, dfun_id) -> do
725 -- tenv is a substitution that instantiates the dfun_id
726 -- to match the requested result type.
728 -- We ASSUME that the dfun is quantified over the very same tyvars
729 -- that are bound by the tenv.
732 -- might have some tyvars that *only* appear in arguments
733 -- dfun :: forall a b. C a b, Ord b => D [a]
734 -- We instantiate b to a flexi type variable -- it'll presumably
735 -- become fixed later via functional dependencies
736 { use_stage <- getStage
737 ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
738 (topIdLvl dfun_id) use_stage
740 -- It's possible that not all the tyvars are in
741 -- the substitution, tenv. For example:
742 -- instance C X a => D X where ...
743 -- (presumably there's a functional dependency in class C)
744 -- Hence the open_tvs to instantiate any un-substituted tyvars.
745 ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
746 open_tvs = filter (`notElemTvSubst` tenv) tyvars
747 ; open_tvs' <- mappM tcInstTyVar open_tvs
749 tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
750 -- Since the open_tvs' are freshly made, they cannot possibly be captured by
751 -- any nested for-alls in rho. So the in-scope set is unchanged
752 dfun_rho = substTy tenv' rho
753 (theta, _) = tcSplitPhiTy dfun_rho
754 src_loc = instLocSpan loc
756 tys = substTyVars tenv' tyvars
758 returnM (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
760 { (dicts, dict_app) <- instCallDicts loc theta
761 ; let co_fn = dict_app <.> mkWpTyApps tys
762 ; returnM (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
766 lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
767 -- Look up a class constraint in the instance environment
768 lookupPred pred@(ClassP clas tys)
770 ; tcg_env <- getGblEnv
771 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
772 ; case lookupInstEnv inst_envs clas tys of {
773 ([(tenv, ispec)], [])
774 -> do { let dfun_id = is_dfun ispec
775 ; traceTc (text "lookupInst success" <+>
776 vcat [text "dict" <+> ppr pred,
777 text "witness" <+> ppr dfun_id
778 <+> ppr (idType dfun_id) ])
779 -- Record that this dfun is needed
780 ; record_dfun_usage dfun_id
781 ; return (Just (tenv, dfun_id)) } ;
784 -> do { traceTc (text "lookupInst fail" <+>
785 vcat [text "dict" <+> ppr pred,
786 text "matches" <+> ppr matches,
787 text "unifs" <+> ppr unifs])
788 -- In the case of overlap (multiple matches) we report
789 -- NoInstance here. That has the effect of making the
790 -- context-simplifier return the dict as an irreducible one.
791 -- Then it'll be given to addNoInstanceErrs, which will do another
792 -- lookupInstEnv to get the detailed info about what went wrong.
796 lookupPred ip_pred = return Nothing -- Implicit parameters
798 record_dfun_usage dfun_id
799 = do { hsc_env <- getTopEnv
800 ; let dfun_name = idName dfun_id
801 dfun_mod = nameModule dfun_name
802 ; if isInternalName dfun_name || -- Internal name => defined in this module
803 modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
804 then return () -- internal, or in another package
805 else do { tcg_env <- getGblEnv
806 ; updMutVar (tcg_inst_uses tcg_env)
807 (`addOneToNameSet` idName dfun_id) }}
810 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
811 -- Gets both the external-package inst-env
812 -- and the home-pkg inst env (includes module being compiled)
813 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
814 return (eps_inst_env eps, tcg_inst_env env) }
819 %************************************************************************
823 %************************************************************************
825 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
826 a do-expression. We have to find (>>) in the current environment, which is
827 done by the rename. Then we have to check that it has the same type as
828 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
831 (>>) :: HB m n mn => m a -> n b -> mn b
833 So the idea is to generate a local binding for (>>), thus:
835 let then72 :: forall a b. m a -> m b -> m b
836 then72 = ...something involving the user's (>>)...
838 ...the do-expression...
840 Now the do-expression can proceed using then72, which has exactly
843 In fact tcSyntaxName just generates the RHS for then72, because we only
844 want an actual binding in the do-expression case. For literals, we can
845 just use the expression inline.
848 tcSyntaxName :: InstOrigin
849 -> TcType -- Type to instantiate it at
850 -> (Name, HsExpr Name) -- (Standard name, user name)
851 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
852 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
853 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
854 -- So we do not call it from lookupInst, which is called from tcSimplify
856 tcSyntaxName orig ty (std_nm, HsVar user_nm)
858 = newMethodFromName orig ty std_nm `thenM` \ id ->
859 returnM (std_nm, HsVar id)
861 tcSyntaxName orig ty (std_nm, user_nm_expr)
862 = tcLookupId std_nm `thenM` \ std_id ->
864 -- C.f. newMethodAtLoc
865 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
866 sigma1 = substTyWith [tv] [ty] tau
867 -- Actually, the "tau-type" might be a sigma-type in the
868 -- case of locally-polymorphic methods.
870 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $
872 -- Check that the user-supplied thing has the
873 -- same type as the standard one.
874 -- Tiresome jiggling because tcCheckSigma takes a located expression
875 getSrcSpanM `thenM` \ span ->
876 tcPolyExpr (L span user_nm_expr) sigma1 `thenM` \ expr ->
877 returnM (std_nm, unLoc expr)
879 syntaxNameCtxt name orig ty tidy_env
880 = getInstLoc orig `thenM` \ inst_loc ->
882 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
883 ptext SLIT("(needed by a syntactic construct)"),
884 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
885 nest 2 (ptext SLIT("arising from") <+> pprInstLoc inst_loc)]
887 returnM (tidy_env, msg)