X-Git-Url: http://wien.tomnetworks.com/gitweb/?a=blobdiff_plain;f=JVM%2FConverter.hs;h=0c26dd156c0e91afcf6c638106fc651ea9a53933;hb=359cf0fa124cd3bc0ffedf8ecee77022970ba562;hp=82a1782134019ed7e0e8503286d3f35d753b5f6d;hpb=55d6741452443c59d700c01de495f50b56eb6f30;p=hs-java.git diff --git a/JVM/Converter.hs b/JVM/Converter.hs index 82a1782..0c26dd1 100644 --- a/JVM/Converter.hs +++ b/JVM/Converter.hs @@ -3,7 +3,7 @@ -- high-level Java classes, methods etc representation module JVM.Converter (parseClass, parseClassFile, - convertClass, classFile, + classFile2Direct, classDirect2File, encodeClass, methodByName, attrByName, @@ -16,76 +16,75 @@ import Data.List import Data.Word import Data.Bits import Data.Binary +import Data.Default () -- import instances only import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString.Lazy.Char8 () import qualified Data.Set as S import qualified Data.Map as M import JVM.ClassFile -import JVM.Types +import JVM.Common import JVM.Exceptions -- | Parse .class file data -parseClass :: B.ByteString -> Class Resolved -parseClass bstr = convertClass $ decode bstr +parseClass :: B.ByteString -> Class Direct +parseClass bstr = classFile2Direct $ decode bstr -- | Parse class data from file -parseClassFile :: FilePath -> IO (Class Resolved) -parseClassFile path = convertClass `fmap` decodeFile path +parseClassFile :: FilePath -> IO (Class Direct) +parseClassFile path = classFile2Direct `fmap` decodeFile path -encodeClass :: (Class Resolved) -> B.ByteString -encodeClass cls = encode $ classFile cls +encodeClass :: (Class Direct) -> B.ByteString +encodeClass cls = encode $ classDirect2File cls -convertClass :: Class Pointers -> Class Resolved -convertClass (Class {..}) = - let pool = constantPoolArray constsPool +classFile2Direct :: Class File -> Class Direct +classFile2Direct (Class {..}) = + let pool = poolFile2Direct constsPool superName = className $ pool ! superClass - in Class { - magic = 0xCAFEBABE, - minorVersion = 0, - majorVersion = 50, + d = defaultClass :: Class Direct + in d { constsPoolSize = fromIntegral (M.size pool), constsPool = pool, - accessFlags = convertAccess accessFlags, + accessFlags = accessFile2Direct accessFlags, thisClass = className $ pool ! thisClass, superClass = if superClass == 0 then "" else superName, interfacesCount = interfacesCount, interfaces = map (\i -> className $ pool ! i) interfaces, classFieldsCount = classFieldsCount, - classFields = map (convertField pool) classFields, + classFields = map (fieldFile2Direct pool) classFields, classMethodsCount = classMethodsCount, - classMethods = map (convertMethod pool) classMethods, + classMethods = map (methodFile2Direct pool) classMethods, classAttributesCount = classAttributesCount, - classAttributes = convertAttrs pool classAttributes } + classAttributes = attributesFile2Direct pool classAttributes } -classFile :: Class Resolved -> Class Pointers -classFile (Class {..}) = Class { - magic = 0xCAFEBABE, - minorVersion = 0, - majorVersion = 50, +classDirect2File :: Class Direct -> Class File +classDirect2File (Class {..}) = + let d = defaultClass :: Class File + in d { constsPoolSize = fromIntegral (M.size poolInfo + 1), constsPool = poolInfo, - accessFlags = access2word16 accessFlags, + accessFlags = accessDirect2File accessFlags, thisClass = force "this" $ poolClassIndex poolInfo thisClass, superClass = force "super" $ poolClassIndex poolInfo superClass, interfacesCount = fromIntegral (length interfaces), interfaces = map (force "ifaces" . poolIndex poolInfo) interfaces, classFieldsCount = fromIntegral (length classFields), - classFields = map (fieldInfo poolInfo) classFields, + classFields = map (fieldDirect2File poolInfo) classFields, classMethodsCount = fromIntegral (length classMethods), - classMethods = map (methodInfo poolInfo) classMethods, + classMethods = map (methodDirect2File poolInfo) classMethods, classAttributesCount = fromIntegral $ arsize classAttributes, classAttributes = to (arlist classAttributes) } where - poolInfo = toCPInfo constsPool - to :: [(B.ByteString, B.ByteString)] -> Attributes Pointers + poolInfo = poolDirect2File constsPool + to :: [(B.ByteString, B.ByteString)] -> Attributes File to pairs = AP (map (attrInfo poolInfo) pairs) -toCPInfo :: Pool Resolved -> Pool Pointers -toCPInfo pool = result +poolDirect2File :: Pool Direct -> Pool File +poolDirect2File pool = result where result = M.map cpInfo pool - cpInfo :: Constant Resolved -> Constant Pointers + cpInfo :: Constant Direct -> Constant File cpInfo (CClass name) = CClass (force "class" $ poolIndex result name) cpInfo (CField cls name) = CField (force "field a" $ poolClassIndex result cls) (force "field b" $ poolNTIndex result name) @@ -104,7 +103,7 @@ toCPInfo pool = result cpInfo (CUnicode s) = CUnicode s -- | Find index of given string in the list of constants -poolIndex :: (Throws NoItemInPool e) => Pool Pointers -> B.ByteString -> EM e Word16 +poolIndex :: (Throws NoItemInPool e) => Pool File -> B.ByteString -> EM e Word16 poolIndex list name = case findIndex test (M.elems list) of Nothing -> throw (NoItemInPool name) Just i -> return $ fromIntegral $ i+1 @@ -114,7 +113,7 @@ poolIndex list name = case findIndex test (M.elems list) of test _ = False -- | Find index of given string in the list of constants -poolClassIndex :: (Throws NoItemInPool e) => Pool Pointers -> B.ByteString -> EM e Word16 +poolClassIndex :: (Throws NoItemInPool e) => Pool File -> B.ByteString -> EM e Word16 poolClassIndex list name = case findIndex checkString (M.elems list) of Nothing -> throw (NoItemInPool name) Just i -> case findIndex (checkClass $ fromIntegral $ i+1) (M.elems list) of @@ -139,43 +138,43 @@ poolNTIndex list x@(NameType n t) = do | (ni == n') && (ti == t') = True check _ _ _ = False -fieldInfo :: Pool Pointers -> Field Resolved -> Field Pointers -fieldInfo pool (Field {..}) = Field { - fieldAccessFlags = access2word16 fieldAccessFlags, +fieldDirect2File :: Pool File -> Field Direct -> Field File +fieldDirect2File pool (Field {..}) = Field { + fieldAccessFlags = accessDirect2File fieldAccessFlags, fieldName = force "field name" $ poolIndex pool fieldName, fieldSignature = force "signature" $ poolIndex pool (encode fieldSignature), fieldAttributesCount = fromIntegral (arsize fieldAttributes), fieldAttributes = to (arlist fieldAttributes) } where - to :: [(B.ByteString, B.ByteString)] -> Attributes Pointers + to :: [(B.ByteString, B.ByteString)] -> Attributes File to pairs = AP (map (attrInfo pool) pairs) -methodInfo :: Pool Pointers -> Method Resolved -> Method Pointers -methodInfo pool (Method {..}) = Method { - methodAccessFlags = access2word16 methodAccessFlags, +methodDirect2File :: Pool File -> Method Direct -> Method File +methodDirect2File pool (Method {..}) = Method { + methodAccessFlags = accessDirect2File methodAccessFlags, methodName = force "method name" $ poolIndex pool methodName, methodSignature = force "method sig" $ poolIndex pool (encode methodSignature), methodAttributesCount = fromIntegral (arsize methodAttributes), methodAttributes = to (arlist methodAttributes) } where - to :: [(B.ByteString, B.ByteString)] -> Attributes Pointers + to :: [(B.ByteString, B.ByteString)] -> Attributes File to pairs = AP (map (attrInfo pool) pairs) -attrInfo :: Pool Pointers -> (B.ByteString, B.ByteString) -> Attribute +attrInfo :: Pool File -> (B.ByteString, B.ByteString) -> Attribute attrInfo pool (name, value) = Attribute { attributeName = force "attr name" $ poolIndex pool name, attributeLength = fromIntegral (B.length value), attributeValue = value } -constantPoolArray :: Pool Pointers -> Pool Resolved -constantPoolArray ps = pool +poolFile2Direct :: Pool File -> Pool Direct +poolFile2Direct ps = pool where - pool :: Pool Resolved + pool :: Pool Direct pool = M.map convert ps n = fromIntegral $ M.size ps - convertNameType :: (HasSignature a, Binary (Signature a)) => Word16 -> NameType a + convertNameType :: (HasSignature a) => Word16 -> NameType a convertNameType i = let (CNameType n s) = pool ! i in NameType n (decode s) @@ -193,8 +192,8 @@ constantPoolArray ps = pool convert (CUTF8 bs) = CUTF8 bs convert (CUnicode bs) = CUnicode bs -convertAccess :: AccessFlags Pointers -> AccessFlags Resolved -convertAccess w = S.fromList $ concat $ zipWith (\i f -> if testBit w i then [f] else []) [0..] $ [ +accessFile2Direct :: AccessFlags File -> AccessFlags Direct +accessFile2Direct w = S.fromList $ concat $ zipWith (\i f -> if testBit w i then [f] else []) [0..] $ [ ACC_PUBLIC, ACC_PRIVATE, ACC_PROTECTED, @@ -207,48 +206,48 @@ convertAccess w = S.fromList $ concat $ zipWith (\i f -> if testBit w i then [f] ACC_INTERFACE, ACC_ABSTRACT ] -access2word16 :: AccessFlags Resolved -> AccessFlags Pointers -access2word16 fs = bitsOr $ map toBit $ S.toList fs +accessDirect2File :: AccessFlags Direct -> AccessFlags File +accessDirect2File fs = bitsOr $ map toBit $ S.toList fs where bitsOr = foldl (.|.) 0 toBit f = 1 `shiftL` (fromIntegral $ fromEnum f) -convertField :: Pool Resolved -> Field Pointers -> Field Resolved -convertField pool (Field {..}) = Field { - fieldAccessFlags = convertAccess fieldAccessFlags, +fieldFile2Direct :: Pool Direct -> Field File -> Field Direct +fieldFile2Direct pool (Field {..}) = Field { + fieldAccessFlags = accessFile2Direct fieldAccessFlags, fieldName = getString $ pool ! fieldName, fieldSignature = decode $ getString $ pool ! fieldSignature, fieldAttributesCount = fromIntegral (apsize fieldAttributes), - fieldAttributes = convertAttrs pool fieldAttributes } + fieldAttributes = attributesFile2Direct pool fieldAttributes } -convertMethod :: Pool Resolved -> Method Pointers -> Method Resolved -convertMethod pool (Method {..}) = Method { - methodAccessFlags = convertAccess methodAccessFlags, +methodFile2Direct :: Pool Direct -> Method File -> Method Direct +methodFile2Direct pool (Method {..}) = Method { + methodAccessFlags = accessFile2Direct methodAccessFlags, methodName = getString $ pool ! methodName, methodSignature = decode $ getString $ pool ! methodSignature, methodAttributesCount = fromIntegral (apsize methodAttributes), - methodAttributes = convertAttrs pool methodAttributes } + methodAttributes = attributesFile2Direct pool methodAttributes } -convertAttrs :: Pool Resolved -> Attributes Pointers -> Attributes Resolved -convertAttrs pool (AP attrs) = AR (M.fromList $ map go attrs) +attributesFile2Direct :: Pool Direct -> Attributes File -> Attributes Direct +attributesFile2Direct pool (AP attrs) = AR (M.fromList $ map go attrs) where go :: Attribute -> (B.ByteString, B.ByteString) go (Attribute {..}) = (getString $ pool ! attributeName, attributeValue) -- | Try to get class method by name -methodByName :: Class Resolved -> B.ByteString -> Maybe (Method Resolved) +methodByName :: Class Direct -> B.ByteString -> Maybe (Method Direct) methodByName cls name = find (\m -> methodName m == name) (classMethods cls) -- | Try to get object attribute by name -attrByName :: (HasAttributes a) => a Resolved -> B.ByteString -> Maybe B.ByteString +attrByName :: (HasAttributes a) => a Direct -> B.ByteString -> Maybe B.ByteString attrByName x name = let (AR m) = attributes x in M.lookup name m -- | Try to get Code for class method (no Code for interface methods) -methodCode :: Class Resolved +methodCode :: Class Direct -> B.ByteString -- ^ Method name -> Maybe B.ByteString methodCode cls name = do