-- 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/CodingStyle#Warnings
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
module Inst (
isTyVarDict, isMethodFor,
zonkInst, zonkInsts,
- instToId, instToVar, instType, instName,
+ instToId, instToVar, instType, instName, instToDictBind,
+ addInstToDictBind,
InstOrigin(..), InstLoc, pprInstLoc,
mkWantedCo, mkGivenCo,
fromWantedCo, fromGivenCo,
- eitherEqInst, mkEqInst, mkEqInsts,
+ eitherEqInst, mkEqInst, mkEqInsts, mkWantedEqInst,
finalizeEqInst, writeWantedCoercion,
eqInstType, updateEqInstCoercion,
- eqInstCoercion,
- eqInstLeftTy, eqInstRightTy
+ eqInstCoercion, eqInstTys
) where
#include "HsVersions.h"
import BasicTypes
import SrcLoc
import DynFlags
+import Bag
import Maybes
import Util
+import Unique
import Outputable
import Data.List
import TypeRep
import Class
+
+import Control.Monad ( liftM )
\end{code}
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) $
-- See [Equational Constraints in Implication Constraints]
let dict_wanteds = filter (not . isEqInst) wanteds
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
zonkInst eqinst@(EqInst {tci_left = ty1, tci_right = ty2})
= do { co' <- eitherEqInst eqinst
- (\covar -> return (mkWantedCo covar))
- (\co -> zonkTcType co >>= \coercion -> return (mkGivenCo coercion))
+ (\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})
+ ; return (eqinst {tci_co = co', tci_left= ty1', tci_right = ty2' })
}
zonkInsts insts = mappM zonkInst insts
= 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)) $$
+pprInst inst = ppr name <> braces (pprUnique (getUnique name)) <+> dcolon
+ <+> (braces (ppr (instType inst) <> implicWantedEqs) $$
ifPprDebug implic_stuff)
where
- implic_stuff | isImplicInst inst = ppr (tci_reft inst)
- | otherwise = empty
+ name = instName inst
+ (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)]
-- [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})
+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
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 :: 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
}
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.
eqInstCoercion :: Inst -> Either TcTyVar Coercion
eqInstCoercion = tci_co
-eqInstLeftTy, eqInstRightTy :: Inst -> TcType
-eqInstLeftTy = tci_left
-eqInstRightTy = tci_right
+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}