X-Git-Url: http://wien.tomnetworks.com/gitweb/?a=blobdiff_plain;f=JVM%2FConverter.hs;h=5993d54388026e22a4a484cc4376c1d3f2aac902;hb=96bd2316525bb8790d4f047834c0ca6750155583;hp=a5f9d106b41ece16fe93b00cdb32b7a5224361e1;hpb=551564c1e46fc926629bd12a3bd73ae7bd976687;p=hs-java.git diff --git a/JVM/Converter.hs b/JVM/Converter.hs index a5f9d10..5993d54 100644 --- a/JVM/Converter.hs +++ b/JVM/Converter.hs @@ -21,163 +21,179 @@ 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 +parseClass :: B.ByteString -> Class Direct parseClass bstr = convertClass $ decode bstr -- | Parse class data from file -parseClassFile :: FilePath -> IO Class +parseClassFile :: FilePath -> IO (Class Direct) parseClassFile path = convertClass `fmap` decodeFile path -encodeClass :: Class -> B.ByteString +encodeClass :: (Class Direct) -> B.ByteString encodeClass cls = encode $ classFile cls -convertClass :: ClassFile -> Class -convertClass (ClassFile {..}) = +convertClass :: Class File -> Class Direct +convertClass (Class {..}) = let pool = constantPoolArray constsPool superName = className $ pool ! superClass in Class { - constantPool = pool, - classAccess = convertAccess accessFlags, - this = className $ pool ! thisClass, - super = if superClass == 0 then Nothing else Just superName, - implements = map (\i -> className $ pool ! i) interfaces, - fields = map (convertField pool) classFields, - methods = map (convertMethod pool) classMethods, - classAttrs = convertAttrs pool classAttributes } - -classFile :: Class -> ClassFile -classFile (Class {..}) = ClassFile { + magic = 0xCAFEBABE, + minorVersion = 0, + majorVersion = 50, + constsPoolSize = fromIntegral (M.size pool), + constsPool = pool, + accessFlags = convertAccess 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, + classMethodsCount = classMethodsCount, + classMethods = map (convertMethod pool) classMethods, + classAttributesCount = classAttributesCount, + classAttributes = convertAttrs pool classAttributes } + +classFile :: Class Direct -> Class File +classFile (Class {..}) = Class { magic = 0xCAFEBABE, minorVersion = 0, majorVersion = 50, - constsPoolSize = fromIntegral (length poolInfo + 1), + constsPoolSize = fromIntegral (M.size poolInfo + 1), constsPool = poolInfo, - accessFlags = access2word16 classAccess, - thisClass = force "this" $ poolClassIndex poolInfo this, - superClass = case super of - Just s -> force "super" $ poolClassIndex poolInfo s - Nothing -> 0, - interfacesCount = fromIntegral (length implements), - interfaces = map (force "ifaces" . poolIndex poolInfo) implements, - classFieldsCount = fromIntegral (length fields), - classFields = map (fieldInfo poolInfo) fields, - classMethodsCount = fromIntegral (length methods), - classMethods = map (methodInfo poolInfo) methods, - classAttributesCount = fromIntegral (M.size classAttrs), - classAttributes = map (attrInfo poolInfo) (M.assocs classAttrs) } + accessFlags = access2word16 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, + classMethodsCount = fromIntegral (length classMethods), + classMethods = map (methodInfo poolInfo) classMethods, + classAttributesCount = fromIntegral $ arsize classAttributes, + classAttributes = to (arlist classAttributes) } where - poolInfo = toCPInfo constantPool + poolInfo = toCPInfo constsPool + to :: [(B.ByteString, B.ByteString)] -> Attributes File + to pairs = AP (map (attrInfo poolInfo) pairs) -toCPInfo :: Pool -> [CpInfo] +toCPInfo :: Pool Direct -> Pool File toCPInfo pool = result where - result = map cpInfo $ M.elems pool + result = M.map cpInfo pool - cpInfo (CClass name) = CONSTANT_Class (force "class" $ poolIndex result name) + cpInfo :: Constant Direct -> Constant File + cpInfo (CClass name) = CClass (force "class" $ poolIndex result name) cpInfo (CField cls name) = - CONSTANT_Fieldref (force "field a" $ poolClassIndex result cls) (force "field b" $ poolNTIndex result name) + CField (force "field a" $ poolClassIndex result cls) (force "field b" $ poolNTIndex result name) cpInfo (CMethod cls name) = - CONSTANT_Methodref (force "method a" $ poolClassIndex result cls) (force ("method b: " ++ show name) $ poolNTIndex result name) + CMethod (force "method a" $ poolClassIndex result cls) (force ("method b: " ++ show name) $ poolNTIndex result name) cpInfo (CIfaceMethod cls name) = - CONSTANT_InterfaceMethodref (force "iface method a" $ poolIndex result cls) (force "iface method b" $ poolNTIndex result name) - cpInfo (CString s) = CONSTANT_String (force "string" $ poolIndex result s) - cpInfo (CInteger x) = CONSTANT_Integer x - cpInfo (CFloat x) = CONSTANT_Float x - cpInfo (CLong x) = CONSTANT_Long (fromIntegral x) - cpInfo (CDouble x) = CONSTANT_Double x + CIfaceMethod (force "iface method a" $ poolIndex result cls) (force "iface method b" $ poolNTIndex result name) + cpInfo (CString s) = CString (force "string" $ poolIndex result s) + cpInfo (CInteger x) = CInteger x + cpInfo (CFloat x) = CFloat x + cpInfo (CLong x) = CLong (fromIntegral x) + cpInfo (CDouble x) = CDouble x cpInfo (CNameType n t) = - CONSTANT_NameAndType (force "name" $ poolIndex result n) (force "type" $ poolIndex result t) - cpInfo (CUTF8 s) = CONSTANT_Utf8 (fromIntegral $ B.length s) s - cpInfo (CUnicode s) = CONSTANT_Unicode (fromIntegral $ B.length s) s + CNameType (force "name" $ poolIndex result n) (force "type" $ poolIndex result t) + cpInfo (CUTF8 s) = CUTF8 s + cpInfo (CUnicode s) = CUnicode s -- | Find index of given string in the list of constants -poolIndex :: (Throws NoItemInPool e) => [CpInfo] -> B.ByteString -> EM e Word16 -poolIndex list name = case findIndex test list of +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 where - test (CONSTANT_Utf8 _ s) | s == name = True - test (CONSTANT_Unicode _ s) | s == name = True + test (CUTF8 s) | s == name = True + test (CUnicode s) | s == name = True test _ = False -- | Find index of given string in the list of constants -poolClassIndex :: (Throws NoItemInPool e) => [CpInfo] -> B.ByteString -> EM e Word16 -poolClassIndex list name = case findIndex checkString list of +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) list of + Just i -> case findIndex (checkClass $ fromIntegral $ i+1) (M.elems list) of Nothing -> throw (NoItemInPool $ i+1) Just j -> return $ fromIntegral $ j+1 where - checkString (CONSTANT_Utf8 _ s) | s == name = True - checkString (CONSTANT_Unicode _ s) | s == name = True + checkString (CUTF8 s) | s == name = True + checkString (CUnicode s) | s == name = True checkString _ = False - checkClass i (CONSTANT_Class x) | i == x = True + checkClass i (CClass x) | i == x = True checkClass _ _ = False poolNTIndex list x@(NameType n t) = do ni <- poolIndex list n ti <- poolIndex list (byteString t) - case findIndex (check ni ti) list of + case findIndex (check ni ti) (M.elems list) of Nothing -> throw (NoItemInPool x) Just i -> return $ fromIntegral (i+1) where - check ni ti (CONSTANT_NameAndType n' t') + check ni ti (CNameType n' t') | (ni == n') && (ti == t') = True check _ _ _ = False -fieldInfo :: [CpInfo] -> Field -> FieldInfo -fieldInfo pool (Field {..}) = FieldInfo { - fieldAccessFlags = access2word16 fieldAccess, - fieldNameIndex = force "field name" $ poolIndex pool fieldName, - fieldSignatureIndex = force "signature" $ poolIndex pool (encode fieldSignature), - fieldAttributesCount = fromIntegral (M.size fieldAttrs), - fieldAttributes = map (attrInfo pool) (M.assocs fieldAttrs) } - -methodInfo :: [CpInfo] -> Method -> MethodInfo -methodInfo pool (Method {..}) = MethodInfo { - methodAccessFlags = access2word16 methodAccess, - methodNameIndex = force "method name" $ poolIndex pool methodName, - methodSignatureIndex = force "method sig" $ poolIndex pool (encode methodSignature), - methodAttributesCount = fromIntegral (M.size methodAttrs), - methodAttributes = map (attrInfo pool) (M.assocs methodAttrs) } - -attrInfo :: [CpInfo] -> (B.ByteString, B.ByteString) -> AttributeInfo -attrInfo pool (name, value) = AttributeInfo { +fieldInfo :: Pool File -> Field Direct -> Field File +fieldInfo pool (Field {..}) = Field { + fieldAccessFlags = access2word16 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 File + to pairs = AP (map (attrInfo pool) pairs) + +methodInfo :: Pool File -> Method Direct -> Method File +methodInfo pool (Method {..}) = Method { + methodAccessFlags = access2word16 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 File + to pairs = AP (map (attrInfo pool) pairs) + +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 :: [CpInfo] -> Pool -constantPoolArray list = pool +constantPoolArray :: Pool File -> Pool Direct +constantPoolArray ps = pool where - pool :: Pool - pool = M.fromList $ zip [1..] $ map convert list - n = fromIntegral $ length list + pool :: Pool Direct + pool = M.map convert ps - convertNameType :: (HasSignature a, Binary (Signature a)) => Word16 -> NameType a + n = fromIntegral $ M.size ps + + convertNameType :: (HasSignature a) => Word16 -> NameType a convertNameType i = let (CNameType n s) = pool ! i in NameType n (decode s) - convert (CONSTANT_Class i) = CClass $ getString $ pool ! i - convert (CONSTANT_Fieldref i j) = CField (className $ pool ! i) (convertNameType j) - convert (CONSTANT_Methodref i j) = CMethod (className $ pool ! i) (convertNameType j) - convert (CONSTANT_InterfaceMethodref i j) = CIfaceMethod (className $ pool ! i) (convertNameType j) - convert (CONSTANT_String i) = CString $ getString $ pool ! i - convert (CONSTANT_Integer x) = CInteger x - convert (CONSTANT_Float x) = CFloat x - convert (CONSTANT_Long x) = CLong (fromIntegral x) - convert (CONSTANT_Double x) = CDouble x - convert (CONSTANT_NameAndType i j) = CNameType (getString $ pool ! i) (getString $ pool ! j) - convert (CONSTANT_Utf8 _ bs) = CUTF8 bs - convert (CONSTANT_Unicode _ bs) = CUnicode bs - -convertAccess :: Word16 -> Access + convert (CClass i) = CClass $ getString $ pool ! i + convert (CField i j) = CField (className $ pool ! i) (convertNameType j) + convert (CMethod i j) = CMethod (className $ pool ! i) (convertNameType j) + convert (CIfaceMethod i j) = CIfaceMethod (className $ pool ! i) (convertNameType j) + convert (CString i) = CString $ getString $ pool ! i + convert (CInteger x) = CInteger x + convert (CFloat x) = CFloat x + convert (CLong x) = CLong (fromIntegral x) + convert (CDouble x) = CDouble x + convert (CNameType i j) = CNameType (getString $ pool ! i) (getString $ pool ! j) + convert (CUTF8 bs) = CUTF8 bs + convert (CUnicode bs) = CUnicode bs + +convertAccess :: AccessFlags File -> AccessFlags Direct convertAccess w = S.fromList $ concat $ zipWith (\i f -> if testBit w i then [f] else []) [0..] $ [ ACC_PUBLIC, ACC_PRIVATE, @@ -191,43 +207,48 @@ convertAccess w = S.fromList $ concat $ zipWith (\i f -> if testBit w i then [f] ACC_INTERFACE, ACC_ABSTRACT ] -access2word16 :: Access -> Word16 +access2word16 :: AccessFlags Direct -> AccessFlags File access2word16 fs = bitsOr $ map toBit $ S.toList fs where bitsOr = foldl (.|.) 0 toBit f = 1 `shiftL` (fromIntegral $ fromEnum f) -convertField :: Pool -> FieldInfo -> Field -convertField pool (FieldInfo {..}) = Field { - fieldAccess = convertAccess fieldAccessFlags, - fieldName = getString $ pool ! fieldNameIndex, - fieldSignature = decode $ getString $ pool ! fieldSignatureIndex, - fieldAttrs = convertAttrs pool fieldAttributes } - -convertMethod :: Pool -> MethodInfo -> Method -convertMethod pool (MethodInfo {..}) = Method { - methodAccess = convertAccess methodAccessFlags, - methodName = getString $ pool ! methodNameIndex, - methodSignature = decode $ getString $ pool ! methodSignatureIndex, - methodAttrs = convertAttrs pool methodAttributes } - -convertAttrs :: Pool -> [AttributeInfo] -> Attributes -convertAttrs pool attrs = M.fromList $ map go attrs +convertField :: Pool Direct -> Field File -> Field Direct +convertField pool (Field {..}) = Field { + fieldAccessFlags = convertAccess fieldAccessFlags, + fieldName = getString $ pool ! fieldName, + fieldSignature = decode $ getString $ pool ! fieldSignature, + fieldAttributesCount = fromIntegral (apsize fieldAttributes), + fieldAttributes = convertAttrs pool fieldAttributes } + +convertMethod :: Pool Direct -> Method File -> Method Direct +convertMethod pool (Method {..}) = Method { + methodAccessFlags = convertAccess methodAccessFlags, + methodName = getString $ pool ! methodName, + methodSignature = decode $ getString $ pool ! methodSignature, + methodAttributesCount = fromIntegral (apsize methodAttributes), + methodAttributes = convertAttrs pool methodAttributes } + +convertAttrs :: Pool Direct -> Attributes File -> Attributes Direct +convertAttrs pool (AP attrs) = AR (M.fromList $ map go attrs) where - go (AttributeInfo {..}) = (getString $ pool ! attributeName, - attributeValue) + go :: Attribute -> (B.ByteString, B.ByteString) + go (Attribute {..}) = (getString $ pool ! attributeName, + attributeValue) -- | Try to get class method by name -methodByName :: Class -> B.ByteString -> Maybe Method +methodByName :: Class Direct -> B.ByteString -> Maybe (Method Direct) methodByName cls name = - find (\m -> methodName m == name) (methods cls) + find (\m -> methodName m == name) (classMethods cls) -- | Try to get object attribute by name -attrByName :: (HasAttributes a) => a -> B.ByteString -> Maybe B.ByteString -attrByName x name = M.lookup name (attributes x) +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 +methodCode :: Class Direct -> B.ByteString -- ^ Method name -> Maybe B.ByteString methodCode cls name = do