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   (parseClass, parseClassFile,
   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 parseClass :: B.ByteString -> Class
  27 parseClass bstr = convertClass $ decode bstr
  28
  29 -- | Parse class data from file
  30 parseClassFile :: FilePath -> IO Class
  31 parseClassFile path = convertClass `fmap` decodeFile path
  32
  33 encodeClass :: Class -> B.ByteString
  34 encodeClass cls = encode $ classFile cls
  35
  36 convertClass :: ClassFile -> Class
  37 convertClass (ClassFile {..}) =
  38   let pool = constantPoolArray constsPool
  39       superName = className $ pool ! superClass
  40   in Class {
  41       constantPool = pool,
  42       classAccess = convertAccess accessFlags,
  43       this = className $ pool ! thisClass,
  44       super = if superClass == 0 then Nothing else Just superName,
  45       implements = map (\i -> className $ pool ! i) interfaces,
  46       fields = map (convertField pool) classFields,
  47       methods = map (convertMethod pool) classMethods,
  48       classAttrs = convertAttrs pool classAttributes }
  49
  50 classFile :: Class -> ClassFile
  51 classFile (Class {..}) = ClassFile {
  52     magic = 0xCAFEBABE,
  53     minorVersion = 0,
  54     majorVersion = 50,
  55     constsPoolSize = fromIntegral (length poolInfo),
  56     constsPool = poolInfo,
  57     accessFlags = access2word16 classAccess,
  58     thisClass = poolIndex poolInfo this,
  59     superClass = poolIndex poolInfo this,
  60     interfacesCount = fromIntegral (length implements),
  61     interfaces = map (poolIndex poolInfo) implements,
  62     classFieldsCount = fromIntegral (length fields),
  63     classFields = map (fieldInfo poolInfo) fields,
  64     classMethodsCount = fromIntegral (length methods),
  65     classMethods = map (methodInfo poolInfo) methods,
  66     classAttributesCount = fromIntegral (M.size classAttrs),
  67     classAttributes = map (attrInfo poolInfo) (M.assocs classAttrs) }
  68   where
  69     poolInfo = toCPInfo constantPool
  70
  71 toCPInfo :: Pool -> [CpInfo]
  72 toCPInfo pool = result
  73   where
  74     result = map cpInfo $ elems pool
  75
  76     cpInfo (CClass name) = CONSTANT_Class (poolIndex result name)
  77     cpInfo (CField cls name) =
  78       CONSTANT_Fieldref (poolIndex result cls) (poolIndex result name)
  79     cpInfo (CMethod cls name) =
  80       CONSTANT_Methodref (poolIndex result cls) (poolIndex result name)
  81     cpInfo (CIfaceMethod cls name) =
  82       CONSTANT_InterfaceMethodref (poolIndex result cls) (poolIndex result name)
  83     cpInfo (CString s) = CONSTANT_String (poolIndex result s)
  84     cpInfo (CInteger x) = CONSTANT_Integer x
  85     cpInfo (CFloat x) = CONSTANT_Float x
  86     cpInfo (CLong x) = CONSTANT_Long (fromIntegral x)
  87     cpInfo (CDouble x) = CONSTANT_Double x
  88     cpInfo (CNameType n t) =
  89       CONSTANT_NameAndType (poolIndex result n) (poolIndex result t)
  90     cpInfo (CUTF8 s) = CONSTANT_Utf8 (fromIntegral $ B.length s) s
  91     cpInfo (CUnicode s) = CONSTANT_Unicode (fromIntegral $ B.length s) s
  92
  93 poolIndex :: [CpInfo] -> B.ByteString -> Word16
  94 poolIndex list name = case findIndex test list of
  95                         Nothing -> error $ "Internal error: no such item in pool: " ++ toString name
  96                         Just i -> fromIntegral i
  97   where
  98     test (CUTF8 s)    | s == name = True
  99     test (CUnicode s) | s == name = True
 100     test _                        = False
 101
 102
 103
 104 fieldInfo :: [CpInfo] -> Field -> FieldInfo
 105 fieldInfo pool (Field {..}) = FieldInfo {
 106   fieldAccessFlags = access2word16 fieldAccess,
 107   fieldNameIndex = poolIndex pool fieldName,
 108   fieldSignatureIndex = poolIndex pool (encode fieldSignature),
 109   fieldAttributesCount = fromIntegral (M.size fieldAttrs),
 110   fieldAttributes = map (attrInfo pool) (M.assocs fieldAttrs) }
 111
 112 methodInfo :: [CpInfo] -> Method -> MethodInfo
 113 methodInfo pool (Method {..}) = MethodInfo {
 114   methodAccessFlags = access2word16 methodAccess,
 115   methodNameIndex = poolIndex pool methodName,
 116   methodSignatureIndex = poolIndex pool (encode methodSignature),
 117   methodAttributesCount = fromIntegral (M.size methodAttrs),
 118   methodAttributes = map (attrInfo pool) (M.assocs methodAttrs) }
 119
 120 attrInfo :: [CpInfo] -> (B.ByteString, B.ByteString) -> AttributeInfo
 121 attrInfo pool (name, value) = AttributeInfo {
 122   attributeName = poolIndex pool name,
 123   attributeLength = fromIntegral (B.length value),
 124   attributeValue = value }
 125
 126
 127 constantPoolArray :: [CpInfo] -> Pool
 128 constantPoolArray list = pool
 129   where
 130     pool :: Pool
 131     pool = listArray (1,n) $ map convert list
 132     n = fromIntegral $ length list
 133
 134     convertNameType :: (HasSignature a, Binary (Signature a)) => Word16 -> NameType a
 135     convertNameType i =
 136       let (CNameType n s) = pool ! i
 137       in  NameType n (decode s)
 138
 139     convert (CONSTANT_Class i) = CClass $ getString $ pool ! i
 140     convert (CONSTANT_Fieldref i j) = CField (className $ pool ! i) (convertNameType j)
 141     convert (CONSTANT_Methodref i j) = CMethod (className $ pool ! i) (convertNameType j)
 142     convert (CONSTANT_InterfaceMethodref i j) = CIfaceMethod (className $ pool ! i) (convertNameType j)
 143     convert (CONSTANT_String i) = CString $ getString $ pool ! i
 144     convert (CONSTANT_Integer x) = CInteger x
 145     convert (CONSTANT_Float x)   = CFloat x
 146     convert (CONSTANT_Long x)    = CLong (fromIntegral x)
 147     convert (CONSTANT_Double x)  = CDouble x
 148     convert (CONSTANT_NameAndType i j) = CNameType (getString $ pool ! i) (getString $ pool ! j)
 149     convert (CONSTANT_Utf8 _ bs) = CUTF8 bs
 150     convert (CONSTANT_Unicode _ bs) = CUnicode bs
 151
 152 convertAccess :: Word16 -> Access
 153 convertAccess w = S.fromList $ concat $ zipWith (\i f -> if testBit w i then [f] else []) [0..] $ [
 154    ACC_PUBLIC,
 155    ACC_PRIVATE,
 156    ACC_PROTECTED,
 157    ACC_STATIC,
 158    ACC_FINAL,
 159    ACC_SYNCHRONIZED,
 160    ACC_VOLATILE,
 161    ACC_TRANSIENT,
 162    ACC_NATIVE,
 163    ACC_INTERFACE,
 164    ACC_ABSTRACT ]
 165
 166 access2word16 :: Access -> Word16
 167 access2word16 fs = bitsOr $ map toBit $ S.toList fs
 168   where
 169     bitsOr = foldl (.|.) 0
 170     toBit f = 1 `shiftL` (fromIntegral $ fromEnum f)
 171
 172 convertField :: Pool -> FieldInfo -> Field
 173 convertField pool (FieldInfo {..}) = Field {
 174   fieldAccess = convertAccess fieldAccessFlags,
 175   fieldName = getString $ pool ! fieldNameIndex,
 176   fieldSignature = decode $ getString $ pool ! fieldSignatureIndex,
 177   fieldAttrs = convertAttrs pool fieldAttributes }
 178
 179 convertMethod :: Pool -> MethodInfo -> Method
 180 convertMethod pool (MethodInfo {..}) = Method {
 181   methodAccess = convertAccess methodAccessFlags,
 182   methodName = getString $ pool ! methodNameIndex,
 183   methodSignature = decode $ getString $ pool ! methodSignatureIndex,
 184   methodAttrs = convertAttrs pool methodAttributes }
 185
 186 convertAttrs :: Pool -> [AttributeInfo] -> Attributes
 187 convertAttrs pool attrs = M.fromList $ map go attrs
 188   where
 189     go (AttributeInfo {..}) = (getString $ pool ! attributeName,
 190                                attributeValue)
 191
 192 -- | Try to get class method by name
 193 methodByName :: Class -> B.ByteString -> Maybe Method
 194 methodByName cls name =
 195   find (\m -> methodName m == name) (methods cls)
 196
 197 -- | Try to get object attribute by name
 198 attrByName :: (HasAttributes a) => a -> B.ByteString -> Maybe B.ByteString
 199 attrByName x name = M.lookup name (attributes x)
 200
 201 -- | Try to get Code for class method (no Code for interface methods)
 202 methodCode :: Class
 203            -> B.ByteString       -- ^ Method name
 204            -> Maybe B.ByteString
 205 methodCode cls name = do
 206   method <- methodByName cls name
 207   attrByName method "Code"
 208