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, classFile,
   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 qualified Data.ByteString.Lazy as B
  20 import qualified Data.Set as S
  21 import qualified Data.Map as M
  22
  23 import JVM.ClassFile
  24 import JVM.Types
  25 import JVM.Exceptions
  26
  27 -- | Parse .class file data
  28 parseClass :: B.ByteString -> Class Resolved
  29 parseClass bstr = convertClass $ decode bstr
  30
  31 -- | Parse class data from file
  32 parseClassFile :: FilePath -> IO (Class Resolved)
  33 parseClassFile path = convertClass `fmap` decodeFile path
  34
  35 encodeClass :: (Class Resolved) -> B.ByteString
  36 encodeClass cls = encode $ classFile cls
  37
  38 convertClass :: Class Pointers -> Class Resolved
  39 convertClass (Class {..}) =
  40   let pool = constantPoolArray constsPool
  41       superName = className $ pool ! superClass
  42   in Class {
  43       magic = 0xCAFEBABE,
  44       minorVersion = 0,
  45       majorVersion = 50,
  46       constsPoolSize = fromIntegral (M.size pool),
  47       constsPool = pool,
  48       accessFlags = convertAccess 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 (convertField pool) classFields,
  55       classMethodsCount = classMethodsCount,
  56       classMethods = map (convertMethod pool) classMethods,
  57       classAttributesCount = classAttributesCount,
  58       classAttributes = convertAttrs pool classAttributes }
  59
  60 classFile :: Class Resolved -> Class Pointers
  61 classFile (Class {..}) = Class {
  62     magic = 0xCAFEBABE,
  63     minorVersion = 0,
  64     majorVersion = 50,
  65     constsPoolSize = fromIntegral (M.size poolInfo + 1),
  66     constsPool = poolInfo,
  67     accessFlags = access2word16 accessFlags,
  68     thisClass = force "this" $ poolClassIndex poolInfo thisClass,
  69     superClass = force "super" $ poolClassIndex poolInfo superClass,
  70     interfacesCount = fromIntegral (length interfaces),
  71     interfaces = map (force "ifaces" . poolIndex poolInfo) interfaces,
  72     classFieldsCount = fromIntegral (length classFields),
  73     classFields = map (fieldInfo poolInfo) classFields,
  74     classMethodsCount = fromIntegral (length classMethods),
  75     classMethods = map (methodInfo poolInfo) classMethods,
  76     classAttributesCount = fromIntegral (M.size classAttributes),
  77     classAttributes = map (attrInfo poolInfo) (M.assocs classAttributes) }
  78   where
  79     poolInfo = toCPInfo constsPool
  80
  81 toCPInfo :: Pool Resolved -> Pool Pointers
  82 toCPInfo pool = result
  83   where
  84     result = M.map cpInfo pool
  85
  86     cpInfo :: Constant Resolved -> Constant Pointers
  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 (fromIntegral $ B.length s) s
 102     cpInfo (CUnicode s) = CUnicode (fromIntegral $ B.length s) s
 103
 104 -- | Find index of given string in the list of constants
 105 poolIndex :: (Throws NoItemInPool e) => Pool Pointers -> B.ByteString -> EM e Word16
 106 poolIndex list name = case findIndex test 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 Pointers -> B.ByteString -> EM e Word16
 116 poolClassIndex list name = case findIndex checkString list of
 117                         Nothing -> throw (NoItemInPool name)
 118                         Just i ->  case findIndex (checkClass $ fromIntegral $ i+1) 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) 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 fieldInfo :: Pool Pointers -> Field Resolved -> Field Pointers
 141 fieldInfo pool (Field {..}) = Field {
 142   fieldAccessFlags = access2word16 fieldAccessFlags,
 143   fieldName = force "field name" $ poolIndex pool fieldName,
 144   fieldSignature = force "signature" $ poolIndex pool (encode fieldSignature),
 145   fieldAttributesCount = fromIntegral (M.size fieldAttributes),
 146   fieldAttributes = map (attrInfo pool) (M.assocs fieldAttributes) }
 147
 148 methodInfo :: Pool Pointers -> Method Resolved -> Method Pointers
 149 methodInfo pool (Method {..}) = Method {
 150   methodAccessFlags = access2word16 methodAccessFlags,
 151   methodName = force "method name" $ poolIndex pool methodName,
 152   methodSignature = force "method sig" $ poolIndex pool (encode methodSignature),
 153   methodAttributesCount = fromIntegral (M.size methodAttributes),
 154   methodAttributes = map (attrInfo pool) (M.assocs methodAttributes) }
 155
 156 attrInfo :: Pool Pointers -> (B.ByteString, B.ByteString) -> Attributes Pointers
 157 attrInfo pool (name, value) = Attribute {
 158   attributeName = force "attr name" $ poolIndex pool name,
 159   attributeLength = fromIntegral (B.length value),
 160   attributeValue = value }
 161
 162 constantPoolArray :: Pool Pointers -> Pool Resolved
 163 constantPoolArray ps = pool
 164   where
 165     pool :: Pool
 166     pool = M.map convert ps
 167
 168     n = fromIntegral $ length ps
 169
 170     convertNameType :: (HasSignature a, Binary (Signature a)) => Word16 -> NameType a
 171     convertNameType i =
 172       let (CNameType n s) = pool ! i
 173       in  NameType n (decode s)
 174
 175     convert (CClass i) = CClass $ getString $ pool ! i
 176     convert (CField i j) = CField (className $ pool ! i) (convertNameType j)
 177     convert (CMethod i j) = CMethod (className $ pool ! i) (convertNameType j)
 178     convert (CIfaceMethod i j) = CIfaceMethod (className $ pool ! i) (convertNameType j)
 179     convert (CString i) = CString $ getString $ pool ! i
 180     convert (CInteger x) = CInteger x
 181     convert (CFloat x)   = CFloat x
 182     convert (CLong x)    = CLong (fromIntegral x)
 183     convert (CDouble x)  = CDouble x
 184     convert (CNameType i j) = CNameType (getString $ pool ! i) (getString $ pool ! j)
 185     convert (CUTF8 _ bs) = CUTF8 bs
 186     convert (CUnicode _ bs) = CUnicode bs
 187
 188 convertAccess :: AccessFlags Pointers -> AccessFlags Resolved
 189 convertAccess w = S.fromList $ concat $ zipWith (\i f -> if testBit w i then [f] else []) [0..] $ [
 190    ACC_PUBLIC,
 191    ACC_PRIVATE,
 192    ACC_PROTECTED,
 193    ACC_STATIC,
 194    ACC_FINAL,
 195    ACC_SYNCHRONIZED,
 196    ACC_VOLATILE,
 197    ACC_TRANSIENT,
 198    ACC_NATIVE,
 199    ACC_INTERFACE,
 200    ACC_ABSTRACT ]
 201
 202 access2word16 :: AccessFlags Resolved -> AccessFlags Pointers
 203 access2word16 fs = bitsOr $ map toBit $ S.toList fs
 204   where
 205     bitsOr = foldl (.|.) 0
 206     toBit f = 1 `shiftL` (fromIntegral $ fromEnum f)
 207
 208 convertField :: Pool Resolved -> Field Pointers -> Field Resolved
 209 convertField pool (Field {..}) = Field {
 210   fieldAccessFlags = convertAccess fieldAccessFlags,
 211   fieldName = getString $ pool ! fieldName,
 212   fieldSignature = decode $ getString $ pool ! fieldSignature,
 213   fieldAttributes = convertAttrs pool fieldAttributes }
 214
 215 convertMethod :: Pool Resolved -> Method Pointers -> Method Resolved
 216 convertMethod pool (Method {..}) = Method {
 217   methodAccessFlags = convertAccess methodAccessFlags,
 218   methodName = getString $ pool ! methodName,
 219   methodSignature = decode $ getString $ pool ! methodSignature,
 220   methodAttributes = convertAttrs pool methodAttributes }
 221
 222 convertAttrs :: Pool Resolved -> Attributes Pointers -> Attributes Resolved
 223 convertAttrs pool attrs = M.fromList $ map go attrs
 224   where
 225     go (Attribute {..}) = (getString $ pool ! attributeName,
 226                            attributeValue)
 227
 228 -- | Try to get class method by name
 229 methodByName :: Class Resolved -> B.ByteString -> Maybe (Method Resolved)
 230 methodByName cls name =
 231   find (\m -> methodName m == name) (classMethods cls)
 232
 233 -- | Try to get object attribute by name
 234 attrByName :: (HasAttributes a) => a Resolved -> B.ByteString -> Maybe B.ByteString
 235 attrByName x name = M.lookup name (attributes x)
 236
 237 -- | Try to get Code for class method (no Code for interface methods)
 238 methodCode :: Class Resolved
 239            -> B.ByteString       -- ^ Method name
 240            -> Maybe B.ByteString
 241 methodCode cls name = do
 242   method <- methodByName cls name
 243   attrByName method "Code"
 244