--- /dev/null
+{-# LANGUAGE RecordWildCards, BangPatterns #-}
+module JVM.ClassFile where
+
+import Control.Monad
+import Control.Applicative
+import Data.Binary
+import Data.Binary.IEEE754
+import Data.Binary.Get
+import Data.Binary.Put
+import Data.Word
+import Data.Char
+import qualified Data.ByteString.Lazy as B
+
+import Debug.Trace
+
+traceS :: (Show a) => String -> a -> a
+traceS msg x = trace (msg ++ ": " ++ show x) x
+
+char :: Word8 -> Char
+char n = chr (fromIntegral n)
+
+getChar8 :: Get Char
+getChar8 = do
+ x <- getWord8
+ return (char x)
+
+data ClassFile = ClassFile {
+ magic :: Word32,
+ minorVersion :: Word16,
+ majorVersion :: Word16,
+ constsPoolSize :: Word16,
+ constsPool :: [CpInfo],
+ accessFlags :: Word16,
+ thisClass :: Word16,
+ superClass :: Word16,
+ interfacesCount :: Word16,
+ interfaces :: [Word16],
+ classFieldsCount :: Word16,
+ classFields :: [FieldInfo],
+ classMethodsCount :: Word16,
+ classMethods :: [MethodInfo],
+ classAttributesCount :: Word16,
+ classAttributes :: [AttributeInfo]
+ }
+ deriving (Eq, Show)
+
+traceM msg x = do
+ r <- x
+ return $ traceS msg r
+
+replicateMT n m = replicateM n (traceM ">" m)
+
+instance Binary ClassFile where
+ put (ClassFile {..}) = do
+ put magic
+ put minorVersion
+ put majorVersion
+ put constsPoolSize
+ forM_ constsPool put
+ put accessFlags
+ put thisClass
+ put superClass
+ put interfacesCount
+ forM_ interfaces put
+ put classFieldsCount
+ forM_ classFields put
+ put classMethodsCount
+ forM_ classMethods put
+ put classAttributesCount
+ forM_ classAttributes put
+
+ get = do
+ magic <- get
+ minor <- get
+ major <- get
+ poolsize <- get
+ pool <- replicateM (fromIntegral poolsize - 1) get
+ af <- get
+ this <- get
+ super <- get
+ interfacesCount <- get
+ ifaces <- replicateM (fromIntegral interfacesCount) get
+ classFieldsCount <- get
+ classFields <- replicateM (fromIntegral classFieldsCount) get
+ classMethodsCount <- get
+ classMethods <- replicateM (fromIntegral classMethodsCount) get
+ asCount <- get
+ as <- replicateM (fromIntegral $ asCount - 1) get
+ return $ ClassFile magic minor major poolsize pool af this super
+ interfacesCount ifaces classFieldsCount classFields classMethodsCount classMethods asCount as
+
+data FieldType =
+ SignedByte -- B
+ | CharByte -- C
+ | DoubleType -- D
+ | FloatType -- F
+ | IntType -- I
+ | LongInt -- J
+ | ShortInt -- S
+ | BoolType -- Z
+ | ObjectType String -- L <class name>
+ | Array (Maybe Int) FieldType
+ deriving (Eq, Show)
+
+type FieldSignature = FieldType
+
+getInt :: Get (Maybe Int)
+getInt = do
+ s <- getDigits
+ if null s
+ then return Nothing
+ else return $ Just (read s)
+ where
+ getDigits :: Get [Char]
+ getDigits = do
+ c <- lookAhead getChar8
+ if isDigit c
+ then do
+ skip 1
+ next <- getDigits
+ return (c: next)
+ else return []
+
+instance Binary FieldType where
+ put SignedByte = put 'B'
+ put CharByte = put 'C'
+ put DoubleType = put 'D'
+ put FloatType = put 'F'
+ put IntType = put 'I'
+ put LongInt = put 'J'
+ put ShortInt = put 'S'
+ put BoolType = put 'Z'
+ put (ObjectType name) = put 'L' >> put name
+ put (Array Nothing sig) = put '[' >> put sig
+ put (Array (Just n) sig) = put '[' >> put (show n) >> put sig
+
+ get = do
+ b <- getChar8
+ case b of
+ 'B' -> return SignedByte
+ 'C' -> return CharByte
+ 'D' -> return DoubleType
+ 'F' -> return FloatType
+ 'I' -> return IntType
+ 'J' -> return LongInt
+ 'S' -> return ShortInt
+ 'Z' -> return BoolType
+ 'L' -> do
+ name <- getToSemicolon
+ return (ObjectType name)
+ '[' -> do
+ mbSize <- getInt
+ sig <- get
+ return (Array mbSize sig)
+ _ -> fail $ "Unknown signature opening symbol: " ++ [b]
+
+getToSemicolon :: Get String
+getToSemicolon = do
+ x <- get
+ if x == ';'
+ then return []
+ else do
+ next <- getToSemicolon
+ return (x: next)
+
+data ReturnSignature =
+ Returns FieldType
+ | ReturnsVoid
+ deriving (Eq, Show)
+
+instance Binary ReturnSignature where
+ put (Returns sig) = put sig
+ put ReturnsVoid = put 'V'
+
+ get = do
+ x <- lookAhead getChar8
+ case x of
+ 'V' -> skip 1 >> return ReturnsVoid
+ _ -> Returns <$> get
+
+type ArgumentSignature = FieldType
+
+data MethodSignature =
+ MethodSignature [ArgumentSignature] ReturnSignature
+ deriving (Eq, Show)
+
+instance Binary MethodSignature where
+ put (MethodSignature args ret) = do
+ put '('
+ forM_ args put
+ put ')'
+ put ret
+
+ get = do
+ x <- getChar8
+ when (x /= '(') $
+ fail "Cannot parse method signature: no starting `(' !"
+ args <- getArgs
+ y <- getChar8
+ when (y /= ')') $
+ fail "Internal error: method signature without `)' !?"
+ ret <- get
+ return (MethodSignature args ret)
+
+getArgs :: Get [ArgumentSignature]
+getArgs = whileJust getArg
+ where
+ getArg :: Get (Maybe ArgumentSignature)
+ getArg = do
+ x <- lookAhead getChar8
+ if x == ')'
+ then return Nothing
+ else Just <$> get
+
+whileJust :: (Monad m) => m (Maybe a) -> m [a]
+whileJust m = do
+ r <- m
+ case r of
+ Just x -> do
+ next <- whileJust m
+ return (x: next)
+ Nothing -> return []
+
+data CpInfo =
+ CONSTANT_Class {nameIndex :: Word16} -- 7
+ | CONSTANT_Fieldref {classIndex :: Word16, nameAndTypeIndex :: Word16} -- 9
+ | CONSTANT_Methodref {classIndex :: Word16, nameAndTypeIndex :: Word16} -- 10
+ | CONSTANT_InterfaceMethodref {classIndex :: Word16, nameAndTypeIndex :: Word16}-- 11
+ | CONSTANT_String {stringIndex :: Word16} -- 8
+ | CONSTANT_Integer {fourBytes :: Word32} -- 3
+ | CONSTANT_Float Float -- 4
+ | CONSTANT_Long Word64 -- 5
+ | CONSTANT_Double Double -- 6
+ | CONSTANT_NameAndType {nameIndex :: Word16, signatureIndex :: Word16} -- 12
+ | CONSTANT_Utf8 {stringLength :: Word16, stringBytes :: B.ByteString} -- 1
+ | CONSTANT_Unicode {stringLength :: Word16, stringBytes :: B.ByteString} -- 2
+ deriving (Eq, Show)
+
+instance Binary CpInfo where
+ put (CONSTANT_Class i) = putWord8 7 >> put i
+ put (CONSTANT_Fieldref i j) = putWord8 9 >> put i >> put j
+ put (CONSTANT_Methodref i j) = putWord8 10 >> put i >> put j
+ put (CONSTANT_InterfaceMethodref i j) = putWord8 11 >> put i >> put j
+ put (CONSTANT_String i) = putWord8 8 >> put i
+ put (CONSTANT_Integer x) = putWord8 3 >> put x
+ put (CONSTANT_Float x) = putWord8 4 >> putFloat32be x
+ put (CONSTANT_Long x) = putWord8 5 >> put x
+ put (CONSTANT_Double x) = putWord8 6 >> putFloat64be x
+ put (CONSTANT_NameAndType i j) = putWord8 12 >> put i >> put j
+ put (CONSTANT_Utf8 l bs) = putWord8 1 >> put l >> putLazyByteString bs
+ put (CONSTANT_Unicode l bs) = putWord8 2 >> put l >> putLazyByteString bs
+
+ get = do
+ !offset <- bytesRead
+ tag <- getWord8
+ case tag of
+ 1 -> do
+ l <- get
+ bs <- getLazyByteString (fromIntegral l)
+ return $ CONSTANT_Utf8 l bs
+ 2 -> do
+ l <- get
+ bs <- getLazyByteString (fromIntegral l)
+ return $ CONSTANT_Unicode l bs
+ 3 -> CONSTANT_Integer <$> get
+ 4 -> CONSTANT_Float <$> getFloat32be
+ 5 -> CONSTANT_Long <$> get
+ 6 -> CONSTANT_Double <$> getFloat64be
+ 7 -> CONSTANT_Class <$> get
+ 8 -> CONSTANT_String <$> get
+ 9 -> CONSTANT_Fieldref <$> get <*> get
+ 10 -> CONSTANT_Methodref <$> get <*> get
+ 11 -> CONSTANT_InterfaceMethodref <$> get <*> get
+ 12 -> CONSTANT_NameAndType <$> get <*> get
+ _ -> fail $ "Unknown constants pool entry tag: " ++ show tag
+
+data FieldInfo = FieldInfo {
+ fieldAccessFlags :: Word16,
+ fieldNameIndex :: Word16,
+ fieldSignatureIndex :: Word16,
+ fieldAttributesCount :: Word16,
+ fieldAttributes :: [AttributeInfo] }
+ deriving (Eq, Show)
+
+instance Binary FieldInfo where
+ put (FieldInfo {..}) = do
+ put fieldAccessFlags
+ put fieldNameIndex
+ put fieldSignatureIndex
+ put fieldAttributesCount
+ forM_ fieldAttributes put
+
+ get = do
+ af <- get
+ ni <- get
+ si <- get
+ n <- get
+ as <- replicateM (fromIntegral n) get
+ return $ FieldInfo af ni si n as
+
+data MethodInfo = MethodInfo {
+ methodAccessFlags :: Word16,
+ methodNameIndex :: Word16,
+ methodSignatureIndex :: Word16,
+ methodAttributesCount :: Word16,
+ methodAttributes :: [AttributeInfo] }
+ deriving (Eq, Show)
+
+instance Binary MethodInfo where
+ put (MethodInfo {..}) = do
+ put methodAccessFlags
+ put methodNameIndex
+ put methodSignatureIndex
+ put methodAttributesCount
+ forM_ methodAttributes put
+
+ get = do
+ offset <- bytesRead
+ af <- get
+ ni <- get
+ si <- get
+ n <- get
+ as <- replicateM (fromIntegral n) get
+ return $ MethodInfo af ni si n as
+
+data AttributeInfo = AttributeInfo {
+ attributeName :: Word16,
+ attributeLength :: Word32,
+ attributeValue :: B.ByteString }
+ deriving (Eq, Show)
+
+instance Binary AttributeInfo where
+ put (AttributeInfo {..}) = do
+ put attributeName
+ putWord32be attributeLength
+ putLazyByteString attributeValue
+
+ get = do
+ offset <- bytesRead
+ name <- get
+ len <- getWord32be
+ value <- getLazyByteString (fromIntegral len)
+ return $ AttributeInfo name len value
+
+
--- /dev/null
+{-# LANGUAGE TypeFamilies, StandaloneDeriving, FlexibleInstances, FlexibleContexts, UndecidableInstances, RecordWildCards, OverloadedStrings #-}
+module JVM.Converter where
+
+import Codec.Binary.UTF8.String hiding (encode, decode)
+import Data.List
+import Data.Word
+import Data.Bits
+import Data.Binary
+import Data.Char
+import Data.String
+import qualified Data.ByteString.Lazy as B
+import Data.Array
+import qualified Data.Set as S
+import qualified Data.Map as M
+
+import Debug.Trace
+
+import JVM.ClassFile
+import JVM.Types
+
+instance IsString B.ByteString where
+ fromString s = B.pack $ map (fromIntegral . ord) $ encodeString s
+
+decompile :: B.ByteString -> Class
+decompile bstr = convertClass $ decode bstr
+
+decompileFile :: FilePath -> IO Class
+decompileFile path = convertClass `fmap` decodeFile path
+
+convertClass :: ClassFile -> Class
+convertClass (ClassFile {..}) =
+ 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 }
+
+constantPoolArray :: [CpInfo] -> Pool
+constantPoolArray list = pool
+ where
+ pool :: Pool
+ pool = listArray (1,n) $ map convert list
+ n = fromIntegral $ length list
+
+ convertNameType :: (HasSignature a, Binary (Signature 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
+
+className' x = trace ("Class name: " ++ show x) B.empty
+
+convertAccess :: Word16 -> Access
+convertAccess w = S.fromList $ concat $ zipWith (\i f -> if testBit w i then [f] else []) [0..] $ [
+ ACC_PUBLIC,
+ ACC_PRIVATE,
+ ACC_PROTECTED,
+ ACC_STATIC,
+ ACC_FINAL,
+ ACC_SYNCHRONIZED,
+ ACC_VOLATILE,
+ ACC_TRANSIENT,
+ ACC_NATIVE,
+ ACC_INTERFACE,
+ ACC_ABSTRACT ]
+
+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
+ where
+ go (AttributeInfo {..}) = (getString $ pool ! attributeName,
+ attributeValue)
+
+methodByName :: Class -> B.ByteString -> Maybe Method
+methodByName cls name =
+ find (\m -> methodName m == name) (methods cls)
+
+attrByName :: (HasAttributes a) => a -> B.ByteString -> Maybe B.ByteString
+attrByName x name = M.lookup name (attributes x)
+
+methodCode :: Class -> B.ByteString -> Maybe B.ByteString
+methodCode cls name = do
+ method <- methodByName cls name
+ attrByName method "Code"
+
--- /dev/null
+{-# LANGUAGE TypeFamilies, StandaloneDeriving, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
+module JVM.Types where
+
+import Data.Array
+import qualified Data.ByteString.Lazy as B
+import Data.Word
+import qualified Data.Set as S
+import qualified Data.Map as M
+
+import JVM.ClassFile
+
+type Pool = Array Word16 Constant
+
+class HasAttributes a where
+ attributes :: a -> Attributes
+
+data Class = Class {
+ constantPool :: Pool,
+ classAccess :: Access,
+ this :: B.ByteString, -- ^ this class name
+ super :: Maybe B.ByteString, -- ^ super class name
+ implements :: [B.ByteString], -- ^ implemented interfaces
+ fields :: [Field],
+ methods :: [Method],
+ classAttrs :: Attributes
+ }
+ deriving (Eq, Show)
+
+instance HasAttributes Class where
+ attributes = classAttrs
+
+class HasSignature a where
+ type Signature a
+
+data NameType a = NameType {
+ ntName :: B.ByteString,
+ ntSignature :: Signature a }
+
+deriving instance Show (Signature a) => Show (NameType a)
+deriving instance Eq (Signature a) => Eq (NameType a)
+
+data Constant =
+ CClass {className :: B.ByteString}
+ | CField {refClass :: B.ByteString, fieldNameType :: NameType Field}
+ | CMethod {refClass :: B.ByteString, nameType :: NameType Method}
+ | CIfaceMethod {refClass :: B.ByteString, nameType :: NameType Method}
+ | CString B.ByteString
+ | CInteger Word32
+ | CFloat Float
+ | CLong Integer
+ | CDouble Double
+ | CNameType B.ByteString B.ByteString
+ | CUTF8 {getString :: B.ByteString}
+ | CUnicode {getString :: B.ByteString}
+ deriving (Eq, Show)
+
+data Field = Field {
+ fieldAccess :: Access,
+ fieldName :: B.ByteString,
+ fieldSignature :: FieldSignature,
+ fieldAttrs :: Attributes }
+ deriving (Eq, Show)
+
+instance HasSignature Field where
+ type Signature Field = FieldSignature
+
+instance HasAttributes Field where
+ attributes = fieldAttrs
+
+data Method = Method {
+ methodAccess :: Access,
+ methodName :: B.ByteString,
+ methodSignature :: MethodSignature,
+ methodAttrs :: Attributes }
+ deriving (Eq, Show)
+
+instance HasSignature Method where
+ type Signature Method = MethodSignature
+
+instance HasAttributes Method where
+ attributes = methodAttrs
+
+type Access = S.Set AccessFlag
+
+data AccessFlag =
+ ACC_PUBLIC -- 0x0001 Видимый для всех Класс, Метод, Переменная
+ | ACC_PRIVATE -- 0x0002 Видимый только для определяемого класса Метод, Переменная
+ | ACC_PROTECTED -- 0x0004 Видимый для подклассов Метод, Переменная
+ | ACC_STATIC -- 0x0008 Переменная или метод статические Метод, Переменная
+ | ACC_FINAL -- 0x0010 Нет дальнейшей подкласификации, обхода или присваивания после инициализации Класс, Метод, Переменная
+ | ACC_SYNCHRONIZED -- 0x0020 Использует возврат в блокировке монитора Метод
+ | ACC_VOLATILE -- 0x0040 Не может помещать в кеш Переменная
+ | ACC_TRANSIENT -- 0x0080 Не может боть написан или прочитан постоянным объектом управления Перемення
+ | ACC_NATIVE -- 0x0100 Реализован в других языках Метод
+ | ACC_INTERFACE -- 0x0200 интерфейс Класс
+ | ACC_ABSTRACT -- 0x0400 Ничего не предусматривает Класс, Метод
+ deriving (Eq, Show, Ord)
+
+data Attribute = Attribute {
+ attrName :: B.ByteString,
+ attrValue :: B.ByteString }
+ deriving (Eq, Show)
+
+class AttributeValue a where
+ decodeAttribute :: B.ByteString -> a
+ encodeAttribute :: a -> B.ByteString
+
+type Attributes = M.Map B.ByteString B.ByteString
+
projects / hs-java.git / commitdiff