JVM/Converter.hs

   1 {-# LANGUAGE TypeFamilies, StandaloneDeriving, FlexibleInstances, FlexibleContexts, UndecidableInstances, RecordWildCards, OverloadedStrings #-}
   2 -- | Functions to convert from low-level .class format representation and
   3 -- high-level Java classes, methods etc representation
   4 module JVM.Converter
   5   (decompile, decompileFile,
   6    convertClass,
   7    methodByName,
   8    attrByName,
   9    methodCode
  10   )
  11   where
  12
  13 import Data.List
  14 import Data.Word
  15 import Data.Bits
  16 import Data.Binary
  17 import qualified Data.ByteString.Lazy as B
  18 import Data.Array
  19 import qualified Data.Set as S
  20 import qualified Data.Map as M
  21
  22 import JVM.ClassFile
  23 import JVM.Types
  24
  25 -- | Parse .class file data
  26 decompile :: B.ByteString -> Class
  27 decompile bstr = convertClass $ decode bstr
  28
  29 -- | Parse class data from file
  30 decompileFile :: FilePath -> IO Class
  31 decompileFile path = convertClass `fmap` decodeFile path
  32
  33 convertClass :: ClassFile -> Class
  34 convertClass (ClassFile {..}) =
  35   let pool = constantPoolArray constsPool
  36       superName = className $ pool ! superClass
  37   in Class {
  38       constantPool = pool,
  39       classAccess = convertAccess accessFlags,
  40       this = className $ pool ! thisClass,
  41       super = if superClass == 0 then Nothing else Just superName,
  42       implements = map (\i -> className $ pool ! i) interfaces,
  43       fields = map (convertField pool) classFields,
  44       methods = map (convertMethod pool) classMethods,
  45       classAttrs = convertAttrs pool classAttributes }
  46
  47 constantPoolArray :: [CpInfo] -> Pool
  48 constantPoolArray list = pool
  49   where
  50     pool :: Pool
  51     pool = listArray (1,n) $ map convert list
  52     n = fromIntegral $ length list
  53
  54     convertNameType :: (HasSignature a, Binary (Signature a)) => Word16 -> NameType a
  55     convertNameType i =
  56       let (CNameType n s) = pool ! i
  57       in  NameType n (decode s)
  58
  59     convert (CONSTANT_Class i) = CClass $ getString $ pool ! i
  60     convert (CONSTANT_Fieldref i j) = CField (className $ pool ! i) (convertNameType j)
  61     convert (CONSTANT_Methodref i j) = CMethod (className $ pool ! i) (convertNameType j)
  62     convert (CONSTANT_InterfaceMethodref i j) = CIfaceMethod (className $ pool ! i) (convertNameType j)
  63     convert (CONSTANT_String i) = CString $ getString $ pool ! i
  64     convert (CONSTANT_Integer x) = CInteger x
  65     convert (CONSTANT_Float x)   = CFloat x
  66     convert (CONSTANT_Long x)    = CLong (fromIntegral x)
  67     convert (CONSTANT_Double x)  = CDouble x
  68     convert (CONSTANT_NameAndType i j) = CNameType (getString $ pool ! i) (getString $ pool ! j)
  69     convert (CONSTANT_Utf8 _ bs) = CUTF8 bs
  70     convert (CONSTANT_Unicode _ bs) = CUnicode bs
  71
  72 convertAccess :: Word16 -> Access
  73 convertAccess w = S.fromList $ concat $ zipWith (\i f -> if testBit w i then [f] else []) [0..] $ [
  74    ACC_PUBLIC,
  75    ACC_PRIVATE,
  76    ACC_PROTECTED,
  77    ACC_STATIC,
  78    ACC_FINAL,
  79    ACC_SYNCHRONIZED,
  80    ACC_VOLATILE,
  81    ACC_TRANSIENT,
  82    ACC_NATIVE,
  83    ACC_INTERFACE,
  84    ACC_ABSTRACT ]
  85
  86 convertField :: Pool -> FieldInfo -> Field
  87 convertField pool (FieldInfo {..}) = Field {
  88   fieldAccess = convertAccess fieldAccessFlags,
  89   fieldName = getString $ pool ! fieldNameIndex,
  90   fieldSignature = decode $ getString $ pool ! fieldSignatureIndex,
  91   fieldAttrs = convertAttrs pool fieldAttributes }
  92
  93 convertMethod :: Pool -> MethodInfo -> Method
  94 convertMethod pool (MethodInfo {..}) = Method {
  95   methodAccess = convertAccess methodAccessFlags,
  96   methodName = getString $ pool ! methodNameIndex,
  97   methodSignature = decode $ getString $ pool ! methodSignatureIndex,
  98   methodAttrs = convertAttrs pool methodAttributes }
  99
 100 convertAttrs :: Pool -> [AttributeInfo] -> Attributes
 101 convertAttrs pool attrs = M.fromList $ map go attrs
 102   where
 103     go (AttributeInfo {..}) = (getString $ pool ! attributeName,
 104                                attributeValue)
 105
 106 -- | Try to get class method by name
 107 methodByName :: Class -> B.ByteString -> Maybe Method
 108 methodByName cls name =
 109   find (\m -> methodName m == name) (methods cls)
 110
 111 -- | Try to get object attribute by name
 112 attrByName :: (HasAttributes a) => a -> B.ByteString -> Maybe B.ByteString
 113 attrByName x name = M.lookup name (attributes x)
 114
 115 -- | Try to get Code for class method (no Code for interface methods)
 116 methodCode :: Class
 117            -> B.ByteString       -- ^ Method name
 118            -> Maybe B.ByteString
 119 methodCode cls name = do
 120   method <- methodByName cls name
 121   attrByName method "Code"
 122