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 = 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 dictPred (Dict {tci_pred = pred}) = pred
122 dictPred inst = pprPanic "dictPred" (ppr inst)
124 getDictClassTys (Dict {tci_pred = pred}) = getClassPredTys pred
125 getDictClassTys inst = pprPanic "getDictClassTys" (ppr inst)
127 -- fdPredsOfInst is used to get predicates that contain functional
128 -- dependencies *or* might do so. The "might do" part is because
129 -- a constraint (C a b) might have a superclass with FDs
130 -- Leaving these in is really important for the call to fdPredsOfInsts
131 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
132 -- which is supposed to be conservative
133 fdPredsOfInst (Dict {tci_pred = pred}) = [pred]
134 fdPredsOfInst (Method {tci_theta = theta}) = theta
135 fdPredsOfInst (ImplicInst {tci_given = gs,
136 tci_wanted = ws}) = fdPredsOfInsts (gs ++ ws)
137 fdPredsOfInst (LitInst {}) = []
139 fdPredsOfInsts :: [Inst] -> [PredType]
140 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
142 isInheritableInst (Dict {tci_pred = pred}) = isInheritablePred pred
143 isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta
144 isInheritableInst other = True
147 ---------------------------------
148 -- Get the implicit parameters mentioned by these Insts
149 -- NB: the results of these functions are insensitive to zonking
151 ipNamesOfInsts :: [Inst] -> [Name]
152 ipNamesOfInst :: Inst -> [Name]
153 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
155 ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
156 ipNamesOfInst (Method {tci_theta = theta}) = [ipNameName n | IParam n _ <- theta]
157 ipNamesOfInst other = []
159 ---------------------------------
160 tyVarsOfInst :: Inst -> TcTyVarSet
161 tyVarsOfInst (LitInst {tci_ty = ty}) = tyVarsOfType ty
162 tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
163 tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
164 -- The id might have free type variables; in the case of
165 -- locally-overloaded class methods, for example
166 tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds})
167 = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds) `minusVarSet` mkVarSet tvs
170 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
171 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
177 isDict :: Inst -> Bool
178 isDict (Dict {}) = True
181 isClassDict :: Inst -> Bool
182 isClassDict (Dict {tci_pred = pred}) = isClassPred pred
183 isClassDict other = False
185 isTyVarDict :: Inst -> Bool
186 isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
187 isTyVarDict other = False
189 isIPDict :: Inst -> Bool
190 isIPDict (Dict {tci_pred = pred}) = isIPPred pred
191 isIPDict other = False
193 isImplicInst (ImplicInst {}) = True
194 isImplicInst other = False
196 isMethod :: Inst -> Bool
197 isMethod (Method {}) = True
198 isMethod other = False
200 isMethodFor :: TcIdSet -> Inst -> Bool
201 isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
202 isMethodFor ids inst = False
204 isMethodOrLit :: Inst -> Bool
205 isMethodOrLit (Method {}) = True
206 isMethodOrLit (LitInst {}) = True
207 isMethodOrLit other = False
211 getDefaultableDicts :: [Inst] -> ([(Inst, Class, TcTyVar)], TcTyVarSet)
212 -- Look for free dicts of the form (C tv), even inside implications
213 -- *and* the set of tyvars mentioned by all *other* constaints
214 -- This disgustingly ad-hoc function is solely to support defaulting
215 getDefaultableDicts insts
216 = (concat ps, unionVarSets tvs)
218 (ps, tvs) = mapAndUnzip get insts
219 get d@(Dict {tci_pred = ClassP cls [ty]})
220 | Just tv <- tcGetTyVar_maybe ty = ([(d,cls,tv)], emptyVarSet)
221 | otherwise = ([], tyVarsOfType ty)
222 get (ImplicInst {tci_tyvars = tvs, tci_wanted = wanteds})
223 = ([ up | up@(_,_,tv) <- ups, not (tv `elemVarSet` tv_set)],
224 ftvs `minusVarSet` tv_set)
226 tv_set = mkVarSet tvs
227 (ups, ftvs) = getDefaultableDicts wanteds
228 get inst = ([], tyVarsOfInst inst)
231 %************************************************************************
233 \subsection{Building dictionaries}
235 %************************************************************************
237 -- newDictBndrs makes a dictionary at a binding site
238 -- instCall makes a dictionary at an occurrence site
239 -- and throws it into the LIE
243 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
244 newDictBndrsO orig theta = do { loc <- getInstLoc orig
245 ; newDictBndrs loc theta }
247 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
248 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
250 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
251 newDictBndr inst_loc pred
252 = do { uniq <- newUnique
253 ; let name = mkPredName uniq inst_loc pred
254 ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
257 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
258 -- Instantiate the constraints of a call
259 -- (instCall o tys theta)
260 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
261 -- (b) Throws these dictionaries into the LIE
262 -- (c) Eeturns an HsWrapper ([.] tys dicts)
264 instCall orig tys theta
265 = do { loc <- getInstLoc orig
266 ; (dicts, dict_app) <- instCallDicts loc theta
268 ; return (dict_app <.> mkWpTyApps tys) }
271 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
272 -- Similar to instCall, but only emit the constraints in the LIE
273 -- Used exclusively for the 'stupid theta' of a data constructor
274 instStupidTheta orig theta
275 = do { loc <- getInstLoc orig
276 ; (dicts, _) <- instCallDicts loc theta
280 instCallDicts :: InstLoc -> TcThetaType -> TcM ([Inst], HsWrapper)
281 -- This is the key place where equality predicates
282 -- are unleashed into the world
283 instCallDicts loc [] = return ([], idHsWrapper)
285 instCallDicts loc (EqPred ty1 ty2 : preds)
286 = do { unifyType ty1 ty2 -- For now, we insist that they unify right away
287 -- Later on, when we do associated types,
288 -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
289 ; (dicts, co_fn) <- instCallDicts loc preds
290 ; return (dicts, co_fn <.> WpTyApp ty1) }
291 -- We use type application to apply the function to the
292 -- coercion; here ty1 *is* the appropriate identity coercion
294 instCallDicts loc (pred : preds)
295 = do { uniq <- newUnique
296 ; let name = mkPredName uniq loc pred
297 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
298 ; (dicts, co_fn) <- instCallDicts loc preds
299 ; return (dict:dicts, co_fn <.> WpApp (instToId dict)) }
302 cloneDict :: Inst -> TcM Inst -- Only used for linear implicit params
303 cloneDict dict@(Dict nm ty loc) = do { uniq <- newUnique
304 ; return (dict {tci_name = setNameUnique nm uniq}) }
305 cloneDict other = pprPanic "cloneDict" (ppr other)
307 -- For vanilla implicit parameters, there is only one in scope
308 -- at any time, so we used to use the name of the implicit parameter itself
309 -- But with splittable implicit parameters there may be many in
310 -- scope, so we make up a new namea.
311 newIPDict :: InstOrigin -> IPName Name -> Type
312 -> TcM (IPName Id, Inst)
313 newIPDict orig ip_name ty
314 = getInstLoc orig `thenM` \ inst_loc ->
315 newUnique `thenM` \ uniq ->
317 pred = IParam ip_name ty
318 name = mkPredName uniq inst_loc pred
319 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}
321 returnM (mapIPName (\n -> instToId dict) ip_name, dict)
326 mkPredName :: Unique -> InstLoc -> PredType -> Name
327 mkPredName uniq loc pred_ty
328 = mkInternalName uniq occ (srcSpanStart (instLocSpan loc))
330 occ = case pred_ty of
331 ClassP cls tys -> mkDictOcc (getOccName cls)
332 IParam ip ty -> getOccName (ipNameName ip)
335 %************************************************************************
337 \subsection{Building methods (calls of overloaded functions)}
339 %************************************************************************
343 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
344 newMethodFromName origin ty name
345 = tcLookupId name `thenM` \ id ->
346 -- Use tcLookupId not tcLookupGlobalId; the method is almost
347 -- always a class op, but with -fno-implicit-prelude GHC is
348 -- meant to find whatever thing is in scope, and that may
349 -- be an ordinary function.
350 getInstLoc origin `thenM` \ loc ->
351 tcInstClassOp loc id [ty] `thenM` \ inst ->
352 extendLIE inst `thenM_`
353 returnM (instToId inst)
355 newMethodWithGivenTy orig id tys
356 = getInstLoc orig `thenM` \ loc ->
357 newMethod loc id tys `thenM` \ inst ->
358 extendLIE inst `thenM_`
359 returnM (instToId inst)
361 --------------------------------------------
362 -- tcInstClassOp, and newMethod do *not* drop the
363 -- Inst into the LIE; they just returns the Inst
364 -- This is important because they are used by TcSimplify
367 -- NB: the kind of the type variable to be instantiated
368 -- might be a sub-kind of the type to which it is applied,
369 -- notably when the latter is a type variable of kind ??
370 -- Hence the call to checkKind
371 -- A worry: is this needed anywhere else?
372 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
373 tcInstClassOp inst_loc sel_id tys
375 (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
377 zipWithM_ checkKind tyvars tys `thenM_`
378 newMethod inst_loc sel_id tys
380 checkKind :: TyVar -> TcType -> TcM ()
381 -- Ensure that the type has a sub-kind of the tyvar
384 -- ty1 <- zonkTcType ty
385 ; if typeKind ty1 `isSubKind` Var.tyVarKind tv
389 pprPanic "checkKind: adding kind constraint"
390 (vcat [ppr tv <+> ppr (Var.tyVarKind tv),
391 ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
393 -- do { tv1 <- tcInstTyVar tv
394 -- ; unifyType ty1 (mkTyVarTy tv1) } }
397 ---------------------------
398 newMethod inst_loc id tys
399 = newUnique `thenM` \ new_uniq ->
401 (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
402 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
403 inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
404 tci_theta = theta, tci_loc = inst_loc}
405 loc = srcSpanStart (instLocSpan inst_loc)
411 shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
413 | isIntTy ty && inIntRange i -- Short cut for Int
414 = Just (HsLit (HsInt i))
415 | isIntegerTy ty -- Short cut for Integer
416 = Just (HsLit (HsInteger i ty))
417 | otherwise = Nothing
419 shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
422 = Just (mk_lit floatDataCon (HsFloatPrim f))
424 = Just (mk_lit doubleDataCon (HsDoublePrim f))
425 | otherwise = Nothing
427 mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
429 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
431 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
432 getSrcSpanM `thenM` \ span ->
433 returnM (L span $ HsLit (HsInteger i integer_ty))
435 mkRatLit :: Rational -> TcM (LHsExpr TcId)
437 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
438 getSrcSpanM `thenM` \ span ->
439 returnM (L span $ HsLit (HsRat r rat_ty))
441 isHsVar :: HsExpr Name -> Name -> Bool
442 isHsVar (HsVar f) g = f==g
443 isHsVar other g = False
447 %************************************************************************
451 %************************************************************************
453 Zonking makes sure that the instance types are fully zonked.
456 zonkInst :: Inst -> TcM Inst
457 zonkInst dict@(Dict { tci_pred = pred})
458 = zonkTcPredType pred `thenM` \ new_pred ->
459 returnM (dict {tci_pred = new_pred})
461 zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta})
462 = zonkId id `thenM` \ new_id ->
463 -- Essential to zonk the id in case it's a local variable
464 -- Can't use zonkIdOcc because the id might itself be
465 -- an InstId, in which case it won't be in scope
467 zonkTcTypes tys `thenM` \ new_tys ->
468 zonkTcThetaType theta `thenM` \ new_theta ->
469 returnM (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
470 -- No need to zonk the tci_id
472 zonkInst lit@(LitInst {tci_ty = ty})
473 = zonkTcType ty `thenM` \ new_ty ->
474 returnM (lit {tci_ty = new_ty})
476 zonkInst implic@(ImplicInst {})
477 = ASSERT( all isImmutableTyVar (tci_tyvars implic) )
478 do { givens' <- zonkInsts (tci_given implic)
479 ; wanteds' <- zonkInsts (tci_wanted implic)
480 ; return (implic {tci_given = givens',tci_wanted = wanteds'}) }
482 zonkInsts insts = mappM zonkInst insts
486 %************************************************************************
488 \subsection{Printing}
490 %************************************************************************
492 ToDo: improve these pretty-printing things. The ``origin'' is really only
493 relevant in error messages.
496 instance Outputable Inst where
497 ppr inst = pprInst inst
499 pprDictsTheta :: [Inst] -> SDoc
500 -- Print in type-like fashion (Eq a, Show b)
501 -- The Inst can be an implication constraint, but not a Method or LitInst
502 pprDictsTheta insts = parens (sep (punctuate comma (map (ppr . instType) insts)))
504 pprDictsInFull :: [Inst] -> SDoc
505 -- Print in type-like fashion, but with source location
507 = vcat (map go dicts)
509 go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
511 pprInsts :: [Inst] -> SDoc
512 -- Debugging: print the evidence :: type
513 pprInsts insts = brackets (interpp'SP insts)
515 pprInst, pprInstInFull :: Inst -> SDoc
516 -- Debugging: print the evidence :: type
517 pprInst inst = ppr (instName inst) <+> dcolon
518 <+> (braces (ppr (instType inst)) $$
519 ifPprDebug implic_stuff)
521 implic_stuff | isImplicInst inst = ppr (tci_reft inst)
524 pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
526 tidyInst :: TidyEnv -> Inst -> Inst
527 tidyInst env lit@(LitInst {tci_ty = ty}) = lit {tci_ty = tidyType env ty}
528 tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
529 tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
530 tidyInst env implic@(ImplicInst {})
531 = implic { tci_tyvars = tvs'
532 , tci_given = map (tidyInst env') (tci_given implic)
533 , tci_wanted = map (tidyInst env') (tci_wanted implic) }
535 (env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic)
537 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
538 -- This function doesn't assume that the tyvars are in scope
539 -- so it works like tidyOpenType, returning a TidyEnv
540 tidyMoreInsts env insts
541 = (env', map (tidyInst env') insts)
543 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
545 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
546 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
548 showLIE :: SDoc -> TcM () -- Debugging
550 = do { lie_var <- getLIEVar ;
551 lie <- readMutVar lie_var ;
552 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
556 %************************************************************************
558 Extending the instance environment
560 %************************************************************************
563 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
564 -- Add new locally-defined instances
565 tcExtendLocalInstEnv dfuns thing_inside
566 = do { traceDFuns dfuns
568 ; inst_env' <- foldlM addLocalInst (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 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
574 -- Check that the proposed new instance is OK,
575 -- and then add it to the home inst env
576 addLocalInst home_ie ispec
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 tcInstSkolType because we don't want to allocate fresh
583 -- *meta* type variables.
584 let dfun = instanceDFunId ispec
585 ; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun)
586 ; let (cls, tys') = tcSplitDFunHead tau'
587 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
588 ispec' = setInstanceDFunId ispec dfun'
590 -- Load imported instances, so that we report
591 -- duplicates correctly
593 ; let inst_envs = (eps_inst_env eps, home_ie)
595 -- Check functional dependencies
596 ; case checkFunDeps inst_envs ispec' of
597 Just specs -> funDepErr ispec' specs
600 -- Check for duplicate instance decls
601 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
602 ; dup_ispecs = [ dup_ispec
603 | (_, dup_ispec) <- matches
604 , let (_,_,_,dup_tys) = instanceHead dup_ispec
605 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
606 -- Find memebers of the match list which ispec itself matches.
607 -- If the match is 2-way, it's a duplicate
609 dup_ispec : _ -> dupInstErr ispec' dup_ispec
612 -- OK, now extend the envt
613 ; return (extendInstEnv home_ie ispec') }
615 getOverlapFlag :: TcM OverlapFlag
617 = do { dflags <- getDOpts
618 ; let overlap_ok = dopt Opt_AllowOverlappingInstances dflags
619 incoherent_ok = dopt Opt_AllowIncoherentInstances dflags
620 overlap_flag | incoherent_ok = Incoherent
621 | overlap_ok = OverlapOk
622 | otherwise = NoOverlap
624 ; return overlap_flag }
627 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
629 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
630 -- Print the dfun name itself too
632 funDepErr ispec ispecs
634 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
635 2 (pprInstances (ispec:ispecs)))
636 dupInstErr ispec dup_ispec
638 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
639 2 (pprInstances [ispec, dup_ispec]))
641 addDictLoc ispec thing_inside
642 = setSrcSpan (mkSrcSpan loc loc) thing_inside
644 loc = getSrcLoc ispec
648 %************************************************************************
650 \subsection{Looking up Insts}
652 %************************************************************************
655 data LookupInstResult
657 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
659 lookupSimpleInst :: Inst -> TcM LookupInstResult
660 -- This is "simple" in tthat it returns NoInstance for implication constraints
662 -- It's important that lookupInst does not put any new stuff into
663 -- the LIE. Instead, any Insts needed by the lookup are returned in
664 -- the LookupInstResult, where they can be further processed by tcSimplify
666 --------------------- Implications ------------------------
667 lookupSimpleInst (ImplicInst {}) = return NoInstance
669 --------------------- Methods ------------------------
670 lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
671 = do { (dicts, dict_app) <- instCallDicts loc theta
672 ; let co_fn = dict_app <.> mkWpTyApps tys
673 ; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
675 span = instLocSpan loc
677 --------------------- Literals ------------------------
678 -- Look for short cuts first: if the literal is *definitely* a
679 -- int, integer, float or a double, generate the real thing here.
680 -- This is essential (see nofib/spectral/nucleic).
681 -- [Same shortcut as in newOverloadedLit, but we
682 -- may have done some unification by now]
684 lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name, tci_ty = ty, tci_loc = loc})
685 | Just expr <- shortCutIntLit i ty
686 = returnM (GenInst [] (noLoc expr))
688 = ASSERT( from_integer_name `isHsVar` fromIntegerName ) -- A LitInst invariant
689 tcLookupId fromIntegerName `thenM` \ from_integer ->
690 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
691 mkIntegerLit i `thenM` \ integer_lit ->
692 returnM (GenInst [method_inst]
693 (mkHsApp (L (instLocSpan loc)
694 (HsVar (instToId method_inst))) integer_lit))
696 lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name, tci_ty = ty, tci_loc = loc})
697 | Just expr <- shortCutFracLit f ty
698 = returnM (GenInst [] (noLoc expr))
701 = ASSERT( from_rat_name `isHsVar` fromRationalName ) -- A LitInst invariant
702 tcLookupId fromRationalName `thenM` \ from_rational ->
703 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
704 mkRatLit f `thenM` \ rat_lit ->
705 returnM (GenInst [method_inst] (mkHsApp (L (instLocSpan loc)
706 (HsVar (instToId method_inst))) rat_lit))
708 --------------------- Dictionaries ------------------------
709 lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
710 = do { mb_result <- lookupPred pred
711 ; case mb_result of {
712 Nothing -> return NoInstance ;
713 Just (tenv, dfun_id) -> do
715 -- tenv is a substitution that instantiates the dfun_id
716 -- to match the requested result type.
718 -- We ASSUME that the dfun is quantified over the very same tyvars
719 -- that are bound by the tenv.
722 -- might have some tyvars that *only* appear in arguments
723 -- dfun :: forall a b. C a b, Ord b => D [a]
724 -- We instantiate b to a flexi type variable -- it'll presumably
725 -- become fixed later via functional dependencies
726 { use_stage <- getStage
727 ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
728 (topIdLvl dfun_id) use_stage
730 -- It's possible that not all the tyvars are in
731 -- the substitution, tenv. For example:
732 -- instance C X a => D X where ...
733 -- (presumably there's a functional dependency in class C)
734 -- Hence the open_tvs to instantiate any un-substituted tyvars.
735 ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
736 open_tvs = filter (`notElemTvSubst` tenv) tyvars
737 ; open_tvs' <- mappM tcInstTyVar open_tvs
739 tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
740 -- Since the open_tvs' are freshly made, they cannot possibly be captured by
741 -- any nested for-alls in rho. So the in-scope set is unchanged
742 dfun_rho = substTy tenv' rho
743 (theta, _) = tcSplitPhiTy dfun_rho
744 src_loc = instLocSpan loc
746 tys = map (substTyVar tenv') tyvars
748 returnM (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
750 { (dicts, dict_app) <- instCallDicts loc theta
751 ; let co_fn = dict_app <.> mkWpTyApps tys
752 ; returnM (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
756 lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
757 -- Look up a class constraint in the instance environment
758 lookupPred pred@(ClassP clas tys)
760 ; tcg_env <- getGblEnv
761 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
762 ; case lookupInstEnv inst_envs clas tys of {
763 ([(tenv, ispec)], [])
764 -> do { let dfun_id = is_dfun ispec
765 ; traceTc (text "lookupInst success" <+>
766 vcat [text "dict" <+> ppr pred,
767 text "witness" <+> ppr dfun_id
768 <+> ppr (idType dfun_id) ])
769 -- Record that this dfun is needed
770 ; record_dfun_usage dfun_id
771 ; return (Just (tenv, dfun_id)) } ;
774 -> do { traceTc (text "lookupInst fail" <+>
775 vcat [text "dict" <+> ppr pred,
776 text "matches" <+> ppr matches,
777 text "unifs" <+> ppr unifs])
778 -- In the case of overlap (multiple matches) we report
779 -- NoInstance here. That has the effect of making the
780 -- context-simplifier return the dict as an irreducible one.
781 -- Then it'll be given to addNoInstanceErrs, which will do another
782 -- lookupInstEnv to get the detailed info about what went wrong.
786 lookupPred ip_pred = return Nothing -- Implicit parameters
788 record_dfun_usage dfun_id
789 = do { hsc_env <- getTopEnv
790 ; let dfun_name = idName dfun_id
791 dfun_mod = nameModule dfun_name
792 ; if isInternalName dfun_name || -- Internal name => defined in this module
793 modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
794 then return () -- internal, or in another package
795 else do { tcg_env <- getGblEnv
796 ; updMutVar (tcg_inst_uses tcg_env)
797 (`addOneToNameSet` idName dfun_id) }}
800 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
801 -- Gets both the external-package inst-env
802 -- and the home-pkg inst env (includes module being compiled)
803 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
804 return (eps_inst_env eps, tcg_inst_env env) }
809 %************************************************************************
813 %************************************************************************
815 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
816 a do-expression. We have to find (>>) in the current environment, which is
817 done by the rename. Then we have to check that it has the same type as
818 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
821 (>>) :: HB m n mn => m a -> n b -> mn b
823 So the idea is to generate a local binding for (>>), thus:
825 let then72 :: forall a b. m a -> m b -> m b
826 then72 = ...something involving the user's (>>)...
828 ...the do-expression...
830 Now the do-expression can proceed using then72, which has exactly
833 In fact tcSyntaxName just generates the RHS for then72, because we only
834 want an actual binding in the do-expression case. For literals, we can
835 just use the expression inline.
838 tcSyntaxName :: InstOrigin
839 -> TcType -- Type to instantiate it at
840 -> (Name, HsExpr Name) -- (Standard name, user name)
841 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
842 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
843 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
844 -- So we do not call it from lookupInst, which is called from tcSimplify
846 tcSyntaxName orig ty (std_nm, HsVar user_nm)
848 = newMethodFromName orig ty std_nm `thenM` \ id ->
849 returnM (std_nm, HsVar id)
851 tcSyntaxName orig ty (std_nm, user_nm_expr)
852 = tcLookupId std_nm `thenM` \ std_id ->
854 -- C.f. newMethodAtLoc
855 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
856 sigma1 = substTyWith [tv] [ty] tau
857 -- Actually, the "tau-type" might be a sigma-type in the
858 -- case of locally-polymorphic methods.
860 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $
862 -- Check that the user-supplied thing has the
863 -- same type as the standard one.
864 -- Tiresome jiggling because tcCheckSigma takes a located expression
865 getSrcSpanM `thenM` \ span ->
866 tcPolyExpr (L span user_nm_expr) sigma1 `thenM` \ expr ->
867 returnM (std_nm, unLoc expr)
869 syntaxNameCtxt name orig ty tidy_env
870 = getInstLoc orig `thenM` \ inst_loc ->
872 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
873 ptext SLIT("(needed by a syntactic construct)"),
874 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
875 nest 2 (ptext SLIT("arising from") <+> pprInstLoc inst_loc)]
877 returnM (tidy_env, msg)