Use type families: done.

diff --git a/JVM/Assembler.hs b/JVM/Assembler.hs
index 31e00fea6ff1678c86bed9e76ef8cd10d7c962a3..b29eae847cdeb293dacb72c96b2da62db883e248 100644 (file)
--- a/JVM/Assembler.hs
+++ b/JVM/Assembler.hs
@@ -53,7 +53,7 @@ data Code = Code {
     codeExceptionsN :: Word16,
     codeExceptions :: [CodeException],
     codeAttrsN :: Word16,
-    codeAttributes :: [AttributeInfo] }
+    codeAttributes :: Attributes Pointers }
   deriving (Eq, Show)
 
 -- | Exception descriptor
@@ -73,7 +73,7 @@ instance BinaryState Integer CodeException where
 
   get = CodeException <$> get <*> get <*> get <*> get
 
-instance BinaryState Integer AttributeInfo where
+instance BinaryState Integer Attribute where
   put a = do
     let sz = 6 + attributeLength a      -- full size of AttributeInfo structure
     liftOffset (fromIntegral sz) Binary.put a
@@ -89,7 +89,7 @@ instance BinaryState Integer Code where
     put codeExceptionsN
     forM_ codeExceptions put
     put codeAttrsN
-    forM_ codeAttributes put
+    forM_ (attributesList codeAttributes) put
 
   get = do
     stackSz <- get
@@ -102,7 +102,7 @@ instance BinaryState Integer Code where
     excs <- replicateM (fromIntegral excn) get
     nAttrs <- get
     attrs <- replicateM (fromIntegral nAttrs) get
-    return $ Code stackSz locals len code excn excs nAttrs attrs
+    return $ Code stackSz locals len code excn excs nAttrs (AP attrs)
 
 -- | Read sequence of instructions (to end of stream)
 readInstructions :: GetState Integer [Instruction]

diff --git a/JVM/ClassFile.hs b/JVM/ClassFile.hs
index 87acae42515ba4f7ae24ba6cd66988678692fe40..18c252613669d4cc998567a02bedcb67b80f0724 100644 (file)
--- a/JVM/ClassFile.hs
+++ b/JVM/ClassFile.hs
@@ -14,7 +14,8 @@ module JVM.ClassFile
    HasSignature (..), HasAttributes (..),
    AccessFlag (..), AccessFlags,
    Attributes (..),
-   className
+   className,
+   apsize, arsize, arlist
   )
   where
 
@@ -56,10 +57,21 @@ type instance AccessFlags Pointers = Word16
 
 type instance AccessFlags Resolved = S.Set AccessFlag
 
-type family Attributes stage
+data family Attributes stage
 
-type instance Attributes Pointers = [Attribute]
-type instance Attributes Resolved = M.Map B.ByteString B.ByteString
+data instance Attributes Pointers = AP {attributesList :: [Attribute]}
+  deriving (Eq, Show)
+data instance Attributes Resolved = AR (M.Map B.ByteString B.ByteString)
+  deriving (Eq, Show)
+
+arsize :: Attributes Resolved -> Int
+arsize (AR m) = M.size m
+
+arlist :: Attributes Resolved -> [(B.ByteString, B.ByteString)]
+arlist (AR m) = M.assocs m
+
+apsize :: Attributes Pointers -> Int
+apsize (AP list) = length list
 
 -- | Access flags. Used for classess, methods, variables.
 data AccessFlag =
@@ -102,7 +114,7 @@ instance (Binary (Signature a)) => Binary (NameType a) where
 
 -- | Constant pool item
 data Constant stage =
-    CClass B.ByteString
+    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)}
@@ -177,7 +189,7 @@ instance Binary (Class Pointers) where
     put classMethodsCount
     forM_ classMethods put
     put classAttributesCount
-    forM_ classAttributes put
+    forM_ (attributesList classAttributes) put
 
   get = do
     magic <- get
