X-Git-Url: http://wien.tomnetworks.com/gitweb/?a=blobdiff_plain;f=JVM%2FTypes.hs;h=e685e7933a56dc0539709c0d429dbf636d957984;hb=67ab22f9b209bb0dbc0fa69ffa7f59277bf3848c;hp=834af21e86aa279e609864d9d7c937a68d98f711;hpb=5a92a8e4a3a1da9114aec1c923a119c0255360b9;p=hs-java.git

diff --git a/JVM/Types.hs b/JVM/Types.hs
index 834af21..e685e79 100644
--- a/JVM/Types.hs
+++ b/JVM/Types.hs
@@ -1,10 +1,13 @@
 {-# LANGUAGE TypeFamilies, StandaloneDeriving, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
+-- | This module declares `high-level' data types for Java classes, methods etc.
 module JVM.Types where
 
 import Codec.Binary.UTF8.String hiding (encode, decode)
+import Control.Applicative
 import Data.Array
+import Data.Binary
+import Data.Binary.Put
 import qualified Data.ByteString.Lazy as B
-import Data.Word
 import Data.Char
 import Data.String
 import qualified Data.Set as S
@@ -18,11 +21,20 @@ instance IsString B.ByteString where
 toString :: B.ByteString -> String
 toString bstr = decodeString $ map (chr . fromIntegral) $ B.unpack bstr
 
+-- | Constant pool
 type Pool = Array Word16 Constant
 
+asize :: (Ix i) => Array i e -> Int
+asize = length . elems
+
+showListIx :: (Show a) => [a] -> String
+showListIx list = unlines $ zipWith s [1..] list
+  where s i x = show i ++ ":\t" ++ show x
+
 class HasAttributes a where
   attributes :: a -> Attributes
 
+-- | Java class
 data Class = Class {
   constantPool :: Pool,
   classAccess :: Access,
@@ -41,6 +53,7 @@ instance HasAttributes Class where
 class HasSignature a where
   type Signature a
 
+-- | Name and signature pair. Used for methods and fields.
 data NameType a = NameType {
   ntName :: B.ByteString,
   ntSignature :: Signature a }
@@ -50,8 +63,9 @@ instance Show (Signature a) => Show (NameType a) where
 
 deriving instance Eq (Signature a) => Eq (NameType a)
 
+-- | Constant pool item
 data Constant =
-    CClass {className :: B.ByteString}
+    CClass B.ByteString
   | CField {refClass :: B.ByteString, fieldNameType :: NameType Field}
   | CMethod {refClass :: B.ByteString, nameType :: NameType Method}
   | CIfaceMethod {refClass :: B.ByteString, nameType :: NameType Method}
@@ -65,6 +79,10 @@ data Constant =
   | CUnicode {getString :: B.ByteString}
   deriving (Eq)
 
+className ::  Constant -> B.ByteString
+className (CClass s) = s
+className x = error $ "Not a class: " ++ show x
+
 instance Show Constant where
   show (CClass name) = "class " ++ toString name
   show (CField cls nt) = "field " ++ toString cls ++ "." ++ show nt
@@ -79,6 +97,7 @@ instance Show Constant where
   show (CUTF8 s) = "UTF8 \"" ++ toString s ++ "\""
   show (CUnicode s) = "Unicode \"" ++ toString s ++ "\""
 
+-- | Class field
 data Field = Field {
   fieldAccess :: Access,
   fieldName :: B.ByteString,
@@ -92,6 +111,7 @@ instance HasSignature Field where
 instance HasAttributes Field where
   attributes = fieldAttrs
 
+-- | Class method
 data Method = Method {
   methodAccess :: Access,
   methodName :: B.ByteString,
@@ -105,30 +125,38 @@ instance HasSignature Method where
 instance HasAttributes Method where
   attributes = methodAttrs
 
+-- | Set of access flags
 type Access = S.Set AccessFlag
 
+-- | Access flags. Used for classess, methods, variables.
 data AccessFlag =
-    ACC_PUBLIC 	     -- 0x0001 Видимый для всех 	Класс, Метод, Переменная
-  | ACC_PRIVATE 	   -- 0x0002 Видимый только для определяемого класса 	Метод, Переменная
-  | ACC_PROTECTED 	 -- 0x0004 Видимый для подклассов 	Метод, Переменная
-  | ACC_STATIC 	     -- 0x0008 Переменная или метод статические 	Метод, Переменная
-  | ACC_FINAL 	     -- 0x0010 Нет дальнейшей подкласификации, обхода или присваивания после инициализации 	Класс, Метод, Переменная
-  | ACC_SYNCHRONIZED -- 0x0020 Использует возврат в блокировке монитора 	Метод
-  | ACC_VOLATILE 	   -- 0x0040 Не может помещать в кеш 	Переменная
-  | ACC_TRANSIENT 	 -- 0x0080 Не может боть написан или прочитан постоянным объектом управления 	Перемення
-  | ACC_NATIVE 	     -- 0x0100 Реализован в других языках 	Метод
-  | ACC_INTERFACE 	 -- 0x0200 интерфейс 	Класс
-  | ACC_ABSTRACT 	   -- 0x0400 Ничего не предусматривает 	Класс, Метод
-  deriving (Eq, Show, Ord)
-
+    ACC_PUBLIC 	     -- ^ 0x0001 Visible for all
+  | ACC_PRIVATE 	   -- ^ 0x0002 Visible only for defined class
+  | ACC_PROTECTED 	 -- ^ 0x0004 Visible only for subclasses
+  | ACC_STATIC 	     -- ^ 0x0008 Static method or variable
+  | ACC_FINAL 	     -- ^ 0x0010 No further subclassing or assignments
+  | ACC_SYNCHRONIZED -- ^ 0x0020 Uses monitors
+  | ACC_VOLATILE 	   -- ^ 0x0040 Could not be cached
+  | ACC_TRANSIENT 	 -- ^ 0x0080 
+  | ACC_NATIVE 	     -- ^ 0x0100 Implemented in other language
+  | ACC_INTERFACE 	 -- ^ 0x0200 Class is interface
+  | ACC_ABSTRACT 	   -- ^ 0x0400 
+  deriving (Eq, Show, Ord, Enum)
+
+-- | Generic attribute
 data Attribute = Attribute {
   attrName :: B.ByteString,
   attrValue :: B.ByteString }
   deriving (Eq, Show)
 
-class AttributeValue a where
-  decodeAttribute :: B.ByteString -> a
-  encodeAttribute :: a -> B.ByteString
-
+-- | Set of attributes
 type Attributes = M.Map B.ByteString B.ByteString
 
+instance (Binary (Signature a)) => Binary (NameType a) where
+  put (NameType n t) = putLazyByteString n >> put t
+
+  get = NameType <$> get <*> get
+
+byteString ::  (Binary t) => t -> B.ByteString
+byteString x = runPut (put x)
+