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