@@ -198,7 +210,8 @@ instance Binary (Class Pointers) where
     as <- replicateM (fromIntegral $ asCount) get
     let pool' = M.fromList $ zip [1..] pool
     return $ Class magic minor major poolsize pool' af this super
-               interfacesCount ifaces classFieldsCount classFields classMethodsCount classMethods asCount as
+               interfacesCount ifaces classFieldsCount classFields
+               classMethodsCount classMethods asCount (AP as)
 
 -- | Field signature format
 data FieldType =
@@ -426,7 +439,7 @@ instance Binary (Field Pointers) where
     put fieldName
     put fieldSignature
     put fieldAttributesCount
-    forM_ fieldAttributes put
+    forM_ (attributesList fieldAttributes) put
 
   get = do
     af <- get
@@ -434,11 +447,11 @@ instance Binary (Field Pointers) where
     si <- get
     n <- get
     as <- replicateM (fromIntegral n) get
-    return $ Field af ni si n as
+    return $ Field af ni si n (AP as)
 
 -- | Class method format
 data Method stage = Method {
-  methodAccessFlags :: Attributes stage,
+  methodAccessFlags :: AccessFlags stage,
   methodName :: Link stage B.ByteString,
   methodSignature :: Link stage MethodSignature,
   methodAttributesCount :: Word16,
@@ -455,7 +468,7 @@ instance Binary (Method Pointers) where
     put methodName
     put methodSignature
     put methodAttributesCount 
-    forM_ methodAttributes put
+    forM_ (attributesList methodAttributes) put
 
   get = do
     offset <- bytesRead
@@ -464,7 +477,12 @@ instance Binary (Method Pointers) where
     si <- get
     n <- get
     as <- replicateM (fromIntegral n) get
-    return $ Method af ni si n as
+    return $ Method {
+               methodAccessFlags = af,
+               methodName = ni,
+               methodSignature = si,
+               methodAttributesCount = n,
+               methodAttributes = AP as }
 
 -- | Any (class/ field/ method/ ...) attribute format.
 -- Some formats specify special formats for @attributeValue@.

diff --git a/JVM/Converter.hs b/JVM/Converter.hs
index e53f380233bbdf60895fedddc30cea16091bee29..82a1782134019ed7e0e8503286d3f35d753b5f6d 100644 (file)
--- a/JVM/Converter.hs
+++ b/JVM/Converter.hs
@@ -73,10 +73,12 @@ classFile (Class {..}) = Class {
     classFields = map (fieldInfo poolInfo) classFields,
     classMethodsCount = fromIntegral (length classMethods),
     classMethods = map (methodInfo poolInfo) classMethods,
-    classAttributesCount = fromIntegral (M.size classAttributes),
-    classAttributes = map (attrInfo poolInfo) (M.assocs classAttributes) }
+    classAttributesCount = fromIntegral $ arsize classAttributes,
+    classAttributes = to (arlist classAttributes) }
   where
     poolInfo = toCPInfo constsPool
+    to :: [(B.ByteString, B.ByteString)] -> Attributes Pointers
+    to pairs = AP (map (attrInfo poolInfo) pairs)
 
 toCPInfo :: Pool Resolved -> Pool Pointers
 toCPInfo pool = result
@@ -98,12 +100,12 @@ toCPInfo pool = result
     cpInfo (CDouble x) = CDouble x
     cpInfo (CNameType n t) =
       CNameType (force "name" $ poolIndex result n) (force "type" $ poolIndex result t)
-    cpInfo (CUTF8 s) = CUTF8 (fromIntegral $ B.length s) s
-    cpInfo (CUnicode s) = CUnicode (fromIntegral $ B.length s) s
+    cpInfo (CUTF8 s) = CUTF8 s
+    cpInfo (CUnicode s) = CUnicode s
 
 -- | Find index of given string in the list of constants
 poolIndex :: (Throws NoItemInPool e) => Pool Pointers -> B.ByteString -> EM e Word16
