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    classFile2Direct, classDirect2File,
   7    encodeClass,
   8    methodByName,
   9    attrByName,
  10    methodCode
  11   )
  12   where
  13
  14 import Control.Monad.Exception
  15 import Data.List
  16 import Data.Word
  17 import Data.Bits
  18 import Data.Binary
  19 import Data.Default () -- import instances only
  20 import qualified Data.ByteString.Lazy as B
  21 import qualified Data.Set as S
  22 import qualified Data.Map as M
  23
  24 import JVM.ClassFile
  25 import JVM.Common
  26 import JVM.Exceptions
  27
  28 -- | Parse .class file data
  29 parseClass :: B.ByteString -> Class Direct
  30 parseClass bstr = classFile2Direct $ decode bstr
  31
  32 -- | Parse class data from file
  33 parseClassFile :: FilePath -> IO (Class Direct)
  34 parseClassFile path = classFile2Direct `fmap` decodeFile path
  35
  36 encodeClass :: (Class Direct) -> B.ByteString
  37 encodeClass cls = encode $ classDirect2File cls
  38
  39 classFile2Direct :: Class File -> Class Direct
  40 classFile2Direct (Class {..}) =
  41   let pool = poolFile2Direct constsPool
  42       superName = className $ pool ! superClass
  43       d = defaultClass :: Class Direct
  44   in d {
  45       constsPoolSize = fromIntegral (M.size pool),
  46       constsPool = pool,
  47       accessFlags = accessFile2Direct accessFlags,
  48       thisClass = className $ pool ! thisClass,
  49       superClass = if superClass == 0 then "" else superName,
  50       interfacesCount = interfacesCount,
  51       interfaces = map (\i -> className $ pool ! i) interfaces,
  52       classFieldsCount = classFieldsCount,
  53       classFields = map (fieldFile2Direct pool) classFields,
  54       classMethodsCount = classMethodsCount,
  55       classMethods = map (methodFile2Direct pool) classMethods,
  56       classAttributesCount = classAttributesCount,
  57       classAttributes = attributesFile2Direct pool classAttributes }
  58
  59 classDirect2File :: Class Direct -> Class File
  60 classDirect2File (Class {..}) =
  61   let d = defaultClass :: Class File
  62   in d {
  63     constsPoolSize = fromIntegral (M.size poolInfo + 1),
  64     constsPool = poolInfo,
  65     accessFlags = accessDirect2File accessFlags,
  66     thisClass = force "this" $ poolClassIndex poolInfo thisClass,
  67     superClass = force "super" $ poolClassIndex poolInfo superClass,
  68     interfacesCount = fromIntegral (length interfaces),
  69     interfaces = map (force "ifaces" . poolIndex poolInfo) interfaces,
  70     classFieldsCount = fromIntegral (length classFields),
  71     classFields = map (fieldDirect2File poolInfo) classFields,
  72     classMethodsCount = fromIntegral (length classMethods),
  73     classMethods = map (methodDirect2File poolInfo) classMethods,
  74     classAttributesCount = fromIntegral $ arsize classAttributes,
  75     classAttributes = to (arlist classAttributes) }
  76   where
  77     poolInfo = poolDirect2File constsPool
  78     to :: [(B.ByteString, B.ByteString)] -> Attributes File
  79     to pairs = AP (map (attrInfo poolInfo) pairs)
  80
  81 poolDirect2File :: Pool Direct -> Pool File
  82 poolDirect2File pool = result
  83   where
  84     result = M.map cpInfo pool
  85
  86     cpInfo :: Constant Direct -> Constant File
  87     cpInfo (CClass name) = CClass (force "class" $ poolIndex result name)
  88     cpInfo (CField cls name) =
  89       CField (force "field a" $ poolClassIndex result cls) (force "field b" $ poolNTIndex result name)
  90     cpInfo (CMethod cls name) =
  91       CMethod (force "method a" $ poolClassIndex result cls) (force ("method b: " ++ show name) $ poolNTIndex result name)
  92     cpInfo (CIfaceMethod cls name) =
  93       CIfaceMethod (force "iface method a" $ poolIndex result cls) (force "iface method b" $ poolNTIndex result name)
  94     cpInfo (CString s) = CString (force "string" $ poolIndex result s)
  95     cpInfo (CInteger x) = CInteger x
  96     cpInfo (CFloat x) = CFloat x
  97     cpInfo (CLong x) = CLong (fromIntegral x)
  98     cpInfo (CDouble x) = CDouble x
  99     cpInfo (CNameType n t) =
 100       CNameType (force "name" $ poolIndex result n) (force "type" $ poolIndex result t)
 101     cpInfo (CUTF8 s) = CUTF8 s
 102     cpInfo (CUnicode s) = CUnicode s
 103
 104 -- | Find index of given string in the list of constants
 105 poolIndex :: (Throws NoItemInPool e) => Pool File -> B.ByteString -> EM e Word16
 106 poolIndex list name = case findIndex test (M.elems list) of
 107                         Nothing -> throw (NoItemInPool name)
 108                         Just i ->  return $ fromIntegral $ i+1
 109   where
 110     test (CUTF8 s)    | s == name = True
 111     test (CUnicode s) | s == name = True
 112     test _                                  = False
 113
 114 -- | Find index of given string in the list of constants
 115 poolClassIndex :: (Throws NoItemInPool e) => Pool File -> B.ByteString -> EM e Word16
 116 poolClassIndex list name = case findIndex checkString (M.elems list) of
 117                         Nothing -> throw (NoItemInPool name)
 118                         Just i ->  case findIndex (checkClass $ fromIntegral $ i+1) (M.elems list) of
 119                                      Nothing -> throw (NoItemInPool $ i+1)
 120                                      Just j  -> return $ fromIntegral $ j+1
 121   where
 122     checkString (CUTF8 s)    | s == name = True
 123     checkString (CUnicode s) | s == name = True
 124     checkString _                                  = False
 125
 126     checkClass i (CClass x) | i == x = True
 127     checkClass _ _                           = False
 128
 129 poolNTIndex list x@(NameType n t) = do
 130     ni <- poolIndex list n
 131     ti <- poolIndex list (byteString t)
 132     case findIndex (check ni ti) (M.elems list) of
 133       Nothing -> throw (NoItemInPool x)
 134       Just i  -> return $ fromIntegral (i+1)
 135   where
 136     check ni ti (CNameType n' t')
 137       | (ni == n') && (ti == t') = True
 138     check _ _ _                  = False
 139
 140 fieldDirect2File :: Pool File -> Field Direct -> Field File
 141 fieldDirect2File pool (Field {..}) = Field {
 142     fieldAccessFlags = accessDirect2File fieldAccessFlags,
 143     fieldName = force "field name" $ poolIndex pool fieldName,
 144     fieldSignature = force "signature" $ poolIndex pool (encode fieldSignature),
 145     fieldAttributesCount = fromIntegral (arsize fieldAttributes),
 146     fieldAttributes = to (arlist fieldAttributes) }
 147   where
 148     to :: [(B.ByteString, B.ByteString)] -> Attributes File
 149     to pairs = AP (map (attrInfo pool) pairs)
 150
 151 methodDirect2File :: Pool File -> Method Direct -> Method File
 152 methodDirect2File pool (Method {..}) = Method {
 153     methodAccessFlags = accessDirect2File methodAccessFlags,
 154     methodName = force "method name" $ poolIndex pool methodName,
 155     methodSignature = force "method sig" $ poolIndex pool (encode methodSignature),
 156     methodAttributesCount = fromIntegral (arsize methodAttributes),
 157     methodAttributes = to (arlist methodAttributes) }
 158   where
 159     to :: [(B.ByteString, B.ByteString)] -> Attributes File
 160     to pairs = AP (map (attrInfo pool) pairs)
 161
 162 attrInfo :: Pool File -> (B.ByteString, B.ByteString) -> Attribute
 163 attrInfo pool (name, value) = Attribute {
 164   attributeName = force "attr name" $ poolIndex pool name,
 165   attributeLength = fromIntegral (B.length value),
 166   attributeValue = value }
 167
 168 poolFile2Direct :: Pool File -> Pool Direct
 169 poolFile2Direct ps = pool
 170   where
 171     pool :: Pool Direct
 172     pool = M.map convert ps
 173
 174     n = fromIntegral $ M.size ps
 175
 176     convertNameType :: (HasSignature a) => Word16 -> NameType a
 177     convertNameType i =
 178       let (CNameType n s) = pool ! i
 179       in  NameType n (decode s)
 180
 181     convert (CClass i) = CClass $ getString $ pool ! i
 182     convert (CField i j) = CField (className $ pool ! i) (convertNameType j)
 183     convert (CMethod i j) = CMethod (className $ pool ! i) (convertNameType j)
 184     convert (CIfaceMethod i j) = CIfaceMethod (className $ pool ! i) (convertNameType j)
 185     convert (CString i) = CString $ getString $ pool ! i
 186     convert (CInteger x) = CInteger x
 187     convert (CFloat x)   = CFloat x
 188     convert (CLong x)    = CLong (fromIntegral x)
 189     convert (CDouble x)  = CDouble x
 190     convert (CNameType i j) = CNameType (getString $ pool ! i) (getString $ pool ! j)
 191     convert (CUTF8 bs) = CUTF8 bs
 192     convert (CUnicode bs) = CUnicode bs
 193
 194 accessFile2Direct :: AccessFlags File -> AccessFlags Direct
 195 accessFile2Direct w = S.fromList $ concat $ zipWith (\i f -> if testBit w i then [f] else []) [0..] $ [
 196    ACC_PUBLIC,
 197    ACC_PRIVATE,
 198    ACC_PROTECTED,
 199    ACC_STATIC,
 200    ACC_FINAL,
 201    ACC_SYNCHRONIZED,
 202    ACC_VOLATILE,
 203    ACC_TRANSIENT,
 204    ACC_NATIVE,
 205    ACC_INTERFACE,
 206    ACC_ABSTRACT ]
 207
 208 accessDirect2File :: AccessFlags Direct -> AccessFlags File
 209 accessDirect2File fs = bitsOr $ map toBit $ S.toList fs
 210   where
 211     bitsOr = foldl (.|.) 0
 212     toBit f = 1 `shiftL` (fromIntegral $ fromEnum f)
 213
 214 fieldFile2Direct :: Pool Direct -> Field File -> Field Direct
 215 fieldFile2Direct pool (Field {..}) = Field {
 216   fieldAccessFlags = accessFile2Direct fieldAccessFlags,
 217   fieldName = getString $ pool ! fieldName,
 218   fieldSignature = decode $ getString $ pool ! fieldSignature,
 219   fieldAttributesCount = fromIntegral (apsize fieldAttributes),
 220   fieldAttributes = attributesFile2Direct pool fieldAttributes }
 221
 222 methodFile2Direct :: Pool Direct -> Method File -> Method Direct
 223 methodFile2Direct pool (Method {..}) = Method {
 224   methodAccessFlags = accessFile2Direct methodAccessFlags,
 225   methodName = getString $ pool ! methodName,
 226   methodSignature = decode $ getString $ pool ! methodSignature,
 227   methodAttributesCount = fromIntegral (apsize methodAttributes),
 228   methodAttributes = attributesFile2Direct pool methodAttributes }
 229
 230 attributesFile2Direct :: Pool Direct -> Attributes File -> Attributes Direct
 231 attributesFile2Direct pool (AP attrs) = AR (M.fromList $ map go attrs)
 232   where
 233     go :: Attribute -> (B.ByteString, B.ByteString)
 234     go (Attribute {..}) = (getString $ pool ! attributeName,
 235                            attributeValue)
 236
 237 -- | Try to get class method by name
 238 methodByName :: Class Direct -> B.ByteString -> Maybe (Method Direct)
 239 methodByName cls name =
 240   find (\m -> methodName m == name) (classMethods cls)
 241
 242 -- | Try to get object attribute by name
 243 attrByName :: (HasAttributes a) => a Direct -> B.ByteString -> Maybe B.ByteString
 244 attrByName x name =
 245   let (AR m) = attributes x
 246   in  M.lookup name m
 247
 248 -- | Try to get Code for class method (no Code for interface methods)
 249 methodCode :: Class Direct
 250            -> B.ByteString       -- ^ Method name
 251            -> Maybe B.ByteString
 252 methodCode cls name = do
 253   method <- methodByName cls name
 254   attrByName method "Code"
 255