hs-java 0.2 → 0.3.1

raw patch · 23 files changed

+1329/−275 lines, 23 filesdep +Globdep +LibZipdep +MissingHPVP ok

version bump matches the API change (PVP)

Dependencies added: Glob, LibZip, MissingH, data-default, parsec

API changes (from Hackage documentation)

Files

• JVM/Assembler.hs +12/−8
• JVM/Builder/Instructions.hs +145/−2
• JVM/Builder/Monad.hs +213/−50
• JVM/ClassFile.hs +249/−111
• JVM/Common.hs +25/−10
• JVM/Converter.hs +76/−74
• JVM/Dump.hs +3/−2
• JVM/Exceptions.hs +33/−0
• Java/ClassPath.hs +100/−0
• Java/ClassPath/Common.hs +74/−0
• Java/ClassPath/Types.hs +35/−0
• Java/IO.hs +7/−3
• Java/JAR.hs +58/−0
• Java/JAR/Archive.hs +54/−0
• Java/Lang.hs +12/−2
• Java/META.hs +81/−0
• Java/META/Parser.hs +66/−0
• Java/META/Spec.hs +33/−0
• Java/META/Types.hs +8/−0
• TestGen.hs +26/−5
• dump-class.hs +1/−1
• hs-java.cabal +14/−3
• rebuild-class.hs +4/−4

@@ -54,7 +54,7 @@     codeExceptionsN :: Word16,     codeExceptions :: [CodeException],     codeAttrsN :: Word16,-    codeAttributes :: Attributes Pointers }+    codeAttributes :: Attributes File }   deriving (Eq, Show)  -- | Exception descriptor@@ -116,7 +116,7 @@           next <- readInstructions           return (x: next) --- | JVM instruction set+-- | JVM instruction set. For comments, see JVM specification. data Instruction =     NOP            -- ^ 0   | ACONST_NULL    -- ^ 1@@ -239,10 +239,10 @@   | LCMP                   -- ^ 148   | FCMP CMP               -- ^ 149, 150   | DCMP CMP               -- ^ 151, 152-  | IF CMP                 -- ^ 153, 154, 155, 156, 157, 158+  | IF CMP Word16          -- ^ 153, 154, 155, 156, 157, 158   | IF_ICMP CMP Word16     -- ^ 159, 160, 161, 162, 163, 164   | IF_ACMP CMP Word16     -- ^ 165, 166-  | GOTO                   -- ^ 167+  | GOTO Word16            -- ^ 167   | JSR Word16             -- ^ 168   | RET                    -- ^ 169   | TABLESWITCH Word32 Word32 Word32 [Word32]     -- ^ 170@@ -251,6 +251,7 @@   | LRETURN                -- ^ 173   | FRETURN                -- ^ 174   | DRETURN                -- ^ 175+  | ARETURN                -- ^ 176   | RETURN                 -- ^ 177   | GETSTATIC Word16       -- ^ 178   | PUTSTATIC Word16       -- ^ 179@@ -475,12 +476,12 @@   put (DCMP C_LT)     = putByte 151   put (DCMP C_GT)     = putByte 152   put (DCMP c)        = fail $ "No such instruction: DCMP " ++ show c-  put (IF c)          = putByte (fromIntegral $ 153 + fromEnum c)+  put (IF c x)        = putByte (fromIntegral $ 153 + fromEnum c) >> put x   put (IF_ACMP C_EQ x) = put1 165 x   put (IF_ACMP C_NE x) = put1 166 x   put (IF_ACMP c _)   = fail $ "No such instruction: IF_ACMP " ++ show c   put (IF_ICMP c x)   = putByte (fromIntegral $ 159 + fromEnum c) >> put x-  put  GOTO           = putByte 167+  put (GOTO x)        = put1 167 x   put (JSR x)         = put1 168 x   put  RET            = putByte 169   put (TABLESWITCH def low high offs) = do@@ -503,6 +504,7 @@   put  LRETURN        = putByte 173   put  FRETURN        = putByte 174   put  DRETURN        = putByte 175+  put  ARETURN        = putByte 176   put  RETURN         = putByte 177   put (GETSTATIC x)   = put1 178 x   put (PUTSTATIC x)   = put1 179 x@@ -646,7 +648,7 @@       152 -> return $ DCMP C_GT       165 -> IF_ACMP C_EQ <$> get       166 -> IF_ACMP C_NE <$> get-      167 -> return GOTO+      167 -> GOTO <$> get       168 -> JSR <$> get       169 -> return RET       170 -> do@@ -670,6 +672,7 @@       173 -> return LRETURN       174 -> return FRETURN       175 -> return DRETURN+      176 -> return ARETURN       177 -> return RETURN       178 -> GETSTATIC <$> get       179 -> PUTSTATIC <$> get@@ -704,10 +707,11 @@         | inRange (34, 37) c -> imm 34 FLOAD_ c         | inRange (38, 41) c -> imm 38 DLOAD_ c         | inRange (42, 45) c -> imm 42 ALOAD_ c-        | inRange (153, 158) c -> return $ IF (toEnum $ fromIntegral $ c-153)+        | inRange (153, 158) c -> IF (toEnum $ fromIntegral $ c-153) <$> get         | inRange (159, 164) c -> IF_ICMP (toEnum $ fromIntegral $ c-159) <$> get         | otherwise -> fail $ "Unknown instruction byte code: " ++ show c +-- | Encode list of instructions encodeInstructions :: [Instruction] -> B.ByteString encodeInstructions code =   let p list = forM_ list put

