X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FInst.lhs;h=13b8be80b8fdcd3f3bb9ea3de8237bba4bd7d0b2;hp=3bfde1c830bfbbfe3301314689d8fbbd8f058384;hb=4ba96c06f2b69ea1fe2b27718013713e94c1520c;hpb=bf40e268d916947786c56ec38db86190854a2d2c diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 3bfde1c..13b8be8 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -1,9 +1,18 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[Inst]{The @Inst@ type: dictionaries or method instances} + +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, @@ -15,84 +24,79 @@ module Inst ( newDictBndr, newDictBndrs, newDictBndrsO, instCall, instStupidTheta, cloneDict, - shortCutFracLit, shortCutIntLit, newIPDict, + shortCutFracLit, shortCutIntLit, shortCutStringLit, newIPDict, newMethod, newMethodFromName, newMethodWithGivenTy, tcInstClassOp, tcSyntaxName, isHsVar, tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts, - instLoc, getDictClassTys, dictPred, + getDictClassTys, dictPred, - lookupInst, LookupInstResult(..), lookupPred, + lookupSimpleInst, LookupInstResult(..), tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag, - isDict, isClassDict, isMethod, - isIPDict, isInheritableInst, + isAbstractableInst, isEqInst, + isDict, isClassDict, isMethod, isImplicInst, + isIPDict, isInheritableInst, isMethodOrLit, isTyVarDict, isMethodFor, zonkInst, zonkInsts, - instToId, instToVar, instName, + instToId, instToVar, instType, instName, + + InstOrigin(..), InstLoc, pprInstLoc, - InstOrigin(..), InstLoc(..), pprInstLoc + mkWantedCo, mkGivenCo, + fromWantedCo, fromGivenCo, + eitherEqInst, mkEqInst, mkEqInsts, mkWantedEqInst, + finalizeEqInst, writeWantedCoercion, + eqInstType, updateEqInstCoercion, + eqInstCoercion, + eqInstLeftTy, eqInstRightTy ) where #include "HsVersions.h" import {-# SOURCE #-} TcExpr( tcPolyExpr ) -import {-# SOURCE #-} TcUnify( unifyType ) +import {-# SOURCE #-} TcUnify( boxyUnify, unifyType ) -import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp, - HsWrapper(..), (<.>), mkWpTyApps, idHsWrapper, - nlHsLit, nlHsVar ) -import TcHsSyn ( zonkId ) +import FastString(FastString) +import HsSyn +import TcHsSyn import TcRnMonad -import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy ) -import InstEnv ( DFunId, InstEnv, Instance(..), OverlapFlag(..), - lookupInstEnv, extendInstEnv, pprInstances, - instanceHead, instanceDFunId, setInstanceDFunId ) -import FunDeps ( checkFunDeps ) -import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zonkTcThetaType, - tcInstTyVar, tcInstSkolType - ) -import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcPredType, - BoxyRhoType, - PredType(..), SkolemInfo(..), typeKind, mkSigmaTy, - tcSplitForAllTys, applyTys, - tcSplitPhiTy, tcSplitDFunHead, - isIntTy,isFloatTy, isIntegerTy, isDoubleTy, - mkPredTy, mkTyVarTys, - tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred, - isClassPred, isTyVarClassPred, - getClassPredTys, mkPredName, - isInheritablePred, isIPPred, - tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy, - pprPred, pprParendType, pprTheta - ) -import Type ( TvSubst, substTy, substTyVar, substTyWith, - notElemTvSubst, extendTvSubstList ) -import Unify ( tcMatchTys ) -import Module ( modulePackageId ) -import {- Kind parts of -} Type ( isSubKind ) -import Coercion ( isEqPred ) -import HscTypes ( ExternalPackageState(..), HscEnv(..) ) -import CoreFVs ( idFreeTyVars ) -import DataCon ( dataConWrapId ) -import Id ( Id, idName, idType, mkUserLocal, mkLocalId, isId ) -import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule, - isInternalName, setNameUnique ) -import NameSet ( addOneToNameSet ) -import Literal ( inIntRange ) -import Var ( Var, TyVar, tyVarKind, setIdType, isId, mkTyVar ) -import VarEnv ( TidyEnv, emptyTidyEnv ) -import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet ) -import TysWiredIn ( floatDataCon, doubleDataCon ) -import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName ) -import BasicTypes( IPName(..), mapIPName, ipNameName ) -import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) ) -import DynFlags ( DynFlag(..), DynFlags(..), dopt ) -import Maybes ( isJust ) +import TcEnv +import InstEnv +import FunDeps +import TcMType +import TcType +import Type +import TypeRep +import Class +import Unify +import Module +import Coercion +import HscTypes +import CoreFVs +import DataCon +import Id +import Name +import NameSet +import Literal +import Var ( Var, TyVar ) +import qualified Var +import VarEnv +import VarSet +import TysWiredIn +import PrelNames +import BasicTypes +import SrcLoc +import DynFlags +import Maybes +import Util import Outputable +import Data.List +import TypeRep +import Class \end{code} @@ -100,28 +104,57 @@ Selection ~~~~~~~~~ \begin{code} instName :: Inst -> Name -instName inst = idName (instToId inst) +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 :: Inst -> Var -instToVar (LitInst nm _ ty _) = mkLocalId nm ty -instToVar (Method id _ _ _ _) = id -instToVar (Dict nm pred _) - | isEqPred pred = mkTyVar nm (mkPredTy pred) +instToVar (LitInst {tci_name = nm, tci_ty = ty}) + = mkLocalId nm ty +instToVar (Method {tci_id = id}) + = id +instToVar (Dict {tci_name = nm, tci_pred = pred}) + | isEqPred pred = Var.mkCoVar nm (mkPredTy pred) | otherwise = mkLocalId nm (mkPredTy pred) - -instLoc (Dict _ _ loc) = loc -instLoc (Method _ _ _ _ loc) = loc -instLoc (LitInst _ _ _ loc) = loc - -dictPred (Dict _ pred _ ) = pred -dictPred inst = pprPanic "dictPred" (ppr inst) - -getDictClassTys (Dict _ pred _) = getClassPredTys pred +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 (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 ) + -- pprTrace "mkImplicTy" (ppr givens) $ + -- 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 +getDictClassTys inst = pprPanic "getDictClassTys" (ppr inst) -- fdPredsOfInst is used to get predicates that contain functional -- dependencies *or* might do so. The "might do" part is because @@ -129,35 +162,46 @@ getDictClassTys (Dict _ pred _) = getClassPredTys pred -- Leaving these in is really important for the call to fdPredsOfInsts -- in TcSimplify.inferLoop, because the result is fed to 'grow', -- which is supposed to be conservative -fdPredsOfInst (Dict _ pred _) = [pred] -fdPredsOfInst (Method _ _ _ theta _) = theta -fdPredsOfInst other = [] -- LitInsts etc +fdPredsOfInst (Dict {tci_pred = pred}) = [pred] +fdPredsOfInst (Method {tci_theta = theta}) = theta +fdPredsOfInst (ImplicInst {tci_given = gs, + tci_wanted = ws}) = fdPredsOfInsts (gs ++ ws) +fdPredsOfInst (LitInst {}) = [] +fdPredsOfInst (EqInst {}) = [] fdPredsOfInsts :: [Inst] -> [PredType] fdPredsOfInsts insts = concatMap fdPredsOfInst insts -isInheritableInst (Dict _ pred _) = isInheritablePred pred -isInheritableInst (Method _ _ _ theta _) = all isInheritablePred theta -isInheritableInst other = True +isInheritableInst (Dict {tci_pred = pred}) = isInheritablePred pred +isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta +isInheritableInst other = True +--------------------------------- +-- Get the implicit parameters mentioned by these Insts +-- NB: the results of these functions are insensitive to zonking + ipNamesOfInsts :: [Inst] -> [Name] ipNamesOfInst :: Inst -> [Name] --- Get the implicit parameters mentioned by these Insts --- NB: ?x and %x get different Names ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst] -ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n] -ipNamesOfInst (Method _ _ _ theta _) = [ipNameName n | IParam n _ <- theta] -ipNamesOfInst other = [] +ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n] +ipNamesOfInst (Method {tci_theta = theta}) = [ipNameName n | IParam n _ <- theta] +ipNamesOfInst other = [] +--------------------------------- tyVarsOfInst :: Inst -> TcTyVarSet -tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty -tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred -tyVarsOfInst (Method _ id tys _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id - -- The id might have free type variables; in the case of - -- locally-overloaded class methods, for example - +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` 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 + `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) @@ -166,31 +210,46 @@ tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie) 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 +isDict (Dict {}) = True +isDict other = False isClassDict :: Inst -> Bool -isClassDict (Dict _ pred _) = isClassPred pred -isClassDict other = False +isClassDict (Dict {tci_pred = pred}) = isClassPred pred +isClassDict other = False isTyVarDict :: Inst -> Bool -isTyVarDict (Dict _ pred _) = isTyVarClassPred pred -isTyVarDict other = False +isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred +isTyVarDict other = False isIPDict :: Inst -> Bool -isIPDict (Dict _ pred _) = isIPPred pred -isIPDict other = False +isIPDict (Dict {tci_pred = pred}) = isIPPred pred +isIPDict other = False + +isImplicInst (ImplicInst {}) = True +isImplicInst other = False isMethod :: Inst -> Bool isMethod (Method {}) = True isMethod other = False isMethodFor :: TcIdSet -> Inst -> Bool -isMethodFor ids (Method uniq id tys _ loc) = id `elemVarSet` ids -isMethodFor ids inst = False -\end{code} +isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids +isMethodFor ids inst = False +isMethodOrLit :: Inst -> Bool +isMethodOrLit (Method {}) = True +isMethodOrLit (LitInst {}) = True +isMethodOrLit other = False +\end{code} %************************************************************************ @@ -213,10 +272,19 @@ newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst] 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 (instLocSrcLoc inst_loc) pred - ; return (Dict name pred inst_loc) } + ; let name = mkPredName uniq inst_loc pred + ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) } ---------------- instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper @@ -224,12 +292,11 @@ instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper -- (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) } ---------------- @@ -238,35 +305,48 @@ instStupidTheta :: InstOrigin -> TcThetaType -> TcM () -- 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 (instLocSrcLoc loc) pred - dict = Dict name pred loc - ; (dicts, co_fn) <- instCallDicts loc preds - ; return (dict:dicts, co_fn <.> WpApp (instToId dict)) } + ; let name = mkPredName uniq loc pred + dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc} + ; extendLIE dict + ; co_fn <- instCallDicts loc preds + ; return (co_fn <.> WpApp (instToId dict)) } ------------- -cloneDict :: Inst -> TcM Inst -- Only used for linear implicit params -cloneDict (Dict nm ty loc) = newUnique `thenM` \ uniq -> - returnM (Dict (setNameUnique nm uniq) ty loc) +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 -- at any time, so we used to use the name of the implicit parameter itself @@ -279,13 +359,29 @@ newIPDict orig ip_name ty newUnique `thenM` \ uniq -> let pred = IParam ip_name ty - name = mkPredName uniq (instLocSrcLoc inst_loc) pred - dict = Dict name pred inst_loc + name = mkPredName uniq inst_loc pred + dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc} in returnM (mapIPName (\n -> instToId dict) ip_name, dict) \end{code} +\begin{code} +mkPredName :: Unique -> InstLoc -> PredType -> Name +mkPredName uniq loc pred_ty + = 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, if there is one, to + -- improve readability of Core code + baseOcc = case splitTyConApp_maybe ty of + Nothing -> mkOccName tcName "$" + Just (tc, _) -> getOccName tc +\end{code} %************************************************************************ %* * @@ -337,12 +433,12 @@ checkKind :: TyVar -> TcType -> TcM () checkKind tv ty = do { let ty1 = ty -- ty1 <- zonkTcType ty - ; if typeKind ty1 `isSubKind` tyVarKind tv + ; if typeKind ty1 `isSubKind` Var.tyVarKind tv then return () else pprPanic "checkKind: adding kind constraint" - (vcat [ppr tv <+> ppr (tyVarKind tv), + (vcat [ppr tv <+> ppr (Var.tyVarKind tv), ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)]) } -- do { tv1 <- tcInstTyVar tv @@ -355,8 +451,9 @@ newMethod inst_loc id tys let (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys) meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc - inst = Method meth_id id tys theta inst_loc - loc = instLocSrcLoc inst_loc + inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys, + tci_theta = theta, tci_loc = inst_loc} + loc = instLocSpan inst_loc in returnM inst \end{code} @@ -380,6 +477,12 @@ shortCutFracLit f ty 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 -> @@ -392,6 +495,12 @@ mkRatLit r 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 @@ -408,11 +517,11 @@ Zonking makes sure that the instance types are fully zonked. \begin{code} zonkInst :: Inst -> TcM Inst -zonkInst (Dict name pred loc) +zonkInst dict@(Dict { tci_pred = pred}) = zonkTcPredType pred `thenM` \ new_pred -> - returnM (Dict name new_pred loc) + returnM (dict {tci_pred = new_pred}) -zonkInst (Method m id tys theta loc) +zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta}) = zonkId id `thenM` \ new_id -> -- Essential to zonk the id in case it's a local variable -- Can't use zonkIdOcc because the id might itself be @@ -420,11 +529,27 @@ zonkInst (Method m id tys theta loc) zonkTcTypes tys `thenM` \ new_tys -> zonkTcThetaType theta `thenM` \ new_theta -> - returnM (Method m new_id new_tys new_theta loc) + returnM (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta }) + -- No need to zonk the tci_id -zonkInst (LitInst nm lit ty loc) +zonkInst lit@(LitInst {tci_ty = ty}) = zonkTcType ty `thenM` \ new_ty -> - returnM (LitInst nm lit new_ty loc) + returnM (lit {tci_ty = new_ty}) + +zonkInst implic@(ImplicInst {}) + = ASSERT( all isImmutableTyVar (tci_tyvars implic) ) + do { givens' <- zonkInsts (tci_given implic) + ; 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 -> zonkTcType co >>= \coercion -> return (mkGivenCo coercion)) + ; ty1' <- zonkTcType ty1 + ; ty2' <- zonkTcType ty2 + ; return (eqinst {tci_co = co',tci_left=ty1',tci_right=ty2}) + } zonkInsts insts = mappM zonkInst insts \end{code} @@ -445,36 +570,51 @@ instance Outputable Inst where pprDictsTheta :: [Inst] -> SDoc -- Print in type-like fashion (Eq a, Show b) -pprDictsTheta dicts = pprTheta (map dictPred dicts) +-- The Inst can be an implication constraint, but not a Method or LitInst +pprDictsTheta insts = parens (sep (punctuate comma (map (ppr . instType) insts))) pprDictsInFull :: [Inst] -> SDoc -- Print in type-like fashion, but with source location pprDictsInFull dicts = vcat (map go dicts) where - go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))] + go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)] pprInsts :: [Inst] -> SDoc -- Debugging: print the evidence :: type -pprInsts insts = brackets (interpp'SP insts) +pprInsts insts = brackets (interpp'SP insts) pprInst, pprInstInFull :: Inst -> SDoc -- Debugging: print the evidence :: type -pprInst (LitInst nm lit ty loc) = ppr nm <+> dcolon <+> ppr ty -pprInst (Dict nm pred loc) = ppr nm <+> dcolon <+> pprPred pred - -pprInst m@(Method inst_id id tys theta loc) - = ppr inst_id <+> dcolon <+> - braces (sep [ppr id <+> ptext SLIT("at"), - brackets (sep (map pprParendType tys))]) +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)) $$ + ifPprDebug implic_stuff) + where + implic_stuff | isImplicInst inst = ppr (tci_reft inst) + | otherwise = empty -pprInstInFull inst - = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))] +pprInstInFull inst@(EqInst {}) = pprInst inst +pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)] tidyInst :: TidyEnv -> Inst -> Inst -tidyInst env (LitInst nm lit ty loc) = LitInst nm lit (tidyType env ty) loc -tidyInst env (Dict nm pred loc) = Dict nm (tidyPred env pred) loc -tidyInst env (Method u id tys theta loc) = Method u id (tidyTypes env tys) theta loc +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} +tidyInst env implic@(ImplicInst {}) + = implic { tci_tyvars = tvs' + , tci_given = map (tidyInst env') (tci_given implic) + , tci_wanted = map (tidyInst env') (tci_wanted implic) } + where + (env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic) tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst]) -- This function doesn't assume that the tyvars are in scope @@ -524,7 +664,7 @@ addLocalInst home_ie ispec -- We use tcInstSkolType because we don't want to allocate fresh -- *meta* type variables. let dfun = instanceDFunId ispec - ; (tvs', theta', tau') <- tcInstSkolType (InstSkol dfun) (idType dfun) + ; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun) ; let (cls, tys') = tcSplitDFunHead tau' dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau') ispec' = setInstanceDFunId ispec dfun' @@ -542,7 +682,7 @@ addLocalInst home_ie ispec -- 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. @@ -557,8 +697,8 @@ addLocalInst home_ie ispec 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 @@ -596,46 +736,48 @@ addDictLoc ispec thing_inside \begin{code} data LookupInstResult = NoInstance - | SimpleInst (LHsExpr TcId) -- Just a variable, type application, or literal - | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts + | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts + +lookupSimpleInst :: Inst -> TcM LookupInstResult +-- This is "simple" in that it returns NoInstance for implication constraints -lookupInst :: Inst -> TcM LookupInstResult -- 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 --- Methods +--------------------- Implications ------------------------ +lookupSimpleInst (ImplicInst {}) = return NoInstance -lookupInst inst@(Method _ id tys theta loc) - = do { (dicts, dict_app) <- instCallDicts loc theta +--------------------- Methods ------------------------ +lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc}) + = 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 - span = instLocSrcSpan loc - --- Literals + span = instLocSpan loc +--------------------- Literals ------------------------ -- Look for short cuts first: if the literal is *definitely* a -- int, integer, float or a double, generate the real thing here. -- This is essential (see nofib/spectral/nucleic). -- [Same shortcut as in newOverloadedLit, but we -- may have done some unification by now] -lookupInst inst@(LitInst _nm (HsIntegral i from_integer_name) ty 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)) -- GenInst, not SimpleInst, because - -- expr may be a constructor application + = returnM (GenInst [] (noLoc expr)) | otherwise = ASSERT( from_integer_name `isHsVar` fromIntegerName ) -- A LitInst invariant tcLookupId fromIntegerName `thenM` \ from_integer -> tcInstClassOp loc from_integer [ty] `thenM` \ method_inst -> mkIntegerLit i `thenM` \ integer_lit -> returnM (GenInst [method_inst] - (mkHsApp (L (instLocSrcSpan loc) + (mkHsApp (L (instLocSpan loc) (HsVar (instToId method_inst))) integer_lit)) -lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty 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)) @@ -644,27 +786,28 @@ lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc) tcLookupId fromRationalName `thenM` \ from_rational -> tcInstClassOp loc from_rational [ty] `thenM` \ method_inst -> mkRatLit f `thenM` \ rat_lit -> - returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc) + returnM (GenInst [method_inst] (mkHsApp (L (instLocSpan loc) (HsVar (instToId method_inst))) rat_lit)) --- Dictionaries -lookupInst (Dict _ pred 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 + = 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 @@ -673,36 +816,32 @@ lookupInst (Dict _ pred loc) -- 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 - src_loc = instLocSrcSpan loc + (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 (SimpleInst (L src_loc $ HsWrap (mkWpTyApps tys) dfun)) + 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, @@ -710,7 +849,7 @@ lookupPred pred@(ClassP clas tys) <+> 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" <+> @@ -725,7 +864,7 @@ lookupPred pred@(ClassP clas tys) ; return Nothing } }} -lookupPred ip_pred = return Nothing +lookupPred ip_pred = return Nothing -- Implicit parameters record_dfun_usage dfun_id = do { hsc_env <- getTopEnv @@ -814,7 +953,96 @@ syntaxNameCtxt name orig ty tidy_env msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+> ptext SLIT("(needed by a syntactic construct)"), nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)), - nest 2 (pprInstLoc inst_loc)] + nest 2 (ptext SLIT("arising from") <+> pprInstLoc inst_loc)] 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 <- newMetaTyVar TauTv (mkCoKind 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 + +eqInstLeftTy, eqInstRightTy :: Inst -> TcType +eqInstLeftTy = tci_left +eqInstRightTy = tci_right + +updateEqInstCoercion :: (Either TcTyVar Coercion -> Either TcTyVar Coercion) -> Inst -> Inst +updateEqInstCoercion f inst = inst {tci_co = f $ tci_co inst} +\end{code}