1 {-# LANGUAGE TypeFamilies, StandaloneDeriving, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
2 -- | This module declares `high-level' data types for Java classes, methods etc.
5 import Codec.Binary.UTF8.String hiding (encode, decode)
6 import Control.Applicative
10 import qualified Data.ByteString.Lazy as B
13 import qualified Data.Set as S
14 import qualified Data.Map as M
18 instance IsString B.ByteString where
19 fromString s = B.pack $ map (fromIntegral . ord) $ encodeString s
21 toString :: B.ByteString -> String
22 toString bstr = decodeString $ map (chr . fromIntegral) $ B.unpack bstr
25 type Pool = Array Word16 Constant
27 asize :: (Ix i) => Array i e -> Int
28 asize = length . elems
30 showListIx :: (Show a) => [a] -> String
31 showListIx list = unlines $ zipWith s [1..] list
32 where s i x = show i ++ ":\t" ++ show x
34 class HasAttributes a where
35 attributes :: a -> Attributes
40 classAccess :: Access,
41 this :: B.ByteString, -- ^ this class name
42 super :: Maybe B.ByteString, -- ^ super class name
43 implements :: [B.ByteString], -- ^ implemented interfaces
46 classAttrs :: Attributes
50 instance HasAttributes Class where
51 attributes = classAttrs
53 class HasSignature a where
56 -- | Name and signature pair. Used for methods and fields.
57 data NameType a = NameType {
58 ntName :: B.ByteString,
59 ntSignature :: Signature a }
61 instance Show (Signature a) => Show (NameType a) where
62 show (NameType n t) = toString n ++ ": " ++ show t
64 deriving instance Eq (Signature a) => Eq (NameType a)
66 -- | Constant pool item
69 | CField {refClass :: B.ByteString, fieldNameType :: NameType Field}
70 | CMethod {refClass :: B.ByteString, nameType :: NameType Method}
71 | CIfaceMethod {refClass :: B.ByteString, nameType :: NameType Method}
72 | CString B.ByteString
77 | CNameType B.ByteString B.ByteString
78 | CUTF8 {getString :: B.ByteString}
79 | CUnicode {getString :: B.ByteString}
82 className :: Constant -> B.ByteString
83 className (CClass s) = s
84 className x = error $ "Not a class: " ++ show x
86 instance Show Constant where
87 show (CClass name) = "class " ++ toString name
88 show (CField cls nt) = "field " ++ toString cls ++ "." ++ show nt
89 show (CMethod cls nt) = "method " ++ toString cls ++ "." ++ show nt
90 show (CIfaceMethod cls nt) = "interface method " ++ toString cls ++ "." ++ show nt
91 show (CString s) = "String \"" ++ toString s ++ "\""
92 show (CInteger x) = show x
93 show (CFloat x) = show x
94 show (CLong x) = show x
95 show (CDouble x) = show x
96 show (CNameType name tp) = toString name ++ ": " ++ toString tp
97 show (CUTF8 s) = "UTF8 \"" ++ toString s ++ "\""
98 show (CUnicode s) = "Unicode \"" ++ toString s ++ "\""
102 fieldAccess :: Access,
103 fieldName :: B.ByteString,
104 fieldSignature :: FieldSignature,
105 fieldAttrs :: Attributes }
108 instance HasSignature Field where
109 type Signature Field = FieldSignature
111 instance HasAttributes Field where
112 attributes = fieldAttrs
115 data Method = Method {
116 methodAccess :: Access,
117 methodName :: B.ByteString,
118 methodSignature :: MethodSignature,
119 methodAttrs :: Attributes }
122 instance HasSignature Method where
123 type Signature Method = MethodSignature
125 instance HasAttributes Method where
126 attributes = methodAttrs
128 -- | Set of access flags
129 type Access = S.Set AccessFlag
131 -- | Access flags. Used for classess, methods, variables.
133 ACC_PUBLIC -- ^ 0x0001 Visible for all
134 | ACC_PRIVATE -- ^ 0x0002 Visible only for defined class
135 | ACC_PROTECTED -- ^ 0x0004 Visible only for subclasses
136 | ACC_STATIC -- ^ 0x0008 Static method or variable
137 | ACC_FINAL -- ^ 0x0010 No further subclassing or assignments
138 | ACC_SYNCHRONIZED -- ^ 0x0020 Uses monitors
139 | ACC_VOLATILE -- ^ 0x0040 Could not be cached
140 | ACC_TRANSIENT -- ^ 0x0080
141 | ACC_NATIVE -- ^ 0x0100 Implemented in other language
142 | ACC_INTERFACE -- ^ 0x0200 Class is interface
143 | ACC_ABSTRACT -- ^ 0x0400
144 deriving (Eq, Show, Ord, Enum)
146 -- | Generic attribute
147 data Attribute = Attribute {
148 attrName :: B.ByteString,
149 attrValue :: B.ByteString }
152 -- | Set of attributes
153 type Attributes = M.Map B.ByteString B.ByteString
155 instance (Binary (Signature a)) => Binary (NameType a) where
156 put (NameType n t) = putLazyByteString n >> put t
158 get = NameType <$> get <*> get
160 byteString :: (Binary t) => t -> B.ByteString
161 byteString x = runPut (put x)