X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FInst.lhs;h=1e99572c5e8b809c5cf3a70a23c463d3b3fc4443;hb=7bb069508f094825ca136ed97606651f3e093123;hp=55a1a4f40a4e8f75c5fcbdf10921ad483be59c03;hpb=cfbedcecad9f9c4241fa1313e73468fd95db76b3;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 55a1a4f4..1e99572 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -11,11 +11,11 @@ module Inst ( Inst, OverloadedLit(..), pprInst, pprInsts, pprInstsInFull, tidyInst, tidyInsts, - InstanceMapper, - newDictFromOld, newDicts, newClassDicts, newDictsAtLoc, newMethod, newMethodWithGivenTy, newOverloadedLit, newIPDict, instOverloadedFun, + instantiateFdClassTys, instFunDeps, instFunDepsOfTheta, + newFunDepFromDict, tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, instLoc, getDictClassTys, getDictPred_maybe, getMethodTheta_maybe, @@ -25,7 +25,8 @@ module Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..), - isDict, isClassDict, isTyVarDict, isStdClassTyVarDict, isMethodFor, notFunDep, + isDict, isClassDict, isMethod, + isTyVarDict, isStdClassTyVarDict, isMethodFor, notFunDep, instBindingRequired, instCanBeGeneralised, zonkInst, zonkInsts, zonkFunDeps, zonkTvFunDeps, @@ -42,21 +43,22 @@ import TcHsSyn ( TcExpr, TcId, mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId ) import TcMonad -import TcEnv ( TcIdSet, tcLookupValueByKey, tcLookupTyConByKey ) +import TcEnv ( TcIdSet, InstEnv, tcGetInstEnv, lookupInstEnv, InstLookupResult(..), + tcLookupValueByKey, tcLookupTyConByKey + ) import TcType ( TcThetaType, TcType, TcTauType, TcTyVarSet, zonkTcTyVars, zonkTcType, zonkTcTypes, zonkTcThetaType ) import Bag -import Class ( classInstEnv, Class ) +import Class ( Class, FunDep ) import FunDeps ( instantiateFdClassTys ) import Id ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal ) import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass ) import Name ( OccName, Name, mkDictOcc, mkMethodOcc, mkIPOcc, getOccName, nameUnique ) import PprType ( pprPred ) -import InstEnv ( InstEnv, lookupInstEnv ) import SrcLoc ( SrcLoc ) import Type ( Type, PredType(..), ThetaType, mkTyVarTy, isTyVarTy, mkDictTy, mkPredTy, @@ -64,7 +66,6 @@ import Type ( Type, PredType(..), ThetaType, splitRhoTy, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, mkSynTy, tidyOpenType, tidyOpenTypes ) -import InstEnv ( InstEnv ) import Subst ( emptyInScopeSet, mkSubst, substTy, substClasses, mkTyVarSubst, mkTopTyVarSubst ) @@ -79,7 +80,8 @@ import TysPrim ( intPrimTy, floatPrimTy, doublePrimTy ) import TysWiredIn ( intDataCon, isIntTy, floatDataCon, isFloatTy, doubleDataCon, isDoubleTy, - integerTy, isIntegerTy + integerTy, isIntegerTy, + voidTy ) import Unique ( fromRationalClassOpKey, rationalTyConKey, fromIntClassOpKey, fromIntegerClassOpKey, Unique @@ -174,8 +176,9 @@ data Inst InstLoc | FunDep + Unique Class -- the class from which this arises - [([TcType], [TcType])] + [FunDep TcType] InstLoc data OverloadedLit @@ -192,48 +195,25 @@ maps to do their stuff. \begin{code} instance Ord Inst where compare = cmpInst -instance Ord PredType where - compare = cmpPred instance Eq Inst where (==) i1 i2 = case i1 `cmpInst` i2 of EQ -> True other -> False -instance Eq PredType where - (==) p1 p2 = case p1 `cmpPred` p2 of - EQ -> True - other -> False -cmpInst (Dict _ pred1 _) (Dict _ pred2 _) - = (pred1 `cmpPred` pred2) -cmpInst (Dict _ _ _) other - = LT - -cmpInst (Method _ _ _ _ _ _) (Dict _ _ _) - = GT -cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) - = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2) -cmpInst (Method _ _ _ _ _ _) other - = LT - -cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) - = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2) -cmpInst (LitInst _ _ _ _) (FunDep _ _ _) - = LT -cmpInst (LitInst _ _ _ _) other - = GT - -cmpInst (FunDep clas1 fds1 _) (FunDep clas2 fds2 _) - = (clas1 `compare` clas2) `thenCmp` (fds1 `compare` fds2) -cmpInst (FunDep _ _ _) other - = GT - -cmpPred (Class c1 tys1) (Class c2 tys2) - = (c1 `compare` c2) `thenCmp` (tys1 `compare` tys2) -cmpPred (IParam n1 ty1) (IParam n2 ty2) - = (n1 `compare` n2) `thenCmp` (ty1 `compare` ty2) -cmpPred (Class _ _) (IParam _ _) = LT -cmpPred _ _ = GT +cmpInst (Dict _ pred1 _) (Dict _ pred2 _) = (pred1 `compare` pred2) +cmpInst (Dict _ _ _) other = LT + +cmpInst (Method _ _ _ _ _ _) (Dict _ _ _) = GT +cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2) +cmpInst (Method _ _ _ _ _ _) other = LT + +cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2) +cmpInst (LitInst _ _ _ _) (FunDep _ _ _ _) = LT +cmpInst (LitInst _ _ _ _) other = GT + +cmpInst (FunDep _ clas1 fds1 _) (FunDep _ clas2 fds2 _) = (clas1 `compare` clas2) `thenCmp` (fds1 `compare` fds2) +cmpInst (FunDep _ _ _ _) other = GT cmpOverLit (OverloadedIntegral i1) (OverloadedIntegral i2) = i1 `compare` i2 cmpOverLit (OverloadedFractional f1) (OverloadedFractional f2) = f1 `compare` f2 @@ -248,7 +228,7 @@ Selection instLoc (Dict u pred loc) = loc instLoc (Method u _ _ _ _ loc) = loc instLoc (LitInst u lit ty loc) = loc -instLoc (FunDep _ _ loc) = loc +instLoc (FunDep _ _ _ loc) = loc getDictPred_maybe (Dict _ p _) = Just p getDictPred_maybe _ = Nothing @@ -258,7 +238,7 @@ getMethodTheta_maybe _ = Nothing getDictClassTys (Dict u (Class clas tys) _) = (clas, tys) -getFunDeps (FunDep clas fds _) = Just (clas, fds) +getFunDeps (FunDep _ clas fds _) = Just (clas, fds) getFunDeps _ = Nothing getFunDepsOfLIE lie = catMaybes (map getFunDeps (lieToList lie)) @@ -273,7 +253,7 @@ getIPs _ = [] getIPsOfLIE lie = concatMap getIPs (lieToList lie) -getAllFunDeps (FunDep clas fds _) = fds +getAllFunDeps (FunDep _ clas fds _) = fds getAllFunDeps inst = map (\(n,ty) -> ([], [ty])) (getIPs inst) getAllFunDepsOfLIE lie = concat (map getAllFunDeps (lieToList lie)) @@ -284,7 +264,7 @@ tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyV -- The id might have free type variables; in the case of -- locally-overloaded class methods, for example tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty -tyVarsOfInst (FunDep _ fds _) +tyVarsOfInst (FunDep _ _ fds _) = foldr unionVarSet emptyVarSet (map tyVarsOfFd fds) where tyVarsOfFd (ts1, ts2) = tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts2 @@ -302,16 +282,19 @@ Predicates \begin{code} isDict :: Inst -> Bool isDict (Dict _ _ _) = True -isDict other = False +isDict other = False + isClassDict :: Inst -> Bool isClassDict (Dict _ (Class _ _) _) = True -isClassDict other = False +isClassDict 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 +isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids +isMethodFor ids inst = False isTyVarDict :: Inst -> Bool isTyVarDict (Dict _ (Class _ tys) _) = all isTyVarTy tys @@ -323,8 +306,8 @@ isStdClassTyVarDict other = False notFunDep :: Inst -> Bool -notFunDep (FunDep _ _ _) = False -notFunDep other = True +notFunDep (FunDep _ _ _ _) = False +notFunDep other = True \end{code} Two predicates which deal with the case where class constraints don't @@ -395,19 +378,26 @@ newMethod orig id tys newMethodWithGivenTy orig id tys theta tau `thenNF_Tc` \ meth_inst -> returnNF_Tc (unitLIE meth_inst, instToId meth_inst) -instOverloadedFun orig (HsVar v) arg_tys theta tau +instOverloadedFun orig v arg_tys theta tau +-- This is where we introduce new functional dependencies into the LIE = newMethodWithGivenTy orig v arg_tys theta tau `thenNF_Tc` \ inst -> instFunDeps orig theta `thenNF_Tc` \ fds -> - returnNF_Tc (HsVar (instToId inst), mkLIE (inst : fds)) + returnNF_Tc (instToId inst, mkLIE (inst : fds)) instFunDeps orig theta - = tcGetInstLoc orig `thenNF_Tc` \ loc -> + = tcGetUnique `thenNF_Tc` \ uniq -> + tcGetInstLoc orig `thenNF_Tc` \ loc -> let ifd (Class clas tys) = let fds = instantiateFdClassTys clas tys in - if null fds then Nothing else Just (FunDep clas fds loc) + if null fds then Nothing else Just (FunDep uniq clas fds loc) ifd _ = Nothing in returnNF_Tc (catMaybes (map ifd theta)) +instFunDepsOfTheta theta + = let ifd (Class clas tys) = instantiateFdClassTys clas tys + ifd (IParam n ty) = [([], [ty])] + in concat (map ifd theta) + newMethodWithGivenTy orig id tys theta tau = tcGetInstLoc orig `thenNF_Tc` \ loc -> newMethodWith id tys theta tau loc @@ -465,6 +455,16 @@ newOverloadedLit orig lit ty -- The general case \end{code} \begin{code} +newFunDepFromDict dict + = tcGetUnique `thenNF_Tc` \ uniq -> + let (clas, tys) = getDictClassTys dict + fds = instantiateFdClassTys clas tys + inst = FunDep uniq clas fds (instLoc dict) + in + if null fds then returnNF_Tc Nothing else returnNF_Tc (Just inst) +\end{code} + +\begin{code} newIPDict name ty loc = tcGetUnique `thenNF_Tc` \ new_uniq -> let d = Dict new_uniq (IParam name ty) loc in @@ -487,8 +487,8 @@ instToIdBndr (Method u id tys theta tau (_,loc,_)) instToIdBndr (LitInst u list ty loc) = mkSysLocal SLIT("lit") u ty -instToIdBndr (FunDep clas fds _) - = panic "FunDep escaped!!!" +instToIdBndr (FunDep u clas fds _) + = mkSysLocal SLIT("FunDep") u voidTy ipToId n ty loc = mkUserLocal (mkIPOcc (getOccName n)) (nameUnique n) (mkPredTy (IParam n ty)) loc @@ -530,9 +530,9 @@ zonkInst (LitInst u lit ty loc) = zonkTcType ty `thenNF_Tc` \ new_ty -> returnNF_Tc (LitInst u lit new_ty loc) -zonkInst (FunDep clas fds loc) +zonkInst (FunDep u clas fds loc) = zonkFunDeps fds `thenNF_Tc` \ fds' -> - returnNF_Tc (FunDep clas fds' loc) + returnNF_Tc (FunDep u clas fds' loc) zonkPreds preds = mapNF_Tc zonkPred preds zonkInsts insts = mapNF_Tc zonkInst insts @@ -574,12 +574,12 @@ pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u pprInst m@(Method u id tys theta tau loc) = hsep [ppr id, ptext SLIT("at"), - brackets (interppSP tys), + brackets (interppSP tys) {- , ppr theta, ppr tau, show_uniq u, - ppr (instToId m)] + ppr (instToId m) -}] -pprInst (FunDep clas fds loc) +pprInst (FunDep _ clas fds loc) = hsep [ppr clas, ppr fds] tidyPred :: TidyEnv -> TcPredType -> (TidyEnv, TcPredType) @@ -610,7 +610,7 @@ tidyInst env (Method u id tys theta tau loc) (env', tys') = tidyOpenTypes env tys -- this case shouldn't arise... (we never print fundeps) -tidyInst env fd@(FunDep clas fds loc) +tidyInst env fd@(FunDep _ clas fds loc) = (env, fd) tidyInsts env insts = mapAccumL tidyInst env insts @@ -626,25 +626,6 @@ show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}") %************************************************************************ \begin{code} -type InstanceMapper = Class -> InstEnv -\end{code} - -A @ClassInstEnv@ lives inside a class, and identifies all the instances -of that class. The @Id@ inside a ClassInstEnv mapping is the dfun for -that instance. - -There is an important consistency constraint between the @MatchEnv@s -in and the dfun @Id@s inside them: the free type variables of the -@Type@ key in the @MatchEnv@ must be a subset of the universally-quantified -type variables of the dfun. Thus, the @ClassInstEnv@ for @Eq@ might -contain the following entry: -@ - [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a] -@ -The "a" in the pattern must be one of the forall'd variables in -the dfun type. - -\begin{code} data LookupInstResult s = NoInstance | SimpleInst TcExpr -- Just a variable, type application, or literal @@ -656,9 +637,10 @@ lookupInst :: Inst -- Dictionaries lookupInst dict@(Dict _ (Class clas tys) loc) - = case lookupInstEnv (ppr clas) (classInstEnv clas) tys of + = tcGetInstEnv `thenNF_Tc` \ inst_env -> + case lookupInstEnv inst_env clas tys of - Just (tenv, dfun_id) + FoundInst tenv dfun_id -> let subst = mkSubst (tyVarsOfTypes tys) tenv (tyvars, rho) = splitForAllTys (idType dfun_id) @@ -679,7 +661,7 @@ lookupInst dict@(Dict _ (Class clas tys) loc) in returnNF_Tc (GenInst dicts rhs) - Nothing -> returnNF_Tc NoInstance + other -> returnNF_Tc NoInstance lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance -- Methods @@ -751,18 +733,20 @@ appropriate dictionary if it exists. It is used only when resolving ambiguous dictionaries. \begin{code} -lookupSimpleInst :: InstEnv - -> Class +lookupSimpleInst :: Class -> [Type] -- Look up (c,t) -> NF_TcM s (Maybe [(Class,[Type])]) -- Here are the needed (c,t)s -lookupSimpleInst class_inst_env clas tys - = case lookupInstEnv (ppr clas) class_inst_env tys of - Nothing -> returnNF_Tc Nothing - - Just (tenv, dfun) +lookupSimpleInst clas tys + = tcGetInstEnv `thenNF_Tc` \ inst_env -> + case lookupInstEnv inst_env clas tys of + FoundInst tenv dfun -> returnNF_Tc (Just (substClasses (mkSubst emptyInScopeSet tenv) theta')) where (_, theta, _) = splitSigmaTy (idType dfun) theta' = map (\(Class clas tys) -> (clas,tys)) theta + + other -> returnNF_Tc Nothing \end{code} + +