diff --git a/java-reflect.cabal b/java-reflect.cabal --- a/java-reflect.cabal +++ b/java-reflect.cabal @@ -1,5 +1,5 @@ name: java-reflect -version: 0.9 +version: 0.9.1 license: MIT license-file: LICENSE @@ -21,6 +21,7 @@ build-depends: base >= 4.5 && < 5 , java-bridge == 0.9 , containers >= 0.4.2.1 + , hx hs-source-dirs: src diff --git a/src/Language/Java/Reflect.hs b/src/Language/Java/Reflect.hs --- a/src/Language/Java/Reflect.hs +++ b/src/Language/Java/Reflect.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE Haskell2010 + , TupleSections + #-} {-# OPTIONS -Wall -fno-warn-missing-signatures @@ -15,8 +17,7 @@ -- -- Methods for reflecting Java classes using a JVM as source of information. module Language.Java.Reflect ( - findClasses, - reflectClasses, + getReflectClasses, module Language.Java.Reflect.Types @@ -28,158 +29,27 @@ import qualified Data.Map as Map import Data.Map (Map) +{- import qualified Data.Set as Set import Data.Set (Set) +-} import Data.Int -import Data.Word import Data.Maybe (fromJust) +import qualified Data.Traversable as T + import Foreign.Java -import Foreign.Java.Utils +import Haskell.X definitely = maybe (error "The impossible happened! Please report this as a bug.") --- ( --- [Methods = [types] ], --- (Maybe Parentclass, [Interfaces]) --- ) -type Class = ([String], (Maybe String, [String])) - - -findClasses :: Word32 -> [String] -> Java [String] --Java (Map String Class) -findClasses maxDepth classNamesToFind = do - - (Just clazz) <- getClass "java.lang.Class" - (Just cMethod) <- getClass "java.lang.reflect.Method" - (Just cConstr) <- getClass "java.lang.reflect.Constructor" - (Just cField) <- getClass "java.lang.reflect.Field" - - getMethods <- clazz `bindMethod` "getMethods" - ::= array (object "java.lang.reflect.Method") - getConstructors <- clazz `bindMethod` "getConstructors" - ::= array (object "java.lang.reflect.Constructor") - getFields <- clazz `bindMethod` "getFields" - ::= array (object "java.lang.reflect.Field") - - getFieldType <- cField `bindMethod` "getType" - ::= object "java.lang.Class" - getReturnType <- cMethod `bindMethod` "getReturnType" - ::= object "java.lang.Class" - getClassName <- clazz `bindMethod` "getName" - ::= string - getParametersM <- cMethod `bindMethod` "getParameterTypes" - ::= array (object "java.lang.Class") - getParametersC <- cConstr `bindMethod` "getParameterTypes" - ::= array (object "java.lang.Class") - getSuperclass <- clazz `bindMethod` "getSuperclass" - ::= object "java.lang.Class" - getInterfaces <- clazz `bindMethod` "getInterfaces" - ::= array (object "java.lang.Class") - - (Just classLoader) <- getClass "java.lang.ClassLoader" - getSystemClassLoader <- classLoader `bindStaticMethod` "getSystemClassLoader" - ::= object "java.lang.ClassLoader" - (Just systemClassLoader) <- getSystemClassLoader - - (Just loadClass) <- classLoader `getMethod` "loadClass" - ::= string --> boolean --> object "java.lang.Class" - - let getClass' :: String -> Java (Maybe JObject) - getClass' clazz = callMethodE loadClass systemClassLoader clazz False - >>= return . either (const Nothing) id - - readClass :: JObject -> Java Class - readClass clazz = do - constructors <- getConstructors clazz - >>= toList . fromJust - >>= mapM (readConstructor . fromJust) - >>= return . concat - methods <- getMethods clazz - >>= toList . fromJust - >>= mapM (readMethod . fromJust) - >>= return . concat - fields <- getFields clazz - >>= toList . fromJust - >>= mapM (readField . fromJust) - superclass <- getSuperclass clazz - >>= maybe (return Nothing) getClassName - interfaces <- getInterfaces clazz - >>= toList . fromJust - >>= mapM (getClassName . fromJust) - >>= return . map fromJust - return (constructors ++ fields ++ methods, (superclass, interfaces)) - - readField :: JObject -> Java String - readField field = do - (Just fieldType) <- getFieldType field >>= getClassName . fromJust - - return fieldType - - readMethod :: JObject -> Java [String] - readMethod method = do - args <- readMethodParameters method --- excs <- readMethodExceptions method - (Just returnType) <- getReturnType method >>= getClassName . fromJust - - return (returnType : args) - - readConstructor :: JObject -> Java [String] - readConstructor constr = do - args <- readConstructorParameters constr --- excs <- readConstructorExceptions constr - - return args - - readMethodParameters :: JObject -> Java [String] - readMethodParameters method = getParametersM method - >>= toList . fromJust - >>= mapM (getClassName . fromJust) - >>= return . map fromJust - - readConstructorParameters :: JObject -> Java [String] - readConstructorParameters method = getParametersC method - >>= toList . fromJust - >>= mapM (getClassName . fromJust) - >>= return . map fromJust - - readReferences :: Class -> [String] - readReferences (refs1, (super, ifaces)) = - let refs2 = maybe ifaces (: ifaces) super - in refs2 ++ refs1 - - isPrimitive x = head x == '[' || x `elem` ["byte", "short", "int", "long", - "float", "double", "boolean", "char", - "void"] - - resolve :: Map String Class -> Set String -> [String] - -> Java (Map String Class, Set String) - resolve map set css = case css of - (x:xs) -> if x `Map.member` map - then do resolve map set xs - else getClass' x >>= maybe (resolve map set xs) (\clazz -> do - clazz' <- readClass clazz - let newClasses = Set.filter (`Map.notMember` map) - $ Set.fromList (readReferences clazz') - resolve (Map.insert x clazz' map) - (newClasses `Set.union` set) - xs) - [] -> do return (map, Set.filter (not . isPrimitive) set) - - findAll :: Word32 -> Map String Class -> [String] -> Java (Map String Class) - findAll 0 classes _xs = return classes - findAll limit classes xs = do - (classes', new) <- resolve classes Set.empty xs - if Set.null new - then return classes' - else findAll (pred limit) classes' (Set.toList new) - - Map.keys `fmap` findAll maxDepth Map.empty classNamesToFind - -reflectClasses :: [String] -> Java [JavaClass] -reflectClasses classes = do +getReflectClasses :: Java (Bool -> [String] -> Java (Map String JavaClass)) +-- ^ Creates a function which can be used to gather reflection information +-- about classes identified by their binary name (e.g. @java.lang.Thread$State@). +getReflectClasses = do (Just clazz) <- getClass "java.lang.Class" (Just cField) <- getClass "java.lang.reflect.Field" @@ -410,7 +280,7 @@ jgtLowerBounds = lowerBounds' } - _ -> getName genericType >>= return . NotSoGeneric . fromJust + _ -> return NotSoGeneric reflectEnumConstant :: JObject -- of type java.lang.Enum @@ -519,9 +389,6 @@ isActuallyAbstract <- isAbstract modifiers isActuallyFinal <- isFinal modifiers - - let name = takeClassName className - packageName = takePackageName className parents <- asObject clazz >>= findParentClasses @@ -563,9 +430,7 @@ isActuallyAnn <- asObject clazz >>= isAnnotation return $ JavaClass { - className = name, - classPackage = packageName, - classModName = "", -- is filled in later + className = className, classFields = fields, classMethods = methods, classParents = parents, @@ -580,5 +445,27 @@ classFinal = isActuallyFinal } - mapM reflectClass classes + reflectWithDependencies :: String -> Java (JavaClass, Map String (Either String JavaClass)) + reflectWithDependencies clazz = do + reflected <- reflectClass clazz + let deps = classDependencies reflected + depsMap = Map.fromList (zip deps (map Left deps)) + return (reflected, depsMap) + + resolve :: Map String (Either String JavaClass) -> Java (Map String (Either String JavaClass)) + resolve classes = do + resolved <- T.mapM (either reflectWithDependencies (return . (, Map.empty))) classes + let newDeps = Map.foldl' Map.union Map.empty (Map.map snd resolved) + resolved' = Map.map (Right . fst) resolved + + return (resolved' `Map.union` newDeps) + + reflect :: Bool -> [String] -> Java (Map String JavaClass) + reflect findAll classes = do + let classesMap = (Map.fromList (zip classes (map Left classes))) + resolved <- (if findAll then exhaustivelyM else id) resolve classesMap + return (snd (Map.mapEither id resolved)) + + return reflect + diff --git a/src/Language/Java/Reflect/Types.hs b/src/Language/Java/Reflect/Types.hs --- a/src/Language/Java/Reflect/Types.hs +++ b/src/Language/Java/Reflect/Types.hs @@ -21,10 +21,12 @@ -- combinators (see "Data.Generics"). module Language.Java.Reflect.Types where -import Foreign.Java.Utils + import Data.Int import Data.Data +import Data.List (nub) + -- type JavaClassCache = Map (String, [JavaType]) JavaClass -- | A JavaType is either a Primitive Type, an Array, or an Object. @@ -62,8 +64,6 @@ -- | The interface of a Java class. data JavaClass = JavaClass { className :: String, - classPackage :: Maybe String, - classModName :: String, classParents :: [String], classIfaces :: [String], classConstructors :: [JavaConstructor], @@ -98,14 +98,11 @@ classDependencies clazz = concat [ classParents clazz, classIfaces clazz, - concatMap fieldDependencies (classFields clazz), - concatMap methodDependencies (classMethods clazz), - concatMap constructorDependencies (classConstructors clazz) ] + concatMap (fieldDependencies typeParams) (classFields clazz), + concatMap (methodDependencies typeParams) (classMethods clazz), + concatMap (constructorDependencies typeParams) (classConstructors clazz) ] + where typeParams = classTypeParams clazz -classFullName :: JavaClass -> String --- ^ Derive the full name from a class definition. See also 'makeName'. -classFullName clazz = makeName (classPackage clazz) (className clazz) - -- | A Type variable declaration. data JavaTypeParam = JavaTypeParam { @@ -117,6 +114,7 @@ newtype TyVar = TyVar { tyVarName :: String } deriving (Eq, Ord, Show, Read, Data, Typeable) + data JavaGenericType = -- | @@, @@ Wildcard { @@ -140,13 +138,8 @@ -- | The name of the type variable, e.g. @E@ or @X@. jgtName :: TyVar } - | -- java.lang.Object - NotSoGeneric { - -- | A plain type, full name. Used for example in a 'Parameterized' - -- type, which may be parameterized by a plain type (like - -- @Class@. - jgtBasetype :: String - } deriving (Eq, Ord, Show, Read, Data, Typeable) + | NotSoGeneric + deriving (Eq, Ord, Show, Read, Data, Typeable) -- | The type of a generic type. data JavaGenericTypeType = WildcardT @@ -162,7 +155,7 @@ (Parameterized _ _) -> ParameterizedT (GenericArray _) -> GenericArrayT (TypeVarReference _) -> TypeVarReferenceT - (NotSoGeneric _) -> NotSoGenericT + NotSoGeneric -> NotSoGenericT -- | The interface to a field in the Java language. data JavaField = JavaField { @@ -172,10 +165,8 @@ fieldStatic :: Bool } deriving (Eq, Show, Read, Data, Typeable) -fieldDependencies :: JavaField -> [String] -fieldDependencies field = case fst (fieldType field) of - JObj n -> [n] - _ -> [] +fieldDependencies :: [JavaTypeParam] -> JavaField -> [String] +fieldDependencies tvars field = dependencies tvars [fieldType field] -- | The interface to a method in the Java language. data JavaMethod = JavaMethod { @@ -192,16 +183,18 @@ methodSynchronized :: Bool } deriving (Eq, Show, Read, Data, Typeable) -methodDependencies :: JavaMethod -> [String] +methodDependencies :: [JavaTypeParam] -> JavaMethod -> [String] -- ^ Return the full names of all classes that this method -- references in its definition. -methodDependencies method = foldl classReference [] referenced - where - referenced = maybe paramTypes (: paramTypes) (fst $ methodReturnType method) - paramTypes = map fst $ methodParams method - classReference r c = case c of - JObj n -> n : r - _ -> r +methodDependencies tvars method = returnDependency ++ dependencies tvars' (methodParams method) + where returnDependency = case methodReturnType method of + (Nothing, _) -> [] + (Just t, gt) -> dependencies tvars' [(t, gt)] + tvars' = methodTypeParams method ++ tvars + -- it is important that the type params are appended + -- up front, since lookup will return the first + -- (the first is the more appropriate one, since it is + -- the one in scope). -- | A Constructor in the Java language. data JavaConstructor = JavaConstructor { @@ -210,14 +203,44 @@ constructorTypeParams :: [JavaTypeParam] } deriving (Eq, Show, Read, Data, Typeable) -constructorDependencies :: JavaConstructor -> [String] +constructorDependencies :: [JavaTypeParam] -> JavaConstructor -> [String] -- ^ Retrieve all classes that this constructor definition -- references in its parameters or generic declaration. -constructorDependencies constr = foldl classReference [] - $ map fst $ constructorParams constr - where - classReference r c = case c of - JObj n -> n : r - _ -> r +constructorDependencies tvars constr = dependencies tvars' (constructorParams constr) + where tvars' = constructorTypeParams constr ++ tvars + -- it is important that the type params are appended + -- up front, since lookup will return the first + -- (the first is the more appropriate one, since it is + -- the one in scope). +dependencies :: [JavaTypeParam] -> [(JavaType, JavaGenericType)] -> [String] +-- ^ Discovers all types which are mentioned in a list of type declarations, +-- using the type variables that are in scope. +dependencies tyvars = nub . foldr (\(t, gt) ds -> deps t ++ gdeps tyvars gt ++ ds) [] + where + -- | Find the dependencies of an ordinary type (if any) + deps t = case t of + JObj c -> [c] + JArr c -> deps c -- in case of an array, the dependency + -- is on the component type + _ -> [] -- in all other cases, it is only a primitive type + -- | Find the dependencies of the generic declaration of that type + -- (bounds, parameters, etc.) + gdeps :: [JavaTypeParam] -> JavaGenericType -> [String] + gdeps tv t = case jgtType t of + WildcardT + -> concatMap (gdeps tv) (jgtBounds t ++ jgtLowerBounds t) + ParameterizedT + -> jgtBasetype t : concatMap (gdeps tv) (jgtParameters t) + GenericArrayT + -> (gdeps tv) (jgtComponentType t) + TypeVarReferenceT + -> maybe [] (concatMap (gdeps tv') . paramBounds) + (lookup tvName (zip (map paramName tv) tyvars)) + NotSoGenericT -> [] + where tvName = jgtName t + tv' = filter ((/= tvName) . paramName) tv + -- remove the current type variable so + -- that we do not end up lookin it up in + -- an infinite loop (*very* important)