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(..), 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 )
47 import FastString(FastString)
68 import Var ( Var, TyVar )
86 instName :: Inst -> Name
87 instName inst = Var.varName (instToVar inst)
89 instToId :: Inst -> TcId
90 instToId inst = ASSERT2( isId id, ppr inst ) id
94 instToVar :: Inst -> Var
95 instToVar (LitInst {tci_name = nm, tci_ty = ty})
97 instToVar (Method {tci_id = id})
99 instToVar (Dict {tci_name = nm, tci_pred = pred})
100 | isEqPred pred = Var.mkCoVar nm (mkPredTy pred)
101 | otherwise = mkLocalId nm (mkPredTy pred)
102 instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens,
103 tci_wanted = wanteds})
104 = mkLocalId nm (mkImplicTy tvs givens wanteds)
106 instType :: Inst -> Type
107 instType (LitInst {tci_ty = ty}) = ty
108 instType (Method {tci_id = id}) = idType id
109 instType (Dict {tci_pred = pred}) = mkPredTy pred
110 instType imp@(ImplicInst {}) = mkImplicTy (tci_tyvars imp) (tci_given imp)
113 mkImplicTy tvs givens wanteds -- The type of an implication constraint
114 = ASSERT( all isDict givens )
115 -- pprTrace "mkImplicTy" (ppr givens) $
117 mkPhiTy (map dictPred givens) $
118 if isSingleton wanteds then
119 instType (head wanteds)
121 mkTupleTy Boxed (length wanteds) (map instType wanteds)
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` varTypeTyVars 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)
170 `minusVarSet` mkVarSet tvs
171 `unionVarSet` unionVarSets (map varTypeTyVars tvs)
172 -- Remember the free tyvars of a coercion
174 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
175 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
181 isDict :: Inst -> Bool
182 isDict (Dict {}) = True
185 isClassDict :: Inst -> Bool
186 isClassDict (Dict {tci_pred = pred}) = isClassPred pred
187 isClassDict other = False
189 isTyVarDict :: Inst -> Bool
190 isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
191 isTyVarDict other = False
193 isIPDict :: Inst -> Bool
194 isIPDict (Dict {tci_pred = pred}) = isIPPred pred
195 isIPDict other = False
197 isImplicInst (ImplicInst {}) = True
198 isImplicInst other = False
200 isMethod :: Inst -> Bool
201 isMethod (Method {}) = True
202 isMethod other = False
204 isMethodFor :: TcIdSet -> Inst -> Bool
205 isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
206 isMethodFor ids inst = False
208 isMethodOrLit :: Inst -> Bool
209 isMethodOrLit (Method {}) = True
210 isMethodOrLit (LitInst {}) = True
211 isMethodOrLit other = False
215 getDefaultableDicts :: [Inst] -> ([(Inst, Class, TcTyVar)], TcTyVarSet)
216 -- Look for free dicts of the form (C tv), even inside implications
217 -- *and* the set of tyvars mentioned by all *other* constaints
218 -- This disgustingly ad-hoc function is solely to support defaulting
219 getDefaultableDicts insts
220 = (concat ps, unionVarSets tvs)
222 (ps, tvs) = mapAndUnzip get insts
223 get d@(Dict {tci_pred = ClassP cls [ty]})
224 | Just tv <- tcGetTyVar_maybe ty = ([(d,cls,tv)], emptyVarSet)
225 | otherwise = ([], tyVarsOfType ty)
226 get (ImplicInst {tci_tyvars = tvs, tci_wanted = wanteds})
227 = ([ up | up@(_,_,tv) <- ups, not (tv `elemVarSet` tv_set)],
228 ftvs `minusVarSet` tv_set)
230 tv_set = mkVarSet tvs
231 (ups, ftvs) = getDefaultableDicts wanteds
232 get inst = ([], tyVarsOfInst inst)
235 %************************************************************************
237 \subsection{Building dictionaries}
239 %************************************************************************
241 -- newDictBndrs makes a dictionary at a binding site
242 -- instCall makes a dictionary at an occurrence site
243 -- and throws it into the LIE
247 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
248 newDictBndrsO orig theta = do { loc <- getInstLoc orig
249 ; newDictBndrs loc theta }
251 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
252 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
254 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
255 newDictBndr inst_loc pred
256 = do { uniq <- newUnique
257 ; let name = mkPredName uniq inst_loc pred
258 ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
261 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
262 -- Instantiate the constraints of a call
263 -- (instCall o tys theta)
264 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
265 -- (b) Throws these dictionaries into the LIE
266 -- (c) Eeturns an HsWrapper ([.] tys dicts)
268 instCall orig tys theta
269 = do { loc <- getInstLoc orig
270 ; (dicts, dict_app) <- instCallDicts loc theta
272 ; return (dict_app <.> mkWpTyApps tys) }
275 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
276 -- Similar to instCall, but only emit the constraints in the LIE
277 -- Used exclusively for the 'stupid theta' of a data constructor
278 instStupidTheta orig theta
279 = do { loc <- getInstLoc orig
280 ; (dicts, _) <- instCallDicts loc theta
284 instCallDicts :: InstLoc -> TcThetaType -> TcM ([Inst], HsWrapper)
285 -- This is the key place where equality predicates
286 -- are unleashed into the world
287 instCallDicts loc [] = return ([], idHsWrapper)
289 instCallDicts loc (EqPred ty1 ty2 : preds)
290 = do { unifyType ty1 ty2 -- For now, we insist that they unify right away
291 -- Later on, when we do associated types,
292 -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
293 ; (dicts, co_fn) <- instCallDicts loc preds
294 ; return (dicts, co_fn <.> WpTyApp ty1) }
295 -- We use type application to apply the function to the
296 -- coercion; here ty1 *is* the appropriate identity coercion
298 instCallDicts loc (pred : preds)
299 = do { uniq <- newUnique
300 ; let name = mkPredName uniq loc pred
301 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
302 ; (dicts, co_fn) <- instCallDicts loc preds
303 ; return (dict:dicts, co_fn <.> WpApp (instToId dict)) }
306 cloneDict :: Inst -> TcM Inst -- Only used for linear implicit params
307 cloneDict dict@(Dict nm ty loc) = do { uniq <- newUnique
308 ; return (dict {tci_name = setNameUnique nm uniq}) }
309 cloneDict other = pprPanic "cloneDict" (ppr other)
311 -- For vanilla implicit parameters, there is only one in scope
312 -- at any time, so we used to use the name of the implicit parameter itself
313 -- But with splittable implicit parameters there may be many in
314 -- scope, so we make up a new namea.
315 newIPDict :: InstOrigin -> IPName Name -> Type
316 -> TcM (IPName Id, Inst)
317 newIPDict orig ip_name ty
318 = getInstLoc orig `thenM` \ inst_loc ->
319 newUnique `thenM` \ uniq ->
321 pred = IParam ip_name ty
322 name = mkPredName uniq inst_loc pred
323 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}
325 returnM (mapIPName (\n -> instToId dict) ip_name, dict)
330 mkPredName :: Unique -> InstLoc -> PredType -> Name
331 mkPredName uniq loc pred_ty
332 = mkInternalName uniq occ (srcSpanStart (instLocSpan loc))
334 occ = case pred_ty of
335 ClassP cls _ -> mkDictOcc (getOccName cls)
336 IParam ip _ -> getOccName (ipNameName ip)
337 EqPred ty _ -> mkEqPredCoOcc baseOcc
339 -- we use the outermost tycon of the lhs, if there is one, to
340 -- improve readability of Core code
341 baseOcc = case splitTyConApp_maybe ty of
342 Nothing -> mkOccName tcName "$"
343 Just (tc, _) -> getOccName tc
346 %************************************************************************
348 \subsection{Building methods (calls of overloaded functions)}
350 %************************************************************************
354 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
355 newMethodFromName origin ty name
356 = tcLookupId name `thenM` \ id ->
357 -- Use tcLookupId not tcLookupGlobalId; the method is almost
358 -- always a class op, but with -fno-implicit-prelude GHC is
359 -- meant to find whatever thing is in scope, and that may
360 -- be an ordinary function.
361 getInstLoc origin `thenM` \ loc ->
362 tcInstClassOp loc id [ty] `thenM` \ inst ->
363 extendLIE inst `thenM_`
364 returnM (instToId inst)
366 newMethodWithGivenTy orig id tys
367 = getInstLoc orig `thenM` \ loc ->
368 newMethod loc id tys `thenM` \ inst ->
369 extendLIE inst `thenM_`
370 returnM (instToId inst)
372 --------------------------------------------
373 -- tcInstClassOp, and newMethod do *not* drop the
374 -- Inst into the LIE; they just returns the Inst
375 -- This is important because they are used by TcSimplify
378 -- NB: the kind of the type variable to be instantiated
379 -- might be a sub-kind of the type to which it is applied,
380 -- notably when the latter is a type variable of kind ??
381 -- Hence the call to checkKind
382 -- A worry: is this needed anywhere else?
383 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
384 tcInstClassOp inst_loc sel_id tys
386 (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
388 zipWithM_ checkKind tyvars tys `thenM_`
389 newMethod inst_loc sel_id tys
391 checkKind :: TyVar -> TcType -> TcM ()
392 -- Ensure that the type has a sub-kind of the tyvar
395 -- ty1 <- zonkTcType ty
396 ; if typeKind ty1 `isSubKind` Var.tyVarKind tv
400 pprPanic "checkKind: adding kind constraint"
401 (vcat [ppr tv <+> ppr (Var.tyVarKind tv),
402 ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
404 -- do { tv1 <- tcInstTyVar tv
405 -- ; unifyType ty1 (mkTyVarTy tv1) } }
408 ---------------------------
409 newMethod inst_loc id tys
410 = newUnique `thenM` \ new_uniq ->
412 (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
413 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
414 inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
415 tci_theta = theta, tci_loc = inst_loc}
416 loc = srcSpanStart (instLocSpan inst_loc)
422 shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
424 | isIntTy ty && inIntRange i -- Short cut for Int
425 = Just (HsLit (HsInt i))
426 | isIntegerTy ty -- Short cut for Integer
427 = Just (HsLit (HsInteger i ty))
428 | otherwise = Nothing
430 shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
433 = Just (mk_lit floatDataCon (HsFloatPrim f))
435 = Just (mk_lit doubleDataCon (HsDoublePrim f))
436 | otherwise = Nothing
438 mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
440 shortCutStringLit :: FastString -> TcType -> Maybe (HsExpr TcId)
441 shortCutStringLit s ty
442 | isStringTy ty -- Short cut for String
443 = Just (HsLit (HsString s))
444 | otherwise = Nothing
446 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
448 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
449 getSrcSpanM `thenM` \ span ->
450 returnM (L span $ HsLit (HsInteger i integer_ty))
452 mkRatLit :: Rational -> TcM (LHsExpr TcId)
454 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
455 getSrcSpanM `thenM` \ span ->
456 returnM (L span $ HsLit (HsRat r rat_ty))
458 mkStrLit :: FastString -> TcM (LHsExpr TcId)
460 = --tcMetaTy stringTyConName `thenM` \ string_ty ->
461 getSrcSpanM `thenM` \ span ->
462 returnM (L span $ HsLit (HsString s))
464 isHsVar :: HsExpr Name -> Name -> Bool
465 isHsVar (HsVar f) g = f==g
466 isHsVar other g = False
470 %************************************************************************
474 %************************************************************************
476 Zonking makes sure that the instance types are fully zonked.
479 zonkInst :: Inst -> TcM Inst
480 zonkInst dict@(Dict { tci_pred = pred})
481 = zonkTcPredType pred `thenM` \ new_pred ->
482 returnM (dict {tci_pred = new_pred})
484 zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta})
485 = zonkId id `thenM` \ new_id ->
486 -- Essential to zonk the id in case it's a local variable
487 -- Can't use zonkIdOcc because the id might itself be
488 -- an InstId, in which case it won't be in scope
490 zonkTcTypes tys `thenM` \ new_tys ->
491 zonkTcThetaType theta `thenM` \ new_theta ->
492 returnM (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
493 -- No need to zonk the tci_id
495 zonkInst lit@(LitInst {tci_ty = ty})
496 = zonkTcType ty `thenM` \ new_ty ->
497 returnM (lit {tci_ty = new_ty})
499 zonkInst implic@(ImplicInst {})
500 = ASSERT( all isImmutableTyVar (tci_tyvars implic) )
501 do { givens' <- zonkInsts (tci_given implic)
502 ; wanteds' <- zonkInsts (tci_wanted implic)
503 ; return (implic {tci_given = givens',tci_wanted = wanteds'}) }
505 zonkInsts insts = mappM zonkInst insts
509 %************************************************************************
511 \subsection{Printing}
513 %************************************************************************
515 ToDo: improve these pretty-printing things. The ``origin'' is really only
516 relevant in error messages.
519 instance Outputable Inst where
520 ppr inst = pprInst inst
522 pprDictsTheta :: [Inst] -> SDoc
523 -- Print in type-like fashion (Eq a, Show b)
524 -- The Inst can be an implication constraint, but not a Method or LitInst
525 pprDictsTheta insts = parens (sep (punctuate comma (map (ppr . instType) insts)))
527 pprDictsInFull :: [Inst] -> SDoc
528 -- Print in type-like fashion, but with source location
530 = vcat (map go dicts)
532 go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
534 pprInsts :: [Inst] -> SDoc
535 -- Debugging: print the evidence :: type
536 pprInsts insts = brackets (interpp'SP insts)
538 pprInst, pprInstInFull :: Inst -> SDoc
539 -- Debugging: print the evidence :: type
540 pprInst inst = ppr (instName inst) <+> dcolon
541 <+> (braces (ppr (instType inst)) $$
542 ifPprDebug implic_stuff)
544 implic_stuff | isImplicInst inst = ppr (tci_reft inst)
547 pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
549 tidyInst :: TidyEnv -> Inst -> Inst
550 tidyInst env lit@(LitInst {tci_ty = ty}) = lit {tci_ty = tidyType env ty}
551 tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
552 tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
553 tidyInst env implic@(ImplicInst {})
554 = implic { tci_tyvars = tvs'
555 , tci_given = map (tidyInst env') (tci_given implic)
556 , tci_wanted = map (tidyInst env') (tci_wanted implic) }
558 (env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic)
560 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
561 -- This function doesn't assume that the tyvars are in scope
562 -- so it works like tidyOpenType, returning a TidyEnv
563 tidyMoreInsts env insts
564 = (env', map (tidyInst env') insts)
566 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
568 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
569 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
571 showLIE :: SDoc -> TcM () -- Debugging
573 = do { lie_var <- getLIEVar ;
574 lie <- readMutVar lie_var ;
575 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
579 %************************************************************************
581 Extending the instance environment
583 %************************************************************************
586 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
587 -- Add new locally-defined instances
588 tcExtendLocalInstEnv dfuns thing_inside
589 = do { traceDFuns dfuns
591 ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
592 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
593 tcg_inst_env = inst_env' }
594 ; setGblEnv env' thing_inside }
596 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
597 -- Check that the proposed new instance is OK,
598 -- and then add it to the home inst env
599 addLocalInst home_ie ispec
600 = do { -- Instantiate the dfun type so that we extend the instance
601 -- envt with completely fresh template variables
602 -- This is important because the template variables must
603 -- not overlap with anything in the things being looked up
604 -- (since we do unification).
605 -- We use tcInstSkolType because we don't want to allocate fresh
606 -- *meta* type variables.
607 let dfun = instanceDFunId ispec
608 ; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun)
609 ; let (cls, tys') = tcSplitDFunHead tau'
610 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
611 ispec' = setInstanceDFunId ispec dfun'
613 -- Load imported instances, so that we report
614 -- duplicates correctly
616 ; let inst_envs = (eps_inst_env eps, home_ie)
618 -- Check functional dependencies
619 ; case checkFunDeps inst_envs ispec' of
620 Just specs -> funDepErr ispec' specs
623 -- Check for duplicate instance decls
624 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
625 ; dup_ispecs = [ dup_ispec
626 | (_, dup_ispec) <- matches
627 , let (_,_,_,dup_tys) = instanceHead dup_ispec
628 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
629 -- Find memebers of the match list which ispec itself matches.
630 -- If the match is 2-way, it's a duplicate
632 dup_ispec : _ -> dupInstErr ispec' dup_ispec
635 -- OK, now extend the envt
636 ; return (extendInstEnv home_ie ispec') }
638 getOverlapFlag :: TcM OverlapFlag
640 = do { dflags <- getDOpts
641 ; let overlap_ok = dopt Opt_AllowOverlappingInstances dflags
642 incoherent_ok = dopt Opt_AllowIncoherentInstances dflags
643 overlap_flag | incoherent_ok = Incoherent
644 | overlap_ok = OverlapOk
645 | otherwise = NoOverlap
647 ; return overlap_flag }
650 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
652 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
653 -- Print the dfun name itself too
655 funDepErr ispec ispecs
657 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
658 2 (pprInstances (ispec:ispecs)))
659 dupInstErr ispec dup_ispec
661 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
662 2 (pprInstances [ispec, dup_ispec]))
664 addDictLoc ispec thing_inside
665 = setSrcSpan (mkSrcSpan loc loc) thing_inside
667 loc = getSrcLoc ispec
671 %************************************************************************
673 \subsection{Looking up Insts}
675 %************************************************************************
678 data LookupInstResult
680 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
682 lookupSimpleInst :: Inst -> TcM LookupInstResult
683 -- This is "simple" in tthat it returns NoInstance for implication constraints
685 -- It's important that lookupInst does not put any new stuff into
686 -- the LIE. Instead, any Insts needed by the lookup are returned in
687 -- the LookupInstResult, where they can be further processed by tcSimplify
689 --------------------- Implications ------------------------
690 lookupSimpleInst (ImplicInst {}) = return NoInstance
692 --------------------- Methods ------------------------
693 lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
694 = do { (dicts, dict_app) <- instCallDicts loc theta
695 ; let co_fn = dict_app <.> mkWpTyApps tys
696 ; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
698 span = instLocSpan loc
700 --------------------- Literals ------------------------
701 -- Look for short cuts first: if the literal is *definitely* a
702 -- int, integer, float or a double, generate the real thing here.
703 -- This is essential (see nofib/spectral/nucleic).
704 -- [Same shortcut as in newOverloadedLit, but we
705 -- may have done some unification by now]
707 lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name, tci_ty = ty, tci_loc = loc})
708 | Just expr <- shortCutIntLit i ty
709 = returnM (GenInst [] (noLoc expr))
711 = ASSERT( from_integer_name `isHsVar` fromIntegerName ) -- A LitInst invariant
712 tcLookupId fromIntegerName `thenM` \ from_integer ->
713 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
714 mkIntegerLit i `thenM` \ integer_lit ->
715 returnM (GenInst [method_inst]
716 (mkHsApp (L (instLocSpan loc)
717 (HsVar (instToId method_inst))) integer_lit))
719 lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name, tci_ty = ty, tci_loc = loc})
720 | Just expr <- shortCutFracLit f ty
721 = returnM (GenInst [] (noLoc expr))
724 = ASSERT( from_rat_name `isHsVar` fromRationalName ) -- A LitInst invariant
725 tcLookupId fromRationalName `thenM` \ from_rational ->
726 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
727 mkRatLit f `thenM` \ rat_lit ->
728 returnM (GenInst [method_inst] (mkHsApp (L (instLocSpan loc)
729 (HsVar (instToId method_inst))) rat_lit))
731 lookupSimpleInst (LitInst {tci_lit = HsIsString s from_string_name, tci_ty = ty, tci_loc = loc})
732 | Just expr <- shortCutStringLit s ty
733 = returnM (GenInst [] (noLoc expr))
735 = ASSERT( from_string_name `isHsVar` fromStringName ) -- A LitInst invariant
736 tcLookupId fromStringName `thenM` \ from_string ->
737 tcInstClassOp loc from_string [ty] `thenM` \ method_inst ->
738 mkStrLit s `thenM` \ string_lit ->
739 returnM (GenInst [method_inst]
740 (mkHsApp (L (instLocSpan loc)
741 (HsVar (instToId method_inst))) string_lit))
743 --------------------- Dictionaries ------------------------
744 lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
745 = do { mb_result <- lookupPred pred
746 ; case mb_result of {
747 Nothing -> return NoInstance ;
748 Just (tenv, dfun_id) -> do
750 -- tenv is a substitution that instantiates the dfun_id
751 -- to match the requested result type.
753 -- We ASSUME that the dfun is quantified over the very same tyvars
754 -- that are bound by the tenv.
757 -- might have some tyvars that *only* appear in arguments
758 -- dfun :: forall a b. C a b, Ord b => D [a]
759 -- We instantiate b to a flexi type variable -- it'll presumably
760 -- become fixed later via functional dependencies
761 { use_stage <- getStage
762 ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
763 (topIdLvl dfun_id) use_stage
765 -- It's possible that not all the tyvars are in
766 -- the substitution, tenv. For example:
767 -- instance C X a => D X where ...
768 -- (presumably there's a functional dependency in class C)
769 -- Hence the open_tvs to instantiate any un-substituted tyvars.
770 ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
771 open_tvs = filter (`notElemTvSubst` tenv) tyvars
772 ; open_tvs' <- mappM tcInstTyVar open_tvs
774 tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
775 -- Since the open_tvs' are freshly made, they cannot possibly be captured by
776 -- any nested for-alls in rho. So the in-scope set is unchanged
777 dfun_rho = substTy tenv' rho
778 (theta, _) = tcSplitPhiTy dfun_rho
779 src_loc = instLocSpan loc
781 tys = substTyVars tenv' tyvars
783 returnM (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
785 { (dicts, dict_app) <- instCallDicts loc theta
786 ; let co_fn = dict_app <.> mkWpTyApps tys
787 ; returnM (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
791 lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
792 -- Look up a class constraint in the instance environment
793 lookupPred pred@(ClassP clas tys)
795 ; tcg_env <- getGblEnv
796 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
797 ; case lookupInstEnv inst_envs clas tys of {
798 ([(tenv, ispec)], [])
799 -> do { let dfun_id = is_dfun ispec
800 ; traceTc (text "lookupInst success" <+>
801 vcat [text "dict" <+> ppr pred,
802 text "witness" <+> ppr dfun_id
803 <+> ppr (idType dfun_id) ])
804 -- Record that this dfun is needed
805 ; record_dfun_usage dfun_id
806 ; return (Just (tenv, dfun_id)) } ;
809 -> do { traceTc (text "lookupInst fail" <+>
810 vcat [text "dict" <+> ppr pred,
811 text "matches" <+> ppr matches,
812 text "unifs" <+> ppr unifs])
813 -- In the case of overlap (multiple matches) we report
814 -- NoInstance here. That has the effect of making the
815 -- context-simplifier return the dict as an irreducible one.
816 -- Then it'll be given to addNoInstanceErrs, which will do another
817 -- lookupInstEnv to get the detailed info about what went wrong.
821 lookupPred ip_pred = return Nothing -- Implicit parameters
823 record_dfun_usage dfun_id
824 = do { hsc_env <- getTopEnv
825 ; let dfun_name = idName dfun_id
826 dfun_mod = nameModule dfun_name
827 ; if isInternalName dfun_name || -- Internal name => defined in this module
828 modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
829 then return () -- internal, or in another package
830 else do { tcg_env <- getGblEnv
831 ; updMutVar (tcg_inst_uses tcg_env)
832 (`addOneToNameSet` idName dfun_id) }}
835 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
836 -- Gets both the external-package inst-env
837 -- and the home-pkg inst env (includes module being compiled)
838 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
839 return (eps_inst_env eps, tcg_inst_env env) }
844 %************************************************************************
848 %************************************************************************
850 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
851 a do-expression. We have to find (>>) in the current environment, which is
852 done by the rename. Then we have to check that it has the same type as
853 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
856 (>>) :: HB m n mn => m a -> n b -> mn b
858 So the idea is to generate a local binding for (>>), thus:
860 let then72 :: forall a b. m a -> m b -> m b
861 then72 = ...something involving the user's (>>)...
863 ...the do-expression...
865 Now the do-expression can proceed using then72, which has exactly
868 In fact tcSyntaxName just generates the RHS for then72, because we only
869 want an actual binding in the do-expression case. For literals, we can
870 just use the expression inline.
873 tcSyntaxName :: InstOrigin
874 -> TcType -- Type to instantiate it at
875 -> (Name, HsExpr Name) -- (Standard name, user name)
876 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
877 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
878 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
879 -- So we do not call it from lookupInst, which is called from tcSimplify
881 tcSyntaxName orig ty (std_nm, HsVar user_nm)
883 = newMethodFromName orig ty std_nm `thenM` \ id ->
884 returnM (std_nm, HsVar id)
886 tcSyntaxName orig ty (std_nm, user_nm_expr)
887 = tcLookupId std_nm `thenM` \ std_id ->
889 -- C.f. newMethodAtLoc
890 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
891 sigma1 = substTyWith [tv] [ty] tau
892 -- Actually, the "tau-type" might be a sigma-type in the
893 -- case of locally-polymorphic methods.
895 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $
897 -- Check that the user-supplied thing has the
898 -- same type as the standard one.
899 -- Tiresome jiggling because tcCheckSigma takes a located expression
900 getSrcSpanM `thenM` \ span ->
901 tcPolyExpr (L span user_nm_expr) sigma1 `thenM` \ expr ->
902 returnM (std_nm, unLoc expr)
904 syntaxNameCtxt name orig ty tidy_env
905 = getInstLoc orig `thenM` \ inst_loc ->
907 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
908 ptext SLIT("(needed by a syntactic construct)"),
909 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
910 nest 2 (ptext SLIT("arising from") <+> pprInstLoc inst_loc)]
912 returnM (tidy_env, msg)