packages feed

hs-java 0.1 → 0.2

raw patch · 16 files changed

+986/−403 lines, 16 filesdep −haskell98

Dependencies removed: haskell98

Files

JVM/Assembler.hs view
@@ -10,6 +10,8 @@    Code (..),    IMM (..),    CMP (..),+   atype2byte,+   encodeInstructions,    encodeMethod,    decodeMethod   )@@ -17,10 +19,10 @@  import Control.Monad import Control.Applicative+import Data.Ix (inRange) import Data.Word import qualified Data.Binary as Binary import qualified Data.ByteString.Lazy as B-import Data.Array  import Data.BinaryState import JVM.ClassFile@@ -52,7 +54,7 @@     codeExceptionsN :: Word16,     codeExceptions :: [CodeException],     codeAttrsN :: Word16,-    codeAttributes :: [AttributeInfo] }+    codeAttributes :: Attributes Pointers }   deriving (Eq, Show)  -- | Exception descriptor@@ -72,7 +74,7 @@    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@@ -88,7 +90,7 @@     put codeExceptionsN     forM_ codeExceptions put     put codeAttrsN-    forM_ codeAttributes put+    forM_ (attributesList codeAttributes) put    get = do     stackSz <- get@@ -101,7 +103,7 @@     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]@@ -705,6 +707,11 @@         | inRange (153, 158) c -> return $ IF (toEnum $ fromIntegral $ c-153)         | inRange (159, 164) c -> IF_ICMP (toEnum $ fromIntegral $ c-159) <$> get         | otherwise -> fail $ "Unknown instruction byte code: " ++ show c++encodeInstructions :: [Instruction] -> B.ByteString+encodeInstructions code =+  let p list = forM_ list put+  in  encodeWith p (0 :: Integer) code    -- | Decode Java method decodeMethod :: B.ByteString -> Code
+ JVM/Builder.hs view
@@ -0,0 +1,18 @@++module JVM.Builder+  (module JVM.Builder.Monad,+   module JVM.Builder.Instructions,+   arrayOf, sizedArray+  ) where++import JVM.ClassFile++import JVM.Builder.Monad+import JVM.Builder.Instructions++arrayOf :: FieldType -> FieldType+arrayOf t = Array Nothing t++sizedArray :: Int -> FieldType -> FieldType+sizedArray n t = Array (Just n) t+
+ JVM/Builder/Instructions.hs view
@@ -0,0 +1,162 @@++module JVM.Builder.Instructions where++import JVM.ClassFile+import JVM.Assembler+import JVM.Builder.Monad++nop = i0 NOP+aconst_null = i0 ACONST_NULL+iconst_m1 = i0 ICONST_M1+iconst_0 = i0 ICONST_0+iconst_1 = i0 ICONST_1+iconst_2 = i0 ICONST_2+iconst_3 = i0 ICONST_3+iconst_4 = i0 ICONST_4+iconst_5 = i0 ICONST_5+lconst_0 = i0 LCONST_0+lconst_1 = i0 LCONST_1+fconst_0 = i0 FCONST_0+fconst_1 = i0 FCONST_1+fconst_2 = i0 FCONST_2+dconst_0 = i0 DCONST_0+dconst_1 = i0 DCONST_1++bipush x = i0 (BIPUSH x)+sipush x = i0 (SIPUSH x)+ldc1 x = i8 LDC1 x+ldc2 x = i1 LDC2 x+ldc2w x = i1 LDC2W x+iload x = i8 ILOAD x+lload x = i8 LLOAD x+fload x = i8 FLOAD x+dload x = i8 DLOAD x+aload x = i8 ALOAD x++iload_ x = i0 (ILOAD_ x)+lload_ x = i0 (LLOAD_ x)+fload_ x = i0 (FLOAD_ x)+dload_ x = i0 (DLOAD_ x)+aload_ x = i0 (ALOAD_ x)++iaload = i0 IALOAD+laload = i0 LALOAD+faload = i0 FALOAD+daload = i0 DALOAD+aaload = i0 AALOAD+caload = i0 CALOAD+saload = i0 SALOAD++istore x = i8 ISTORE x+lstore x = i8 LSTORE x+fstore x = i8 FSTORE x+dstore x = i8 DSTORE x+astore x = i8 ASTORE x++istore_ x = i0 (ISTORE x)+lstore_ x = i0 (LSTORE x)+fstore_ x = i0 (FSTORE x)+dstore_ x = i0 (DSTORE x)+astore_ x = i0 (ASTORE x)++iastore = i0 IASTORE+lastore = i0 LASTORE+fastore = i0 FASTORE+dastore = i0 DASTORE+aastore = i0 AASTORE+bastore = i0 BASTORE+castore = i0 CASTORE+sastore = i0 SASTORE++pop     = i0 POP    +pop2    = i0 POP2   +dup     = i0 DUP    +dup_x1  = i0 DUP_X1 +dup_x2  = i0 DUP_X2 +dup2    = i0 DUP2   +dup2_x1 = i0 DUP2_X1+dup2_x2 = i0 DUP2_X2+swap    = i0 SWAP   +iadd    = i0 IADD   +ladd    = i0 LADD   +fadd    = i0 FADD   +dadd    = i0 DADD   +isub    = i0 ISUB   +lsub    = i0 LSUB   +fsub    = i0 FSUB   +dsub    = i0 DSUB   +imul    = i0 IMUL   +lmul    = i0 LMUL   +fmul    = i0 FMUL   +dmul    = i0 DMUL   +idiv    = i0 IDIV   +ldiv    = i0 LDIV   +fdiv    = i0 FDIV   +ddiv    = i0 DDIV   +irem    = i0 IREM   +lrem    = i0 LREM   +frem    = i0 FREM   +drem    = i0 DREM   +ineg    = i0 INEG   +lneg    = i0 LNEG   +fneg    = i0 FNEG   +dneg    = i0 DNEG   +ishl    = i0 ISHL   +lshl    = i0 LSHL   +ishr    = i0 ISHR   +lshr    = i0 LSHR   +iushr   = i0 IUSHR  +lushr   = i0 LUSHR  +iand    = i0 IAND   +land    = i0 LAND   +ior     = i0 IOR    +lor     = i0 LOR    +ixor    = i0 IXOR   +lxor    = i0 LXOR   ++iinc x y = i0 (IINC x y)++i2l  = i0 I2L +i2f  = i0 I2F +i2d  = i0 I2D +l2i  = i0 L2I +l2f  = i0 L2F +l2d  = i0 L2D +f2i  = i0 F2I +f2l  = i0 F2L +f2d  = i0 F2D +d2i  = i0 D2I +d2l  = i0 D2L +d2f  = i0 D2F +i2b  = i0 I2B +i2c  = i0 I2C +i2s  = i0 I2S +lcmp = i0 LCMP++new cls =+  i1 NEW (CClass cls)++newArray t =+  i0 (NEWARRAY $ atype2byte t)++allocNewArray cls =+  i1 ANEWARRAY (CClass cls)++invokeVirtual cls sig =+  i1 INVOKEVIRTUAL (CMethod cls sig)++invokeStatic cls sig =+  i1 INVOKESTATIC (CMethod cls sig)++invokeSpecial cls sig =+  i1 INVOKESPECIAL (CMethod cls sig)++getStaticField cls sig =+  i1 GETSTATIC (CField cls sig)++loadString str =+  i8 LDC1 (CString str)++allocArray cls =+  i1 ANEWARRAY (CClass cls)+
+ JVM/Builder/Monad.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE FlexibleContexts, TypeFamilies, OverloadedStrings #-}+module JVM.Builder.Monad where++import Control.Monad.State as St+import Data.Word+import Data.List+import Data.Binary+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.ByteString.Lazy as B++import JVM.Common ()  -- import instances only+import JVM.ClassFile+import JVM.Assembler++data GState = GState {+  generated :: [Instruction],+  currentPool :: Pool Resolved,+  doneMethods :: [Method Resolved],+  currentMethod :: Maybe (Method Resolved)}+  deriving (Eq,Show)++emptyGState = GState {+  generated = [],+  currentPool = M.empty,+  doneMethods = [],+  currentMethod = Nothing }++type Generate a = State GState a++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 Resolved -> Generate Word16+addItem c = do+  pool <- St.gets currentPool+  case lookupPool c pool of+    Just i -> return (i+1)+    Nothing -> do+      let (pool', i) = appendPool c pool+      st <- St.get+      St.put $ st {currentPool = pool'}+      return (i+1)++lookupPool :: Constant Resolved -> Pool Resolved -> Maybe Word16+lookupPool c pool =+  fromIntegral `fmap` findIndex (== c) (M.elems pool)++addNT :: Binary (Signature a) => NameType a -> Generate Word16+addNT (NameType name sig) = do+  let bsig = encode sig+  x <- addItem (CNameType name bsig)+  addItem (CUTF8 name)+  addItem (CUTF8 bsig)+  return x++addSig :: MethodSignature -> Generate Word16+addSig c@(MethodSignature args ret) = do+  let bsig = encode c+  addItem (CUTF8 bsig)++addToPool :: Constant Resolved -> Generate Word16+addToPool c@(CClass str) = do+  addItem (CUTF8 str)+  addItem c+addToPool c@(CField cls name) = do+  addToPool (CClass cls)+  addNT name+  addItem c+addToPool c@(CMethod cls name) = do+  addToPool (CClass cls)+  addNT name+  addItem c+addToPool c@(CIfaceMethod cls name) = do+  addToPool (CClass cls)+  addNT name+  addItem c+addToPool c@(CString str) = do+  addToPool (CUTF8 str)+  addItem c+addToPool c@(CNameType name sig) = do+  addItem (CUTF8 name)+  addItem (CUTF8 sig)+  addItem c+addToPool c = addItem c++putInstruction :: Instruction -> Generate ()+putInstruction instr = do+  st <- St.get+  let code = generated st+  St.put $ st {generated = code ++ [instr]}++i0 :: Instruction -> Generate ()+i0 = putInstruction++i1 :: (Word16 -> Instruction) -> Constant Resolved -> Generate ()+i1 fn c = do+  ix <- addToPool c+  i0 (fn ix)++i8 :: (Word8 -> Instruction) -> Constant Resolved -> Generate ()+i8 fn c = do+  ix <- addToPool c+  i0 (fn $ fromIntegral ix)++startMethod :: [AccessFlag] -> B.ByteString -> MethodSignature -> Generate ()+startMethod flags name sig = do+  addToPool (CString name)+  addSig sig+  st <- St.get+  let method = Method {+    methodAccessFlags = S.fromList flags,+    methodName = name,+    methodSignature = sig,+    methodAttributesCount = 0,+    methodAttributes = AR M.empty }+  St.put $ st {generated = [],+               currentMethod = Just method }++endMethod :: Generate ()+endMethod = do+  m <- St.gets currentMethod+  code <- St.gets genCode+  case m of+    Nothing -> fail "endMethod without startMethod!"+    Just method -> do+      let method' = method {methodAttributes = AR $ M.fromList [("Code", encodeMethod code)],+                            methodAttributesCount = 1}+      st <- St.get+      St.put $ st {generated = [],+                   currentMethod = Nothing,+                   doneMethods = doneMethods st ++ [method']}++newMethod :: [AccessFlag] -> B.ByteString -> [ArgumentSignature] -> ReturnSignature -> Generate () -> Generate (NameType Method)+newMethod flags name args ret gen = do+  let sig = MethodSignature args ret+  startMethod flags name sig+  gen+  endMethod+  return (NameType name sig)++genCode :: GState -> Code+genCode st = Code {+    codeStackSize = 4096,+    codeMaxLocals = 100,+    codeLength = len,+    codeInstructions = generated st,+    codeExceptionsN = 0,+    codeExceptions = [],+    codeAttrsN = 0,+    codeAttributes = AP [] }+  where+    len = fromIntegral $ B.length $ encodeInstructions (generated st)++initClass :: B.ByteString -> Generate Word16+initClass name = do+  addToPool (CClass "java/lang/Object")+  addToPool (CClass name)+  addToPool (CString "Code")++generate :: B.ByteString -> Generate () -> Class Resolved+generate name gen =+  let generator = do+        initClass name+        gen+      res = execState generator emptyGState+      code = genCode res+  in  Class {+        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 }+
JVM/ClassFile.hs view
@@ -1,15 +1,21 @@-{-# LANGUAGE RecordWildCards, BangPatterns #-}+{-# LANGUAGE RecordWildCards, BangPatterns, TypeFamilies, StandaloneDeriving, FlexibleContexts, FlexibleInstances, UndecidableInstances, TypeSynonymInstances #-} -- | This module declares (low-level) data types for Java .class files -- structures, and Binary instances to read/write them. module JVM.ClassFile-  (ClassFile (..),-   CpInfo (..),-   FieldInfo (..),-   MethodInfo (..),-   AttributeInfo (..),+  (Attribute (..),    FieldType (..),    FieldSignature, MethodSignature (..), ReturnSignature (..),-   ArgumentSignature (..)+   ArgumentSignature (..),+   Pool, Link,+   Method (..), Field (..), Class (..),+   Constant (..),+   Pointers, Resolved,+   NameType (..),+   HasSignature (..), HasAttributes (..),+   AccessFlag (..), AccessFlags,+   Attributes (..),+   className,+   apsize, arsize, arlist   )   where @@ -21,7 +27,10 @@ import Data.Binary.Put import Data.Char import Data.List+import qualified Data.Set as S+import qualified Data.Map as M import qualified Data.ByteString.Lazy as B+import Codec.Binary.UTF8.String hiding (encode, decode)  -- | Read one-byte Char getChar8 :: Get Char@@ -29,34 +38,147 @@   x <- getWord8   return $ chr (fromIntegral x) +toString :: B.ByteString -> String+toString bstr = decodeString $ map (chr . fromIntegral) $ B.unpack bstr++type family Link s a++data Pointers = Pointers++data Resolved = Resolved++type instance Link Pointers a = Word16++type instance Link Resolved a = a++type family AccessFlags stage++type instance AccessFlags Pointers = Word16++type instance AccessFlags Resolved = S.Set AccessFlag++data family Attributes stage++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 =+    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)++class HasSignature a where+  type Signature a++instance HasSignature Field where+  type Signature Field = FieldSignature++instance HasSignature Method where+  type Signature Method = MethodSignature++-- | Name and signature pair. Used for methods and fields.+data NameType a = NameType {+  ntName :: B.ByteString,+  ntSignature :: Signature a }++instance Show (Signature a) => Show (NameType a) where+  show (NameType n t) = toString n ++ ": " ++ show t++deriving instance Eq (Signature a) => Eq (NameType a)++instance (Binary (Signature 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)}+  | CString (Link stage B.ByteString)+  | CInteger Word32+  | CFloat Float+  | CLong Integer+  | CDouble Double+  | CNameType (Link stage B.ByteString) (Link stage B.ByteString)+  | CUTF8 {getString :: B.ByteString}+  | CUnicode {getString :: B.ByteString}++className ::  Constant Resolved -> B.ByteString+className (CClass s) = s+className x = error $ "Not a class: " ++ show x++instance Show (Constant Resolved) where+  show (CClass name) = "class " ++ toString name+  show (CField cls nt) = "field " ++ toString cls ++ "." ++ show nt+  show (CMethod cls nt) = "method " ++ toString cls ++ "." ++ show nt+  show (CIfaceMethod cls nt) = "interface method " ++ toString cls ++ "." ++ show nt+  show (CString s) = "String \"" ++ toString s ++ "\""+  show (CInteger x) = show x+  show (CFloat x) = show x+  show (CLong x) = show x+  show (CDouble x) = show x+  show (CNameType name tp) = toString name ++ ": " ++ toString tp+  show (CUTF8 s) = "UTF8 \"" ++ toString s ++ "\""+  show (CUnicode s) = "Unicode \"" ++ toString s ++ "\""++-- | Constant pool+type Pool stage = M.Map Word16 (Constant stage)+ -- | Generic .class file format-data ClassFile = ClassFile {+data Class stage = Class {   magic :: Word32,                   -- ^ Magic value: 0xCAFEBABE   minorVersion :: Word16,   majorVersion :: Word16,   constsPoolSize :: Word16,          -- ^ Number of items in constants pool-  constsPool :: [CpInfo],            -- ^ Constants pool itself-  accessFlags :: Word16,             -- ^ See @JVM.Types.AccessFlag@-  thisClass :: Word16,               -- ^ Constants pool item index for this class-  superClass :: Word16,              -- ^ --/-- for super class, zero for java.lang.Object+  constsPool :: Pool stage,            -- ^ Constants pool itself+  accessFlags :: AccessFlags stage,             -- ^ See @JVM.Types.AccessFlag@+  thisClass :: Link stage B.ByteString,               -- ^ Constants pool item index for this class+  superClass :: Link stage B.ByteString,              -- ^ --/-- for super class, zero for java.lang.Object   interfacesCount :: Word16,         -- ^ Number of implemented interfaces-  interfaces :: [Word16],            -- ^ Constants pool item indexes for implemented interfaces+  interfaces :: [Link stage B.ByteString],            -- ^ Constants pool item indexes for implemented interfaces   classFieldsCount :: Word16,        -- ^ Number of class fileds-  classFields :: [FieldInfo],        -- ^ Class fields+  classFields :: [Field stage],        -- ^ Class fields   classMethodsCount :: Word16,       -- ^ Number of class methods-  classMethods :: [MethodInfo],      -- ^ Class methods+  classMethods :: [Method stage],      -- ^ Class methods   classAttributesCount :: Word16,    -- ^ Number of class attributes-  classAttributes :: [AttributeInfo] -- ^ Class attributes+  classAttributes :: Attributes stage -- ^ Class attributes   }-  deriving (Eq, Show) -instance Binary ClassFile where-  put (ClassFile {..}) = do+deriving instance Eq (Constant Pointers)+deriving instance Eq (Constant Resolved)+deriving instance Show (Constant Pointers)++instance Binary (Class Pointers) where+  put (Class {..}) = do     put magic     put minorVersion     put majorVersion     put constsPoolSize-    forM_ constsPool put+    forM_ (M.elems constsPool) put     put accessFlags     put thisClass     put superClass@@ -67,7 +189,7 @@     put classMethodsCount     forM_ classMethods put     put classAttributesCount-    forM_ classAttributes put+    forM_ (attributesList classAttributes) put    get = do     magic <- get@@ -86,8 +208,10 @@     classMethods <- replicateM (fromIntegral classMethodsCount) get     asCount <- get     as <- replicateM (fromIntegral $ asCount) get-    return $ ClassFile magic minor major poolsize pool af this super-               interfacesCount ifaces classFieldsCount classFields classMethodsCount classMethods asCount as+    let pool' = M.fromList $ zip [1..] pool+    return $ Class magic minor major poolsize pool' af this super+               interfacesCount ifaces classFieldsCount classFields+               classMethodsCount classMethods asCount (AP as)  -- | Field signature format data FieldType =@@ -252,35 +376,25 @@               return (x: next)     Nothing -> return [] --- | Constant pool item format-data CpInfo =-    CONSTANT_Class {nameIndex :: Word16}                                          -- ^ 7-  | CONSTANT_Fieldref {classIndex :: Word16, nameAndTypeIndex :: Word16}	        -- ^ 9-  | CONSTANT_Methodref 	{classIndex :: Word16, nameAndTypeIndex :: Word16}        -- ^ 10-  | CONSTANT_InterfaceMethodref {classIndex :: Word16, nameAndTypeIndex :: Word16}-- ^ 11-  | CONSTANT_String {stringIndex :: Word16}                                       -- ^ 8-  | CONSTANT_Integer {fourBytes :: Word32}	                                      -- ^ 3-  | CONSTANT_Float Float                                                          -- ^ 4-  | CONSTANT_Long Word64                                                          -- ^ 5-  | CONSTANT_Double Double                                                        -- ^ 6-  | CONSTANT_NameAndType {nameIndex :: Word16, signatureIndex :: Word16} 	        -- ^ 12-  | CONSTANT_Utf8 {stringLength :: Word16, stringBytes :: B.ByteString}   	      -- ^ 1-  | CONSTANT_Unicode {stringLength :: Word16, stringBytes :: B.ByteString}   	    -- ^ 2-  deriving (Eq, Show)--instance Binary CpInfo where-  put (CONSTANT_Class i) = putWord8 7 >> put i-  put (CONSTANT_Fieldref i j) = putWord8 9 >> put i >> put j-  put (CONSTANT_Methodref i j) = putWord8 10 >> put i >> put j-  put (CONSTANT_InterfaceMethodref i j) = putWord8 11 >> put i >> put j-  put (CONSTANT_String i) = putWord8 8 >> put i-  put (CONSTANT_Integer x) = putWord8 3 >> put x-  put (CONSTANT_Float x)   = putWord8 4 >> putFloat32be x-  put (CONSTANT_Long x)    = putWord8 5 >> put x-  put (CONSTANT_Double x)  = putWord8 6 >> putFloat64be x-  put (CONSTANT_NameAndType i j) = putWord8 12 >> put i >> put j-  put (CONSTANT_Utf8 l bs) = putWord8 1 >> put l >> putLazyByteString bs-  put (CONSTANT_Unicode l bs) = putWord8 2 >> put l >> putLazyByteString bs+instance Binary (Constant Pointers) where+  put (CClass i) = putWord8 7 >> put i+  put (CField i j) = putWord8 9 >> put i >> put j+  put (CMethod i j) = putWord8 10 >> put i >> put j+  put (CIfaceMethod i j) = putWord8 11 >> put i >> put j+  put (CString i) = putWord8 8 >> put i+  put (CInteger x) = putWord8 3 >> put x+  put (CFloat x)   = putWord8 4 >> putFloat32be x+  put (CLong x)    = putWord8 5 >> put x+  put (CDouble x)  = putWord8 6 >> putFloat64be x+  put (CNameType i j) = putWord8 12 >> put i >> put j+  put (CUTF8 bs) = do+                   putWord8 1+                   put (fromIntegral (B.length bs) :: Word16)+                   putLazyByteString bs+  put (CUnicode bs) = do+                   putWord8 2+                   put (fromIntegral (B.length bs) :: Word16)+                   putLazyByteString bs    get = do     !offset <- bytesRead@@ -288,40 +402,44 @@     case tag of       1 -> do         l <- get-        bs <- getLazyByteString (fromIntegral l)-        return $ CONSTANT_Utf8 l bs+        bs <- getLazyByteString (fromIntegral (l :: Word16))+        return $ CUTF8 bs       2 -> do         l <- get-        bs <- getLazyByteString (fromIntegral l)-        return $ CONSTANT_Unicode l bs-      3  -> CONSTANT_Integer   <$> get-      4  -> CONSTANT_Float     <$> getFloat32be-      5  -> CONSTANT_Long      <$> get-      6  -> CONSTANT_Double    <$> getFloat64be-      7  -> CONSTANT_Class     <$> get-      8  -> CONSTANT_String    <$> get-      9  -> CONSTANT_Fieldref  <$> get <*> get-      10 -> CONSTANT_Methodref <$> get <*> get-      11 -> CONSTANT_InterfaceMethodref <$> get <*> get-      12 -> CONSTANT_NameAndType <$> get <*> get+        bs <- getLazyByteString (fromIntegral (l :: Word16))+        return $ CUnicode bs+      3  -> CInteger   <$> get+      4  -> CFloat     <$> getFloat32be+      5  -> CLong      <$> get+      6  -> CDouble    <$> getFloat64be+      7  -> CClass     <$> get+      8  -> CString    <$> get+      9  -> CField     <$> get <*> get+      10 -> CMethod    <$> get <*> get+      11 -> CIfaceMethod <$> get <*> get+      12 -> CNameType    <$> get <*> get       _  -> fail $ "Unknown constants pool entry tag: " ++ show tag  -- | Class field format-data FieldInfo = FieldInfo {-  fieldAccessFlags :: Word16,-  fieldNameIndex :: Word16,-  fieldSignatureIndex :: Word16,+data Field stage = Field {+  fieldAccessFlags :: AccessFlags stage,+  fieldName :: Link stage B.ByteString,+  fieldSignature :: Link stage FieldSignature,   fieldAttributesCount :: Word16,-  fieldAttributes :: [AttributeInfo] }-  deriving (Eq, Show)+  fieldAttributes :: Attributes stage } -instance Binary FieldInfo where-  put (FieldInfo {..}) = do+deriving instance Eq (Field Pointers)+deriving instance Eq (Field Resolved)+deriving instance Show (Field Pointers)+deriving instance Show (Field Resolved)++instance Binary (Field Pointers) where+  put (Field {..}) = do     put fieldAccessFlags -    put fieldNameIndex-    put fieldSignatureIndex+    put fieldName+    put fieldSignature     put fieldAttributesCount-    forM_ fieldAttributes put+    forM_ (attributesList fieldAttributes) put    get = do     af <- get@@ -329,24 +447,28 @@     si <- get     n <- get     as <- replicateM (fromIntegral n) get-    return $ FieldInfo af ni si n as+    return $ Field af ni si n (AP as)  -- | Class method format-data MethodInfo = MethodInfo {-  methodAccessFlags :: Word16,-  methodNameIndex :: Word16,-  methodSignatureIndex :: Word16,+data Method stage = Method {+  methodAccessFlags :: AccessFlags stage,+  methodName :: Link stage B.ByteString,+  methodSignature :: Link stage MethodSignature,   methodAttributesCount :: Word16,-  methodAttributes :: [AttributeInfo] }-  deriving (Eq, Show)+  methodAttributes :: Attributes stage } -instance Binary MethodInfo where-  put (MethodInfo {..}) = do+deriving instance Eq (Method Pointers)+deriving instance Eq (Method Resolved)+deriving instance Show (Method Pointers)+deriving instance Show (Method Resolved)++instance Binary (Method Pointers) where+  put (Method {..}) = do     put methodAccessFlags-    put methodNameIndex -    put methodSignatureIndex+    put methodName+    put methodSignature     put methodAttributesCount -    forM_ methodAttributes put+    forM_ (attributesList methodAttributes) put    get = do     offset <- bytesRead@@ -355,18 +477,23 @@     si <- get     n <- get     as <- replicateM (fromIntegral n) get-    return $ MethodInfo 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@.-data AttributeInfo = AttributeInfo {+data Attribute = Attribute {   attributeName :: Word16,   attributeLength :: Word32,   attributeValue :: B.ByteString }   deriving (Eq, Show) -instance Binary AttributeInfo where-  put (AttributeInfo {..}) = do+instance Binary Attribute where+  put (Attribute {..}) = do     put attributeName     putWord32be attributeLength     putLazyByteString attributeValue@@ -376,5 +503,17 @@     name <- get     len <- getWord32be     value <- getLazyByteString (fromIntegral len)-    return $ AttributeInfo name len value+    return $ Attribute name len value++class HasAttributes a where+  attributes :: a stage -> Attributes stage++instance HasAttributes Class where+  attributes = classAttributes++instance HasAttributes Field where+  attributes = fieldAttributes++instance HasAttributes Method where+  attributes = methodAttributes
+ JVM/Common.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE TypeFamilies, StandaloneDeriving, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}+-- | This module declares `high-level' data types for Java classes, methods etc.+module JVM.Common where++import Codec.Binary.UTF8.String hiding (encode, decode)+import Data.Binary+import Data.Binary.Put+import qualified Data.ByteString.Lazy as B+import Data.Char+import Data.String+import qualified Data.Map as M++import JVM.ClassFile++instance IsString B.ByteString where+  fromString s = B.pack $ map (fromIntegral . ord) $ encodeString s++toCharList :: B.ByteString -> [Int]+toCharList bstr = map fromIntegral $ B.unpack bstr++poolSize :: Pool stage -> Int+poolSize = M.size++(!) :: (Ord k) => M.Map k a -> k -> a+(!) = (M.!)++showListIx :: (Show a) => [a] -> String+showListIx list = unlines $ zipWith s [1..] list+  where s i x = show i ++ ":\t" ++ show x++byteString ::  (Binary t) => t -> B.ByteString+byteString x = runPut (put x)+
JVM/Converter.hs view
@@ -17,168 +17,183 @@ import Data.Bits import Data.Binary import qualified Data.ByteString.Lazy as B-import Data.Array import qualified Data.Set as S import qualified Data.Map as M  import JVM.ClassFile-import JVM.Types+import JVM.Common import JVM.Exceptions  -- | Parse .class file data-parseClass :: B.ByteString -> Class+parseClass :: B.ByteString -> Class Resolved parseClass bstr = convertClass $ decode bstr  -- | Parse class data from file-parseClassFile :: FilePath -> IO Class+parseClassFile :: FilePath -> IO (Class Resolved) parseClassFile path = convertClass `fmap` decodeFile path -encodeClass :: Class -> B.ByteString+encodeClass :: (Class Resolved) -> B.ByteString encodeClass cls = encode $ classFile cls -convertClass :: ClassFile -> Class-convertClass (ClassFile {..}) =+convertClass :: Class Pointers -> Class Resolved+convertClass (Class {..}) =   let pool = constantPoolArray constsPool       superName = className $ pool ! superClass   in Class {-      constantPool = pool,-      classAccess = convertAccess accessFlags,-      this = className $ pool ! thisClass,-      super = if superClass == 0 then Nothing else Just superName,-      implements = map (\i -> className $ pool ! i) interfaces,-      fields = map (convertField pool) classFields,-      methods = map (convertMethod pool) classMethods,-      classAttrs = convertAttrs pool classAttributes }+      magic = 0xCAFEBABE,+      minorVersion = 0,+      majorVersion = 50,+      constsPoolSize = fromIntegral (M.size pool),+      constsPool = pool,+      accessFlags = convertAccess accessFlags,+      thisClass = className $ pool ! thisClass,+      superClass = if superClass == 0 then "" else superName,+      interfacesCount = interfacesCount,+      interfaces = map (\i -> className $ pool ! i) interfaces,+      classFieldsCount = classFieldsCount,+      classFields = map (convertField pool) classFields,+      classMethodsCount = classMethodsCount,+      classMethods = map (convertMethod pool) classMethods,+      classAttributesCount = classAttributesCount,+      classAttributes = convertAttrs pool classAttributes } -classFile :: Class -> ClassFile-classFile (Class {..}) = ClassFile {+classFile :: Class Resolved -> Class Pointers+classFile (Class {..}) = Class {     magic = 0xCAFEBABE,     minorVersion = 0,     majorVersion = 50,-    constsPoolSize = fromIntegral (length poolInfo + 1),+    constsPoolSize = fromIntegral (M.size poolInfo + 1),     constsPool = poolInfo,-    accessFlags = access2word16 classAccess,-    thisClass = force "this" $ poolClassIndex poolInfo this,-    superClass = case super of-                  Just s -> force "super" $ poolClassIndex poolInfo s-                  Nothing -> 0,-    interfacesCount = fromIntegral (length implements),-    interfaces = map (force "ifaces" . poolIndex poolInfo) implements,-    classFieldsCount = fromIntegral (length fields),-    classFields = map (fieldInfo poolInfo) fields,-    classMethodsCount = fromIntegral (length methods),-    classMethods = map (methodInfo poolInfo) methods,-    classAttributesCount = fromIntegral (M.size classAttrs),-    classAttributes = map (attrInfo poolInfo) (M.assocs classAttrs) }+    accessFlags = access2word16 accessFlags,+    thisClass = force "this" $ poolClassIndex poolInfo thisClass,+    superClass = force "super" $ poolClassIndex poolInfo superClass,+    interfacesCount = fromIntegral (length interfaces),+    interfaces = map (force "ifaces" . poolIndex poolInfo) interfaces,+    classFieldsCount = fromIntegral (length classFields),+    classFields = map (fieldInfo poolInfo) classFields,+    classMethodsCount = fromIntegral (length classMethods),+    classMethods = map (methodInfo poolInfo) classMethods,+    classAttributesCount = fromIntegral $ arsize classAttributes,+    classAttributes = to (arlist classAttributes) }   where-    poolInfo = toCPInfo constantPool+    poolInfo = toCPInfo constsPool+    to :: [(B.ByteString, B.ByteString)] -> Attributes Pointers+    to pairs = AP (map (attrInfo poolInfo) pairs) -toCPInfo :: Pool -> [CpInfo]+toCPInfo :: Pool Resolved -> Pool Pointers toCPInfo pool = result   where-    result = map cpInfo $ elems pool+    result = M.map cpInfo pool -    cpInfo (CClass name) = CONSTANT_Class (force "class" $ poolIndex result name)+    cpInfo :: Constant Resolved -> Constant Pointers+    cpInfo (CClass name) = CClass (force "class" $ poolIndex result name)     cpInfo (CField cls name) =-      CONSTANT_Fieldref (force "field a" $ poolClassIndex result cls) (force "field b" $ poolNTIndex result name)+      CField (force "field a" $ poolClassIndex result cls) (force "field b" $ poolNTIndex result name)     cpInfo (CMethod cls name) =-      CONSTANT_Methodref (force "method a" $ poolClassIndex result cls) (force ("method b: " ++ show name) $ poolNTIndex result name)+      CMethod (force "method a" $ poolClassIndex result cls) (force ("method b: " ++ show name) $ poolNTIndex result name)     cpInfo (CIfaceMethod cls name) =-      CONSTANT_InterfaceMethodref (force "iface method a" $ poolIndex result cls) (force "iface method b" $ poolNTIndex result name)-    cpInfo (CString s) = CONSTANT_String (force "string" $ poolIndex result s)-    cpInfo (CInteger x) = CONSTANT_Integer x-    cpInfo (CFloat x) = CONSTANT_Float x-    cpInfo (CLong x) = CONSTANT_Long (fromIntegral x)-    cpInfo (CDouble x) = CONSTANT_Double x+      CIfaceMethod (force "iface method a" $ poolIndex result cls) (force "iface method b" $ poolNTIndex result name)+    cpInfo (CString s) = CString (force "string" $ poolIndex result s)+    cpInfo (CInteger x) = CInteger x+    cpInfo (CFloat x) = CFloat x+    cpInfo (CLong x) = CLong (fromIntegral x)+    cpInfo (CDouble x) = CDouble x     cpInfo (CNameType n t) =-      CONSTANT_NameAndType (force "name" $ poolIndex result n) (force "type" $ poolIndex result t)-    cpInfo (CUTF8 s) = CONSTANT_Utf8 (fromIntegral $ B.length s) s-    cpInfo (CUnicode s) = CONSTANT_Unicode (fromIntegral $ B.length s) s+      CNameType (force "name" $ poolIndex result n) (force "type" $ poolIndex result t)+    cpInfo (CUTF8 s) = CUTF8 s+    cpInfo (CUnicode s) = CUnicode s  -- | Find index of given string in the list of constants-poolIndex :: (Throws NoItemInPool e) => [CpInfo] -> B.ByteString -> EM e Word16-poolIndex list name = case findIndex test list of+poolIndex :: (Throws NoItemInPool e) => Pool Pointers -> B.ByteString -> EM e Word16+poolIndex list name = case findIndex test (M.elems list) of                         Nothing -> throw (NoItemInPool name)                         Just i ->  return $ fromIntegral $ i+1   where-    test (CONSTANT_Utf8 _ s)    | s == name = True-    test (CONSTANT_Unicode _ s) | s == name = True+    test (CUTF8 s)    | s == name = True+    test (CUnicode s) | s == name = True     test _                                  = False  -- | Find index of given string in the list of constants-poolClassIndex :: (Throws NoItemInPool e) => [CpInfo] -> B.ByteString -> EM e Word16-poolClassIndex list name = case findIndex checkString list of+poolClassIndex :: (Throws NoItemInPool e) => Pool Pointers -> B.ByteString -> EM e Word16+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-    checkString (CONSTANT_Utf8 _ s)    | s == name = True-    checkString (CONSTANT_Unicode _ s) | s == name = True+    checkString (CUTF8 s)    | s == name = True+    checkString (CUnicode s) | s == name = True     checkString _                                  = False -    checkClass i (CONSTANT_Class x) | i == x = True+    checkClass i (CClass x) | i == x = True     checkClass _ _                           = False  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-    check ni ti (CONSTANT_NameAndType n' t')+    check ni ti (CNameType n' t')       | (ni == n') && (ti == t') = True     check _ _ _                  = False -fieldInfo :: [CpInfo] -> Field -> FieldInfo-fieldInfo pool (Field {..}) = FieldInfo {-  fieldAccessFlags = access2word16 fieldAccess,-  fieldNameIndex = force "field name" $ poolIndex pool fieldName,-  fieldSignatureIndex = force "signature" $ poolIndex pool (encode fieldSignature),-  fieldAttributesCount = fromIntegral (M.size fieldAttrs),-  fieldAttributes = map (attrInfo pool) (M.assocs fieldAttrs) }+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 (arsize fieldAttributes),+    fieldAttributes = to (arlist fieldAttributes) }+  where+    to :: [(B.ByteString, B.ByteString)] -> Attributes Pointers+    to pairs = AP (map (attrInfo pool) pairs) -methodInfo :: [CpInfo] -> Method -> MethodInfo-methodInfo pool (Method {..}) = MethodInfo {-  methodAccessFlags = access2word16 methodAccess,-  methodNameIndex = force "method name" $ poolIndex pool methodName,-  methodSignatureIndex = force "method sig" $ poolIndex pool (encode methodSignature),-  methodAttributesCount = fromIntegral (M.size methodAttrs),-  methodAttributes = map (attrInfo pool) (M.assocs methodAttrs) }+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 (arsize methodAttributes),+    methodAttributes = to (arlist methodAttributes) }+  where+    to :: [(B.ByteString, B.ByteString)] -> Attributes Pointers+    to pairs = AP (map (attrInfo pool) pairs) -attrInfo :: [CpInfo] -> (B.ByteString, B.ByteString) -> AttributeInfo-attrInfo pool (name, value) = AttributeInfo {+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),   attributeValue = value } -constantPoolArray :: [CpInfo] -> Pool-constantPoolArray list = pool+constantPoolArray :: Pool Pointers -> Pool Resolved+constantPoolArray ps = pool   where-    pool :: Pool-    pool = listArray (1,n) $ map convert list-    n = fromIntegral $ length list+    pool :: Pool Resolved+    pool = M.map convert ps +    n = fromIntegral $ M.size ps+     convertNameType :: (HasSignature a, Binary (Signature a)) => Word16 -> NameType a     convertNameType i =       let (CNameType n s) = pool ! i       in  NameType n (decode s) -    convert (CONSTANT_Class i) = CClass $ getString $ pool ! i-    convert (CONSTANT_Fieldref i j) = CField (className $ pool ! i) (convertNameType j)-    convert (CONSTANT_Methodref i j) = CMethod (className $ pool ! i) (convertNameType j)-    convert (CONSTANT_InterfaceMethodref i j) = CIfaceMethod (className $ pool ! i) (convertNameType j)-    convert (CONSTANT_String i) = CString $ getString $ pool ! i-    convert (CONSTANT_Integer x) = CInteger x-    convert (CONSTANT_Float x)   = CFloat x-    convert (CONSTANT_Long x)    = CLong (fromIntegral x)-    convert (CONSTANT_Double x)  = CDouble x-    convert (CONSTANT_NameAndType i j) = CNameType (getString $ pool ! i) (getString $ pool ! j)-    convert (CONSTANT_Utf8 _ bs) = CUTF8 bs-    convert (CONSTANT_Unicode _ bs) = CUnicode bs+    convert (CClass i) = CClass $ getString $ pool ! i+    convert (CField i j) = CField (className $ pool ! i) (convertNameType j)+    convert (CMethod i j) = CMethod (className $ pool ! i) (convertNameType j)+    convert (CIfaceMethod i j) = CIfaceMethod (className $ pool ! i) (convertNameType j)+    convert (CString i) = CString $ getString $ pool ! i+    convert (CInteger x) = CInteger x+    convert (CFloat x)   = CFloat x+    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 -convertAccess :: Word16 -> Access+convertAccess :: AccessFlags Pointers -> AccessFlags Resolved convertAccess w = S.fromList $ concat $ zipWith (\i f -> if testBit w i then [f] else []) [0..] $ [    ACC_PUBLIC,    ACC_PRIVATE,@@ -192,43 +207,48 @@    ACC_INTERFACE,    ACC_ABSTRACT ] -access2word16 :: Access -> Word16+access2word16 :: AccessFlags Resolved -> AccessFlags Pointers access2word16 fs = bitsOr $ map toBit $ S.toList fs   where     bitsOr = foldl (.|.) 0     toBit f = 1 `shiftL` (fromIntegral $ fromEnum f) -convertField :: Pool -> FieldInfo -> Field-convertField pool (FieldInfo {..}) = Field {-  fieldAccess = convertAccess fieldAccessFlags,-  fieldName = getString $ pool ! fieldNameIndex,-  fieldSignature = decode $ getString $ pool ! fieldSignatureIndex,-  fieldAttrs = convertAttrs pool fieldAttributes }+convertField :: Pool Resolved -> Field Pointers -> Field Resolved+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 -> MethodInfo -> Method-convertMethod pool (MethodInfo {..}) = Method {-  methodAccess = convertAccess methodAccessFlags,-  methodName = getString $ pool ! methodNameIndex,-  methodSignature = decode $ getString $ pool ! methodSignatureIndex,-  methodAttrs = convertAttrs pool methodAttributes }+convertMethod :: Pool Resolved -> Method Pointers -> Method Resolved+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 -> [AttributeInfo] -> Attributes-convertAttrs pool attrs = M.fromList $ map go attrs+convertAttrs :: Pool Resolved -> Attributes Pointers -> Attributes Resolved+convertAttrs pool (AP attrs) = AR (M.fromList $ map go attrs)   where-    go (AttributeInfo {..}) = (getString $ pool ! attributeName,-                               attributeValue)+    go :: Attribute -> (B.ByteString, B.ByteString)+    go (Attribute {..}) = (getString $ pool ! attributeName,+                           attributeValue)  -- | Try to get class method by name-methodByName :: Class -> B.ByteString -> Maybe Method+methodByName :: Class Resolved -> B.ByteString -> Maybe (Method Resolved) methodByName cls name =-  find (\m -> methodName m == name) (methods cls)+  find (\m -> methodName m == name) (classMethods cls)  -- | Try to get object attribute by name-attrByName :: (HasAttributes a) => a -> B.ByteString -> Maybe B.ByteString-attrByName x name = M.lookup name (attributes x)+attrByName :: (HasAttributes a) => a Resolved -> B.ByteString -> Maybe B.ByteString+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+methodCode :: Class Resolved            -> B.ByteString       -- ^ Method name            -> Maybe B.ByteString methodCode cls name = do
+ JVM/Dump.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}+module JVM.Dump where++import Control.Monad+import qualified Data.Map as M+import qualified Data.ByteString.Lazy as B+import Text.Printf++import JVM.Common ()+import JVM.ClassFile+import JVM.Converter+import JVM.Assembler++dumpClass :: Class Resolved -> IO ()+dumpClass cls = do+    putStr "Class: "+    B.putStrLn (thisClass cls)+    putStrLn "Constants pool:"+    forM_ (M.assocs $ constsPool cls) $ \(i, c) ->+      putStrLn $ printf "  #%d:\t%s" i (show c)+    putStrLn "Methods:"+    forM_ (classMethods cls) $ \m -> do+      putStr ">> Method "+      B.putStr (methodName m)+      print (methodSignature m)+      case attrByName m "Code" of+        Nothing -> putStrLn "(no code)\n"+        Just bytecode -> let code = decodeMethod bytecode+                         in  forM_ (codeInstructions code) $ \i -> do+                               putStr "  "+                               print i+
+ JVM/Exceptions.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE DeriveDataTypeable, ExistentialQuantification #-}+module JVM.Exceptions where++import Control.Monad.Exception++data NoItemInPool = forall a. Show a => NoItemInPool a+  deriving (Typeable)++instance Exception NoItemInPool++instance Show NoItemInPool where+  show (NoItemInPool s) = "Internal error: no such item in pool: <" ++ show s ++ ">"++force :: String -> EM AnyException a -> a+force s x =+  case tryEM x of+    Right result -> result+    Left  exc    -> error $ "Exception at " ++ s ++ ": " ++ show exc
− JVM/Types.hs 
@@ -1,162 +0,0 @@-{-# 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.Char-import Data.String-import qualified Data.Set as S-import qualified Data.Map as M--import JVM.ClassFile--instance IsString B.ByteString where-  fromString s = B.pack $ map (fromIntegral . ord) $ encodeString s--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,-  this :: B.ByteString,        -- ^ this class name-  super :: Maybe B.ByteString, -- ^ super class name-  implements :: [B.ByteString], -- ^ implemented interfaces-  fields :: [Field],-  methods :: [Method],-  classAttrs :: Attributes-  }-  deriving (Eq, Show)--instance HasAttributes Class where-  attributes = classAttrs--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 }--instance Show (Signature a) => Show (NameType a) where-  show (NameType n t) = toString n ++ ": " ++ show t--deriving instance Eq (Signature a) => Eq (NameType a)---- | Constant pool item-data Constant =-    CClass B.ByteString-  | CField {refClass :: B.ByteString, fieldNameType :: NameType Field}-  | CMethod {refClass :: B.ByteString, nameType :: NameType Method}-  | CIfaceMethod {refClass :: B.ByteString, nameType :: NameType Method}-  | CString B.ByteString-  | CInteger Word32-  | CFloat Float-  | CLong Integer-  | CDouble Double-  | CNameType B.ByteString B.ByteString-  | CUTF8 {getString :: B.ByteString}-  | 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-  show (CMethod cls nt) = "method " ++ toString cls ++ "." ++ show nt-  show (CIfaceMethod cls nt) = "interface method " ++ toString cls ++ "." ++ show nt-  show (CString s) = "String \"" ++ toString s ++ "\""-  show (CInteger x) = show x-  show (CFloat x) = show x-  show (CLong x) = show x-  show (CDouble x) = show x-  show (CNameType name tp) = toString name ++ ": " ++ toString tp-  show (CUTF8 s) = "UTF8 \"" ++ toString s ++ "\""-  show (CUnicode s) = "Unicode \"" ++ toString s ++ "\""---- | Class field-data Field = Field {-  fieldAccess :: Access,-  fieldName :: B.ByteString,-  fieldSignature :: FieldSignature,-  fieldAttrs :: Attributes }-  deriving (Eq, Show)--instance HasSignature Field where-  type Signature Field = FieldSignature--instance HasAttributes Field where-  attributes = fieldAttrs---- | Class method-data Method = Method {-  methodAccess :: Access,-  methodName :: B.ByteString,-  methodSignature :: MethodSignature,-  methodAttrs :: Attributes }-  deriving (Eq, Show)--instance HasSignature Method where-  type Signature Method = MethodSignature--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 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)---- | 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)-
+ Java/IO.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}+module Java.IO where++import Data.String++import JVM.Common ()  -- import instances only+import JVM.ClassFile++import qualified Java.Lang++printStream :: IsString s => s+printStream = "java/io/PrintStream"++printStreamClass = ObjectType printStream++println :: NameType Method+println = NameType "println" $ MethodSignature [Java.Lang.stringClass] ReturnsVoid++out :: NameType Field+out = NameType "out" printStreamClass++printf :: NameType Method+printf =+  NameType "printf" $ MethodSignature [Java.Lang.stringClass,+                                       Array Nothing Java.Lang.objectClass] (Returns printStreamClass)+
+ Java/Lang.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE OverloadedStrings #-}+module Java.Lang where++import Data.String++import JVM.Common ()  -- import instances only+import JVM.ClassFile++objectClass = ObjectType object+stringClass = ObjectType string+integerClass = ObjectType integer+systemClass = ObjectType system++object :: IsString s => s+object = "java/lang/Object"++string :: IsString s => s+string = "java/lang/String"++integer :: IsString s => s+integer = "java/lang/Integer"++system :: IsString s => s+system = "java/lang/System"++objectInit :: NameType Method+objectInit = NameType "<init>" $ MethodSignature [] ReturnsVoid++valueOfInteger :: NameType Method+valueOfInteger = NameType "valueOf" $ MethodSignature [IntType] (Returns Java.Lang.integerClass)+
+ TestGen.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedStrings #-}++import qualified Data.ByteString.Lazy as B++import JVM.ClassFile+import JVM.Converter+import JVM.Assembler+import JVM.Builder++import qualified Java.Lang+import qualified Java.IO++test :: Generate ()+test = do+  newMethod [ACC_PUBLIC] "<init>" [] ReturnsVoid $ do+      aload_ I0+      invokeSpecial Java.Lang.object Java.Lang.objectInit+      i0 RETURN++  hello <- newMethod [ACC_PUBLIC, ACC_STATIC] "hello" [IntType] ReturnsVoid $ do+      getStaticField Java.Lang.system Java.IO.out+      loadString "Здравствуй, мир!"+      invokeVirtual Java.IO.printStream Java.IO.println+      getStaticField Java.Lang.system Java.IO.out+      loadString "Argument: %d\n"+      iconst_1+      allocArray Java.Lang.object+      dup+      iconst_0+      iload_ I0+      invokeStatic Java.Lang.integer Java.Lang.valueOfInteger+      aastore+      invokeVirtual Java.IO.printStream Java.IO.printf+      pop+      i0 RETURN++  newMethod [ACC_PUBLIC, ACC_STATIC] "main" [arrayOf Java.Lang.stringClass] ReturnsVoid $ do+      iconst_5+      invokeStatic "Test" hello+      i0 RETURN++  return ()++testClass ::  Class Resolved+testClass = generate "Test" test++main = do+  B.writeFile "Test.class" (encodeClass testClass)+
dump-class.hs view
@@ -1,37 +1,22 @@ {-# LANGUAGE OverloadedStrings #-} module Main where -import Control.Monad-import Data.Array+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.Common+import JVM.ClassFile import JVM.Converter-import JVM.Assembler+import JVM.Dump  main = do   args <- getArgs   case args of     [clspath] -> do+      clsFile <- decodeFile clspath+      putStrLn $ showListIx $ M.elems $ constsPool (clsFile :: Class Pointers)       cls <- parseClassFile clspath-      putStr "Class: "-      B.putStrLn (this cls)-      putStrLn "Constants pool:"-      forM_ (assocs $ constantPool cls) $ \(i, c) ->-        putStrLn $ printf "  #%d:\t%s" i (show c)-      putStrLn "Methods:"-      forM_ (methods cls) $ \m -> do-        putStr ">> Method "-        B.putStr (methodName m)-        print (methodSignature m)-        case attrByName m "Code" of-          Nothing -> putStrLn "(no code)\n"-          Just bytecode -> let code = decodeMethod bytecode-                           in  forM_ (codeInstructions code) $ \i -> do-                                 putStr "  "-                                 print i-+      dumpClass cls     _ -> error "Synopsis: dump-class File.class"
hs-java.cabal view
@@ -1,5 +1,5 @@ Name:           hs-java-Version:        0.1+Version:        0.2 Cabal-Version:  >= 1.6 License:        BSD3 License-File:   LICENSE@@ -9,21 +9,33 @@ Category:       Jvm Build-Type:     Simple Description:    This package declares data types for Java .class files format and functions-                to assemble/disassemble Java bytecode.+                to assemble/disassemble Java bytecode. See dump-class.hs, rebuild-class.hs,+                TestGen.hs for examples of usage.  Extra-source-files: dump-class.hs+                    rebuild-class.hs+                    TestGen.hs  library-  Exposed-Modules: JVM.Types+  Exposed-Modules: JVM.Common                    JVM.ClassFile                    JVM.Assembler                    JVM.Converter+                   JVM.Builder+                   JVM.Builder.Monad+                   JVM.Builder.Instructions+                   JVM.Dump+                   JVM.Exceptions+                   Java.Lang+                   Java.IO -  Build-Depends:  base >= 3 && <= 5, haskell98, containers, binary,+  Build-Depends:  base >= 3 && <= 5, containers, binary,                   mtl, directory, filepath, utf8-string, array,                   bytestring, data-binary-ieee754, binary-state,                   control-monad-exception    ghc-options: -fwarn-unused-imports -+Source-repository head+  type:     git+  location: git remote add origin git@gitorious.org:hs-java/hs-java.git
+ rebuild-class.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}++import Data.Binary+import System.Environment+import qualified Data.ByteString.Lazy as B+import qualified Data.Map as M++import JVM.Common+import JVM.ClassFile+import JVM.Converter+import JVM.Dump++main = do+  args <- getArgs+  case args of+    [clspath,outpath] -> do+      cls <- parseClassFile clspath+      clsfile <- decodeFile clspath :: IO (Class Pointers)+      dumpClass cls+      putStrLn $ "Source pool:\n" ++ showListIx (M.elems $ constsPool clsfile)+      let result = classFile cls+      putStrLn $ "Result pool:\n" ++ showListIx (M.elems $ constsPool result)+      B.writeFile outpath (encodeClass cls)++    _ -> error "Synopsis: rebuild-class File.class Output.class"