-{-# LANGUAGE RecordWildCards, BangPatterns #-}
+{-# LANGUAGE RecordWildCards, BangPatterns, TypeFamilies, StandaloneDeriving, FlexibleContexts, FlexibleInstances, UndecidableInstances, TypeSynonymInstances #-}
-- | This module declares (low-level) data types for Java .class files
-- structures, and Binary instances to read/write them.
module JVM.ClassFile
- (ClassFile (..),
- CpInfo (..),
- FieldInfo (..),
- MethodInfo (..),
- AttributeInfo (..),
+ (Attribute (..),
FieldType (..),
FieldSignature, MethodSignature (..), ReturnSignature (..),
- ArgumentSignature (..)
+ ArgumentSignature (..),
+ Pool, Link,
+ Method (..), Field (..), Class (..),
+ Constant (..),
+ Pointers, Resolved,
+ NameType (..),
+ HasSignature (..), HasAttributes (..),
+ AccessFlag (..), AccessFlags,
+ Attributes (..),
+ className
)
where
import Data.Binary.Put
import Data.Char
import Data.List
+import qualified Data.Set as S
+import qualified Data.Map as M
import qualified Data.ByteString.Lazy as B
+import Codec.Binary.UTF8.String hiding (encode, decode)
-- | Read one-byte Char
getChar8 :: Get Char
x <- getWord8
return $ chr (fromIntegral x)
+toString :: B.ByteString -> String
+toString bstr = decodeString $ map (chr . fromIntegral) $ B.unpack bstr
+
+type family Link s a
+
+data Pointers = Pointers
+
+data Resolved = Resolved
+
+type instance Link Pointers a = Word16
+
+type instance Link Resolved a = a
+
+type family AccessFlags stage
+
+type instance AccessFlags Pointers = Word16
+
+type instance AccessFlags Resolved = S.Set AccessFlag
+
+type family Attributes stage
+
+type instance Attributes Pointers = [Attribute]
+type instance Attributes Resolved = M.Map B.ByteString B.ByteString
+
+-- | Access flags. Used for classess, methods, variables.
+data AccessFlag =
+ ACC_PUBLIC -- ^ 0x0001 Visible for all
+ | ACC_PRIVATE -- ^ 0x0002 Visible only for defined class
+ | ACC_PROTECTED -- ^ 0x0004 Visible only for subclasses
+ | ACC_STATIC -- ^ 0x0008 Static method or variable
+ | ACC_FINAL -- ^ 0x0010 No further subclassing or assignments
+ | ACC_SYNCHRONIZED -- ^ 0x0020 Uses monitors
+ | ACC_VOLATILE -- ^ 0x0040 Could not be cached
+ | ACC_TRANSIENT -- ^ 0x0080
+ | ACC_NATIVE -- ^ 0x0100 Implemented in other language
+ | ACC_INTERFACE -- ^ 0x0200 Class is interface
+ | ACC_ABSTRACT -- ^ 0x0400
+ deriving (Eq, Show, Ord, Enum)
+
+class HasSignature a where
+ type Signature a
+
+instance HasSignature Field where
+ type Signature Field = FieldSignature
+
+instance HasSignature Method where
+ type Signature Method = MethodSignature
+
+-- | Name and signature pair. Used for methods and fields.
+data NameType a = NameType {
+ ntName :: B.ByteString,
+ ntSignature :: Signature a }
+
+instance Show (Signature a) => Show (NameType a) where
+ show (NameType n t) = toString n ++ ": " ++ show t
+
+deriving instance Eq (Signature a) => Eq (NameType a)
+
+instance (Binary (Signature a)) => Binary (NameType a) where
+ put (NameType n t) = putLazyByteString n >> put t
+
+ get = NameType <$> get <*> get
+
+-- | Constant pool item
+data Constant stage =
+ CClass B.ByteString
+ | CField {refClass :: Link stage B.ByteString, fieldNameType :: Link stage (NameType Field)}
+ | CMethod {refClass :: Link stage B.ByteString, nameType :: Link stage (NameType Method)}
+ | CIfaceMethod {refClass :: Link stage B.ByteString, nameType :: Link stage (NameType Method)}
+ | CString (Link stage B.ByteString)
+ | CInteger Word32
+ | CFloat Float
+ | CLong Integer
+ | CDouble Double
+ | CNameType (Link stage B.ByteString) (Link stage B.ByteString)
+ | CUTF8 {getString :: B.ByteString}
+ | CUnicode {getString :: B.ByteString}
+
+className :: Constant Resolved -> B.ByteString
+className (CClass s) = s
+className x = error $ "Not a class: " ++ show x
+
+instance Show (Constant Resolved) where
+ show (CClass name) = "class " ++ toString name
+ show (CField cls nt) = "field " ++ toString cls ++ "." ++ show nt
+ show (CMethod cls nt) = "method " ++ toString cls ++ "." ++ show nt
+ show (CIfaceMethod cls nt) = "interface method " ++ toString cls ++ "." ++ show nt
+ show (CString s) = "String \"" ++ toString s ++ "\""
+ show (CInteger x) = show x
+ show (CFloat x) = show x
+ show (CLong x) = show x
+ show (CDouble x) = show x
+ show (CNameType name tp) = toString name ++ ": " ++ toString tp
+ show (CUTF8 s) = "UTF8 \"" ++ toString s ++ "\""
+ show (CUnicode s) = "Unicode \"" ++ toString s ++ "\""
+
+-- | Constant pool
+type Pool stage = M.Map Word16 (Constant stage)
+
-- | Generic .class file format
-data ClassFile = ClassFile {
+data Class stage = Class {
magic :: Word32, -- ^ Magic value: 0xCAFEBABE
minorVersion :: Word16,
majorVersion :: Word16,
constsPoolSize :: Word16, -- ^ Number of items in constants pool
- constsPool :: [CpInfo], -- ^ Constants pool itself
- accessFlags :: Word16, -- ^ See @JVM.Types.AccessFlag@
- thisClass :: Word16, -- ^ Constants pool item index for this class
- superClass :: Word16, -- ^ --/-- for super class, zero for java.lang.Object
+ constsPool :: Pool stage, -- ^ Constants pool itself
+ accessFlags :: AccessFlags stage, -- ^ See @JVM.Types.AccessFlag@
+ thisClass :: Link stage B.ByteString, -- ^ Constants pool item index for this class
+ superClass :: Link stage B.ByteString, -- ^ --/-- for super class, zero for java.lang.Object
interfacesCount :: Word16, -- ^ Number of implemented interfaces
- interfaces :: [Word16], -- ^ Constants pool item indexes for implemented interfaces
+ interfaces :: [Link stage B.ByteString], -- ^ Constants pool item indexes for implemented interfaces
classFieldsCount :: Word16, -- ^ Number of class fileds
- classFields :: [FieldInfo], -- ^ Class fields
+ classFields :: [Field stage], -- ^ Class fields
classMethodsCount :: Word16, -- ^ Number of class methods
- classMethods :: [MethodInfo], -- ^ Class methods
+ classMethods :: [Method stage], -- ^ Class methods
classAttributesCount :: Word16, -- ^ Number of class attributes
- classAttributes :: [AttributeInfo] -- ^ Class attributes
+ classAttributes :: Attributes stage -- ^ Class attributes
}
- deriving (Eq, Show)
-instance Binary ClassFile where
- put (ClassFile {..}) = do
+deriving instance Eq (Constant Pointers)
+deriving instance Eq (Constant Resolved)
+deriving instance Show (Constant Pointers)
+
+instance Binary (Class Pointers) where
+ put (Class {..}) = do
put magic
put minorVersion
put majorVersion
put constsPoolSize
- forM_ constsPool put
+ forM_ (M.elems constsPool) put
put accessFlags
put thisClass
put superClass
classMethods <- replicateM (fromIntegral classMethodsCount) get
asCount <- get
as <- replicateM (fromIntegral $ asCount) get
- return $ ClassFile magic minor major poolsize pool af this super
+ let pool' = M.fromList $ zip [1..] pool
+ return $ Class magic minor major poolsize pool' af this super
interfacesCount ifaces classFieldsCount classFields classMethodsCount classMethods asCount as
-- | Field signature format
return (x: next)
Nothing -> return []
--- | Constant pool item format
-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
+instance Binary (Constant Pointers) where
+ put (CClass i) = putWord8 7 >> put i
+ put (CField i j) = putWord8 9 >> put i >> put j
+ put (CMethod i j) = putWord8 10 >> put i >> put j
+ put (CIfaceMethod i j) = putWord8 11 >> put i >> put j
+ put (CString i) = putWord8 8 >> put i
+ put (CInteger x) = putWord8 3 >> put x
+ put (CFloat x) = putWord8 4 >> putFloat32be x
+ put (CLong x) = putWord8 5 >> put x
+ put (CDouble x) = putWord8 6 >> putFloat64be x
+ put (CNameType i j) = putWord8 12 >> put i >> put j
+ put (CUTF8 bs) = do
+ putWord8 1
+ put (fromIntegral (B.length bs) :: Word16)
+ putLazyByteString bs
+ put (CUnicode bs) = do
+ putWord8 2
+ put (fromIntegral (B.length bs) :: Word16)
+ putLazyByteString bs
get = do
!offset <- bytesRead
case tag of
1 -> do
l <- get
- bs <- getLazyByteString (fromIntegral l)
- return $ CONSTANT_Utf8 l bs
+ bs <- getLazyByteString (fromIntegral (l :: Word16))
+ return $ CUTF8 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
+ bs <- getLazyByteString (fromIntegral (l :: Word16))
+ return $ CUnicode bs
+ 3 -> CInteger <$> get
+ 4 -> CFloat <$> getFloat32be
+ 5 -> CLong <$> get
+ 6 -> CDouble <$> getFloat64be
+ 7 -> CClass <$> get
+ 8 -> CString <$> get
+ 9 -> CField <$> get <*> get
+ 10 -> CMethod <$> get <*> get
+ 11 -> CIfaceMethod <$> get <*> get
+ 12 -> CNameType <$> get <*> get
_ -> fail $ "Unknown constants pool entry tag: " ++ show tag
-- | Class field format
-data FieldInfo = FieldInfo {
- fieldAccessFlags :: Word16,
- fieldNameIndex :: Word16,
- fieldSignatureIndex :: Word16,
+data Field stage = Field {
+ fieldAccessFlags :: AccessFlags stage,
+ fieldName :: Link stage B.ByteString,
+ fieldSignature :: Link stage FieldSignature,
fieldAttributesCount :: Word16,
- fieldAttributes :: [AttributeInfo] }
- deriving (Eq, Show)
+ fieldAttributes :: Attributes stage }
+
+deriving instance Eq (Field Pointers)
+deriving instance Eq (Field Resolved)
+deriving instance Show (Field Pointers)
+deriving instance Show (Field Resolved)
-instance Binary FieldInfo where
- put (FieldInfo {..}) = do
+instance Binary (Field Pointers) where
+ put (Field {..}) = do
put fieldAccessFlags
- put fieldNameIndex
- put fieldSignatureIndex
+ put fieldName
+ put fieldSignature
put fieldAttributesCount
forM_ fieldAttributes put
si <- get
n <- get
as <- replicateM (fromIntegral n) get
- return $ FieldInfo af ni si n as
+ return $ Field af ni si n as
-- | Class method format
-data MethodInfo = MethodInfo {
- methodAccessFlags :: Word16,
- methodNameIndex :: Word16,
- methodSignatureIndex :: Word16,
+data Method stage = Method {
+ methodAccessFlags :: Attributes stage,
+ methodName :: Link stage B.ByteString,
+ methodSignature :: Link stage MethodSignature,
methodAttributesCount :: Word16,
- methodAttributes :: [AttributeInfo] }
- deriving (Eq, Show)
+ methodAttributes :: Attributes stage }
+
+deriving instance Eq (Method Pointers)
+deriving instance Eq (Method Resolved)
+deriving instance Show (Method Pointers)
+deriving instance Show (Method Resolved)
-instance Binary MethodInfo where
- put (MethodInfo {..}) = do
+instance Binary (Method Pointers) where
+ put (Method {..}) = do
put methodAccessFlags
- put methodNameIndex
- put methodSignatureIndex
+ put methodName
+ put methodSignature
put methodAttributesCount
forM_ methodAttributes put
si <- get
n <- get
as <- replicateM (fromIntegral n) get
- return $ MethodInfo af ni si n as
+ return $ Method af ni si n as
-- | Any (class/ field/ method/ ...) attribute format.
-- Some formats specify special formats for @attributeValue@.
-data AttributeInfo = AttributeInfo {
+data Attribute = Attribute {
attributeName :: Word16,
attributeLength :: Word32,
attributeValue :: B.ByteString }
deriving (Eq, Show)
-instance Binary AttributeInfo where
- put (AttributeInfo {..}) = do
+instance Binary Attribute where
+ put (Attribute {..}) = do
put attributeName
putWord32be attributeLength
putLazyByteString attributeValue
name <- get
len <- getWord32be
value <- getLazyByteString (fromIntegral len)
- return $ AttributeInfo name len value
+ return $ Attribute name len value
+
+class HasAttributes a where
+ attributes :: a stage -> Attributes stage
+
+instance HasAttributes Class where
+ attributes = classAttributes
+
+instance HasAttributes Field where
+ attributes = fieldAttributes
+
+instance HasAttributes Method where
+ attributes = methodAttributes
import JVM.Exceptions
-- | Parse .class file data
-parseClass :: B.ByteString -> Class
+parseClass :: B.ByteString -> Class Resolved
parseClass bstr = convertClass $ decode bstr
-- | Parse class data from file
-parseClassFile :: FilePath -> IO Class
+parseClassFile :: FilePath -> IO (Class Resolved)
parseClassFile path = convertClass `fmap` decodeFile path
-encodeClass :: Class -> B.ByteString
+encodeClass :: (Class Resolved) -> B.ByteString
encodeClass cls = encode $ classFile cls
-convertClass :: ClassFile -> Class
-convertClass (ClassFile {..}) =
+convertClass :: Class Pointers -> Class Resolved
+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 Resolved -> Class Pointers
+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 (M.size classAttributes),
+ classAttributes = map (attrInfo poolInfo) (M.assocs classAttributes) }
where
- poolInfo = toCPInfo constantPool
+ poolInfo = toCPInfo constsPool
-toCPInfo :: Pool -> [CpInfo]
+toCPInfo :: Pool Resolved -> Pool Pointers
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 Resolved -> Constant Pointers
+ 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 (fromIntegral $ B.length s) s
+ cpInfo (CUnicode s) = CUnicode (fromIntegral $ B.length s) s
-- | Find index of given string in the list of constants
-poolIndex :: (Throws NoItemInPool e) => [CpInfo] -> B.ByteString -> EM e Word16
+poolIndex :: (Throws NoItemInPool e) => Pool Pointers -> B.ByteString -> EM e Word16
poolIndex list name = case findIndex test 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 :: (Throws NoItemInPool e) => Pool Pointers -> B.ByteString -> EM e Word16
poolClassIndex list name = case findIndex checkString list of
Nothing -> throw (NoItemInPool name)
Just i -> case findIndex (checkClass $ fromIntegral $ i+1) 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
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 Pointers -> Field Resolved -> Field Pointers
+fieldInfo pool (Field {..}) = Field {
+ fieldAccessFlags = access2word16 fieldAccessFlags,
+ fieldName = force "field name" $ poolIndex pool fieldName,
+ fieldSignature = force "signature" $ poolIndex pool (encode fieldSignature),
+ fieldAttributesCount = fromIntegral (M.size fieldAttributes),
+ fieldAttributes = map (attrInfo pool) (M.assocs fieldAttributes) }
+
+methodInfo :: Pool Pointers -> Method Resolved -> Method Pointers
+methodInfo pool (Method {..}) = Method {
+ methodAccessFlags = access2word16 methodAccessFlags,
+ methodName = force "method name" $ poolIndex pool methodName,
+ methodSignature = force "method sig" $ poolIndex pool (encode methodSignature),
+ methodAttributesCount = fromIntegral (M.size methodAttributes),
+ methodAttributes = map (attrInfo pool) (M.assocs methodAttributes) }
+
+attrInfo :: Pool Pointers -> (B.ByteString, B.ByteString) -> Attributes Pointers
+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 Pointers -> Pool Resolved
+constantPoolArray ps = pool
where
pool :: Pool
- pool = M.fromList $ zip [1..] $ map convert list
- n = fromIntegral $ length list
+ pool = M.map convert ps
+
+ n = fromIntegral $ length ps
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
-
-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 Pointers -> AccessFlags Resolved
convertAccess w = S.fromList $ concat $ zipWith (\i f -> if testBit w i then [f] else []) [0..] $ [
ACC_PUBLIC,
ACC_PRIVATE,
ACC_INTERFACE,
ACC_ABSTRACT ]
-access2word16 :: Access -> Word16
+access2word16 :: AccessFlags Resolved -> AccessFlags Pointers
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
+convertField :: Pool Resolved -> Field Pointers -> Field Resolved
+convertField pool (Field {..}) = Field {
+ fieldAccessFlags = convertAccess fieldAccessFlags,
+ fieldName = getString $ pool ! fieldName,
+ fieldSignature = decode $ getString $ pool ! fieldSignature,
+ fieldAttributes = convertAttrs pool fieldAttributes }
+
+convertMethod :: Pool Resolved -> Method Pointers -> Method Resolved
+convertMethod pool (Method {..}) = Method {
+ methodAccessFlags = convertAccess methodAccessFlags,
+ methodName = getString $ pool ! methodName,
+ methodSignature = decode $ getString $ pool ! methodSignature,
+ methodAttributes = convertAttrs pool methodAttributes }
+
+convertAttrs :: Pool Resolved -> Attributes Pointers -> Attributes Resolved
convertAttrs pool attrs = M.fromList $ map go attrs
where
- go (AttributeInfo {..}) = (getString $ pool ! attributeName,
- attributeValue)
+ go (Attribute {..}) = (getString $ pool ! attributeName,
+ attributeValue)
-- | Try to get class method by name
-methodByName :: Class -> B.ByteString -> Maybe Method
+methodByName :: Class Resolved -> B.ByteString -> Maybe (Method Resolved)
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 :: (HasAttributes a) => a Resolved -> B.ByteString -> Maybe B.ByteString
attrByName x name = M.lookup name (attributes x)
-- | Try to get Code for class method (no Code for interface methods)
-methodCode :: Class
+methodCode :: Class Resolved
-> B.ByteString -- ^ Method name
-> Maybe B.ByteString
methodCode cls name = do
instance IsString B.ByteString where
fromString s = B.pack $ map (fromIntegral . ord) $ encodeString s
-toString :: B.ByteString -> String
-toString bstr = decodeString $ map (chr . fromIntegral) $ B.unpack bstr
-
toCharList :: B.ByteString -> [Int]
toCharList bstr = map fromIntegral $ B.unpack bstr
--- | Constant pool
-type Pool = M.Map Word16 Constant
-
-poolSize :: Pool -> Int
+poolSize :: Pool stage -> Int
poolSize = M.size
(!) :: (Ord k) => M.Map k a -> k -> a
showListIx list = unlines $ zipWith s [1..] list
where s i x = show i ++ ":\t" ++ show x
-class HasAttributes a where
- attributes :: a -> Attributes
-
--- | Java class
-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
-
--- | Name and signature pair. Used for methods and fields.
-data NameType a = NameType {
- ntName :: B.ByteString,
- ntSignature :: Signature a }
-
-instance Show (Signature a) => Show (NameType a) where
- show (NameType n t) = toString n ++ ": " ++ show t
-
-deriving instance Eq (Signature a) => Eq (NameType a)
-
--- | Constant pool item
-data Constant =
- CClass 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)
-
-className :: Constant -> B.ByteString
-className (CClass s) = s
-className x = error $ "Not a class: " ++ show x
-
-instance Show Constant where
- show (CClass name) = "class " ++ toString name
- show (CField cls nt) = "field " ++ toString cls ++ "." ++ show nt
- show (CMethod cls nt) = "method " ++ toString cls ++ "." ++ show nt
- show (CIfaceMethod cls nt) = "interface method " ++ toString cls ++ "." ++ show nt
- show (CString s) = "String \"" ++ toString s ++ "\""
- show (CInteger x) = show x
- show (CFloat x) = show x
- show (CLong x) = show x
- show (CDouble x) = show x
- show (CNameType name tp) = toString name ++ ": " ++ toString tp
- show (CUTF8 s) = "UTF8 \"" ++ toString s ++ "\""
- show (CUnicode s) = "Unicode \"" ++ toString s ++ "\""
-
--- | Class field
-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
-
--- | Class method
-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
-
--- | Set of access flags
-type Access = S.Set AccessFlag
-
--- | Access flags. Used for classess, methods, variables.
-data AccessFlag =
- ACC_PUBLIC -- ^ 0x0001 Visible for all
- | ACC_PRIVATE -- ^ 0x0002 Visible only for defined class
- | ACC_PROTECTED -- ^ 0x0004 Visible only for subclasses
- | ACC_STATIC -- ^ 0x0008 Static method or variable
- | ACC_FINAL -- ^ 0x0010 No further subclassing or assignments
- | ACC_SYNCHRONIZED -- ^ 0x0020 Uses monitors
- | ACC_VOLATILE -- ^ 0x0040 Could not be cached
- | ACC_TRANSIENT -- ^ 0x0080
- | ACC_NATIVE -- ^ 0x0100 Implemented in other language
- | ACC_INTERFACE -- ^ 0x0200 Class is interface
- | ACC_ABSTRACT -- ^ 0x0400
- deriving (Eq, Show, Ord, Enum)
-
--- | Generic attribute
-data Attribute = Attribute {
- attrName :: B.ByteString,
- attrValue :: B.ByteString }
- deriving (Eq, Show)
-
--- | Set of attributes
-type Attributes = M.Map B.ByteString B.ByteString
-
-instance (Binary (Signature a)) => Binary (NameType a) where
- put (NameType n t) = putLazyByteString n >> put t
-
- get = NameType <$> get <*> get
-
byteString :: (Binary t) => t -> B.ByteString
byteString x = runPut (put x)
projects / hs-java.git / commitdiff