@@ -1,162 +1,305 @@-+-- | This module exports shortcuts for some of JVM instructions (which are defined in JVM.Assembler).+-- These functions get Constants, put them into constants pool and generate instruction using index+-- of constant in the pool. module JVM.Builder.Instructions where +import Data.Word+import qualified Data.ByteString.Lazy as B+import Codec.Binary.UTF8.String (encodeString)+import Data.String+ import JVM.ClassFile import JVM.Assembler import JVM.Builder.Monad +nop :: Generator e g => g e () nop = i0 NOP+aconst_null :: Generator e g => g e () aconst_null = i0 ACONST_NULL+iconst_m1 :: Generator e g => g e () iconst_m1 = i0 ICONST_M1+iconst_0 :: Generator e g => g e () iconst_0 = i0 ICONST_0+iconst_1 :: Generator e g => g e () iconst_1 = i0 ICONST_1+iconst_2 :: Generator e g => g e () iconst_2 = i0 ICONST_2+iconst_3 :: Generator e g => g e () iconst_3 = i0 ICONST_3+iconst_4 :: Generator e g => g e () iconst_4 = i0 ICONST_4+iconst_5 :: Generator e g => g e () iconst_5 = i0 ICONST_5+lconst_0 :: Generator e g => g e () lconst_0 = i0 LCONST_0+lconst_1 :: Generator e g => g e () lconst_1 = i0 LCONST_1+fconst_0 :: Generator e g => g e () fconst_0 = i0 FCONST_0+fconst_1 :: Generator e g => g e () fconst_1 = i0 FCONST_1+fconst_2 :: Generator e g => g e () fconst_2 = i0 FCONST_2+dconst_0 :: Generator e g => g e () dconst_0 = i0 DCONST_0+dconst_1 :: Generator e g => g e () dconst_1 = i0 DCONST_1 +bipush :: Generator e g => Word8 -> g e () bipush x = i0 (BIPUSH x)+sipush :: Generator e g => Word16 -> g e () sipush x = i0 (SIPUSH x)++ldc1 :: Generator e g => Constant Direct -> g e () ldc1 x = i8 LDC1 x+ldc2 :: Generator e g => Constant Direct -> g e () ldc2 x = i1 LDC2 x+ldc2w :: Generator e g => Constant Direct -> g e () ldc2w x = i1 LDC2W x+iload :: Generator e g => Constant Direct -> g e () iload x = i8 ILOAD x+lload :: Generator e g => Constant Direct -> g e () lload x = i8 LLOAD x+fload :: Generator e g => Constant Direct -> g e () fload x = i8 FLOAD x+dload :: Generator e g => Constant Direct -> g e () dload x = i8 DLOAD x+aload :: Generator e g => Constant Direct -> g e () aload x = i8 ALOAD x +iload_ :: Generator e g => IMM -> g e () iload_ x = i0 (ILOAD_ x)+lload_ :: Generator e g => IMM -> g e () lload_ x = i0 (LLOAD_ x)+fload_ :: Generator e g => IMM -> g e () fload_ x = i0 (FLOAD_ x)+dload_ :: Generator e g => IMM -> g e () dload_ x = i0 (DLOAD_ x)+aload_ :: Generator e g => IMM -> g e () aload_ x = i0 (ALOAD_ x) +iaload :: Generator e g => g e () iaload = i0 IALOAD+laload :: Generator e g => g e () laload = i0 LALOAD+faload :: Generator e g => g e () faload = i0 FALOAD+daload :: Generator e g => g e () daload = i0 DALOAD+aaload :: Generator e g => g e () aaload = i0 AALOAD+caload :: Generator e g => g e () caload = i0 CALOAD+saload :: Generator e g => g e () saload = i0 SALOAD +istore :: Generator e g => Constant Direct -> g e () istore x = i8 ISTORE x+lstore :: Generator e g => Constant Direct -> g e () lstore x = i8 LSTORE x+fstore :: Generator e g => Constant Direct -> g e () fstore x = i8 FSTORE x+dstore :: Generator e g => Constant Direct -> g e () dstore x = i8 DSTORE x+astore :: Generator e g => Constant Direct -> g e () astore x = i8 ASTORE x +istore_ :: Generator e g => Word8 -> g e () istore_ x = i0 (ISTORE x)+lstore_ :: Generator e g => Word8 -> g e () lstore_ x = i0 (LSTORE x)+fstore_ :: Generator e g => Word8 -> g e () fstore_ x = i0 (FSTORE x)+dstore_ :: Generator e g => Word8 -> g e () dstore_ x = i0 (DSTORE x)+astore_ :: Generator e g => Word8 -> g e () astore_ x = i0 (ASTORE x) +iastore :: Generator e g => g e () iastore = i0 IASTORE+lastore :: Generator e g => g e () lastore = i0 LASTORE+fastore :: Generator e g => g e () fastore = i0 FASTORE+dastore :: Generator e g => g e () dastore = i0 DASTORE+aastore :: Generator e g => g e () aastore = i0 AASTORE+bastore :: Generator e g => g e () bastore = i0 BASTORE+castore :: Generator e g => g e () castore = i0 CASTORE+sastore :: Generator e g => g e () sastore = i0 SASTORE +pop :: Generator e g => g e () pop     = i0 POP    +pop2 :: Generator e g => g e () pop2    = i0 POP2   +dup :: Generator e g => g e () dup     = i0 DUP    +dup_x1 :: Generator e g => g e () dup_x1  = i0 DUP_X1 +dup_x2 :: Generator e g => g e () dup_x2  = i0 DUP_X2 +dup2 :: Generator e g => g e () dup2    = i0 DUP2   +dup2_x1 :: Generator e g => g e () dup2_x1 = i0 DUP2_X1+dup2_x2 :: Generator e g => g e () dup2_x2 = i0 DUP2_X2+swap :: Generator e g => g e () swap    = i0 SWAP   +iadd :: Generator e g => g e () iadd    = i0 IADD   +ladd :: Generator e g => g e () ladd    = i0 LADD   +fadd :: Generator e g => g e () fadd    = i0 FADD   +dadd :: Generator e g => g e () dadd    = i0 DADD   +isub :: Generator e g => g e () isub    = i0 ISUB   +lsub :: Generator e g => g e () lsub    = i0 LSUB   +fsub :: Generator e g => g e () fsub    = i0 FSUB   +dsub :: Generator e g => g e () dsub    = i0 DSUB   +imul :: Generator e g => g e () imul    = i0 IMUL   +lmul :: Generator e g => g e () lmul    = i0 LMUL   +fmul :: Generator e g => g e () fmul    = i0 FMUL   +dmul :: Generator e g => g e () dmul    = i0 DMUL   +idiv :: Generator e g => g e () idiv    = i0 IDIV   +ldiv :: Generator e g => g e () ldiv    = i0 LDIV   +fdiv :: Generator e g => g e () fdiv    = i0 FDIV   +ddiv :: Generator e g => g e () ddiv    = i0 DDIV   +irem :: Generator e g => g e () irem    = i0 IREM   +lrem :: Generator e g => g e () lrem    = i0 LREM   +frem :: Generator e g => g e () frem    = i0 FREM   +drem :: Generator e g => g e () drem    = i0 DREM   +ineg :: Generator e g => g e () ineg    = i0 INEG   +lneg :: Generator e g => g e () lneg    = i0 LNEG   +fneg :: Generator e g => g e () fneg    = i0 FNEG   +dneg :: Generator e g => g e () dneg    = i0 DNEG   +ishl :: Generator e g => g e () ishl    = i0 ISHL   +lshl :: Generator e g => g e () lshl    = i0 LSHL   +ishr :: Generator e g => g e () ishr    = i0 ISHR   +lshr :: Generator e g => g e () lshr    = i0 LSHR   +iushr :: Generator e g => g e () iushr   = i0 IUSHR  +lushr :: Generator e g => g e () lushr   = i0 LUSHR  +iand :: Generator e g => g e () iand    = i0 IAND   +land :: Generator e g => g e () land    = i0 LAND   +ior :: Generator e g => g e () ior     = i0 IOR    +lor :: Generator e g => g e () lor     = i0 LOR    +ixor :: Generator e g => g e () ixor    = i0 IXOR   +lxor :: Generator e g => g e () lxor    = i0 LXOR    +iinc :: Generator e g => Word8 -> Word8 -> g e () iinc x y = i0 (IINC x y) +i2l :: Generator e g => g e () i2l  = i0 I2L +i2f :: Generator e g => g e () i2f  = i0 I2F +i2d :: Generator e g => g e () i2d  = i0 I2D +l2i :: Generator e g => g e () l2i  = i0 L2I +l2f :: Generator e g => g e () l2f  = i0 L2F +l2d :: Generator e g => g e () l2d  = i0 L2D +f2i :: Generator e g => g e () f2i  = i0 F2I +f2l :: Generator e g => g e () f2l  = i0 F2L +f2d :: Generator e g => g e () f2d  = i0 F2D +d2i :: Generator e g => g e () d2i  = i0 D2I +d2l :: Generator e g => g e () d2l  = i0 D2L +d2f :: Generator e g => g e () d2f  = i0 D2F +i2b :: Generator e g => g e () i2b  = i0 I2B +i2c :: Generator e g => g e () i2c  = i0 I2C +i2s :: Generator e g => g e () i2s  = i0 I2S +lcmp :: Generator e g => g e () lcmp = i0 LCMP +-- | Wide instruction+wide :: Generator e g => (Word8 -> Instruction) -> Constant Direct -> g e ()+wide fn c = do+  ix <- addToPool c+  let ix0 = fromIntegral (ix `div` 0x100) :: Word8+      ix1 = fromIntegral (ix `mod` 0x100) :: Word8+  i0 (WIDE ix0 $ fn ix1)++new :: Generator e g => B.ByteString -> g e () new cls =   i1 NEW (CClass cls) +newArray :: Generator e g => ArrayType -> g e () newArray t =   i0 (NEWARRAY $ atype2byte t) +allocNewArray :: Generator e g => B.ByteString -> g e () allocNewArray cls =   i1 ANEWARRAY (CClass cls) +invokeVirtual :: Generator e g => B.ByteString -> NameType (Method Direct) -> g e () invokeVirtual cls sig =   i1 INVOKEVIRTUAL (CMethod cls sig) +invokeStatic :: Generator e g => B.ByteString -> NameType (Method Direct) -> g e () invokeStatic cls sig =   i1 INVOKESTATIC (CMethod cls sig) +invokeSpecial :: Generator e g => B.ByteString -> NameType (Method Direct) -> g e () invokeSpecial cls sig =   i1 INVOKESPECIAL (CMethod cls sig) +getStaticField :: Generator e g => B.ByteString -> NameType (Field Direct) -> g e () getStaticField cls sig =   i1 GETSTATIC (CField cls sig) +loadString :: Generator e g => String -> g e () loadString str =-  i8 LDC1 (CString str)+  i8 LDC1 (CString $ fromString $ encodeString $ str) +allocArray :: Generator e g => B.ByteString -> g e () allocArray cls =   i1 ANEWARRAY (CClass cls) 