-poolIndex list name = case findIndex test list of
+poolIndex list name = case findIndex test (M.elems list) of
                         Nothing -> throw (NoItemInPool name)
                         Just i ->  return $ fromIntegral $ i+1
   where
@@ -113,9 +115,9 @@ poolIndex list name = case findIndex test list of
 
 -- | Find index of given string in the list of constants
 poolClassIndex :: (Throws NoItemInPool e) => Pool Pointers -> B.ByteString -> EM e Word16
-poolClassIndex list name = case findIndex checkString list of
+poolClassIndex list name = case findIndex checkString (M.elems list) of
                         Nothing -> throw (NoItemInPool name)
-                        Just i ->  case findIndex (checkClass $ fromIntegral $ i+1) list of
+                        Just i ->  case findIndex (checkClass $ fromIntegral $ i+1) (M.elems list) of
                                      Nothing -> throw (NoItemInPool $ i+1)
                                      Just j  -> return $ fromIntegral $ j+1
   where
@@ -129,7 +131,7 @@ poolClassIndex list name = case findIndex checkString list of
 poolNTIndex list x@(NameType n t) = do
     ni <- poolIndex list n
     ti <- poolIndex list (byteString t)
-    case findIndex (check ni ti) list of
+    case findIndex (check ni ti) (M.elems list) of
       Nothing -> throw (NoItemInPool x)
       Just i  -> return $ fromIntegral (i+1)
   where
@@ -139,21 +141,27 @@ poolNTIndex list x@(NameType n t) = do
 
 fieldInfo :: Pool Pointers -> Field Resolved -> Field Pointers
 fieldInfo pool (Field {..}) = Field {
-  fieldAccessFlags = access2word16 fieldAccessFlags,
-  fieldName = force "field name" $ poolIndex pool fieldName,
-  fieldSignature = force "signature" $ poolIndex pool (encode fieldSignature),
-  fieldAttributesCount = fromIntegral (M.size fieldAttributes),
-  fieldAttributes = map (attrInfo pool) (M.assocs fieldAttributes) }
+    fieldAccessFlags = access2word16 fieldAccessFlags,
+    fieldName = force "field name" $ poolIndex pool fieldName,
+    fieldSignature = force "signature" $ poolIndex pool (encode fieldSignature),
+    fieldAttributesCount = fromIntegral (arsize fieldAttributes),
+    fieldAttributes = to (arlist fieldAttributes) }
+  where
+    to :: [(B.ByteString, B.ByteString)] -> Attributes Pointers
+    to pairs = AP (map (attrInfo pool) pairs)
 
 methodInfo :: Pool Pointers -> Method Resolved -> Method Pointers
 methodInfo pool (Method {..}) = Method {
-  methodAccessFlags = access2word16 methodAccessFlags,
-  methodName = force "method name" $ poolIndex pool methodName,
-  methodSignature = force "method sig" $ poolIndex pool (encode methodSignature),
-  methodAttributesCount = fromIntegral (M.size methodAttributes),
-  methodAttributes = map (attrInfo pool) (M.assocs methodAttributes) }
+    methodAccessFlags = access2word16 methodAccessFlags,
+    methodName = force "method name" $ poolIndex pool methodName,
+    methodSignature = force "method sig" $ poolIndex pool (encode methodSignature),
+    methodAttributesCount = fromIntegral (arsize methodAttributes),
+    methodAttributes = to (arlist methodAttributes) }
+  where
+    to :: [(B.ByteString, B.ByteString)] -> Attributes Pointers
+    to pairs = AP (map (attrInfo pool) pairs)
 
