jvm-binary (empty) → 0.0.1
raw patch · 27 files changed
+2081/−0 lines, 27 filesdep +basedep +binarydep +bytestringsetup-changed
Dependencies added: base, binary, bytestring, containers, criterion, directory, filepath, jvm-binary, tasty, tasty-discover, tasty-hspec, tasty-quickcheck, text, vector
Files
- CHANGELOG.md +7/−0
- LICENSE.md +23/−0
- README.md +31/−0
- Setup.hs +7/−0
- benchmark/Main.hs +15/−0
- jvm-binary.cabal +94/−0
- package.yaml +68/−0
- src/Language/JVM.hs +35/−0
- src/Language/JVM/AccessFlag.hs +114/−0
- src/Language/JVM/Attribute.hs +99/−0
- src/Language/JVM/Attribute/Code.hs +665/−0
- src/Language/JVM/ClassFile.hs +90/−0
- src/Language/JVM/Constant.hs +180/−0
- src/Language/JVM/Field.hs +30/−0
- src/Language/JVM/Method.hs +62/−0
- src/Language/JVM/Utils.hs +157/−0
- stack.yaml +6/−0
- test-suite/Language/JVM/Attribute/CodeTest.hs +84/−0
- test-suite/Language/JVM/AttributeTest.hs +21/−0
- test-suite/Language/JVM/ClassFileTest.hs +33/−0
- test-suite/Language/JVM/ConstantTest.hs +42/−0
- test-suite/Language/JVM/FieldTest.hs +19/−0
- test-suite/Language/JVM/MethodTest.hs +19/−0
- test-suite/Language/JVM/UtilsTest.hs +22/−0
- test-suite/Language/JVMTest.hs +30/−0
- test-suite/SpecHelper.hs +68/−0
- test-suite/Test.hs +60/−0
+ CHANGELOG.md view
@@ -0,0 +1,7 @@+# Change log++jvm-binary uses [Semantic Versioning][].+The change log is available through the [releases on GitHub][].++[Semantic Versioning]: http://semver.org/spec/v2.0.0.html+[releases on GitHub]: https://github.com/kalhauge/jvm-binary/releases
+ LICENSE.md view
@@ -0,0 +1,23 @@+[The MIT License (MIT)][]++Copyright (c) 2017 Christian Gram Kalhauge++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies+of the Software, and to permit persons to whom the Software is furnished to do+so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.++[The MIT License (MIT)]: https://opensource.org/licenses/MIT
+ README.md view
@@ -0,0 +1,31 @@+# jvm-binary++A library for reading and writing Java class-files. To get started+importing the `Language.JVM` file should be sufficient for most uses.++If you want to access Code elements of methods it is recommended to +import `Language.JVM.Attribute.Code` qualified, like this:++```haskell+import Language.JVM+import qualified Language.JVM.Attribute.Code as Code+```++## Todo's++- Add more Attributes as to the+[docs](http://docs.oracle.com/javase/specs/jvms/se7/html/jvms-4.html#jvms-4.7).+The most notable and required are:++ - ConstantValue+ - Exceptions+ - Signature (for Java 6 support)+ - StackMapTable (for Java 7 support)+ - BootstrapMethods (for Java 8 support)++ - LineNumberTable++## Developing++Use stack to build, test, and benchmark.+
+ Setup.hs view
@@ -0,0 +1,7 @@+-- This script is used to build and install your package. Typically you don't+-- need to change it. The Cabal documentation has more information about this+-- file: <https://www.haskell.org/cabal/users-guide/installing-packages.html>.+import qualified Distribution.Simple++main :: IO ()+main = Distribution.Simple.defaultMain
+ benchmark/Main.hs view
@@ -0,0 +1,15 @@+-- You can benchmark your code quickly and effectively with Criterion. See its+-- website for help: <http://www.serpentine.com/criterion/>.+import Criterion.Main++import Language.JVM++import Data.ByteString.Lazy as BL++main :: IO ()+main = defaultMain+ [ bench "simple load" (+ whnfIO $ decodeClassFile <$>+ BL.readFile "test-suite/data/project/Main.class"+ )+ ]
+ jvm-binary.cabal view
@@ -0,0 +1,94 @@+-- This file has been generated from package.yaml by hpack version 0.17.1.+--+-- see: https://github.com/sol/hpack++name: jvm-binary+version: 0.0.1+synopsis: A library for reading Java class-files+description: A library for reading Java class-files+category: Language+homepage: https://github.com/kalhauge/jvm-binary#readme+bug-reports: https://github.com/kalhauge/jvm-binary/issues+maintainer: Christian Gram Kalhauge+license: MIT+license-file: LICENSE.md+build-type: Simple+cabal-version: >= 1.10++extra-source-files:+ CHANGELOG.md+ LICENSE.md+ package.yaml+ README.md+ stack.yaml++source-repository head+ type: git+ location: https://github.com/kalhauge/jvm-binary++library+ hs-source-dirs:+ src+ ghc-options: -Wall+ build-depends:+ base >= 4.9 && < 4.10+ , binary+ , bytestring+ , containers+ , text+ , vector+ exposed-modules:+ Language.JVM+ Language.JVM.AccessFlag+ Language.JVM.Attribute+ Language.JVM.Attribute.Code+ Language.JVM.ClassFile+ Language.JVM.Constant+ Language.JVM.Field+ Language.JVM.Method+ Language.JVM.Utils+ default-language: Haskell2010++test-suite jvm-binary-test-suite+ type: exitcode-stdio-1.0+ main-is: Test.hs+ hs-source-dirs:+ test-suite+ ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N -fno-warn-orphans+ build-depends:+ base >= 4.9 && < 4.10+ , jvm-binary+ , tasty+ , tasty-hspec+ , tasty-discover+ , tasty-quickcheck+ , binary+ , bytestring+ , containers+ , filepath+ , directory+ , text+ other-modules:+ Language.JVM.Attribute.CodeTest+ Language.JVM.AttributeTest+ Language.JVM.ClassFileTest+ Language.JVM.ConstantTest+ Language.JVM.FieldTest+ Language.JVM.MethodTest+ Language.JVM.UtilsTest+ Language.JVMTest+ SpecHelper+ default-language: Haskell2010++benchmark jvm-binary-benchmarks+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs:+ benchmark+ ghc-options: -Wall -rtsopts -threaded -funbox-strict-fields -with-rtsopts=-N+ build-depends:+ base >= 4.9 && < 4.10+ , jvm-binary+ , criterion+ , bytestring+ default-language: Haskell2010
+ package.yaml view
@@ -0,0 +1,68 @@+name: jvm-binary+version: '0.0.1'+maintainer: Christian Gram Kalhauge+synopsis: A library for reading Java class-files++license: MIT+license-file: LICENSE.md+category: Language+github: kalhauge/jvm-binary++description: A library for reading Java class-files++ghc-options: -Wall++extra-source-files:+- CHANGELOG.md+- LICENSE.md+- package.yaml+- README.md+- stack.yaml++library:+ dependencies:+ - base >= 4.9 && < 4.10+ - binary+ - bytestring+ - containers+ - text+ - vector+ source-dirs: src++tests:+ jvm-binary-test-suite:+ dependencies:+ - base >= 4.9 && < 4.10+ - jvm-binary+ - tasty+ - tasty-hspec+ - tasty-discover+ - tasty-quickcheck+ - binary+ - bytestring+ - containers+ - filepath+ - directory+ - text+ ghc-options:+ - -rtsopts+ - -threaded+ - -with-rtsopts=-N+ - -fno-warn-orphans+ main: Test.hs+ source-dirs: test-suite++benchmarks:+ jvm-binary-benchmarks:+ dependencies:+ - base >= 4.9 && < 4.10+ - jvm-binary+ - criterion+ - bytestring+ ghc-options:+ - -rtsopts+ - -threaded+ - -funbox-strict-fields+ - -with-rtsopts=-N+ main: Main.hs+ source-dirs: benchmark
+ src/Language/JVM.hs view
@@ -0,0 +1,35 @@+{-|+Module : Language.JVM+Copyright : (c) Christian Gram Kalhauge, 2017+License : MIT+Maintainer : kalhuage@cs.ucla.edu++The main entry point for using the library.+-}++module Language.JVM+ ( decodeClassFile++ , module Language.JVM.Attribute+ , module Language.JVM.ClassFile+ , module Language.JVM.Constant+ , module Language.JVM.Field+ , module Language.JVM.Method+ ) where++import qualified Data.ByteString.Lazy as BL+import Data.Binary++import Language.JVM.Attribute+import Language.JVM.ClassFile+import Language.JVM.Constant+import Language.JVM.Field+import Language.JVM.Method++-- | Create a class file form a lazy byte string+decodeClassFile :: BL.ByteString -> Either String ClassFile+decodeClassFile bs = do+ case decodeOrFail bs of+ Right (_, _, cf) -> Right cf+ Left (_, _, msg) -> Left msg+
+ src/Language/JVM/AccessFlag.hs view
@@ -0,0 +1,114 @@+{-|+Module : Language.JVM.AccessFlag+Copyright : (c) Christian Gram Kalhauge, 2017+License : MIT+Maintainer : kalhuage@cs.ucla.edu++Contains the AccessFlags used in the different modules.+-}++module Language.JVM.AccessFlag+ ( MAccessFlag(..), mflags+ , FAccessFlag(..), fflags+ , CAccessFlag(..), cflags+ ) where++import Language.JVM.Utils++-- | Access flags for the 'Language.JVM.Method.Method'+data MAccessFlag+ = MPublic+ | MPrivate+ | MProtected+ | MStatic+ | MFinal+ | MSynchronized+ | MBridge+ | MVarargs+ | MNative+ | MAbstract+ | MStrictFP+ | MSynthetic+ deriving (Ord, Show, Eq)+++-- | The 'Enumish' mapping of the 'MAccessFlag'+mflags :: [(Int, MAccessFlag)]+mflags =+ [ (0, MPublic)+ , (1, MPrivate)+ , (2, MProtected)+ , (3, MStatic)+ , (4, MFinal)+ , (5, MSynchronized)+ , (6, MBridge)+ , (7, MVarargs)+ , (8, MNative)+ , (10, MAbstract)+ , (11, MStrictFP)+ , (12, MSynthetic)+ ]++instance Enumish MAccessFlag where+ inOrder = mflags++-- | Access flags for the 'Language.JVM.ClassFile.ClassFile'+data CAccessFlag+ = CPublic+ | CFinal+ | CSuper+ | CAbstract+ | CSynthetic+ | CAnnotation+ | CEnum+ deriving (Ord, Show, Eq)++-- | The 'Enumish' mapping of the 'CAccessFlag'+cflags :: [(Int, CAccessFlag)]+cflags =+ [ (0, CPublic)+ , (4, CFinal)+ , (5, CSuper)+ , (10, CAbstract)+ , (12, CSynthetic)+ , (13, CAnnotation)+ , (14, CEnum)+ ]++instance Enumish CAccessFlag where+ inOrder = cflags++-- | Access flags for the 'Language.JVM.Field.Field'+data FAccessFlag+ = FPublic+ | FPrivate+ | FProtected+ | FStatic+ | FFinal+ | FSynchronized+ | FUnused6+ | FVolatile+ | FTransient+ | FSynthetic+ | FEnum+ deriving (Ord, Show, Eq)++-- | The 'Enumish' mapping of the 'FAccessFlag'+fflags :: [(Int, FAccessFlag)]+fflags =+ [ (0, FPublic)+ , (1, FPrivate)+ , (2, FProtected)+ , (3, FStatic)+ , (4, FFinal)+ , (5, FSynchronized)+ , (6, FUnused6)+ , (7, FVolatile)+ , (8, FTransient)+ , (13, FSynthetic)+ , (15, FEnum)+ ]++instance Enumish FAccessFlag where+ inOrder = fflags+
+ src/Language/JVM/Attribute.hs view
@@ -0,0 +1,99 @@+{-|+Module : Language.JVM.Attribute+Copyright : (c) Christian Gram Kalhauge, 2017+License : MIT+Maintainer : kalhuage@cs.ucla.edu++This is the main module for accessing all kinds of Attributes.+-}++{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Language.JVM.Attribute+ ( Attribute (..)+ , aInfo++ , aName++ , IsAttribute (..)+ -- SubAttributes+-- , module Language.JVM.Attribute.Code+ , Code++ , Const++ ) where++import GHC.Generics (Generic)++import Data.Bifunctor+import Data.Binary+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import Data.Text as Text++import Language.JVM.Constant (ConstantPool, ConstantRef,+ lookupText)+import Language.JVM.Utils (SizedByteString32, trd,+ unSizedByteString)++import qualified Language.JVM.Attribute.Code++-- | An Attribute, simply contains of a reference to a name and+-- contains info.+data Attribute = Attribute+ { aNameIndex :: ! ConstantRef+ , aInfo' :: ! SizedByteString32+ } deriving (Show, Eq, Generic)++instance Binary Attribute where++-- | A small helper function to extract the info as a+-- lazy 'Data.ByteString.Lazy.ByteString'.+aInfo :: Attribute -> BS.ByteString+aInfo = unSizedByteString . aInfo'++-- | Extracts the name from the attribute, if it exists in the+-- ConstantPool.+aName :: ConstantPool -> Attribute -> Maybe Text.Text+aName cp as = lookupText (aNameIndex as) cp++-- | Create a type dependent on another type 'b',+-- used for accessing the correct 'attrName' in 'IsAttribute'.+newtype Const a b = Const { unConst :: a }++-- | A class-type that describes a data-type 'a' as an Attribute. Most notable+-- it provides the 'fromAttribute'' method that enables converting an Attribute+-- to a data-type 'a'.+class IsAttribute a where+ attrName :: Const Text.Text a+ -- ^ The name of the attribute.++ fromAttribute :: Attribute -> Either String a+ -- ^ Generate a 'a' from an Attribute.++ fromAttribute'+ :: ConstantPool+ -> Attribute+ -> Maybe (Either String a)+ fromAttribute' cp as = do+ name <- aName cp as+ if name == unConst (attrName :: Const Text.Text a) then+ return $ fromAttribute as+ else Nothing++-- # Attributes++-- | Code is redefined with Attribute, as it is recursively containing+-- 'Attribute'. This is a small hack to fix it.+type Code = Language.JVM.Attribute.Code.Code Attribute++-- | Code is an Attribute.+instance IsAttribute Code where+ attrName =+ Const "Code"+ fromAttribute =+ bimap trd trd . decodeOrFail . BL.fromStrict . aInfo
+ src/Language/JVM/Attribute/Code.hs view
@@ -0,0 +1,665 @@+{-|+Module : Language.JVM.Attribute.Code+Copyright : (c) Christian Gram Kalhauge, 2017+License : MIT+Maintainer : kalhuage@cs.ucla.edu+-}++{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TemplateHaskell #-}+module Language.JVM.Attribute.Code+ ( Code (..)++ , ByteCode (..)+ , ExceptionTable (..)++ , ByteCodeInst (..)+ , ByteCodeOpr (..)++ , Constant (..)+ , WordSize+ , OneOrTwo (..)+ , ArithmeticType (..)+ , SmallArithmeticType (..)+ , BinOpr (..)+ , LocalType (..)+ , ArrayType (..)+ , CmpOpr (..)+ , LongOffset+ , Offset++ , LocalAddress (..)+ , IncrementAmount (..)+ , BitOpr (..)+ , FieldAccess (..)+ , Invokation (..)+ ) where++import GHC.Generics (Generic)++import Prelude hiding (fail)+import qualified Prelude as P++import Numeric (showHex)++import Control.Monad hiding (fail)+import Control.Monad.Fail (fail)++import Data.Binary+import Data.Binary.Get hiding (Get)+import Data.Binary.Put hiding (Put)+import qualified Data.ByteString.Lazy as BL+import Data.Int+import qualified Data.Vector as V++import Language.JVM.Constant (ConstantRef (..))+import Language.JVM.Utils++++data Code a = Code+ { maxStack :: Int16+ , maxLocals :: Int16+ , bytecode :: ByteCode+ , exceptionTable :: SizedList16 ExceptionTable+ , attributes :: SizedList16 a+ } deriving (Show, Eq, Generic)++instance (Binary a) => Binary (Code a) where+ -- Auto implemented by generic++newtype ByteCode = ByteCode+ { unByteCode :: [ByteCodeInst]+ } deriving (Show, Eq)++instance Binary ByteCode where+ get = do+ x <- getWord32be+ bs <- getLazyByteString (fromIntegral x)+ case runGetOrFail go bs of+ Right (_,_,bcs) -> return $ ByteCode bcs+ Left (_,_,msg) -> fail msg+ where+ go = isEmpty >>= \t ->+ if t+ then return []+ else do+ x <- get+ (x:) <$> go+++ put (ByteCode lst)= do+ let bs = runPut (mapM_ put lst)+ putWord32be (fromIntegral $ BL.length bs)+ putLazyByteString bs+++data ExceptionTable = ExceptionTable+ { start :: ! Word16+ -- ^ Inclusive program counter into 'code'+ , end :: ! Word16+ -- ^ Exclusive program counter into 'code'+ , handler :: ! Word16+ -- ^ A program counter into 'code' indicating the handler.+ , catchType :: ! ConstantRef+ }+ deriving (Show, Eq, Generic)++instance Binary ExceptionTable where++data ByteCodeInst = ByteCodeInst+ { offset :: LongOffset+ , opcode :: ByteCodeOpr+ }+ deriving (Show, Eq, Generic)++instance Binary ByteCodeInst where+ get =+ ByteCodeInst <$> (fromIntegral <$> bytesRead) <*> get+ put x =+ put $ opcode x++data ArithmeticType = MInt | MLong | MFloat | MDouble+ deriving (Show, Eq, Enum, Bounded)++data SmallArithmeticType = MByte | MChar | MShort+ deriving (Show, Eq, Enum, Bounded)++data LocalType = LInt | LLong | LFloat | LDouble | LRef+ deriving (Show, Eq, Enum, Bounded)++data ArrayType a+ = ABoolean | AByte | AChar | AShort | AInt | ALong+ | AFloat | ADouble | ARef a+ deriving (Show, Eq)++data Invokation+ = InvkSpecial+ | InvkVirtual+ | InvkStatic+ | InvkInterface Word8+ | InvkDynamic+ deriving (Show, Eq)++data FieldAccess+ = FldStatic+ | FldField+ deriving (Show, Eq)++data OneOrTwo = One | Two+ deriving (Show, Ord, Bounded, Eq, Enum)++type WordSize = OneOrTwo++data Constant+ = CNull++ | CIntM1+ | CInt0+ | CInt1+ | CInt2+ | CInt3+ | CInt4+ | CInt5++ | CLong0+ | CLong1++ | CFloat0+ | CFloat1+ | CFloat2++ | CDouble0+ | CDouble1++ | CByte Int8+ | CShort Int16++ | CHalfRef ConstantRef+ | CRef WordSize ConstantRef+ deriving (Show, Eq)++data BinOpr+ = Add+ | Sub+ | Mul+ | Div+ | Rem+ deriving (Show, Eq)++data BitOpr+ = ShL+ | ShR+ | UShR+ | And+ | Or+ | XOr+ deriving (Show, Eq)++type Offset = Int16+type LongOffset = Int32++data LocalAddress+ = LWide Word16+ | LSingle Word8+ deriving (Show, Eq)++data IncrementAmount+ = IWide Int16+ | ISingle Int8+ deriving (Show, Eq)++data CmpOpr+ = CEq | CNe | CLt | CGe | CGt | CLe+ deriving (Show, Eq)++data ByteCodeOpr+ = ArrayLoad (ArrayType ())+ -- ^ aaload baload ...+ | ArrayStore (ArrayType ())+ -- ^ aastore bastore ...++ | Push Constant++ | Load LocalType LocalAddress+ -- ^ aload_0, bload_2, iload 5 ...+ | Store LocalType LocalAddress+ -- ^ aload, bload ...++ | BinaryOpr BinOpr ArithmeticType+ -- ^ iadd ...+ | Neg ArithmeticType+ -- ^ ineg ...++ | BitOpr BitOpr WordSize+ -- ^ Exclusively on int and long, identified by the word-size++ | IncrLocal !LocalAddress !IncrementAmount+ -- ^ Only works on ints, increment local #1, with #2++ | Cast ArithmeticType ArithmeticType+ -- ^ Only valid on different types++ | CastDown SmallArithmeticType+ -- ^ Only valid on different types++ | CompareLongs++ | CompareFloating Bool WordSize+ -- ^ Compare two floating values, #1 indicates if greater-than, #2+ -- is if float or double should be used.++ | If CmpOpr OneOrTwo Offset+ -- ^ compare with 0 if #2 is False, and two ints from the stack if+ -- True. the last value is the offset++ | IfRef Bool OneOrTwo Offset+ -- ^ check if two objects are equal, or not equal. If #2 is True, compare+ -- with null.++ | Goto LongOffset+ | Jsr LongOffset+ | Ret LocalAddress++ | TableSwitch Int32 Int32 Int32 (V.Vector Int32)+ -- ^ a table switch has 3 values `default` `low` `high` and a list of+ -- offets.+ | LookupSwitch Int32 (V.Vector (Int32, Int32))+ -- ^ a lookup switch has a `default` value and a list of pairs.++ | Get FieldAccess ConstantRef+ | Put FieldAccess ConstantRef++ | Invoke Invokation ConstantRef++ | New ConstantRef+ | NewArray (ArrayType ConstantRef)++ | ArrayLength++ | Throw++ | CheckCast ConstantRef+ | InstanceOf ConstantRef++ | Monitor Bool+ -- ^ True => Enter, False => Exit++ | MultiNewArray ConstantRef Word8+ -- ^ Create a new multi array of #1 and with #2 dimensions++ | Return (Maybe LocalType)++ | Nop++ | Pop WordSize++ | Dup WordSize+ | DupX1 WordSize+ | DupX2 WordSize++ | Swap++ deriving (Show, Eq)++instance Binary ByteCodeOpr where+ get = do+ cmd <- getWord8+ case cmd of+ 0x00 -> return Nop+ 0x01 -> return $ Push CNull++ 0x02 -> return $ Push CIntM1+ 0x03 -> return $ Push CInt0+ 0x04 -> return $ Push CInt1+ 0x05 -> return $ Push CInt2+ 0x06 -> return $ Push CInt3+ 0x07 -> return $ Push CInt4+ 0x08 -> return $ Push CInt5++ 0x09 -> return $ Push CLong0+ 0x0a -> return $ Push CLong1++ 0x0b -> return $ Push CFloat0+ 0x0c -> return $ Push CFloat1+ 0x0d -> return $ Push CFloat2++ 0x0e -> return $ Push CDouble0+ 0x0f -> return $ Push CDouble1++ 0x10 -> Push . CByte <$> get+ 0x11 -> Push . CShort <$> get++ 0x12 -> Push . CHalfRef . ConstantRef . fromIntegral <$> getWord8+ 0x13 -> Push . CRef One <$> get+ 0x14 -> Push . CRef Two <$> get++ 0x15 -> Load LInt . LSingle <$> get+ 0x16 -> Load LLong . LSingle <$> get+ 0x17 -> Load LFloat . LSingle <$> get+ 0x18 -> Load LDouble . LSingle <$> get+ 0x19 -> Load LRef . LSingle <$> get++ 0x1a -> return $ Load LInt (LSingle 0)+ 0x1b -> return $ Load LInt (LSingle 1)+ 0x1c -> return $ Load LInt (LSingle 2)+ 0x1d -> return $ Load LInt (LSingle 3)++ 0x1e -> return $ Load LLong (LSingle 0)+ 0x1f -> return $ Load LLong (LSingle 1)+ 0x20 -> return $ Load LLong (LSingle 2)+ 0x21 -> return $ Load LLong (LSingle 3)++ 0x22 -> return $ Load LFloat (LSingle 0)+ 0x23 -> return $ Load LFloat (LSingle 1)+ 0x24 -> return $ Load LFloat (LSingle 2)+ 0x25 -> return $ Load LFloat (LSingle 3)++ 0x26 -> return $ Load LDouble (LSingle 0)+ 0x27 -> return $ Load LDouble (LSingle 1)+ 0x28 -> return $ Load LDouble (LSingle 2)+ 0x29 -> return $ Load LDouble (LSingle 3)++ 0x2a -> return $ Load LRef (LSingle 0)+ 0x2b -> return $ Load LRef (LSingle 1)+ 0x2c -> return $ Load LRef (LSingle 2)+ 0x2d -> return $ Load LRef (LSingle 3)++ 0x2e -> return $ ArrayLoad AInt+ 0x2f -> return $ ArrayLoad ALong+ 0x30 -> return $ ArrayLoad AFloat+ 0x31 -> return $ ArrayLoad ADouble+ 0x32 -> return $ ArrayLoad (ARef ())+ 0x33 -> return $ ArrayLoad AByte+ 0x34 -> return $ ArrayLoad AChar+ 0x35 -> return $ ArrayLoad AShort++ 0x36 -> Store LInt . LSingle <$> get+ 0x37 -> Store LLong . LSingle <$> get+ 0x38 -> Store LFloat . LSingle <$> get+ 0x39 -> Store LDouble . LSingle <$> get+ 0x3a -> Store LRef . LSingle <$> get++ 0x3b -> return $ Store LInt (LSingle 0)+ 0x3c -> return $ Store LInt (LSingle 1)+ 0x3d -> return $ Store LInt (LSingle 2)+ 0x3e -> return $ Store LInt (LSingle 3)++ 0x3f -> return $ Store LLong (LSingle 0)+ 0x40 -> return $ Store LLong (LSingle 1)+ 0x41 -> return $ Store LLong (LSingle 2)+ 0x42 -> return $ Store LLong (LSingle 3)++ 0x43 -> return $ Store LFloat (LSingle 0)+ 0x44 -> return $ Store LFloat (LSingle 1)+ 0x45 -> return $ Store LFloat (LSingle 2)+ 0x46 -> return $ Store LFloat (LSingle 3)++ 0x47 -> return $ Store LDouble (LSingle 0)+ 0x48 -> return $ Store LDouble (LSingle 1)+ 0x49 -> return $ Store LDouble (LSingle 2)+ 0x4a -> return $ Store LDouble (LSingle 3)++ 0x4b -> return $ Store LRef (LSingle 0)+ 0x4c -> return $ Store LRef (LSingle 1)+ 0x4d -> return $ Store LRef (LSingle 2)+ 0x4e -> return $ Store LRef (LSingle 3)++ 0x4f -> return $ ArrayStore AInt+ 0x50 -> return $ ArrayStore ALong+ 0x51 -> return $ ArrayStore AFloat+ 0x52 -> return $ ArrayStore ADouble+ 0x53 -> return $ ArrayStore (ARef ())+ 0x54 -> return $ ArrayStore AByte+ 0x55 -> return $ ArrayStore AChar+ 0x56 -> return $ ArrayStore AShort++ 0x57 -> return $ Pop One+ 0x58 -> return $ Pop Two++ 0x59 -> return $ Dup One+ 0x5a -> return $ DupX1 One+ 0x5b -> return $ DupX2 One++ 0x5c -> return $ Dup Two+ 0x5d -> return $ DupX1 Two+ 0x5e -> return $ DupX2 Two++ 0x5f -> return $ Swap++ 0x60 -> return $ BinaryOpr Add MInt+ 0x61 -> return $ BinaryOpr Add MLong+ 0x62 -> return $ BinaryOpr Add MFloat+ 0x63 -> return $ BinaryOpr Add MDouble++ 0x64 -> return $ BinaryOpr Sub MInt+ 0x65 -> return $ BinaryOpr Sub MLong+ 0x66 -> return $ BinaryOpr Sub MFloat+ 0x67 -> return $ BinaryOpr Sub MDouble++ 0x68 -> return $ BinaryOpr Mul MInt+ 0x69 -> return $ BinaryOpr Mul MLong+ 0x6a -> return $ BinaryOpr Mul MFloat+ 0x6b -> return $ BinaryOpr Mul MDouble++ 0x6c -> return $ BinaryOpr Div MInt+ 0x6d -> return $ BinaryOpr Div MLong+ 0x6e -> return $ BinaryOpr Div MFloat+ 0x6f -> return $ BinaryOpr Div MDouble++ 0x70 -> return $ BinaryOpr Rem MInt+ 0x71 -> return $ BinaryOpr Rem MLong+ 0x72 -> return $ BinaryOpr Rem MFloat+ 0x73 -> return $ BinaryOpr Rem MDouble++ 0x74 -> return $ Neg MInt+ 0x75 -> return $ Neg MLong+ 0x76 -> return $ Neg MFloat+ 0x77 -> return $ Neg MDouble++ 0x78 -> return $ BitOpr ShL One+ 0x79 -> return $ BitOpr ShL Two+ 0x7a -> return $ BitOpr ShR One+ 0x7b -> return $ BitOpr ShR Two++ 0x7c -> return $ BitOpr UShR One+ 0x7d -> return $ BitOpr UShR Two++ 0x7e -> return $ BitOpr And One+ 0x7f -> return $ BitOpr And Two+ 0x80 -> return $ BitOpr Or One+ 0x81 -> return $ BitOpr Or Two+ 0x82 -> return $ BitOpr XOr One+ 0x83 -> return $ BitOpr XOr Two++ 0x84 -> IncrLocal <$> (LSingle <$> get) <*> (ISingle <$> get)++ 0x85 -> return $ Cast MInt MLong+ 0x86 -> return $ Cast MInt MFloat+ 0x87 -> return $ Cast MInt MDouble++ 0x88 -> return $ Cast MLong MInt+ 0x89 -> return $ Cast MLong MFloat+ 0x8a -> return $ Cast MLong MDouble++ 0x8b -> return $ Cast MFloat MInt+ 0x8c -> return $ Cast MFloat MLong+ 0x8d -> return $ Cast MFloat MDouble++ 0x8e -> return $ Cast MDouble MInt+ 0x8f -> return $ Cast MDouble MLong+ 0x90 -> return $ Cast MDouble MFloat++ 0x91 -> return $ CastDown MByte+ 0x92 -> return $ CastDown MChar+ 0x93 -> return $ CastDown MShort++ 0x94 -> return $ CompareLongs++ 0x95 -> return $ CompareFloating True One+ 0x96 -> return $ CompareFloating False Two++ 0x97 -> return $ CompareFloating True One+ 0x98 -> return $ CompareFloating False Two++ 0x99 -> If CEq One <$> get+ 0x9a -> If CNe One <$> get+ 0x9b -> If CLt One <$> get+ 0x9c -> If CGe One <$> get+ 0x9d -> If CGt One <$> get+ 0x9e -> If CLe One <$> get++ 0x9f -> If CEq Two <$> get+ 0xa0 -> If CNe Two <$> get+ 0xa1 -> If CLt Two <$> get+ 0xa2 -> If CGe Two <$> get+ 0xa3 -> If CGt Two <$> get+ 0xa4 -> If CLe Two <$> get++ 0xa5 -> IfRef True Two <$> get+ 0xa6 -> IfRef False Two <$> get++ 0xa7 -> Goto . fromIntegral <$> getInt16be+ 0xa8 -> Jsr . fromIntegral <$> getInt16be+ 0xa9 -> Ret . LSingle <$> get++ 0xaa -> do+ offset' <- bytesRead+ let skipAmount = (4 - offset' `mod` 4) `mod` 4+ if skipAmount > 0 then skip $ fromIntegral skipAmount else return ()+ dft <- getInt32be+ low <- getInt32be+ high <- getInt32be+ table <- V.replicateM (fromIntegral $ high - low + 1) getInt32be+ return $ TableSwitch dft low high table++ 0xab -> do+ offset' <- bytesRead+ let skipAmount = (4 - offset' `mod` 4) `mod` 4+ if skipAmount > 0 then skip $ fromIntegral skipAmount else return ()+ dft <- getInt32be+ npairs <- getInt32be+ pairs <- V.replicateM (fromIntegral npairs) get+ return $ LookupSwitch dft pairs++ 0xac -> return . Return . Just $ LInt+ 0xad -> return . Return . Just $ LLong+ 0xae -> return . Return . Just $ LFloat+ 0xaf -> return . Return . Just $ LDouble+ 0xb0 -> return . Return . Just $ LRef+ 0xb1 -> return . Return $ Nothing++ 0xb2 -> Get FldStatic <$> get+ 0xb3 -> Put FldStatic <$> get++ 0xb4 -> Get FldField <$> get+ 0xb5 -> Put FldField <$> get++ 0xb6 -> Invoke InvkVirtual <$> get+ 0xb7 -> Invoke InvkSpecial <$> get+ 0xb8 -> Invoke InvkStatic <$> get+ 0xb9 -> do+ ref <- get+ count <- get+ when (count == 0) $ fail "Should be not zero"+ zero <- getWord8+ when (zero /= 0) $ fail "Should be zero"+ return $ Invoke (InvkInterface count) ref+ 0xba -> do+ ref <- get+ count <- getWord8+ when (count /= 0) $ fail "Should be zero"+ zero <- getWord8+ when (zero /= 0) $ fail "Should be zero"+ return $ Invoke InvkDynamic ref+ 0xbb -> New <$> get++ 0xbc -> do+ x <- getWord8+ NewArray <$> case x of+ 4 -> return ABoolean+ 5 -> return AChar+ 6 -> return AFloat+ 7 -> return ADouble+ 8 -> return AByte+ 9 -> return AShort+ 10 -> return AInt+ 11 -> return ALong+ _ -> fail $ "Unknown type '0x" ++ showHex x "'."++ 0xbd -> NewArray . ARef <$> get++ 0xbe -> return ArrayLength++ 0xbf -> return Throw++ 0xc0 -> CheckCast <$> get+ 0xc1 -> InstanceOf <$> get++ 0xc2 -> return $ Monitor True+ 0xc3 -> return $ Monitor False++ 0xc4 -> do+ subopcode <- getWord8+ case subopcode of+ 0x15 -> Load LInt . LWide <$> get+ 0x16 -> Load LLong . LWide <$> get+ 0x17 -> Load LFloat . LWide <$> get+ 0x18 -> Load LDouble . LWide <$> get+ 0x19 -> Load LRef . LWide <$> get++ 0x36 -> Store LInt . LWide <$> get+ 0x37 -> Store LLong . LWide <$> get+ 0x38 -> Store LFloat . LWide <$> get+ 0x39 -> Store LDouble . LWide <$> get+ 0x3a -> Store LRef . LWide <$> get++ 0x84 -> IncrLocal <$> (LWide <$> get)+ <*> (IWide <$> get)++ 0xa9 -> Ret . LWide <$> get++ _ -> fail $ "Wide does not work for opcode 'Ox"+ ++ showHex subopcode "'"++ 0xc5 -> MultiNewArray <$> get <*> get++ 0xc6 -> IfRef False One <$> get+ 0xc7 -> IfRef True One <$> get++ 0xc8 -> Goto <$> getInt32be+ 0xc9 -> Jsr <$> getInt32be++ _ -> fail $ "I do not know this bytecode '0x" ++ showHex cmd "'."+++ put bc =+ case bc of+ Nop -> putInt8 0x00+ Push CNull -> putInt8 0x01++ Push CIntM1 -> putInt8 0x02+ Push CInt0 -> putInt8 0x03+ Push CInt1 -> putInt8 0x04+ Push CInt2 -> putInt8 0x05+ Push CInt3 -> putInt8 0x06+ Push CInt4 -> putInt8 0x07+ Push CInt5 -> putInt8 0x08++ Push CLong0 -> putInt8 0x09+ Push CLong1 -> putInt8 0x0a++ Push CFloat0 -> putInt8 0x0b+ Push CFloat1 -> putInt8 0x0c+ Push CFloat2 -> putInt8 0x0d++ Push CDouble0 -> putInt8 0x0e+ Push CDouble1 -> putInt8 0x0f++ Push (CByte x) -> putInt8 0x10 >> put x+ Push (CShort x) -> putInt8 0x11 >> put x++ Push (CHalfRef (ConstantRef r)) -> putInt8 0x12 >> putWord8 (fromIntegral r)+ Push (CRef One (ConstantRef r)) -> putInt8 0x13 >> put r+ Push (CRef Two (ConstantRef r)) -> putInt8 0x14 >> put r+ _ -> P.fail $ "Is not able to print '" ++ show bc ++ "' yet."
+ src/Language/JVM/ClassFile.hs view
@@ -0,0 +1,90 @@+{-|+Module : Language.JVM.ClassFile+Copyright : (c) Christian Gram Kalhauge, 2017+License : MIT+Maintainer : kalhuage@cs.ucla.edu++The class file is described in this module.+-}++{-# LANGUAGE DeriveGeneric #-}+module Language.JVM.ClassFile+ ( ClassFile (..)++ , cInterfaces+ , cFields+ , cMethods+ , cAttributes++ , cThisClass+ , cSuperClass+ ) where++import Data.Binary+import qualified Data.Text as Text+import GHC.Generics (Generic)++import Language.JVM.AccessFlag+import Language.JVM.Attribute (Attribute)+import Language.JVM.Constant+import Language.JVM.Field (Field)+import Language.JVM.Method (Method)+import Language.JVM.Utils++-- | A 'ClassFile' as described+-- [here](http://docs.oracle.com/javase/specs/jvms/se7/html/jvms-4.html).++data ClassFile = ClassFile+ { cMagicNumber :: !Word32++ , cMinorVersion :: !Word16+ , cMajorVersion :: !Word16++ , cConstantPool :: !ConstantPool++ , cAccessFlags :: BitSet16 CAccessFlag++ , cThisClassIndex :: !ConstantRef+ , cSuperClassIndex :: !ConstantRef++ , cInterfaces' :: SizedList16 ConstantRef+ , cFields' :: SizedList16 Field+ , cMethods' :: SizedList16 Method+ , cAttributes' :: SizedList16 Attribute+ } deriving (Show, Eq, Generic)++instance Binary ClassFile where++-- | Get a list of 'ConstantRef's to interfaces.+cInterfaces :: ClassFile -> [ConstantRef]+cInterfaces = unSizedList . cInterfaces'++-- | Get a list of 'Field's of a ClassFile.+cFields :: ClassFile -> [Field]+cFields = unSizedList . cFields'++-- | Get a list of 'Method's of a ClassFile.+cMethods :: ClassFile -> [Method]+cMethods = unSizedList . cMethods'++-- | Get a list of 'Attribute's of a ClassFile.+cAttributes :: ClassFile -> [Attribute]+cAttributes = unSizedList . cAttributes'++-- | Lookup the this class in a ConstantPool+cThisClass :: ConstantPool -> ClassFile -> Maybe Text.Text+cThisClass cp = flip lookupClassName cp . cThisClassIndex++-- | Lookup the super class in the ConstantPool+cSuperClass :: ConstantPool -> ClassFile -> Maybe Text.Text+cSuperClass cp = flip lookupClassName cp . cSuperClassIndex+++-- -- $accesors+-- textOf :: ClassFile -> ConstantRef -> Maybe Text.Text+-- textOf cf cr =+-- lookupText cr (cConstantPool cf)++-- constantOf :: ClassFile -> ConstantRef -> Maybe Constant+-- constantOf cf cr =+-- lookupConstant cr (cConstantPool cf)
+ src/Language/JVM/Constant.hs view
@@ -0,0 +1,180 @@+{-|+Module : Language.JVM.Constant+Copyright : (c) Christian Gram Kalhauge, 2017+License : MIT+Maintainer : kalhuage@cs.ucla.edu++This module contains the 'Constant' type and the 'ConstantPool'. These+are essential for accessing data in the class-file.+-}++{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RankNTypes #-}+module Language.JVM.Constant+ (+ -- * Constant+ Constant (..)+ , constantSize+ , ConstantRef (..)++ -- * Constant Pool+ -- $ConstantPool+ , ConstantPool (..)++ , lookupConstant+ , lookupText+ , lookupClassName++ , toListOfConstants+ ) where++import GHC.Generics (Generic)++import Prelude hiding (fail, lookup)++import Control.Monad (forM_)+import Control.Monad.Fail (fail)++import Data.Binary+import Data.Binary.Get+import Data.Binary.Put+import qualified Data.IntMap.Strict as IM++import Language.JVM.Utils+++import qualified Data.Text as Text+import qualified Data.Text.Encoding as TE++-- | A constant is referenced by the ConstantRef data type. It is+-- just a 16 bit word, but wrapped for type safety.+newtype ConstantRef =+ ConstantRef Word16+ deriving (Eq, Show, Generic)++instance Binary ConstantRef where++-- | A constant is a multi word item in the 'ConstantPool'. Each of+-- the constructors are pretty much self expiatory from the types.+data Constant+ = String !SizedByteString16+ | Integer !Word32+ | Float !Word32+ | Long !Word64+ | Double !Word64+ | ClassRef !ConstantRef+ | StringRef !ConstantRef+ | FieldRef !ConstantRef !ConstantRef+ | MethodRef !ConstantRef !ConstantRef+ | InterfaceMethodRef !ConstantRef !ConstantRef+ | NameAndType !ConstantRef !ConstantRef+ | MethodHandle !Word8 !ConstantRef+ | MethodType !ConstantRef+ | InvokeDynamic !ConstantRef !ConstantRef+ deriving (Show, Eq)++instance Binary Constant where+ get = do+ ident <- getWord8+ case ident of+ 1 -> String <$> get+ 3 -> Integer <$> get+ 4 -> Float <$> get+ 5 -> Long <$> get+ 6 -> Double <$> get+ 7 -> ClassRef <$> get+ 8 -> StringRef <$> get+ 9 -> FieldRef <$> get <*> get+ 10 -> MethodRef <$> get <*> get+ 11 -> InterfaceMethodRef <$> get <*> get+ 12 -> NameAndType <$> get <*> get+ 15 -> MethodHandle <$> get <*> get+ 16 -> MethodType <$> get+ 18 -> InvokeDynamic <$> get <*> get+ _ -> fail $ "Unkown identifier " ++ show ident++ put x =+ case x of+ String bs -> do putWord8 1; put bs+ Integer i -> do putWord8 3; put i+ Float i -> do putWord8 4; put i+ Long i -> do putWord8 5; put i+ Double i -> do putWord8 6; put i+ ClassRef i -> do putWord8 7; put i+ StringRef i -> do putWord8 8; put i+ FieldRef i j -> do putWord8 9; put i; put j+ MethodRef i j -> do putWord8 10; put i; put j+ InterfaceMethodRef i j -> do putWord8 11; put i; put j+ NameAndType i j -> do putWord8 12; put i; put j+ MethodHandle i j -> do putWord8 15; put i; put j+ MethodType i -> do putWord8 16; put i;+ InvokeDynamic i j -> do putWord8 18; put i; put j++-- | Some of the 'Constant's take up more space in the constant pool than other.+-- Notice that 'Language.JVM.Constant.String' and 'MethodType' is not of size+-- 32, but is still awarded value 1. This is due to an+-- [inconsistency](http://docs.oracle.com/javase/specs/jvms/se7/html/jvms-4.html#jvms-4.4.5)+-- in JVM.+constantSize :: Constant -> Int+constantSize x =+ case x of+ Double _ -> 2+ Long _ -> 2+ _ -> 1++-- $ConstantPool+--+-- The 'ConstantPool' contains all the constants, and is accessible using the+-- Lookup methods.++-- | A ConstantPool is just an 'IntMap'. A 'IntMap' is used, because constants are+-- accessed after their byte-offset. 'constantSize'+newtype ConstantPool = ConstantPool+ { unConstantPool :: IM.IntMap Constant+ } deriving (Show, Eq)++-- | Return a list of reference-constant pairs.+toListOfConstants :: ConstantPool -> [(ConstantRef, Constant)]+toListOfConstants =+ map (\(a,b) -> (ConstantRef . fromIntegral $ a, b)) . IM.toList . unConstantPool++instance Binary ConstantPool where+ get = do+ len <- fromIntegral <$> getInt16be+ list <- go len 1+ return . ConstantPool $ IM.fromList list+ where+ go len n | len > n = do+ constant <- get+ rest <- go len (n + constantSize constant)+ return $ (n, constant) : rest+ go _ _ = return []+ put (ConstantPool p)= do+ case IM.maxViewWithKey p of+ Just ((key, e), _) -> do+ putInt16be (fromIntegral (key + constantSize e))+ forM_ (IM.toAscList p) (put . snd)+ Nothing -> do+ putInt16be 0++-- | Lookup a 'Constant' in the 'ConstantPool'.+lookupConstant :: ConstantRef -> ConstantPool -> Maybe Constant+lookupConstant (ConstantRef ref) (ConstantPool cp) =+ IM.lookup (fromIntegral ref) cp++-- | Lookup a 'Text.Text' in the 'ConstantPool', returns 'Nothing' if the+-- reference does not point to something in the ConstantPool, if it points to+-- something not a 'Language.JVM.Constant.String' Constant, or if it is+-- impossible to decode the 'ByteString' as Utf8.+lookupText :: ConstantRef -> ConstantPool -> Maybe Text.Text+lookupText ref cp = do+ String str <- lookupConstant ref cp+ case TE.decodeUtf8' . unSizedByteString $ str of+ Left _ -> Nothing+ Right txt -> Just txt++-- | Lookup a class name in the 'ConstantPool', returns 'Nothing' otherwise.+lookupClassName :: ConstantRef -> ConstantPool -> Maybe Text.Text+lookupClassName ref cp = do+ ClassRef r <- lookupConstant ref cp+ lookupText r cp
+ src/Language/JVM/Field.hs view
@@ -0,0 +1,30 @@+{-|+Module : Language.JVM.Field+Copyright : (c) Christian Gram Kalhauge, 2017+License : MIT+Maintainer : kalhuage@cs.ucla.edu+-}++{-# LANGUAGE DeriveGeneric #-}+module Language.JVM.Field+ ( Field (..)+ ) where++import Data.Binary+import GHC.Generics (Generic)++import Language.JVM.AccessFlag+import Language.JVM.Attribute (Attribute)+import Language.JVM.Constant (ConstantRef)+import Language.JVM.Utils++-- | A Field in the class-file, as described+-- [here](http://docs.oracle.com/javase/specs/jvms/se7/html/jvms-4.html#jvms-4.5).+data Field = Field+ { fAccessFlags :: BitSet16 FAccessFlag+ , fNameIndex :: ! ConstantRef+ , fDescriptorIndex :: ! ConstantRef+ , fAttributes :: SizedList16 Attribute+ } deriving (Show, Eq, Generic)++instance Binary Field where
+ src/Language/JVM/Method.hs view
@@ -0,0 +1,62 @@+{-|+Module : Language.JVM.Method+Copyright : (c) Christian Gram Kalhauge, 2017+License : MIT+Maintainer : kalhuage@cs.ucla.edu+-}++{-# LANGUAGE DeriveGeneric #-}+module Language.JVM.Method+ ( Method (..)++ , mAccessFlags+ , mAttributes++ , mName+ , mDescriptor+ , mCode+ ) where++import Data.Binary+import Data.Set (Set)+import qualified Data.Text as Text+import GHC.Generics (Generic)++import Data.Monoid++import Language.JVM.AccessFlag+import Language.JVM.Attribute (Attribute, fromAttribute', Code)+import Language.JVM.Constant (ConstantRef, ConstantPool, lookupText)+import Language.JVM.Utils++-- | A Method in the class-file, as described+-- [here](http://docs.oracle.com/javase/specs/jvms/se7/html/jvms-4.html#jvms-4.6).+data Method = Method+ { mAccessFlags' :: BitSet16 MAccessFlag+ , mNameIndex :: ! ConstantRef+ , mDescriptorIndex :: ! ConstantRef+ , mAttributes' :: SizedList16 Attribute+ } deriving (Show, Eq, Generic)++instance Binary Method where++-- | Unpack the BitSet and get the AccessFlags as a Set.+mAccessFlags :: Method -> Set MAccessFlag+mAccessFlags = toSet . mAccessFlags'++-- | Unpack the SizedList and get the attributes as a List.+mAttributes :: Method -> [Attribute]+mAttributes = unSizedList . mAttributes'++-- | Lookup the name of the method in the 'ConstantPool'.+mName :: ConstantPool -> Method -> Maybe Text.Text+mName cp = flip lookupText cp . mNameIndex++-- | Lookup the descriptor of the method in the 'ConstantPool'.+mDescriptor :: ConstantPool -> Method -> Maybe Text.Text+mDescriptor cp = flip lookupText cp . mDescriptorIndex++-- | Fetch the first 'Code' Attribute.+mCode :: ConstantPool -> Method -> Maybe (Either String Code)+mCode cp =+ getFirst . foldMap (First . fromAttribute' cp) . mAttributes
+ src/Language/JVM/Utils.hs view
@@ -0,0 +1,157 @@+{-|+Module : Language.JVM.Utils+Copyright : (c) Christian Gram Kalhauge, 2017+License : MIT+Maintainer : kalhuage@cs.ucla.edu++This module contains utilities missing not in other libraries.+-}++{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Language.JVM.Utils+ ( -- * Sized Data Structures+ --+ -- $SizedDataStructures+ SizedList (..)+ , listSize++ , SizedByteString (..)+ , byteStringSize++ -- ** Specific sizes+ , SizedList16+ , SizedByteString32+ , SizedByteString16++ -- * Bit Set+ --+ -- $BitSet+ , BitSet (..)+ , Enumish(..)++ -- ** Specific sizes+ , BitSet16++ -- * General Utilities+ -- $utils+ , trd+ ) where++import Data.Binary+import Data.Binary.Get+import Data.Binary.Put+import Data.Bits+import Data.List as List+import Data.Set as Set++import Control.Monad++import qualified Data.ByteString as BS+++-- $SizedDataStructures+-- These data structures enables binary reading and writing of lists and+-- byte strings that are prepended with the number of elements to read or write.+++-- | SizedList is a binary type, that reads a list of elements. It first reads a+-- length N of type 'w' and then N items of type 'a'.+newtype SizedList w a = SizedList+ { unSizedList :: [ a ]+ } deriving (Show, Eq, Functor)++-- | Get the size of the sized list.+listSize :: Num w => SizedList w a -> w+listSize =+ fromIntegral . length . unSizedList++instance Foldable (SizedList w) where+ foldMap am =+ foldMap am . unSizedList++instance Traversable (SizedList w) where+ traverse afb ta =+ SizedList <$> traverse afb (unSizedList ta)++instance (Binary w, Integral w, Binary a) => Binary (SizedList w a) where+ get = do+ len <- get :: Get w+ SizedList <$> replicateM (fromIntegral len) get++ put sl@(SizedList l) = do+ put (listSize sl)+ forM_ l put++-- | A byte string with a size w.+newtype SizedByteString w = SizedByteString+ { unSizedByteString :: BS.ByteString+ } deriving (Show, Eq)++-- | Get the size of a SizedByteString+byteStringSize :: (Num w) => SizedByteString w -> w+byteStringSize =+ fromIntegral . BS.length . unSizedByteString++instance (Binary w, Integral w) => Binary (SizedByteString w) where+ get = do+ x <- get :: Get w+ SizedByteString <$> getByteString (fromIntegral x)+ put sbs@(SizedByteString bs) = do+ put (byteStringSize sbs)+ putByteString bs++-- $BitSet+-- A bit set is a set where each element is represented a bit in a word. This+-- section also defines the 'Enumish' type class. It is different than a 'Enum'+-- in that the integers they represent does not have to be subsequent.++-- | An Enumish value, all maps to a number, but not all integers maps to a+-- enumsish value. There is no guarantee that the integers will be subsequent.+class (Eq a, Ord a) => Enumish a where+ -- | The only needed implementation is a list of integer-enum pairs in+ -- ascending order, corresponding to their integer value.+ inOrder :: [(Int, a)]++ fromEnumish :: a -> Int+ fromEnumish a = let Just (i, _) = List.find ((== a) . snd) $ inOrder in i++ toEnumish :: Int -> Maybe a+ toEnumish i = snd <$> (List.find ((== i) . fst) $ inOrder)++-- | A bit set of size w+newtype BitSet w a = BitSet+ { toSet :: Set.Set a+ } deriving (Ord, Show, Eq)++instance (Bits w, Binary w, Enumish a) => Binary (BitSet w a) where+ get = do+ word <- get :: Get w+ return . BitSet $ Set.fromList [ x | (i, x) <- inOrder, testBit word i ]++ put (BitSet f) = do+ let word =+ List.foldl' setBit zeroBits+ (List.map fromEnumish $ Set.toList f) :: w+ put word++-- | A sized list using a 16 bit word as length+type SizedList16 = SizedList Word16++-- | A sized bytestring using a 32 bit word as length+type SizedByteString32 = SizedByteString Word32++-- | A sized bytestring using a 16 bit word as length+type SizedByteString16 = SizedByteString Word16++-- | A BitSet using a 16 bit word+type BitSet16 = BitSet Word16++{- $utils++-}++-- | Takes the third element of a triple.+trd :: (a, b, c) -> c+trd (_, _, c) = c
+ stack.yaml view
@@ -0,0 +1,6 @@+resolver: lts-9.3+packages:+- .+extra-deps: []+flags: {}+extra-package-dbs: []
+ test-suite/Language/JVM/Attribute/CodeTest.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE OverloadedStrings, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Language.JVM.Attribute.CodeTest where++import SpecHelper++import Data.Word++import Language.JVM.Attribute (Attribute)+import Language.JVM.AttributeTest ()++import Language.JVM.Attribute.Code+import qualified Language.JVM.Constant as Constant+import Language.JVM.UtilsTest ()+++-- prop_encode_and_decode_ByteCode :: ByteCode -> Property+-- prop_encode_and_decode_ByteCode = isoBinary++-- prop_encode_and_decode :: Code Attribute -> Property+-- prop_encode_and_decode = isoBinary++instance Arbitrary (Code Attribute) where+ arbitrary = Code+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+++instance Arbitrary ArithmeticType where+ arbitrary = elements [ MInt, MLong, MFloat, MDouble ]++instance Arbitrary LocalType where+ arbitrary = elements [ LInt, LLong, LFloat, LDouble, LRef ]++instance Arbitrary ByteCodeInst where+ arbitrary = ByteCodeInst <$> arbitrary <*> arbitrary++instance Arbitrary ByteCodeOpr where+ arbitrary = oneof+ [ pure Nop+ , Push <$> arbitrary+ ]++instance Arbitrary Constant where+ arbitrary = oneof+ [ pure CNull+ , pure CIntM1+ , pure CInt0+ , pure CInt1+ , pure CInt2+ , pure CInt3+ , pure CInt4+ , pure CInt5++ , pure CLong0+ , pure CLong1++ , pure CFloat0+ , pure CFloat1+ , pure CFloat2++ , pure CDouble0+ , pure CDouble1++ , CByte <$> arbitrary+ , CShort <$> arbitrary++ , CHalfRef . Constant.ConstantRef . fromIntegral <$> (arbitrary :: Gen Word8)+ , CRef One <$> arbitrary+ , CRef Two <$> arbitrary+ ]++instance Arbitrary ByteCode where+ arbitrary = ByteCode <$> arbitrary++instance Arbitrary ExceptionTable where+ arbitrary = ExceptionTable+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary
+ test-suite/Language/JVM/AttributeTest.hs view
@@ -0,0 +1,21 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Language.JVM.AttributeTest where++import SpecHelper++import Language.JVM.Attribute (Attribute (..))+import Language.JVM.ConstantTest ()+import Language.JVM.Utils+import Language.JVM.UtilsTest ()++import qualified Data.ByteString as BS++prop_encode_and_decode :: Attribute -> Property+prop_encode_and_decode = isoBinary++instance Arbitrary Attribute where+ arbitrary = do+ idx <- arbitrary+ len <- choose (0, 50)+ bs <- SizedByteString . BS.pack <$> sequence (replicate len arbitrary)+ return $ Attribute idx bs
+ test-suite/Language/JVM/ClassFileTest.hs view
@@ -0,0 +1,33 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Language.JVM.ClassFileTest where++import SpecHelper++import qualified Data.IntMap as IM++import Language.JVM.ClassFile+import Language.JVM.Constant++import Language.JVM.Utils+import Language.JVM.UtilsTest ()+import Language.JVM.AttributeTest ()+import Language.JVM.ConstantTest ()+import Language.JVM.FieldTest ()+import Language.JVM.MethodTest ()++prop_encode_and_decode :: ClassFile -> Property+prop_encode_and_decode = isoBinary++instance Arbitrary ClassFile where+ arbitrary = ClassFile+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> (pure $ ConstantPool IM.empty)+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> (pure $ SizedList [])+ <*> (pure $ SizedList [])+ <*> (pure $ SizedList [])+ <*> (pure $ SizedList [])
+ test-suite/Language/JVM/ConstantTest.hs view
@@ -0,0 +1,42 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Language.JVM.ConstantTest where++import SpecHelper++import Language.JVM.Constant+import Language.JVM.UtilsTest ()++import qualified Data.IntMap as IM++prop_encode_and_decode :: ConstantPool -> Property+prop_encode_and_decode = isoBinary++instance Arbitrary ConstantRef where+ arbitrary =+ ConstantRef <$> arbitrary++instance Arbitrary ConstantPool where+ arbitrary =+ ConstantPool . IM.fromList . go 1 <$> arbitrary+ where+ go n (e : lst) =+ (n, e) : go (n + constantSize e) lst+ go _ [] = []++instance Arbitrary Constant where+ arbitrary = oneof+ [ String <$> arbitrary+ , Integer <$> arbitrary+ , Float <$> arbitrary+ , Long <$> arbitrary+ , Double <$> arbitrary+ , ClassRef <$> arbitrary+ , StringRef <$> arbitrary+ , FieldRef <$> arbitrary <*> arbitrary+ , MethodRef <$> arbitrary <*> arbitrary+ , InterfaceMethodRef <$> arbitrary <*> arbitrary+ , NameAndType <$> arbitrary <*> arbitrary+ , MethodHandle <$> arbitrary <*> arbitrary+ , MethodType <$> arbitrary+ , InvokeDynamic <$> arbitrary <*> arbitrary+ ]
+ test-suite/Language/JVM/FieldTest.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Language.JVM.FieldTest where++import SpecHelper++import Language.JVM.Field+import Language.JVM.UtilsTest ()+import Language.JVM.ConstantTest ()+import Language.JVM.AttributeTest ()++prop_encode_and_decode :: Field -> Property+prop_encode_and_decode = isoBinary++instance Arbitrary Field where+ arbitrary = Field+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary
+ test-suite/Language/JVM/MethodTest.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Language.JVM.MethodTest where++import SpecHelper++import Language.JVM.Method+import Language.JVM.UtilsTest ()+import Language.JVM.ConstantTest ()+import Language.JVM.AttributeTest ()++prop_encode_and_decode :: Method -> Property+prop_encode_and_decode = isoBinary++instance Arbitrary Method where+ arbitrary = Method+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary
+ test-suite/Language/JVM/UtilsTest.hs view
@@ -0,0 +1,22 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Language.JVM.UtilsTest where++import SpecHelper++import qualified Data.ByteString as BS++import Data.Set as Set+import Language.JVM.Utils++instance Arbitrary a => Arbitrary (SizedList w a) where+ arbitrary =+ SizedList <$> arbitrary++instance Arbitrary (SizedByteString w) where+ arbitrary = do+ len <- choose (0, 50)+ SizedByteString . BS.pack <$> sequence (replicate len arbitrary)++instance (Enumish a) => Arbitrary (BitSet w a) where+ arbitrary =+ BitSet . Set.fromList <$> sublistOf (snd <$> inOrder)
+ test-suite/Language/JVMTest.hs view
@@ -0,0 +1,30 @@+module Language.JVMTest where++import SpecHelper++import Control.Monad+-- import Data.Text as Text+import Data.Maybe+import Data.Either+-- import Debug.Trace++import Language.JVM+import Language.JVM.Attribute.Code ()++test_reading_classfile :: IO [TestTree]+test_reading_classfile = testAllFiles $ do+ it "can parse the bytestring" $ \bs -> do+ decodeClassFile bs `shouldSatisfy` isRight++ beforeWith (\bs -> either fail return $ decodeClassFile bs) $ do++ it "has a the magic number: 0xCAFEBABE" $ \cls ->+ cMagicNumber cls `shouldBe` 0xCAFEBABE++ it "has a class name" $ \cls ->+ cThisClass (cConstantPool cls) cls `shouldSatisfy` isJust++ it "can parse all method codes" $ \cls ->+ forM_ (catMaybes . map (mCode (cConstantPool cls)) $ cMethods cls) $+ \code-> do+ code `shouldSatisfy` isRight
+ test-suite/SpecHelper.hs view
@@ -0,0 +1,68 @@+module SpecHelper+ ( module Test.Tasty+ , module Test.Tasty.Hspec+ , module Test.Tasty.QuickCheck+ , decode+ , encode+ , blReadFile+ , isoBinary+ , testAllFiles+ , testSomeFiles+ ) where++import Test.Tasty+import Test.Tasty.Hspec+import Test.Tasty.QuickCheck+import qualified Data.ByteString.Lazy as BL++import System.FilePath+import System.Directory++import Control.Monad+import Data.Binary+import Data.Bits++blReadFile :: FilePath -> IO BL.ByteString+blReadFile = BL.readFile++toHex :: Word8 -> String+toHex x =+ [ alpha !! fromIntegral (x `shift` (-4))+ , alpha !! fromIntegral (x `mod` 16)+ ]+ where alpha = "0123456789abcdef"++testAllFiles :: SpecWith BL.ByteString -> IO [TestTree]+testAllFiles spec = do+ files <- filter isClass <$> recursiveContents "test-suite/data"+ forM files $ \file -> testSpec file (beforeAll (blReadFile file) spec)+ where+ isClass p = takeExtension p == ".class"+++testSomeFiles :: SpecWith BL.ByteString -> IO [TestTree]+testSomeFiles spec =+ forM files $ \file -> testSpec file (beforeAll (blReadFile file) spec)+ where+ files =+ [ "test-suite/data/java/util/zip/ZipOutputStream.class"+ -- , "test-suite/data/project/Main.class"+ ]++isoBinary :: (Binary a, Eq a, Show a) => a -> Property+isoBinary a =+ let bs = encode a+ in counterexample (concat . map toHex $ BL.unpack bs) $+ decode bs === a++folderContents :: FilePath -> IO [ FilePath ]+folderContents fp =+ map (fp </>) <$> listDirectory fp++recursiveContents :: FilePath -> IO [ FilePath ]+recursiveContents fp = do+ test <- doesDirectoryExist fp+ (fp:) <$> if test then do+ content <- folderContents fp+ concat <$> mapM recursiveContents content+ else return []
+ test-suite/Test.hs view
@@ -0,0 +1,60 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-}+++-- {-# LANGUAGE OverloadedStrings #-}+-- import Language.JVM.Binary.Attribute (Attribute(..))+-- import Language.JVM.Binary.ClassFile+++-- import Data.Binary (decode, encode)+-- import qualified Data.ByteString.Lazy as LBS+-- import qualified Data.ByteString.Char8 as BC+-- import qualified Data.ByteString as BS++-- import qualified Test.Tasty+-- import Test.Tasty.Hspec+-- import Test.Tasty.QuickCheck as QC+++-- main :: IO ()+-- main = do+-- putStrLn ".."+-- test <- testSpec "jvmhs" classfileSpec+-- Test.Tasty.defaultMain (Test.Tasty.testGroup "All of it" [ test, encodedecode ])++-- classfileSpec :: Spec+-- classfileSpec = beforeAll (LBS.readFile "test-suite/project/Main.class") $ do+-- it "can read the bytestring" $+-- \bs -> let classfile = decode bs+-- in (magicNumber classfile) `shouldBe` 3405691582++-- it "can encode and decode attributes" $+-- \_ -> let attr = Attribute 1 (BC.pack "Hello")+-- in (decode . encode ) attr `shouldBe` attr++-- it "will encode and decode back to a class file" $ \bs ->+-- let classfile = decode bs :: ClassFile+-- encoding = encode classfile+-- in (methods classfile) `shouldBe` (methods $ decode (LBS.append encoding (LBS.repeat 0)))++-- it "will encode the data back to the same format" $ \bs ->+-- let classfile = decode bs :: ClassFile+-- in bs `shouldBe` encode classfile+++-- encodedecode :: Test.Tasty.TestTree+-- encodedecode =+-- Test.Tasty.testGroup "encode . decode == id"+-- [ QC.testProperty "Attribute" $ \(ArbAttribute attr) ->+-- (decode . encode) attr == attr+-- ]++-- newtype ArbAttribute =+-- ArbAttribute Attribute deriving (Show, Eq)++-- instance Arbitrary ArbAttribute where+-- arbitrary = do+-- index <- arbitrary+-- len <- choose (0, 50)+-- bs <- BS.pack <$> sequence (replicate len arbitrary)+-- return $ ArbAttribute (Attribute index bs)