The @Inst@ type: dictionaries or method instances
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module Inst (
Inst,
newDictBndr, newDictBndrs, newDictBndrsO,
instCall, instStupidTheta,
cloneDict,
- shortCutFracLit, shortCutIntLit, newIPDict,
+ shortCutFracLit, shortCutIntLit, shortCutStringLit, newIPDict,
newMethod, newMethodFromName, newMethodWithGivenTy,
tcInstClassOp,
tcSyntaxName, isHsVar,
ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
getDictClassTys, dictPred,
- lookupSimpleInst, LookupInstResult(..), lookupPred,
+ lookupSimpleInst, LookupInstResult(..),
tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
+ isAbstractableInst, isEqInst,
isDict, isClassDict, isMethod, isImplicInst,
isIPDict, isInheritableInst, isMethodOrLit,
- isTyVarDict, isMethodFor, getDefaultableDicts,
+ isTyVarDict, isMethodFor,
zonkInst, zonkInsts,
- instToId, instToVar, instName,
+ instToId, instToVar, instType, instName, instToDictBind,
+ addInstToDictBind,
+
+ InstOrigin(..), InstLoc, pprInstLoc,
- InstOrigin(..), InstLoc, pprInstLoc
+ mkWantedCo, mkGivenCo,
+ fromWantedCo, fromGivenCo,
+ eitherEqInst, mkEqInst, mkEqInsts, mkWantedEqInst,
+ finalizeEqInst, writeWantedCoercion,
+ eqInstType, updateEqInstCoercion,
+ eqInstCoercion, eqInstTys
) where
#include "HsVersions.h"
import {-# SOURCE #-} TcExpr( tcPolyExpr )
-import {-# SOURCE #-} TcUnify( unifyType )
+import {-# SOURCE #-} TcUnify( boxyUnify, unifyType )
+import FastString(FastString)
import HsSyn
import TcHsSyn
import TcRnMonad
import TcMType
import TcType
import Type
+import TypeRep
import Class
import Unify
import Module
import BasicTypes
import SrcLoc
import DynFlags
+import Bag
import Maybes
import Util
import Outputable
+import Data.List
+import TypeRep
+import Class
+
+import Control.Monad ( liftM )
\end{code}
~~~~~~~~~
\begin{code}
instName :: Inst -> Name
+instName (EqInst {tci_name = name}) = name
instName inst = Var.varName (instToVar inst)
instToId :: Inst -> TcId
-instToId inst = ASSERT2( isId id, ppr inst ) id
+instToId inst = WARN( not (isId id), ppr inst )
+ id
where
id = instToVar inst
instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens,
tci_wanted = wanteds})
= mkLocalId nm (mkImplicTy tvs givens wanteds)
+instToVar i@(EqInst {})
+ = eitherEqInst i id (\(TyVarTy covar) -> covar)
instType :: Inst -> Type
-instType (LitInst {tci_ty = ty}) = ty
-instType (Method {tci_id = id}) = idType id
+instType (LitInst {tci_ty = ty}) = ty
+instType (Method {tci_id = id}) = idType id
instType (Dict {tci_pred = pred}) = mkPredTy pred
instType imp@(ImplicInst {}) = mkImplicTy (tci_tyvars imp) (tci_given imp)
(tci_wanted imp)
+-- instType i@(EqInst {tci_co = co}) = eitherEqInst i TyVarTy id
+instType (EqInst {tci_left = ty1, tci_right = ty2}) = mkPredTy (EqPred ty1 ty2)
mkImplicTy tvs givens wanteds -- The type of an implication constraint
- = ASSERT( all isDict givens )
+ = ASSERT( all isAbstractableInst givens )
-- pprTrace "mkImplicTy" (ppr givens) $
- mkForAllTys tvs $
- mkPhiTy (map dictPred givens) $
- if isSingleton wanteds then
- instType (head wanteds)
- else
- mkTupleTy Boxed (length wanteds) (map instType wanteds)
+ -- See [Equational Constraints in Implication Constraints]
+ let dict_wanteds = filter (not . isEqInst) wanteds
+ in
+ mkForAllTys tvs $
+ mkPhiTy (map dictPred givens) $
+ if isSingleton dict_wanteds then
+ instType (head dict_wanteds)
+ else
+ mkTupleTy Boxed (length dict_wanteds) (map instType dict_wanteds)
dictPred (Dict {tci_pred = pred}) = pred
+dictPred (EqInst {tci_left=ty1,tci_right=ty2}) = EqPred ty1 ty2
dictPred inst = pprPanic "dictPred" (ppr inst)
getDictClassTys (Dict {tci_pred = pred}) = getClassPredTys pred
fdPredsOfInst (ImplicInst {tci_given = gs,
tci_wanted = ws}) = fdPredsOfInsts (gs ++ ws)
fdPredsOfInst (LitInst {}) = []
+fdPredsOfInst (EqInst {}) = []
fdPredsOfInsts :: [Inst] -> [PredType]
fdPredsOfInsts insts = concatMap fdPredsOfInst insts
tyVarsOfInst :: Inst -> TcTyVarSet
tyVarsOfInst (LitInst {tci_ty = ty}) = tyVarsOfType ty
tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
-tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
+tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id
-- The id might have free type variables; in the case of
-- locally-overloaded class methods, for example
tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds})
- = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds) `minusVarSet` mkVarSet tvs
-
+ = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds)
+ `minusVarSet` mkVarSet tvs
+ `unionVarSet` unionVarSets (map varTypeTyVars tvs)
+ -- Remember the free tyvars of a coercion
+tyVarsOfInst (EqInst {tci_left = ty1, tci_right = ty2}) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
+
+
+--------------------------
+instToDictBind :: Inst -> LHsExpr TcId -> TcDictBinds
+instToDictBind inst rhs
+ = unitBag (L (instSpan inst) (VarBind (instToId inst) rhs))
+
+addInstToDictBind :: TcDictBinds -> Inst -> LHsExpr TcId -> TcDictBinds
+addInstToDictBind binds inst rhs = binds `unionBags` instToDictBind inst rhs
\end{code}
Predicates
~~~~~~~~~~
\begin{code}
+
+isAbstractableInst :: Inst -> Bool
+isAbstractableInst inst = isDict inst || isEqInst inst
+
+isEqInst :: Inst -> Bool
+isEqInst (EqInst {}) = True
+isEqInst other = False
+
isDict :: Inst -> Bool
isDict (Dict {}) = True
isDict other = False
isMethodOrLit other = False
\end{code}
-\begin{code}
-getDefaultableDicts :: [Inst] -> ([(Inst, Class, TcTyVar)], TcTyVarSet)
--- Look for free dicts of the form (C tv), even inside implications
--- *and* the set of tyvars mentioned by all *other* constaints
--- This disgustingly ad-hoc function is solely to support defaulting
-getDefaultableDicts insts
- = (concat ps, unionVarSets tvs)
- where
- (ps, tvs) = mapAndUnzip get insts
- get d@(Dict {tci_pred = ClassP cls [ty]})
- | Just tv <- tcGetTyVar_maybe ty = ([(d,cls,tv)], emptyVarSet)
- | otherwise = ([], tyVarsOfType ty)
- get (ImplicInst {tci_tyvars = tvs, tci_wanted = wanteds})
- = ([ up | up@(_,_,tv) <- ups, not (tv `elemVarSet` tv_set)],
- ftvs `minusVarSet` tv_set)
- where
- tv_set = mkVarSet tvs
- (ups, ftvs) = getDefaultableDicts wanteds
- get inst = ([], tyVarsOfInst inst)
-\end{code}
%************************************************************************
%* *
newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
newDictBndr :: InstLoc -> TcPredType -> TcM Inst
+newDictBndr inst_loc pred@(EqPred ty1 ty2)
+ = do { uniq <- newUnique
+ ; let name = mkPredName uniq inst_loc pred
+ ; return (EqInst {tci_name = name,
+ tci_loc = inst_loc,
+ tci_left = ty1,
+ tci_right = ty2,
+ tci_co = mkGivenCo $ TyVarTy (Var.mkCoVar name (PredTy pred))})
+ }
newDictBndr inst_loc pred
= do { uniq <- newUnique
; let name = mkPredName uniq inst_loc pred
-- (instCall o tys theta)
-- (a) Makes fresh dictionaries as necessary for the constraints (theta)
-- (b) Throws these dictionaries into the LIE
--- (c) Eeturns an HsWrapper ([.] tys dicts)
+-- (c) Returns an HsWrapper ([.] tys dicts)
instCall orig tys theta
= do { loc <- getInstLoc orig
- ; (dicts, dict_app) <- instCallDicts loc theta
- ; extendLIEs dicts
+ ; dict_app <- instCallDicts loc theta
; return (dict_app <.> mkWpTyApps tys) }
----------------
-- Used exclusively for the 'stupid theta' of a data constructor
instStupidTheta orig theta
= do { loc <- getInstLoc orig
- ; (dicts, _) <- instCallDicts loc theta
- ; extendLIEs dicts }
+ ; _co <- instCallDicts loc theta -- Discard the coercion
+ ; return () }
----------------
-instCallDicts :: InstLoc -> TcThetaType -> TcM ([Inst], HsWrapper)
+instCallDicts :: InstLoc -> TcThetaType -> TcM HsWrapper
+-- Instantiates the TcTheta, puts all constraints thereby generated
+-- into the LIE, and returns a HsWrapper to enclose the call site.
-- This is the key place where equality predicates
-- are unleashed into the world
-instCallDicts loc [] = return ([], idHsWrapper)
+instCallDicts loc [] = return idHsWrapper
+
+-- instCallDicts loc (EqPred ty1 ty2 : preds)
+-- = do { unifyType ty1 ty2 -- For now, we insist that they unify right away
+-- -- Later on, when we do associated types,
+-- -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
+-- ; (dicts, co_fn) <- instCallDicts loc preds
+-- ; return (dicts, co_fn <.> WpTyApp ty1) }
+-- -- We use type application to apply the function to the
+-- -- coercion; here ty1 *is* the appropriate identity coercion
instCallDicts loc (EqPred ty1 ty2 : preds)
- = do { unifyType ty1 ty2 -- For now, we insist that they unify right away
- -- Later on, when we do associated types,
- -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
- ; (dicts, co_fn) <- instCallDicts loc preds
- ; return (dicts, co_fn <.> WpTyApp ty1) }
- -- We use type application to apply the function to the
- -- coercion; here ty1 *is* the appropriate identity coercion
+ = do { traceTc (text "instCallDicts" <+> ppr (EqPred ty1 ty2))
+ ; coi <- boxyUnify ty1 ty2
+-- ; coi <- unifyType ty1 ty2
+ ; let co = fromCoI coi ty1
+ ; co_fn <- instCallDicts loc preds
+ ; return (co_fn <.> WpTyApp co) }
instCallDicts loc (pred : preds)
= do { uniq <- newUnique
; let name = mkPredName uniq loc pred
dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
- ; (dicts, co_fn) <- instCallDicts loc preds
- ; return (dict:dicts, co_fn <.> WpApp (instToId dict)) }
+ ; extendLIE dict
+ ; co_fn <- instCallDicts loc preds
+ ; return (co_fn <.> WpApp (instToId dict)) }
-------------
-cloneDict :: Inst -> TcM Inst -- Only used for linear implicit params
+cloneDict :: Inst -> TcM Inst
cloneDict dict@(Dict nm ty loc) = do { uniq <- newUnique
; return (dict {tci_name = setNameUnique nm uniq}) }
+cloneDict eq@(EqInst {}) = return eq
cloneDict other = pprPanic "cloneDict" (ppr other)
-- For vanilla implicit parameters, there is only one in scope
\begin{code}
mkPredName :: Unique -> InstLoc -> PredType -> Name
mkPredName uniq loc pred_ty
- = mkInternalName uniq occ (srcSpanStart (instLocSpan loc))
+ = mkInternalName uniq occ (instLocSpan loc)
where
occ = case pred_ty of
ClassP cls _ -> mkDictOcc (getOccName cls)
IParam ip _ -> getOccName (ipNameName ip)
EqPred ty _ -> mkEqPredCoOcc baseOcc
where
- -- we use the outermost tycon of the lhs, which must be a type
- -- function, as the base name for an equality
+ -- we use the outermost tycon of the lhs, if there is one, to
+ -- improve readability of Core code
baseOcc = case splitTyConApp_maybe ty of
- Nothing ->
- pprPanic "Inst.mkPredName:" (ppr ty)
+ Nothing -> mkOccName tcName "$"
Just (tc, _) -> getOccName tc
\end{code}
meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
tci_theta = theta, tci_loc = inst_loc}
- loc = srcSpanStart (instLocSpan inst_loc)
+ loc = instLocSpan inst_loc
in
returnM inst
\end{code}
where
mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
+shortCutStringLit :: FastString -> TcType -> Maybe (HsExpr TcId)
+shortCutStringLit s ty
+ | isStringTy ty -- Short cut for String
+ = Just (HsLit (HsString s))
+ | otherwise = Nothing
+
mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
mkIntegerLit i
= tcMetaTy integerTyConName `thenM` \ integer_ty ->
getSrcSpanM `thenM` \ span ->
returnM (L span $ HsLit (HsRat r rat_ty))
+mkStrLit :: FastString -> TcM (LHsExpr TcId)
+mkStrLit s
+ = --tcMetaTy stringTyConName `thenM` \ string_ty ->
+ getSrcSpanM `thenM` \ span ->
+ returnM (L span $ HsLit (HsString s))
+
isHsVar :: HsExpr Name -> Name -> Bool
isHsVar (HsVar f) g = f==g
isHsVar other g = False
; wanteds' <- zonkInsts (tci_wanted implic)
; return (implic {tci_given = givens',tci_wanted = wanteds'}) }
+zonkInst eqinst@(EqInst {tci_left = ty1, tci_right = ty2})
+ = do { co' <- eitherEqInst eqinst
+ (\covar -> return (mkWantedCo covar))
+ (\co -> liftM mkGivenCo $ zonkTcType co)
+ ; ty1' <- zonkTcType ty1
+ ; ty2' <- zonkTcType ty2
+ ; return (eqinst {tci_co = co', tci_left= ty1', tci_right = ty2' })
+ }
+
zonkInsts insts = mappM zonkInst insts
\end{code}
pprInst, pprInstInFull :: Inst -> SDoc
-- Debugging: print the evidence :: type
+pprInst i@(EqInst {tci_left = ty1, tci_right = ty2, tci_co = co})
+ = eitherEqInst i
+ (\covar -> text "Wanted" <+> ppr (TyVarTy covar) <+> dcolon <+> ppr (EqPred ty1 ty2))
+ (\co -> text "Given" <+> ppr co <+> dcolon <+> ppr (EqPred ty1 ty2))
pprInst inst = ppr (instName inst) <+> dcolon
- <+> (braces (ppr (instType inst)) $$
+ <+> (braces (ppr (instType inst) <> implicWantedEqs) $$
ifPprDebug implic_stuff)
where
- implic_stuff | isImplicInst inst = ppr (tci_reft inst)
- | otherwise = empty
+ (implic_stuff, implicWantedEqs)
+ | isImplicInst inst = (ppr (tci_reft inst),
+ text " &" <+>
+ ppr (filter isEqInst (tci_wanted inst)))
+ | otherwise = (empty, empty)
+pprInstInFull inst@(EqInst {}) = pprInst inst
pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
tidyInst :: TidyEnv -> Inst -> Inst
+tidyInst env eq@(EqInst {tci_left = lty, tci_right = rty, tci_co = co}) =
+ eq { tci_left = tidyType env lty
+ , tci_right = tidyType env rty
+ , tci_co = either Left (Right . tidyType env) co
+ }
tidyInst env lit@(LitInst {tci_ty = ty}) = lit {tci_ty = tidyType env ty}
tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
-- Check for duplicate instance decls
; let { (matches, _) = lookupInstEnv inst_envs cls tys'
; dup_ispecs = [ dup_ispec
- | (_, dup_ispec) <- matches
+ | (dup_ispec, _) <- matches
, let (_,_,_,dup_tys) = instanceHead dup_ispec
, isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
-- Find memebers of the match list which ispec itself matches.
getOverlapFlag :: TcM OverlapFlag
getOverlapFlag
= do { dflags <- getDOpts
- ; let overlap_ok = dopt Opt_AllowOverlappingInstances dflags
- incoherent_ok = dopt Opt_AllowIncoherentInstances dflags
+ ; let overlap_ok = dopt Opt_OverlappingInstances dflags
+ incoherent_ok = dopt Opt_IncoherentInstances dflags
overlap_flag | incoherent_ok = Incoherent
| overlap_ok = OverlapOk
| otherwise = NoOverlap
| GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
lookupSimpleInst :: Inst -> TcM LookupInstResult
--- This is "simple" in tthat it returns NoInstance for implication constraints
+-- This is "simple" in that it returns NoInstance for implication constraints
-- It's important that lookupInst does not put any new stuff into
-- the LIE. Instead, any Insts needed by the lookup are returned in
-- the LookupInstResult, where they can be further processed by tcSimplify
+lookupSimpleInst (EqInst {}) = return NoInstance
+
--------------------- Implications ------------------------
lookupSimpleInst (ImplicInst {}) = return NoInstance
--------------------- Methods ------------------------
lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
- = do { (dicts, dict_app) <- instCallDicts loc theta
+ = do { (dict_app, dicts) <- getLIE $ instCallDicts loc theta
; let co_fn = dict_app <.> mkWpTyApps tys
; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
where
-- [Same shortcut as in newOverloadedLit, but we
-- may have done some unification by now]
-lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name, tci_ty = ty, tci_loc = loc})
+lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name _, tci_ty = ty, tci_loc = loc})
| Just expr <- shortCutIntLit i ty
= returnM (GenInst [] (noLoc expr))
| otherwise
(mkHsApp (L (instLocSpan loc)
(HsVar (instToId method_inst))) integer_lit))
-lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name, tci_ty = ty, tci_loc = loc})
+lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name _, tci_ty = ty, tci_loc = loc})
| Just expr <- shortCutFracLit f ty
= returnM (GenInst [] (noLoc expr))
returnM (GenInst [method_inst] (mkHsApp (L (instLocSpan loc)
(HsVar (instToId method_inst))) rat_lit))
+lookupSimpleInst (LitInst {tci_lit = HsIsString s from_string_name _, tci_ty = ty, tci_loc = loc})
+ | Just expr <- shortCutStringLit s ty
+ = returnM (GenInst [] (noLoc expr))
+ | otherwise
+ = ASSERT( from_string_name `isHsVar` fromStringName ) -- A LitInst invariant
+ tcLookupId fromStringName `thenM` \ from_string ->
+ tcInstClassOp loc from_string [ty] `thenM` \ method_inst ->
+ mkStrLit s `thenM` \ string_lit ->
+ returnM (GenInst [method_inst]
+ (mkHsApp (L (instLocSpan loc)
+ (HsVar (instToId method_inst))) string_lit))
+
--------------------- Dictionaries ------------------------
lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
= do { mb_result <- lookupPred pred
; case mb_result of {
Nothing -> return NoInstance ;
- Just (tenv, dfun_id) -> do
-
- -- tenv is a substitution that instantiates the dfun_id
- -- to match the requested result type.
- --
- -- We ASSUME that the dfun is quantified over the very same tyvars
- -- that are bound by the tenv.
- --
- -- However, the dfun
- -- might have some tyvars that *only* appear in arguments
- -- dfun :: forall a b. C a b, Ord b => D [a]
- -- We instantiate b to a flexi type variable -- it'll presumably
- -- become fixed later via functional dependencies
+ Just (dfun_id, mb_inst_tys) -> do
+
{ use_stage <- getStage
; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
(topIdLvl dfun_id) use_stage
-- the substitution, tenv. For example:
-- instance C X a => D X where ...
-- (presumably there's a functional dependency in class C)
- -- Hence the open_tvs to instantiate any un-substituted tyvars.
- ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
- open_tvs = filter (`notElemTvSubst` tenv) tyvars
- ; open_tvs' <- mappM tcInstTyVar open_tvs
+ -- Hence mb_inst_tys :: Either TyVar TcType
+
+ ; let inst_tv (Left tv) = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
+ inst_tv (Right ty) = return ty
+ ; tys <- mappM inst_tv mb_inst_tys
; let
- tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
- -- Since the open_tvs' are freshly made, they cannot possibly be captured by
- -- any nested for-alls in rho. So the in-scope set is unchanged
- dfun_rho = substTy tenv' rho
- (theta, _) = tcSplitPhiTy dfun_rho
+ (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
src_loc = instLocSpan loc
dfun = HsVar dfun_id
- tys = map (substTyVar tenv') tyvars
; if null theta then
returnM (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
else do
- { (dicts, dict_app) <- instCallDicts loc theta
+ { (dict_app, dicts) <- getLIE $ instCallDicts loc theta -- !!!
; let co_fn = dict_app <.> mkWpTyApps tys
; returnM (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
}}}}
---------------
-lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
+lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
-- Look up a class constraint in the instance environment
lookupPred pred@(ClassP clas tys)
= do { eps <- getEps
; tcg_env <- getGblEnv
; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
; case lookupInstEnv inst_envs clas tys of {
- ([(tenv, ispec)], [])
+ ([(ispec, inst_tys)], [])
-> do { let dfun_id = is_dfun ispec
; traceTc (text "lookupInst success" <+>
vcat [text "dict" <+> ppr pred,
<+> ppr (idType dfun_id) ])
-- Record that this dfun is needed
; record_dfun_usage dfun_id
- ; return (Just (tenv, dfun_id)) } ;
+ ; return (Just (dfun_id, inst_tys)) } ;
(matches, unifs)
-> do { traceTc (text "lookupInst fail" <+>
in
returnM (tidy_env, msg)
\end{code}
+
+%************************************************************************
+%* *
+ EqInsts
+%* *
+%************************************************************************
+
+\begin{code}
+mkGivenCo :: Coercion -> Either TcTyVar Coercion
+mkGivenCo = Right
+
+mkWantedCo :: TcTyVar -> Either TcTyVar Coercion
+mkWantedCo = Left
+
+fromGivenCo :: Either TcTyVar Coercion -> Coercion
+fromGivenCo (Right co) = co
+fromGivenCo _ = panic "fromGivenCo: not a wanted coercion"
+
+fromWantedCo :: String -> Either TcTyVar Coercion -> TcTyVar
+fromWantedCo _ (Left covar) = covar
+fromWantedCo msg _ = panic ("fromWantedCo: not a wanted coercion: " ++ msg)
+
+eitherEqInst :: Inst -- given or wanted EqInst
+ -> (TcTyVar -> a) -- result if wanted
+ -> (Coercion -> a) -- result if given
+ -> a
+eitherEqInst (EqInst {tci_co = either_co}) withWanted withGiven
+ = case either_co of
+ Left covar -> withWanted covar
+ Right co -> withGiven co
+
+mkEqInsts :: [PredType] -> [Either TcTyVar Coercion] -> TcM [Inst]
+mkEqInsts preds cos = zipWithM mkEqInst preds cos
+
+mkEqInst :: PredType -> Either TcTyVar Coercion -> TcM Inst
+mkEqInst (EqPred ty1 ty2) co
+ = do { uniq <- newUnique
+ ; src_span <- getSrcSpanM
+ ; err_ctxt <- getErrCtxt
+ ; let loc = InstLoc EqOrigin src_span err_ctxt
+ name = mkName uniq src_span
+ inst = EqInst {tci_left = ty1, tci_right = ty2, tci_co = co, tci_loc = loc, tci_name = name}
+ ; return inst
+ }
+ where mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span
+
+mkWantedEqInst :: PredType -> TcM Inst
+mkWantedEqInst pred@(EqPred ty1 ty2)
+ = do { cotv <- newMetaCoVar ty1 ty2
+ ; mkEqInst pred (Left cotv)
+ }
+
+-- type inference:
+-- We want to promote the wanted EqInst to a given EqInst
+-- in the signature context.
+-- This means we have to give the coercion a name
+-- and fill it in as its own name.
+finalizeEqInst
+ :: Inst -- wanted
+ -> TcM Inst -- given
+finalizeEqInst wanted@(EqInst {tci_left = ty1, tci_right = ty2, tci_name = name})
+ = do { let var = Var.mkCoVar name (PredTy $ EqPred ty1 ty2)
+ ; writeWantedCoercion wanted (TyVarTy var)
+ ; let given = wanted { tci_co = mkGivenCo $ TyVarTy var }
+ ; return given
+ }
+
+writeWantedCoercion
+ :: Inst -- wanted EqInst
+ -> Coercion -- coercion to fill the hole with
+ -> TcM ()
+writeWantedCoercion wanted co
+ = do { let cotv = fromWantedCo "writeWantedCoercion" $ tci_co wanted
+ ; writeMetaTyVar cotv co
+ }
+
+eqInstType :: Inst -> TcType
+eqInstType inst = eitherEqInst inst mkTyVarTy id
+
+eqInstCoercion :: Inst -> Either TcTyVar Coercion
+eqInstCoercion = tci_co
+
+eqInstTys :: Inst -> (TcType, TcType)
+eqInstTys inst = (tci_left inst, tci_right inst)
+
+updateEqInstCoercion :: (Either TcTyVar Coercion -> Either TcTyVar Coercion) -> Inst -> Inst
+updateEqInstCoercion f inst = inst {tci_co = f $ tci_co inst}
+\end{code}
projects / ghc-hetmet.git / blobdiff