X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FInst.lhs;h=da80df428c4493baa6c5ea938417f50de1048a25;hp=8d21d1bcb190b8973b99d40035e75f5c8e8a7b94;hb=aafdba3bce91afb003f5f50e001e141744837bae;hpb=7fc749a43b4b6b85d234fa95d4928648259584f4 diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 8d21d1b..da80df4 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -42,17 +42,17 @@ 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" @@ -91,12 +91,15 @@ import PrelNames 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} @@ -137,7 +140,7 @@ instType imp@(ImplicInst {}) = mkImplicTy (tci_tyvars imp) (tci_given imp) 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 @@ -205,6 +208,15 @@ tyVarsOfInst (EqInst {tci_left = ty1, tci_right = ty2}) = tyVarsOfType ty1 `unio 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 @@ -544,11 +556,11 @@ zonkInst implic@(ImplicInst {}) 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 @@ -591,11 +603,14 @@ pprInst i@(EqInst {tci_left = ty1, tci_right = ty2, tci_co = co}) (\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)] @@ -765,7 +780,7 @@ lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_lo -- [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 @@ -777,7 +792,7 @@ lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name, tci_ty = ty (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)) @@ -789,7 +804,7 @@ lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name, tci_ty = ty, 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 @@ -979,11 +994,10 @@ 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 :: 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 @@ -1004,6 +1018,12 @@ mkEqInst (EqPred ty1 ty2) co } 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. @@ -1034,9 +1054,8 @@ eqInstType inst = eitherEqInst inst mkTyVarTy id 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}