Constant (..),
AccessFlag (..), AccessFlags,
Attributes (..),
+ defaultClass,
-- * Misc
HasSignature (..), HasAttributes (..),
NameType (..),
+ fieldNameType, methodNameType,
+ lookupField, lookupMethod,
+ toString,
className,
apsize, arsize, arlist
)
import Data.Binary.Put
import Data.Char
import Data.List
+import Data.Default
import qualified Data.Set as S
import qualified Data.Map as M
import qualified Data.ByteString.Lazy as B
data instance Attributes File = AP {attributesList :: [Attribute]}
deriving (Eq, Show)
+instance Default (Attributes File) where
+ def = AP []
+
-- | At Direct stage, attributes are represented as a Map.
data instance Attributes Direct = AR (M.Map B.ByteString B.ByteString)
deriving (Eq, Show)
+instance Default (Attributes Direct) where
+ def = AR M.empty
+
-- | Size of attributes set at Direct stage
arsize :: Attributes Direct -> Int
arsize (AR m) = M.size m
deriving (Eq, Show, Ord, Enum)
-- | Fields and methods have signatures.
-class HasSignature a where
+class (Binary (Signature a), Show (Signature a), Eq (Signature a))
+ => HasSignature a where
type Signature a
instance HasSignature Field where
ntName :: B.ByteString,
ntSignature :: Signature a }
-instance Show (Signature a) => Show (NameType a) where
+instance (HasSignature a) => Show (NameType a) where
show (NameType n t) = toString n ++ ": " ++ show t
-deriving instance Eq (Signature a) => Eq (NameType a)
+deriving instance HasSignature a => Eq (NameType a)
-instance (Binary (Signature a)) => Binary (NameType a) where
+instance HasSignature a => Binary (NameType a) where
put (NameType n t) = putLazyByteString n >> put t
get = NameType <$> get <*> get
-- | Constant pool item
data Constant stage =
CClass (Link stage B.ByteString)
- | CField {refClass :: Link stage B.ByteString, fieldNameType :: Link stage (NameType Field)}
- | CMethod {refClass :: Link stage B.ByteString, nameType :: Link stage (NameType Method)}
- | CIfaceMethod {refClass :: Link stage B.ByteString, nameType :: Link stage (NameType Method)}
+ | CField (Link stage B.ByteString) (Link stage (NameType Field))
+ | CMethod (Link stage B.ByteString) (Link stage (NameType Method))
+ | CIfaceMethod (Link stage B.ByteString) (Link stage (NameType Method))
| CString (Link stage B.ByteString)
| CInteger Word32
| CFloat Float
classAttributes :: Attributes stage -- ^ Class attributes
}
+deriving instance Eq (Class File)
+deriving instance Eq (Class Direct)
+deriving instance Show (Class File)
+deriving instance Show (Class Direct)
+
deriving instance Eq (Constant File)
deriving instance Eq (Constant Direct)
deriving instance Show (Constant File)
+-- | Default (empty) class file definition.
+defaultClass :: (Default (AccessFlags stage), Default (Link stage B.ByteString), Default (Attributes stage))
+ => Class stage
+defaultClass = Class {
+ magic = 0xCAFEBABE,
+ minorVersion = 0,
+ majorVersion = 50,
+ constsPoolSize = 0,
+ constsPool = def,
+ accessFlags = def,
+ thisClass = def,
+ superClass = def,
+ interfacesCount = 0,
+ interfaces = [],
+ classFieldsCount = 0,
+ classFields = [],
+ classMethodsCount = 0,
+ classMethods = [],
+ classAttributesCount = 0,
+ classAttributes = def }
+
instance Binary (Class File) where
put (Class {..}) = do
put magic
deriving instance Show (Field File)
deriving instance Show (Field Direct)
+lookupField :: B.ByteString -> Class Direct -> Maybe (Field Direct)
+lookupField name cls = look (classFields cls)
+ where
+ look [] = Nothing
+ look (f:fs)
+ | fieldName f == name = Just f
+ | otherwise = look fs
+
+fieldNameType :: Field Direct -> NameType Field
+fieldNameType f = NameType (fieldName f) (fieldSignature f)
+
instance Binary (Field File) where
put (Field {..}) = do
put fieldAccessFlags
deriving instance Show (Method File)
deriving instance Show (Method Direct)
+methodNameType :: Method Direct -> NameType Method
+methodNameType m = NameType (methodName m) (methodSignature m)
+
+lookupMethod :: B.ByteString -> Class Direct -> Maybe (Method Direct)
+lookupMethod name cls = look (classMethods cls)
+ where
+ look [] = Nothing
+ look (f:fs)
+ | methodName f == name = Just f
+ | otherwise = look fs
+
instance Binary (Method File) where
put (Method {..}) = do
put methodAccessFlags