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