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
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
19 pprInstances, pprDictsTheta, pprDictsInFull, -- User error messages
20 showLIE, pprInst, pprInsts, pprInstInFull, -- Debugging messages
22 tidyInsts, tidyMoreInsts,
24 newDictBndr, newDictBndrs, newDictBndrsO,
25 instCall, instStupidTheta,
27 shortCutFracLit, shortCutIntLit, shortCutStringLit, newIPDict,
28 newMethod, newMethodFromName, newMethodWithGivenTy,
30 tcSyntaxName, isHsVar,
32 tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
33 ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
34 getDictClassTys, dictPred,
36 lookupSimpleInst, LookupInstResult(..),
37 tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
39 isAbstractableInst, isEqInst,
40 isDict, isClassDict, isMethod, isImplicInst,
41 isIPDict, isInheritableInst, isMethodOrLit,
42 isTyVarDict, isMethodFor,
45 instToId, instToVar, instType, instName, instToDictBind,
48 InstOrigin(..), InstLoc, pprInstLoc,
50 mkWantedCo, mkGivenCo,
51 fromWantedCo, fromGivenCo,
52 eitherEqInst, mkEqInst, mkEqInsts, mkWantedEqInst,
53 finalizeEqInst, writeWantedCoercion,
54 eqInstType, updateEqInstCoercion,
56 eqInstLeftTy, eqInstRightTy
59 #include "HsVersions.h"
61 import {-# SOURCE #-} TcExpr( tcPolyExpr )
62 import {-# SOURCE #-} TcUnify( boxyUnify, unifyType )
64 import FastString(FastString)
86 import Var ( Var, TyVar )
108 instName :: Inst -> Name
109 instName (EqInst {tci_name = name}) = name
110 instName inst = Var.varName (instToVar inst)
112 instToId :: Inst -> TcId
113 instToId inst = WARN( not (isId id), ppr inst )
118 instToVar :: Inst -> Var
119 instToVar (LitInst {tci_name = nm, tci_ty = ty})
121 instToVar (Method {tci_id = id})
123 instToVar (Dict {tci_name = nm, tci_pred = pred})
124 | isEqPred pred = Var.mkCoVar nm (mkPredTy pred)
125 | otherwise = mkLocalId nm (mkPredTy pred)
126 instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens,
127 tci_wanted = wanteds})
128 = mkLocalId nm (mkImplicTy tvs givens wanteds)
129 instToVar i@(EqInst {})
130 = eitherEqInst i id (\(TyVarTy covar) -> covar)
132 instType :: Inst -> Type
133 instType (LitInst {tci_ty = ty}) = ty
134 instType (Method {tci_id = id}) = idType id
135 instType (Dict {tci_pred = pred}) = mkPredTy pred
136 instType imp@(ImplicInst {}) = mkImplicTy (tci_tyvars imp) (tci_given imp)
138 -- instType i@(EqInst {tci_co = co}) = eitherEqInst i TyVarTy id
139 instType (EqInst {tci_left = ty1, tci_right = ty2}) = mkPredTy (EqPred ty1 ty2)
141 mkImplicTy tvs givens wanteds -- The type of an implication constraint
142 = ASSERT( all isDict givens )
143 -- pprTrace "mkImplicTy" (ppr givens) $
144 -- See [Equational Constraints in Implication Constraints]
145 let dict_wanteds = filter (not . isEqInst) wanteds
148 mkPhiTy (map dictPred givens) $
149 if isSingleton dict_wanteds then
150 instType (head dict_wanteds)
152 mkTupleTy Boxed (length dict_wanteds) (map instType dict_wanteds)
154 dictPred (Dict {tci_pred = pred}) = pred
155 dictPred (EqInst {tci_left=ty1,tci_right=ty2}) = EqPred ty1 ty2
156 dictPred inst = pprPanic "dictPred" (ppr inst)
158 getDictClassTys (Dict {tci_pred = pred}) = getClassPredTys pred
159 getDictClassTys inst = pprPanic "getDictClassTys" (ppr inst)
161 -- fdPredsOfInst is used to get predicates that contain functional
162 -- dependencies *or* might do so. The "might do" part is because
163 -- a constraint (C a b) might have a superclass with FDs
164 -- Leaving these in is really important for the call to fdPredsOfInsts
165 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
166 -- which is supposed to be conservative
167 fdPredsOfInst (Dict {tci_pred = pred}) = [pred]
168 fdPredsOfInst (Method {tci_theta = theta}) = theta
169 fdPredsOfInst (ImplicInst {tci_given = gs,
170 tci_wanted = ws}) = fdPredsOfInsts (gs ++ ws)
171 fdPredsOfInst (LitInst {}) = []
172 fdPredsOfInst (EqInst {}) = []
174 fdPredsOfInsts :: [Inst] -> [PredType]
175 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
177 isInheritableInst (Dict {tci_pred = pred}) = isInheritablePred pred
178 isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta
179 isInheritableInst other = True
182 ---------------------------------
183 -- Get the implicit parameters mentioned by these Insts
184 -- NB: the results of these functions are insensitive to zonking
186 ipNamesOfInsts :: [Inst] -> [Name]
187 ipNamesOfInst :: Inst -> [Name]
188 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
190 ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
191 ipNamesOfInst (Method {tci_theta = theta}) = [ipNameName n | IParam n _ <- theta]
192 ipNamesOfInst other = []
194 ---------------------------------
195 tyVarsOfInst :: Inst -> TcTyVarSet
196 tyVarsOfInst (LitInst {tci_ty = ty}) = tyVarsOfType ty
197 tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
198 tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id
199 -- The id might have free type variables; in the case of
200 -- locally-overloaded class methods, for example
201 tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds})
202 = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds)
203 `minusVarSet` mkVarSet tvs
204 `unionVarSet` unionVarSets (map varTypeTyVars tvs)
205 -- Remember the free tyvars of a coercion
206 tyVarsOfInst (EqInst {tci_left = ty1, tci_right = ty2}) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
208 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
209 tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
212 --------------------------
213 instToDictBind :: Inst -> LHsExpr TcId -> TcDictBinds
214 instToDictBind inst rhs
215 = unitBag (L (instSpan inst) (VarBind (instToId inst) rhs))
217 addInstToDictBind :: TcDictBinds -> Inst -> LHsExpr TcId -> TcDictBinds
218 addInstToDictBind binds inst rhs = binds `unionBags` instToDictBind inst rhs
225 isAbstractableInst :: Inst -> Bool
226 isAbstractableInst inst = isDict inst || isEqInst inst
228 isEqInst :: Inst -> Bool
229 isEqInst (EqInst {}) = True
230 isEqInst other = False
232 isDict :: Inst -> Bool
233 isDict (Dict {}) = True
236 isClassDict :: Inst -> Bool
237 isClassDict (Dict {tci_pred = pred}) = isClassPred pred
238 isClassDict other = False
240 isTyVarDict :: Inst -> Bool
241 isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
242 isTyVarDict other = False
244 isIPDict :: Inst -> Bool
245 isIPDict (Dict {tci_pred = pred}) = isIPPred pred
246 isIPDict other = False
248 isImplicInst (ImplicInst {}) = True
249 isImplicInst other = False
251 isMethod :: Inst -> Bool
252 isMethod (Method {}) = True
253 isMethod other = False
255 isMethodFor :: TcIdSet -> Inst -> Bool
256 isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
257 isMethodFor ids inst = False
259 isMethodOrLit :: Inst -> Bool
260 isMethodOrLit (Method {}) = True
261 isMethodOrLit (LitInst {}) = True
262 isMethodOrLit other = False
266 %************************************************************************
268 \subsection{Building dictionaries}
270 %************************************************************************
272 -- newDictBndrs makes a dictionary at a binding site
273 -- instCall makes a dictionary at an occurrence site
274 -- and throws it into the LIE
278 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
279 newDictBndrsO orig theta = do { loc <- getInstLoc orig
280 ; newDictBndrs loc theta }
282 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
283 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
285 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
286 newDictBndr inst_loc pred@(EqPred ty1 ty2)
287 = do { uniq <- newUnique
288 ; let name = mkPredName uniq inst_loc pred
289 ; return (EqInst {tci_name = name,
293 tci_co = mkGivenCo $ TyVarTy (Var.mkCoVar name (PredTy pred))})
295 newDictBndr inst_loc pred
296 = do { uniq <- newUnique
297 ; let name = mkPredName uniq inst_loc pred
298 ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
301 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
302 -- Instantiate the constraints of a call
303 -- (instCall o tys theta)
304 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
305 -- (b) Throws these dictionaries into the LIE
306 -- (c) Returns an HsWrapper ([.] tys dicts)
308 instCall orig tys theta
309 = do { loc <- getInstLoc orig
310 ; dict_app <- instCallDicts loc theta
311 ; return (dict_app <.> mkWpTyApps tys) }
314 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
315 -- Similar to instCall, but only emit the constraints in the LIE
316 -- Used exclusively for the 'stupid theta' of a data constructor
317 instStupidTheta orig theta
318 = do { loc <- getInstLoc orig
319 ; _co <- instCallDicts loc theta -- Discard the coercion
323 instCallDicts :: InstLoc -> TcThetaType -> TcM HsWrapper
324 -- Instantiates the TcTheta, puts all constraints thereby generated
325 -- into the LIE, and returns a HsWrapper to enclose the call site.
326 -- This is the key place where equality predicates
327 -- are unleashed into the world
328 instCallDicts loc [] = return idHsWrapper
330 -- instCallDicts loc (EqPred ty1 ty2 : preds)
331 -- = do { unifyType ty1 ty2 -- For now, we insist that they unify right away
332 -- -- Later on, when we do associated types,
333 -- -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
334 -- ; (dicts, co_fn) <- instCallDicts loc preds
335 -- ; return (dicts, co_fn <.> WpTyApp ty1) }
336 -- -- We use type application to apply the function to the
337 -- -- coercion; here ty1 *is* the appropriate identity coercion
339 instCallDicts loc (EqPred ty1 ty2 : preds)
340 = do { traceTc (text "instCallDicts" <+> ppr (EqPred ty1 ty2))
341 ; coi <- boxyUnify ty1 ty2
342 -- ; coi <- unifyType ty1 ty2
343 ; let co = fromCoI coi ty1
344 ; co_fn <- instCallDicts loc preds
345 ; return (co_fn <.> WpTyApp co) }
347 instCallDicts loc (pred : preds)
348 = do { uniq <- newUnique
349 ; let name = mkPredName uniq loc pred
350 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
352 ; co_fn <- instCallDicts loc preds
353 ; return (co_fn <.> WpApp (instToId dict)) }
356 cloneDict :: Inst -> TcM Inst
357 cloneDict dict@(Dict nm ty loc) = do { uniq <- newUnique
358 ; return (dict {tci_name = setNameUnique nm uniq}) }
359 cloneDict eq@(EqInst {}) = return eq
360 cloneDict other = pprPanic "cloneDict" (ppr other)
362 -- For vanilla implicit parameters, there is only one in scope
363 -- at any time, so we used to use the name of the implicit parameter itself
364 -- But with splittable implicit parameters there may be many in
365 -- scope, so we make up a new namea.
366 newIPDict :: InstOrigin -> IPName Name -> Type
367 -> TcM (IPName Id, Inst)
368 newIPDict orig ip_name ty
369 = getInstLoc orig `thenM` \ inst_loc ->
370 newUnique `thenM` \ uniq ->
372 pred = IParam ip_name ty
373 name = mkPredName uniq inst_loc pred
374 dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}
376 returnM (mapIPName (\n -> instToId dict) ip_name, dict)
381 mkPredName :: Unique -> InstLoc -> PredType -> Name
382 mkPredName uniq loc pred_ty
383 = mkInternalName uniq occ (instLocSpan loc)
385 occ = case pred_ty of
386 ClassP cls _ -> mkDictOcc (getOccName cls)
387 IParam ip _ -> getOccName (ipNameName ip)
388 EqPred ty _ -> mkEqPredCoOcc baseOcc
390 -- we use the outermost tycon of the lhs, if there is one, to
391 -- improve readability of Core code
392 baseOcc = case splitTyConApp_maybe ty of
393 Nothing -> mkOccName tcName "$"
394 Just (tc, _) -> getOccName tc
397 %************************************************************************
399 \subsection{Building methods (calls of overloaded functions)}
401 %************************************************************************
405 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
406 newMethodFromName origin ty name
407 = tcLookupId name `thenM` \ id ->
408 -- Use tcLookupId not tcLookupGlobalId; the method is almost
409 -- always a class op, but with -fno-implicit-prelude GHC is
410 -- meant to find whatever thing is in scope, and that may
411 -- be an ordinary function.
412 getInstLoc origin `thenM` \ loc ->
413 tcInstClassOp loc id [ty] `thenM` \ inst ->
414 extendLIE inst `thenM_`
415 returnM (instToId inst)
417 newMethodWithGivenTy orig id tys
418 = getInstLoc orig `thenM` \ loc ->
419 newMethod loc id tys `thenM` \ inst ->
420 extendLIE inst `thenM_`
421 returnM (instToId inst)
423 --------------------------------------------
424 -- tcInstClassOp, and newMethod do *not* drop the
425 -- Inst into the LIE; they just returns the Inst
426 -- This is important because they are used by TcSimplify
429 -- NB: the kind of the type variable to be instantiated
430 -- might be a sub-kind of the type to which it is applied,
431 -- notably when the latter is a type variable of kind ??
432 -- Hence the call to checkKind
433 -- A worry: is this needed anywhere else?
434 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
435 tcInstClassOp inst_loc sel_id tys
437 (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
439 zipWithM_ checkKind tyvars tys `thenM_`
440 newMethod inst_loc sel_id tys
442 checkKind :: TyVar -> TcType -> TcM ()
443 -- Ensure that the type has a sub-kind of the tyvar
446 -- ty1 <- zonkTcType ty
447 ; if typeKind ty1 `isSubKind` Var.tyVarKind tv
451 pprPanic "checkKind: adding kind constraint"
452 (vcat [ppr tv <+> ppr (Var.tyVarKind tv),
453 ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
455 -- do { tv1 <- tcInstTyVar tv
456 -- ; unifyType ty1 (mkTyVarTy tv1) } }
459 ---------------------------
460 newMethod inst_loc id tys
461 = newUnique `thenM` \ new_uniq ->
463 (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
464 meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
465 inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
466 tci_theta = theta, tci_loc = inst_loc}
467 loc = instLocSpan inst_loc
473 shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
475 | isIntTy ty && inIntRange i -- Short cut for Int
476 = Just (HsLit (HsInt i))
477 | isIntegerTy ty -- Short cut for Integer
478 = Just (HsLit (HsInteger i ty))
479 | otherwise = Nothing
481 shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
484 = Just (mk_lit floatDataCon (HsFloatPrim f))
486 = Just (mk_lit doubleDataCon (HsDoublePrim f))
487 | otherwise = Nothing
489 mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
491 shortCutStringLit :: FastString -> TcType -> Maybe (HsExpr TcId)
492 shortCutStringLit s ty
493 | isStringTy ty -- Short cut for String
494 = Just (HsLit (HsString s))
495 | otherwise = Nothing
497 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
499 = tcMetaTy integerTyConName `thenM` \ integer_ty ->
500 getSrcSpanM `thenM` \ span ->
501 returnM (L span $ HsLit (HsInteger i integer_ty))
503 mkRatLit :: Rational -> TcM (LHsExpr TcId)
505 = tcMetaTy rationalTyConName `thenM` \ rat_ty ->
506 getSrcSpanM `thenM` \ span ->
507 returnM (L span $ HsLit (HsRat r rat_ty))
509 mkStrLit :: FastString -> TcM (LHsExpr TcId)
511 = --tcMetaTy stringTyConName `thenM` \ string_ty ->
512 getSrcSpanM `thenM` \ span ->
513 returnM (L span $ HsLit (HsString s))
515 isHsVar :: HsExpr Name -> Name -> Bool
516 isHsVar (HsVar f) g = f==g
517 isHsVar other g = False
521 %************************************************************************
525 %************************************************************************
527 Zonking makes sure that the instance types are fully zonked.
530 zonkInst :: Inst -> TcM Inst
531 zonkInst dict@(Dict { tci_pred = pred})
532 = zonkTcPredType pred `thenM` \ new_pred ->
533 returnM (dict {tci_pred = new_pred})
535 zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta})
536 = zonkId id `thenM` \ new_id ->
537 -- Essential to zonk the id in case it's a local variable
538 -- Can't use zonkIdOcc because the id might itself be
539 -- an InstId, in which case it won't be in scope
541 zonkTcTypes tys `thenM` \ new_tys ->
542 zonkTcThetaType theta `thenM` \ new_theta ->
543 returnM (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
544 -- No need to zonk the tci_id
546 zonkInst lit@(LitInst {tci_ty = ty})
547 = zonkTcType ty `thenM` \ new_ty ->
548 returnM (lit {tci_ty = new_ty})
550 zonkInst implic@(ImplicInst {})
551 = ASSERT( all isImmutableTyVar (tci_tyvars implic) )
552 do { givens' <- zonkInsts (tci_given implic)
553 ; wanteds' <- zonkInsts (tci_wanted implic)
554 ; return (implic {tci_given = givens',tci_wanted = wanteds'}) }
556 zonkInst eqinst@(EqInst {tci_left = ty1, tci_right = ty2})
557 = do { co' <- eitherEqInst eqinst
558 (\covar -> return (mkWantedCo covar))
559 (\co -> zonkTcType co >>= \coercion -> return (mkGivenCo coercion))
560 ; ty1' <- zonkTcType ty1
561 ; ty2' <- zonkTcType ty2
562 ; return (eqinst {tci_co = co',tci_left=ty1',tci_right=ty2})
565 zonkInsts insts = mappM zonkInst insts
569 %************************************************************************
571 \subsection{Printing}
573 %************************************************************************
575 ToDo: improve these pretty-printing things. The ``origin'' is really only
576 relevant in error messages.
579 instance Outputable Inst where
580 ppr inst = pprInst inst
582 pprDictsTheta :: [Inst] -> SDoc
583 -- Print in type-like fashion (Eq a, Show b)
584 -- The Inst can be an implication constraint, but not a Method or LitInst
585 pprDictsTheta insts = parens (sep (punctuate comma (map (ppr . instType) insts)))
587 pprDictsInFull :: [Inst] -> SDoc
588 -- Print in type-like fashion, but with source location
590 = vcat (map go dicts)
592 go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
594 pprInsts :: [Inst] -> SDoc
595 -- Debugging: print the evidence :: type
596 pprInsts insts = brackets (interpp'SP insts)
598 pprInst, pprInstInFull :: Inst -> SDoc
599 -- Debugging: print the evidence :: type
600 pprInst i@(EqInst {tci_left = ty1, tci_right = ty2, tci_co = co})
602 (\covar -> text "Wanted" <+> ppr (TyVarTy covar) <+> dcolon <+> ppr (EqPred ty1 ty2))
603 (\co -> text "Given" <+> ppr co <+> dcolon <+> ppr (EqPred ty1 ty2))
604 pprInst inst = ppr (instName inst) <+> dcolon
605 <+> (braces (ppr (instType inst)) $$
606 ifPprDebug implic_stuff)
608 implic_stuff | isImplicInst inst = ppr (tci_reft inst)
611 pprInstInFull inst@(EqInst {}) = pprInst inst
612 pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
614 tidyInst :: TidyEnv -> Inst -> Inst
615 tidyInst env eq@(EqInst {tci_left = lty, tci_right = rty, tci_co = co}) =
616 eq { tci_left = tidyType env lty
617 , tci_right = tidyType env rty
618 , tci_co = either Left (Right . tidyType env) co
620 tidyInst env lit@(LitInst {tci_ty = ty}) = lit {tci_ty = tidyType env ty}
621 tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
622 tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
623 tidyInst env implic@(ImplicInst {})
624 = implic { tci_tyvars = tvs'
625 , tci_given = map (tidyInst env') (tci_given implic)
626 , tci_wanted = map (tidyInst env') (tci_wanted implic) }
628 (env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic)
630 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
631 -- This function doesn't assume that the tyvars are in scope
632 -- so it works like tidyOpenType, returning a TidyEnv
633 tidyMoreInsts env insts
634 = (env', map (tidyInst env') insts)
636 env' = tidyFreeTyVars env (tyVarsOfInsts insts)
638 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
639 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
641 showLIE :: SDoc -> TcM () -- Debugging
643 = do { lie_var <- getLIEVar ;
644 lie <- readMutVar lie_var ;
645 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
649 %************************************************************************
651 Extending the instance environment
653 %************************************************************************
656 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
657 -- Add new locally-defined instances
658 tcExtendLocalInstEnv dfuns thing_inside
659 = do { traceDFuns dfuns
661 ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
662 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
663 tcg_inst_env = inst_env' }
664 ; setGblEnv env' thing_inside }
666 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
667 -- Check that the proposed new instance is OK,
668 -- and then add it to the home inst env
669 addLocalInst home_ie ispec
670 = do { -- Instantiate the dfun type so that we extend the instance
671 -- envt with completely fresh template variables
672 -- This is important because the template variables must
673 -- not overlap with anything in the things being looked up
674 -- (since we do unification).
675 -- We use tcInstSkolType because we don't want to allocate fresh
676 -- *meta* type variables.
677 let dfun = instanceDFunId ispec
678 ; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun)
679 ; let (cls, tys') = tcSplitDFunHead tau'
680 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
681 ispec' = setInstanceDFunId ispec dfun'
683 -- Load imported instances, so that we report
684 -- duplicates correctly
686 ; let inst_envs = (eps_inst_env eps, home_ie)
688 -- Check functional dependencies
689 ; case checkFunDeps inst_envs ispec' of
690 Just specs -> funDepErr ispec' specs
693 -- Check for duplicate instance decls
694 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
695 ; dup_ispecs = [ dup_ispec
696 | (dup_ispec, _) <- matches
697 , let (_,_,_,dup_tys) = instanceHead dup_ispec
698 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
699 -- Find memebers of the match list which ispec itself matches.
700 -- If the match is 2-way, it's a duplicate
702 dup_ispec : _ -> dupInstErr ispec' dup_ispec
705 -- OK, now extend the envt
706 ; return (extendInstEnv home_ie ispec') }
708 getOverlapFlag :: TcM OverlapFlag
710 = do { dflags <- getDOpts
711 ; let overlap_ok = dopt Opt_OverlappingInstances dflags
712 incoherent_ok = dopt Opt_IncoherentInstances dflags
713 overlap_flag | incoherent_ok = Incoherent
714 | overlap_ok = OverlapOk
715 | otherwise = NoOverlap
717 ; return overlap_flag }
720 = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
722 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
723 -- Print the dfun name itself too
725 funDepErr ispec ispecs
727 addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
728 2 (pprInstances (ispec:ispecs)))
729 dupInstErr ispec dup_ispec
731 addErr (hang (ptext SLIT("Duplicate instance declarations:"))
732 2 (pprInstances [ispec, dup_ispec]))
734 addDictLoc ispec thing_inside
735 = setSrcSpan (mkSrcSpan loc loc) thing_inside
737 loc = getSrcLoc ispec
741 %************************************************************************
743 \subsection{Looking up Insts}
745 %************************************************************************
748 data LookupInstResult
750 | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
752 lookupSimpleInst :: Inst -> TcM LookupInstResult
753 -- This is "simple" in that it returns NoInstance for implication constraints
755 -- It's important that lookupInst does not put any new stuff into
756 -- the LIE. Instead, any Insts needed by the lookup are returned in
757 -- the LookupInstResult, where they can be further processed by tcSimplify
759 lookupSimpleInst (EqInst {}) = return NoInstance
761 --------------------- Implications ------------------------
762 lookupSimpleInst (ImplicInst {}) = return NoInstance
764 --------------------- Methods ------------------------
765 lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
766 = do { (dict_app, dicts) <- getLIE $ instCallDicts loc theta
767 ; let co_fn = dict_app <.> mkWpTyApps tys
768 ; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
770 span = instLocSpan loc
772 --------------------- Literals ------------------------
773 -- Look for short cuts first: if the literal is *definitely* a
774 -- int, integer, float or a double, generate the real thing here.
775 -- This is essential (see nofib/spectral/nucleic).
776 -- [Same shortcut as in newOverloadedLit, but we
777 -- may have done some unification by now]
779 lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name, tci_ty = ty, tci_loc = loc})
780 | Just expr <- shortCutIntLit i ty
781 = returnM (GenInst [] (noLoc expr))
783 = ASSERT( from_integer_name `isHsVar` fromIntegerName ) -- A LitInst invariant
784 tcLookupId fromIntegerName `thenM` \ from_integer ->
785 tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
786 mkIntegerLit i `thenM` \ integer_lit ->
787 returnM (GenInst [method_inst]
788 (mkHsApp (L (instLocSpan loc)
789 (HsVar (instToId method_inst))) integer_lit))
791 lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name, tci_ty = ty, tci_loc = loc})
792 | Just expr <- shortCutFracLit f ty
793 = returnM (GenInst [] (noLoc expr))
796 = ASSERT( from_rat_name `isHsVar` fromRationalName ) -- A LitInst invariant
797 tcLookupId fromRationalName `thenM` \ from_rational ->
798 tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
799 mkRatLit f `thenM` \ rat_lit ->
800 returnM (GenInst [method_inst] (mkHsApp (L (instLocSpan loc)
801 (HsVar (instToId method_inst))) rat_lit))
803 lookupSimpleInst (LitInst {tci_lit = HsIsString s from_string_name, tci_ty = ty, tci_loc = loc})
804 | Just expr <- shortCutStringLit s ty
805 = returnM (GenInst [] (noLoc expr))
807 = ASSERT( from_string_name `isHsVar` fromStringName ) -- A LitInst invariant
808 tcLookupId fromStringName `thenM` \ from_string ->
809 tcInstClassOp loc from_string [ty] `thenM` \ method_inst ->
810 mkStrLit s `thenM` \ string_lit ->
811 returnM (GenInst [method_inst]
812 (mkHsApp (L (instLocSpan loc)
813 (HsVar (instToId method_inst))) string_lit))
815 --------------------- Dictionaries ------------------------
816 lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
817 = do { mb_result <- lookupPred pred
818 ; case mb_result of {
819 Nothing -> return NoInstance ;
820 Just (dfun_id, mb_inst_tys) -> do
822 { use_stage <- getStage
823 ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
824 (topIdLvl dfun_id) use_stage
826 -- It's possible that not all the tyvars are in
827 -- the substitution, tenv. For example:
828 -- instance C X a => D X where ...
829 -- (presumably there's a functional dependency in class C)
830 -- Hence mb_inst_tys :: Either TyVar TcType
832 ; let inst_tv (Left tv) = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
833 inst_tv (Right ty) = return ty
834 ; tys <- mappM inst_tv mb_inst_tys
836 (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
837 src_loc = instLocSpan loc
840 returnM (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
842 { (dict_app, dicts) <- getLIE $ instCallDicts loc theta -- !!!
843 ; let co_fn = dict_app <.> mkWpTyApps tys
844 ; returnM (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
848 lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
849 -- Look up a class constraint in the instance environment
850 lookupPred pred@(ClassP clas tys)
852 ; tcg_env <- getGblEnv
853 ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
854 ; case lookupInstEnv inst_envs clas tys of {
855 ([(ispec, inst_tys)], [])
856 -> do { let dfun_id = is_dfun ispec
857 ; traceTc (text "lookupInst success" <+>
858 vcat [text "dict" <+> ppr pred,
859 text "witness" <+> ppr dfun_id
860 <+> ppr (idType dfun_id) ])
861 -- Record that this dfun is needed
862 ; record_dfun_usage dfun_id
863 ; return (Just (dfun_id, inst_tys)) } ;
866 -> do { traceTc (text "lookupInst fail" <+>
867 vcat [text "dict" <+> ppr pred,
868 text "matches" <+> ppr matches,
869 text "unifs" <+> ppr unifs])
870 -- In the case of overlap (multiple matches) we report
871 -- NoInstance here. That has the effect of making the
872 -- context-simplifier return the dict as an irreducible one.
873 -- Then it'll be given to addNoInstanceErrs, which will do another
874 -- lookupInstEnv to get the detailed info about what went wrong.
878 lookupPred ip_pred = return Nothing -- Implicit parameters
880 record_dfun_usage dfun_id
881 = do { hsc_env <- getTopEnv
882 ; let dfun_name = idName dfun_id
883 dfun_mod = nameModule dfun_name
884 ; if isInternalName dfun_name || -- Internal name => defined in this module
885 modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
886 then return () -- internal, or in another package
887 else do { tcg_env <- getGblEnv
888 ; updMutVar (tcg_inst_uses tcg_env)
889 (`addOneToNameSet` idName dfun_id) }}
892 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
893 -- Gets both the external-package inst-env
894 -- and the home-pkg inst env (includes module being compiled)
895 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
896 return (eps_inst_env eps, tcg_inst_env env) }
901 %************************************************************************
905 %************************************************************************
907 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
908 a do-expression. We have to find (>>) in the current environment, which is
909 done by the rename. Then we have to check that it has the same type as
910 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
913 (>>) :: HB m n mn => m a -> n b -> mn b
915 So the idea is to generate a local binding for (>>), thus:
917 let then72 :: forall a b. m a -> m b -> m b
918 then72 = ...something involving the user's (>>)...
920 ...the do-expression...
922 Now the do-expression can proceed using then72, which has exactly
925 In fact tcSyntaxName just generates the RHS for then72, because we only
926 want an actual binding in the do-expression case. For literals, we can
927 just use the expression inline.
930 tcSyntaxName :: InstOrigin
931 -> TcType -- Type to instantiate it at
932 -> (Name, HsExpr Name) -- (Standard name, user name)
933 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
934 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
935 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
936 -- So we do not call it from lookupInst, which is called from tcSimplify
938 tcSyntaxName orig ty (std_nm, HsVar user_nm)
940 = newMethodFromName orig ty std_nm `thenM` \ id ->
941 returnM (std_nm, HsVar id)
943 tcSyntaxName orig ty (std_nm, user_nm_expr)
944 = tcLookupId std_nm `thenM` \ std_id ->
946 -- C.f. newMethodAtLoc
947 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
948 sigma1 = substTyWith [tv] [ty] tau
949 -- Actually, the "tau-type" might be a sigma-type in the
950 -- case of locally-polymorphic methods.
952 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $
954 -- Check that the user-supplied thing has the
955 -- same type as the standard one.
956 -- Tiresome jiggling because tcCheckSigma takes a located expression
957 getSrcSpanM `thenM` \ span ->
958 tcPolyExpr (L span user_nm_expr) sigma1 `thenM` \ expr ->
959 returnM (std_nm, unLoc expr)
961 syntaxNameCtxt name orig ty tidy_env
962 = getInstLoc orig `thenM` \ inst_loc ->
964 msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
965 ptext SLIT("(needed by a syntactic construct)"),
966 nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
967 nest 2 (ptext SLIT("arising from") <+> pprInstLoc inst_loc)]
969 returnM (tidy_env, msg)
972 %************************************************************************
976 %************************************************************************
979 mkGivenCo :: Coercion -> Either TcTyVar Coercion
982 mkWantedCo :: TcTyVar -> Either TcTyVar Coercion
985 fromGivenCo :: Either TcTyVar Coercion -> Coercion
986 fromGivenCo (Right co) = co
987 fromGivenCo _ = panic "fromGivenCo: not a wanted coercion"
989 fromWantedCo :: String -> Either TcTyVar Coercion -> TcTyVar
990 fromWantedCo _ (Left covar) = covar
991 fromWantedCo msg _ = panic ("fromWantedCo: not a wanted coercion: " ++ msg)
993 eitherEqInst :: Inst -- given or wanted EqInst
994 -> (TcTyVar -> a) -- result if wanted
995 -> (Coercion -> a) -- result if given
997 eitherEqInst (EqInst {tci_co = either_co}) withWanted withGiven
999 Left covar -> withWanted covar
1000 Right co -> withGiven co
1002 mkEqInsts :: [PredType] -> [Either TcTyVar Coercion] -> TcM [Inst]
1003 mkEqInsts preds cos = zipWithM mkEqInst preds cos
1005 mkEqInst :: PredType -> Either TcTyVar Coercion -> TcM Inst
1006 mkEqInst (EqPred ty1 ty2) co
1007 = do { uniq <- newUnique
1008 ; src_span <- getSrcSpanM
1009 ; err_ctxt <- getErrCtxt
1010 ; let loc = InstLoc EqOrigin src_span err_ctxt
1011 name = mkName uniq src_span
1012 inst = EqInst {tci_left = ty1, tci_right = ty2, tci_co = co, tci_loc = loc, tci_name = name}
1015 where mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span
1017 mkWantedEqInst :: PredType -> TcM Inst
1018 mkWantedEqInst pred@(EqPred ty1 ty2)
1019 = do { cotv <- newMetaCoVar ty1 ty2
1020 ; mkEqInst pred (Left cotv)
1024 -- We want to promote the wanted EqInst to a given EqInst
1025 -- in the signature context.
1026 -- This means we have to give the coercion a name
1027 -- and fill it in as its own name.
1030 -> TcM Inst -- given
1031 finalizeEqInst wanted@(EqInst {tci_left = ty1, tci_right = ty2, tci_name = name})
1032 = do { let var = Var.mkCoVar name (PredTy $ EqPred ty1 ty2)
1033 ; writeWantedCoercion wanted (TyVarTy var)
1034 ; let given = wanted { tci_co = mkGivenCo $ TyVarTy var }
1039 :: Inst -- wanted EqInst
1040 -> Coercion -- coercion to fill the hole with
1042 writeWantedCoercion wanted co
1043 = do { let cotv = fromWantedCo "writeWantedCoercion" $ tci_co wanted
1044 ; writeMetaTyVar cotv co
1047 eqInstType :: Inst -> TcType
1048 eqInstType inst = eitherEqInst inst mkTyVarTy id
1050 eqInstCoercion :: Inst -> Either TcTyVar Coercion
1051 eqInstCoercion = tci_co
1053 eqInstLeftTy, eqInstRightTy :: Inst -> TcType
1054 eqInstLeftTy = tci_left
1055 eqInstRightTy = tci_right
1057 updateEqInstCoercion :: (Either TcTyVar Coercion -> Either TcTyVar Coercion) -> Inst -> Inst
1058 updateEqInstCoercion f inst = inst {tci_co = f $ tci_co inst}