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, shortCutStringLit, newIPDict,
21 newMethod, newMethodFromName, newMethodWithGivenTy,
23 tcSyntaxName, isHsVar,
25 tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
26 ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
27 getDictClassTys, dictPred,
29 lookupSimpleInst, LookupInstResult(..),
30 tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
32 isDict, isClassDict, isMethod, isImplicInst,
33 isIPDict, isInheritableInst, isMethodOrLit,
34 isTyVarDict, isMethodFor,
37 instToId, instToVar, instName,
39 InstOrigin(..), InstLoc, pprInstLoc
42 #include "HsVersions.h"
44 import {-# SOURCE #-} TcExpr( tcPolyExpr )
45 import {-# SOURCE #-} TcUnify( unifyType )
47 import FastString(FastString)
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 %************************************************************************
216 \subsection{Building dictionaries}
218 %************************************************************************
220 -- newDictBndrs makes a dictionary at a binding site
221 -- instCall makes a dictionary at an occurrence site
222 -- and throws it into the LIE
226 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
227 newDictBndrsO orig theta = do { loc <- getInstLoc orig
228 ; newDictBndrs loc theta }
230 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
231 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
233 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
234 newDictBndr inst_loc pred
235 = do { uniq <- newUnique
236 ; let name = mkPredName uniq inst_loc pred
237 ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
240 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
241 -- Instantiate the constraints of a call
242 -- (instCall o tys theta)
243 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
244 -- (b) Throws these dictionaries into the LIE
245 -- (c) Eeturns an HsWrapper ([.] tys dicts)
247 instCall orig tys theta
248 = do { loc <- getInstLoc orig
249 ; (dicts, dict_app) <- instCallDicts loc theta
251 ; return (dict_app <.> mkWpTyApps tys) }
254 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
255 -- Similar to instCall, but only emit the constraints in the LIE
256 -- Used exclusively for the 'stupid theta' of a data constructor
257 instStupidTheta orig theta
258 = do { loc <- getInstLoc orig
259 ; (dicts, _) <- instCallDicts loc theta
263 instCallDicts :: InstLoc -> TcThetaType -> TcM ([Inst], HsWrapper)
264 -- This is the key place where equality predicates
265 -- are unleashed into the world
266 instCallDicts loc [] = return ([], idHsWrapper)
268 instCallDicts loc (EqPred ty1 ty2 : preds)
269 = do { unifyType ty1 ty2 -- For now, we insist that they unify right away
270 -- Later on, when we do associated types,
271 -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
272 ; (dicts, co_fn) <- instCallDicts loc preds
273 ; return (dicts, co_fn <.> WpTyApp ty1) }
274 -- We use type application to apply the function to the
275 -- coercion; here ty1 *is* the appropriate identity coercion
277 instCallDicts loc (pred : preds)
278 = do { uniq <- newUnique
279 ; let name = mkPredName uniq loc pred
280 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
281 ; (dicts, co_fn) <- instCallDicts loc preds
282 ; return (dict:dicts, co_fn <.> WpApp (instToId dict)) }
285 cloneDict :: Inst -> TcM Inst
286 cloneDict dict@(Dict nm ty loc) = do { uniq <- newUnique
287 ; return (dict {tci_name = setNameUnique nm uniq}) }
288 cloneDict other = pprPanic "cloneDict" (ppr other)
290 -- For vanilla implicit parameters, there is only one in scope
291 -- at any time, so we used to use the name of the implicit parameter itself
292 -- But with splittable implicit parameters there may be many in
293 -- scope, so we make up a new namea.
294 newIPDict :: InstOrigin -> IPName Name -> Type
295 -> TcM (IPName Id, Inst)
296 newIPDict orig ip_name ty
297 = getInstLoc orig `thenM` \ inst_loc ->
298 newUnique `thenM` \ uniq ->
300 pred = IParam ip_name ty
301 name = mkPredName uniq inst_loc pred
302 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}
304 returnM (mapIPName (\n -> instToId dict) ip_name, dict)
309 mkPredName :: Unique -> InstLoc -> PredType -> Name
310 mkPredName uniq loc pred_ty
311 = mkInternalName uniq occ (instLocSpan loc)
313 occ = case pred_ty of
314 ClassP cls _ -> mkDictOcc (getOccName cls)
315 IParam ip _ -> getOccName (ipNameName ip)
316 EqPred ty _ -> mkEqPredCoOcc baseOcc
318 -- we use the outermost tycon of the lhs, if there is one, to
319 -- improve readability of Core code
320 baseOcc = case splitTyConApp_maybe ty of
321 Nothing -> mkOccName tcName "$"
322 Just (tc, _) -> getOccName tc
325 %************************************************************************
327 \subsection{Building methods (calls of overloaded functions)}
329 %************************************************************************
333 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
334 newMethodFromName origin ty name
335 = tcLookupId name `thenM` \ id ->
336 -- Use tcLookupId not tcLookupGlobalId; the method is almost
337 -- always a class op, but with -fno-implicit-prelude GHC is
338 -- meant to find whatever thing is in scope, and that may
339 -- be an ordinary function.
340 getInstLoc origin `thenM` \ loc ->
341 tcInstClassOp loc id [ty] `thenM` \ inst ->
342 extendLIE inst `thenM_`
343 returnM (instToId inst)
345 newMethodWithGivenTy orig id tys
346 = getInstLoc orig `thenM` \ loc ->
347 newMethod loc id tys `thenM` \ inst ->
348 extendLIE inst `thenM_`
349 returnM (instToId inst)
351 --------------------------------------------
352 -- tcInstClassOp, and newMethod do *not* drop the
353 -- Inst into the LIE; they just returns the Inst
354 -- This is important because they are used by TcSimplify
357 -- NB: the kind of the type variable to be instantiated
358 -- might be a sub-kind of the type to which it is applied,
359 -- notably when the latter is a type variable of kind ??
360 -- Hence the call to checkKind
361 -- A worry: is this needed anywhere else?
362 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
363 tcInstClassOp inst_loc sel_id tys
365 (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
367 zipWithM_ checkKind tyvars tys `thenM_`
368 newMethod inst_loc sel_id tys
370 checkKind :: TyVar -> TcType -> TcM ()
371 -- Ensure that the type has a sub-kind of the tyvar
374 -- ty1 <- zonkTcType ty
375 ; if typeKind ty1 `isSubKind` Var.tyVarKind tv
379 pprPanic "checkKind: adding kind constraint"
380 (vcat [ppr tv <+> ppr (Var.tyVarKind tv),
381 ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
383 -- do { tv1 <- tcInstTyVar tv
384 -- ; unifyType ty1 (mkTyVarTy tv1) } }
387 ---------------------------
388 newMethod inst_loc id tys
389 = newUnique `thenM` \ new_uniq ->
391 (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
392 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
393 inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
394 tci_theta = theta, tci_loc = inst_loc}
395 loc = instLocSpan inst_loc
401 shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
403 | isIntTy ty && inIntRange i -- Short cut for Int
404 = Just (HsLit (HsInt i))
405 | isIntegerTy ty -- Short cut for Integer
406 = Just (HsLit (HsInteger i ty))
407 | otherwise = Nothing
409 shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
412 = Just (mk_lit floatDataCon (HsFloatPrim f))
414 = Just (mk_lit doubleDataCon (HsDoublePrim f))
415 | otherwise = Nothing
417 mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
419 shortCutStringLit :: FastString -> TcType -> Maybe (HsExpr TcId)
420 shortCutStringLit s ty
421 | isStringTy ty -- Short cut for String
422 = Just (HsLit (HsString s))
423 | otherwise = Nothing
425 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
427 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
428 getSrcSpanM `thenM` \ span ->
429 returnM (L span $ HsLit (HsInteger i integer_ty))
431 mkRatLit :: Rational -> TcM (LHsExpr TcId)
433 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
434 getSrcSpanM `thenM` \ span ->
435 returnM (L span $ HsLit (HsRat r rat_ty))
437 mkStrLit :: FastString -> TcM (LHsExpr TcId)
439 = --tcMetaTy stringTyConName `thenM` \ string_ty ->
440 getSrcSpanM `thenM` \ span ->
441 returnM (L span $ HsLit (HsString s))
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 --------------------- Implications ------------------------
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 lookupSimpleInst (LitInst {tci_lit = HsIsString s from_string_name, tci_ty = ty, tci_loc = loc})
711 | Just expr <- shortCutStringLit s ty
712 = returnM (GenInst [] (noLoc expr))
714 = ASSERT( from_string_name `isHsVar` fromStringName ) -- A LitInst invariant
715 tcLookupId fromStringName `thenM` \ from_string ->
716 tcInstClassOp loc from_string [ty] `thenM` \ method_inst ->
717 mkStrLit s `thenM` \ string_lit ->
718 returnM (GenInst [method_inst]
719 (mkHsApp (L (instLocSpan loc)
720 (HsVar (instToId method_inst))) string_lit))
722 --------------------- Dictionaries ------------------------
723 lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
724 = do { mb_result <- lookupPred pred
725 ; case mb_result of {
726 Nothing -> return NoInstance ;
727 Just (dfun_id, mb_inst_tys) -> do
729 { use_stage <- getStage
730 ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
731 (topIdLvl dfun_id) use_stage
733 -- It's possible that not all the tyvars are in
734 -- the substitution, tenv. For example:
735 -- instance C X a => D X where ...
736 -- (presumably there's a functional dependency in class C)
737 -- Hence mb_inst_tys :: Either TyVar TcType
739 ; let inst_tv (Left tv) = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
740 inst_tv (Right ty) = return ty
741 ; tys <- mappM inst_tv mb_inst_tys
743 (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
744 src_loc = instLocSpan loc
747 returnM (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
749 { (dicts, dict_app) <- instCallDicts loc theta
750 ; let co_fn = dict_app <.> mkWpTyApps tys
751 ; returnM (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
755 lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
756 -- Look up a class constraint in the instance environment
757 lookupPred pred@(ClassP clas tys)
759 ; tcg_env <- getGblEnv
760 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
761 ; case lookupInstEnv inst_envs clas tys of {
762 ([(ispec, inst_tys)], [])
763 -> do { let dfun_id = is_dfun ispec
764 ; traceTc (text "lookupInst success" <+>
765 vcat [text "dict" <+> ppr pred,
766 text "witness" <+> ppr dfun_id
767 <+> ppr (idType dfun_id) ])
768 -- Record that this dfun is needed
769 ; record_dfun_usage dfun_id
770 ; return (Just (dfun_id, inst_tys)) } ;
773 -> do { traceTc (text "lookupInst fail" <+>
774 vcat [text "dict" <+> ppr pred,
775 text "matches" <+> ppr matches,
776 text "unifs" <+> ppr unifs])
777 -- In the case of overlap (multiple matches) we report
778 -- NoInstance here. That has the effect of making the
779 -- context-simplifier return the dict as an irreducible one.
780 -- Then it'll be given to addNoInstanceErrs, which will do another
781 -- lookupInstEnv to get the detailed info about what went wrong.
785 lookupPred ip_pred = return Nothing -- Implicit parameters
787 record_dfun_usage dfun_id
788 = do { hsc_env <- getTopEnv
789 ; let dfun_name = idName dfun_id
790 dfun_mod = nameModule dfun_name
791 ; if isInternalName dfun_name || -- Internal name => defined in this module
792 modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
793 then return () -- internal, or in another package
794 else do { tcg_env <- getGblEnv
795 ; updMutVar (tcg_inst_uses tcg_env)
796 (`addOneToNameSet` idName dfun_id) }}
799 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
800 -- Gets both the external-package inst-env
801 -- and the home-pkg inst env (includes module being compiled)
802 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
803 return (eps_inst_env eps, tcg_inst_env env) }
808 %************************************************************************
812 %************************************************************************
814 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
815 a do-expression. We have to find (>>) in the current environment, which is
816 done by the rename. Then we have to check that it has the same type as
817 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
820 (>>) :: HB m n mn => m a -> n b -> mn b
822 So the idea is to generate a local binding for (>>), thus:
824 let then72 :: forall a b. m a -> m b -> m b
825 then72 = ...something involving the user's (>>)...
827 ...the do-expression...
829 Now the do-expression can proceed using then72, which has exactly
832 In fact tcSyntaxName just generates the RHS for then72, because we only
833 want an actual binding in the do-expression case. For literals, we can
834 just use the expression inline.
837 tcSyntaxName :: InstOrigin
838 -> TcType -- Type to instantiate it at
839 -> (Name, HsExpr Name) -- (Standard name, user name)
840 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
841 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
842 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
843 -- So we do not call it from lookupInst, which is called from tcSimplify
845 tcSyntaxName orig ty (std_nm, HsVar user_nm)
847 = newMethodFromName orig ty std_nm `thenM` \ id ->
848 returnM (std_nm, HsVar id)
850 tcSyntaxName orig ty (std_nm, user_nm_expr)
851 = tcLookupId std_nm `thenM` \ std_id ->
853 -- C.f. newMethodAtLoc
854 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
855 sigma1 = substTyWith [tv] [ty] tau
856 -- Actually, the "tau-type" might be a sigma-type in the
857 -- case of locally-polymorphic methods.
859 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $
861 -- Check that the user-supplied thing has the
862 -- same type as the standard one.
863 -- Tiresome jiggling because tcCheckSigma takes a located expression
864 getSrcSpanM `thenM` \ span ->
865 tcPolyExpr (L span user_nm_expr) sigma1 `thenM` \ expr ->
866 returnM (std_nm, unLoc expr)
868 syntaxNameCtxt name orig ty tidy_env
869 = getInstLoc orig `thenM` \ inst_loc ->
871 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
872 ptext SLIT("(needed by a syntactic construct)"),
873 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
874 nest 2 (ptext SLIT("arising from") <+> pprInstLoc inst_loc)]
876 returnM (tidy_env, msg)