hs-java (empty) → 0.1
raw patch · 8 files changed
+1728/−0 lines, 8 filesdep +arraydep +basedep +binarysetup-changed
Dependencies added: array, base, binary, binary-state, bytestring, containers, control-monad-exception, data-binary-ieee754, directory, filepath, haskell98, mtl, utf8-string
Files
- JVM/Assembler.hs +716/−0
- JVM/ClassFile.hs +380/−0
- JVM/Converter.hs +237/−0
- JVM/Types.hs +162/−0
- LICENSE +165/−0
- Setup.hs +2/−0
- dump-class.hs +37/−0
- hs-java.cabal +29/−0
+ JVM/Assembler.hs view
@@ -0,0 +1,716 @@+{-# LANGUAGE TypeFamilies, StandaloneDeriving, FlexibleInstances,+ FlexibleContexts, UndecidableInstances, RecordWildCards, OverloadedStrings,+ TypeSynonymInstances, MultiParamTypeClasses #-}+-- | This module declares data type for JVM instructions, and BinaryState+-- instances to read/write them.+module JVM.Assembler + (Instruction (..),+ ArrayType (..),+ CodeException (..),+ Code (..),+ IMM (..),+ CMP (..),+ encodeMethod,+ decodeMethod+ )+ where++import Control.Monad+import Control.Applicative+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++-- | Immediate constant. Corresponding value will be added to base opcode.+data IMM =+ I0 -- ^ 0+ | I1 -- ^ 1+ | I2 -- ^ 2+ | I3 -- ^ 3+ deriving (Eq, Ord, Enum, Show)++-- | Comparation operation type. Not all CMP instructions support all operations.+data CMP =+ C_EQ+ | C_NE+ | C_LT+ | C_GE+ | C_GT+ | C_LE+ deriving (Eq, Ord, Enum, Show)++-- | Format of Code method attribute.+data Code = Code {+ codeStackSize :: Word16,+ codeMaxLocals :: Word16,+ codeLength :: Word32,+ codeInstructions :: [Instruction],+ codeExceptionsN :: Word16,+ codeExceptions :: [CodeException],+ codeAttrsN :: Word16,+ codeAttributes :: [AttributeInfo] }+ deriving (Eq, Show)++-- | Exception descriptor+data CodeException = CodeException {+ eStartPC :: Word16,+ eEndPC :: Word16,+ eHandlerPC :: Word16,+ eCatchType :: Word16 }+ deriving (Eq, Show)++instance BinaryState Integer CodeException where+ put (CodeException {..}) = do+ put eStartPC+ put eEndPC+ put eHandlerPC+ put eCatchType++ get = CodeException <$> get <*> get <*> get <*> get++instance BinaryState Integer AttributeInfo where+ put a = do+ let sz = 6 + attributeLength a -- full size of AttributeInfo structure+ liftOffset (fromIntegral sz) Binary.put a++ get = getZ++instance BinaryState Integer Code where+ put (Code {..}) = do+ put codeStackSize+ put codeMaxLocals+ put codeLength+ forM_ codeInstructions put+ put codeExceptionsN+ forM_ codeExceptions put+ put codeAttrsN+ forM_ codeAttributes put++ get = do+ stackSz <- get+ locals <- get+ len <- get+ bytes <- replicateM (fromIntegral len) get+ let bytecode = B.pack bytes+ code = decodeWith readInstructions 0 bytecode+ excn <- get+ excs <- replicateM (fromIntegral excn) get+ nAttrs <- get+ attrs <- replicateM (fromIntegral nAttrs) get+ return $ Code stackSz locals len code excn excs nAttrs attrs++-- | Read sequence of instructions (to end of stream)+readInstructions :: GetState Integer [Instruction]+readInstructions = do+ end <- isEmpty+ if end+ then return []+ else do+ x <- get+ next <- readInstructions+ return (x: next)++-- | JVM instruction set+data Instruction =+ NOP -- ^ 0+ | ACONST_NULL -- ^ 1+ | ICONST_M1 -- ^ 2+ | ICONST_0 -- ^ 3+ | ICONST_1 -- ^ 4+ | ICONST_2 -- ^ 5+ | ICONST_3 -- ^ 6+ | ICONST_4 -- ^ 7+ | ICONST_5 -- ^ 8+ | LCONST_0 -- ^ 9+ | LCONST_1 -- ^ 10+ | FCONST_0 -- ^ 11+ | FCONST_1 -- ^ 12+ | FCONST_2 -- ^ 13+ | DCONST_0 -- ^ 14+ | DCONST_1 -- ^ 15+ | BIPUSH Word8 -- ^ 16+ | SIPUSH Word16 -- ^ 17+ | LDC1 Word8 -- ^ 18+ | LDC2 Word16 -- ^ 19+ | LDC2W Word16 -- ^ 20+ | ILOAD Word8 -- ^ 21+ | LLOAD Word8 -- ^ 22+ | FLOAD Word8 -- ^ 23+ | DLOAD Word8 -- ^ 24+ | ALOAD Word8 -- ^ 25+ | ILOAD_ IMM -- ^ 26, 27, 28, 29+ | LLOAD_ IMM -- ^ 30, 31, 32, 33+ | FLOAD_ IMM -- ^ 34, 35, 36, 37+ | DLOAD_ IMM -- ^ 38, 39, 40, 41+ | ALOAD_ IMM -- ^ 42, 43, 44, 45+ | IALOAD -- ^ 46+ | LALOAD -- ^ 47+ | FALOAD -- ^ 48+ | DALOAD -- ^ 49+ | AALOAD -- ^ 50+ | BALOAD -- ^ 51+ | CALOAD -- ^ 52+ | SALOAD -- ^ 53+ | ISTORE Word8 -- ^ 54+ | LSTORE Word8 -- ^ 55+ | FSTORE Word8 -- ^ 56+ | DSTORE Word8 -- ^ 57+ | ASTORE Word8 -- ^ 58+ | ISTORE_ IMM -- ^ 59, 60, 61, 62+ | LSTORE_ IMM -- ^ 63, 64, 65, 66+ | FSTORE_ IMM -- ^ 67, 68, 69, 70+ | DSTORE_ IMM -- ^ 71, 72, 73, 74+ | ASTORE_ IMM -- ^ 75, 76, 77, 78+ | IASTORE -- ^ 79+ | LASTORE -- ^ 80+ | FASTORE -- ^ 81+ | DASTORE -- ^ 82+ | AASTORE -- ^ 83+ | BASTORE -- ^ 84+ | CASTORE -- ^ 85+ | SASTORE -- ^ 86+ | POP -- ^ 87+ | POP2 -- ^ 88+ | DUP -- ^ 89+ | DUP_X1 -- ^ 90+ | DUP_X2 -- ^ 91+ | DUP2 -- ^ 92+ | DUP2_X1 -- ^ 93 + | DUP2_X2 -- ^ 94+ | SWAP -- ^ 95+ | IADD -- ^ 96+ | LADD -- ^ 97+ | FADD -- ^ 98+ | DADD -- ^ 99+ | ISUB -- ^ 100+ | LSUB -- ^ 101+ | FSUB -- ^ 102+ | DSUB -- ^ 103+ | IMUL -- ^ 104+ | LMUL -- ^ 105+ | FMUL -- ^ 106+ | DMUL -- ^ 107+ | IDIV -- ^ 108+ | LDIV -- ^ 109+ | FDIV -- ^ 110+ | DDIV -- ^ 111+ | IREM -- ^ 112+ | LREM -- ^ 113+ | FREM -- ^ 114+ | DREM -- ^ 115+ | INEG -- ^ 116+ | LNEG -- ^ 117+ | FNEG -- ^ 118+ | DNEG -- ^ 119+ | ISHL -- ^ 120+ | LSHL -- ^ 121+ | ISHR -- ^ 122+ | LSHR -- ^ 123+ | IUSHR -- ^ 124+ | LUSHR -- ^ 125+ | IAND -- ^ 126+ | LAND -- ^ 127+ | IOR -- ^ 128+ | LOR -- ^ 129+ | IXOR -- ^ 130+ | LXOR -- ^ 131+ | IINC Word8 Word8 -- ^ 132+ | I2L -- ^ 133+ | I2F -- ^ 134+ | I2D -- ^ 135+ | L2I -- ^ 136+ | L2F -- ^ 137+ | L2D -- ^ 138+ | F2I -- ^ 139+ | F2L -- ^ 140+ | F2D -- ^ 141+ | D2I -- ^ 142+ | D2L -- ^ 143+ | D2F -- ^ 144+ | I2B -- ^ 145+ | I2C -- ^ 146+ | I2S -- ^ 147+ | LCMP -- ^ 148+ | FCMP CMP -- ^ 149, 150+ | DCMP CMP -- ^ 151, 152+ | IF CMP -- ^ 153, 154, 155, 156, 157, 158+ | IF_ICMP CMP Word16 -- ^ 159, 160, 161, 162, 163, 164+ | IF_ACMP CMP Word16 -- ^ 165, 166+ | GOTO -- ^ 167+ | JSR Word16 -- ^ 168+ | RET -- ^ 169+ | TABLESWITCH Word32 Word32 Word32 [Word32] -- ^ 170+ | LOOKUPSWITCH Word32 Word32 [(Word32, Word32)] -- ^ 171+ | IRETURN -- ^ 172+ | LRETURN -- ^ 173+ | FRETURN -- ^ 174+ | DRETURN -- ^ 175+ | RETURN -- ^ 177+ | GETSTATIC Word16 -- ^ 178+ | PUTSTATIC Word16 -- ^ 179+ | GETFIELD Word16 -- ^ 180+ | PUTFIELD Word16 -- ^ 181+ | INVOKEVIRTUAL Word16 -- ^ 182+ | INVOKESPECIAL Word16 -- ^ 183+ | INVOKESTATIC Word16 -- ^ 184+ | INVOKEINTERFACE Word16 Word8 -- ^ 185+ | NEW Word16 -- ^ 187+ | NEWARRAY Word8 -- ^ 188, see @ArrayType@+ | ANEWARRAY Word16 -- ^ 189+ | ARRAYLENGTH -- ^ 190+ | ATHROW -- ^ 191+ | CHECKCAST Word16 -- ^ 192+ | INSTANCEOF Word16 -- ^ 193+ | MONITORENTER -- ^ 194+ | MONITOREXIT -- ^ 195+ | WIDE Word8 Instruction -- ^ 196+ | MULTINANEWARRAY Word16 Word8 -- ^ 197+ | IFNULL Word16 -- ^ 198+ | IFNONNULL Word16 -- ^ 199+ | GOTO_W Word32 -- ^ 200+ | JSR_W Word32 -- ^ 201+ deriving (Eq, Show)++-- | JVM array type (primitive types)+data ArrayType =+ T_BOOLEAN -- ^ 4+ | T_CHAR -- ^ 5+ | T_FLOAT -- ^ 6+ | T_DOUBLE -- ^ 7+ | T_BYTE -- ^ 8+ | T_SHORT -- ^ 9+ | T_INT -- ^ 10+ | T_LONG -- ^ 11+ deriving (Eq, Show, Enum)++-- | Parse opcode with immediate constant+imm :: Word8 -- ^ Base opcode+ -> (IMM -> Instruction) -- ^ Instruction constructor+ -> Word8 -- ^ Opcode to parse+ -> GetState s Instruction+imm base constr x = return $ constr $ toEnum $ fromIntegral (x-base)++-- | Put opcode with immediate constant+putImm :: Word8 -- ^ Base opcode+ -> IMM -- ^ Constant to add to opcode+ -> PutState Integer ()+putImm base i = putByte $ base + (fromIntegral $ fromEnum i)++atype2byte :: ArrayType -> Word8+atype2byte T_BOOLEAN = 4+atype2byte T_CHAR = 5+atype2byte T_FLOAT = 6+atype2byte T_DOUBLE = 7+atype2byte T_BYTE = 8+atype2byte T_SHORT = 9+atype2byte T_INT = 10+atype2byte T_LONG = 11++byte2atype :: Word8 -> GetState s ArrayType+byte2atype 4 = return T_BOOLEAN+byte2atype 5 = return T_CHAR+byte2atype 6 = return T_FLOAT+byte2atype 7 = return T_DOUBLE+byte2atype 8 = return T_BYTE+byte2atype 9 = return T_SHORT+byte2atype 10 = return T_INT+byte2atype 11 = return T_LONG+byte2atype x = fail $ "Unknown array type byte: " ++ show x++instance BinaryState Integer ArrayType where+ get = do+ x <- getByte+ byte2atype x++ put t = putByte (atype2byte t)++-- | Put opcode with one argument+put1 :: (BinaryState Integer a)+ => Word8 -- ^ Opcode+ -> a -- ^ First argument+ -> PutState Integer ()+put1 code x = do+ putByte code+ put x++put2 :: (BinaryState Integer a, BinaryState Integer b)+ => Word8 -- ^ Opcode+ -> a -- ^ First argument+ -> b -- ^ Second argument+ -> PutState Integer ()+put2 code x y = do+ putByte code+ put x+ put y++instance BinaryState Integer Instruction where+ put NOP = putByte 0+ put ACONST_NULL = putByte 1+ put ICONST_M1 = putByte 2+ put ICONST_0 = putByte 3+ put ICONST_1 = putByte 4+ put ICONST_2 = putByte 5+ put ICONST_3 = putByte 6+ put ICONST_4 = putByte 7+ put ICONST_5 = putByte 8+ put LCONST_0 = putByte 9+ put LCONST_1 = putByte 10+ put FCONST_0 = putByte 11+ put FCONST_1 = putByte 12+ put FCONST_2 = putByte 13+ put DCONST_0 = putByte 14+ put DCONST_1 = putByte 15+ put (BIPUSH x) = put1 16 x+ put (SIPUSH x) = put1 17 x+ put (LDC1 x) = put1 18 x+ put (LDC2 x) = put1 19 x+ put (LDC2W x) = put1 20 x+ put (ILOAD x) = put1 21 x+ put (LLOAD x) = put1 22 x+ put (FLOAD x) = put1 23 x+ put (DLOAD x) = put1 24 x+ put (ALOAD x) = put1 25 x+ put (ILOAD_ i) = putImm 26 i+ put (LLOAD_ i) = putImm 30 i+ put (FLOAD_ i) = putImm 34 i+ put (DLOAD_ i) = putImm 38 i+ put (ALOAD_ i) = putImm 42 i+ put IALOAD = putByte 46+ put LALOAD = putByte 47+ put FALOAD = putByte 48+ put DALOAD = putByte 49+ put AALOAD = putByte 50+ put BALOAD = putByte 51+ put CALOAD = putByte 52+ put SALOAD = putByte 53+ put (ISTORE x) = put1 54 x+ put (LSTORE x) = put1 55 x+ put (FSTORE x) = put1 56 x+ put (DSTORE x) = put1 57 x+ put (ASTORE x) = put1 58 x+ put (ISTORE_ i) = putImm 59 i+ put (LSTORE_ i) = putImm 63 i+ put (FSTORE_ i) = putImm 67 i+ put (DSTORE_ i) = putImm 71 i+ put (ASTORE_ i) = putImm 75 i+ put IASTORE = putByte 79+ put LASTORE = putByte 80+ put FASTORE = putByte 81+ put DASTORE = putByte 82+ put AASTORE = putByte 83+ put BASTORE = putByte 84+ put CASTORE = putByte 85+ put SASTORE = putByte 86+ put POP = putByte 87+ put POP2 = putByte 88+ put DUP = putByte 89+ put DUP_X1 = putByte 90+ put DUP_X2 = putByte 91+ put DUP2 = putByte 92+ put DUP2_X1 = putByte 93 + put DUP2_X2 = putByte 94+ put SWAP = putByte 95+ put IADD = putByte 96+ put LADD = putByte 97+ put FADD = putByte 98+ put DADD = putByte 99+ put ISUB = putByte 100+ put LSUB = putByte 101+ put FSUB = putByte 102+ put DSUB = putByte 103+ put IMUL = putByte 104+ put LMUL = putByte 105+ put FMUL = putByte 106+ put DMUL = putByte 107+ put IDIV = putByte 108+ put LDIV = putByte 109+ put FDIV = putByte 110+ put DDIV = putByte 111+ put IREM = putByte 112+ put LREM = putByte 113+ put FREM = putByte 114+ put DREM = putByte 115+ put INEG = putByte 116+ put LNEG = putByte 117+ put FNEG = putByte 118+ put DNEG = putByte 119+ put ISHL = putByte 120+ put LSHL = putByte 121+ put ISHR = putByte 122+ put LSHR = putByte 123+ put IUSHR = putByte 124+ put LUSHR = putByte 125+ put IAND = putByte 126+ put LAND = putByte 127+ put IOR = putByte 128+ put LOR = putByte 129+ put IXOR = putByte 130+ put LXOR = putByte 131+ put (IINC x y) = put2 132 x y+ put I2L = putByte 133+ put I2F = putByte 134+ put I2D = putByte 135+ put L2I = putByte 136+ put L2F = putByte 137+ put L2D = putByte 138+ put F2I = putByte 139+ put F2L = putByte 140+ put F2D = putByte 141+ put D2I = putByte 142+ put D2L = putByte 143+ put D2F = putByte 144+ put I2B = putByte 145+ put I2C = putByte 146+ put I2S = putByte 147+ put LCMP = putByte 148+ put (FCMP C_LT) = putByte 149+ put (FCMP C_GT) = putByte 150+ put (FCMP c) = fail $ "No such instruction: FCMP " ++ show c+ 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_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 (JSR x) = put1 168 x+ put RET = putByte 169+ put (TABLESWITCH def low high offs) = do+ putByte 170+ offset <- getOffset+ let pads = 4 - (offset `mod` 4)+ replicateM (fromIntegral pads) (putByte 0)+ put low+ put high+ forM_ offs put+ put (LOOKUPSWITCH def n pairs) = do+ putByte 171+ offset <- getOffset+ let pads = 4 - (offset `mod` 4)+ replicateM (fromIntegral pads) (putByte 0)+ put def+ put n+ forM_ pairs put+ put IRETURN = putByte 172+ put LRETURN = putByte 173+ put FRETURN = putByte 174+ put DRETURN = putByte 175+ put RETURN = putByte 177+ put (GETSTATIC x) = put1 178 x+ put (PUTSTATIC x) = put1 179 x+ put (GETFIELD x) = put1 180 x+ put (PUTFIELD x) = put1 181 x+ put (INVOKEVIRTUAL x) = put1 182 x+ put (INVOKESPECIAL x) = put1 183 x+ put (INVOKESTATIC x) = put1 184 x+ put (INVOKEINTERFACE x c) = put2 185 x c >> putByte 0+ put (NEW x) = put1 187 x+ put (NEWARRAY x) = put1 188 x+ put (ANEWARRAY x) = put1 189 x+ put ARRAYLENGTH = putByte 190+ put ATHROW = putByte 191+ put (CHECKCAST x) = put1 192 x+ put (INSTANCEOF x) = put1 193 x+ put MONITORENTER = putByte 194+ put MONITOREXIT = putByte 195+ put (WIDE x inst) = put2 196 x inst+ put (MULTINANEWARRAY x y) = put2 197 x y+ put (IFNULL x) = put1 198 x+ put (IFNONNULL x) = put1 199 x+ put (GOTO_W x) = put1 200 x+ put (JSR_W x) = put1 201 x++ get = do+ c <- getByte+ case c of+ 0 -> return NOP+ 1 -> return ACONST_NULL+ 2 -> return ICONST_M1+ 3 -> return ICONST_0+ 4 -> return ICONST_1+ 5 -> return ICONST_2+ 6 -> return ICONST_3+ 7 -> return ICONST_4+ 8 -> return ICONST_5+ 9 -> return LCONST_0+ 10 -> return LCONST_1+ 11 -> return FCONST_0+ 12 -> return FCONST_1+ 13 -> return FCONST_2+ 14 -> return DCONST_0+ 15 -> return DCONST_1+ 16 -> BIPUSH <$> get+ 17 -> SIPUSH <$> get+ 18 -> LDC1 <$> get+ 19 -> LDC2 <$> get+ 20 -> LDC2W <$> get+ 21 -> ILOAD <$> get+ 22 -> LLOAD <$> get+ 23 -> FLOAD <$> get+ 24 -> DLOAD <$> get+ 25 -> ALOAD <$> get+ 46 -> return IALOAD+ 47 -> return LALOAD+ 48 -> return FALOAD+ 49 -> return DALOAD+ 50 -> return AALOAD+ 51 -> return BALOAD+ 52 -> return CALOAD+ 53 -> return SALOAD+ 54 -> ISTORE <$> get+ 55 -> LSTORE <$> get+ 56 -> FSTORE <$> get+ 57 -> DSTORE <$> get+ 58 -> ASTORE <$> get+ 79 -> return IASTORE+ 80 -> return LASTORE+ 81 -> return FASTORE+ 82 -> return DASTORE+ 83 -> return AASTORE+ 84 -> return BASTORE+ 85 -> return CASTORE+ 86 -> return SASTORE+ 87 -> return POP+ 88 -> return POP2+ 89 -> return DUP+ 90 -> return DUP_X1+ 91 -> return DUP_X2+ 92 -> return DUP2+ 93 -> return DUP2_X1 + 94 -> return DUP2_X2+ 95 -> return SWAP+ 96 -> return IADD+ 97 -> return LADD+ 98 -> return FADD+ 99 -> return DADD+ 100 -> return ISUB+ 101 -> return LSUB+ 102 -> return FSUB+ 103 -> return DSUB+ 104 -> return IMUL+ 105 -> return LMUL+ 106 -> return FMUL+ 107 -> return DMUL+ 108 -> return IDIV+ 109 -> return LDIV+ 110 -> return FDIV+ 111 -> return DDIV+ 112 -> return IREM+ 113 -> return LREM+ 114 -> return FREM+ 115 -> return DREM+ 116 -> return INEG+ 117 -> return LNEG+ 118 -> return FNEG+ 119 -> return DNEG+ 120 -> return ISHL+ 121 -> return LSHL+ 122 -> return ISHR+ 123 -> return LSHR+ 124 -> return IUSHR+ 125 -> return LUSHR+ 126 -> return IAND+ 127 -> return LAND+ 128 -> return IOR+ 129 -> return LOR+ 130 -> return IXOR+ 131 -> return LXOR+ 132 -> IINC <$> get <*> get+ 133 -> return I2L+ 134 -> return I2F+ 135 -> return I2D+ 136 -> return L2I+ 137 -> return L2F+ 138 -> return L2D+ 139 -> return F2I+ 140 -> return F2L+ 141 -> return F2D+ 142 -> return D2I+ 143 -> return D2L+ 144 -> return D2F+ 145 -> return I2B+ 146 -> return I2C+ 147 -> return I2S+ 148 -> return LCMP+ 149 -> return $ FCMP C_LT+ 150 -> return $ FCMP C_GT+ 151 -> return $ DCMP C_LT+ 152 -> return $ DCMP C_GT+ 165 -> IF_ACMP C_EQ <$> get+ 166 -> IF_ACMP C_NE <$> get+ 167 -> return GOTO+ 168 -> JSR <$> get+ 169 -> return RET+ 170 -> do+ offset <- bytesRead+ let pads = 4 - (offset `mod` 4)+ skip (fromIntegral pads)+ def <- get+ low <- get+ high <- get+ offs <- replicateM (fromIntegral $ high - low + 1) get+ return $ TABLESWITCH def low high offs+ 171 -> do+ offset <- bytesRead+ let pads = 4 - (offset `mod` 4)+ skip (fromIntegral pads)+ def <- get+ n <- get+ pairs <- replicateM (fromIntegral n) get+ return $ LOOKUPSWITCH def n pairs+ 172 -> return IRETURN+ 173 -> return LRETURN+ 174 -> return FRETURN+ 175 -> return DRETURN+ 177 -> return RETURN+ 178 -> GETSTATIC <$> get+ 179 -> PUTSTATIC <$> get+ 180 -> GETFIELD <$> get+ 181 -> PUTFIELD <$> get+ 182 -> INVOKEVIRTUAL <$> get+ 183 -> INVOKESPECIAL <$> get+ 184 -> INVOKESTATIC <$> get+ 185 -> (INVOKEINTERFACE <$> get <*> get) <* skip 1+ 187 -> NEW <$> get+ 188 -> NEWARRAY <$> get+ 189 -> ANEWARRAY <$> get+ 190 -> return ARRAYLENGTH+ 191 -> return ATHROW+ 192 -> CHECKCAST <$> get+ 193 -> INSTANCEOF <$> get+ 194 -> return MONITORENTER+ 195 -> return MONITOREXIT+ 196 -> WIDE <$> get <*> get+ 197 -> MULTINANEWARRAY <$> get <*> get+ 198 -> IFNULL <$> get+ 199 -> IFNONNULL <$> get+ 200 -> GOTO_W <$> get+ 201 -> JSR_W <$> get+ _ | inRange (59, 62) c -> imm 59 ISTORE_ c+ | inRange (63, 66) c -> imm 63 LSTORE_ c+ | inRange (67, 70) c -> imm 67 FSTORE_ c+ | inRange (71, 74) c -> imm 71 DSTORE_ c+ | inRange (75, 78) c -> imm 75 ASTORE_ c+ | inRange (26, 29) c -> imm 26 ILOAD_ c+ | inRange (30, 33) c -> imm 30 LLOAD_ c+ | 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 (159, 164) c -> IF_ICMP (toEnum $ fromIntegral $ c-159) <$> get+ | otherwise -> fail $ "Unknown instruction byte code: " ++ show c+ +-- | Decode Java method+decodeMethod :: B.ByteString -> Code+decodeMethod str = decodeS (0 :: Integer) str++-- | Encode Java method+encodeMethod :: Code -> B.ByteString+encodeMethod code = encodeS (0 :: Integer) code+
+ JVM/ClassFile.hs view
@@ -0,0 +1,380 @@+{-# LANGUAGE RecordWildCards, BangPatterns #-}+-- | 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 (..),+ FieldType (..),+ FieldSignature, MethodSignature (..), ReturnSignature (..),+ ArgumentSignature (..)+ )+ where++import Control.Monad+import Control.Applicative+import Data.Binary+import Data.Binary.IEEE754+import Data.Binary.Get+import Data.Binary.Put+import Data.Char+import Data.List+import qualified Data.ByteString.Lazy as B++-- | Read one-byte Char+getChar8 :: Get Char+getChar8 = do+ x <- getWord8+ return $ chr (fromIntegral x)++-- | Generic .class file format+data ClassFile = ClassFile {+ 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+ interfacesCount :: Word16, -- ^ Number of implemented interfaces+ interfaces :: [Word16], -- ^ Constants pool item indexes for implemented interfaces+ classFieldsCount :: Word16, -- ^ Number of class fileds+ classFields :: [FieldInfo], -- ^ Class fields+ classMethodsCount :: Word16, -- ^ Number of class methods+ classMethods :: [MethodInfo], -- ^ Class methods+ classAttributesCount :: Word16, -- ^ Number of class attributes+ classAttributes :: [AttributeInfo] -- ^ Class attributes+ }+ deriving (Eq, Show)++instance Binary ClassFile where+ put (ClassFile {..}) = do+ put magic+ put minorVersion+ put majorVersion+ put constsPoolSize+ forM_ constsPool put+ put accessFlags+ put thisClass+ put superClass+ put interfacesCount+ forM_ interfaces put+ put classFieldsCount+ forM_ classFields put+ put classMethodsCount+ forM_ classMethods put+ put classAttributesCount+ forM_ classAttributes put++ get = do+ magic <- get+ minor <- get+ major <- get+ poolsize <- get+ pool <- replicateM (fromIntegral poolsize - 1) get+ af <- get+ this <- get+ super <- get+ interfacesCount <- get+ ifaces <- replicateM (fromIntegral interfacesCount) get+ classFieldsCount <- get+ classFields <- replicateM (fromIntegral classFieldsCount) get+ classMethodsCount <- get+ 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++-- | Field signature format+data FieldType =+ SignedByte -- ^ B+ | CharByte -- ^ C+ | DoubleType -- ^ D+ | FloatType -- ^ F+ | IntType -- ^ I+ | LongInt -- ^ J+ | ShortInt -- ^ S+ | BoolType -- ^ Z+ | ObjectType String -- ^ L @{class name}@+ | Array (Maybe Int) FieldType -- ^ @[{type}@+ deriving (Eq)++instance Show FieldType where+ show SignedByte = "byte"+ show CharByte = "char"+ show DoubleType = "double"+ show FloatType = "float"+ show IntType = "int"+ show LongInt = "long"+ show ShortInt = "short"+ show BoolType = "bool"+ show (ObjectType s) = "Object " ++ s+ show (Array Nothing t) = show t ++ "[]"+ show (Array (Just n) t) = show t ++ "[" ++ show n ++ "]"++-- | Class field signature+type FieldSignature = FieldType++-- | Try to read integer value from decimal representation+getInt :: Get (Maybe Int)+getInt = do+ s <- getDigits+ if null s+ then return Nothing+ else return $ Just (read s)+ where+ getDigits :: Get [Char]+ getDigits = do+ c <- lookAhead getChar8+ if isDigit c+ then do+ skip 1+ next <- getDigits+ return (c: next)+ else return []++putString :: String -> Put+putString str = forM_ str put++instance Binary FieldType where+ put SignedByte = put 'B'+ put CharByte = put 'C'+ put DoubleType = put 'D'+ put FloatType = put 'F'+ put IntType = put 'I'+ put LongInt = put 'J'+ put ShortInt = put 'S'+ put BoolType = put 'Z'+ put (ObjectType name) = put 'L' >> putString name >> put ';'+ put (Array Nothing sig) = put '[' >> put sig+ put (Array (Just n) sig) = put '[' >> put (show n) >> put sig++ get = do+ b <- getChar8+ case b of+ 'B' -> return SignedByte+ 'C' -> return CharByte+ 'D' -> return DoubleType+ 'F' -> return FloatType+ 'I' -> return IntType+ 'J' -> return LongInt+ 'S' -> return ShortInt+ 'Z' -> return BoolType+ 'L' -> do+ name <- getToSemicolon+ return (ObjectType name)+ '[' -> do+ mbSize <- getInt+ sig <- get+ return (Array mbSize sig)+ _ -> fail $ "Unknown signature opening symbol: " ++ [b]++-- | Read string up to `;'+getToSemicolon :: Get String+getToSemicolon = do+ x <- get+ if x == ';'+ then return []+ else do+ next <- getToSemicolon+ return (x: next)++-- | Return value signature+data ReturnSignature =+ Returns FieldType+ | ReturnsVoid+ deriving (Eq)++instance Show ReturnSignature where+ show (Returns t) = show t+ show ReturnsVoid = "Void"++instance Binary ReturnSignature where+ put (Returns sig) = put sig+ put ReturnsVoid = put 'V'++ get = do+ x <- lookAhead getChar8+ case x of+ 'V' -> skip 1 >> return ReturnsVoid+ _ -> Returns <$> get++-- | Method argument signature+type ArgumentSignature = FieldType++-- | Class method argument signature+data MethodSignature =+ MethodSignature [ArgumentSignature] ReturnSignature+ deriving (Eq)++instance Show MethodSignature where+ show (MethodSignature args ret) = "(" ++ intercalate ", " (map show args) ++ ") returns " ++ show ret++instance Binary MethodSignature where+ put (MethodSignature args ret) = do+ put '('+ forM_ args put+ put ')'+ put ret++ get = do+ x <- getChar8+ when (x /= '(') $+ fail "Cannot parse method signature: no starting `(' !"+ args <- getArgs+ y <- getChar8+ when (y /= ')') $+ fail "Internal error: method signature without `)' !?"+ ret <- get+ return (MethodSignature args ret)++-- | Read arguments signatures (up to `)')+getArgs :: Get [ArgumentSignature]+getArgs = whileJust getArg+ where+ getArg :: Get (Maybe ArgumentSignature)+ getArg = do+ x <- lookAhead getChar8+ if x == ')'+ then return Nothing+ else Just <$> get++whileJust :: (Monad m) => m (Maybe a) -> m [a]+whileJust m = do+ r <- m+ case r of+ Just x -> do+ next <- whileJust m+ 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++ get = do+ !offset <- bytesRead+ tag <- getWord8+ case tag of+ 1 -> do+ l <- get+ bs <- getLazyByteString (fromIntegral l)+ return $ CONSTANT_Utf8 l 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+ _ -> fail $ "Unknown constants pool entry tag: " ++ show tag++-- | Class field format+data FieldInfo = FieldInfo {+ fieldAccessFlags :: Word16,+ fieldNameIndex :: Word16,+ fieldSignatureIndex :: Word16,+ fieldAttributesCount :: Word16,+ fieldAttributes :: [AttributeInfo] }+ deriving (Eq, Show)++instance Binary FieldInfo where+ put (FieldInfo {..}) = do+ put fieldAccessFlags + put fieldNameIndex+ put fieldSignatureIndex+ put fieldAttributesCount+ forM_ fieldAttributes put++ get = do+ af <- get+ ni <- get+ si <- get+ n <- get+ as <- replicateM (fromIntegral n) get+ return $ FieldInfo af ni si n as++-- | Class method format+data MethodInfo = MethodInfo {+ methodAccessFlags :: Word16,+ methodNameIndex :: Word16,+ methodSignatureIndex :: Word16,+ methodAttributesCount :: Word16,+ methodAttributes :: [AttributeInfo] }+ deriving (Eq, Show)++instance Binary MethodInfo where+ put (MethodInfo {..}) = do+ put methodAccessFlags+ put methodNameIndex + put methodSignatureIndex+ put methodAttributesCount + forM_ methodAttributes put++ get = do+ offset <- bytesRead+ af <- get+ ni <- get+ si <- get+ n <- get+ as <- replicateM (fromIntegral n) get+ return $ MethodInfo af ni si n as++-- | Any (class/ field/ method/ ...) attribute format.+-- Some formats specify special formats for @attributeValue@.+data AttributeInfo = AttributeInfo {+ attributeName :: Word16,+ attributeLength :: Word32,+ attributeValue :: B.ByteString }+ deriving (Eq, Show)++instance Binary AttributeInfo where+ put (AttributeInfo {..}) = do+ put attributeName+ putWord32be attributeLength+ putLazyByteString attributeValue++ get = do+ offset <- bytesRead+ name <- get+ len <- getWord32be+ value <- getLazyByteString (fromIntegral len)+ return $ AttributeInfo name len value+
+ JVM/Converter.hs view
@@ -0,0 +1,237 @@+{-# LANGUAGE TypeFamilies, StandaloneDeriving, FlexibleInstances, FlexibleContexts, UndecidableInstances, RecordWildCards, OverloadedStrings #-}+-- | Functions to convert from low-level .class format representation and+-- high-level Java classes, methods etc representation+module JVM.Converter+ (parseClass, parseClassFile,+ convertClass, classFile,+ encodeClass,+ methodByName,+ attrByName,+ methodCode+ )+ where++import Control.Monad.Exception+import Data.List+import Data.Word+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.Exceptions++-- | Parse .class file data+parseClass :: B.ByteString -> Class+parseClass bstr = convertClass $ decode bstr++-- | Parse class data from file+parseClassFile :: FilePath -> IO Class+parseClassFile path = convertClass `fmap` decodeFile path++encodeClass :: Class -> B.ByteString+encodeClass cls = encode $ classFile cls++convertClass :: ClassFile -> Class+convertClass (ClassFile {..}) =+ 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 }++classFile :: Class -> ClassFile+classFile (Class {..}) = ClassFile {+ magic = 0xCAFEBABE,+ minorVersion = 0,+ majorVersion = 50,+ constsPoolSize = fromIntegral (length 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) }+ where+ poolInfo = toCPInfo constantPool++toCPInfo :: Pool -> [CpInfo]+toCPInfo pool = result+ where+ result = map cpInfo $ elems pool++ cpInfo (CClass name) = CONSTANT_Class (force "class" $ poolIndex result name)+ cpInfo (CField cls name) =+ CONSTANT_Fieldref (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)+ 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+ 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++-- | 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+ 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 _ = 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+ Nothing -> throw (NoItemInPool name)+ Just i -> case findIndex (checkClass $ fromIntegral $ i+1) 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 _ = False++ checkClass i (CONSTANT_Class 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+ Nothing -> throw (NoItemInPool x)+ Just i -> return $ fromIntegral (i+1)+ where+ check ni ti (CONSTANT_NameAndType 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) }++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) }++attrInfo :: [CpInfo] -> (B.ByteString, B.ByteString) -> AttributeInfo+attrInfo pool (name, value) = AttributeInfo {+ attributeName = force "attr name" $ poolIndex pool name,+ attributeLength = fromIntegral (B.length value),+ attributeValue = value }++constantPoolArray :: [CpInfo] -> Pool+constantPoolArray list = pool+ where+ pool :: Pool+ pool = listArray (1,n) $ map convert list+ n = fromIntegral $ length list++ 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++convertAccess :: Word16 -> Access+convertAccess w = S.fromList $ concat $ zipWith (\i f -> if testBit w i then [f] else []) [0..] $ [+ ACC_PUBLIC,+ ACC_PRIVATE,+ ACC_PROTECTED,+ ACC_STATIC,+ ACC_FINAL,+ ACC_SYNCHRONIZED,+ ACC_VOLATILE,+ ACC_TRANSIENT,+ ACC_NATIVE,+ ACC_INTERFACE,+ ACC_ABSTRACT ]++access2word16 :: Access -> Word16+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 }++convertMethod :: Pool -> MethodInfo -> Method+convertMethod pool (MethodInfo {..}) = Method {+ methodAccess = convertAccess methodAccessFlags,+ methodName = getString $ pool ! methodNameIndex,+ methodSignature = decode $ getString $ pool ! methodSignatureIndex,+ methodAttrs = convertAttrs pool methodAttributes }++convertAttrs :: Pool -> [AttributeInfo] -> Attributes+convertAttrs pool attrs = M.fromList $ map go attrs+ where+ go (AttributeInfo {..}) = (getString $ pool ! attributeName,+ attributeValue)++-- | Try to get class method by name+methodByName :: Class -> B.ByteString -> Maybe Method+methodByName cls name =+ find (\m -> methodName m == name) (methods 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)++-- | Try to get Code for class method (no Code for interface methods)+methodCode :: Class+ -> B.ByteString -- ^ Method name+ -> Maybe B.ByteString+methodCode cls name = do+ method <- methodByName cls name+ attrByName method "Code"+
+ JVM/Types.hs view
@@ -0,0 +1,162 @@+{-# 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)+
+ LICENSE view
@@ -0,0 +1,165 @@+ GNU LESSER GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.+++ This version of the GNU Lesser General Public License incorporates+the terms and conditions of version 3 of the GNU General Public+License, supplemented by the additional permissions listed below.++ 0. Additional Definitions. ++ As used herein, "this License" refers to version 3 of the GNU Lesser+General Public License, and the "GNU GPL" refers to version 3 of the GNU+General Public License.++ "The Library" refers to a covered work governed by this License,+other than an Application or a Combined Work as defined below.++ An "Application" is any work that makes use of an interface provided+by the Library, but which is not otherwise based on the Library.+Defining a subclass of a class defined by the Library is deemed a mode+of using an interface provided by the Library.++ A "Combined Work" is a work produced by combining or linking an+Application with the Library. The particular version of the Library+with which the Combined Work was made is also called the "Linked+Version".++ The "Minimal Corresponding Source" for a Combined Work means the+Corresponding Source for the Combined Work, excluding any source code+for portions of the Combined Work that, considered in isolation, are+based on the Application, and not on the Linked Version.++ The "Corresponding Application Code" for a Combined Work means the+object code and/or source code for the Application, including any data+and utility programs needed for reproducing the Combined Work from the+Application, but excluding the System Libraries of the Combined Work.++ 1. Exception to Section 3 of the GNU GPL.++ You may convey a covered work under sections 3 and 4 of this License+without being bound by section 3 of the GNU GPL.++ 2. Conveying Modified Versions.++ If you modify a copy of the Library, and, in your modifications, a+facility refers to a function or data to be supplied by an Application+that uses the facility (other than as an argument passed when the+facility is invoked), then you may convey a copy of the modified+version:++ a) under this License, provided that you make a good faith effort to+ ensure that, in the event an Application does not supply the+ function or data, the facility still operates, and performs+ whatever part of its purpose remains meaningful, or++ b) under the GNU GPL, with none of the additional permissions of+ this License applicable to that copy.++ 3. Object Code Incorporating Material from Library Header Files.++ The object code form of an Application may incorporate material from+a header file that is part of the Library. You may convey such object+code under terms of your choice, provided that, if the incorporated+material is not limited to numerical parameters, data structure+layouts and accessors, or small macros, inline functions and templates+(ten or fewer lines in length), you do both of the following:++ a) Give prominent notice with each copy of the object code that the+ Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the object code with a copy of the GNU GPL and this license+ document.++ 4. Combined Works.++ You may convey a Combined Work under terms of your choice that,+taken together, effectively do not restrict modification of the+portions of the Library contained in the Combined Work and reverse+engineering for debugging such modifications, if you also do each of+the following:++ a) Give prominent notice with each copy of the Combined Work that+ the Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the Combined Work with a copy of the GNU GPL and this license+ document.++ c) For a Combined Work that displays copyright notices during+ execution, include the copyright notice for the Library among+ these notices, as well as a reference directing the user to the+ copies of the GNU GPL and this license document.++ d) Do one of the following:++ 0) Convey the Minimal Corresponding Source under the terms of this+ License, and the Corresponding Application Code in a form+ suitable for, and under terms that permit, the user to+ recombine or relink the Application with a modified version of+ the Linked Version to produce a modified Combined Work, in the+ manner specified by section 6 of the GNU GPL for conveying+ Corresponding Source.++ 1) Use a suitable shared library mechanism for linking with the+ Library. A suitable mechanism is one that (a) uses at run time+ a copy of the Library already present on the user's computer+ system, and (b) will operate properly with a modified version+ of the Library that is interface-compatible with the Linked+ Version. ++ e) Provide Installation Information, but only if you would otherwise+ be required to provide such information under section 6 of the+ GNU GPL, and only to the extent that such information is+ necessary to install and execute a modified version of the+ Combined Work produced by recombining or relinking the+ Application with a modified version of the Linked Version. (If+ you use option 4d0, the Installation Information must accompany+ the Minimal Corresponding Source and Corresponding Application+ Code. If you use option 4d1, you must provide the Installation+ Information in the manner specified by section 6 of the GNU GPL+ for conveying Corresponding Source.)++ 5. Combined Libraries.++ You may place library facilities that are a work based on the+Library side by side in a single library together with other library+facilities that are not Applications and are not covered by this+License, and convey such a combined library under terms of your+choice, if you do both of the following:++ a) Accompany the combined library with a copy of the same work based+ on the Library, uncombined with any other library facilities,+ conveyed under the terms of this License.++ b) Give prominent notice with the combined library that part of it+ is a work based on the Library, and explaining where to find the+ accompanying uncombined form of the same work.++ 6. Revised Versions of the GNU Lesser General Public License.++ The Free Software Foundation may publish revised and/or new versions+of the GNU Lesser General Public License from time to time. Such new+versions will be similar in spirit to the present version, but may+differ in detail to address new problems or concerns.++ Each version is given a distinguishing version number. If the+Library as you received it specifies that a certain numbered version+of the GNU Lesser General Public License "or any later version"+applies to it, you have the option of following the terms and+conditions either of that published version or of any later version+published by the Free Software Foundation. If the Library as you+received it does not specify a version number of the GNU Lesser+General Public License, you may choose any version of the GNU Lesser+General Public License ever published by the Free Software Foundation.++ If the Library as you received it specifies that a proxy can decide+whether future versions of the GNU Lesser General Public License shall+apply, that proxy's public statement of acceptance of any version is+permanent authorization for you to choose that version for the+Library.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ dump-class.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Control.Monad+import Data.Array+import System.Environment+import qualified Data.ByteString.Lazy as B+import Text.Printf++import JVM.Types+import JVM.Converter+import JVM.Assembler++main = do+ args <- getArgs+ case args of+ [clspath] -> do+ 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++ _ -> error "Synopsis: dump-class File.class"+
+ hs-java.cabal view
@@ -0,0 +1,29 @@+Name: hs-java+Version: 0.1+Cabal-Version: >= 1.6+License: BSD3+License-File: LICENSE+Author: Ilya V. Portnov+Maintainer: portnov84@rambler.ru+Synopsis: Java .class files assembler/disassembler+Category: Jvm+Build-Type: Simple+Description: This package declares data types for Java .class files format and functions+ to assemble/disassemble Java bytecode.++Extra-source-files: dump-class.hs++library+ Exposed-Modules: JVM.Types+ JVM.ClassFile+ JVM.Assembler+ JVM.Converter++ Build-Depends: base >= 3 && <= 5, haskell98, containers, binary,+ mtl, directory, filepath, utf8-string, array,+ bytestring, data-binary-ieee754, binary-state,+ control-monad-exception++ ghc-options: -fwarn-unused-imports++