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 classFile2Direct, classDirect2File,
14 import Control.Monad.Exception
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
29 -- | Parse .class file data
30 parseClass :: B.ByteString -> Class Direct
31 parseClass bstr = classFile2Direct $ decode bstr
33 -- | Parse class data from file
34 parseClassFile :: FilePath -> IO (Class Direct)
35 parseClassFile path = classFile2Direct `fmap` decodeFile path
37 encodeClass :: (Class Direct) -> B.ByteString
38 encodeClass cls = encode $ classDirect2File cls
40 classFile2Direct :: Class File -> Class Direct
41 classFile2Direct (Class {..}) =
42 let pool = poolFile2Direct constsPool
43 superName = className $ pool ! superClass
44 d = defaultClass :: Class Direct
46 constsPoolSize = fromIntegral (M.size 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 }
60 classDirect2File :: Class Direct -> Class File
61 classDirect2File (Class {..}) =
62 let d = defaultClass :: Class File
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) }
78 poolInfo = poolDirect2File constsPool
79 to :: [(B.ByteString, B.ByteString)] -> Attributes File
80 to pairs = AP (map (attrInfo poolInfo) pairs)
82 poolDirect2File :: Pool Direct -> Pool File
83 poolDirect2File pool = result
85 result = M.map cpInfo pool
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
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
111 test (CUTF8 s) | s == name = True
112 test (CUnicode s) | s == name = True
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
123 checkString (CUTF8 s) | s == name = True
124 checkString (CUnicode s) | s == name = True
125 checkString _ = False
127 checkClass i (CClass x) | i == x = True
128 checkClass _ _ = False
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
137 check ni ti (CNameType n' t')
138 | (ni == n') && (ti == t') = True
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) }
149 to :: [(B.ByteString, B.ByteString)] -> Attributes File
150 to pairs = AP (map (attrInfo pool) pairs)
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) }
160 to :: [(B.ByteString, B.ByteString)] -> Attributes File
161 to pairs = AP (map (attrInfo pool) pairs)
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 }
169 poolFile2Direct :: Pool File -> Pool Direct
170 poolFile2Direct ps = pool
173 pool = M.map convert ps
175 n = fromIntegral $ M.size ps
177 convertNameType :: (HasSignature a) => Word16 -> NameType a
180 CNameType n s -> NameType n (decode s)
181 x -> error $ "Unexpected: " ++ show i
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
198 accessFile2Direct :: AccessFlags File -> AccessFlags Direct
199 accessFile2Direct w = S.fromList $ concat $ zipWith (\i f -> if testBit w i then [f] else []) [0..] $ [
212 accessDirect2File :: AccessFlags Direct -> AccessFlags File
213 accessDirect2File fs = bitsOr $ map toBit $ S.toList fs
215 bitsOr = foldl (.|.) 0
216 toBit f = 1 `shiftL` (fromIntegral $ fromEnum f)
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 }
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 }
234 attributesFile2Direct :: Pool Direct -> Attributes File -> Attributes Direct
235 attributesFile2Direct pool (AP attrs) = AR (M.fromList $ map go attrs)
237 go :: Attribute -> (B.ByteString, B.ByteString)
238 go (Attribute {..}) = (getString $ pool ! attributeName,
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)
246 -- | Try to get object attribute by name
247 attrByName :: (HasAttributes a) => a Direct -> B.ByteString -> Maybe B.ByteString
249 let (AR m) = attributes x
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"