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 isAbstractableInst, isEqInst,
33 isDict, isClassDict, isMethod, isImplicInst,
34 isIPDict, isInheritableInst, isMethodOrLit,
35 isTyVarDict, isMethodFor,
38 instToId, instToVar, instType, instName,
40 InstOrigin(..), InstLoc, pprInstLoc,
42 mkWantedCo, mkGivenCo,
43 fromWantedCo, fromGivenCo,
44 eitherEqInst, mkEqInst, mkEqInsts,
45 finalizeEqInst, writeWantedCoercion,
46 eqInstType, updateEqInstCoercion,
48 eqInstLeftTy, eqInstRightTy
51 #include "HsVersions.h"
53 import {-# SOURCE #-} TcExpr( tcPolyExpr )
54 import {-# SOURCE #-} TcUnify( boxyUnify, unifyType )
56 import FastString(FastString)
78 import Var ( Var, TyVar )
99 instName :: Inst -> Name
100 instName (EqInst {tci_name = name}) = name
101 instName inst = Var.varName (instToVar inst)
103 instToId :: Inst -> TcId
104 instToId inst = WARN( not (isId id), ppr inst )
109 instToVar :: Inst -> Var
110 instToVar (LitInst {tci_name = nm, tci_ty = ty})
112 instToVar (Method {tci_id = id})
114 instToVar (Dict {tci_name = nm, tci_pred = pred})
115 | isEqPred pred = Var.mkCoVar nm (mkPredTy pred)
116 | otherwise = mkLocalId nm (mkPredTy pred)
117 instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens,
118 tci_wanted = wanteds})
119 = mkLocalId nm (mkImplicTy tvs givens wanteds)
120 instToVar i@(EqInst {})
121 = eitherEqInst i id (\(TyVarTy covar) -> covar)
123 instType :: Inst -> Type
124 instType (LitInst {tci_ty = ty}) = ty
125 instType (Method {tci_id = id}) = idType id
126 instType (Dict {tci_pred = pred}) = mkPredTy pred
127 instType imp@(ImplicInst {}) = mkImplicTy (tci_tyvars imp) (tci_given imp)
129 -- instType i@(EqInst {tci_co = co}) = eitherEqInst i TyVarTy id
130 instType (EqInst {tci_left = ty1, tci_right = ty2}) = mkPredTy (EqPred ty1 ty2)
132 mkImplicTy tvs givens wanteds -- The type of an implication constraint
133 = ASSERT( all isDict givens )
134 -- pprTrace "mkImplicTy" (ppr givens) $
135 -- See [Equational Constraints in Implication Constraints]
136 let dict_wanteds = filter (not . isEqInst) wanteds
139 mkPhiTy (map dictPred givens) $
140 if isSingleton dict_wanteds then
141 instType (head dict_wanteds)
143 mkTupleTy Boxed (length dict_wanteds) (map instType dict_wanteds)
145 dictPred (Dict {tci_pred = pred}) = pred
146 dictPred (EqInst {tci_left=ty1,tci_right=ty2}) = EqPred ty1 ty2
147 dictPred inst = pprPanic "dictPred" (ppr inst)
149 getDictClassTys (Dict {tci_pred = pred}) = getClassPredTys pred
150 getDictClassTys inst = pprPanic "getDictClassTys" (ppr inst)
152 -- fdPredsOfInst is used to get predicates that contain functional
153 -- dependencies *or* might do so. The "might do" part is because
154 -- a constraint (C a b) might have a superclass with FDs
155 -- Leaving these in is really important for the call to fdPredsOfInsts
156 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
157 -- which is supposed to be conservative
158 fdPredsOfInst (Dict {tci_pred = pred}) = [pred]
159 fdPredsOfInst (Method {tci_theta = theta}) = theta
160 fdPredsOfInst (ImplicInst {tci_given = gs,
161 tci_wanted = ws}) = fdPredsOfInsts (gs ++ ws)
162 fdPredsOfInst (LitInst {}) = []
163 fdPredsOfInst (EqInst {}) = []
165 fdPredsOfInsts :: [Inst] -> [PredType]
166 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
168 isInheritableInst (Dict {tci_pred = pred}) = isInheritablePred pred
169 isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta
170 isInheritableInst other = True
173 ---------------------------------
174 -- Get the implicit parameters mentioned by these Insts
175 -- NB: the results of these functions are insensitive to zonking
177 ipNamesOfInsts :: [Inst] -> [Name]
178 ipNamesOfInst :: Inst -> [Name]
179 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
181 ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
182 ipNamesOfInst (Method {tci_theta = theta}) = [ipNameName n | IParam n _ <- theta]
183 ipNamesOfInst other = []
185 ---------------------------------
186 tyVarsOfInst :: Inst -> TcTyVarSet
187 tyVarsOfInst (LitInst {tci_ty = ty}) = tyVarsOfType ty
188 tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
189 tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id
190 -- The id might have free type variables; in the case of
191 -- locally-overloaded class methods, for example
192 tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds})
193 = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds)
194 `minusVarSet` mkVarSet tvs
195 `unionVarSet` unionVarSets (map varTypeTyVars tvs)
196 -- Remember the free tyvars of a coercion
197 tyVarsOfInst (EqInst {tci_left = ty1, tci_right = ty2}) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
199 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
200 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
207 isAbstractableInst :: Inst -> Bool
208 isAbstractableInst inst = isDict inst || isEqInst inst
210 isEqInst :: Inst -> Bool
211 isEqInst (EqInst {}) = True
212 isEqInst other = False
214 isDict :: Inst -> Bool
215 isDict (Dict {}) = True
218 isClassDict :: Inst -> Bool
219 isClassDict (Dict {tci_pred = pred}) = isClassPred pred
220 isClassDict other = False
222 isTyVarDict :: Inst -> Bool
223 isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
224 isTyVarDict other = False
226 isIPDict :: Inst -> Bool
227 isIPDict (Dict {tci_pred = pred}) = isIPPred pred
228 isIPDict other = False
230 isImplicInst (ImplicInst {}) = True
231 isImplicInst other = False
233 isMethod :: Inst -> Bool
234 isMethod (Method {}) = True
235 isMethod other = False
237 isMethodFor :: TcIdSet -> Inst -> Bool
238 isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
239 isMethodFor ids inst = False
241 isMethodOrLit :: Inst -> Bool
242 isMethodOrLit (Method {}) = True
243 isMethodOrLit (LitInst {}) = True
244 isMethodOrLit other = False
248 %************************************************************************
250 \subsection{Building dictionaries}
252 %************************************************************************
254 -- newDictBndrs makes a dictionary at a binding site
255 -- instCall makes a dictionary at an occurrence site
256 -- and throws it into the LIE
260 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
261 newDictBndrsO orig theta = do { loc <- getInstLoc orig
262 ; newDictBndrs loc theta }
264 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
265 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
267 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
268 newDictBndr inst_loc pred@(EqPred ty1 ty2)
269 = do { uniq <- newUnique
270 ; let name = mkPredName uniq inst_loc pred
271 ; return (EqInst {tci_name = name,
275 tci_co = mkGivenCo $ TyVarTy (Var.mkCoVar name (PredTy pred))})
277 newDictBndr inst_loc pred
278 = do { uniq <- newUnique
279 ; let name = mkPredName uniq inst_loc pred
280 ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
283 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
284 -- Instantiate the constraints of a call
285 -- (instCall o tys theta)
286 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
287 -- (b) Throws these dictionaries into the LIE
288 -- (c) Returns an HsWrapper ([.] tys dicts)
290 instCall orig tys theta
291 = do { loc <- getInstLoc orig
292 ; dict_app <- instCallDicts loc theta
293 ; return (dict_app <.> mkWpTyApps tys) }
296 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
297 -- Similar to instCall, but only emit the constraints in the LIE
298 -- Used exclusively for the 'stupid theta' of a data constructor
299 instStupidTheta orig theta
300 = do { loc <- getInstLoc orig
301 ; _co <- instCallDicts loc theta -- Discard the coercion
305 instCallDicts :: InstLoc -> TcThetaType -> TcM HsWrapper
306 -- Instantiates the TcTheta, puts all constraints thereby generated
307 -- into the LIE, and returns a HsWrapper to enclose the call site.
308 -- This is the key place where equality predicates
309 -- are unleashed into the world
310 instCallDicts loc [] = return idHsWrapper
312 -- instCallDicts loc (EqPred ty1 ty2 : preds)
313 -- = do { unifyType ty1 ty2 -- For now, we insist that they unify right away
314 -- -- Later on, when we do associated types,
315 -- -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
316 -- ; (dicts, co_fn) <- instCallDicts loc preds
317 -- ; return (dicts, co_fn <.> WpTyApp ty1) }
318 -- -- We use type application to apply the function to the
319 -- -- coercion; here ty1 *is* the appropriate identity coercion
321 instCallDicts loc (EqPred ty1 ty2 : preds)
322 = do { traceTc (text "instCallDicts" <+> ppr (EqPred ty1 ty2))
323 ; coi <- boxyUnify ty1 ty2
324 -- ; coi <- unifyType ty1 ty2
325 ; let co = fromCoI coi ty1
326 ; co_fn <- instCallDicts loc preds
327 ; return (co_fn <.> WpTyApp co) }
329 instCallDicts loc (pred : preds)
330 = do { uniq <- newUnique
331 ; let name = mkPredName uniq loc pred
332 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
334 ; co_fn <- instCallDicts loc preds
335 ; return (co_fn <.> WpApp (instToId dict)) }
338 cloneDict :: Inst -> TcM Inst
339 cloneDict dict@(Dict nm ty loc) = do { uniq <- newUnique
340 ; return (dict {tci_name = setNameUnique nm uniq}) }
341 cloneDict eq@(EqInst {}) = return eq
342 cloneDict other = pprPanic "cloneDict" (ppr other)
344 -- For vanilla implicit parameters, there is only one in scope
345 -- at any time, so we used to use the name of the implicit parameter itself
346 -- But with splittable implicit parameters there may be many in
347 -- scope, so we make up a new namea.
348 newIPDict :: InstOrigin -> IPName Name -> Type
349 -> TcM (IPName Id, Inst)
350 newIPDict orig ip_name ty
351 = getInstLoc orig `thenM` \ inst_loc ->
352 newUnique `thenM` \ uniq ->
354 pred = IParam ip_name ty
355 name = mkPredName uniq inst_loc pred
356 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}
358 returnM (mapIPName (\n -> instToId dict) ip_name, dict)
363 mkPredName :: Unique -> InstLoc -> PredType -> Name
364 mkPredName uniq loc pred_ty
365 = mkInternalName uniq occ (instLocSpan loc)
367 occ = case pred_ty of
368 ClassP cls _ -> mkDictOcc (getOccName cls)
369 IParam ip _ -> getOccName (ipNameName ip)
370 EqPred ty _ -> mkEqPredCoOcc baseOcc
372 -- we use the outermost tycon of the lhs, if there is one, to
373 -- improve readability of Core code
374 baseOcc = case splitTyConApp_maybe ty of
375 Nothing -> mkOccName tcName "$"
376 Just (tc, _) -> getOccName tc
379 %************************************************************************
381 \subsection{Building methods (calls of overloaded functions)}
383 %************************************************************************
387 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
388 newMethodFromName origin ty name
389 = tcLookupId name `thenM` \ id ->
390 -- Use tcLookupId not tcLookupGlobalId; the method is almost
391 -- always a class op, but with -fno-implicit-prelude GHC is
392 -- meant to find whatever thing is in scope, and that may
393 -- be an ordinary function.
394 getInstLoc origin `thenM` \ loc ->
395 tcInstClassOp loc id [ty] `thenM` \ inst ->
396 extendLIE inst `thenM_`
397 returnM (instToId inst)
399 newMethodWithGivenTy orig id tys
400 = getInstLoc orig `thenM` \ loc ->
401 newMethod loc id tys `thenM` \ inst ->
402 extendLIE inst `thenM_`
403 returnM (instToId inst)
405 --------------------------------------------
406 -- tcInstClassOp, and newMethod do *not* drop the
407 -- Inst into the LIE; they just returns the Inst
408 -- This is important because they are used by TcSimplify
411 -- NB: the kind of the type variable to be instantiated
412 -- might be a sub-kind of the type to which it is applied,
413 -- notably when the latter is a type variable of kind ??
414 -- Hence the call to checkKind
415 -- A worry: is this needed anywhere else?
416 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
417 tcInstClassOp inst_loc sel_id tys
419 (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
421 zipWithM_ checkKind tyvars tys `thenM_`
422 newMethod inst_loc sel_id tys
424 checkKind :: TyVar -> TcType -> TcM ()
425 -- Ensure that the type has a sub-kind of the tyvar
428 -- ty1 <- zonkTcType ty
429 ; if typeKind ty1 `isSubKind` Var.tyVarKind tv
433 pprPanic "checkKind: adding kind constraint"
434 (vcat [ppr tv <+> ppr (Var.tyVarKind tv),
435 ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
437 -- do { tv1 <- tcInstTyVar tv
438 -- ; unifyType ty1 (mkTyVarTy tv1) } }
441 ---------------------------
442 newMethod inst_loc id tys
443 = newUnique `thenM` \ new_uniq ->
445 (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
446 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
447 inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
448 tci_theta = theta, tci_loc = inst_loc}
449 loc = instLocSpan inst_loc
455 shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
457 | isIntTy ty && inIntRange i -- Short cut for Int
458 = Just (HsLit (HsInt i))
459 | isIntegerTy ty -- Short cut for Integer
460 = Just (HsLit (HsInteger i ty))
461 | otherwise = Nothing
463 shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
466 = Just (mk_lit floatDataCon (HsFloatPrim f))
468 = Just (mk_lit doubleDataCon (HsDoublePrim f))
469 | otherwise = Nothing
471 mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
473 shortCutStringLit :: FastString -> TcType -> Maybe (HsExpr TcId)
474 shortCutStringLit s ty
475 | isStringTy ty -- Short cut for String
476 = Just (HsLit (HsString s))
477 | otherwise = Nothing
479 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
481 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
482 getSrcSpanM `thenM` \ span ->
483 returnM (L span $ HsLit (HsInteger i integer_ty))
485 mkRatLit :: Rational -> TcM (LHsExpr TcId)
487 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
488 getSrcSpanM `thenM` \ span ->
489 returnM (L span $ HsLit (HsRat r rat_ty))
491 mkStrLit :: FastString -> TcM (LHsExpr TcId)
493 = --tcMetaTy stringTyConName `thenM` \ string_ty ->
494 getSrcSpanM `thenM` \ span ->
495 returnM (L span $ HsLit (HsString s))
497 isHsVar :: HsExpr Name -> Name -> Bool
498 isHsVar (HsVar f) g = f==g
499 isHsVar other g = False
503 %************************************************************************
507 %************************************************************************
509 Zonking makes sure that the instance types are fully zonked.
512 zonkInst :: Inst -> TcM Inst
513 zonkInst dict@(Dict { tci_pred = pred})
514 = zonkTcPredType pred `thenM` \ new_pred ->
515 returnM (dict {tci_pred = new_pred})
517 zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta})
518 = zonkId id `thenM` \ new_id ->
519 -- Essential to zonk the id in case it's a local variable
520 -- Can't use zonkIdOcc because the id might itself be
521 -- an InstId, in which case it won't be in scope
523 zonkTcTypes tys `thenM` \ new_tys ->
524 zonkTcThetaType theta `thenM` \ new_theta ->
525 returnM (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
526 -- No need to zonk the tci_id
528 zonkInst lit@(LitInst {tci_ty = ty})
529 = zonkTcType ty `thenM` \ new_ty ->
530 returnM (lit {tci_ty = new_ty})
532 zonkInst implic@(ImplicInst {})
533 = ASSERT( all isImmutableTyVar (tci_tyvars implic) )
534 do { givens' <- zonkInsts (tci_given implic)
535 ; wanteds' <- zonkInsts (tci_wanted implic)
536 ; return (implic {tci_given = givens',tci_wanted = wanteds'}) }
538 zonkInst eqinst@(EqInst {tci_left = ty1, tci_right = ty2})
539 = do { co' <- eitherEqInst eqinst
540 (\covar -> return (mkWantedCo covar))
541 (\co -> zonkTcType co >>= \coercion -> return (mkGivenCo coercion))
542 ; ty1' <- zonkTcType ty1
543 ; ty2' <- zonkTcType ty2
544 ; return (eqinst {tci_co = co',tci_left=ty1',tci_right=ty2})
547 zonkInsts insts = mappM zonkInst insts
551 %************************************************************************
553 \subsection{Printing}
555 %************************************************************************
557 ToDo: improve these pretty-printing things. The ``origin'' is really only
558 relevant in error messages.
561 instance Outputable Inst where
562 ppr inst = pprInst inst
564 pprDictsTheta :: [Inst] -> SDoc
565 -- Print in type-like fashion (Eq a, Show b)
566 -- The Inst can be an implication constraint, but not a Method or LitInst
567 pprDictsTheta insts = parens (sep (punctuate comma (map (ppr . instType) insts)))
569 pprDictsInFull :: [Inst] -> SDoc
570 -- Print in type-like fashion, but with source location
572 = vcat (map go dicts)
574 go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
576 pprInsts :: [Inst] -> SDoc
577 -- Debugging: print the evidence :: type
578 pprInsts insts = brackets (interpp'SP insts)
580 pprInst, pprInstInFull :: Inst -> SDoc
581 -- Debugging: print the evidence :: type
582 pprInst i@(EqInst {tci_left = ty1, tci_right = ty2, tci_co = co})
584 (\covar -> text "Wanted" <+> ppr (TyVarTy covar) <+> dcolon <+> ppr (EqPred ty1 ty2))
585 (\co -> text "Given" <+> ppr co <+> dcolon <+> ppr (EqPred ty1 ty2))
586 pprInst inst = ppr (instName inst) <+> dcolon
587 <+> (braces (ppr (instType inst)) $$
588 ifPprDebug implic_stuff)
590 implic_stuff | isImplicInst inst = ppr (tci_reft inst)
593 pprInstInFull inst@(EqInst {}) = pprInst inst
594 pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
596 tidyInst :: TidyEnv -> Inst -> Inst
597 tidyInst env eq@(EqInst {tci_left = lty, tci_right = rty, tci_co = co}) =
598 eq { tci_left = tidyType env lty
599 , tci_right = tidyType env rty
600 , tci_co = either Left (Right . tidyType env) co
602 tidyInst env lit@(LitInst {tci_ty = ty}) = lit {tci_ty = tidyType env ty}
603 tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
604 tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
605 tidyInst env implic@(ImplicInst {})
606 = implic { tci_tyvars = tvs'
607 , tci_given = map (tidyInst env') (tci_given implic)
608 , tci_wanted = map (tidyInst env') (tci_wanted implic) }
610 (env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic)
612 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
613 -- This function doesn't assume that the tyvars are in scope
614 -- so it works like tidyOpenType, returning a TidyEnv
615 tidyMoreInsts env insts
616 = (env', map (tidyInst env') insts)
618 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
620 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
621 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
623 showLIE :: SDoc -> TcM () -- Debugging
625 = do { lie_var <- getLIEVar ;
626 lie <- readMutVar lie_var ;
627 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
631 %************************************************************************
633 Extending the instance environment
635 %************************************************************************
638 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
639 -- Add new locally-defined instances
640 tcExtendLocalInstEnv dfuns thing_inside
641 = do { traceDFuns dfuns
643 ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
644 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
645 tcg_inst_env = inst_env' }
646 ; setGblEnv env' thing_inside }
648 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
649 -- Check that the proposed new instance is OK,
650 -- and then add it to the home inst env
651 addLocalInst home_ie ispec
652 = do { -- Instantiate the dfun type so that we extend the instance
653 -- envt with completely fresh template variables
654 -- This is important because the template variables must
655 -- not overlap with anything in the things being looked up
656 -- (since we do unification).
657 -- We use tcInstSkolType because we don't want to allocate fresh
658 -- *meta* type variables.
659 let dfun = instanceDFunId ispec
660 ; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun)
661 ; let (cls, tys') = tcSplitDFunHead tau'
662 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
663 ispec' = setInstanceDFunId ispec dfun'
665 -- Load imported instances, so that we report
666 -- duplicates correctly
668 ; let inst_envs = (eps_inst_env eps, home_ie)
670 -- Check functional dependencies
671 ; case checkFunDeps inst_envs ispec' of
672 Just specs -> funDepErr ispec' specs
675 -- Check for duplicate instance decls
676 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
677 ; dup_ispecs = [ dup_ispec
678 | (dup_ispec, _) <- matches
679 , let (_,_,_,dup_tys) = instanceHead dup_ispec
680 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
681 -- Find memebers of the match list which ispec itself matches.
682 -- If the match is 2-way, it's a duplicate
684 dup_ispec : _ -> dupInstErr ispec' dup_ispec
687 -- OK, now extend the envt
688 ; return (extendInstEnv home_ie ispec') }
690 getOverlapFlag :: TcM OverlapFlag
692 = do { dflags <- getDOpts
693 ; let overlap_ok = dopt Opt_OverlappingInstances dflags
694 incoherent_ok = dopt Opt_IncoherentInstances dflags
695 overlap_flag | incoherent_ok = Incoherent
696 | overlap_ok = OverlapOk
697 | otherwise = NoOverlap
699 ; return overlap_flag }
702 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
704 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
705 -- Print the dfun name itself too
707 funDepErr ispec ispecs
709 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
710 2 (pprInstances (ispec:ispecs)))
711 dupInstErr ispec dup_ispec
713 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
714 2 (pprInstances [ispec, dup_ispec]))
716 addDictLoc ispec thing_inside
717 = setSrcSpan (mkSrcSpan loc loc) thing_inside
719 loc = getSrcLoc ispec
723 %************************************************************************
725 \subsection{Looking up Insts}
727 %************************************************************************
730 data LookupInstResult
732 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
734 lookupSimpleInst :: Inst -> TcM LookupInstResult
735 -- This is "simple" in that it returns NoInstance for implication constraints
737 -- It's important that lookupInst does not put any new stuff into
738 -- the LIE. Instead, any Insts needed by the lookup are returned in
739 -- the LookupInstResult, where they can be further processed by tcSimplify
741 lookupSimpleInst (EqInst {}) = return NoInstance
743 --------------------- Implications ------------------------
744 lookupSimpleInst (ImplicInst {}) = return NoInstance
746 --------------------- Methods ------------------------
747 lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
748 = do { (dict_app, dicts) <- getLIE $ instCallDicts loc theta
749 ; let co_fn = dict_app <.> mkWpTyApps tys
750 ; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
752 span = instLocSpan loc
754 --------------------- Literals ------------------------
755 -- Look for short cuts first: if the literal is *definitely* a
756 -- int, integer, float or a double, generate the real thing here.
757 -- This is essential (see nofib/spectral/nucleic).
758 -- [Same shortcut as in newOverloadedLit, but we
759 -- may have done some unification by now]
761 lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name, tci_ty = ty, tci_loc = loc})
762 | Just expr <- shortCutIntLit i ty
763 = returnM (GenInst [] (noLoc expr))
765 = ASSERT( from_integer_name `isHsVar` fromIntegerName ) -- A LitInst invariant
766 tcLookupId fromIntegerName `thenM` \ from_integer ->
767 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
768 mkIntegerLit i `thenM` \ integer_lit ->
769 returnM (GenInst [method_inst]
770 (mkHsApp (L (instLocSpan loc)
771 (HsVar (instToId method_inst))) integer_lit))
773 lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name, tci_ty = ty, tci_loc = loc})
774 | Just expr <- shortCutFracLit f ty
775 = returnM (GenInst [] (noLoc expr))
778 = ASSERT( from_rat_name `isHsVar` fromRationalName ) -- A LitInst invariant
779 tcLookupId fromRationalName `thenM` \ from_rational ->
780 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
781 mkRatLit f `thenM` \ rat_lit ->
782 returnM (GenInst [method_inst] (mkHsApp (L (instLocSpan loc)
783 (HsVar (instToId method_inst))) rat_lit))
785 lookupSimpleInst (LitInst {tci_lit = HsIsString s from_string_name, tci_ty = ty, tci_loc = loc})
786 | Just expr <- shortCutStringLit s ty
787 = returnM (GenInst [] (noLoc expr))
789 = ASSERT( from_string_name `isHsVar` fromStringName ) -- A LitInst invariant
790 tcLookupId fromStringName `thenM` \ from_string ->
791 tcInstClassOp loc from_string [ty] `thenM` \ method_inst ->
792 mkStrLit s `thenM` \ string_lit ->
793 returnM (GenInst [method_inst]
794 (mkHsApp (L (instLocSpan loc)
795 (HsVar (instToId method_inst))) string_lit))
797 --------------------- Dictionaries ------------------------
798 lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
799 = do { mb_result <- lookupPred pred
800 ; case mb_result of {
801 Nothing -> return NoInstance ;
802 Just (dfun_id, mb_inst_tys) -> do
804 { use_stage <- getStage
805 ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
806 (topIdLvl dfun_id) use_stage
808 -- It's possible that not all the tyvars are in
809 -- the substitution, tenv. For example:
810 -- instance C X a => D X where ...
811 -- (presumably there's a functional dependency in class C)
812 -- Hence mb_inst_tys :: Either TyVar TcType
814 ; let inst_tv (Left tv) = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
815 inst_tv (Right ty) = return ty
816 ; tys <- mappM inst_tv mb_inst_tys
818 (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
819 src_loc = instLocSpan loc
822 returnM (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
824 { (dict_app, dicts) <- getLIE $ instCallDicts loc theta -- !!!
825 ; let co_fn = dict_app <.> mkWpTyApps tys
826 ; returnM (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
830 lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
831 -- Look up a class constraint in the instance environment
832 lookupPred pred@(ClassP clas tys)
834 ; tcg_env <- getGblEnv
835 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
836 ; case lookupInstEnv inst_envs clas tys of {
837 ([(ispec, inst_tys)], [])
838 -> do { let dfun_id = is_dfun ispec
839 ; traceTc (text "lookupInst success" <+>
840 vcat [text "dict" <+> ppr pred,
841 text "witness" <+> ppr dfun_id
842 <+> ppr (idType dfun_id) ])
843 -- Record that this dfun is needed
844 ; record_dfun_usage dfun_id
845 ; return (Just (dfun_id, inst_tys)) } ;
848 -> do { traceTc (text "lookupInst fail" <+>
849 vcat [text "dict" <+> ppr pred,
850 text "matches" <+> ppr matches,
851 text "unifs" <+> ppr unifs])
852 -- In the case of overlap (multiple matches) we report
853 -- NoInstance here. That has the effect of making the
854 -- context-simplifier return the dict as an irreducible one.
855 -- Then it'll be given to addNoInstanceErrs, which will do another
856 -- lookupInstEnv to get the detailed info about what went wrong.
860 lookupPred ip_pred = return Nothing -- Implicit parameters
862 record_dfun_usage dfun_id
863 = do { hsc_env <- getTopEnv
864 ; let dfun_name = idName dfun_id
865 dfun_mod = nameModule dfun_name
866 ; if isInternalName dfun_name || -- Internal name => defined in this module
867 modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
868 then return () -- internal, or in another package
869 else do { tcg_env <- getGblEnv
870 ; updMutVar (tcg_inst_uses tcg_env)
871 (`addOneToNameSet` idName dfun_id) }}
874 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
875 -- Gets both the external-package inst-env
876 -- and the home-pkg inst env (includes module being compiled)
877 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
878 return (eps_inst_env eps, tcg_inst_env env) }
883 %************************************************************************
887 %************************************************************************
889 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
890 a do-expression. We have to find (>>) in the current environment, which is
891 done by the rename. Then we have to check that it has the same type as
892 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
895 (>>) :: HB m n mn => m a -> n b -> mn b
897 So the idea is to generate a local binding for (>>), thus:
899 let then72 :: forall a b. m a -> m b -> m b
900 then72 = ...something involving the user's (>>)...
902 ...the do-expression...
904 Now the do-expression can proceed using then72, which has exactly
907 In fact tcSyntaxName just generates the RHS for then72, because we only
908 want an actual binding in the do-expression case. For literals, we can
909 just use the expression inline.
912 tcSyntaxName :: InstOrigin
913 -> TcType -- Type to instantiate it at
914 -> (Name, HsExpr Name) -- (Standard name, user name)
915 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
916 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
917 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
918 -- So we do not call it from lookupInst, which is called from tcSimplify
920 tcSyntaxName orig ty (std_nm, HsVar user_nm)
922 = newMethodFromName orig ty std_nm `thenM` \ id ->
923 returnM (std_nm, HsVar id)
925 tcSyntaxName orig ty (std_nm, user_nm_expr)
926 = tcLookupId std_nm `thenM` \ std_id ->
928 -- C.f. newMethodAtLoc
929 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
930 sigma1 = substTyWith [tv] [ty] tau
931 -- Actually, the "tau-type" might be a sigma-type in the
932 -- case of locally-polymorphic methods.
934 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $
936 -- Check that the user-supplied thing has the
937 -- same type as the standard one.
938 -- Tiresome jiggling because tcCheckSigma takes a located expression
939 getSrcSpanM `thenM` \ span ->
940 tcPolyExpr (L span user_nm_expr) sigma1 `thenM` \ expr ->
941 returnM (std_nm, unLoc expr)
943 syntaxNameCtxt name orig ty tidy_env
944 = getInstLoc orig `thenM` \ inst_loc ->
946 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
947 ptext SLIT("(needed by a syntactic construct)"),
948 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
949 nest 2 (ptext SLIT("arising from") <+> pprInstLoc inst_loc)]
951 returnM (tidy_env, msg)
954 %************************************************************************
958 %************************************************************************
961 mkGivenCo :: Coercion -> Either TcTyVar Coercion
964 mkWantedCo :: TcTyVar -> Either TcTyVar Coercion
967 fromGivenCo :: Either TcTyVar Coercion -> Coercion
968 fromGivenCo (Right co) = co
969 fromGivenCo _ = panic "fromGivenCo: not a wanted coercion"
971 fromWantedCo :: String -> Either TcTyVar Coercion -> TcTyVar
972 fromWantedCo _ (Left covar) = covar
973 fromWantedCo msg _ = panic ("fromWantedCo: not a wanted coercion: " ++ msg)
976 :: Inst -- given or wanted EqInst
977 -> (TcTyVar -> a) -- result if wanted
978 -> (Coercion -> a) -- result if given
980 eitherEqInst (EqInst {tci_co = either_co}) withWanted withGiven
982 Left covar -> withWanted covar
983 Right co -> withGiven co
985 mkEqInsts :: [PredType] -> [Either TcTyVar Coercion] -> TcM [Inst]
986 mkEqInsts preds cos = zipWithM mkEqInst preds cos
988 mkEqInst :: PredType -> Either TcTyVar Coercion -> TcM Inst
989 mkEqInst (EqPred ty1 ty2) co
990 = do { uniq <- newUnique
991 ; src_span <- getSrcSpanM
992 ; err_ctxt <- getErrCtxt
993 ; let loc = InstLoc EqOrigin src_span err_ctxt
994 name = mkName uniq src_span
995 inst = EqInst {tci_left = ty1, tci_right = ty2, tci_co = co, tci_loc = loc, tci_name = name}
998 where mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span
1001 -- We want to promote the wanted EqInst to a given EqInst
1002 -- in the signature context.
1003 -- This means we have to give the coercion a name
1004 -- and fill it in as its own name.
1007 -> TcM Inst -- given
1008 finalizeEqInst wanted@(EqInst {tci_left = ty1, tci_right = ty2, tci_name = name})
1009 = do { let var = Var.mkCoVar name (PredTy $ EqPred ty1 ty2)
1010 ; writeWantedCoercion wanted (TyVarTy var)
1011 ; let given = wanted { tci_co = mkGivenCo $ TyVarTy var }
1016 :: Inst -- wanted EqInst
1017 -> Coercion -- coercion to fill the hole with
1019 writeWantedCoercion wanted co
1020 = do { let cotv = fromWantedCo "writeWantedCoercion" $ tci_co wanted
1021 ; writeMetaTyVar cotv co
1024 eqInstType :: Inst -> TcType
1025 eqInstType inst = eitherEqInst inst mkTyVarTy id
1027 eqInstCoercion :: Inst -> Either TcTyVar Coercion
1028 eqInstCoercion = tci_co
1030 eqInstLeftTy, eqInstRightTy :: Inst -> TcType
1031 eqInstLeftTy = tci_left
1032 eqInstRightTy = tci_right
1034 updateEqInstCoercion :: (Either TcTyVar Coercion -> Either TcTyVar Coercion) -> Inst -> Inst
1035 updateEqInstCoercion f inst = inst {tci_co = f $ tci_co inst}