From 7bccc38b8504325928429cced480f1714a7cf214 Mon Sep 17 00:00:00 2001 From: "Ilya V. Portnov" Date: Fri, 30 Sep 2011 13:36:40 +0600 Subject: [PATCH] Use type families to distinguish class parsing/building stages. --- JVM/ClassFile.hs | 301 +++++++++++++++++++++++++++++++++-------------- JVM/Converter.hs | 230 +++++++++++++++++++----------------- JVM/Types.hs | 134 +-------------------- 3 files changed, 331 insertions(+), 334 deletions(-) diff --git a/JVM/ClassFile.hs b/JVM/ClassFile.hs index e9b1377..87acae4 100644 --- a/JVM/ClassFile.hs +++ b/JVM/ClassFile.hs @@ -1,15 +1,20 @@ -{-# 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 @@ -21,7 +26,10 @@ import Data.Binary.Get 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 @@ -29,34 +37,136 @@ getChar8 = do 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 @@ -86,7 +196,8 @@ instance Binary ClassFile where 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 @@ -252,35 +363,25 @@ whileJust m = do 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 @@ -288,38 +389,42 @@ instance Binary CpInfo where 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 @@ -329,22 +434,26 @@ instance Binary FieldInfo where 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 @@ -355,18 +464,18 @@ instance Binary MethodInfo where 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 @@ -376,5 +485,17 @@ instance Binary AttributeInfo where 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 diff --git a/JVM/Converter.hs b/JVM/Converter.hs index a5f9d10..e53f380 100644 --- a/JVM/Converter.hs +++ b/JVM/Converter.hs @@ -25,98 +25,105 @@ import JVM.Types 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 @@ -126,58 +133,59 @@ 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, @@ -191,43 +199,43 @@ convertAccess w = S.fromList $ concat $ zipWith (\i f -> if testBit w i then [f] 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 diff --git a/JVM/Types.hs b/JVM/Types.hs index 7ce6580..6af75e7 100644 --- a/JVM/Types.hs +++ b/JVM/Types.hs @@ -17,16 +17,10 @@ import JVM.ClassFile 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 @@ -36,132 +30,6 @@ showListIx :: (Show a) => [a] -> String 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) -- 2.25.1