-attrInfo :: Pool Pointers -> (B.ByteString, B.ByteString) -> Attributes Pointers
+attrInfo :: Pool Pointers -> (B.ByteString, B.ByteString) -> Attribute
 attrInfo pool (name, value) = Attribute {
   attributeName = force "attr name" $ poolIndex pool name,
   attributeLength = fromIntegral (B.length value),
@@ -162,10 +170,10 @@ attrInfo pool (name, value) = Attribute {
 constantPoolArray :: Pool Pointers -> Pool Resolved
 constantPoolArray ps = pool
   where
-    pool :: Pool
+    pool :: Pool Resolved
     pool = M.map convert ps
 
-    n = fromIntegral $ length ps
+    n = fromIntegral $ M.size ps
 
     convertNameType :: (HasSignature a, Binary (Signature a)) => Word16 -> NameType a
     convertNameType i =
@@ -182,8 +190,8 @@ constantPoolArray ps = pool
     convert (CLong x)    = CLong (fromIntegral x)
     convert (CDouble x)  = CDouble x
     convert (CNameType i j) = CNameType (getString $ pool ! i) (getString $ pool ! j)
-    convert (CUTF8 _ bs) = CUTF8 bs
-    convert (CUnicode _ bs) = CUnicode bs
+    convert (CUTF8 bs) = CUTF8 bs
+    convert (CUnicode bs) = CUnicode bs
 
 convertAccess :: AccessFlags Pointers -> AccessFlags Resolved
 convertAccess w = S.fromList $ concat $ zipWith (\i f -> if testBit w i then [f] else []) [0..] $ [
@@ -210,6 +218,7 @@ convertField pool (Field {..}) = Field {
   fieldAccessFlags = convertAccess fieldAccessFlags,
   fieldName = getString $ pool ! fieldName,
   fieldSignature = decode $ getString $ pool ! fieldSignature,
+  fieldAttributesCount = fromIntegral (apsize fieldAttributes),
   fieldAttributes = convertAttrs pool fieldAttributes }
 
 convertMethod :: Pool Resolved -> Method Pointers -> Method Resolved
@@ -217,11 +226,13 @@ convertMethod pool (Method {..}) = Method {
   methodAccessFlags = convertAccess methodAccessFlags,
   methodName = getString $ pool ! methodName,
   methodSignature = decode $ getString $ pool ! methodSignature,
+  methodAttributesCount = fromIntegral (apsize methodAttributes),
   methodAttributes = convertAttrs pool methodAttributes }
 
 convertAttrs :: Pool Resolved -> Attributes Pointers -> Attributes Resolved
-convertAttrs pool attrs = M.fromList $ map go attrs
+convertAttrs pool (AP attrs) = AR (M.fromList $ map go attrs)
   where
+    go :: Attribute -> (B.ByteString, B.ByteString)
     go (Attribute {..}) = (getString $ pool ! attributeName,
                            attributeValue)
 
@@ -232,7 +243,9 @@ methodByName cls name =
 
 -- | Try to get object attribute by name
 attrByName :: (HasAttributes a) => a Resolved -> B.ByteString -> Maybe B.ByteString
-attrByName x name = M.lookup name (attributes x)
+attrByName x name =
+  let (AR m) = attributes x
+  in  M.lookup name m
 
 -- | Try to get Code for class method (no Code for interface methods)
 methodCode :: Class Resolved

diff --git a/JVM/Dump.hs b/JVM/Dump.hs
index 2012c8b94b5533eb706b93f63ad3b44c5336beca..02da46ae2a0d074b2dab39cc459c528795573816 100644 (file)
--- a/JVM/Dump.hs
+++ b/JVM/Dump.hs
@@ -7,18 +7,19 @@ import qualified Data.ByteString.Lazy as B
 import Text.Printf
 
 import JVM.Types
+import JVM.ClassFile
 import JVM.Converter
 import JVM.Assembler
 
-dumpClass :: Class -> IO ()
+dumpClass :: Class Resolved -> IO ()
 dumpClass cls = do
     putStr "Class: "
-    B.putStrLn (this cls)
+    B.putStrLn (thisClass cls)
     putStrLn "Constants pool:"
-    forM_ (M.assocs $ constantPool cls) $ \(i, c) ->
+    forM_ (M.assocs $ constsPool cls) $ \(i, c) ->
       putStrLn $ printf "  #%d:\t%s" i (show c)
     putStrLn "Methods:"
-    forM_ (methods cls) $ \m -> do
+    forM_ (classMethods cls) $ \m -> do
       putStr ">> Method "
       B.putStr (methodName m)
       print (methodSignature m)

diff --git a/JVM/Generator.hs b/JVM/Generator.hs
index 6291b068fcc4322d09068f99b4e556a93d686f52..2ee0240f00726dc24049ffc6c862e54dd0ae1fbd 100644 (file)
--- a/JVM/Generator.hs
+++ b/JVM/Generator.hs
@@ -15,9 +15,9 @@ import JVM.Assembler
 
 data GState = GState {
   generated :: [Instruction],
-  currentPool :: Pool,
-  doneMethods :: [Method],
-  currentMethod :: Maybe Method}
+  currentPool :: Pool Resolved,
+  doneMethods :: [Method Resolved],
+  currentMethod :: Maybe (Method Resolved)}
   deriving (Eq,Show)
 
 emptyGState = GState {
@@ -28,13 +28,13 @@ emptyGState = GState {
 
 type Generate a = State GState a
 
-appendPool :: Constant -> Pool -> (Pool, Word16)
+appendPool :: Constant Resolved -> Pool Resolved -> (Pool Resolved, Word16)
 appendPool c pool =
   let size = fromIntegral (M.size pool)
       pool' = M.insert size c pool
   in  (pool', size)
 
-addItem :: Constant -> Generate Word16
+addItem :: Constant Resolved -> Generate Word16
 addItem c = do
   pool <- St.gets currentPool
   case lookupPool c pool of
@@ -45,7 +45,7 @@ addItem c = do
       St.put $ st {currentPool = pool'}
       return (i+1)
 
-lookupPool :: Constant -> Pool -> Maybe Word16
+lookupPool :: Constant Resolved -> Pool Resolved -> Maybe Word16
 lookupPool c pool =
   fromIntegral `fmap` findIndex (== c) (M.elems pool)
 
@@ -62,7 +62,7 @@ addSig c@(MethodSignature args ret) = do
   let bsig = encode c
   addItem (CUTF8 bsig)
 
-addToPool :: Constant -> Generate Word16
+addToPool :: Constant Resolved -> Generate Word16
 addToPool c@(CClass str) = do
   addItem (CUTF8 str)
   addItem c
@@ -96,12 +96,12 @@ putInstruction instr = do
 i0 :: Instruction -> Generate ()
 i0 = putInstruction
 
-i1 :: (Word16 -> Instruction) -> Constant -> Generate ()
+i1 :: (Word16 -> Instruction) -> Constant Resolved -> Generate ()
 i1 fn c = do
   ix <- addToPool c
   i0 (fn ix)
 
-i8 :: (Word8 -> Instruction) -> Constant -> Generate ()
+i8 :: (Word8 -> Instruction) -> Constant Resolved -> Generate ()
 i8 fn c = do
   ix <- addToPool c
   i0 (fn $ fromIntegral ix)
@@ -112,10 +112,11 @@ startMethod flags name sig = do
   addSig sig
   st <- St.get
   let method = Method {
-    methodAccess = S.fromList flags,
+    methodAccessFlags = S.fromList flags,
     methodName = name,
     methodSignature = sig,
-    methodAttrs = M.empty }
+    methodAttributesCount = 0,
+    methodAttributes = AR M.empty }
   St.put $ st {generated = [],
                currentMethod = Just method }
 
@@ -126,7 +127,8 @@ endMethod = do
   case m of
     Nothing -> fail "endMethod without startMethod!"
     Just method -> do
-      let method' = method {methodAttrs = M.fromList [("Code", encodeMethod code)] }
+      let method' = method {methodAttributes = AR $ M.fromList [("Code", encodeMethod code)],
+                            methodAttributesCount = 1}
       st <- St.get
       St.put $ st {generated = [],
                    currentMethod = Nothing,
@@ -147,7 +149,7 @@ genCode st = Code {
     codeExceptionsN = 0,
     codeExceptions = [],
     codeAttrsN = 0,
-    codeAttributes = [] }
+    codeAttributes = AP [] }
   where
     len = fromIntegral $ B.length $ encodeInstructions (generated st)
 
@@ -157,7 +159,7 @@ initClass name = do
   addToPool (CClass name)
   addToPool (CString "Code")
 
-generate :: B.ByteString -> Generate () -> Class
+generate :: B.ByteString -> Generate () -> Class Resolved
 generate name gen =
   let generator = do
         initClass name
@@ -165,12 +167,20 @@ generate name gen =
       res = execState generator emptyGState
       code = genCode res
   in  Class {
-        constantPool = currentPool res,
-        classAccess = S.fromList [ACC_PUBLIC, ACC_STATIC],
-        this = name,
-        super = Just "java/lang/Object",
-        implements = [],
-        fields = [],
-        methods = doneMethods res,
-        classAttrs = M.empty }
+        magic = 0xCAFEBABE,
+        minorVersion = 0,
+        majorVersion = 50,
+        constsPoolSize = fromIntegral $ M.size (currentPool res),
+        constsPool = currentPool res,
+        accessFlags = S.fromList [ACC_PUBLIC, ACC_STATIC],
+        thisClass = name,
+        superClass = "java/lang/Object",
+        interfacesCount = 0,
+        interfaces = [],
+        classFieldsCount = 0,
+        classFields = [],
+        classMethodsCount = fromIntegral $ length (doneMethods res),
+        classMethods = doneMethods res,
+        classAttributesCount = 0,
+        classAttributes = AR M.empty }
 

diff --git a/dump-class.hs b/dump-class.hs
index 3c52965c8a0a9efd1f0c1facd0c1e48066bcdc2d..86e714f1ea73bb85ca50678870fa705ea00f6fc6 100644 (file)
--- a/dump-class.hs
+++ b/dump-class.hs
@@ -7,6 +7,7 @@ import Data.Binary
 import System.Environment
 import qualified Data.ByteString.Lazy as B
 import Text.Printf
+import qualified Data.Map as M
 
 import JVM.Types
 import JVM.ClassFile
@@ -18,7 +19,7 @@ main = do
   case args of
     [clspath] -> do
       clsFile <- decodeFile clspath
-      putStrLn $ showListIx $ constsPool clsFile
+      putStrLn $ showListIx $ M.elems $ constsPool (clsFile :: Class Pointers)
       cls <- parseClassFile clspath
       dumpClass cls
     _ -> error "Synopsis: dump-class File.class"

diff --git a/rebuild-class.hs b/rebuild-class.hs
index 1265cf1207b9dd07db78da902197b4e049ff8d77..337c5b2f9d95fd94907f270055450e5fa0aff034 100644 (file)
--- a/rebuild-class.hs
+++ b/rebuild-class.hs
@@ -6,6 +6,7 @@ import Data.Binary
 import System.Environment
 import qualified Data.ByteString.Lazy as B
 import Text.Printf
+import qualified Data.Map as M
 
 import JVM.Types
 import JVM.ClassFile
@@ -18,11 +19,11 @@ main = do
   case args of
     [clspath,outpath] -> do
       cls <- parseClassFile clspath
-      clsfile <- decodeFile clspath :: IO ClassFile
+      clsfile <- decodeFile clspath :: IO (Class Pointers)
       dumpClass cls
-      putStrLn $ "Source pool:\n" ++ showListIx (constsPool clsfile)
+      putStrLn $ "Source pool:\n" ++ showListIx (M.elems $ constsPool clsfile)
       let result = classFile cls
-      putStrLn $ "Result pool:\n" ++ showListIx (constsPool result)
+      putStrLn $ "Result pool:\n" ++ showListIx (M.elems $ constsPool result)
       B.writeFile outpath (encodeClass cls)
 
     _ -> error "Synopsis: rebuild-class File.class Output.class"