@@ -1,55 +1,141 @@-{-# LANGUAGE FlexibleContexts, TypeFamilies, OverloadedStrings #-}-module JVM.Builder.Monad where+{-# LANGUAGE FlexibleContexts, TypeFamilies, OverloadedStrings, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}+-- | This module defines Generate[IO] monad, which helps generating JVM code and+-- creating Java class constants pool.+--+-- Code generation could be done using one of two monads: Generate and GenerateIO.+-- Generate monad is pure (simply State monad), while GenerateIO is IO-related.+-- In GenerateIO additional actions are available, such as setting up ClassPath+-- and loading classes (from .class files or JAR archives).+--+module JVM.Builder.Monad+  (GState (..),+   emptyGState,+   Generator (..),+   Generate, GenerateIO,+   addToPool,+   i0, i1, i8,+   newMethod,+   setStackSize, setMaxLocals,+   withClassPath,+   getClassField, getClassMethod,+   generate, generateIO+  ) where +import Prelude hiding (catch) import Control.Monad.State as St+import Control.Monad.Exception+import Control.Monad.Exception.Base 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.Common import JVM.ClassFile import JVM.Assembler+import JVM.Exceptions+import Java.ClassPath +-- | Generator state data GState = GState {-  generated :: [Instruction],-  currentPool :: Pool Resolved,-  doneMethods :: [Method Resolved],-  currentMethod :: Maybe (Method Resolved)}+  generated :: [Instruction],             -- ^ Already generated code (in current method)+  currentPool :: Pool Direct,             -- ^ Already generated constants pool+  nextPoolIndex :: Word16,                -- ^ Next index to be used in constants pool+  doneMethods :: [Method Direct],         -- ^ Already generated class methods+  currentMethod :: Maybe (Method Direct), -- ^ Current method+  stackSize :: Word16,                    -- ^ Maximum stack size for current method+  locals :: Word16,                       -- ^ Maximum number of local variables for current method+  classPath :: [Tree CPEntry]+  }   deriving (Eq,Show) +-- | Empty generator state+emptyGState ::  GState emptyGState = GState {   generated = [],   currentPool = M.empty,+  nextPoolIndex = 1,   doneMethods = [],-  currentMethod = Nothing }+  currentMethod = Nothing,+  stackSize = 496,+  locals = 0,+  classPath = []} -type Generate a = State GState a+class (Monad (g e), MonadState GState (g e)) => Generator e g where+  throwG :: (Exception x, Throws x e) => x -> g e 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)+-- | Generate monad+newtype Generate e a = Generate {+  runGenerate :: EMT e (State GState) a }+  deriving (Monad, MonadState GState) -addItem :: Constant Resolved -> Generate Word16+instance MonadState st (EMT e (StateT st IO)) where+  get = lift St.get+  put x = lift (St.put x)++instance MonadState st (EMT e (State st)) where+  get = lift St.get+  put x = lift (St.put x)++-- | IO version of Generate monad+newtype GenerateIO e a = GenerateIO {+  runGenerateIO :: EMT e (StateT GState IO) a }+  deriving (Monad, MonadState GState, MonadIO)++instance MonadIO (EMT e (StateT GState IO)) where+  liftIO action = lift $ liftIO action++instance Generator e GenerateIO where+  throwG e = GenerateIO (throw e)++instance (MonadState GState (EMT e (State GState))) => Generator e Generate where+  throwG e = Generate (throw e)++execGenerateIO :: [Tree CPEntry]+               -> GenerateIO (Caught SomeException NoExceptions) a+               -> IO GState+execGenerateIO cp (GenerateIO emt) = do+    let caught = emt `catch` (\(e :: SomeException) -> fail $ show e)+    execStateT (runEMT caught) (emptyGState {classPath = cp})++execGenerate :: [Tree CPEntry]+             -> Generate (Caught SomeException NoExceptions) a+             -> GState+execGenerate cp (Generate emt) = do+    let caught = emt `catch` (\(e :: SomeException) -> fail $ show e)+    execState (runEMT caught) (emptyGState {classPath = cp})++-- | Update ClassPath+withClassPath :: ClassPath () -> GenerateIO e ()+withClassPath cp = do+  res <- liftIO $ execClassPath cp+  st <- St.get+  St.put $ st {classPath = res}++-- | Add a constant to pool+addItem :: (Generator e g) => Constant Direct -> g e Word16 addItem c = do   pool <- St.gets currentPool   case lookupPool c pool of-    Just i -> return (i+1)+    Just i -> return i     Nothing -> do-      let (pool', i) = appendPool c pool+      i <- St.gets nextPoolIndex+      let pool' = M.insert i c pool+          i' = if long c+                 then i+2+                 else i+1       st <- St.get-      St.put $ st {currentPool = pool'}-      return (i+1)+      St.put $ st {currentPool = pool',+                   nextPoolIndex = i'}+      return i -lookupPool :: Constant Resolved -> Pool Resolved -> Maybe Word16+-- | Lookup in a pool+lookupPool :: Constant Direct -> Pool Direct -> Maybe Word16 lookupPool c pool =-  fromIntegral `fmap` findIndex (== c) (M.elems pool)+  fromIntegral `fmap` mapFindIndex (== c) pool -addNT :: Binary (Signature a) => NameType a -> Generate Word16+addNT :: (Generator e g, HasSignature a) => NameType a -> g e Word16 addNT (NameType name sig) = do   let bsig = encode sig   x <- addItem (CNameType name bsig)@@ -57,12 +143,13 @@   addItem (CUTF8 bsig)   return x -addSig :: MethodSignature -> Generate Word16+addSig :: (Generator e g) => MethodSignature -> g e Word16 addSig c@(MethodSignature args ret) = do   let bsig = encode c   addItem (CUTF8 bsig) -addToPool :: Constant Resolved -> Generate Word16+-- | Add a constant into pool+addToPool :: (Generator e g) => Constant Direct -> g e Word16 addToPool c@(CClass str) = do   addItem (CUTF8 str)   addItem c@@ -87,29 +174,47 @@   addItem c addToPool c = addItem c -putInstruction :: Instruction -> Generate ()+putInstruction :: (Generator e g) => Instruction -> g e () putInstruction instr = do   st <- St.get   let code = generated st   St.put $ st {generated = code ++ [instr]} -i0 :: Instruction -> Generate ()+-- | Generate one (zero-arguments) instruction+i0 :: (Generator e g) => Instruction -> g e () i0 = putInstruction -i1 :: (Word16 -> Instruction) -> Constant Resolved -> Generate ()+-- | Generate one one-argument instruction+i1 :: (Generator e g) => (Word16 -> Instruction) -> Constant Direct -> g e () i1 fn c = do   ix <- addToPool c   i0 (fn ix) -i8 :: (Word8 -> Instruction) -> Constant Resolved -> Generate ()+-- | Generate one one-argument instruction+i8 :: (Generator e g) => (Word8 -> Instruction) -> Constant Direct -> g e () i8 fn c = do   ix <- addToPool c   i0 (fn $ fromIntegral ix) -startMethod :: [AccessFlag] -> B.ByteString -> MethodSignature -> Generate ()+-- | Set maximum stack size for current method+setStackSize :: (Generator e g) => Word16 -> g e ()+setStackSize n = do+  st <- St.get+  St.put $ st {stackSize = n}++-- | Set maximum number of local variables for current method+setMaxLocals :: (Generator e g) => Word16 -> g e ()+setMaxLocals n = do+  st <- St.get+  St.put $ st {locals = n}++-- | Start generating new method+startMethod :: (Generator e g) => [AccessFlag] -> B.ByteString -> MethodSignature -> g e () startMethod flags name sig = do   addToPool (CString name)   addSig sig+  setStackSize 4096+  setMaxLocals 100   st <- St.get   let method = Method {     methodAccessFlags = S.fromList flags,@@ -120,12 +225,13 @@   St.put $ st {generated = [],                currentMethod = Just method } -endMethod :: Generate ()+-- | End of method generation+endMethod :: (Generator e g, Throws UnexpectedEndMethod e) => g e () endMethod = do   m <- St.gets currentMethod   code <- St.gets genCode   case m of-    Nothing -> fail "endMethod without startMethod!"+    Nothing -> throwG UnexpectedEndMethod     Just method -> do       let method' = method {methodAttributes = AR $ M.fromList [("Code", encodeMethod code)],                             methodAttributesCount = 1}@@ -134,7 +240,14 @@                    currentMethod = Nothing,                    doneMethods = doneMethods st ++ [method']} -newMethod :: [AccessFlag] -> B.ByteString -> [ArgumentSignature] -> ReturnSignature -> Generate () -> Generate (NameType Method)+-- | Generate new method+newMethod :: (Generator e g, Throws UnexpectedEndMethod e)+          => [AccessFlag]        -- ^ Access flags for method (public, static etc)+          -> B.ByteString        -- ^ Method name+          -> [ArgumentSignature] -- ^ Signatures of method arguments+          -> ReturnSignature     -- ^ Method return signature+          -> g e ()                -- ^ Generator for method code+          -> g e (NameType (Method Direct)) newMethod flags name args ret gen = do   let sig = MethodSignature args ret   startMethod flags name sig@@ -142,10 +255,42 @@   endMethod   return (NameType name sig) +-- | Get a class from current ClassPath+getClass :: (Throws ENotLoaded e, Throws ENotFound e)+         => String -> GenerateIO e (Class Direct)+getClass name = do+  cp <- St.gets classPath+  res <- liftIO $ getEntry cp name+  case res of+    Just (NotLoaded p) -> throwG (ClassFileNotLoaded p)+    Just (Loaded _ c) -> return c+    Just (NotLoadedJAR p c) -> throwG (JARNotLoaded p c)+    Just (LoadedJAR _ c) -> return c+    Nothing -> throwG (ClassNotFound name)++-- | Get class field signature from current ClassPath+getClassField :: (Throws ENotFound e, Throws ENotLoaded e)+              => String -> B.ByteString -> GenerateIO e (NameType (Field Direct))+getClassField clsName fldName = do+  cls <- getClass clsName+  case lookupField fldName cls of+    Just fld -> return (fieldNameType fld)+    Nothing  -> throwG (FieldNotFound clsName fldName)++-- | Get class method signature from current ClassPath+getClassMethod :: (Throws ENotFound e, Throws ENotLoaded e)+               => String -> B.ByteString -> GenerateIO e (NameType (Method Direct))+getClassMethod clsName mName = do+  cls <- getClass clsName+  case lookupMethod mName cls of+    Just m -> return (methodNameType m)+    Nothing  -> throwG (MethodNotFound clsName mName)++-- | Convert Generator state to method Code. genCode :: GState -> Code genCode st = Code {-    codeStackSize = 4096,-    codeMaxLocals = 100,+    codeStackSize = stackSize st,+    codeMaxLocals = locals st,     codeLength = len,     codeInstructions = generated st,     codeExceptionsN = 0,@@ -155,34 +300,52 @@   where     len = fromIntegral $ B.length $ encodeInstructions (generated st) -initClass :: B.ByteString -> Generate Word16+-- | Start class generation.+initClass :: (Generator e g) => B.ByteString -> g e Word16 initClass name = do   addToPool (CClass "java/lang/Object")   addToPool (CClass name)   addToPool (CString "Code") -generate :: B.ByteString -> Generate () -> Class Resolved-generate name gen =+-- | Generate a class+generateIO :: [Tree CPEntry]+           -> B.ByteString+           -> GenerateIO (Caught SomeException NoExceptions) ()+           -> IO (Class Direct)+generateIO cp name gen = do   let generator = do         initClass name         gen-      res = execState generator emptyGState+  res <- execGenerateIO cp generator+  let code = genCode res+      d = defaultClass :: Class Direct+  return $ d {+        constsPoolSize = fromIntegral $ M.size (currentPool res),+        constsPool = currentPool res,+        accessFlags = S.fromList [ACC_PUBLIC, ACC_STATIC],+        thisClass = name,+        superClass = "java/lang/Object",+        classMethodsCount = fromIntegral $ length (doneMethods res),+        classMethods = doneMethods res }++-- | Generate a class+generate :: [Tree CPEntry]+         -> B.ByteString+         -> Generate (Caught SomeException NoExceptions) ()+         -> Class Direct+generate cp name gen =+  let generator = do+        initClass name+        gen+      res = execGenerate cp generator       code = genCode res-  in  Class {-        magic = 0xCAFEBABE,-        minorVersion = 0,-        majorVersion = 50,+      d = defaultClass :: Class Direct+  in  d {         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 }+        classMethods = doneMethods res } 

@@ -2,36 +2,69 @@ -- | This module declares (low-level) data types for Java .class files -- structures, and Binary instances to read/write them. module JVM.ClassFile-  (Attribute (..),+  (-- * About+   -- $about+   --+   --+   -- * Internal class file structures+   Attribute (..),    FieldType (..),+   -- * Signatures    FieldSignature, MethodSignature (..), ReturnSignature (..),    ArgumentSignature (..),+   -- * Stage types+   File, Direct,+   -- * Staged structures    Pool, Link,    Method (..), Field (..), Class (..),    Constant (..),-   Pointers, Resolved,-   NameType (..),-   HasSignature (..), HasAttributes (..),    AccessFlag (..), AccessFlags,    Attributes (..),+   defaultClass,+   -- * Misc+   HasSignature (..), HasAttributes (..),+   NameType (..),+   fieldNameType, methodNameType,+   lookupField, lookupMethod,+   long,+   toString,    className,    apsize, arsize, arlist   )   where  import Control.Monad+import Control.Monad.Trans (lift) import Control.Applicative+import qualified Control.Monad.State as St import Data.Binary import Data.Binary.IEEE754 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 import Codec.Binary.UTF8.String hiding (encode, decode) +-- $about+--+-- Java .class file uses constants pool, which stores almost all source-code-level+-- constants (strings, integer literals etc), and also all identifiers (class,+-- method, field names etc). All other structures contain indexes of constants in+-- the pool instead of constants theirself.+--+-- It's not convient to use that indexes programmatically. So, .class file is represented+-- at two stages: File and Direct. At File stage, all data structures contain only indexes,+-- not constants theirself. When we read a class from a file, we get structure at File stage.+-- We only can write File stage structure to file.+--+-- At Direct stage, structures conain constants, not indexes. Convertion functions (File <-> Direct)+-- are located in the JVM.Converter module.+--+ -- | Read one-byte Char getChar8 :: Get Char getChar8 = do@@ -41,36 +74,57 @@ toString :: B.ByteString -> String toString bstr = decodeString $ map (chr . fromIntegral) $ B.unpack bstr -type family Link s a+-- | File stage+data File = File -data Pointers = Pointers+-- | Direct representation stage+data Direct = Direct -data Resolved = Resolved+-- | Link to some object+type family Link stage a -type instance Link Pointers a = Word16+-- | At File stage, Link contain index of object in the constants pool.+type instance Link File a = Word16 -type instance Link Resolved a = a+-- | At Direct stage, Link contain object itself.+type instance Link Direct a = a +-- | Object (class, method, field …) access flags  type family AccessFlags stage -type instance AccessFlags Pointers = Word16+-- | At File stage, access flags are represented as Word16+type instance AccessFlags File = Word16 -type instance AccessFlags Resolved = S.Set AccessFlag+-- | At Direct stage, access flags are represented as set of flags.+type instance AccessFlags Direct = S.Set AccessFlag +-- | Object (class, method, field) attributes data family Attributes stage -data instance Attributes Pointers = AP {attributesList :: [Attribute]}+-- | At File stage, attributes are represented as list of Attribute structures.+data instance Attributes File = AP {attributesList :: [Attribute]}   deriving (Eq, Show)-data instance Attributes Resolved = AR (M.Map B.ByteString B.ByteString)++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) -arsize :: Attributes Resolved -> Int+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 -arlist :: Attributes Resolved -> [(B.ByteString, B.ByteString)]+-- | Associative list of attributes at Direct stage+arlist :: Attributes Direct -> [(B.ByteString, B.ByteString)] arlist (AR m) = M.assocs m -apsize :: Attributes Pointers -> Int+-- | Size of attributes set at File stage+apsize :: Attributes File -> Int apsize (AP list) = length list  -- | Access flags. Used for classess, methods, variables.@@ -88,26 +142,28 @@   | ACC_ABSTRACT 	   -- ^ 0x0400    deriving (Eq, Show, Ord, Enum) -class HasSignature a where+-- | Fields and methods have signatures.+class (Binary (Signature a), Show (Signature a), Eq (Signature a))+    => HasSignature a where   type Signature a -instance HasSignature Field where-  type Signature Field = FieldSignature+instance HasSignature (Field Direct) where+  type Signature (Field Direct) = FieldSignature -instance HasSignature Method where-  type Signature Method = MethodSignature+instance HasSignature (Method Direct) where+  type Signature (Method Direct) = 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+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@@ -115,23 +171,24 @@ -- | 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 stage)))+  | CMethod (Link stage B.ByteString) (Link stage (NameType (Method stage)))+  | CIfaceMethod (Link stage B.ByteString) (Link stage (NameType (Method stage)))   | CString (Link stage B.ByteString)   | CInteger Word32   | CFloat Float-  | CLong Integer+  | CLong Word64   | CDouble Double   | CNameType (Link stage B.ByteString) (Link stage B.ByteString)   | CUTF8 {getString :: B.ByteString}   | CUnicode {getString :: B.ByteString} -className ::  Constant Resolved -> B.ByteString+-- | Name of the CClass. Error on any other constant.+className ::  Constant Direct -> B.ByteString className (CClass s) = s className x = error $ "Not a class: " ++ show x -instance Show (Constant Resolved) where+instance Show (Constant Direct) 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@@ -150,35 +207,60 @@  -- | Generic .class file format data Class stage = Class {-  magic :: Word32,                   -- ^ Magic value: 0xCAFEBABE+  magic :: Word32,                         -- ^ Magic value: 0xCAFEBABE   minorVersion :: Word16,   majorVersion :: Word16,-  constsPoolSize :: Word16,          -- ^ Number of items in constants pool-  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 :: [Link stage B.ByteString],            -- ^ Constants pool item indexes for implemented interfaces-  classFieldsCount :: Word16,        -- ^ Number of class fileds-  classFields :: [Field stage],        -- ^ Class fields-  classMethodsCount :: Word16,       -- ^ Number of class methods-  classMethods :: [Method stage],      -- ^ Class methods-  classAttributesCount :: Word16,    -- ^ Number of class attributes-  classAttributes :: Attributes stage -- ^ Class attributes+  constsPoolSize :: Word16,                -- ^ Number of items in constants pool+  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 :: [Link stage B.ByteString], -- ^ Constants pool item indexes for implemented interfaces+  classFieldsCount :: Word16,              -- ^ Number of class fileds+  classFields :: [Field stage],            -- ^ Class fields+  classMethodsCount :: Word16,             -- ^ Number of class methods+  classMethods :: [Method stage],          -- ^ Class methods+  classAttributesCount :: Word16,          -- ^ Number of class attributes+  classAttributes :: Attributes stage      -- ^ Class attributes   } -deriving instance Eq (Constant Pointers)-deriving instance Eq (Constant Resolved)-deriving instance Show (Constant Pointers)+deriving instance Eq (Class File)+deriving instance Eq (Class Direct)+deriving instance Show (Class File)+deriving instance Show (Class Direct) -instance Binary (Class Pointers) where+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     put minorVersion     put majorVersion-    put constsPoolSize-    forM_ (M.elems constsPool) put+    putPool constsPool     put accessFlags     put thisClass     put superClass@@ -193,23 +275,26 @@    get = do     magic <- get+    when (magic /= 0xCAFEBABE) $+      fail $ "Invalid .class file MAGIC value: " ++ show magic     minor <- get     major <- get-    poolsize <- get-    pool <- replicateM (fromIntegral poolsize - 1) get-    af <- get+    when (major > 50) $+      fail $ "Too new .class file format: " ++ show major+    poolsize <- getWord16be+    pool <- getPool (poolsize - 1)+    af <-  get     this <- get     super <- get     interfacesCount <- get     ifaces <- replicateM (fromIntegral interfacesCount) get-    classFieldsCount <- get+    classFieldsCount <- getWord16be     classFields <- replicateM (fromIntegral classFieldsCount) get     classMethodsCount <- get     classMethods <- replicateM (fromIntegral classMethodsCount) get     asCount <- get     as <- replicateM (fromIntegral $ asCount) get-    let pool' = M.fromList $ zip [1..] pool-    return $ Class magic minor major poolsize pool' af this super+    return $ Class magic minor major poolsize pool af this super                interfacesCount ifaces classFieldsCount classFields                classMethodsCount classMethods asCount (AP as) @@ -376,50 +461,81 @@               return (x: next)     Nothing -> return [] -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+long :: Constant stage -> Bool+long (CLong _)   = True+long (CDouble _) = True+long _           = False -  get = do-    !offset <- bytesRead-    tag <- getWord8-    case tag of-      1 -> do-        l <- get-        bs <- getLazyByteString (fromIntegral (l :: Word16))-        return $ CUTF8 bs-      2 -> do-        l <- 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+putPool :: Pool File -> Put+putPool pool = do+    let list = M.elems pool+        d = length $ filter long list+    putWord16be $ fromIntegral (M.size pool + d + 1)+    forM_ list putC+  where+    putC (CClass i) = putWord8 7 >> put i+    putC (CField i j) = putWord8 9 >> put i >> put j+    putC (CMethod i j) = putWord8 10 >> put i >> put j+    putC (CIfaceMethod i j) = putWord8 11 >> put i >> put j+    putC (CString i) = putWord8 8 >> put i+    putC (CInteger x) = putWord8 3 >> put x+    putC (CFloat x)   = putWord8 4 >> putFloat32be x+    putC (CLong x)    = putWord8 5 >> put x+    putC (CDouble x)  = putWord8 6 >> putFloat64be x+    putC (CNameType i j) = putWord8 12 >> put i >> put j+    putC (CUTF8 bs) = do+                     putWord8 1+                     put (fromIntegral (B.length bs) :: Word16)+                     putLazyByteString bs+    putC (CUnicode bs) = do+                     putWord8 2+                     put (fromIntegral (B.length bs) :: Word16)+                     putLazyByteString bs +getPool :: Word16 -> Get (Pool File)+getPool n = do+    items <- St.evalStateT go 1+    return $ M.fromList items+  where+    go :: St.StateT Word16 Get [(Word16, Constant File)]+    go = do+      i <- St.get+      if i > n+        then return []+        else do+          c <- lift getC+          let i' = if long c+                      then i+2+                      else i+1+          St.put i'+          next <- go+          return $ (i,c): next++    getC = do+      !offset <- bytesRead+      tag <- getWord8+      case tag of+        1 -> do+          l <- get+          bs <- getLazyByteString (fromIntegral (l :: Word16))+          return $ CUTF8 bs+        2 -> do+          l <- 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+--         _ -> return $ CInteger 0+ -- | Class field format data Field stage = Field {   fieldAccessFlags :: AccessFlags stage,@@ -428,12 +544,23 @@   fieldAttributesCount :: Word16,   fieldAttributes :: Attributes stage } -deriving instance Eq (Field Pointers)-deriving instance Eq (Field Resolved)-deriving instance Show (Field Pointers)-deriving instance Show (Field Resolved)+deriving instance Eq (Field File)+deriving instance Eq (Field Direct)+deriving instance Show (Field File)+deriving instance Show (Field Direct) -instance Binary (Field Pointers) where+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 Direct)+fieldNameType f = NameType (fieldName f) (fieldSignature f)++instance Binary (Field File) where   put (Field {..}) = do     put fieldAccessFlags      put fieldName@@ -443,9 +570,9 @@    get = do     af <- get-    ni <- get+    ni <- getWord16be     si <- get-    n <- get+    n <- getWord16be     as <- replicateM (fromIntegral n) get     return $ Field af ni si n (AP as) @@ -457,12 +584,23 @@   methodAttributesCount :: Word16,   methodAttributes :: Attributes stage } -deriving instance Eq (Method Pointers)-deriving instance Eq (Method Resolved)-deriving instance Show (Method Pointers)-deriving instance Show (Method Resolved)+deriving instance Eq (Method File)+deriving instance Eq (Method Direct)+deriving instance Show (Method File)+deriving instance Show (Method Direct) -instance Binary (Method Pointers) where+methodNameType :: Method Direct -> NameType (Method Direct)+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     put methodName@@ -500,7 +638,7 @@    get = do     offset <- bytesRead-    name <- get+    name <- getWord16be     len <- getWord32be     value <- getLazyByteString (fromIntegral len)     return $ Attribute name len value

@@ -1,20 +1,29 @@ {-# LANGUAGE TypeFamilies, StandaloneDeriving, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}--- | This module declares `high-level' data types for Java classes, methods etc.-module JVM.Common where+-- | This module declares some commonly used functions and instances.+module JVM.Common+  (toCharList,+  poolSize,+  (!),+  showListIx,+  mapFindIndex,+  byteString+  ) 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 Data.Default+import Data.List  import JVM.ClassFile -instance IsString B.ByteString where-  fromString s = B.pack $ map (fromIntegral . ord) $ encodeString s+instance Default B.ByteString where+  def = B.empty +instance Default Word16 where+  def = 0+ toCharList :: B.ByteString -> [Int] toCharList bstr = map fromIntegral $ B.unpack bstr @@ -24,10 +33,16 @@ (!) :: (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+showListIx :: (Show i, Show a) => [(i,a)] -> String+showListIx list = unlines $ map s list+  where s (i, x) = show i ++ ":\t" ++ show x  byteString ::  (Binary t) => t -> B.ByteString byteString x = runPut (put x)++mapFindIndex :: (Num k) => (v -> Bool) -> M.Map k v -> Maybe k+mapFindIndex check m =+  case find (check . snd) (M.assocs m) of+    Nothing -> Nothing+    Just (k,_) -> Just k 

@@ -3,7 +3,7 @@ -- high-level Java classes, methods etc representation module JVM.Converter   (parseClass, parseClassFile,-   convertClass, classFile,+   classFile2Direct, classDirect2File,    encodeClass,    methodByName,    attrByName,@@ -16,7 +16,9 @@ import Data.Word import Data.Bits import Data.Binary+import Data.Default () -- import instances only import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString.Lazy.Char8 () import qualified Data.Set as S import qualified Data.Map as M @@ -25,67 +27,64 @@ import JVM.Exceptions  -- | Parse .class file data-parseClass :: B.ByteString -> Class Resolved-parseClass bstr = convertClass $ decode bstr+parseClass :: B.ByteString -> Class Direct+parseClass bstr = classFile2Direct $ decode bstr  -- | Parse class data from file-parseClassFile :: FilePath -> IO (Class Resolved)-parseClassFile path = convertClass `fmap` decodeFile path+parseClassFile :: FilePath -> IO (Class Direct)+parseClassFile path = classFile2Direct `fmap` decodeFile path -encodeClass :: (Class Resolved) -> B.ByteString-encodeClass cls = encode $ classFile cls+encodeClass :: (Class Direct) -> B.ByteString+encodeClass cls = encode $ classDirect2File cls -convertClass :: Class Pointers -> Class Resolved-convertClass (Class {..}) =-  let pool = constantPoolArray constsPool+classFile2Direct :: Class File -> Class Direct+classFile2Direct (Class {..}) =+  let pool = poolFile2Direct constsPool       superName = className $ pool ! superClass-  in Class {-      magic = 0xCAFEBABE,-      minorVersion = 0,-      majorVersion = 50,+      d = defaultClass :: Class Direct+  in d {       constsPoolSize = fromIntegral (M.size pool),       constsPool = pool,-      accessFlags = convertAccess accessFlags,+      accessFlags = accessFile2Direct 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,+      classFields = map (fieldFile2Direct pool) classFields,       classMethodsCount = classMethodsCount,-      classMethods = map (convertMethod pool) classMethods,+      classMethods = map (methodFile2Direct pool) classMethods,       classAttributesCount = classAttributesCount,-      classAttributes = convertAttrs pool classAttributes }+      classAttributes = attributesFile2Direct pool classAttributes } -classFile :: Class Resolved -> Class Pointers-classFile (Class {..}) = Class {-    magic = 0xCAFEBABE,-    minorVersion = 0,-    majorVersion = 50,+classDirect2File :: Class Direct -> Class File+classDirect2File (Class {..}) =+  let d = defaultClass :: Class File+  in d {     constsPoolSize = fromIntegral (M.size poolInfo + 1),     constsPool = poolInfo,-    accessFlags = access2word16 accessFlags,+    accessFlags = accessDirect2File 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,+    classFields = map (fieldDirect2File poolInfo) classFields,     classMethodsCount = fromIntegral (length classMethods),-    classMethods = map (methodInfo poolInfo) classMethods,+    classMethods = map (methodDirect2File poolInfo) classMethods,     classAttributesCount = fromIntegral $ arsize classAttributes,     classAttributes = to (arlist classAttributes) }   where-    poolInfo = toCPInfo constsPool-    to :: [(B.ByteString, B.ByteString)] -> Attributes Pointers+    poolInfo = poolDirect2File constsPool+    to :: [(B.ByteString, B.ByteString)] -> Attributes File     to pairs = AP (map (attrInfo poolInfo) pairs) -toCPInfo :: Pool Resolved -> Pool Pointers-toCPInfo pool = result+poolDirect2File :: Pool Direct -> Pool File+poolDirect2File pool = result   where     result = M.map cpInfo pool -    cpInfo :: Constant Resolved -> Constant Pointers+    cpInfo :: Constant Direct -> Constant File     cpInfo (CClass name) = CClass (force "class" $ poolIndex result name)     cpInfo (CField cls name) =       CField (force "field a" $ poolClassIndex result cls) (force "field b" $ poolNTIndex result name)@@ -104,22 +103,22 @@     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 (M.elems list) of+poolIndex :: (Throws NoItemInPool e) => Pool File -> B.ByteString -> EM e Word16+poolIndex list name = case mapFindIndex test list of                         Nothing -> throw (NoItemInPool name)-                        Just i ->  return $ fromIntegral $ i+1+                        Just i ->  return $ fromIntegral i   where     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) => Pool Pointers -> B.ByteString -> EM e Word16-poolClassIndex list name = case findIndex checkString (M.elems list) of+poolClassIndex :: (Throws NoItemInPool e) => Pool File -> B.ByteString -> EM e Word16+poolClassIndex list name = case mapFindIndex checkString list of                         Nothing -> throw (NoItemInPool name)-                        Just i ->  case findIndex (checkClass $ fromIntegral $ i+1) (M.elems list) of-                                     Nothing -> throw (NoItemInPool $ i+1)-                                     Just j  -> return $ fromIntegral $ j+1+                        Just i ->  case mapFindIndex (checkClass $ fromIntegral i) list of+                                     Nothing -> throw (NoItemInPool i)+                                     Just j  -> return $ fromIntegral j   where     checkString (CUTF8 s)    | s == name = True     checkString (CUnicode s) | s == name = True@@ -131,56 +130,59 @@ poolNTIndex list x@(NameType n t) = do     ni <- poolIndex list n     ti <- poolIndex list (byteString t)-    case findIndex (check ni ti) (M.elems list) of+    case mapFindIndex (check ni ti) list of       Nothing -> throw (NoItemInPool x)-      Just i  -> return $ fromIntegral (i+1)+      Just i  -> return $ fromIntegral i   where     check ni ti (CNameType n' t')       | (ni == n') && (ti == t') = True     check _ _ _                  = False -fieldInfo :: Pool Pointers -> Field Resolved -> Field Pointers-fieldInfo pool (Field {..}) = Field {-    fieldAccessFlags = access2word16 fieldAccessFlags,+fieldDirect2File :: Pool File -> Field Direct -> Field File+fieldDirect2File pool (Field {..}) = Field {+    fieldAccessFlags = accessDirect2File 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 :: [(B.ByteString, B.ByteString)] -> Attributes File     to pairs = AP (map (attrInfo pool) pairs) -methodInfo :: Pool Pointers -> Method Resolved -> Method Pointers-methodInfo pool (Method {..}) = Method {-    methodAccessFlags = access2word16 methodAccessFlags,+methodDirect2File :: Pool File -> Method Direct -> Method File+methodDirect2File pool (Method {..}) = Method {+    methodAccessFlags = accessDirect2File 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 :: [(B.ByteString, B.ByteString)] -> Attributes File     to pairs = AP (map (attrInfo pool) pairs) -attrInfo :: Pool Pointers -> (B.ByteString, B.ByteString) -> Attribute+attrInfo :: Pool File -> (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 :: Pool Pointers -> Pool Resolved-constantPoolArray ps = pool+poolFile2Direct :: Pool File -> Pool Direct+poolFile2Direct ps = pool   where-    pool :: Pool Resolved+    pool :: Pool Direct     pool = M.map convert ps      n = fromIntegral $ M.size ps -    convertNameType :: (HasSignature a, Binary (Signature a)) => Word16 -> NameType a+    convertNameType :: (HasSignature a) => Word16 -> NameType a     convertNameType i =-      let (CNameType n s) = pool ! i-      in  NameType n (decode s)+      case pool ! i of+        CNameType n s -> NameType n (decode s)+        x -> error $ "Unexpected: " ++ show i -    convert (CClass i) = CClass $ getString $ pool ! i+    convert (CClass i) = case pool ! i of+                          CUTF8 name -> CClass name+                          x -> error $ "Unexpected class name: " ++ show x ++ " at " ++ show 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)@@ -193,8 +195,8 @@     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..] $ [+accessFile2Direct :: AccessFlags File -> AccessFlags Direct+accessFile2Direct w = S.fromList $ concat $ zipWith (\i f -> if testBit w i then [f] else []) [0..] $ [    ACC_PUBLIC,    ACC_PRIVATE,    ACC_PROTECTED,@@ -207,48 +209,48 @@    ACC_INTERFACE,    ACC_ABSTRACT ] -access2word16 :: AccessFlags Resolved -> AccessFlags Pointers-access2word16 fs = bitsOr $ map toBit $ S.toList fs+accessDirect2File :: AccessFlags Direct -> AccessFlags File+accessDirect2File fs = bitsOr $ map toBit $ S.toList fs   where     bitsOr = foldl (.|.) 0     toBit f = 1 `shiftL` (fromIntegral $ fromEnum f) -convertField :: Pool Resolved -> Field Pointers -> Field Resolved-convertField pool (Field {..}) = Field {-  fieldAccessFlags = convertAccess fieldAccessFlags,+fieldFile2Direct :: Pool Direct -> Field File -> Field Direct+fieldFile2Direct pool (Field {..}) = Field {+  fieldAccessFlags = accessFile2Direct fieldAccessFlags,   fieldName = getString $ pool ! fieldName,   fieldSignature = decode $ getString $ pool ! fieldSignature,   fieldAttributesCount = fromIntegral (apsize fieldAttributes),-  fieldAttributes = convertAttrs pool fieldAttributes }+  fieldAttributes = attributesFile2Direct pool fieldAttributes } -convertMethod :: Pool Resolved -> Method Pointers -> Method Resolved-convertMethod pool (Method {..}) = Method {-  methodAccessFlags = convertAccess methodAccessFlags,+methodFile2Direct :: Pool Direct -> Method File -> Method Direct+methodFile2Direct pool (Method {..}) = Method {+  methodAccessFlags = accessFile2Direct methodAccessFlags,   methodName = getString $ pool ! methodName,   methodSignature = decode $ getString $ pool ! methodSignature,   methodAttributesCount = fromIntegral (apsize methodAttributes),-  methodAttributes = convertAttrs pool methodAttributes }+  methodAttributes = attributesFile2Direct pool methodAttributes } -convertAttrs :: Pool Resolved -> Attributes Pointers -> Attributes Resolved-convertAttrs pool (AP attrs) = AR (M.fromList $ map go attrs)+attributesFile2Direct :: Pool Direct -> Attributes File -> Attributes Direct+attributesFile2Direct pool (AP attrs) = AR (M.fromList $ map go attrs)   where     go :: Attribute -> (B.ByteString, B.ByteString)     go (Attribute {..}) = (getString $ pool ! attributeName,                            attributeValue)  -- | Try to get class method by name-methodByName :: Class Resolved -> B.ByteString -> Maybe (Method Resolved)+methodByName :: Class Direct -> B.ByteString -> Maybe (Method Direct) methodByName cls name =   find (\m -> methodName m == name) (classMethods cls)  -- | Try to get object attribute by name-attrByName :: (HasAttributes a) => a Resolved -> B.ByteString -> Maybe B.ByteString+attrByName :: (HasAttributes a) => a Direct -> 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 Resolved+methodCode :: Class Direct            -> B.ByteString       -- ^ Method name            -> Maybe B.ByteString methodCode cls name = do

@@ -3,7 +3,7 @@  import Control.Monad import qualified Data.Map as M-import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString.Lazy.Char8 as B import Text.Printf  import JVM.Common ()@@ -11,7 +11,8 @@ import JVM.Converter import JVM.Assembler -dumpClass :: Class Resolved -> IO ()+-- | Dump a class to console.+dumpClass :: Class Direct -> IO () dumpClass cls = do     putStr "Class: "     B.putStrLn (thisClass cls)

@@ -2,7 +2,10 @@ module JVM.Exceptions where  import Control.Monad.Exception+import qualified Data.ByteString.Lazy as B +import JVM.ClassFile+ data NoItemInPool = forall a. Show a => NoItemInPool a   deriving (Typeable) @@ -10,6 +13,36 @@  instance Show NoItemInPool where   show (NoItemInPool s) = "Internal error: no such item in pool: <" ++ show s ++ ">"++data UnexpectedEndMethod = UnexpectedEndMethod+  deriving (Typeable)++instance Show UnexpectedEndMethod where+  show UnexpectedEndMethod = "endMethod without startMethod!"++instance Exception UnexpectedEndMethod++data ENotLoaded = ClassFileNotLoaded FilePath+                | JARNotLoaded FilePath String+  deriving (Typeable)++instance Show ENotLoaded where+  show (ClassFileNotLoaded p) = "Class file was not loaded: " ++ p+  show (JARNotLoaded p c) = "Class was not loaded from JAR: " ++ p ++ ": " ++ c++instance Exception ENotLoaded++data ENotFound = ClassNotFound String+               | FieldNotFound String B.ByteString+               | MethodNotFound String B.ByteString+  deriving (Typeable)++instance Show ENotFound where+  show (ClassNotFound p) = "No such class in ClassPath: " ++ p+  show (FieldNotFound c f) = "No such field in class " ++ c ++ ": " ++ toString f+  show (MethodNotFound c m) = "No such method in class " ++ c ++ ": " ++ toString m++instance Exception ENotFound  force :: String -> EM AnyException a -> a force s x =

@@ -0,0 +1,100 @@++module Java.ClassPath+  (module Java.ClassPath.Types,+   module Java.ClassPath.Common,+   appendPath, addDirectory, loadClass,+   runClassPath, execClassPath,+   getEntry+  ) where++import qualified Control.Monad.State as St+import Control.Monad.Trans (liftIO)+import System.FilePath.Glob hiding (glob)+import Data.String.Utils (split)++import JVM.ClassFile+import JVM.Converter+import Java.ClassPath.Types+import Java.ClassPath.Common+import Java.JAR.Archive++-- | For given list of glob masks, return list of matching files+glob :: FilePath -> [FilePath] -> IO [FilePath]+glob dir patterns = do+  (matches, _) <- globDir (map compile patterns) dir+  return $ concat matches++-- | Append one file to ClassPath forest+appendPath :: FilePath -> [Tree CPEntry] -> [Tree CPEntry]+appendPath path forest = merge $ forest ++ (mapF NotLoaded $ buildTree [path])++-- | Add one directory to current ClassPath+addDirectory :: FilePath -> ClassPath ()+addDirectory dir = do+  files <- liftIO $ glob dir ["*.class"]+  cp <- St.get+  let cp' = foldr appendPath cp files+  St.put cp'++-- | Run ClassPath monad+runClassPath :: ClassPath a -> IO a+runClassPath m = St.evalStateT m []++-- | Run ClassPath monad and return resulting ClassPath+execClassPath :: ClassPath () -> IO [Tree CPEntry]+execClassPath m = St.execStateT m []++-- | Load one class in current ClassPath+loadClass :: String -> ClassPath ()+loadClass path = do+    cp <- St.get+    cp' <- liftIO $ mapM (load xs) cp+    St.put cp'+  where+    xs = split "/" path++    load :: [String] -> Tree CPEntry -> IO (Tree CPEntry)+    load [] t = return t+    load (p:ps) t@(Directory dir forest)+      | p == dir  = Directory dir `fmap` mapM (load ps) forest+      | otherwise = return t+    load [p] t@(File (NotLoaded f))+      | (p ++ ".class") == f = do+                               cls <- parseClassFile (path ++ ".class")+                               return (File $ Loaded path cls)+      | otherwise = return t+    load [p] t@(File (NotLoadedJAR jarfile f))+      | (p ++ ".class") == f = do+                               cls <- readFromJAR jarfile (path ++ ".class")+                               return (File $ LoadedJAR jarfile cls)+      | otherwise = return t+    load ps (File _) = fail $ "Found file when expecting directory! " ++ show ps++-- | Get one ClassPath entry+getEntry :: [Tree CPEntry] -> String -> IO (Maybe CPEntry)+getEntry cp path = get cp (split "/" path)+  where+    get :: [Tree CPEntry] -> [String] -> IO (Maybe CPEntry)+    get _ [] = fail "Empty path for ClassPath.getEntry.get!"+    get [] _ = return Nothing+    get (Directory dir forest: es) (p:ps)+      | dir == p  = get forest ps+      | otherwise = get es (p:ps)+    get (File i@(NotLoaded f): es) [p]+      | (p ++ ".class" == f) = do+                               cls <- parseClassFile (path ++ ".class")+                               return $ Just (Loaded path cls)+      | otherwise = get es [p]+    get (File i@(NotLoadedJAR jarfile r): es) [p]+      | (p ++ ".class" == r) = do+                               cls <- readFromJAR jarfile (path ++ ".class")+                               return $ Just (LoadedJAR jarfile cls)+      | otherwise = get es [p]+    get (File i@(Loaded f c):es) [p]+      | f == p = return (Just i)+      | otherwise = get es [p]+    get (File i@(LoadedJAR f c):es) [p]+      | toString (thisClass c) == path = return (Just i)+      | otherwise = get es [p]+    get x y = fail $ "Unexpected arguments for ClassPath.getEntry.get: " ++ show x ++ ", " ++ show y+

@@ -0,0 +1,74 @@++module Java.ClassPath.Common where++import Data.List+import Data.String.Utils (split)+import System.FilePath++import Java.ClassPath.Types++-- | map on forest+mapF ::  (t -> a) -> [Tree t] -> [Tree a]+mapF fn forest = map (mapT fn) forest++-- | mapM on forest+mapFM :: (Monad m, Functor m) => (t -> m a) -> [Tree t] -> m [Tree a]+mapFM fn forest = mapM (mapTM fn) forest++-- | mapM on tree+mapTM ::  (Monad m, Functor m) => (t -> m a) -> Tree t -> m (Tree a)+mapTM fn (Directory dir forest) = Directory dir `fmap` mapFM fn forest+mapTM fn (File a) = File `fmap` fn a++mapFMF ::  (Monad m, Functor m) => (FilePath -> t -> m a) -> [Tree t] -> m [Tree a]+mapFMF fn forest = mapM (mapTMF fn) forest++mapTMF ::  (Monad m, Functor m) => (FilePath -> t -> m a) -> Tree t -> m (Tree a)+mapTMF fn t = go "" t+  where+    go path (Directory dir forest) = Directory dir `fmap` mapM (go $ path </> dir) forest+    go path (File a) = File `fmap` fn path a++-- | map on tree+mapT ::  (t -> a) -> Tree t -> Tree a+mapT fn (Directory dir forest) = Directory dir (mapF fn forest)+mapT fn (File a) = File (fn a)++-- | Build tree from list of filenames.+-- For example, ["org/haskell", "org/java"] --> [org/{haskell, java}]+buildTree :: [FilePath] -> [Tree FilePath]+buildTree strs =+  let build :: [[String]] -> [Tree FilePath]+      build [[name]] = [File name]+      build ss = map node $ groupBy eq (sort ss)++      node [] = error "Impossible: groupBy give an empty group!"+      node ([]:l) = node l+      node l | all (null . tail) l = File (head $ head l)+             | otherwise           = Directory (head $ head l) (build $ map tail l)++      ls = map (split "/") strs++      eq [] []       = True+      eq (x:_) (y:_) = x == y++  in  build ls++-- | Merge ClassPath forest.+-- For example, [org/haskell, org/java] --> [org/{haskell, java}].+merge :: [Tree CPEntry] -> [Tree CPEntry]+merge [] = []+merge [t1,t2] = merge1 [t1] t2+merge (t:ts) = foldl merge1 [t] ts+  +-- | Add one ClassPath tree to forest.+merge1 :: [Tree CPEntry] -> Tree CPEntry -> [Tree CPEntry]+merge1 [] x = [x]+merge1 (x@(File e): es) y@(File e') | e == e'   = x: es+                                    | otherwise = x: merge1 es y+merge1 (d@(Directory _ _):es) f@(File _) = d: merge1 es f+merge1 (f@(File _):es) d@(Directory _ _) = f: merge1 es d+merge1 (x@(Directory dir f):es) y@(Directory dir' f')+  | dir == dir' = Directory dir (merge $ f ++ f'): es +  | otherwise   = x: merge1 es y+

@@ -0,0 +1,35 @@++module Java.ClassPath.Types where++import Control.Monad.State+import Data.List++import JVM.ClassFile++-- | Directories tree+data Tree a =+    Directory FilePath [Tree a]+  | File a+  deriving (Eq)++instance Show a => Show (Tree a) where+  show (Directory dir forest) = dir ++ "/{" ++ intercalate ", " (map show forest) ++ "}"+  show (File a) = show a++-- | ClassPath entry+data CPEntry =+    NotLoaded FilePath                -- ^ Not loaded .class file+  | Loaded FilePath (Class Direct)    -- ^ Class loaded from .class file+  | NotLoadedJAR FilePath FilePath    -- ^ Not loaded .jar file+  | LoadedJAR FilePath (Class Direct) -- ^ Class loaded from .jar file+  deriving (Eq)++instance Show CPEntry where+  show (NotLoaded path) = "<Not loaded file: " ++ path ++ ">"+  show (Loaded path cls) = "<Loaded from " ++ path ++ ": " ++ toString (thisClass cls) ++ ">"+  show (NotLoadedJAR jar path) = "<Not loaded JAR: " ++ jar ++ ": " ++ path ++ ">"+  show (LoadedJAR path cls) = "<Read JAR: " ++ path ++ ": " ++ toString (thisClass cls) ++ ">"++-- | ClassPath monad+type ClassPath a = StateT [Tree CPEntry] IO a+

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+-- | This module exports definitions for some most used classes and methods from standard Java java.io package. module Java.IO where  import Data.String@@ -8,18 +9,21 @@  import qualified Java.Lang +-- | java.io.PrintStream class name printStream :: IsString s => s printStream = "java/io/PrintStream" +-- | java.io.PrintStream class as field type+printStreamClass ::  FieldType printStreamClass = ObjectType printStream -println :: NameType Method+println :: NameType (Method Direct) println = NameType "println" $ MethodSignature [Java.Lang.stringClass] ReturnsVoid -out :: NameType Field+out :: NameType (Field Direct) out = NameType "out" printStreamClass -printf :: NameType Method+printf :: NameType (Method Direct) printf =   NameType "printf" $ MethodSignature [Java.Lang.stringClass,                                        Array Nothing Java.Lang.objectClass] (Returns printStreamClass)

@@ -0,0 +1,58 @@++module Java.JAR +  (readManifest,+   readJAR,+   addJAR+  ) where++import Control.Monad.Trans (liftIO)+import qualified Control.Monad.State as St+import Data.List+import qualified Codec.Archive.LibZip as Zip++import Java.ClassPath+import Java.JAR.Archive+import Java.META++readManifest :: Zip.Archive (Maybe Manifest)+readManifest = do+  let manifestPath = "META-INF/MANIFEST.MF"+  files <- Zip.fileNames []+  if manifestPath `elem` files+    then do+         content <- Zip.fileContents [] manifestPath+         case parseMeta content of+           Left e -> fail $ show e+           Right meta -> return $ Just (loadSpec meta)+    else return Nothing++readOne :: FilePath -> String -> Zip.Archive [Tree CPEntry]+readOne jarfile str = do+    files <- Zip.fileNames []+    return $ mapF (NotLoadedJAR jarfile) (buildTree $ filter good files)+  where+    good name = (str `isPrefixOf` name) && (".class" `isSuffixOf` name)++-- | Read entries from JAR file, using MANIFEST.MF if it exists.+readJAR :: FilePath -> IO [Tree CPEntry]+readJAR jarfile = do+  r <- Zip.withArchive [] jarfile $ do+         m <- readManifest+         case m of+           Nothing -> return Nothing+           Just mf -> do+                      trees <- mapM (readOne jarfile) (map meName $ manifestEntries mf)+                      let forest = merge (concat trees)+                      return (Just forest)+  case r of+    Nothing -> readAllJAR jarfile+    Just f  -> return f++-- | Add given JAR file to ClassPath+addJAR :: FilePath -> ClassPath ()+addJAR jarfile = do+  classes <- liftIO $ readJAR jarfile+  cp <- St.get+  let cp' = merge $ cp ++ classes+  St.put cp'+

@@ -0,0 +1,54 @@+-- | This module defines functions to read Java JAR files.+module Java.JAR.Archive where++import qualified Codec.Archive.LibZip as Zip+import Data.Binary+import Data.List+import qualified Data.ByteString.Lazy as B+import System.FilePath++import Java.ClassPath.Types+import Java.ClassPath.Common+import JVM.ClassFile+import JVM.Converter++readJAREntry :: (Enum a) => FilePath -> String -> IO (Maybe [a])+readJAREntry jarfile path = do+  Zip.catchZipError (Just `fmap` (Zip.withArchive [] jarfile $ Zip.fileContents [] path))+                    (\_ -> return Nothing)++-- | Read all entires from JAR file+readAllJAR :: FilePath -> IO [Tree CPEntry]+readAllJAR jarfile = do+    files <- Zip.withArchive [] jarfile $ Zip.fileNames []+    return $ mapF (NotLoadedJAR jarfile) (buildTree $ filter good files)+  where+    good file = ".class" `isSuffixOf` file++-- | Read one class from JAR file+readFromJAR :: FilePath -> FilePath -> IO (Class Direct)+readFromJAR jarfile path = do+  content <- Zip.withArchive [] jarfile $ Zip.fileContents [] path+  let bstr = B.pack content+  return $ classFile2Direct (decode bstr)++checkClassTree :: [Tree CPEntry] -> IO [Tree (FilePath, Class Direct)]+checkClassTree forest = mapFMF check forest+  where+    check _ (NotLoaded path) = do+       cls <- parseClassFile path+       return (path, cls)+    check a (Loaded path cls) = return (a </> path, cls)+    check a (NotLoadedJAR jar path) = do+       cls <- readFromJAR jar (a </> path)+       return (a </> path, cls)+    check a (LoadedJAR _ cls) =+       return (a </> show (thisClass cls), cls)++zipJAR :: [Tree (FilePath, Class Direct)] -> Zip.Archive ()+zipJAR forest = do+    mapFM go forest+    return ()+  where+    go (path, cls) = Zip.addFile path =<< Zip.sourceBuffer (B.unpack $ encodeClass cls)+

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+-- | This module exports some definitions from standard Java java.lang package. module Java.Lang where  import Data.String@@ -6,9 +7,16 @@ import JVM.Common ()  -- import instances only import JVM.ClassFile +objectClass ::  FieldType objectClass = ObjectType object++stringClass ::  FieldType stringClass = ObjectType string++integerClass ::  FieldType integerClass = ObjectType integer++systemClass ::  FieldType systemClass = ObjectType system  object :: IsString s => s@@ -23,9 +31,11 @@ system :: IsString s => s system = "java/lang/System" -objectInit :: NameType Method+-- | java.lang.Object.<init>() method+objectInit :: NameType (Method Direct) objectInit = NameType "<init>" $ MethodSignature [] ReturnsVoid -valueOfInteger :: NameType Method+-- | java.lang.Integer.valueOf() method+valueOfInteger :: NameType (Method Direct) valueOfInteger = NameType "valueOf" $ MethodSignature [IntType] (Returns Java.Lang.integerClass) 

@@ -0,0 +1,81 @@+-- | This module declares functions and data types for+-- JAR meta-information classes, such as MANIFEST.MF etc.+module Java.META+  (module Java.META.Types,+   module Java.META.Parser,+   module Java.META.Spec,+   Manifest (..),+   ManifestEntry (..))+  where++import qualified Data.Map as M+import Data.Map ((!))++import Java.META.Types+import Java.META.Parser+import Java.META.Spec++-- | JAR MANIFEST.MF+data Manifest = Manifest {+  manifestVersion :: String,+  createdBy :: String,+  sealed :: Bool,+  signatureVersion :: Maybe String,+  classPath :: [String],+  mainClass :: Maybe String,+  manifestEntries :: [ManifestEntry]}+  deriving (Eq, Show)++-- | Manifest entry+data ManifestEntry = ManifestEntry {+  meName :: String,+  meSealed :: Bool,+  meContentType :: Maybe String,+  meBean :: Bool }+  deriving (Eq, Show)++instance MetaSpec Manifest where+  loadFirstSection s = Manifest {+    manifestVersion = s ! "Manifest-Version",+    createdBy = s ! "Created-By",+    sealed = case M.lookup "Sealed" s of+               Nothing -> False+               Just str -> string2bool str,+    signatureVersion = M.lookup "Signature-Version" s,+    classPath = case M.lookup "Class-Path" s of+                  Nothing -> []+                  Just str -> words str,+    mainClass = M.lookup "Main-Class" s,+    manifestEntries = []}++  loadOtherSection m s = m {manifestEntries = manifestEntries m ++ [entry]}+    where+      entry = ManifestEntry {+                meName = s ! "Name",+                meSealed = case M.lookup "Sealed" s of+                             Nothing -> sealed m+                             Just str -> string2bool str,+                meContentType = M.lookup "Content-Type" s,+                meBean = case M.lookup "Java-Bean" s of+                           Nothing -> False+                           Just str -> string2bool str }++  storeMeta m = first: map store (manifestEntries m)+    where+      first = M.fromList $ [+          ("Manifest-Version", manifestVersion m),+          ("Created-By", createdBy m)] +++          lookupList "Signature-Version" (signatureVersion m) +++          lookupList "Main-Class" (mainClass m) +++          case classPath m of+            [] -> []+            list -> [("Class-Path", unwords list)]++      store e = M.fromList $ [+          ("Name", meName e),+          ("Sealed", bool2string $ meSealed e)] +++          lookupList "Content-Type" (meContentType e) +++          if meBean e+            then [("Java-Bean", "true")]+            else []+

@@ -0,0 +1,66 @@++module Java.META.Parser+  (parseMeta,+   parseMetaFile) where++import qualified Data.Map as M+import Text.Parsec+import Text.Parsec.String++import Java.META.Types++pNewLine :: Parser ()+pNewLine = choice $ map try $ [+              string "\r\n" >> return (),+              char '\r' >> return (),+              char '\n' >> return () ]++blankline :: Parser ()+blankline = do+  pNewLine <?> "first newline in blankline"+  return ()++pSection :: Parser Section+pSection = do+  list <- many1 pHeader+  blankline <?> "blank line"+  return $ M.fromList list++pHeader :: Parser (String, String) +pHeader = do+    name <- many1 headerChar <?> "header name"+    char ':'+    value <- pValue+    return (name, value)+  where+    headerChar = oneOf "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_"++pValue :: Parser String+pValue = do+  list <- manyLines+  return (concat list)++manyLines :: Parser [String]+manyLines = do+  char ' '+  many space+  s <- many1 (noneOf "\n\r\0")+  pNewLine <?> "new line at end of value line"+  c <- lookAhead anyChar+  if c == ' '+    then do+         next <- manyLines+         return (s: next)+    else return [s]++pMETA :: Parser META+pMETA = many1 pSection++parseMetaFile :: FilePath -> IO (Either ParseError META)+parseMetaFile path = do+  str <- readFile path+  return $ parse pMETA path (str ++ "\n\n")++parseMeta :: String -> Either ParseError META+parseMeta str = parse pMETA "<META>" (str ++ "\n\n")+

@@ -0,0 +1,33 @@+module Java.META.Spec where++import Data.Char (toLower)++import Java.META.Types++class MetaSpec s where+  loadFirstSection :: Section -> s++  loadOtherSection :: s -> Section -> s+  loadOtherSection s _ = s++  storeMeta :: s -> META++loadSpec :: (MetaSpec s) => META -> s+loadSpec [] = error "Cannot load empty metadata"+loadSpec (s:ss) =+  let x = loadFirstSection s+  in  foldl loadOtherSection x ss++lookupList :: String -> Maybe String -> [(String, String)]+lookupList _ Nothing = []+lookupList name (Just val) = [(name, val)]++bool2string :: Bool -> String+bool2string True = "true"+bool2string False = "false"++string2bool :: String -> Bool+string2bool s+  | map toLower s == "true" = True+  | otherwise = False+

@@ -0,0 +1,8 @@++module Java.META.Types where++import qualified Data.Map as M++type Section = M.Map String String+type META = [Section]+

@@ -1,23 +1,39 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} +import Control.Monad.Exception import qualified Data.ByteString.Lazy as B  import JVM.ClassFile import JVM.Converter import JVM.Assembler import JVM.Builder+import JVM.Exceptions+import Java.ClassPath  import qualified Java.Lang import qualified Java.IO -test :: Generate ()+test :: (Throws ENotFound e, Throws ENotLoaded e, Throws UnexpectedEndMethod e) => GenerateIO e () test = do+  withClassPath $ do+      -- Add current directory (with Hello.class) to ClassPath+      addDirectory "."++  -- Load method signature: Hello.hello() from Hello.class+  helloJava <- getClassMethod "./Hello" "hello"++  -- Initializer method. Just calls java.lang.Object.<init>   newMethod [ACC_PUBLIC] "<init>" [] ReturnsVoid $ do+      setStackSize 1+       aload_ I0       invokeSpecial Java.Lang.object Java.Lang.objectInit       i0 RETURN +  -- Declare hello() method and bind it's signature to hello.   hello <- newMethod [ACC_PUBLIC, ACC_STATIC] "hello" [IntType] ReturnsVoid $ do+      setStackSize 8+       getStaticField Java.Lang.system Java.IO.out       loadString "Здравствуй, мир!"       invokeVirtual Java.IO.printStream Java.IO.println@@ -31,19 +47,24 @@       invokeStatic Java.Lang.integer Java.Lang.valueOfInteger       aastore       invokeVirtual Java.IO.printStream Java.IO.printf+      -- Call Hello.hello()+      invokeStatic "Hello" helloJava       pop       i0 RETURN +  -- Main class method.    newMethod [ACC_PUBLIC, ACC_STATIC] "main" [arrayOf Java.Lang.stringClass] ReturnsVoid $ do+      setStackSize 1+       iconst_5+      -- Call previously declared method       invokeStatic "Test" hello       i0 RETURN    return () -testClass ::  Class Resolved-testClass = generate "Test" test-+main :: IO () main = do+  testClass <- generateIO [] "Test" test   B.writeFile "Test.class" (encodeClass testClass) 

@@ -15,7 +15,7 @@   case args of     [clspath] -> do       clsFile <- decodeFile clspath-      putStrLn $ showListIx $ M.elems $ constsPool (clsFile :: Class Pointers)+      putStrLn $ showListIx $ M.assocs $ constsPool (clsFile :: Class File)       cls <- parseClassFile clspath       dumpClass cls     _ -> error "Synopsis: dump-class File.class"

@@ -1,5 +1,5 @@ Name:           hs-java-Version:        0.2+Version:        0.3.1 Cabal-Version:  >= 1.6 License:        BSD3 License-File:   LICENSE@@ -11,6 +11,7 @@ Description:    This package declares data types for Java .class files format and functions                 to assemble/disassemble Java bytecode. See dump-class.hs, rebuild-class.hs,                 TestGen.hs for examples of usage.+Bug-reports: http://redmine.iportnov.ru/projects/hs-java/  Extra-source-files: dump-class.hs                     rebuild-class.hs@@ -28,14 +29,24 @@                    JVM.Exceptions                    Java.Lang                    Java.IO+                   Java.ClassPath+                   Java.ClassPath.Types+                   Java.ClassPath.Common+                   Java.JAR+                   Java.JAR.Archive+                   Java.META+                   Java.META.Types+                   Java.META.Spec+                   Java.META.Parser    Build-Depends:  base >= 3 && <= 5, containers, binary,                   mtl, directory, filepath, utf8-string, array,                   bytestring, data-binary-ieee754, binary-state,-                  control-monad-exception+                  control-monad-exception, data-default, MissingH,+                  LibZip, Glob, parsec >= 3 && <4    ghc-options: -fwarn-unused-imports  Source-repository head   type:     git-  location: git remote add origin git@gitorious.org:hs-java/hs-java.git+  location: git@gitorious.org:hs-java/hs-java.git

@@ -15,11 +15,11 @@   case args of     [clspath,outpath] -> do       cls <- parseClassFile clspath-      clsfile <- decodeFile clspath :: IO (Class Pointers)+      clsfile <- decodeFile clspath :: IO (Class File)       dumpClass cls-      putStrLn $ "Source pool:\n" ++ showListIx (M.elems $ constsPool clsfile)-      let result = classFile cls-      putStrLn $ "Result pool:\n" ++ showListIx (M.elems $ constsPool result)+      putStrLn $ "Source pool:\n" ++ showListIx (M.assocs $ constsPool clsfile)+      let result = classDirect2File cls+      putStrLn $ "Result pool:\n" ++ showListIx (M.assocs $ constsPool result)       B.writeFile outpath (encodeClass cls)      _ -> error "Synopsis: rebuild-class File.class Output.class"