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