{-# LANGUAGE TypeFamilies, StandaloneDeriving, FlexibleInstances, FlexibleContexts, UndecidableInstances, RecordWildCards, OverloadedStrings #-}
-module JVM.Converter where
+-- | Functions to convert from low-level .class format representation and
+-- high-level Java classes, methods etc representation
+module JVM.Converter
+ (parseClass, parseClassFile,
+ classFile2Direct, classDirect2File,
+ encodeClass,
+ methodByName,
+ attrByName,
+ methodCode
+ )
+ where
+import Control.Monad.Exception
import Data.List
import Data.Word
import Data.Bits
import Data.Binary
-import Data.Char
-import Data.String
+import Data.Default () -- import instances only
import qualified Data.ByteString.Lazy as B
-import Data.Array
+import qualified Data.ByteString.Lazy.Char8 ()
import qualified Data.Set as S
import qualified Data.Map as M
-import Debug.Trace
-
import JVM.ClassFile
-import JVM.Types
+import JVM.Common
+import JVM.Exceptions
-decompile :: B.ByteString -> Class
-decompile bstr = convertClass $ decode bstr
+-- | Parse .class file data
+parseClass :: B.ByteString -> Class Direct
+parseClass bstr = classFile2Direct $ decode bstr
-decompileFile :: FilePath -> IO Class
-decompileFile path = convertClass `fmap` decodeFile path
+-- | Parse class data from file
+parseClassFile :: FilePath -> IO (Class Direct)
+parseClassFile path = classFile2Direct `fmap` decodeFile path
-convertClass :: ClassFile -> Class
-convertClass (ClassFile {..}) =
- let pool = constantPoolArray constsPool
+encodeClass :: (Class Direct) -> B.ByteString
+encodeClass cls = encode $ classDirect2File cls
+
+classFile2Direct :: Class File -> Class Direct
+classFile2Direct (Class {..}) =
+ let pool = poolFile2Direct 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
+ d = defaultClass :: Class Direct
+ in d {
+ constsPoolSize = fromIntegral (M.size pool),
+ constsPool = pool,
+ accessFlags = accessFile2Direct accessFlags,
+ thisClass = className $ pool ! thisClass,
+ superClass = if superClass == 0 then "" else superName,
+ interfacesCount = interfacesCount,
+ interfaces = map (\i -> className $ pool ! i) interfaces,
+ classFieldsCount = classFieldsCount,
+ classFields = map (fieldFile2Direct pool) classFields,
+ classMethodsCount = classMethodsCount,
+ classMethods = map (methodFile2Direct pool) classMethods,
+ classAttributesCount = classAttributesCount,
+ classAttributes = attributesFile2Direct pool classAttributes }
+
+classDirect2File :: Class Direct -> Class File
+classDirect2File (Class {..}) =
+ let d = defaultClass :: Class File
+ in d {
+ constsPoolSize = fromIntegral (M.size poolInfo + 1),
+ constsPool = poolInfo,
+ accessFlags = accessDirect2File accessFlags,
+ thisClass = force "this" $ poolClassIndex poolInfo thisClass,
+ superClass = force "super" $ poolClassIndex poolInfo superClass,
+ interfacesCount = fromIntegral (length interfaces),
+ interfaces = map (force "ifaces" . poolIndex poolInfo) interfaces,
+ classFieldsCount = fromIntegral (length classFields),
+ classFields = map (fieldDirect2File poolInfo) classFields,
+ classMethodsCount = fromIntegral (length classMethods),
+ classMethods = map (methodDirect2File poolInfo) classMethods,
+ classAttributesCount = fromIntegral $ arsize classAttributes,
+ classAttributes = to (arlist classAttributes) }
+ where
+ poolInfo = poolDirect2File constsPool
+ to :: [(B.ByteString, B.ByteString)] -> Attributes File
+ to pairs = AP (map (attrInfo poolInfo) pairs)
+
+poolDirect2File :: Pool Direct -> Pool File
+poolDirect2File pool = result
+ where
+ result = M.map cpInfo pool
+
+ cpInfo :: Constant Direct -> Constant File
+ cpInfo (CClass name) = CClass (force "class" $ poolIndex result name)
+ cpInfo (CField cls name) =
+ CField (force "field a" $ poolClassIndex result cls) (force "field b" $ poolNTIndex result name)
+ cpInfo (CMethod cls name) =
+ CMethod (force "method a" $ poolClassIndex result cls) (force ("method b: " ++ show name) $ poolNTIndex result name)
+ cpInfo (CIfaceMethod cls name) =
+ 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) =
+ 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) => 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 (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) => Pool File -> B.ByteString -> EM e Word16
+poolClassIndex list name = case findIndex checkString (M.elems list) of
+ Nothing -> throw (NoItemInPool name)
+ Just i -> case findIndex (checkClass $ fromIntegral $ i+1) (M.elems list) of
+ Nothing -> throw (NoItemInPool $ i+1)
+ Just j -> return $ fromIntegral $ j+1
+ where
+ checkString (CUTF8 s) | s == name = True
+ checkString (CUnicode s) | s == name = True
+ checkString _ = False
+
+ 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) (M.elems list) of
+ Nothing -> throw (NoItemInPool x)
+ Just i -> return $ fromIntegral (i+1)
where
- pool :: Pool
- pool = listArray (1,n) $ map convert list
- n = fromIntegral $ length list
+ check ni ti (CNameType n' t')
+ | (ni == n') && (ti == t') = True
+ check _ _ _ = False
- convertNameType :: (HasSignature a, Binary (Signature a)) => Word16 -> NameType a
+fieldDirect2File :: Pool File -> Field Direct -> Field File
+fieldDirect2File pool (Field {..}) = Field {
+ fieldAccessFlags = accessDirect2File fieldAccessFlags,
+ fieldName = force "field name" $ poolIndex pool fieldName,
+ fieldSignature = force "signature" $ poolIndex pool (encode fieldSignature),
+ fieldAttributesCount = fromIntegral (arsize fieldAttributes),
+ fieldAttributes = to (arlist fieldAttributes) }
+ where
+ to :: [(B.ByteString, B.ByteString)] -> Attributes File
+ to pairs = AP (map (attrInfo pool) pairs)
+
+methodDirect2File :: Pool File -> Method Direct -> Method File
+methodDirect2File pool (Method {..}) = Method {
+ methodAccessFlags = accessDirect2File methodAccessFlags,
+ methodName = force "method name" $ poolIndex pool methodName,
+ methodSignature = force "method sig" $ poolIndex pool (encode methodSignature),
+ methodAttributesCount = fromIntegral (arsize methodAttributes),
+ methodAttributes = to (arlist methodAttributes) }
+ where
+ to :: [(B.ByteString, B.ByteString)] -> Attributes 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 }
+
+poolFile2Direct :: Pool File -> Pool Direct
+poolFile2Direct ps = pool
+ where
+ pool :: Pool Direct
+ pool = M.map convert ps
+
+ 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
-
-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..] $ [
+ 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
+
+accessFile2Direct :: AccessFlags File -> AccessFlags Direct
+accessFile2Direct w = S.fromList $ concat $ zipWith (\i f -> if testBit w i then [f] else []) [0..] $ [
ACC_PUBLIC,
ACC_PRIVATE,
ACC_PROTECTED,
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
+accessDirect2File :: AccessFlags Direct -> AccessFlags File
+accessDirect2File fs = bitsOr $ map toBit $ S.toList fs
+ where
+ bitsOr = foldl (.|.) 0
+ toBit f = 1 `shiftL` (fromIntegral $ fromEnum f)
+
+fieldFile2Direct :: Pool Direct -> Field File -> Field Direct
+fieldFile2Direct pool (Field {..}) = Field {
+ fieldAccessFlags = accessFile2Direct fieldAccessFlags,
+ fieldName = getString $ pool ! fieldName,
+ fieldSignature = decode $ getString $ pool ! fieldSignature,
+ fieldAttributesCount = fromIntegral (apsize fieldAttributes),
+ fieldAttributes = attributesFile2Direct pool fieldAttributes }
+
+methodFile2Direct :: Pool Direct -> Method File -> Method Direct
+methodFile2Direct pool (Method {..}) = Method {
+ methodAccessFlags = accessFile2Direct methodAccessFlags,
+ methodName = getString $ pool ! methodName,
+ methodSignature = decode $ getString $ pool ! methodSignature,
+ methodAttributesCount = fromIntegral (apsize methodAttributes),
+ methodAttributes = attributesFile2Direct pool methodAttributes }
+
+attributesFile2Direct :: Pool Direct -> Attributes File -> Attributes Direct
+attributesFile2Direct 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)
-methodByName :: Class -> B.ByteString -> Maybe Method
+-- | Try to get class method by name
+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)
-attrByName :: (HasAttributes a) => a -> B.ByteString -> Maybe B.ByteString
-attrByName x name = M.lookup name (attributes x)
+-- | Try to get object attribute by name
+attrByName :: (HasAttributes a) => a Direct -> B.ByteString -> Maybe B.ByteString
+attrByName x name =
+ let (AR m) = attributes x
+ in M.lookup name m
-methodCode :: Class -> B.ByteString -> Maybe B.ByteString
+-- | Try to get Code for class method (no Code for interface methods)
+methodCode :: Class Direct
+ -> B.ByteString -- ^ Method name
+ -> Maybe B.ByteString
methodCode cls name = do
method <- methodByName cls name
attrByName method "Code"
projects / hs-java.git / blobdiff