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 instLoc, 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 = idName (instToId 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 = -- pprTrace "mkImplicTy" (ppr givens) $
115 mkPhiTy (map dictPred givens) $
116 if isSingleton wanteds then
117 instType (head wanteds)
119 mkTupleTy Boxed (length wanteds) (map instType wanteds)
121 instLoc inst = tci_loc inst
123 dictPred (Dict {tci_pred = pred}) = pred
124 dictPred inst = pprPanic "dictPred" (ppr inst)
126 getDictClassTys (Dict {tci_pred = pred}) = getClassPredTys pred
127 getDictClassTys inst = pprPanic "getDictClassTys" (ppr inst)
129 -- fdPredsOfInst is used to get predicates that contain functional
130 -- dependencies *or* might do so. The "might do" part is because
131 -- a constraint (C a b) might have a superclass with FDs
132 -- Leaving these in is really important for the call to fdPredsOfInsts
133 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
134 -- which is supposed to be conservative
135 fdPredsOfInst (Dict {tci_pred = pred}) = [pred]
136 fdPredsOfInst (Method {tci_theta = theta}) = theta
137 fdPredsOfInst (ImplicInst {tci_given = gs,
138 tci_wanted = ws}) = fdPredsOfInsts (gs ++ ws)
139 fdPredsOfInst (LitInst {}) = []
141 fdPredsOfInsts :: [Inst] -> [PredType]
142 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
144 isInheritableInst (Dict {tci_pred = pred}) = isInheritablePred pred
145 isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta
146 isInheritableInst other = True
149 ---------------------------------
150 -- Get the implicit parameters mentioned by these Insts
151 -- NB: the results of these functions are insensitive to zonking
153 ipNamesOfInsts :: [Inst] -> [Name]
154 ipNamesOfInst :: Inst -> [Name]
155 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
157 ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
158 ipNamesOfInst (Method {tci_theta = theta}) = [ipNameName n | IParam n _ <- theta]
159 ipNamesOfInst other = []
161 ---------------------------------
162 tyVarsOfInst :: Inst -> TcTyVarSet
163 tyVarsOfInst (LitInst {tci_ty = ty}) = tyVarsOfType ty
164 tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
165 tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
166 -- The id might have free type variables; in the case of
167 -- locally-overloaded class methods, for example
168 tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds})
169 = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds) `minusVarSet` mkVarSet tvs
172 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
173 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
179 isDict :: Inst -> Bool
180 isDict (Dict {}) = True
183 isClassDict :: Inst -> Bool
184 isClassDict (Dict {tci_pred = pred}) = isClassPred pred
185 isClassDict other = False
187 isTyVarDict :: Inst -> Bool
188 isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
189 isTyVarDict other = False
191 isIPDict :: Inst -> Bool
192 isIPDict (Dict {tci_pred = pred}) = isIPPred pred
193 isIPDict other = False
195 isImplicInst (ImplicInst {}) = True
196 isImplicInst other = False
198 isMethod :: Inst -> Bool
199 isMethod (Method {}) = True
200 isMethod other = False
202 isMethodFor :: TcIdSet -> Inst -> Bool
203 isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
204 isMethodFor ids inst = False
206 isMethodOrLit :: Inst -> Bool
207 isMethodOrLit (Method {}) = True
208 isMethodOrLit (LitInst {}) = True
209 isMethodOrLit other = False
213 getDefaultableDicts :: [Inst] -> ([(Inst, Class, TcTyVar)], TcTyVarSet)
214 -- Look for free dicts of the form (C tv), even inside implications
215 -- *and* the set of tyvars mentioned by all *other* constaints
216 -- This disgustingly ad-hoc function is solely to support defaulting
217 getDefaultableDicts insts
218 = (concat ps, unionVarSets tvs)
220 (ps, tvs) = mapAndUnzip get insts
221 get d@(Dict {tci_pred = ClassP cls [ty]})
222 | Just tv <- tcGetTyVar_maybe ty = ([(d,cls,tv)], emptyVarSet)
223 | otherwise = ([], tyVarsOfType ty)
224 get (ImplicInst {tci_tyvars = tvs, tci_wanted = wanteds})
225 = ([ up | up@(_,_,tv) <- ups, not (tv `elemVarSet` tv_set)],
226 ftvs `minusVarSet` tv_set)
228 tv_set = mkVarSet tvs
229 (ups, ftvs) = getDefaultableDicts wanteds
230 get inst = ([], tyVarsOfInst inst)
233 %************************************************************************
235 \subsection{Building dictionaries}
237 %************************************************************************
239 -- newDictBndrs makes a dictionary at a binding site
240 -- instCall makes a dictionary at an occurrence site
241 -- and throws it into the LIE
245 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
246 newDictBndrsO orig theta = do { loc <- getInstLoc orig
247 ; newDictBndrs loc theta }
249 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
250 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
252 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
253 newDictBndr inst_loc pred
254 = do { uniq <- newUnique
255 ; let name = mkPredName uniq inst_loc pred
256 ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
259 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
260 -- Instantiate the constraints of a call
261 -- (instCall o tys theta)
262 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
263 -- (b) Throws these dictionaries into the LIE
264 -- (c) Eeturns an HsWrapper ([.] tys dicts)
266 instCall orig tys theta
267 = do { loc <- getInstLoc orig
268 ; (dicts, dict_app) <- instCallDicts loc theta
270 ; return (dict_app <.> mkWpTyApps tys) }
273 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
274 -- Similar to instCall, but only emit the constraints in the LIE
275 -- Used exclusively for the 'stupid theta' of a data constructor
276 instStupidTheta orig theta
277 = do { loc <- getInstLoc orig
278 ; (dicts, _) <- instCallDicts loc theta
282 instCallDicts :: InstLoc -> TcThetaType -> TcM ([Inst], HsWrapper)
283 -- This is the key place where equality predicates
284 -- are unleashed into the world
285 instCallDicts loc [] = return ([], idHsWrapper)
287 instCallDicts loc (EqPred ty1 ty2 : preds)
288 = do { unifyType ty1 ty2 -- For now, we insist that they unify right away
289 -- Later on, when we do associated types,
290 -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
291 ; (dicts, co_fn) <- instCallDicts loc preds
292 ; return (dicts, co_fn <.> WpTyApp ty1) }
293 -- We use type application to apply the function to the
294 -- coercion; here ty1 *is* the appropriate identity coercion
296 instCallDicts loc (pred : preds)
297 = do { uniq <- newUnique
298 ; let name = mkPredName uniq loc pred
299 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
300 ; (dicts, co_fn) <- instCallDicts loc preds
301 ; return (dict:dicts, co_fn <.> WpApp (instToId dict)) }
304 cloneDict :: Inst -> TcM Inst -- Only used for linear implicit params
305 cloneDict dict@(Dict nm ty loc) = do { uniq <- newUnique
306 ; return (dict {tci_name = setNameUnique nm uniq}) }
307 cloneDict other = pprPanic "cloneDict" (ppr other)
309 -- For vanilla implicit parameters, there is only one in scope
310 -- at any time, so we used to use the name of the implicit parameter itself
311 -- But with splittable implicit parameters there may be many in
312 -- scope, so we make up a new namea.
313 newIPDict :: InstOrigin -> IPName Name -> Type
314 -> TcM (IPName Id, Inst)
315 newIPDict orig ip_name ty
316 = getInstLoc orig `thenM` \ inst_loc ->
317 newUnique `thenM` \ uniq ->
319 pred = IParam ip_name ty
320 name = mkPredName uniq inst_loc pred
321 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}
323 returnM (mapIPName (\n -> instToId dict) ip_name, dict)
328 mkPredName :: Unique -> InstLoc -> PredType -> Name
329 mkPredName uniq loc pred_ty
330 = mkInternalName uniq occ (srcSpanStart (instLocSpan loc))
332 occ = case pred_ty of
333 ClassP cls tys -> mkDictOcc (getOccName cls)
334 IParam ip ty -> getOccName (ipNameName ip)
337 %************************************************************************
339 \subsection{Building methods (calls of overloaded functions)}
341 %************************************************************************
345 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
346 newMethodFromName origin ty name
347 = tcLookupId name `thenM` \ id ->
348 -- Use tcLookupId not tcLookupGlobalId; the method is almost
349 -- always a class op, but with -fno-implicit-prelude GHC is
350 -- meant to find whatever thing is in scope, and that may
351 -- be an ordinary function.
352 getInstLoc origin `thenM` \ loc ->
353 tcInstClassOp loc id [ty] `thenM` \ inst ->
354 extendLIE inst `thenM_`
355 returnM (instToId inst)
357 newMethodWithGivenTy orig id tys
358 = getInstLoc orig `thenM` \ loc ->
359 newMethod loc id tys `thenM` \ inst ->
360 extendLIE inst `thenM_`
361 returnM (instToId inst)
363 --------------------------------------------
364 -- tcInstClassOp, and newMethod do *not* drop the
365 -- Inst into the LIE; they just returns the Inst
366 -- This is important because they are used by TcSimplify
369 -- NB: the kind of the type variable to be instantiated
370 -- might be a sub-kind of the type to which it is applied,
371 -- notably when the latter is a type variable of kind ??
372 -- Hence the call to checkKind
373 -- A worry: is this needed anywhere else?
374 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
375 tcInstClassOp inst_loc sel_id tys
377 (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
379 zipWithM_ checkKind tyvars tys `thenM_`
380 newMethod inst_loc sel_id tys
382 checkKind :: TyVar -> TcType -> TcM ()
383 -- Ensure that the type has a sub-kind of the tyvar
386 -- ty1 <- zonkTcType ty
387 ; if typeKind ty1 `isSubKind` Var.tyVarKind tv
391 pprPanic "checkKind: adding kind constraint"
392 (vcat [ppr tv <+> ppr (Var.tyVarKind tv),
393 ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
395 -- do { tv1 <- tcInstTyVar tv
396 -- ; unifyType ty1 (mkTyVarTy tv1) } }
399 ---------------------------
400 newMethod inst_loc id tys
401 = newUnique `thenM` \ new_uniq ->
403 (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
404 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
405 inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
406 tci_theta = theta, tci_loc = inst_loc}
407 loc = srcSpanStart (instLocSpan inst_loc)
413 shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
415 | isIntTy ty && inIntRange i -- Short cut for Int
416 = Just (HsLit (HsInt i))
417 | isIntegerTy ty -- Short cut for Integer
418 = Just (HsLit (HsInteger i ty))
419 | otherwise = Nothing
421 shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
424 = Just (mk_lit floatDataCon (HsFloatPrim f))
426 = Just (mk_lit doubleDataCon (HsDoublePrim f))
427 | otherwise = Nothing
429 mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
431 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
433 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
434 getSrcSpanM `thenM` \ span ->
435 returnM (L span $ HsLit (HsInteger i integer_ty))
437 mkRatLit :: Rational -> TcM (LHsExpr TcId)
439 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
440 getSrcSpanM `thenM` \ span ->
441 returnM (L span $ HsLit (HsRat r rat_ty))
443 isHsVar :: HsExpr Name -> Name -> Bool
444 isHsVar (HsVar f) g = f==g
445 isHsVar other g = False
449 %************************************************************************
453 %************************************************************************
455 Zonking makes sure that the instance types are fully zonked.
458 zonkInst :: Inst -> TcM Inst
459 zonkInst dict@(Dict { tci_pred = pred})
460 = zonkTcPredType pred `thenM` \ new_pred ->
461 returnM (dict {tci_pred = new_pred})
463 zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta})
464 = zonkId id `thenM` \ new_id ->
465 -- Essential to zonk the id in case it's a local variable
466 -- Can't use zonkIdOcc because the id might itself be
467 -- an InstId, in which case it won't be in scope
469 zonkTcTypes tys `thenM` \ new_tys ->
470 zonkTcThetaType theta `thenM` \ new_theta ->
471 returnM (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
472 -- No need to zonk the tci_id
474 zonkInst lit@(LitInst {tci_ty = ty})
475 = zonkTcType ty `thenM` \ new_ty ->
476 returnM (lit {tci_ty = new_ty})
478 zonkInst implic@(ImplicInst {})
479 = ASSERT( all isImmutableTyVar (tci_tyvars implic) )
480 do { givens' <- zonkInsts (tci_given implic)
481 ; wanteds' <- zonkInsts (tci_wanted implic)
482 ; return (implic {tci_given = givens',tci_wanted = wanteds'}) }
484 zonkInsts insts = mappM zonkInst insts
488 %************************************************************************
490 \subsection{Printing}
492 %************************************************************************
494 ToDo: improve these pretty-printing things. The ``origin'' is really only
495 relevant in error messages.
498 instance Outputable Inst where
499 ppr inst = pprInst inst
501 pprDictsTheta :: [Inst] -> SDoc
502 -- Print in type-like fashion (Eq a, Show b)
503 -- The Inst can be an implication constraint, but not a Method or LitInst
504 pprDictsTheta insts = parens (sep (punctuate comma (map (ppr . instType) insts)))
506 pprDictsInFull :: [Inst] -> SDoc
507 -- Print in type-like fashion, but with source location
509 = vcat (map go dicts)
511 go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
513 pprInsts :: [Inst] -> SDoc
514 -- Debugging: print the evidence :: type
515 pprInsts insts = brackets (interpp'SP insts)
517 pprInst, pprInstInFull :: Inst -> SDoc
518 -- Debugging: print the evidence :: type
519 pprInst inst = ppr (instName inst) <+> dcolon
520 <+> (braces (ppr (instType inst)) $$
521 ifPprDebug implic_stuff)
523 implic_stuff | isImplicInst inst = ppr (tci_reft inst)
526 pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
528 tidyInst :: TidyEnv -> Inst -> Inst
529 tidyInst env lit@(LitInst {tci_ty = ty}) = lit {tci_ty = tidyType env ty}
530 tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
531 tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
532 tidyInst env implic@(ImplicInst {})
533 = implic { tci_tyvars = tvs'
534 , tci_given = map (tidyInst env') (tci_given implic)
535 , tci_wanted = map (tidyInst env') (tci_wanted implic) }
537 (env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic)
539 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
540 -- This function doesn't assume that the tyvars are in scope
541 -- so it works like tidyOpenType, returning a TidyEnv
542 tidyMoreInsts env insts
543 = (env', map (tidyInst env') insts)
545 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
547 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
548 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
550 showLIE :: SDoc -> TcM () -- Debugging
552 = do { lie_var <- getLIEVar ;
553 lie <- readMutVar lie_var ;
554 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
558 %************************************************************************
560 Extending the instance environment
562 %************************************************************************
565 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
566 -- Add new locally-defined instances
567 tcExtendLocalInstEnv dfuns thing_inside
568 = do { traceDFuns dfuns
570 ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
571 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
572 tcg_inst_env = inst_env' }
573 ; setGblEnv env' thing_inside }
575 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
576 -- Check that the proposed new instance is OK,
577 -- and then add it to the home inst env
578 addLocalInst home_ie ispec
579 = do { -- Instantiate the dfun type so that we extend the instance
580 -- envt with completely fresh template variables
581 -- This is important because the template variables must
582 -- not overlap with anything in the things being looked up
583 -- (since we do unification).
584 -- We use tcInstSkolType because we don't want to allocate fresh
585 -- *meta* type variables.
586 let dfun = instanceDFunId ispec
587 ; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun)
588 ; let (cls, tys') = tcSplitDFunHead tau'
589 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
590 ispec' = setInstanceDFunId ispec dfun'
592 -- Load imported instances, so that we report
593 -- duplicates correctly
595 ; let inst_envs = (eps_inst_env eps, home_ie)
597 -- Check functional dependencies
598 ; case checkFunDeps inst_envs ispec' of
599 Just specs -> funDepErr ispec' specs
602 -- Check for duplicate instance decls
603 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
604 ; dup_ispecs = [ dup_ispec
605 | (_, dup_ispec) <- matches
606 , let (_,_,_,dup_tys) = instanceHead dup_ispec
607 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
608 -- Find memebers of the match list which ispec itself matches.
609 -- If the match is 2-way, it's a duplicate
611 dup_ispec : _ -> dupInstErr ispec' dup_ispec
614 -- OK, now extend the envt
615 ; return (extendInstEnv home_ie ispec') }
617 getOverlapFlag :: TcM OverlapFlag
619 = do { dflags <- getDOpts
620 ; let overlap_ok = dopt Opt_AllowOverlappingInstances dflags
621 incoherent_ok = dopt Opt_AllowIncoherentInstances dflags
622 overlap_flag | incoherent_ok = Incoherent
623 | overlap_ok = OverlapOk
624 | otherwise = NoOverlap
626 ; return overlap_flag }
629 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
631 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
632 -- Print the dfun name itself too
634 funDepErr ispec ispecs
636 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
637 2 (pprInstances (ispec:ispecs)))
638 dupInstErr ispec dup_ispec
640 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
641 2 (pprInstances [ispec, dup_ispec]))
643 addDictLoc ispec thing_inside
644 = setSrcSpan (mkSrcSpan loc loc) thing_inside
646 loc = getSrcLoc ispec
650 %************************************************************************
652 \subsection{Looking up Insts}
654 %************************************************************************
657 data LookupInstResult
659 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
661 lookupSimpleInst :: Inst -> TcM LookupInstResult
662 -- This is "simple" in tthat it returns NoInstance for implication constraints
664 -- It's important that lookupInst does not put any new stuff into
665 -- the LIE. Instead, any Insts needed by the lookup are returned in
666 -- the LookupInstResult, where they can be further processed by tcSimplify
668 --------------------- Impliciations ------------------------
669 lookupSimpleInst (ImplicInst {}) = return NoInstance
671 --------------------- Methods ------------------------
672 lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
673 = do { (dicts, dict_app) <- instCallDicts loc theta
674 ; let co_fn = dict_app <.> mkWpTyApps tys
675 ; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
677 span = instLocSpan loc
679 --------------------- Literals ------------------------
680 -- Look for short cuts first: if the literal is *definitely* a
681 -- int, integer, float or a double, generate the real thing here.
682 -- This is essential (see nofib/spectral/nucleic).
683 -- [Same shortcut as in newOverloadedLit, but we
684 -- may have done some unification by now]
686 lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name, tci_ty = ty, tci_loc = loc})
687 | Just expr <- shortCutIntLit i ty
688 = returnM (GenInst [] (noLoc expr))
690 = ASSERT( from_integer_name `isHsVar` fromIntegerName ) -- A LitInst invariant
691 tcLookupId fromIntegerName `thenM` \ from_integer ->
692 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
693 mkIntegerLit i `thenM` \ integer_lit ->
694 returnM (GenInst [method_inst]
695 (mkHsApp (L (instLocSpan loc)
696 (HsVar (instToId method_inst))) integer_lit))
698 lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name, tci_ty = ty, tci_loc = loc})
699 | Just expr <- shortCutFracLit f ty
700 = returnM (GenInst [] (noLoc expr))
703 = ASSERT( from_rat_name `isHsVar` fromRationalName ) -- A LitInst invariant
704 tcLookupId fromRationalName `thenM` \ from_rational ->
705 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
706 mkRatLit f `thenM` \ rat_lit ->
707 returnM (GenInst [method_inst] (mkHsApp (L (instLocSpan loc)
708 (HsVar (instToId method_inst))) rat_lit))
710 --------------------- Dictionaries ------------------------
711 lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
712 = do { mb_result <- lookupPred pred
713 ; case mb_result of {
714 Nothing -> return NoInstance ;
715 Just (tenv, dfun_id) -> do
717 -- tenv is a substitution that instantiates the dfun_id
718 -- to match the requested result type.
720 -- We ASSUME that the dfun is quantified over the very same tyvars
721 -- that are bound by the tenv.
724 -- might have some tyvars that *only* appear in arguments
725 -- dfun :: forall a b. C a b, Ord b => D [a]
726 -- We instantiate b to a flexi type variable -- it'll presumably
727 -- become fixed later via functional dependencies
728 { use_stage <- getStage
729 ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
730 (topIdLvl dfun_id) use_stage
732 -- It's possible that not all the tyvars are in
733 -- the substitution, tenv. For example:
734 -- instance C X a => D X where ...
735 -- (presumably there's a functional dependency in class C)
736 -- Hence the open_tvs to instantiate any un-substituted tyvars.
737 ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
738 open_tvs = filter (`notElemTvSubst` tenv) tyvars
739 ; open_tvs' <- mappM tcInstTyVar open_tvs
741 tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
742 -- Since the open_tvs' are freshly made, they cannot possibly be captured by
743 -- any nested for-alls in rho. So the in-scope set is unchanged
744 dfun_rho = substTy tenv' rho
745 (theta, _) = tcSplitPhiTy dfun_rho
746 src_loc = instLocSpan loc
748 tys = map (substTyVar tenv') tyvars
750 returnM (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
752 { (dicts, dict_app) <- instCallDicts loc theta
753 ; let co_fn = dict_app <.> mkWpTyApps tys
754 ; returnM (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
758 lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
759 -- Look up a class constraint in the instance environment
760 lookupPred pred@(ClassP clas tys)
762 ; tcg_env <- getGblEnv
763 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
764 ; case lookupInstEnv inst_envs clas tys of {
765 ([(tenv, ispec)], [])
766 -> do { let dfun_id = is_dfun ispec
767 ; traceTc (text "lookupInst success" <+>
768 vcat [text "dict" <+> ppr pred,
769 text "witness" <+> ppr dfun_id
770 <+> ppr (idType dfun_id) ])
771 -- Record that this dfun is needed
772 ; record_dfun_usage dfun_id
773 ; return (Just (tenv, dfun_id)) } ;
776 -> do { traceTc (text "lookupInst fail" <+>
777 vcat [text "dict" <+> ppr pred,
778 text "matches" <+> ppr matches,
779 text "unifs" <+> ppr unifs])
780 -- In the case of overlap (multiple matches) we report
781 -- NoInstance here. That has the effect of making the
782 -- context-simplifier return the dict as an irreducible one.
783 -- Then it'll be given to addNoInstanceErrs, which will do another
784 -- lookupInstEnv to get the detailed info about what went wrong.
788 lookupPred ip_pred = return Nothing
790 record_dfun_usage dfun_id
791 = do { hsc_env <- getTopEnv
792 ; let dfun_name = idName dfun_id
793 dfun_mod = nameModule dfun_name
794 ; if isInternalName dfun_name || -- Internal name => defined in this module
795 modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
796 then return () -- internal, or in another package
797 else do { tcg_env <- getGblEnv
798 ; updMutVar (tcg_inst_uses tcg_env)
799 (`addOneToNameSet` idName dfun_id) }}
802 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
803 -- Gets both the external-package inst-env
804 -- and the home-pkg inst env (includes module being compiled)
805 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
806 return (eps_inst_env eps, tcg_inst_env env) }
811 %************************************************************************
815 %************************************************************************
817 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
818 a do-expression. We have to find (>>) in the current environment, which is
819 done by the rename. Then we have to check that it has the same type as
820 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
823 (>>) :: HB m n mn => m a -> n b -> mn b
825 So the idea is to generate a local binding for (>>), thus:
827 let then72 :: forall a b. m a -> m b -> m b
828 then72 = ...something involving the user's (>>)...
830 ...the do-expression...
832 Now the do-expression can proceed using then72, which has exactly
835 In fact tcSyntaxName just generates the RHS for then72, because we only
836 want an actual binding in the do-expression case. For literals, we can
837 just use the expression inline.
840 tcSyntaxName :: InstOrigin
841 -> TcType -- Type to instantiate it at
842 -> (Name, HsExpr Name) -- (Standard name, user name)
843 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
844 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
845 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
846 -- So we do not call it from lookupInst, which is called from tcSimplify
848 tcSyntaxName orig ty (std_nm, HsVar user_nm)
850 = newMethodFromName orig ty std_nm `thenM` \ id ->
851 returnM (std_nm, HsVar id)
853 tcSyntaxName orig ty (std_nm, user_nm_expr)
854 = tcLookupId std_nm `thenM` \ std_id ->
856 -- C.f. newMethodAtLoc
857 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
858 sigma1 = substTyWith [tv] [ty] tau
859 -- Actually, the "tau-type" might be a sigma-type in the
860 -- case of locally-polymorphic methods.
862 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $
864 -- Check that the user-supplied thing has the
865 -- same type as the standard one.
866 -- Tiresome jiggling because tcCheckSigma takes a located expression
867 getSrcSpanM `thenM` \ span ->
868 tcPolyExpr (L span user_nm_expr) sigma1 `thenM` \ expr ->
869 returnM (std_nm, unLoc expr)
871 syntaxNameCtxt name orig ty tidy_env
872 = getInstLoc orig `thenM` \ inst_loc ->
874 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
875 ptext SLIT("(needed by a syntactic construct)"),
876 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
877 nest 2 (ptext SLIT("arising from") <+> pprInstLoc inst_loc)]
879 returnM (tidy_env, msg)