X-Git-Url: http://wien.tomnetworks.com/gitweb/?a=blobdiff_plain;f=JVM%2FClassFile.hs;h=02a7adaf60aec86bb253ef42cd872d020c96f4b6;hb=c6d4e51116f1ca78ecbbbc4ce422fb33ce25ad19;hp=0359320592a9ab1cf10aa464f795423ade56ebf4;hpb=e9f82ee018d11b66f73e5e97591a6de474e76848;p=hs-java.git

diff --git a/JVM/ClassFile.hs b/JVM/ClassFile.hs
index 0359320..02a7ada 100644
--- a/JVM/ClassFile.hs
+++ b/JVM/ClassFile.hs
@@ -19,9 +19,13 @@ module JVM.ClassFile
    Constant (..),
    AccessFlag (..), AccessFlags,
    Attributes (..),
+   defaultClass,
    -- * Misc
    HasSignature (..), HasAttributes (..),
    NameType (..),
+   fieldNameType, methodNameType,
+   lookupField, lookupMethod,
+   toString,
    className,
    apsize, arsize, arlist
   )
@@ -35,6 +39,7 @@ import Data.Binary.Get
 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
@@ -96,10 +101,16 @@ data family Attributes stage
 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
@@ -128,7 +139,8 @@ data AccessFlag =
   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
@@ -142,12 +154,12 @@ data NameType a = NameType {
   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
@@ -155,9 +167,9 @@ instance (Binary (Signature a)) => Binary (NameType a) where
 -- | 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
@@ -209,10 +221,36 @@ data Class stage = Class {
   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
@@ -474,6 +512,17 @@ deriving instance Eq (Field Direct)
 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 
@@ -503,6 +552,17 @@ deriving instance Eq (Method Direct)
 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