JVM/Converter.hs

   1 {-# LANGUAGE TypeFamilies, StandaloneDeriving, FlexibleInstances, FlexibleContexts, UndecidableInstances, RecordWildCards, OverloadedStrings #-}
   2 module JVM.Converter where
   3
   4 import Codec.Binary.UTF8.String hiding (encode, decode)
   5 import Data.List
   6 import Data.Word
   7 import Data.Bits
   8 import Data.Binary
   9 import Data.Char
  10 import Data.String
  11 import qualified Data.ByteString.Lazy as B
  12 import Data.Array
  13 import qualified Data.Set as S
  14 import qualified Data.Map as M
  15
  16 import Debug.Trace
  17
  18 import JVM.ClassFile
  19 import JVM.Types
  20
  21 instance IsString B.ByteString where
  22   fromString s = B.pack $ map (fromIntegral . ord) $ encodeString s
  23
  24 decompile :: B.ByteString -> Class
  25 decompile bstr = convertClass $ decode bstr
  26
  27 decompileFile :: FilePath -> IO Class
  28 decompileFile path = convertClass `fmap` decodeFile path
  29
  30 convertClass :: ClassFile -> Class
  31 convertClass (ClassFile {..}) =
  32   let pool = constantPoolArray constsPool
  33       superName = className $ pool ! superClass
  34   in Class {
  35       constantPool = pool,
  36       classAccess = convertAccess accessFlags,
  37       this = className $ pool ! thisClass,
  38       super = if superClass == 0 then Nothing else Just superName,
  39       implements = map (\i -> className $ pool ! i) interfaces,
  40       fields = map (convertField pool) classFields,
  41       methods = map (convertMethod pool) classMethods,
  42       classAttrs = convertAttrs pool classAttributes }
  43
  44 constantPoolArray :: [CpInfo] -> Pool
  45 constantPoolArray list = pool
  46   where
  47     pool :: Pool
  48     pool = listArray (1,n) $ map convert list
  49     n = fromIntegral $ length list
  50
  51     convertNameType :: (HasSignature a, Binary (Signature a)) => Word16 -> NameType a
  52     convertNameType i =
  53       let (CNameType n s) = pool ! i
  54       in  NameType n (decode s)
  55
  56     convert (CONSTANT_Class i) = CClass $ getString $ pool ! i
  57     convert (CONSTANT_Fieldref i j) = CField (className $ pool ! i) (convertNameType j)
  58     convert (CONSTANT_Methodref i j) = CMethod (className $ pool ! i) (convertNameType j)
  59     convert (CONSTANT_InterfaceMethodref i j) = CIfaceMethod (className $ pool ! i) (convertNameType j)
  60     convert (CONSTANT_String i) = CString $ getString $ pool ! i
  61     convert (CONSTANT_Integer x) = CInteger x
  62     convert (CONSTANT_Float x)   = CFloat x
  63     convert (CONSTANT_Long x)    = CLong (fromIntegral x)
  64     convert (CONSTANT_Double x)  = CDouble x
  65     convert (CONSTANT_NameAndType i j) = CNameType (getString $ pool ! i) (getString $ pool ! j)
  66     convert (CONSTANT_Utf8 _ bs) = CUTF8 bs
  67     convert (CONSTANT_Unicode _ bs) = CUnicode bs
  68
  69 className' x = trace ("Class name: " ++ show x) B.empty
  70
  71 convertAccess :: Word16 -> Access
  72 convertAccess w = S.fromList $ concat $ zipWith (\i f -> if testBit w i then [f] else []) [0..] $ [
  73    ACC_PUBLIC,
  74    ACC_PRIVATE,
  75    ACC_PROTECTED,
  76    ACC_STATIC,
  77    ACC_FINAL,
  78    ACC_SYNCHRONIZED,
  79    ACC_VOLATILE,
  80    ACC_TRANSIENT,
  81    ACC_NATIVE,
  82    ACC_INTERFACE,
  83    ACC_ABSTRACT ]
  84
  85 convertField :: Pool -> FieldInfo -> Field
  86 convertField pool (FieldInfo {..}) = Field {
  87   fieldAccess = convertAccess fieldAccessFlags,
  88   fieldName = getString $ pool ! fieldNameIndex,
  89   fieldSignature = decode $ getString $ pool ! fieldSignatureIndex,
  90   fieldAttrs = convertAttrs pool fieldAttributes }
  91
  92 convertMethod :: Pool -> MethodInfo -> Method
  93 convertMethod pool (MethodInfo {..}) = Method {
  94   methodAccess = convertAccess methodAccessFlags,
  95   methodName = getString $ pool ! methodNameIndex,
  96   methodSignature = decode $ getString $ pool ! methodSignatureIndex,
  97   methodAttrs = convertAttrs pool methodAttributes }
  98
  99 convertAttrs :: Pool -> [AttributeInfo] -> Attributes
 100 convertAttrs pool attrs = M.fromList $ map go attrs
 101   where
 102     go (AttributeInfo {..}) = (getString $ pool ! attributeName,
 103                                attributeValue)
 104
 105 methodByName :: Class -> B.ByteString -> Maybe Method
 106 methodByName cls name =
 107   find (\m -> methodName m == name) (methods cls)
 108
 109 attrByName :: (HasAttributes a) => a -> B.ByteString -> Maybe B.ByteString
 110 attrByName x name = M.lookup name (attributes x)
 111
 112 methodCode :: Class -> B.ByteString -> Maybe B.ByteString
 113 methodCode cls name = do
 114   method <- methodByName cls name
 115   attrByName method "Code"
 116