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 )
87 instName :: Inst -> Name
88 instName inst = Var.varName (instToVar inst)
90 instToId :: Inst -> TcId
91 instToId inst = ASSERT2( isId id, ppr inst ) id
95 instToVar :: Inst -> Var
96 instToVar (LitInst {tci_name = nm, tci_ty = ty})
98 instToVar (Method {tci_id = id})
100 instToVar (Dict {tci_name = nm, tci_pred = pred})
101 | isEqPred pred = Var.mkCoVar nm (mkPredTy pred)
102 | otherwise = mkLocalId nm (mkPredTy pred)
103 instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens,
104 tci_wanted = wanteds})
105 = mkLocalId nm (mkImplicTy tvs givens wanteds)
107 instType :: Inst -> Type
108 instType (LitInst {tci_ty = ty}) = ty
109 instType (Method {tci_id = id}) = idType id
110 instType (Dict {tci_pred = pred}) = mkPredTy pred
111 instType imp@(ImplicInst {}) = mkImplicTy (tci_tyvars imp) (tci_given imp)
114 mkImplicTy tvs givens wanteds -- The type of an implication constraint
115 = ASSERT( all isDict givens )
116 -- pprTrace "mkImplicTy" (ppr givens) $
118 mkPhiTy (map dictPred givens) $
119 if isSingleton wanteds then
120 instType (head wanteds)
122 mkTupleTy Boxed (length wanteds) (map instType wanteds)
124 dictPred (Dict {tci_pred = pred}) = pred
125 dictPred inst = pprPanic "dictPred" (ppr inst)
127 getDictClassTys (Dict {tci_pred = pred}) = getClassPredTys pred
128 getDictClassTys inst = pprPanic "getDictClassTys" (ppr inst)
130 -- fdPredsOfInst is used to get predicates that contain functional
131 -- dependencies *or* might do so. The "might do" part is because
132 -- a constraint (C a b) might have a superclass with FDs
133 -- Leaving these in is really important for the call to fdPredsOfInsts
134 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
135 -- which is supposed to be conservative
136 fdPredsOfInst (Dict {tci_pred = pred}) = [pred]
137 fdPredsOfInst (Method {tci_theta = theta}) = theta
138 fdPredsOfInst (ImplicInst {tci_given = gs,
139 tci_wanted = ws}) = fdPredsOfInsts (gs ++ ws)
140 fdPredsOfInst (LitInst {}) = []
142 fdPredsOfInsts :: [Inst] -> [PredType]
143 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
145 isInheritableInst (Dict {tci_pred = pred}) = isInheritablePred pred
146 isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta
147 isInheritableInst other = True
150 ---------------------------------
151 -- Get the implicit parameters mentioned by these Insts
152 -- NB: the results of these functions are insensitive to zonking
154 ipNamesOfInsts :: [Inst] -> [Name]
155 ipNamesOfInst :: Inst -> [Name]
156 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
158 ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
159 ipNamesOfInst (Method {tci_theta = theta}) = [ipNameName n | IParam n _ <- theta]
160 ipNamesOfInst other = []
162 ---------------------------------
163 tyVarsOfInst :: Inst -> TcTyVarSet
164 tyVarsOfInst (LitInst {tci_ty = ty}) = tyVarsOfType ty
165 tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
166 tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id
167 -- The id might have free type variables; in the case of
168 -- locally-overloaded class methods, for example
169 tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds})
170 = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds)
171 `minusVarSet` mkVarSet tvs
172 `unionVarSet` unionVarSets (map varTypeTyVars tvs)
173 -- Remember the free tyvars of a coercion
175 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
176 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
182 isDict :: Inst -> Bool
183 isDict (Dict {}) = True
186 isClassDict :: Inst -> Bool
187 isClassDict (Dict {tci_pred = pred}) = isClassPred pred
188 isClassDict other = False
190 isTyVarDict :: Inst -> Bool
191 isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
192 isTyVarDict other = False
194 isIPDict :: Inst -> Bool
195 isIPDict (Dict {tci_pred = pred}) = isIPPred pred
196 isIPDict other = False
198 isImplicInst (ImplicInst {}) = True
199 isImplicInst other = False
201 isMethod :: Inst -> Bool
202 isMethod (Method {}) = True
203 isMethod other = False
205 isMethodFor :: TcIdSet -> Inst -> Bool
206 isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
207 isMethodFor ids inst = False
209 isMethodOrLit :: Inst -> Bool
210 isMethodOrLit (Method {}) = True
211 isMethodOrLit (LitInst {}) = True
212 isMethodOrLit other = False
216 %************************************************************************
218 \subsection{Building dictionaries}
220 %************************************************************************
222 -- newDictBndrs makes a dictionary at a binding site
223 -- instCall makes a dictionary at an occurrence site
224 -- and throws it into the LIE
228 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
229 newDictBndrsO orig theta = do { loc <- getInstLoc orig
230 ; newDictBndrs loc theta }
232 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
233 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
235 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
236 newDictBndr inst_loc pred
237 = do { uniq <- newUnique
238 ; let name = mkPredName uniq inst_loc pred
239 ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
242 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
243 -- Instantiate the constraints of a call
244 -- (instCall o tys theta)
245 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
246 -- (b) Throws these dictionaries into the LIE
247 -- (c) Eeturns an HsWrapper ([.] tys dicts)
249 instCall orig tys theta
250 = do { loc <- getInstLoc orig
251 ; (dicts, dict_app) <- instCallDicts loc theta
253 ; return (dict_app <.> mkWpTyApps tys) }
256 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
257 -- Similar to instCall, but only emit the constraints in the LIE
258 -- Used exclusively for the 'stupid theta' of a data constructor
259 instStupidTheta orig theta
260 = do { loc <- getInstLoc orig
261 ; (dicts, _) <- instCallDicts loc theta
265 instCallDicts :: InstLoc -> TcThetaType -> TcM ([Inst], HsWrapper)
266 -- This is the key place where equality predicates
267 -- are unleashed into the world
268 instCallDicts loc [] = return ([], idHsWrapper)
270 instCallDicts loc (EqPred ty1 ty2 : preds)
271 = do { unifyType ty1 ty2 -- For now, we insist that they unify right away
272 -- Later on, when we do associated types,
273 -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
274 ; (dicts, co_fn) <- instCallDicts loc preds
275 ; return (dicts, co_fn <.> WpTyApp ty1) }
276 -- We use type application to apply the function to the
277 -- coercion; here ty1 *is* the appropriate identity coercion
279 instCallDicts loc (pred : preds)
280 = do { uniq <- newUnique
281 ; let name = mkPredName uniq loc pred
282 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
283 ; (dicts, co_fn) <- instCallDicts loc preds
284 ; return (dict:dicts, co_fn <.> WpApp (instToId dict)) }
287 cloneDict :: Inst -> TcM Inst
288 cloneDict dict@(Dict nm ty loc) = do { uniq <- newUnique
289 ; return (dict {tci_name = setNameUnique nm uniq}) }
290 cloneDict other = pprPanic "cloneDict" (ppr other)
292 -- For vanilla implicit parameters, there is only one in scope
293 -- at any time, so we used to use the name of the implicit parameter itself
294 -- But with splittable implicit parameters there may be many in
295 -- scope, so we make up a new namea.
296 newIPDict :: InstOrigin -> IPName Name -> Type
297 -> TcM (IPName Id, Inst)
298 newIPDict orig ip_name ty
299 = getInstLoc orig `thenM` \ inst_loc ->
300 newUnique `thenM` \ uniq ->
302 pred = IParam ip_name ty
303 name = mkPredName uniq inst_loc pred
304 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}
306 returnM (mapIPName (\n -> instToId dict) ip_name, dict)
311 mkPredName :: Unique -> InstLoc -> PredType -> Name
312 mkPredName uniq loc pred_ty
313 = mkInternalName uniq occ (instLocSpan loc)
315 occ = case pred_ty of
316 ClassP cls _ -> mkDictOcc (getOccName cls)
317 IParam ip _ -> getOccName (ipNameName ip)
318 EqPred ty _ -> mkEqPredCoOcc baseOcc
320 -- we use the outermost tycon of the lhs, if there is one, to
321 -- improve readability of Core code
322 baseOcc = case splitTyConApp_maybe ty of
323 Nothing -> mkOccName tcName "$"
324 Just (tc, _) -> getOccName tc
327 %************************************************************************
329 \subsection{Building methods (calls of overloaded functions)}
331 %************************************************************************
335 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
336 newMethodFromName origin ty name
337 = tcLookupId name `thenM` \ id ->
338 -- Use tcLookupId not tcLookupGlobalId; the method is almost
339 -- always a class op, but with -fno-implicit-prelude GHC is
340 -- meant to find whatever thing is in scope, and that may
341 -- be an ordinary function.
342 getInstLoc origin `thenM` \ loc ->
343 tcInstClassOp loc id [ty] `thenM` \ inst ->
344 extendLIE inst `thenM_`
345 returnM (instToId inst)
347 newMethodWithGivenTy orig id tys
348 = getInstLoc orig `thenM` \ loc ->
349 newMethod loc id tys `thenM` \ inst ->
350 extendLIE inst `thenM_`
351 returnM (instToId inst)
353 --------------------------------------------
354 -- tcInstClassOp, and newMethod do *not* drop the
355 -- Inst into the LIE; they just returns the Inst
356 -- This is important because they are used by TcSimplify
359 -- NB: the kind of the type variable to be instantiated
360 -- might be a sub-kind of the type to which it is applied,
361 -- notably when the latter is a type variable of kind ??
362 -- Hence the call to checkKind
363 -- A worry: is this needed anywhere else?
364 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
365 tcInstClassOp inst_loc sel_id tys
367 (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
369 zipWithM_ checkKind tyvars tys `thenM_`
370 newMethod inst_loc sel_id tys
372 checkKind :: TyVar -> TcType -> TcM ()
373 -- Ensure that the type has a sub-kind of the tyvar
376 -- ty1 <- zonkTcType ty
377 ; if typeKind ty1 `isSubKind` Var.tyVarKind tv
381 pprPanic "checkKind: adding kind constraint"
382 (vcat [ppr tv <+> ppr (Var.tyVarKind tv),
383 ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
385 -- do { tv1 <- tcInstTyVar tv
386 -- ; unifyType ty1 (mkTyVarTy tv1) } }
389 ---------------------------
390 newMethod inst_loc id tys
391 = newUnique `thenM` \ new_uniq ->
393 (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
394 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
395 inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
396 tci_theta = theta, tci_loc = inst_loc}
397 loc = instLocSpan inst_loc
403 shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
405 | isIntTy ty && inIntRange i -- Short cut for Int
406 = Just (HsLit (HsInt i))
407 | isIntegerTy ty -- Short cut for Integer
408 = Just (HsLit (HsInteger i ty))
409 | otherwise = Nothing
411 shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
414 = Just (mk_lit floatDataCon (HsFloatPrim f))
416 = Just (mk_lit doubleDataCon (HsDoublePrim f))
417 | otherwise = Nothing
419 mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
421 shortCutStringLit :: FastString -> TcType -> Maybe (HsExpr TcId)
422 shortCutStringLit s ty
423 | isStringTy ty -- Short cut for String
424 = Just (HsLit (HsString s))
425 | otherwise = Nothing
427 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
429 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
430 getSrcSpanM `thenM` \ span ->
431 returnM (L span $ HsLit (HsInteger i integer_ty))
433 mkRatLit :: Rational -> TcM (LHsExpr TcId)
435 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
436 getSrcSpanM `thenM` \ span ->
437 returnM (L span $ HsLit (HsRat r rat_ty))
439 mkStrLit :: FastString -> TcM (LHsExpr TcId)
441 = --tcMetaTy stringTyConName `thenM` \ string_ty ->
442 getSrcSpanM `thenM` \ span ->
443 returnM (L span $ HsLit (HsString s))
445 isHsVar :: HsExpr Name -> Name -> Bool
446 isHsVar (HsVar f) g = f==g
447 isHsVar other g = False
451 %************************************************************************
455 %************************************************************************
457 Zonking makes sure that the instance types are fully zonked.
460 zonkInst :: Inst -> TcM Inst
461 zonkInst dict@(Dict { tci_pred = pred})
462 = zonkTcPredType pred `thenM` \ new_pred ->
463 returnM (dict {tci_pred = new_pred})
465 zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta})
466 = zonkId id `thenM` \ new_id ->
467 -- Essential to zonk the id in case it's a local variable
468 -- Can't use zonkIdOcc because the id might itself be
469 -- an InstId, in which case it won't be in scope
471 zonkTcTypes tys `thenM` \ new_tys ->
472 zonkTcThetaType theta `thenM` \ new_theta ->
473 returnM (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
474 -- No need to zonk the tci_id
476 zonkInst lit@(LitInst {tci_ty = ty})
477 = zonkTcType ty `thenM` \ new_ty ->
478 returnM (lit {tci_ty = new_ty})
480 zonkInst implic@(ImplicInst {})
481 = ASSERT( all isImmutableTyVar (tci_tyvars implic) )
482 do { givens' <- zonkInsts (tci_given implic)
483 ; wanteds' <- zonkInsts (tci_wanted implic)
484 ; return (implic {tci_given = givens',tci_wanted = wanteds'}) }
486 zonkInsts insts = mappM zonkInst insts
490 %************************************************************************
492 \subsection{Printing}
494 %************************************************************************
496 ToDo: improve these pretty-printing things. The ``origin'' is really only
497 relevant in error messages.
500 instance Outputable Inst where
501 ppr inst = pprInst inst
503 pprDictsTheta :: [Inst] -> SDoc
504 -- Print in type-like fashion (Eq a, Show b)
505 -- The Inst can be an implication constraint, but not a Method or LitInst
506 pprDictsTheta insts = parens (sep (punctuate comma (map (ppr . instType) insts)))
508 pprDictsInFull :: [Inst] -> SDoc
509 -- Print in type-like fashion, but with source location
511 = vcat (map go dicts)
513 go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
515 pprInsts :: [Inst] -> SDoc
516 -- Debugging: print the evidence :: type
517 pprInsts insts = brackets (interpp'SP insts)
519 pprInst, pprInstInFull :: Inst -> SDoc
520 -- Debugging: print the evidence :: type
521 pprInst inst = ppr (instName inst) <+> dcolon
522 <+> (braces (ppr (instType inst)) $$
523 ifPprDebug implic_stuff)
525 implic_stuff | isImplicInst inst = ppr (tci_reft inst)
528 pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
530 tidyInst :: TidyEnv -> Inst -> Inst
531 tidyInst env lit@(LitInst {tci_ty = ty}) = lit {tci_ty = tidyType env ty}
532 tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
533 tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
534 tidyInst env implic@(ImplicInst {})
535 = implic { tci_tyvars = tvs'
536 , tci_given = map (tidyInst env') (tci_given implic)
537 , tci_wanted = map (tidyInst env') (tci_wanted implic) }
539 (env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic)
541 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
542 -- This function doesn't assume that the tyvars are in scope
543 -- so it works like tidyOpenType, returning a TidyEnv
544 tidyMoreInsts env insts
545 = (env', map (tidyInst env') insts)
547 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
549 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
550 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
552 showLIE :: SDoc -> TcM () -- Debugging
554 = do { lie_var <- getLIEVar ;
555 lie <- readMutVar lie_var ;
556 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
560 %************************************************************************
562 Extending the instance environment
564 %************************************************************************
567 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
568 -- Add new locally-defined instances
569 tcExtendLocalInstEnv dfuns thing_inside
570 = do { traceDFuns dfuns
572 ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
573 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
574 tcg_inst_env = inst_env' }
575 ; setGblEnv env' thing_inside }
577 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
578 -- Check that the proposed new instance is OK,
579 -- and then add it to the home inst env
580 addLocalInst home_ie ispec
581 = do { -- Instantiate the dfun type so that we extend the instance
582 -- envt with completely fresh template variables
583 -- This is important because the template variables must
584 -- not overlap with anything in the things being looked up
585 -- (since we do unification).
586 -- We use tcInstSkolType because we don't want to allocate fresh
587 -- *meta* type variables.
588 let dfun = instanceDFunId ispec
589 ; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun)
590 ; let (cls, tys') = tcSplitDFunHead tau'
591 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
592 ispec' = setInstanceDFunId ispec dfun'
594 -- Load imported instances, so that we report
595 -- duplicates correctly
597 ; let inst_envs = (eps_inst_env eps, home_ie)
599 -- Check functional dependencies
600 ; case checkFunDeps inst_envs ispec' of
601 Just specs -> funDepErr ispec' specs
604 -- Check for duplicate instance decls
605 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
606 ; dup_ispecs = [ dup_ispec
607 | (dup_ispec, _) <- matches
608 , let (_,_,_,dup_tys) = instanceHead dup_ispec
609 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
610 -- Find memebers of the match list which ispec itself matches.
611 -- If the match is 2-way, it's a duplicate
613 dup_ispec : _ -> dupInstErr ispec' dup_ispec
616 -- OK, now extend the envt
617 ; return (extendInstEnv home_ie ispec') }
619 getOverlapFlag :: TcM OverlapFlag
621 = do { dflags <- getDOpts
622 ; let overlap_ok = dopt Opt_AllowOverlappingInstances dflags
623 incoherent_ok = dopt Opt_AllowIncoherentInstances dflags
624 overlap_flag | incoherent_ok = Incoherent
625 | overlap_ok = OverlapOk
626 | otherwise = NoOverlap
628 ; return overlap_flag }
631 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
633 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
634 -- Print the dfun name itself too
636 funDepErr ispec ispecs
638 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
639 2 (pprInstances (ispec:ispecs)))
640 dupInstErr ispec dup_ispec
642 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
643 2 (pprInstances [ispec, dup_ispec]))
645 addDictLoc ispec thing_inside
646 = setSrcSpan (mkSrcSpan loc loc) thing_inside
648 loc = getSrcLoc ispec
652 %************************************************************************
654 \subsection{Looking up Insts}
656 %************************************************************************
659 data LookupInstResult
661 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
663 lookupSimpleInst :: Inst -> TcM LookupInstResult
664 -- This is "simple" in tthat it returns NoInstance for implication constraints
666 -- It's important that lookupInst does not put any new stuff into
667 -- the LIE. Instead, any Insts needed by the lookup are returned in
668 -- the LookupInstResult, where they can be further processed by tcSimplify
670 --------------------- Implications ------------------------
671 lookupSimpleInst (ImplicInst {}) = return NoInstance
673 --------------------- Methods ------------------------
674 lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
675 = do { (dicts, dict_app) <- instCallDicts loc theta
676 ; let co_fn = dict_app <.> mkWpTyApps tys
677 ; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
679 span = instLocSpan loc
681 --------------------- Literals ------------------------
682 -- Look for short cuts first: if the literal is *definitely* a
683 -- int, integer, float or a double, generate the real thing here.
684 -- This is essential (see nofib/spectral/nucleic).
685 -- [Same shortcut as in newOverloadedLit, but we
686 -- may have done some unification by now]
688 lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name, tci_ty = ty, tci_loc = loc})
689 | Just expr <- shortCutIntLit i ty
690 = returnM (GenInst [] (noLoc expr))
692 = ASSERT( from_integer_name `isHsVar` fromIntegerName ) -- A LitInst invariant
693 tcLookupId fromIntegerName `thenM` \ from_integer ->
694 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
695 mkIntegerLit i `thenM` \ integer_lit ->
696 returnM (GenInst [method_inst]
697 (mkHsApp (L (instLocSpan loc)
698 (HsVar (instToId method_inst))) integer_lit))
700 lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name, tci_ty = ty, tci_loc = loc})
701 | Just expr <- shortCutFracLit f ty
702 = returnM (GenInst [] (noLoc expr))
705 = ASSERT( from_rat_name `isHsVar` fromRationalName ) -- A LitInst invariant
706 tcLookupId fromRationalName `thenM` \ from_rational ->
707 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
708 mkRatLit f `thenM` \ rat_lit ->
709 returnM (GenInst [method_inst] (mkHsApp (L (instLocSpan loc)
710 (HsVar (instToId method_inst))) rat_lit))
712 lookupSimpleInst (LitInst {tci_lit = HsIsString s from_string_name, tci_ty = ty, tci_loc = loc})
713 | Just expr <- shortCutStringLit s ty
714 = returnM (GenInst [] (noLoc expr))
716 = ASSERT( from_string_name `isHsVar` fromStringName ) -- A LitInst invariant
717 tcLookupId fromStringName `thenM` \ from_string ->
718 tcInstClassOp loc from_string [ty] `thenM` \ method_inst ->
719 mkStrLit s `thenM` \ string_lit ->
720 returnM (GenInst [method_inst]
721 (mkHsApp (L (instLocSpan loc)
722 (HsVar (instToId method_inst))) string_lit))
724 --------------------- Dictionaries ------------------------
725 lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
726 = do { mb_result <- lookupPred pred
727 ; case mb_result of {
728 Nothing -> return NoInstance ;
729 Just (dfun_id, mb_inst_tys) -> do
731 { use_stage <- getStage
732 ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
733 (topIdLvl dfun_id) use_stage
735 -- It's possible that not all the tyvars are in
736 -- the substitution, tenv. For example:
737 -- instance C X a => D X where ...
738 -- (presumably there's a functional dependency in class C)
739 -- Hence mb_inst_tys :: Either TyVar TcType
741 ; let inst_tv (Left tv) = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
742 inst_tv (Right ty) = return ty
743 ; tys <- mappM inst_tv mb_inst_tys
745 (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
746 src_loc = instLocSpan loc
749 returnM (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
751 { (dicts, dict_app) <- instCallDicts loc theta
752 ; let co_fn = dict_app <.> mkWpTyApps tys
753 ; returnM (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
757 lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
758 -- Look up a class constraint in the instance environment
759 lookupPred pred@(ClassP clas tys)
761 ; tcg_env <- getGblEnv
762 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
763 ; case lookupInstEnv inst_envs clas tys of {
764 ([(ispec, inst_tys)], [])
765 -> do { let dfun_id = is_dfun ispec
766 ; traceTc (text "lookupInst success" <+>
767 vcat [text "dict" <+> ppr pred,
768 text "witness" <+> ppr dfun_id
769 <+> ppr (idType dfun_id) ])
770 -- Record that this dfun is needed
771 ; record_dfun_usage dfun_id
772 ; return (Just (dfun_id, inst_tys)) } ;
775 -> do { traceTc (text "lookupInst fail" <+>
776 vcat [text "dict" <+> ppr pred,
777 text "matches" <+> ppr matches,
778 text "unifs" <+> ppr unifs])
779 -- In the case of overlap (multiple matches) we report
780 -- NoInstance here. That has the effect of making the
781 -- context-simplifier return the dict as an irreducible one.
782 -- Then it'll be given to addNoInstanceErrs, which will do another
783 -- lookupInstEnv to get the detailed info about what went wrong.
787 lookupPred ip_pred = return Nothing -- Implicit parameters
789 record_dfun_usage dfun_id
790 = do { hsc_env <- getTopEnv
791 ; let dfun_name = idName dfun_id
792 dfun_mod = nameModule dfun_name
793 ; if isInternalName dfun_name || -- Internal name => defined in this module
794 modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
795 then return () -- internal, or in another package
796 else do { tcg_env <- getGblEnv
797 ; updMutVar (tcg_inst_uses tcg_env)
798 (`addOneToNameSet` idName dfun_id) }}
801 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
802 -- Gets both the external-package inst-env
803 -- and the home-pkg inst env (includes module being compiled)
804 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
805 return (eps_inst_env eps, tcg_inst_env env) }
810 %************************************************************************
814 %************************************************************************
816 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
817 a do-expression. We have to find (>>) in the current environment, which is
818 done by the rename. Then we have to check that it has the same type as
819 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
822 (>>) :: HB m n mn => m a -> n b -> mn b
824 So the idea is to generate a local binding for (>>), thus:
826 let then72 :: forall a b. m a -> m b -> m b
827 then72 = ...something involving the user's (>>)...
829 ...the do-expression...
831 Now the do-expression can proceed using then72, which has exactly
834 In fact tcSyntaxName just generates the RHS for then72, because we only
835 want an actual binding in the do-expression case. For literals, we can
836 just use the expression inline.
839 tcSyntaxName :: InstOrigin
840 -> TcType -- Type to instantiate it at
841 -> (Name, HsExpr Name) -- (Standard name, user name)
842 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
843 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
844 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
845 -- So we do not call it from lookupInst, which is called from tcSimplify
847 tcSyntaxName orig ty (std_nm, HsVar user_nm)
849 = newMethodFromName orig ty std_nm `thenM` \ id ->
850 returnM (std_nm, HsVar id)
852 tcSyntaxName orig ty (std_nm, user_nm_expr)
853 = tcLookupId std_nm `thenM` \ std_id ->
855 -- C.f. newMethodAtLoc
856 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
857 sigma1 = substTyWith [tv] [ty] tau
858 -- Actually, the "tau-type" might be a sigma-type in the
859 -- case of locally-polymorphic methods.
861 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $
863 -- Check that the user-supplied thing has the
864 -- same type as the standard one.
865 -- Tiresome jiggling because tcCheckSigma takes a located expression
866 getSrcSpanM `thenM` \ span ->
867 tcPolyExpr (L span user_nm_expr) sigma1 `thenM` \ expr ->
868 returnM (std_nm, unLoc expr)
870 syntaxNameCtxt name orig ty tidy_env
871 = getInstLoc orig `thenM` \ inst_loc ->
873 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
874 ptext SLIT("(needed by a syntactic construct)"),
875 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
876 nest 2 (ptext SLIT("arising from") <+> pprInstLoc inst_loc)]
878 returnM (tidy_env, msg)