diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,21 @@ # Change log +## Version 0.9.0 +- Changed attributeError to evolveError +- Added new instruction NewArray to correctly model array behaviour +- Massive rewrite of AbsMethodId and friends to make them easier to + work with +- Changed ClassType in Signature to contain the inner classes in + the correct order. +- Fixed problem with defintion of TypedAnnotations +- Fixed spelling mistake in TypeParameter +- Added MethodParameters +- Made more Annotations Ord'able and exported them fully +- Make some data types into newtypes + +## Version 0.8.1 +- Made all tests work with nix + ## Version 0.8.0 - Upgrade to GHC 8.6.4 diff --git a/jvm-binary.cabal b/jvm-binary.cabal --- a/jvm-binary.cabal +++ b/jvm-binary.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.1. +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: 03c963aeab3e7e2bc2d184ccd232d7e3fee10eca4c19073d94b1471921209eea +-- hash: 3eccf421837ee1c579e393ed97d897fa8a716f1758cf440c9a85110a0351686c name: jvm-binary -version: 0.8.0 +version: 0.9.0 synopsis: A library for reading Java class-files description: A library for reading Java class-files. category: Language, Java, JVM @@ -21,31 +21,17 @@ extra-source-files: CHANGELOG.md LICENSE.md - package.yaml README.md - stack.yaml +data-files: + test/data/project/Main.class + test/data/project/Main.java + test/data/Localizable.class source-repository head type: git location: https://github.com/ucla-pls/jvm-binary library - hs-source-dirs: - src - ghc-options: -Wall - build-depends: - attoparsec - , base >=4.9 && <4.13 - , binary - , bytestring - , containers - , data-binary-ieee754 - , deepseq >=1.4.3.0 - , deriving-compat - , mtl - , template-haskell - , text - , vector exposed-modules: Language.JVM Language.JVM.AccessFlag @@ -59,6 +45,7 @@ Language.JVM.Attribute.Exceptions Language.JVM.Attribute.InnerClasses Language.JVM.Attribute.LineNumberTable + Language.JVM.Attribute.MethodParameters Language.JVM.Attribute.Signature Language.JVM.Attribute.StackMapTable Language.JVM.ByteCode @@ -70,22 +57,17 @@ Language.JVM.Method Language.JVM.Stage Language.JVM.Staged + Language.JVM.TextSerializable Language.JVM.TH Language.JVM.Type Language.JVM.Utils other-modules: Paths_jvm_binary - default-language: Haskell2010 - -test-suite jvm-binary-test - type: exitcode-stdio-1.0 - main-is: Main.hs hs-source-dirs: - test - ghc-options: -rtsopts -threaded -with-rtsopts=-N -fno-warn-orphans + src + ghc-options: -Wall build-depends: - QuickCheck - , attoparsec + attoparsec , base >=4.9 && <4.13 , binary , bytestring @@ -93,18 +75,15 @@ , data-binary-ieee754 , deepseq >=1.4.3.0 , deriving-compat - , directory - , filepath - , generic-random - , hspec >=2.5.5 - , hspec-discover - , hspec-expectations-pretty-diff - , jvm-binary , mtl , template-haskell , text , vector - , zip-archive + default-language: Haskell2010 + +test-suite jvm-binary-test + type: exitcode-stdio-1.0 + main-is: Main.hs other-modules: Language.JVM.Attribute.AnnotationsSpec Language.JVM.Attribute.BootstrapMethodsSpec @@ -117,6 +96,7 @@ Language.JVM.Attribute.SignatureSpec Language.JVM.Attribute.StackMapTableSpec Language.JVM.AttributeSpec + Language.JVM.ByteCodeSpec Language.JVM.ClassFileSpec Language.JVM.ConstantSpec Language.JVM.FieldSpec @@ -127,11 +107,39 @@ Spec SpecHelper Paths_jvm_binary + hs-source-dirs: + test + ghc-options: -rtsopts -threaded -with-rtsopts=-N -fno-warn-orphans + build-depends: + QuickCheck + , attoparsec + , base >=4.9 && <4.13 + , binary + , bytestring + , containers + , data-binary-ieee754 + , deepseq >=1.4.3.0 + , deriving-compat + , directory + , doctest + , filepath + , generic-random + , hspec >=2.5.5 + , hspec-discover + , hspec-expectations-pretty-diff + , jvm-binary + , mtl + , template-haskell + , text + , vector + , zip-archive default-language: Haskell2010 benchmark jvm-binary-benchmarks type: exitcode-stdio-1.0 main-is: Main.hs + other-modules: + Paths_jvm_binary hs-source-dirs: benchmark ghc-options: -rtsopts -O2 -threaded -funbox-strict-fields -with-rtsopts=-N @@ -150,6 +158,4 @@ , template-haskell , text , vector - other-modules: - Paths_jvm_binary default-language: Haskell2010 diff --git a/package.yaml b/package.yaml deleted file mode 100644 --- a/package.yaml +++ /dev/null @@ -1,71 +0,0 @@ -name: jvm-binary -version: '0.8.0' -author: Christian Gram Kalhauge -maintainer: Christian Gram Kalhauge -synopsis: A library for reading Java class-files - -license: MIT -license-file: LICENSE.md -category: Language, Java, JVM -github: ucla-pls/jvm-binary - -description: A library for reading Java class-files. - -extra-source-files: -- CHANGELOG.md -- LICENSE.md -- package.yaml -- README.md -- stack.yaml - -dependencies: -- base >= 4.9 && < 4.13 -- binary -- bytestring -- containers -- text -- vector -- deepseq >= 1.4.3.0 -- deriving-compat -- attoparsec -- mtl -- data-binary-ieee754 -- template-haskell - -library: - source-dirs: src - ghc-options: -Wall - -tests: - jvm-binary-test: - dependencies: - - jvm-binary - - QuickCheck - - directory - - filepath - - generic-random - - hspec >= 2.5.5 - - hspec-discover - - hspec-expectations-pretty-diff - - zip-archive - ghc-options: - - -rtsopts - - -threaded - - -with-rtsopts=-N - - -fno-warn-orphans - main: Main.hs - source-dirs: test - -benchmarks: - jvm-binary-benchmarks: - dependencies: - - jvm-binary - - criterion - ghc-options: - - -rtsopts - - -O2 - - -threaded - - -funbox-strict-fields - - -with-rtsopts=-N - main: Main.hs - source-dirs: benchmark diff --git a/src/Language/JVM/AccessFlag.hs b/src/Language/JVM/AccessFlag.hs --- a/src/Language/JVM/AccessFlag.hs +++ b/src/Language/JVM/AccessFlag.hs @@ -9,16 +9,23 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} module Language.JVM.AccessFlag - ( MAccessFlag(..), mflags - , FAccessFlag(..), fflags - , CAccessFlag(..), cflags - , ICAccessFlag(..), icflags - ) where + ( MAccessFlag(..) + , mflags + , FAccessFlag(..) + , fflags + , CAccessFlag(..) + , cflags + , ICAccessFlag(..) + , icflags + , PAccessFlag(..) + , pflags + ) +where import Language.JVM.Utils -import GHC.Generics (Generic) -import Control.DeepSeq (NFData) +import GHC.Generics ( Generic ) +import Control.DeepSeq ( NFData ) -- | Access flags for the 'Language.JVM.Method.Method' data MAccessFlag @@ -39,15 +46,15 @@ -- | 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) + [ (0 , MPublic) + , (1 , MPrivate) + , (2 , MProtected) + , (3 , MStatic) + , (4 , MFinal) + , (5 , MSynchronized) + , (6 , MBridge) + , (7 , MVarargs) + , (8 , MNative) , (10, MAbstract) , (11, MStrictFP) , (12, MSynthetic) @@ -72,10 +79,10 @@ -- | The 'Enumish' mapping of the 'CAccessFlag' cflags :: [(Int, CAccessFlag)] cflags = - [ (0, CPublic) - , (4, CFinal) - , (5, CSuper) - , (9, CInterface) + [ (0 , CPublic) + , (4 , CFinal) + , (5 , CSuper) + , (9 , CInterface) , (10, CAbstract) , (12, CSynthetic) , (13, CAnnotation) @@ -104,12 +111,12 @@ -- | The 'Enumish' mapping of the 'CAccessFlag' icflags :: [(Int, ICAccessFlag)] icflags = - [ (0, ICPublic) - , (1, ICPrivate) - , (2, ICProtected) - , (3, ICStatic) - , (4, ICFinal) - , (9, ICInterface) + [ (0 , ICPublic) + , (1 , ICPrivate) + , (2 , ICProtected) + , (3 , ICStatic) + , (4 , ICFinal) + , (9 , ICInterface) , (10, ICAbstract) , (12, ICSynthetic) , (13, ICAnnotation) @@ -136,13 +143,13 @@ -- | The 'Enumish' mapping of the 'FAccessFlag' fflags :: [(Int, FAccessFlag)] fflags = - [ (0, FPublic) - , (1, FPrivate) - , (2, FProtected) - , (3, FStatic) - , (4, FFinal) - , (6, FVolatile) - , (7, FTransient) + [ (0 , FPublic) + , (1 , FPrivate) + , (2 , FProtected) + , (3 , FStatic) + , (4 , FFinal) + , (6 , FVolatile) + , (7 , FTransient) , (12, FSynthetic) , (14, FEnum) ] @@ -150,3 +157,28 @@ instance Enumish FAccessFlag where inOrder = fflags + +-- | Access flags for parameters, as declared in the documentation. +data PAccessFlag + = PFinal + -- ^ Indicates that the formal parameter was declared final. + | PSynthetic + -- ^ Indicates that the formal parameter was not explicitly or + -- implicitly declared in source code, according to the specification + -- of the language in which the source code was written (JLS §13.1). + -- (The formal parameter is an implementation artifact of the compiler + -- which produced this class file.) + | PMandated + -- ^ Indicates that the formal parameter was implicitly declared in + -- source code, according to the specification of the language in which + -- the source code was written (JLS §13.1). (The formal parameter is + -- mandated by a language specification, so all compilers for the + -- language must emit it.) + deriving (Ord, Show, Eq, NFData, Generic) + +instance Enumish PAccessFlag where + inOrder = pflags + +-- | The 'Enumish' mapping of the 'PAccessFlag' +pflags :: [(Int, PAccessFlag)] +pflags = [(4, PFinal), (12, PSynthetic), (15, PMandated)] diff --git a/src/Language/JVM/Attribute.hs b/src/Language/JVM/Attribute.hs --- a/src/Language/JVM/Attribute.hs +++ b/src/Language/JVM/Attribute.hs @@ -23,38 +23,47 @@ , LineNumberTable , StackMapTable , Signature - , RuntimeVisibleAnnotations , RuntimeInvisibleAnnotations , RuntimeVisibleParameterAnnotations , RuntimeInvisibleParameterAnnotations , RuntimeVisibleTypeAnnotations , RuntimeInvisibleTypeAnnotations - , ClassTypeAnnotation , MethodTypeAnnotation , FieldTypeAnnotation , CodeTypeAnnotation , AnnotationDefault - ) where + , MethodParameters + ) +where import Language.JVM.Attribute.Base -import Language.JVM.Attribute.BootstrapMethods (BootstrapMethods) -import Language.JVM.Attribute.Code (Code) -import Language.JVM.Attribute.ConstantValue (ConstantValue) -import Language.JVM.Attribute.Exceptions (Exceptions) -import Language.JVM.Attribute.LineNumberTable (LineNumberTable) -import Language.JVM.Attribute.Signature (Signature) -import Language.JVM.Attribute.StackMapTable (StackMapTable) -import Language.JVM.Attribute.Annotations ( RuntimeVisibleAnnotations - , RuntimeInvisibleAnnotations - , RuntimeVisibleParameterAnnotations - , RuntimeInvisibleParameterAnnotations - , RuntimeVisibleTypeAnnotations - , RuntimeInvisibleTypeAnnotations - , ClassTypeAnnotation - , MethodTypeAnnotation - , FieldTypeAnnotation - , CodeTypeAnnotation - , AnnotationDefault - ) +import Language.JVM.Attribute.BootstrapMethods + ( BootstrapMethods ) +import Language.JVM.Attribute.Code ( Code ) +import Language.JVM.Attribute.ConstantValue + ( ConstantValue ) +import Language.JVM.Attribute.Exceptions + ( Exceptions ) +import Language.JVM.Attribute.LineNumberTable + ( LineNumberTable ) +import Language.JVM.Attribute.Signature + ( Signature ) +import Language.JVM.Attribute.StackMapTable + ( StackMapTable ) +import Language.JVM.Attribute.Annotations + ( RuntimeVisibleAnnotations + , RuntimeInvisibleAnnotations + , RuntimeVisibleParameterAnnotations + , RuntimeInvisibleParameterAnnotations + , RuntimeVisibleTypeAnnotations + , RuntimeInvisibleTypeAnnotations + , ClassTypeAnnotation + , MethodTypeAnnotation + , FieldTypeAnnotation + , CodeTypeAnnotation + , AnnotationDefault + ) +import Language.JVM.Attribute.MethodParameters + ( MethodParameters ) diff --git a/src/Language/JVM/Attribute/Annotations.hs b/src/Language/JVM/Attribute/Annotations.hs --- a/src/Language/JVM/Attribute/Annotations.hs +++ b/src/Language/JVM/Attribute/Annotations.hs @@ -16,63 +16,58 @@ [here](https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.16). -} module Language.JVM.Attribute.Annotations - ( RuntimeVisibleAnnotations (..) - , RuntimeInvisibleAnnotations (..) - , RuntimeVisibleParameterAnnotations (..) - , RuntimeInvisibleParameterAnnotations (..) - - , Annotation (..) - , ElementValue (..) - , EnumValue (..) - , ValuePair (..) + ( RuntimeVisibleAnnotations(..) + , RuntimeInvisibleAnnotations(..) + , RuntimeVisibleParameterAnnotations(..) + , RuntimeInvisibleParameterAnnotations(..) + , Annotation(..) + , ElementValue(..) + , EnumValue(..) + , ValuePair(..) -- * TypeAnnotations - - , TypeAnnotation (..) - + , TypeAnnotation(..) , TypePath - , TypePathItem (..) - , TypePathKind (..) - - , RuntimeVisibleTypeAnnotations (..) - , RuntimeInvisibleTypeAnnotations (..) - - , ClassTypeAnnotation (..) - , MethodTypeAnnotation (..) - , FieldTypeAnnotation (..) - , CodeTypeAnnotation (..) - + , TypePathItem(..) + , TypePathKind(..) + , RuntimeVisibleTypeAnnotations(..) + , RuntimeInvisibleTypeAnnotations(..) + , ClassTypeAnnotation(..) + , MethodTypeAnnotation(..) + , FieldTypeAnnotation(..) + , CodeTypeAnnotation(..) , TypeParameterTarget , SupertypeTarget , isInExtendsClause - , TypeParameterBoundTarget + , TypeParameterBoundTarget(..) , FormalParameterTarget , ThrowsTarget , LocalvarTarget - , LocalvarEntry (..) + , LocalvarEntry(..) , CatchTarget , OffsetTarget - , TypeArgumentTarget (..) + , TypeArgumentTarget(..) -- * AnnotationDefault - , AnnotationDefault (..) - ) where + , AnnotationDefault(..) + ) +where -- base -import Data.Char -import Numeric -import GHC.Generics -import Unsafe.Coerce +import Data.Char +import Numeric +import GHC.Generics +import Unsafe.Coerce -- text -import qualified Data.Text as Text +import qualified Data.Text as Text -- nfdata -import Control.DeepSeq +import Control.DeepSeq -- binary -import Data.Binary -import qualified Data.Binary.Get as Get +import Data.Binary +import qualified Data.Binary.Get as Get -- jvm-binary import Language.JVM.Attribute.Base @@ -93,8 +88,7 @@ instance Staged RuntimeVisibleAnnotations where stage f (RuntimeVisibleAnnotations m) = - label "RuntimeVisibleAnnotations" - $ RuntimeVisibleAnnotations <$> mapM f m + label "RuntimeVisibleAnnotations" $ RuntimeVisibleAnnotations <$> mapM f m newtype RuntimeInvisibleAnnotations r = RuntimeInvisibleAnnotations { asListOfRuntimeInvisibleAnnotations :: SizedList16 (Annotation r) @@ -106,7 +100,8 @@ instance Staged RuntimeInvisibleAnnotations where stage f (RuntimeInvisibleAnnotations m) = label "RuntimeInvisibleAnnotations" - $ RuntimeInvisibleAnnotations <$> mapM f m + $ RuntimeInvisibleAnnotations + <$> mapM f m newtype RuntimeVisibleParameterAnnotations r = RuntimeVisibleParameterAnnotations @@ -121,7 +116,8 @@ instance Staged RuntimeVisibleParameterAnnotations where stage f (RuntimeVisibleParameterAnnotations m) = label "RuntimeVisibleParameterAnnotations" - $ RuntimeVisibleParameterAnnotations <$> mapM (mapM f) m + $ RuntimeVisibleParameterAnnotations + <$> mapM (mapM f) m newtype RuntimeInvisibleParameterAnnotations r = RuntimeInvisibleParameterAnnotations @@ -136,16 +132,17 @@ instance Staged RuntimeInvisibleParameterAnnotations where stage f (RuntimeInvisibleParameterAnnotations m) = label "RuntimeInvisibleParameterAnnotations" - $ RuntimeInvisibleParameterAnnotations <$> mapM (mapM f) m + $ RuntimeInvisibleParameterAnnotations + <$> mapM (mapM f) m data Annotation r = Annotation - { annotationType :: !(Ref Text.Text r) + { annotationType :: !(Ref FieldDescriptor r) , annotationValuePairs :: !(SizedList16 (ValuePair r)) } instance Staged Annotation where - evolve (Annotation t b) = Annotation <$> link t <*> mapM evolve b - devolve (Annotation t b) = Annotation <$> unlink t <*> mapM devolve b + evolve (Annotation t b) = Annotation <$> link t <*> mapM evolve b + devolve (Annotation t b) = Annotation <$> unlink t <*> mapM devolve b data ValuePair r = ValuePair { name :: !(Ref Text.Text r) @@ -153,7 +150,7 @@ } instance Staged ValuePair where - evolve (ValuePair t b) = ValuePair <$> link t <*> evolve b + evolve (ValuePair t b) = ValuePair <$> link t <*> evolve b devolve (ValuePair t b) = ValuePair <$> unlink t <*> devolve b data ElementValue r @@ -175,34 +172,34 @@ instance Staged ElementValue where evolve = \case - EByte s -> EByte <$> link s - EChar s -> EChar <$> link s - EDouble s -> EDouble <$> link s - EFloat s -> EFloat <$> link s - EInt s -> EInt <$> link s - ELong s -> ELong <$> link s - EShort s -> EShort <$> link s - EBoolean s -> EBoolean <$> link s - EString s -> EString <$> link s - EEnum s -> EEnum <$> evolve s - EClass s -> EClass <$> link s + EByte s -> EByte <$> link s + EChar s -> EChar <$> link s + EDouble s -> EDouble <$> link s + EFloat s -> EFloat <$> link s + EInt s -> EInt <$> link s + ELong s -> ELong <$> link s + EShort s -> EShort <$> link s + EBoolean s -> EBoolean <$> link s + EString s -> EString <$> link s + EEnum s -> EEnum <$> evolve s + EClass s -> EClass <$> link s EAnnotationType s -> EAnnotationType <$> evolve s - EArrayType s -> EArrayType <$> mapM evolve s + EArrayType s -> EArrayType <$> mapM evolve s devolve = \case - EByte s -> EByte <$> unlink s - EChar s -> EChar <$> unlink s - EDouble s -> EDouble <$> unlink s - EFloat s -> EFloat <$> unlink s - EInt s -> EInt <$> unlink s - ELong s -> ELong <$> unlink s - EShort s -> EShort <$> unlink s - EEnum s -> EEnum <$> devolve s - EBoolean s -> EBoolean <$> unlink s - EString s -> EString <$> unlink s - EClass s -> EClass <$> unlink s + EByte s -> EByte <$> unlink s + EChar s -> EChar <$> unlink s + EDouble s -> EDouble <$> unlink s + EFloat s -> EFloat <$> unlink s + EInt s -> EInt <$> unlink s + ELong s -> ELong <$> unlink s + EShort s -> EShort <$> unlink s + EEnum s -> EEnum <$> devolve s + EBoolean s -> EBoolean <$> unlink s + EString s -> EString <$> unlink s + EClass s -> EClass <$> unlink s EAnnotationType s -> EAnnotationType <$> devolve s - EArrayType s -> EArrayType <$> mapM devolve s + EArrayType s -> EArrayType <$> mapM devolve s instance Binary (ElementValue Low) where get = Get.label "ElementValue" $ getChar8 >>= \case @@ -219,25 +216,23 @@ 'c' -> EClass <$> get '@' -> EAnnotationType <$> get '[' -> EArrayType <$> get - c -> fail $ "Does not know " ++ show c - + c -> fail $ "Does not know " ++ show c where getChar8 = chr . fromIntegral <$> Get.getWord8 put = \case - EByte a -> putChar8 'B' >> put a - EChar a -> putChar8 'C' >> put a - EDouble a -> putChar8 'D' >> put a - EFloat a -> putChar8 'F' >> put a - EInt a -> putChar8 'I' >> put a - ELong a -> putChar8 'J' >> put a - EShort a -> putChar8 'S' >> put a - EBoolean a -> putChar8 'Z' >> put a - EString a -> putChar8 's' >> put a - EEnum a -> putChar8 'e' >> put a - EClass a -> putChar8 'c' >> put a + EByte a -> putChar8 'B' >> put a + EChar a -> putChar8 'C' >> put a + EDouble a -> putChar8 'D' >> put a + EFloat a -> putChar8 'F' >> put a + EInt a -> putChar8 'I' >> put a + ELong a -> putChar8 'J' >> put a + EShort a -> putChar8 'S' >> put a + EBoolean a -> putChar8 'Z' >> put a + EString a -> putChar8 's' >> put a + EEnum a -> putChar8 'e' >> put a + EClass a -> putChar8 'c' >> put a EAnnotationType a -> putChar8 '@' >> put a - EArrayType a -> putChar8 '[' >> put a - + EArrayType a -> putChar8 '[' >> put a where putChar8 = putWord8 . fromIntegral . ord data EnumValue r = EnumValue @@ -249,42 +244,52 @@ evolve (EnumValue n c) = EnumValue <$> link n <*> link c devolve (EnumValue n c) = EnumValue <$> unlink n <*> unlink c - -- Type Annoations --- | A TypeAnnoation is targeting different types. +-- | A 'TypeAnnotation' is targeting different types. data TypeAnnotation m r = TypeAnnotation - { typeAnnotationTarget :: m r + { typeAnnotationTarget :: !(m r) , typeAnnotationPath :: !TypePath + , typeAnnotationType :: !(Ref FieldDescriptor r) , typeAnnotationValuePairs :: SizedList16 (ValuePair r) } instance Binary (m Low) => Binary (TypeAnnotation m Low) where - get = TypeAnnotation <$> get <*> get <*> get + get = TypeAnnotation <$> get <*> get <*> get <*> get put TypeAnnotation {..} = put typeAnnotationTarget - >> put typeAnnotationPath - >> put typeAnnotationValuePairs + >> put typeAnnotationPath + >> put typeAnnotationType + >> put typeAnnotationValuePairs instance Staged m => Staged (TypeAnnotation m) where - stage f TypeAnnotation {..} = + evolve TypeAnnotation {..} = TypeAnnotation - <$> stage f typeAnnotationTarget - <*> pure typeAnnotationPath - <*> mapM f typeAnnotationValuePairs + <$> evolve typeAnnotationTarget + <*> pure typeAnnotationPath + <*> link typeAnnotationType + <*> mapM evolve typeAnnotationValuePairs + devolve TypeAnnotation {..} = + TypeAnnotation + <$> devolve typeAnnotationTarget + <*> pure typeAnnotationPath + <*> unlink typeAnnotationType + <*> mapM devolve typeAnnotationValuePairs instance ByteCodeStaged m => ByteCodeStaged (TypeAnnotation m) where evolveBC f TypeAnnotation {..} = TypeAnnotation - <$> evolveBC f typeAnnotationTarget - <*> pure typeAnnotationPath - <*> mapM evolve typeAnnotationValuePairs + <$> evolveBC f typeAnnotationTarget + <*> pure typeAnnotationPath + <*> link typeAnnotationType + <*> mapM evolve typeAnnotationValuePairs devolveBC f TypeAnnotation {..} = TypeAnnotation - <$> devolveBC f typeAnnotationTarget - <*> pure typeAnnotationPath - <*> mapM devolve typeAnnotationValuePairs + <$> devolveBC f typeAnnotationTarget + <*> pure typeAnnotationPath + <*> unlink typeAnnotationType + <*> mapM devolve typeAnnotationValuePairs deriving instance Show (m High) => Show (TypeAnnotation m High) deriving instance Eq (m High) => Eq (TypeAnnotation m High) @@ -320,13 +325,13 @@ 3 -> pure TPathTypeArgument a -> fail $ "Expected unsigned byte in range [0:3] got: " ++ show a typePathIndex <- getWord8 - pure $ TypePathItem {..} + pure $ TypePathItem { .. } put TypePathItem {..} = do putWord8 $ case typePathKind of - TPathInArray -> 0 - TPathInNested -> 1 - TPathWildcard -> 2 + TPathInArray -> 0 + TPathInNested -> 1 + TPathWildcard -> 2 TPathTypeArgument -> 3 putWord8 typePathIndex @@ -347,15 +352,19 @@ 0x00 -> ClassTypeParameterDeclaration <$> get 0x10 -> ClassSuperType <$> get 0x11 -> ClassBoundTypeParameterDeclaration <$> get - a -> fail $ "Unexpected target type " ++ showHex a "" ++ " in class type annotation" + a -> + fail + $ "Unexpected target type " + ++ showHex a "" + ++ " in class type annotation" put = \case - ClassTypeParameterDeclaration a -> putWord8 0x00 >> put a - ClassSuperType a -> putWord8 0x10 >> put a + ClassTypeParameterDeclaration a -> putWord8 0x00 >> put a + ClassSuperType a -> putWord8 0x10 >> put a ClassBoundTypeParameterDeclaration a -> putWord8 0x11 >> put a instance Staged ClassTypeAnnotation where - stage _ = unsafeCoerce + stage _ = pure . unsafeCoerce data MethodTypeAnnotation r = MethodTypeParameterDeclaration !TypeParameterTarget @@ -381,30 +390,38 @@ 0x15 -> pure MethodReceiverType 0x16 -> MethodFormalParameter <$> get 0x17 -> MethodThrowsClause <$> get - a -> fail $ "Unexpected target type " ++ showHex a "" ++ " in method type annotation" + a -> + fail + $ "Unexpected target type " + ++ showHex a "" + ++ " in method type annotation" put = \case - MethodTypeParameterDeclaration a -> putWord8 0x01 >> put a + MethodTypeParameterDeclaration a -> putWord8 0x01 >> put a MethodBoundTypeParameterDeclaration a -> putWord8 0x12 >> put a - MethodReturnType -> putWord8 0x14 - MethodReceiverType -> putWord8 0x15 - MethodFormalParameter a -> putWord8 0x16 >> put a - MethodThrowsClause a -> putWord8 0x17 >> put a + MethodReturnType -> putWord8 0x14 + MethodReceiverType -> putWord8 0x15 + MethodFormalParameter a -> putWord8 0x16 >> put a + MethodThrowsClause a -> putWord8 0x17 >> put a instance Staged MethodTypeAnnotation where - stage _ = unsafeCoerce + stage _ = pure . unsafeCoerce data FieldTypeAnnotation r = FieldTypeAnnotation -- ^ type in field declaration (0x13) instance Staged FieldTypeAnnotation where - stage _ = unsafeCoerce + stage _ = pure . unsafeCoerce instance Binary (FieldTypeAnnotation Low) where get = getWord8 >>= \case 0x13 -> pure FieldTypeAnnotation - a -> fail $ "Unexpected target type " ++ showHex a "" ++ " in field type annotation" + a -> + fail + $ "Unexpected target type " + ++ showHex a "" + ++ " in field type annotation" put _ = putWord8 0x13 @@ -449,51 +466,66 @@ 0x49 -> MethodIncovationExpression <$> get 0x4A -> GenericNewMethodReferenceExpression <$> get 0x4B -> GenericIdentifierwMethodReferenceExpression <$> get - a -> fail $ "Unexpected target type " ++ showHex a "" ++ " in code type annotation" + a -> + fail + $ "Unexpected target type " + ++ showHex a "" + ++ " in code type annotation" put = \case - LocalVariableDeclaration a -> putWord8 0x40 >> put a - ResourceVariableDeclaration a -> putWord8 0x41 >> put a - ExceptionParameterDeclaration a -> putWord8 0x42 >> put a - InstanceOfExpression a -> putWord8 0x43 >> put a - NewExpression a -> putWord8 0x44 >> put a - NewMethodReferenceExpression a -> putWord8 0x45 >> put a - IdentifierMethodReferenceExpression a -> putWord8 0x46 >> put a - CastExpression a -> putWord8 0x47 >> put a - ConstructorExpression a -> putWord8 0x48 >> put a - MethodIncovationExpression a -> putWord8 0x49 >> put a - GenericNewMethodReferenceExpression a -> putWord8 0x4A >> put a + LocalVariableDeclaration a -> putWord8 0x40 >> put a + ResourceVariableDeclaration a -> putWord8 0x41 >> put a + ExceptionParameterDeclaration a -> putWord8 0x42 >> put a + InstanceOfExpression a -> putWord8 0x43 >> put a + NewExpression a -> putWord8 0x44 >> put a + NewMethodReferenceExpression a -> putWord8 0x45 >> put a + IdentifierMethodReferenceExpression a -> putWord8 0x46 >> put a + CastExpression a -> putWord8 0x47 >> put a + ConstructorExpression a -> putWord8 0x48 >> put a + MethodIncovationExpression a -> putWord8 0x49 >> put a + GenericNewMethodReferenceExpression a -> putWord8 0x4A >> put a GenericIdentifierwMethodReferenceExpression a -> putWord8 0x4B >> put a - instance ByteCodeStaged CodeTypeAnnotation where evolveBC ev = \case - LocalVariableDeclaration a -> LocalVariableDeclaration <$> mapM (evolveBC ev) a - ResourceVariableDeclaration a -> ResourceVariableDeclaration <$> mapM (evolveBC ev) a + LocalVariableDeclaration a -> + LocalVariableDeclaration <$> mapM (evolveBC ev) a + ResourceVariableDeclaration a -> + ResourceVariableDeclaration <$> mapM (evolveBC ev) a ExceptionParameterDeclaration a -> pure $ ExceptionParameterDeclaration a - InstanceOfExpression a -> InstanceOfExpression <$> ev a - NewExpression a -> NewExpression <$> ev a - NewMethodReferenceExpression a -> NewMethodReferenceExpression <$> ev a - IdentifierMethodReferenceExpression a -> IdentifierMethodReferenceExpression <$> ev a - CastExpression a -> CastExpression <$> evolveBC ev a + InstanceOfExpression a -> InstanceOfExpression <$> ev a + NewExpression a -> NewExpression <$> ev a + NewMethodReferenceExpression a -> NewMethodReferenceExpression <$> ev a + IdentifierMethodReferenceExpression a -> + IdentifierMethodReferenceExpression <$> ev a + CastExpression a -> CastExpression <$> evolveBC ev a ConstructorExpression a -> ConstructorExpression <$> evolveBC ev a - MethodIncovationExpression a -> MethodIncovationExpression <$> evolveBC ev a - GenericNewMethodReferenceExpression a -> GenericNewMethodReferenceExpression <$> evolveBC ev a - GenericIdentifierwMethodReferenceExpression a -> GenericIdentifierwMethodReferenceExpression <$> evolveBC ev a + MethodIncovationExpression a -> + MethodIncovationExpression <$> evolveBC ev a + GenericNewMethodReferenceExpression a -> + GenericNewMethodReferenceExpression <$> evolveBC ev a + GenericIdentifierwMethodReferenceExpression a -> + GenericIdentifierwMethodReferenceExpression <$> evolveBC ev a devolveBC dev = \case - LocalVariableDeclaration a -> LocalVariableDeclaration <$> mapM (devolveBC dev) a - ResourceVariableDeclaration a -> ResourceVariableDeclaration <$> mapM (devolveBC dev) a + LocalVariableDeclaration a -> + LocalVariableDeclaration <$> mapM (devolveBC dev) a + ResourceVariableDeclaration a -> + ResourceVariableDeclaration <$> mapM (devolveBC dev) a ExceptionParameterDeclaration a -> pure $ ExceptionParameterDeclaration a - InstanceOfExpression a -> InstanceOfExpression <$> dev a - NewExpression a -> NewExpression <$> dev a - NewMethodReferenceExpression a -> NewMethodReferenceExpression <$> dev a - IdentifierMethodReferenceExpression a -> IdentifierMethodReferenceExpression <$> dev a - CastExpression a -> CastExpression <$> devolveBC dev a + InstanceOfExpression a -> InstanceOfExpression <$> dev a + NewExpression a -> NewExpression <$> dev a + NewMethodReferenceExpression a -> NewMethodReferenceExpression <$> dev a + IdentifierMethodReferenceExpression a -> + IdentifierMethodReferenceExpression <$> dev a + CastExpression a -> CastExpression <$> devolveBC dev a ConstructorExpression a -> ConstructorExpression <$> devolveBC dev a - MethodIncovationExpression a -> MethodIncovationExpression <$> devolveBC dev a - GenericNewMethodReferenceExpression a -> GenericNewMethodReferenceExpression <$> devolveBC dev a - GenericIdentifierwMethodReferenceExpression a -> GenericIdentifierwMethodReferenceExpression <$> devolveBC dev a + MethodIncovationExpression a -> + MethodIncovationExpression <$> devolveBC dev a + GenericNewMethodReferenceExpression a -> + GenericNewMethodReferenceExpression <$> devolveBC dev a + GenericIdentifierwMethodReferenceExpression a -> + GenericIdentifierwMethodReferenceExpression <$> devolveBC dev a -- | The 'TypeParameterTarget' item indicates that an annotation appears on the -- declaration of the i'th type parameter of a generic class, generic interface, @@ -672,12 +704,27 @@ $(deriveBaseWithBinary ''AnnotationDefault) $(deriveBase ''ElementValue) +deriving instance Ord (ValuePair High) +deriving instance Ord (ElementValue High) +deriving instance Ord (EnumValue High) +deriving instance Ord (Annotation High) + $(deriveBase ''ClassTypeAnnotation) $(deriveBase ''MethodTypeAnnotation) $(deriveBase ''FieldTypeAnnotation) $(deriveBase ''CodeTypeAnnotation) +deriving instance Ord (MethodTypeAnnotation High) +deriving instance Ord (ClassTypeAnnotation High) +deriving instance Ord (FieldTypeAnnotation High) +deriving instance Ord (CodeTypeAnnotation High) + +deriving instance Ord (a High) => Ord (TypeAnnotation a High) + $(deriveBaseWithBinary ''LocalvarEntry) $(deriveBaseWithBinary ''TypeArgumentTarget) + +deriving instance Ord (LocalvarEntry High) +deriving instance Ord (TypeArgumentTarget High) $(deriveBaseWithBinary ''EnumValue) diff --git a/src/Language/JVM/Attribute/Base.hs b/src/Language/JVM/Attribute/Base.hs --- a/src/Language/JVM/Attribute/Base.hs +++ b/src/Language/JVM/Attribute/Base.hs @@ -126,7 +126,7 @@ -> Maybe (m (a High)) fromAttribute as = if aName as == getConst (attrName :: Const Text.Text (a Low)) - then Just . label (Text.unpack $ aName as) . either attributeError evolve $ fromAttribute' as + then Just . label (Text.unpack $ aName as) . either evolveError evolve $ fromAttribute' as else Nothing -- | Generate an BCAttribute in the 'EvolveM' monad @@ -137,7 +137,7 @@ -> Maybe (m (a High)) fromBCAttribute fn as = if aName as == getConst (attrName :: Const Text.Text (a Low)) - then Just . label (Text.unpack $ aName as) . either attributeError (evolveBC fn) $ fromAttribute' as + then Just . label (Text.unpack $ aName as) . either evolveError (evolveBC fn) $ fromAttribute' as else Nothing -- -- | Generate an attribute in the 'EvolveM' monad diff --git a/src/Language/JVM/Attribute/ConstantValue.hs b/src/Language/JVM/Attribute/ConstantValue.hs --- a/src/Language/JVM/Attribute/ConstantValue.hs +++ b/src/Language/JVM/Attribute/ConstantValue.hs @@ -14,8 +14,9 @@ -} module Language.JVM.Attribute.ConstantValue - ( ConstantValue (..) - ) where + ( ConstantValue(..) + ) +where import Language.JVM.Attribute.Base import Language.JVM.Constant @@ -25,16 +26,13 @@ instance IsAttribute (ConstantValue Low) where attrName = Const "ConstantValue" - -- | A constant value is just a index into the constant pool. -data ConstantValue r = ConstantValue - { constantValue :: !(Ref JValue r) +newtype ConstantValue r = ConstantValue + { constantValue :: Ref JValue r } instance Staged ConstantValue where - evolve (ConstantValue r) = - ConstantValue <$> link r - devolve (ConstantValue r) = - ConstantValue <$> unlink r + evolve (ConstantValue r) = ConstantValue <$> link r + devolve (ConstantValue r) = ConstantValue <$> unlink r $(deriveBaseWithBinary ''ConstantValue) diff --git a/src/Language/JVM/Attribute/MethodParameters.hs b/src/Language/JVM/Attribute/MethodParameters.hs new file mode 100644 --- /dev/null +++ b/src/Language/JVM/Attribute/MethodParameters.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-| +Module : Language.JVM.Attribute.MethodParameters +Copyright : (c) Christian Gram Kalhauge, 2017 +License : MIT +Maintainer : kalhuage@cs.ucla.edu + +Based on the MethodParameters Attribute, as documented +[here](http://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.24). +-} + +module Language.JVM.Attribute.MethodParameters + ( MethodParameters(..) + , MethodParameter(..) + ) +where + +import qualified Data.Text as Text + +import Language.JVM.Constant +import Language.JVM.Attribute.Base +import Language.JVM.Staged +import Language.JVM.Utils +import Language.JVM.AccessFlag + +-- | 'BootstrapMethods' is an Attribute. +instance IsAttribute (MethodParameters Low) where + attrName = Const "MethodParameters" + +-- | Is a list of method parameters, one for each parameter +newtype MethodParameters r = MethodParameters + { methodParameters :: SizedList8 (MethodParameter r) + } + +-- | A method parameter +data MethodParameter r = MethodParameter + { parameterName :: !(Ref Text.Text r) + , parameterAccessFlags :: !(BitSet16 PAccessFlag) + } + +instance Staged MethodParameters where + stage f (MethodParameters m) = + label "BootstrapMethods" $ MethodParameters <$> mapM f m + +instance Staged MethodParameter where + evolve (MethodParameter a m) = MethodParameter <$> link a <*> pure m + + devolve (MethodParameter a m) = MethodParameter <$> unlink a <*> pure m + +$(deriveBaseWithBinary ''MethodParameter) +$(deriveBaseWithBinary ''MethodParameters) diff --git a/src/Language/JVM/Attribute/Signature.hs b/src/Language/JVM/Attribute/Signature.hs --- a/src/Language/JVM/Attribute/Signature.hs +++ b/src/Language/JVM/Attribute/Signature.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} @@ -16,70 +18,89 @@ -} module Language.JVM.Attribute.Signature - ( Signature (..) + ( Signature(..) , signatureToText , signatureFromText -- * Top Level Definitions - - , ClassSignature (..) + , ClassSignature(..) + , isSimpleClassSignature , classSignatureToText , classSignatureFromText - , classSignatureP - , MethodSignature (..) + , MethodSignature(..) + , isSimpleMethodSignature , methodSignatureToText , methodSignatureFromText - , methodSignatureP - , FieldSignature (..) + , FieldSignature(..) + , isSimpleFieldSignature , fieldSignatureToText , fieldSignatureFromText - , fieldSignatureP + -- ** Handlers + + -- * Lower Level Definitions - , ClassType (..) + , ClassType(..) + , isSimpleClassType + , classTypeToName + , classTypeFromName + , InnerClassType(..) + , ReferenceType(..) + , isSimpleReferenceType + , referenceTypeFromRefType + , ThrowsSignature(..) + , isSimpleThrowsSignature + , throwsSignatureFromName + , TypeSignature(..) + , isSimpleTypeSignature + , typeSignatureFromType + , TypeArgument(..) + , TypeParameter(..) + , TypeVariable(..) + , Wildcard(..) + + -- * Parsers + , classSignatureP + , methodSignatureP + , fieldSignatureP , classTypeP , classTypeT - , ReferenceType (..) , referenceTypeP , referenceTypeT - , ThrowsSignature (..) , throwsSignatureP , throwsSignatureT - , TypeArgument (..) , typeArgumentsT , typeArgumentsP , typeArgumentP , typeArgumentT - , TypeParameter (..) , typeParameterP , typeParameterT , typeParametersT , typeParametersP - , TypeSignature (..) - , TypeVariable (..) + , typeSignatureP + , typeSignatureT , typeVariableP - , Wildcard (..) - ) where + ) +where -import Control.DeepSeq (NFData) -import qualified Data.Text as Text +import Control.DeepSeq ( NFData ) +import qualified Data.Text as Text -import qualified Data.Text.Lazy as LText -import Data.Text.Lazy.Builder as Text +import qualified Data.Text.Lazy as LText +import Data.Text.Lazy.Builder as Text import Data.Functor -import GHC.Generics (Generic) +import GHC.Generics ( Generic ) import Data.Attoparsec.Text import Control.Applicative -import qualified Data.List as L +import qualified Data.List as L import Language.JVM.Attribute.Base import Language.JVM.Staged import Language.JVM.Type - instance IsAttribute (Signature Low) where attrName = Const "Signature" @@ -97,7 +118,7 @@ , csSuperclassSignature :: ClassType , csInterfaceSignatures :: [ClassType] } - deriving (Show, Eq, Generic, NFData) + deriving (Show, Eq, Ord, Generic, NFData) data MethodSignature = MethodSignature { msTypeParameters :: [TypeParameter] @@ -105,58 +126,176 @@ , msResults :: Maybe TypeSignature , msThrows :: [ ThrowsSignature ] } - deriving (Show, Eq, Generic, NFData) + deriving (Show, Eq, Ord, Generic, NFData) newtype FieldSignature = FieldSignature {fsRefType :: ReferenceType} - deriving (Show, Eq, Generic, NFData) - + deriving (Show, Eq, Ord, Generic, NFData) data TypeSignature = ReferenceType ReferenceType | BaseType JBaseType - deriving (Show, Eq, Generic, NFData) + deriving (Show, Eq, Ord, Generic, NFData) data ReferenceType = RefClassType ClassType | RefTypeVariable TypeVariable | RefArrayType TypeSignature - deriving (Show, Eq, Generic, NFData) + deriving (Show, Eq, Ord, Generic, NFData) data ClassType = ClassType - { ctsClassName :: ClassName + { ctsName :: !ClassName + , ctsInnerClass :: !(Maybe InnerClassType) , ctsTypeArguments :: [Maybe TypeArgument] } - | InnerClassType - { ctsInnerClassName :: Text.Text - , ctsOuterClassType :: ClassType - , ctsTypeArguments :: [Maybe TypeArgument] + deriving (Show, Eq, Ord, Generic, NFData) + +data InnerClassType + = InnerClassType + { ictsName :: !Text.Text + , ictsInnerClass :: !(Maybe InnerClassType) + , ictsTypeArguments :: [Maybe TypeArgument] } - deriving (Show, Eq, Generic, NFData) + deriving (Show, Eq, Ord, Generic, NFData) data TypeArgument = TypeArgument { taWildcard :: Maybe Wildcard , taType :: ReferenceType - } deriving (Show, Eq, Generic, NFData) + } deriving (Show, Eq, Ord, Generic, NFData) data Wildcard = WildPlus | WildMinus - deriving (Show, Eq, Generic, NFData) + deriving (Show, Eq, Ord, Generic, NFData) newtype TypeVariable = TypeVariable { tvAsText :: Text.Text } - deriving (Show, Eq, Generic, NFData) + deriving (Show, Eq, Ord, Generic, NFData) data TypeParameter = TypeParameter - { tpIndentifier :: Text.Text + { tpIdentifier :: Text.Text , tpClassBound :: Maybe ReferenceType , tpInterfaceBound :: [ReferenceType] } - deriving (Show, Eq, Generic, NFData) + deriving (Show, Eq, Ord, Generic, NFData) +data ThrowsSignature + = ThrowsClass ClassType + | ThrowsTypeVariable TypeVariable + deriving (Show, Eq, Ord, Generic, NFData) +-- Conversion + +classTypeToName :: ClassType -> ClassName +classTypeToName = + (either error id . textCls . Text.intercalate "$" . getClassName) + where + getClassName (ClassType {..}) = + classNameAsText ctsName : getInnerClassName ctsInnerClass + + getInnerClassName = \case + Just (InnerClassType {..}) -> ictsName : getInnerClassName ictsInnerClass + Nothing -> [] + +-- | Create a classType from a Name +-- Note the language is wierd here! Main.A is not Main$A, but Main.A is! +classTypeFromName :: ClassName -> ClassType +classTypeFromName cn = ClassType cn Nothing [] + +throwsSignatureFromName :: ClassName -> ThrowsSignature +throwsSignatureFromName cn = ThrowsClass (classTypeFromName cn) + +referenceTypeFromRefType :: JRefType -> ReferenceType +referenceTypeFromRefType = \case + JTArray a -> RefArrayType (typeSignatureFromType a) + JTClass a -> RefClassType (classTypeFromName a) + +typeSignatureFromType :: JType -> TypeSignature +typeSignatureFromType = \case + JTBase a -> BaseType a + JTRef a -> ReferenceType (referenceTypeFromRefType a) + +isSimpleMethodSignature :: MethodSignature -> Bool +isSimpleMethodSignature MethodSignature {..} = and + [ null msTypeParameters + , all isSimpleTypeSignature msArguments + , all isSimpleTypeSignature msResults + , all isSimpleThrowsSignature msThrows + ] + +isSimpleClassSignature :: ClassSignature -> Bool +isSimpleClassSignature ClassSignature {..} = and + [ null csTypeParameters + , isSimpleClassType csSuperclassSignature + , all isSimpleClassType csInterfaceSignatures + ] + +isSimpleFieldSignature :: FieldSignature -> Bool +isSimpleFieldSignature FieldSignature {..} = isSimpleReferenceType fsRefType + +isSimpleTypeSignature :: TypeSignature -> Bool +isSimpleTypeSignature = \case + BaseType _ -> True + ReferenceType a -> isSimpleReferenceType a + +isSimpleReferenceType :: ReferenceType -> Bool +isSimpleReferenceType = \case + RefArrayType a -> isSimpleTypeSignature a + RefClassType a -> isSimpleClassType a + RefTypeVariable _ -> False + +isSimpleClassType :: ClassType -> Bool +isSimpleClassType = \case + ClassType _ Nothing [] -> True + _ -> False + +isSimpleThrowsSignature :: ThrowsSignature -> Bool +isSimpleThrowsSignature = \case + ThrowsClass a -> isSimpleClassType a + ThrowsTypeVariable _ -> False + + +instance TextSerializable ClassSignature where + parseText = classSignatureP + toBuilder = classSignatureT + +instance TextSerializable MethodSignature where + parseText = methodSignatureP + toBuilder = methodSignatureT + +instance TextSerializable FieldSignature where + parseText = fieldSignatureP + toBuilder = fieldSignatureT + +instance TextSerializable TypeSignature where + parseText = typeSignatureP + toBuilder = typeSignatureT + +instance TextSerializable ReferenceType where + parseText = referenceTypeP + toBuilder = referenceTypeT + +instance TextSerializable ClassType where + parseText = classTypeP + toBuilder = classTypeT + +instance TextSerializable Wildcard where + parseText = wildcardP + toBuilder = wildcardT + +instance TextSerializable TypeVariable where + parseText = typeVariableP + toBuilder = typeVariableT + +instance TextSerializable TypeParameter where + parseText = typeParameterP + toBuilder = typeParameterT + +instance TextSerializable ThrowsSignature where + parseText = throwsSignatureP + toBuilder = throwsSignatureT + ---------------------- -- Parsing ---------------------- @@ -169,26 +308,26 @@ return $ ClassSignature tp ss is classSignatureToText :: ClassSignature -> Text.Text -classSignatureToText = - LText.toStrict . toLazyText . classSignatureT +classSignatureToText = LText.toStrict . toLazyText . classSignatureT classSignatureFromText :: Text.Text -> Either String ClassSignature -classSignatureFromText = - parseOnly classSignatureP +classSignatureFromText = parseOnly classSignatureP classSignatureT :: ClassSignature -> Builder -classSignatureT (ClassSignature tp ct its)= do - typeParametersT tp <> foldMap classTypeT (ct:its) +classSignatureT (ClassSignature tp ct its) = do + typeParametersT tp <> foldMap classTypeT (ct : its) typeSignatureP :: Parser TypeSignature typeSignatureP = do - choice [ (ReferenceType <$> referenceTypeP) "JRefereceType" - , (BaseType <$> parseType) "JBaseType" ] + choice + [ (ReferenceType <$> referenceTypeP) "JRefereceType" + , (BaseType <$> parseJBaseType) "JBaseType" + ] typeSignatureT :: TypeSignature -> Builder typeSignatureT (ReferenceType t) = referenceTypeT t -typeSignatureT (BaseType t) = singleton (jBaseTypeToChar t) +typeSignatureT (BaseType t) = singleton (jBaseTypeToChar t) referenceTypeP :: Parser ReferenceType referenceTypeP = do @@ -199,58 +338,62 @@ ] referenceTypeT :: ReferenceType -> Builder -referenceTypeT t = - case t of - RefClassType ct -> classTypeT ct - RefTypeVariable tv -> typeVariableT tv - RefArrayType at -> singleton '[' <> typeSignatureT at +referenceTypeT t = case t of + RefClassType ct -> classTypeT ct + RefTypeVariable tv -> typeVariableT tv + RefArrayType at -> singleton '[' <> typeSignatureT at classTypeP :: Parser ClassType classTypeP = nameit "ClassType" $ do - _ <- char 'L' - cn <- parseType - ta <- option [] typeArgumentsP + _ <- char 'L' + cn <- parseClassName + ta <- option [] typeArgumentsP ict <- many' $ do - _ <- char '.' - i <- identifierP - ta' <- option [] typeArgumentsP - return (i, ta') + _ <- char '.' + i <- identifierP + ta' <- option [] typeArgumentsP + return (i, ta') _ <- char ';' - return $ L.foldl' (\a (i,ta') -> InnerClassType i a ta') (ClassType cn ta) ict + return $ ClassType + cn + (L.foldr (\(i, ta') a -> Just $ InnerClassType i a ta') Nothing ict) + ta classTypeT :: ClassType -> Builder -classTypeT t = - go t <> singleton ';' - where - go t' = - case t' of - InnerClassType n ct arg -> - go ct <> singleton '.' <> Text.fromText n <> typeArgumentsT arg - ClassType cn arg -> - singleton 'L' - <> Text.fromText (classNameAsText cn) - <> typeArgumentsT arg +classTypeT (ClassType n ic arg) = + singleton 'L' + <> Text.fromText (classNameAsText n) + <> typeArgumentsT arg + <> go ic + <> singleton ';' + where + go = \case + Nothing -> mempty + Just (InnerClassType n' ic' arg') -> + singleton '.' <> Text.fromText n' <> typeArgumentsT arg' <> go ic' -typeArgumentsP :: Parser [ Maybe TypeArgument ] +typeArgumentsP :: Parser [Maybe TypeArgument] typeArgumentsP = do - _ <- char '<' + _ <- char '<' tas <- many1' typeArgumentP - _ <- char '>' + _ <- char '>' return tas typeArgumentP :: Parser (Maybe TypeArgument) typeArgumentP = do - choice [ Just - <$> ( TypeArgument - <$> option Nothing (Just <$> wildcardP) - <*> referenceTypeP - ) - , char '*' $> Nothing - ] "TypeArgument" + choice + [ Just + <$> ( TypeArgument + <$> option Nothing (Just <$> wildcardP) + <*> referenceTypeP + ) + , char '*' $> Nothing + ] + "TypeArgument" -typeArgumentsT :: [ Maybe TypeArgument ] -> Builder +typeArgumentsT :: [Maybe TypeArgument] -> Builder typeArgumentsT args = do if L.null args then mempty @@ -262,15 +405,21 @@ Nothing -> singleton '*' Just (TypeArgument w rt) -> (case w of - Just WildMinus -> singleton '-' - Just WildPlus -> singleton '+' - Nothing -> mempty) <> referenceTypeT rt + Just m -> wildcardT m + Nothing -> mempty + ) + <> referenceTypeT rt wildcardP :: Parser Wildcard -wildcardP = choice [ char '+' $> WildPlus, char '-' $> WildMinus] +wildcardP = choice [char '+' $> WildPlus, char '-' $> WildMinus] +wildcardT :: Wildcard -> Builder +wildcardT = \case + WildPlus -> singleton '+' + WildMinus -> singleton '-' + typeVariableP :: Parser TypeVariable typeVariableP = do _ <- char 'T' @@ -279,18 +428,18 @@ return $ TypeVariable t typeVariableT :: TypeVariable -> Builder -typeVariableT (TypeVariable t)= do +typeVariableT (TypeVariable t) = do singleton 'T' <> Text.fromText t <> singleton ';' typeParametersP :: Parser [TypeParameter] typeParametersP = nameit "TypeParameters" $ do - _ <- char '<' + _ <- char '<' tps <- many1' typeParameterP - _ <- char '>' + _ <- char '>' return tps -typeParametersT :: [ TypeParameter ] -> Builder +typeParametersT :: [TypeParameter] -> Builder typeParametersT args = do if L.null args then mempty @@ -299,86 +448,80 @@ typeParameterP :: Parser TypeParameter typeParameterP = nameit "TypeParameter" $ do id_ <- identifierP - _ <- char ':' - cb <- optional referenceTypeP - ib <- many' (char ':' >> referenceTypeP) + _ <- char ':' + cb <- optional referenceTypeP + ib <- many' (char ':' >> referenceTypeP) return $ TypeParameter id_ cb ib typeParameterT :: TypeParameter -> Builder typeParameterT (TypeParameter n cb ibs) = - Text.fromText n <> singleton ':' <> maybe mempty referenceTypeT cb <> - foldMap (\i -> singleton ':' <> referenceTypeT i) ibs + Text.fromText n + <> singleton ':' + <> maybe mempty referenceTypeT cb + <> foldMap (\i -> singleton ':' <> referenceTypeT i) ibs nameit :: String -> Parser a -> Parser a nameit str m = m str identifierP :: Parser Text.Text -identifierP = - takeWhile1 (notInClass ".;[/<>:") "Identifier" +identifierP = takeWhile1 (notInClass ".;[/<>:") "Identifier" methodSignatureP :: Parser MethodSignature methodSignatureP = do - tps <- option [] typeParametersP - _ <- char '(' - targ <- many' typeSignatureP - _ <- char ')' - res <- choice [ Just <$> typeSignatureP, char 'V' $> Nothing ] + tps <- option [] typeParametersP + _ <- char '(' + targ <- many' typeSignatureP + _ <- char ')' + res <- choice [Just <$> typeSignatureP, char 'V' $> Nothing] thrws <- many' throwsSignatureP return $ MethodSignature tps targ res thrws methodSignatureToText :: MethodSignature -> Text.Text -methodSignatureToText = - LText.toStrict . toLazyText . methodSignatureT +methodSignatureToText = LText.toStrict . toLazyText . methodSignatureT methodSignatureFromText :: Text.Text -> Either String MethodSignature -methodSignatureFromText = - parseOnly methodSignatureP +methodSignatureFromText = parseOnly methodSignatureP fieldSignatureFromText :: Text.Text -> Either String FieldSignature -fieldSignatureFromText = - parseOnly fieldSignatureP +fieldSignatureFromText = parseOnly fieldSignatureP methodSignatureT :: MethodSignature -> Builder -methodSignatureT (MethodSignature tp args res thrws)= do +methodSignatureT (MethodSignature tp args res thrws) = do typeParametersT tp <> singleton '(' <> foldMap typeSignatureT args <> singleton ')' - <> (case res of Nothing -> singleton 'V'; Just r -> typeSignatureT r) + <> (case res of + Nothing -> singleton 'V' + Just r -> typeSignatureT r + ) <> foldMap throwsSignatureT thrws -data ThrowsSignature - = ThrowsClass ClassType - | ThrowsTypeVariable TypeVariable - deriving (Show, Eq, Generic, NFData) throwsSignatureP :: Parser ThrowsSignature throwsSignatureP = do _ <- char '^' - choice [ ThrowsClass <$> classTypeP, ThrowsTypeVariable <$> typeVariableP] + choice [ThrowsClass <$> classTypeP, ThrowsTypeVariable <$> typeVariableP] throwsSignatureT :: ThrowsSignature -> Builder -throwsSignatureT t = - singleton '^' - <> case t of - ThrowsClass ct -> classTypeT ct - ThrowsTypeVariable tt -> typeVariableT tt +throwsSignatureT t = singleton '^' <> case t of + ThrowsClass ct -> classTypeT ct + ThrowsTypeVariable tt -> typeVariableT tt fieldSignatureP :: Parser FieldSignature -fieldSignatureP = - FieldSignature <$> referenceTypeP +fieldSignatureP = FieldSignature <$> referenceTypeP fieldSignatureToText :: FieldSignature -> Text.Text -fieldSignatureToText = - LText.toStrict . toLazyText . referenceTypeT . fsRefType +fieldSignatureToText = LText.toStrict . toLazyText . referenceTypeT . fsRefType +fieldSignatureT :: FieldSignature -> Builder +fieldSignatureT = referenceTypeT . fsRefType + instance Staged Signature where - evolve (Signature a) = - label "Signature" $ Signature <$> link a + evolve (Signature a) = label "Signature" $ Signature <$> link a - devolve (Signature a) = - label "Signature" $ Signature <$> unlink a + devolve (Signature a) = label "Signature" $ Signature <$> unlink a $(deriveBaseWithBinary ''Signature) diff --git a/src/Language/JVM/Attribute/StackMapTable.hs b/src/Language/JVM/Attribute/StackMapTable.hs --- a/src/Language/JVM/Attribute/StackMapTable.hs +++ b/src/Language/JVM/Attribute/StackMapTable.hs @@ -162,9 +162,10 @@ | VTDouble | VTNull | VTUninitializedThis - | VTObject (Ref JRefType r) - | VTUninitialized !Word16 - + | VTObject !(Ref JRefType r) + | VTUninitialized !(ByteCodeRef r) + -- ^ This 'ByteCodeRef' refers to the "new" bytcode instruction + -- which created the object. instance Binary (VerificationTypeInfo Low) where get = getWord8 >>= \case @@ -197,7 +198,7 @@ where acc a (StackMapFrame delta frm) = do (lidx, lst) <- a - frm' <- evolve frm + frm' <- evolveBC f frm let bco = if lst /= [] then offsetDelta lidx delta else delta x <- f bco return (bco, StackMapFrame x frm' : lst) @@ -208,7 +209,7 @@ where acc a (StackMapFrame x frm) = do (lidx, lst) <- a - frm' <- devolve frm + frm' <- devolveBC f frm tidx <- f x let delta = if lst /= [] then offsetDeltaInv lidx tidx else tidx return (tidx, StackMapFrame delta frm' : lst) @@ -234,23 +235,40 @@ offsetDeltaInv lidx tidx = tidx - lidx - 1 -instance Staged StackMapFrameType where - stage f x = +instance ByteCodeStaged StackMapFrameType where + evolveBC f x = case x of - SameLocals1StackItemFrame a -> SameLocals1StackItemFrame <$> f a - AppendFrame ls -> AppendFrame <$> mapM f ls - FullFrame bs as -> FullFrame <$> mapM f bs <*> mapM f as - a -> return $ unsafeCoerce a + SameLocals1StackItemFrame a -> + SameLocals1StackItemFrame <$> evolveBC f a + AppendFrame ls -> + AppendFrame <$> mapM (evolveBC f) ls + FullFrame bs as -> + FullFrame <$> mapM (evolveBC f) bs <*> mapM (evolveBC f) as + a -> + return $ unsafeCoerce a -instance Staged VerificationTypeInfo where - devolve x = + devolveBC f x = case x of + SameLocals1StackItemFrame a -> + SameLocals1StackItemFrame <$> devolveBC f a + AppendFrame ls -> + AppendFrame <$> mapM (devolveBC f) ls + FullFrame bs as -> + FullFrame <$> mapM (devolveBC f) bs <*> mapM (devolveBC f) as + a -> + return $ unsafeCoerce a + +instance ByteCodeStaged VerificationTypeInfo where + devolveBC f x = + case x of VTObject a -> VTObject <$> unlink a + VTUninitialized r -> VTUninitialized <$> f r a -> return $ unsafeCoerce a - evolve x = + evolveBC f x = case x of VTObject a -> VTObject <$> link a + VTUninitialized r -> VTUninitialized <$> f r a -> return $ unsafeCoerce a $(deriveBaseWithBinary ''StackMapTable) diff --git a/src/Language/JVM/ByteCode.hs b/src/Language/JVM/ByteCode.hs --- a/src/Language/JVM/ByteCode.hs +++ b/src/Language/JVM/ByteCode.hs @@ -44,6 +44,7 @@ -- * ByteCode Operations , ByteCodeOpr (..) + , BConstant , CConstant (..) , OneOrTwo (..) @@ -53,6 +54,12 @@ , FieldAccess (..) , Invocation (..) + , ShortRelativeRef + , LongRelativeRef + , NewArrayType (..) + , newArrayTypeType + , LowNewArrayType (..) + -- * Operations , BinOpr (..) , BitOpr (..) @@ -132,7 +139,7 @@ case offsetIndex o i of Just a -> return $ a Nothing -> - attributeError $ "Not valid offset " ++ show i + evolveError $ "Not valid offset " ++ show i -- | Given low byte code we can create an `OffsetMap` offsetMap :: ByteCode Low -> OffsetMap @@ -230,20 +237,48 @@ evolveBC = evolveByteCodeInst devolveBC = devolveByteCodeInst -evolveRefType :: EvolveM m => RefType Low -> m JRefType -evolveRefType = \case - ArrayBaseType bt -> return $ JTArray (JTBase bt) - Reference m 1 -> JTArray . JTRef . JTClass <$> link m - Reference m _ -> link m -devolveRefType :: DevolveM m => JRefType -> m (RefType Low) -devolveRefType = \case - JTArray (JTBase bt) -> return $ ArrayBaseType bt - JTArray (JTRef (JTClass bt)) -> - flip Reference 1 <$> unlink bt - c -> - flip Reference (fromIntegral $ refTypeDepth c) <$> unlink c +newArrayTypeType :: NewArrayType -> JRefType +newArrayTypeType (NewArrayType n m) = extendArrays n m + where + extendArrays :: Word8 -> JType -> JRefType + extendArrays 1 = JTArray + extendArrays n = extendArrays (n-1) . JTRef . JTArray +evolveNewArrayType :: EvolveM m => LowNewArrayType -> m NewArrayType +evolveNewArrayType = \case + ArrayBaseType b -> pure $ NewArrayType 1 (JTBase b) + ArrayReference _ 0 -> evolveError "Invalid bytecode instruction" + ArrayReference m 1 -> do + m' <- link m + pure $ NewArrayType 1 (JTRef m') + ArrayReference m n -> do + m' <- link m + m'' <- dropArrays n (JTRef m') + pure $ NewArrayType n m'' + + where + dropArrays 0 = pure + dropArrays n = \case + JTRef (JTArray a) -> + dropArrays (n - 1) a + a -> + evolveError ("expected array got" <> show a) + +devolveNewArrayType :: DevolveM m => NewArrayType -> m LowNewArrayType +devolveNewArrayType = \case + NewArrayType 0 _ -> error "NewArrayType cannot have 0 dimentions" + NewArrayType 1 (JTBase m) -> + return $ ArrayBaseType m + NewArrayType 1 (JTRef m) -> do + m' <- unlink m + return $ ArrayReference m' 1 + a@(NewArrayType n _) -> do + m' <- unlink (newArrayTypeType a) + return $ ArrayReference m' n + + + evolveByteCodeInst :: EvolveM m => (ByteCodeOffset -> m ByteCodeIndex) @@ -255,7 +290,8 @@ Get fa r -> label "Get" $ Get fa <$> link r Put fa r -> label "Put" $ Put fa <$> link r Invoke r -> label "Invoke" $ Invoke <$> evolve r - New r -> label "New" $ New <$> evolveRefType r + New r -> label "New" $ New <$> link r + NewArray r -> label "NewArray" $ NewArray <$> evolveNewArrayType r CheckCast r -> label "CheckCast" $ CheckCast <$> link r InstanceOf r -> label "InstanceOf" $ InstanceOf <$> link r If cp on r -> label "If" $ If cp on <$> calcOffset r @@ -284,7 +320,8 @@ Get fa r -> label "Get" $ Get fa <$> unlink r Put fa r -> label "Put" $ Put fa <$> unlink r Invoke r -> label "Invoke" $ Invoke <$> devolve r - New r -> label "New" $ New <$> devolveRefType r + New r -> label "New" $ New <$> unlink r + NewArray r -> label "NewArray" $ NewArray <$> devolveNewArrayType r CheckCast r -> label "CheckCast" $ CheckCast <$> unlink r InstanceOf r -> label "InstanceOf" $ InstanceOf <$> unlink r If cp on r -> label "If" $ If cp on <$> calcOffset r @@ -361,10 +398,15 @@ data SmallArithmeticType = MByte | MChar | MShort deriving (Show, Ord, Eq, Enum, Bounded, Generic, NFData) -data RefType r +data LowNewArrayType = ArrayBaseType JBaseType - | Reference (Ref JRefType r) Word8 + | ArrayReference (Ref JRefType Low) Word8 + deriving (Show, Ord, Eq, Generic, NFData) +data NewArrayType + = NewArrayType Word8 JType + deriving (Show, Ord, Eq, Generic, NFData) + data LocalType = LInt | LLong | LFloat | LDouble | LRef deriving (Show, Ord, Eq, Enum, Bounded, Generic, NFData) @@ -374,12 +416,12 @@ deriving (Show, Eq, Ord, Generic, NFData) data Invocation r - = InvkSpecial !(DeepRef AbsVariableMethodId r) + = InvkSpecial !(Ref AbsVariableMethodId r) -- ^ Variable since 52.0 - | InvkVirtual !(DeepRef AbsMethodId r) - | InvkStatic !(DeepRef AbsVariableMethodId r) + | InvkVirtual !(Ref (InRefType MethodId) r) + | InvkStatic !(Ref AbsVariableMethodId r) -- ^ Variable since 52.0 - | InvkInterface !Word8 !(DeepRef AbsInterfaceMethodId r) + | InvkInterface !Word8 !(Ref AbsInterfaceMethodId r) -- ^ Should be a positive number | InvkDynamic !(DeepRef InvokeDynamic r) @@ -580,19 +622,24 @@ | LookupSwitch !(LongRelativeRef r) (V.Vector (Int32, (LongRelativeRef r))) -- ^ a lookup switch has a `default` value and a list of pairs. - | Get !FieldAccess !(DeepRef (InClass FieldId) r) - | Put !FieldAccess !(DeepRef (InClass FieldId) r) + | Get !FieldAccess !(Ref AbsFieldId r) + | Put !FieldAccess !(Ref AbsFieldId r) | Invoke !(Invocation r) - | New !(Choice (RefType Low) JRefType r) + | New !(Ref ClassName r) + + | NewArray !(Choice LowNewArrayType NewArrayType r) + -- ^ the first argument is the number of dimentions + -- of the array that have to be instantiatied. + -- The JType indicates the type of the instantiated array | ArrayLength | Throw - | CheckCast !(Ref ClassName r) - | InstanceOf !(Ref ClassName r) + | CheckCast !(Ref JRefType r) + | InstanceOf !(Ref JRefType r) | Monitor !Bool -- ^ True => Enter, False => Exit @@ -601,11 +648,11 @@ | Nop - | Pop WordSize + | Pop !WordSize - | Dup WordSize - | DupX1 WordSize - | DupX2 WordSize + | Dup !WordSize + | DupX1 !WordSize + | DupX2 !WordSize | Swap @@ -881,11 +928,11 @@ zero <- getWord8 when (zero /= 0) $ fail "Should be zero" return $ Invoke (InvkDynamic ref) - 0xbb -> New . (flip Reference 0) <$> get + 0xbb -> New <$> get 0xbc -> do x <- getWord8 - New . ArrayBaseType <$> case x of + NewArray . ArrayBaseType <$> case x of 4 -> return JTBoolean 5 -> return JTChar 6 -> return JTFloat @@ -896,7 +943,7 @@ 11 -> return JTLong _ -> fail $ "Unknown type '0x" ++ showHex x "'." - 0xbd -> New . (flip Reference 1) <$> get + 0xbd -> NewArray . (flip ArrayReference 1) <$> get 0xbe -> return ArrayLength @@ -930,7 +977,7 @@ _ -> fail $ "Wide does not work for opcode '0x" ++ showHex subopcode "'" - 0xc5 -> New <$> (Reference <$> get <*> get) + 0xc5 -> NewArray <$> (ArrayReference <$> get <*> get) 0xc6 -> IfRef False One <$> get 0xc7 -> IfRef True One <$> get @@ -1303,7 +1350,8 @@ InvkDynamic a -> putWord8 0xba >> put a >> putWord8 0 >> putWord8 0 - New a -> + New a -> putWord8 0xbb >> put a + NewArray a -> case a of ArrayBaseType bt -> case bt of JTBoolean -> putWord8 0xbc >> putWord8 4 @@ -1314,9 +1362,8 @@ JTShort -> putWord8 0xbc >> putWord8 9 JTInt -> putWord8 0xbc >> putWord8 10 JTLong -> putWord8 0xbc >> putWord8 11 - Reference p 0 -> putWord8 0xbb >> put p - Reference p 1 -> putWord8 0xbd >> put p - Reference p n -> putWord8 0xc5 >> put p >> put n + ArrayReference p 1 -> putWord8 0xbd >> put p + ArrayReference p n -> putWord8 0xc5 >> put p >> put n ArrayLength -> putWord8 0xbe Throw -> putWord8 0xbf @@ -1356,5 +1403,4 @@ $(deriveBase ''ByteCodeOpr) $(deriveBase ''SwitchTable) $(deriveBase ''Invocation) -$(deriveBase ''RefType) $(deriveBase ''CConstant) diff --git a/src/Language/JVM/ClassFile.hs b/src/Language/JVM/ClassFile.hs --- a/src/Language/JVM/ClassFile.hs +++ b/src/Language/JVM/ClassFile.hs @@ -129,11 +129,11 @@ evolve cf = label "ClassFile" $ do tci' <- link (cThisClass cf) sci' <- - if tci' /= ClassName "java/lang/Object" + if tci' /= "java/lang/Object" then do link (cSuperClass cf) else do - return $ ClassName "java/lang/Object" + return $ "java/lang/Object" cii' <- mapM link $ cInterfaces cf cf' <- mapM evolve $ cFields' cf cm' <- mapM evolve $ cMethods' cf @@ -162,7 +162,7 @@ devolve cf = do tci' <- unlink (cThisClass cf) sci' <- - if cThisClass cf /= ClassName "java/lang/Object" then + if cThisClass cf /= "java/lang/Object" then unlink (cSuperClass cf) else return $ 0 diff --git a/src/Language/JVM/ClassFileReader.hs b/src/Language/JVM/ClassFileReader.hs --- a/src/Language/JVM/ClassFileReader.hs +++ b/src/Language/JVM/ClassFileReader.hs @@ -175,7 +175,7 @@ attributeFilter = asks ecAttributeFilter - attributeError msg = do + evolveError msg = do lvl <- asks (showLvl . ecLabel) throwError (CFEConversionError lvl msg) diff --git a/src/Language/JVM/Constant.hs b/src/Language/JVM/Constant.hs --- a/src/Language/JVM/Constant.hs +++ b/src/Language/JVM/Constant.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -18,13 +19,13 @@ -} module Language.JVM.Constant - ( Constant (..) + ( Constant(..) , constantSize , typeToStr - - , Referenceable (..) + , Referenceable(..) - , JValue (..) + -- * JValue + , JValue(..) , VInteger , VLong , VDouble @@ -32,48 +33,45 @@ , VString -- * Special constants - , ClassName (..) - - , InClass (..) - - , AbsMethodId - , AbsFieldId - , AbsInterfaceMethodId (..) - , AbsVariableMethodId (..) - - , MethodId (..) - , FieldId (..) - , NameAndType (..) - - + , ClassName(..) + , InClass(..) + , InRefType(..) + , parseAbsMethodId + , AbsFieldId(..) + , AbsInterfaceMethodId(..) + , AbsVariableMethodId(..) + , MethodId(..) + , FieldId(..) + , NameAndType(..) , MethodDescriptor , FieldDescriptor - - - , MethodHandle (..) - , MethodHandleField (..) - , MethodHandleMethod (..) - , MethodHandleInterface (..) - , MethodHandleFieldKind (..) - , InvokeDynamic (..) + , MethodHandle(..) + , MethodHandleField(..) + , MethodHandleMethod(..) + , MethodHandleInterface(..) + , MethodHandleFieldKind(..) + , InvokeDynamic(..) -- * re-exports , High , Low - ) where + ) +where -import Control.DeepSeq (NFData) +import Control.DeepSeq ( NFData ) import Control.Monad.Reader import Data.Binary import Data.String import Data.Binary.IEEE754 -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS import Data.Int -import qualified Data.Text as Text -import qualified Data.Text.Encoding.Error as TE -import GHC.Generics (Generic) -import Numeric (showHex) -import Prelude hiding (fail, lookup) +import qualified Data.Text as Text +import qualified Data.Text.Encoding.Error as TE +import GHC.Generics ( Generic ) +import Numeric ( showHex ) +import Prelude hiding ( fail + , lookup + ) import Language.JVM.Stage import Language.JVM.TH @@ -91,9 +89,9 @@ | CDouble !Double | CClassRef !(Ref Text.Text r) | CStringRef !(Ref BS.ByteString r) - | CFieldRef !(InClass FieldId r) - | CMethodRef !(InClass MethodId r) - | CInterfaceMethodRef !(InClass MethodId r) + | CFieldRef !(Choice (Index, Index) AbsFieldId r) + | CMethodRef !(Choice (Index, Index) (InRefType MethodId) r) + | CInterfaceMethodRef !(Choice (Index, Index) (InRefType MethodId) r) | CNameAndType !(Ref Text.Text r) !(Ref Text.Text r) | CMethodHandle !(MethodHandle r) | CMethodType !(Ref MethodDescriptor r) @@ -101,53 +99,16 @@ --deriving (Show, Eq, Generic, NFData) --- | Anything pointing inside a class -data InClass a r = InClass - { inClassName :: !(Ref ClassName r) - , inClassId :: !(Ref a r) - } - -deriving instance Show a => Show (InClass a High) -deriving instance Eq a => Eq (InClass a High) -deriving instance Ord a => Ord (InClass a High) -deriving instance Generic a => Generic (InClass a High) -deriving instance (Generic a, NFData a) => NFData (InClass a High) - -deriving instance Eq (InClass a Low) -deriving instance Ord (InClass a Low) -deriving instance Show (InClass a Low) -deriving instance NFData (InClass a Low) -deriving instance Generic (InClass a Low) -deriving instance Binary (InClass a Low) - --- | A method id in a class. -type AbsMethodId = InClass MethodId - --- | A field id in a class -type AbsFieldId = InClass FieldId - -- | An method which is from an interface -newtype AbsInterfaceMethodId r = AbsInterfaceMethodId - { interfaceMethodId :: InClass MethodId r - } +newtype AbsInterfaceMethodId = AbsInterfaceMethodId + { interfaceMethodId :: InRefType MethodId + } deriving (Show, Eq, Generic, NFData) -- | An method which can be from an interface -data AbsVariableMethodId r = AbsVariableMethodId +data AbsVariableMethodId = AbsVariableMethodId { variableIsInterface :: !Bool - , variableMethodId :: !(InClass MethodId r) - } - -newtype MethodId = MethodId (NameAndType MethodDescriptor) - deriving (Eq, Show, NFData, Ord, Generic) - -newtype FieldId = FieldId (NameAndType FieldDescriptor) - deriving (Eq, Show, NFData, Ord, Generic) - -instance IsString FieldId where - fromString = FieldId . fromString - -instance IsString MethodId where - fromString = MethodId . fromString + , variableMethodId :: !(InRefType MethodId) + } deriving (Show, Eq, Generic, NFData) -- | The union type over the different method handles. data MethodHandle r @@ -155,10 +116,9 @@ | MHMethod !(MethodHandleMethod r) | MHInterface !(MethodHandleInterface r) - data MethodHandleField r = MethodHandleField { methodHandleFieldKind :: !MethodHandleFieldKind - , methodHandleFieldRef :: !(DeepRef AbsFieldId r) + , methodHandleFieldRef :: !(Ref AbsFieldId r) } data MethodHandleFieldKind @@ -169,15 +129,15 @@ deriving (Eq, Show, NFData, Generic, Ord) data MethodHandleMethod r - = MHInvokeVirtual !(DeepRef AbsMethodId r) - | MHInvokeStatic !(DeepRef AbsVariableMethodId r) + = MHInvokeVirtual !(Ref (InRefType MethodId) r) + | MHInvokeStatic !(Ref AbsVariableMethodId r) -- ^ Since version 52.0 - | MHInvokeSpecial !(DeepRef AbsVariableMethodId r) + | MHInvokeSpecial !(Ref AbsVariableMethodId r) -- ^ Since version 52.0 - | MHNewInvokeSpecial !(DeepRef AbsMethodId r) + | MHNewInvokeSpecial !(Ref (InRefType MethodId) r) -data MethodHandleInterface r = MethodHandleInterface - { methodHandleInterfaceRef :: !(DeepRef AbsInterfaceMethodId r) +newtype MethodHandleInterface r = MethodHandleInterface + { methodHandleInterfaceRef :: Ref AbsInterfaceMethodId r } data InvokeDynamic r = InvokeDynamic @@ -187,22 +147,21 @@ -- | Hack that returns the name of a constant. typeToStr :: Constant r -> String -typeToStr c = - case c of - CString _ -> "CString" - CInteger _ -> "CInteger" - CFloat _ -> "CFloat" - CLong _ -> "CLong" - CDouble _ -> "CDouble" - CClassRef _ -> "CClassRef" - CStringRef _ -> "CStringRef" - CFieldRef _ -> "CFieldRef" - CMethodRef _ -> "CMethodRef" - CInterfaceMethodRef _ -> "CInterfaceMethodRef" - CNameAndType _ _ -> "CNameAndType" - CMethodHandle _ -> "CMethodHandle" - CMethodType _ -> "CMethodType" - CInvokeDynamic _ -> "CInvokeDynamic" +typeToStr c = case c of + CString _ -> "CString" + CInteger _ -> "CInteger" + CFloat _ -> "CFloat" + CLong _ -> "CLong" + CDouble _ -> "CDouble" + CClassRef _ -> "CClassRef" + CStringRef _ -> "CStringRef" + CFieldRef _ -> "CFieldRef" + CMethodRef _ -> "CMethodRef" + CInterfaceMethodRef _ -> "CInterfaceMethodRef" + CNameAndType _ _ -> "CNameAndType" + CMethodHandle _ -> "CMethodHandle" + CMethodType _ -> "CMethodType" + CInvokeDynamic _ -> "CInvokeDynamic" instance Binary (Constant Low) where get = do @@ -224,22 +183,50 @@ 18 -> CInvokeDynamic <$> get _ -> fail $ "Unknown identifier " ++ show ident - put x = - case x of - CString bs -> do putWord8 1; put bs - CInteger i -> do putWord8 3; put i - CFloat i -> do putWord8 4; putFloat32be i - CLong i -> do putWord8 5; put i - CDouble i -> do putWord8 6; putFloat64be i - CClassRef i -> do putWord8 7; put i - CStringRef i -> do putWord8 8; put i - CFieldRef i -> do putWord8 9; put i - CMethodRef i -> do putWord8 10; put i - CInterfaceMethodRef i -> do putWord8 11; put i - CNameAndType i j -> do putWord8 12; put i; put j - CMethodHandle h -> do putWord8 15; put h - CMethodType i -> do putWord8 16; put i; - CInvokeDynamic i -> do putWord8 18; put i + put x = case x of + CString bs -> do + putWord8 1 + put bs + CInteger i -> do + putWord8 3 + put i + CFloat i -> do + putWord8 4 + putFloat32be i + CLong i -> do + putWord8 5 + put i + CDouble i -> do + putWord8 6 + putFloat64be i + CClassRef i -> do + putWord8 7 + put i + CStringRef i -> do + putWord8 8 + put i + CFieldRef i -> do + putWord8 9 + put i + CMethodRef i -> do + putWord8 10 + put i + CInterfaceMethodRef i -> do + putWord8 11 + put i + CNameAndType i j -> do + putWord8 12 + put i + put j + CMethodHandle h -> do + putWord8 15 + put h + CMethodType i -> do + putWord8 16 + put i + CInvokeDynamic i -> do + putWord8 18 + put i instance Binary (MethodHandle Low) where get = do @@ -252,7 +239,7 @@ 5 -> MHMethod . MHInvokeVirtual <$> get 6 -> MHMethod . MHInvokeStatic <$> get - 7 -> MHMethod . MHInvokeSpecial<$> get + 7 -> MHMethod . MHInvokeSpecial <$> get 8 -> MHMethod . MHNewInvokeSpecial <$> get 9 -> MHInterface . MethodHandleInterface <$> get @@ -268,15 +255,14 @@ MHPutStatic -> 4 put $ methodHandleFieldRef h - MHMethod h -> do - case h of - MHInvokeVirtual m -> putWord8 5 >> put m - MHInvokeStatic m -> putWord8 6 >> put m - MHInvokeSpecial m -> putWord8 7 >> put m - MHNewInvokeSpecial m -> putWord8 8 >> put m + MHMethod h -> case h of + MHInvokeVirtual m -> putWord8 5 >> put m + MHInvokeStatic m -> putWord8 6 >> put m + MHInvokeSpecial m -> putWord8 7 >> put m + MHNewInvokeSpecial m -> putWord8 8 >> put m MHInterface h -> do - putWord8 9 + putWord8 9 put $ methodHandleInterfaceRef h -- | Some of the 'Constant's take up more space in the constant pool than other. @@ -285,11 +271,10 @@ -- [inconsistency](http://docs.oracle.com/javase/specs/jvms/se7/html/jvms-4.html#jvms-4.4.5) -- in JVM. constantSize :: Constant r -> Index -constantSize x = - case x of - CDouble _ -> 2 - CLong _ -> 2 - _ -> 1 +constantSize x = case x of + CDouble _ -> 2 + CLong _ -> 2 + _ -> 1 -- | 'Referenceable' is something that can exist in the constant pool. class Referenceable a where @@ -307,75 +292,67 @@ fromConst _ = return toConst = return -instance TypeParse a => Referenceable (NameAndType a) where +instance TextSerializable a => Referenceable (NameAndType a) where fromConst err (CNameAndType rn txt) = do - md <- either err return $ typeFromText txt + md <- either err return $ deserialize txt return $ NameAndType rn md fromConst e c = expected "CNameAndType" e c - toConst (NameAndType rn md) = - return $ CNameAndType rn (typeToText md) + toConst (NameAndType rn md) = return $ CNameAndType rn (serialize md) -- TODO: Find good encoding of string. instance Referenceable Text.Text where - fromConst err c = - case c of - CString str -> - case sizedByteStringToText str of - Left (TE.DecodeError msg _) -> - err $ badEncoding msg (unSizedByteString str) - Left _ -> error "This is deprecated in the api" - Right txt -> return txt - a -> err $ wrongType "String" a + fromConst err c = case c of + CString str -> case sizedByteStringToText str of + Left (TE.DecodeError msg _) -> + err $ badEncoding msg (unSizedByteString str) + Left _ -> error "This is deprecated in the api" + Right txt -> return txt + a -> err $ wrongType "String" a - toConst = - return . CString . sizedByteStringFromText + toConst = return . CString . sizedByteStringFromText instance Referenceable BS.ByteString where - fromConst err c = - case c of - CString str -> return $ unSizedByteString str - a -> err $ wrongType "String" a - toConst = - return . CString . SizedByteString + fromConst err c = case c of + CString str -> return $ unSizedByteString str + a -> err $ wrongType "String" a + toConst = return . CString . SizedByteString instance Referenceable ClassName where - fromConst _ (CClassRef r) = - return . ClassName $ r - fromConst err a = - err $ wrongType "ClassRef" a + fromConst err = \case + CClassRef r -> case textCls r of + Right cn -> return cn + Left msg -> + err $ "Could not read class name: " <> Text.unpack r <> ": " <> msg + a -> err $ wrongType "ClassRef" a - toConst (ClassName txt) = do - return . CClassRef $ txt + toConst (classNameAsText -> txt) = return . CClassRef $ txt instance Referenceable JRefType where - fromConst err (CClassRef r) = - either err return $ parseOnly parseFlatJRefType r - fromConst err a = - err $ wrongType "ClassRef" a - toConst = - return . CClassRef . jRefTypeToFlatText + fromConst err = \case + CClassRef r -> case deserializeWith parseFlatJRefType r of + Right t -> return t + Left msg -> + err + $ "Could not read the flat reference type: " + <> Text.unpack r + <> ": " + <> msg + a -> err $ wrongType "ClassRef" a + toConst = return . CClassRef . serializeWith serializeFlatJRefType instance Referenceable ReturnDescriptor where - fromConst err = - fromConst err >=> either err return . typeFromText - toConst = toConst . typeToText + fromConst err = fromConst err >=> either err return . deserialize + toConst = toConst . serialize instance Referenceable MethodDescriptor where - fromConst err = - fromConst err >=> either err pure . typeFromText - toConst = toConst . typeToText + fromConst err = fromConst err >=> either err pure . deserialize + toConst = toConst . serialize instance Referenceable FieldDescriptor where - fromConst err = - fromConst err >=> either err pure . typeFromText - toConst = toConst . typeToText - --- instance TypeParse f => Referenceable (NameAndType f) where --- fromConst err = --- fromConst err >=> either err pure . fromText --- toConst = toConst . typeToText + fromConst err = fromConst err >=> either err pure . deserialize + toConst = toConst . serialize instance Referenceable MethodId where fromConst err x = MethodId <$> fromConst err x @@ -385,71 +362,58 @@ fromConst err x = FieldId <$> fromConst err x toConst (FieldId s) = toConst s -instance Referenceable (InClass FieldId High) where - fromConst _ (CFieldRef s) = do - return $ s - fromConst err c = expected "CFieldRef" err c +instance Referenceable AbsFieldId where + fromConst err = \case + CFieldRef s -> return s + c -> expected "CFieldRef" err c - toConst s = - return $ CFieldRef s + toConst s = return $ CFieldRef s -instance Referenceable (InClass MethodId High) where - fromConst _ (CMethodRef s) = do - return $ s - fromConst err c = expected "CMethodRef" err c +instance Referenceable (InRefType MethodId) where + fromConst err = \case + CMethodRef s -> return $ s + c -> expected "CMethodRef" err c - toConst s = - return $ CMethodRef s + toConst s = return $ CMethodRef s +instance Referenceable AbsVariableMethodId where + fromConst err = \case + CMethodRef s -> return $ AbsVariableMethodId False s + CInterfaceMethodRef s -> return $ AbsVariableMethodId True s + c -> expected "CMethodRef or CInterfaceMethodRef" err c -instance Referenceable (AbsVariableMethodId High) where - fromConst _ (CMethodRef s) = do - return $ AbsVariableMethodId False s - fromConst _ (CInterfaceMethodRef s) = do - return $ AbsVariableMethodId True s - fromConst err c = expected "CMethodRef or CInterfaceMethodRef" err c + toConst (AbsVariableMethodId t s) = + return $ if t then CInterfaceMethodRef s else CMethodRef s - toConst (AbsVariableMethodId t s) - | t = - return $ CInterfaceMethodRef s - | otherwise = - return $ CMethodRef s +instance Referenceable AbsInterfaceMethodId where + fromConst _ (CInterfaceMethodRef s) = return . AbsInterfaceMethodId $ s + fromConst err c = expected "CInterfaceMethodRef" err c + toConst (AbsInterfaceMethodId s) = return $ CInterfaceMethodRef s + instance Referenceable (InvokeDynamic High) where - fromConst _ (CInvokeDynamic c) = return c - fromConst err c = expected "CInvokeDynamic" err c + fromConst _ (CInvokeDynamic c) = return c + fromConst err c = expected "CInvokeDynamic" err c - toConst s = - return $ CInvokeDynamic s + toConst s = return $ CInvokeDynamic s instance Referenceable (MethodHandle High) where - fromConst _ (CMethodHandle c) = return c - fromConst err c = expected "CMethodHandle" err c + fromConst _ (CMethodHandle c) = return c + fromConst err c = expected "CMethodHandle" err c - toConst s = - return $ CMethodHandle s + toConst s = return $ CMethodHandle s -instance Referenceable (AbsInterfaceMethodId High) where - fromConst _ (CInterfaceMethodRef s) = - return . AbsInterfaceMethodId $ s - fromConst err c = expected "CInterfaceMethodRef" err c - toConst (AbsInterfaceMethodId s) = - return $ CInterfaceMethodRef s - expected :: String -> (String -> a) -> (Constant r) -> a -expected name err c = - err $ wrongType name c +expected name err c = err $ wrongType name c wrongType :: String -> Constant r -> String -wrongType n c = - "Expected '" ++ n ++ "', but found '" ++ typeToStr c ++ "'." +wrongType n c = "Expected '" ++ n ++ "', but found '" ++ typeToStr c ++ "'." badEncoding :: String -> BS.ByteString -> String -badEncoding str bs = - "Could not encode '" ++ str ++ "': " ++ show bs +badEncoding str bs = "Could not encode '" ++ str ++ "': " ++ show bs -- $(deriveBaseWithBinary ''MethodId) -- $(deriveBaseWithBinary ''FieldId) @@ -463,8 +427,8 @@ -- $(deriveBaseWithBinary ''AbsMethodId) -- $(deriveBaseWithBinary ''AbsFieldId) -$(deriveBaseWithBinary ''AbsInterfaceMethodId) -$(deriveBaseWithBinary ''AbsVariableMethodId) +-- $(deriveBaseWithBinary ''AbsInterfaceMethodId) +-- $(deriveBaseWithBinary ''AbsVariableMethodId) type VInteger = Int32 type VLong = Int64 @@ -475,25 +439,25 @@ instance Referenceable VInteger where fromConst err = \case CInteger i -> return i - x -> expected "Integer" err x + x -> expected "Integer" err x toConst = return . CInteger instance Referenceable VLong where fromConst err = \case CLong i -> return i - x -> expected "Long" err x + x -> expected "Long" err x toConst = return . CLong instance Referenceable VFloat where fromConst err = \case CFloat i -> return i - x -> expected "Float" err x + x -> expected "Float" err x toConst = return . CFloat instance Referenceable VDouble where fromConst err = \case CDouble i -> return i - x -> expected "Double" err x + x -> expected "Double" err x toConst = return . CDouble -- instance Referenceable VString where @@ -509,31 +473,34 @@ | VFloat VFloat | VDouble VDouble | VString VString - | VClass ClassName + | VClass JRefType | VMethodType MethodDescriptor | VMethodHandle (MethodHandle High) deriving (Show, Eq, Generic, NFData) instance Referenceable JValue where fromConst err = \case - CStringRef s -> return $ VString s - CInteger i -> return $ VInteger i - CFloat f -> return $ VFloat f - CLong l -> return $ VLong l - CDouble d -> return $ VDouble d - CClassRef r -> return $ VClass (ClassName r) + CStringRef s -> return $ VString s + CInteger i -> return $ VInteger i + CFloat f -> return $ VFloat f + CLong l -> return $ VLong l + CDouble d -> return $ VDouble d + CClassRef r -> case deserializeWith parseFlatJRefType r of + Right rt -> return $ VClass rt + Left msg -> + err $ "Could not parse reftype " <> Text.unpack r <> ": " <> msg CMethodHandle m -> return $ VMethodHandle m - CMethodType t -> return $ VMethodType t + CMethodType t -> return $ VMethodType t x -> expected "Value" err x {-# INLINE fromConst #-} toConst = return . \case - VString s -> CStringRef s - VInteger i -> CInteger i - VFloat f -> CFloat f - VLong l -> CLong l - VDouble d -> CDouble d - VClass (ClassName r) -> CClassRef r - VMethodHandle m -> CMethodHandle m - VMethodType t -> CMethodType t + VString s -> CStringRef s + VInteger i -> CInteger i + VFloat f -> CFloat f + VLong l -> CLong l + VDouble d -> CDouble d + VClass (serializeWith serializeFlatJRefType -> r) -> CClassRef r + VMethodHandle m -> CMethodHandle m + VMethodType t -> CMethodType t {-# INLINE toConst #-} diff --git a/src/Language/JVM/ConstantPool.hs b/src/Language/JVM/ConstantPool.hs --- a/src/Language/JVM/ConstantPool.hs +++ b/src/Language/JVM/ConstantPool.hs @@ -21,7 +21,7 @@ ( -- * Constant Pool -- $ConstantPool - ConstantPool + ConstantPool (..) , access , growPool diff --git a/src/Language/JVM/Field.hs b/src/Language/JVM/Field.hs --- a/src/Language/JVM/Field.hs +++ b/src/Language/JVM/Field.hs @@ -76,7 +76,7 @@ evolve field = label "Field" $ do fi <- link (fName field) fd <- link (fDescriptor field) - label (Text.unpack . typeToText $ NameAndType fi fd) $ do + label (Text.unpack . serialize $ fi <:> fd) $ do fattr <- fmap (`appEndo` emptyFieldAttributes) . fromAttributes FieldAttribute (fAttributes field) $ collect [ Attr (\e a -> a {faConstantValues = e : faConstantValues a }) diff --git a/src/Language/JVM/Method.hs b/src/Language/JVM/Method.hs --- a/src/Language/JVM/Method.hs +++ b/src/Language/JVM/Method.hs @@ -13,31 +13,32 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE RecordWildCards #-} module Language.JVM.Method - ( Method (..) + ( Method(..) , mAccessFlags -- * Attributes - , MethodAttributes (..) + , MethodAttributes(..) , emptyMethodAttributes , mCode , mExceptions' , mExceptions , mSignature - - ) where + ) +where -- base import Data.Monoid -- containers -import Data.Set (Set) +import Data.Set ( Set ) -- text -import qualified Data.Text as Text +import qualified Data.Text as Text import Language.JVM.AccessFlag import Language.JVM.Attribute -import Language.JVM.Attribute.Exceptions (exceptions) +import Language.JVM.Attribute.Exceptions + ( exceptions ) import Language.JVM.Constant import Language.JVM.Staged import Language.JVM.Type @@ -61,10 +62,11 @@ , maExceptions :: [Exceptions r] , maSignatures :: [Signature r] , maAnnotationDefault :: [AnnotationDefault r] + , maMethodParameters :: [MethodParameters r] , maVisibleAnnotations :: [RuntimeVisibleAnnotations r] , maInvisibleAnnotations :: [RuntimeInvisibleAnnotations r] , maVisibleParameterAnnotations :: [RuntimeVisibleParameterAnnotations r] - , maInvisibleParamterAnnotations :: [RuntimeInvisibleParameterAnnotations r] + , maInvisibleParameterAnnotations :: [RuntimeInvisibleParameterAnnotations r] , maVisibleTypeAnnotations :: [RuntimeVisibleTypeAnnotations MethodTypeAnnotation r] , maInvisibleTypeAnnotations :: @@ -73,73 +75,93 @@ } emptyMethodAttributes :: MethodAttributes High -emptyMethodAttributes = - MethodAttributes [] [] [] [] [] [] [] [] [] [] [] +emptyMethodAttributes = MethodAttributes [] [] [] [] [] [] [] [] [] [] [] [] -- | Fetch the 'Code' attribute, if any. -- There can only be one code attribute in a method. mCode :: Method High -> Maybe (Code High) -mCode = - firstOne . maCode . mAttributes +mCode = firstOne . maCode . mAttributes -- | Fetch the 'Exceptions' attribute. -- There can only be one exceptions attribute in a method. mExceptions' :: Method High -> Maybe (Exceptions High) -mExceptions' = - firstOne . maExceptions . mAttributes +mExceptions' = firstOne . maExceptions . mAttributes -- | Fetches the 'Exceptions' attribute, but turns it into an list of exceptions. -- If no exceptions field where found the empty list is returned mExceptions :: Method High -> [ClassName] -mExceptions = - maybe [] (unSizedList . exceptions) . mExceptions' +mExceptions = maybe [] (unSizedList . exceptions) . mExceptions' -- | Fetches the 'Signature' attribute, if any. mSignature :: Method High -> Maybe (Signature High) -mSignature = - firstOne . maSignatures . mAttributes +mSignature = firstOne . maSignatures . mAttributes instance Staged Method where evolve (Method mf mn md mattr) = label "Method" $ do mn' <- link mn md' <- link md - label (Text.unpack.typeToText $ NameAndType mn' md') $ do - mattr' <- fmap (`appEndo` emptyMethodAttributes) . fromAttributes MethodAttribute mattr + label (Text.unpack . serialize $ mn' <:> md') $ do + mattr' <- + fmap (`appEndo` emptyMethodAttributes) + . fromAttributes MethodAttribute mattr $ collect - [ Attr (\e a -> a { maCode = e : maCode a }) - , Attr (\e a -> a { maExceptions = e : maExceptions a }) - , Attr (\e a -> a { maSignatures = e : maSignatures a }) - , Attr (\e a -> a { maAnnotationDefault = e : maAnnotationDefault a }) - , Attr (\e a -> a { maVisibleAnnotations = e : maVisibleAnnotations a }) - , Attr (\e a -> a { maInvisibleAnnotations = e : maInvisibleAnnotations a }) - , Attr (\e a -> a { maVisibleParameterAnnotations = e : maVisibleParameterAnnotations a }) - , Attr (\e a -> a { maInvisibleParamterAnnotations = e : maInvisibleParamterAnnotations a }) - , Attr (\e a -> a { maVisibleTypeAnnotations = e : maVisibleTypeAnnotations a }) - , Attr (\e a -> a { maInvisibleTypeAnnotations = e : maInvisibleTypeAnnotations a }) - ] - (\e a -> a { maOthers = e : maOthers a }) + [ Attr (\e a -> a { maCode = e : maCode a }) + , Attr (\e a -> a { maExceptions = e : maExceptions a }) + , Attr (\e a -> a { maSignatures = e : maSignatures a }) + , Attr + (\e a -> a { maAnnotationDefault = e : maAnnotationDefault a }) + , Attr + (\e a -> a { maVisibleAnnotations = e : maVisibleAnnotations a }) + , Attr + (\e a -> + a { maInvisibleAnnotations = e : maInvisibleAnnotations a } + ) + , Attr + (\e a -> a + { maVisibleParameterAnnotations = + e : maVisibleParameterAnnotations a + } + ) + , Attr + (\e a -> a + { maInvisibleParameterAnnotations = + e : maInvisibleParameterAnnotations a + } + ) + , Attr + (\e a -> a + { maVisibleTypeAnnotations = e : maVisibleTypeAnnotations a + } + ) + , Attr + (\e a -> a + { maInvisibleTypeAnnotations = e : maInvisibleTypeAnnotations a + } + ) + , Attr (\e a -> a { maMethodParameters = e : maMethodParameters a }) + ] + (\e a -> a { maOthers = e : maOthers a }) return $ Method mf mn' md' mattr' devolve (Method mf mn md mattr) = do - mn' <- unlink mn - md' <- unlink md + mn' <- unlink mn + md' <- unlink md mattr' <- fromMethodAttributes mattr return $ Method mf mn' md' (SizedList mattr') - where - fromMethodAttributes MethodAttributes {..} = - concat <$> sequence - [ mapM toAttribute maCode - , mapM toAttribute maExceptions - , mapM toAttribute maSignatures - , mapM toAttribute maAnnotationDefault - , mapM toAttribute maVisibleAnnotations - , mapM toAttribute maInvisibleAnnotations - , mapM toAttribute maVisibleParameterAnnotations - , mapM toAttribute maInvisibleParamterAnnotations - , mapM toAttribute maVisibleTypeAnnotations - , mapM toAttribute maInvisibleTypeAnnotations - , mapM devolve maOthers - ] + where + fromMethodAttributes MethodAttributes {..} = concat <$> sequence + [ mapM toAttribute maCode + , mapM toAttribute maExceptions + , mapM toAttribute maSignatures + , mapM toAttribute maAnnotationDefault + , mapM toAttribute maVisibleAnnotations + , mapM toAttribute maInvisibleAnnotations + , mapM toAttribute maVisibleParameterAnnotations + , mapM toAttribute maInvisibleParameterAnnotations + , mapM toAttribute maVisibleTypeAnnotations + , mapM toAttribute maInvisibleTypeAnnotations + , mapM devolve maOthers + ] $(deriveBase ''MethodAttributes) $(deriveBaseWithBinary ''Method) diff --git a/src/Language/JVM/Staged.hs b/src/Language/JVM/Staged.hs --- a/src/Language/JVM/Staged.hs +++ b/src/Language/JVM/Staged.hs @@ -9,26 +9,27 @@ -} module Language.JVM.Staged - ( Staged (..) + ( Staged(..) -- * Monad Classes - , LabelM (..) - , EvolveM (..) - , DevolveM (..) + , LabelM(..) + , EvolveM(..) + , DevolveM(..) -- * AttributeLocation - , AttributeLocation (..) + , AttributeLocation(..) -- * Re-exports , module Language.JVM.Stage , module Language.JVM.TH - ) where + ) +where -import qualified Data.Text as Text +import qualified Data.Text as Text -import Language.JVM.Constant -import Language.JVM.Stage -import Language.JVM.TH +import Language.JVM.Constant +import Language.JVM.Stage +import Language.JVM.TH class Monad m => LabelM m where label :: String -> m a -> m a @@ -46,7 +47,7 @@ class LabelM m => EvolveM m where link :: Referenceable r => Index -> m r attributeFilter :: m ((AttributeLocation, Text.Text) -> Bool) - attributeError :: String -> m r + evolveError :: String -> m r class LabelM m => DevolveM m where unlink :: Referenceable r => r -> m Index @@ -66,47 +67,58 @@ {-# INLINE devolve #-} instance Staged Constant where - evolve c = - case c of - CString s -> pure $ CString s - CInteger i -> pure $ CInteger i - CFloat d -> pure $ CFloat d - CLong l -> pure $ CLong l - CDouble d -> pure $ CDouble d - CClassRef r -> label "CClassRef" $ CClassRef <$> link r - CStringRef r -> label "CStringRef" $ CStringRef <$> link r - CFieldRef r -> label "CFieldRef" $ CFieldRef <$> evolve r - CMethodRef r -> label "CMethodRef" $ CMethodRef <$> evolve r - CInterfaceMethodRef r -> label "CInterfaceMethodRef" $ CInterfaceMethodRef <$> evolve r - CNameAndType r1 r2 -> label "CNameAndType" $ CNameAndType <$> link r1 <*> link r2 - CMethodHandle mh -> label "CMethodHandle" $ CMethodHandle <$> evolve mh - CMethodType r -> label "CMethodType" $ CMethodType <$> link r - CInvokeDynamic i -> label "CInvokeDynamic" $ CInvokeDynamic <$> evolve i + evolve c = case c of + CString s -> pure $ CString s + CInteger i -> pure $ CInteger i + CFloat d -> pure $ CFloat d + CLong l -> pure $ CLong l + CDouble d -> pure $ CDouble d + CClassRef r -> label "CClassRef" $ CClassRef <$> link r + CStringRef r -> label "CStringRef" $ CStringRef <$> link r + CFieldRef (x, y) -> + label "CFieldRef" + $ CFieldRef + . AbsFieldId + <$> (InClass <$> link x <*> link y) + CMethodRef (x, y) -> + label "CMethodRef" $ CMethodRef <$> (InRefType <$> link x <*> link y) + CInterfaceMethodRef (x, y) -> + label "CInterfaceMethodRef" + $ CInterfaceMethodRef + <$> (InRefType <$> link x <*> link y) + CNameAndType r1 r2 -> + label "CNameAndType" $ CNameAndType <$> link r1 <*> link r2 + CMethodHandle mh -> label "CMethodHandle" $ CMethodHandle <$> evolve mh + CMethodType r -> label "CMethodType" $ CMethodType <$> link r + CInvokeDynamic i -> label "CInvokeDynamic" $ CInvokeDynamic <$> evolve i - devolve c = - case c of - CString s -> pure $ CString s - CInteger i -> pure $ CInteger i - CFloat d -> pure $ CFloat d - CLong l -> pure $ CLong l - CDouble d -> pure $ CDouble d - CClassRef r -> label "CClassRef" $ CClassRef <$> unlink r - CStringRef r -> label "CStringRef" $ CStringRef <$> unlink r - CFieldRef r -> label "CFieldRef" $ CFieldRef <$> devolve r - CMethodRef r -> label "CMethodRef" $ CMethodRef <$> devolve r - CInterfaceMethodRef r -> label "CInterfaceMethodRef" $ CInterfaceMethodRef <$> devolve r - CNameAndType r1 r2 -> label "CNameAndType" $ CNameAndType <$> unlink r1 <*> unlink r2 - CMethodHandle mh -> label "CMetho" $ CMethodHandle <$> devolve mh - CMethodType r -> label "CMethodType" $ CMethodType <$> unlink r - CInvokeDynamic i -> label "CInvokeDynamic" $ CInvokeDynamic <$> devolve i + devolve c = case c of + CString s -> pure $ CString s + CInteger i -> pure $ CInteger i + CFloat d -> pure $ CFloat d + CLong l -> pure $ CLong l + CDouble d -> pure $ CDouble d + CClassRef r -> label "CClassRef" $ CClassRef <$> unlink r + CStringRef r -> label "CStringRef" $ CStringRef <$> unlink r + CFieldRef (AbsFieldId (InClass rt rid)) -> + label "CFieldRef" $ CFieldRef <$> ((,) <$> unlink rt <*> unlink rid) + CMethodRef (InRefType rt rid) -> + label "CMethodRef" $ CMethodRef <$> ((,) <$> unlink rt <*> unlink rid) + CInterfaceMethodRef (InRefType rt rid) -> + label "CInterfaceMethodRef" + $ CInterfaceMethodRef + <$> ((,) <$> unlink rt <*> unlink rid) + CNameAndType r1 r2 -> + label "CNameAndType" $ CNameAndType <$> unlink r1 <*> unlink r2 + CMethodHandle mh -> label "CMetho" $ CMethodHandle <$> devolve mh + CMethodType r -> label "CMethodType" $ CMethodType <$> unlink r + CInvokeDynamic i -> label "CInvokeDynamic" $ CInvokeDynamic <$> devolve i instance Staged InvokeDynamic where - evolve (InvokeDynamic w ref) = - InvokeDynamic w <$> link ref + evolve (InvokeDynamic w ref) = InvokeDynamic w <$> link ref - devolve (InvokeDynamic w ref) = - InvokeDynamic w <$> unlink ref + devolve (InvokeDynamic w ref) = InvokeDynamic w <$> unlink ref -- instance Staged MethodId where -- evolve (MethodId n d) = @@ -115,50 +127,48 @@ -- devolve (MethodId n d) = -- MethodId <$> unlink n <*> unlink d -instance Referenceable r => Staged (InClass r) where - evolve (InClass cn cid) = - InClass <$> link cn <*> link cid - devolve (InClass cn cid) = - InClass <$> unlink cn <*> unlink cid +-- instance Referenceable r => Staged (InClass r) where +-- evolve (InClass cn cid) = +-- InClass <$> link cn <*> link cid +-- devolve (InClass cn cid) = +-- InClass <$> unlink cn <*> unlink cid +-- instance Referenceable r => Staged (InRefType r) where +-- evolve (InRefType cn cid) = +-- InRefType <$> link cn <*> link cid +-- devolve (InRefType cn cid) = +-- InRefType <$> unlink cn <*> unlink cid + instance Staged MethodHandle where - evolve m = - case m of - MHField r -> MHField <$> evolve r - MHMethod r -> MHMethod <$> evolve r - MHInterface r -> MHInterface <$> evolve r + evolve m = case m of + MHField r -> MHField <$> evolve r + MHMethod r -> MHMethod <$> evolve r + MHInterface r -> MHInterface <$> evolve r - devolve m = - case m of - MHField r -> MHField <$> devolve r - MHMethod r -> MHMethod <$> devolve r - MHInterface r -> MHInterface <$> devolve r + devolve m = case m of + MHField r -> MHField <$> devolve r + MHMethod r -> MHMethod <$> devolve r + MHInterface r -> MHInterface <$> devolve r instance Staged MethodHandleMethod where - evolve g = - case g of - MHInvokeVirtual m -> MHInvokeVirtual <$> link m - MHInvokeStatic m -> MHInvokeStatic <$> link m - MHInvokeSpecial m -> MHInvokeSpecial <$> link m - MHNewInvokeSpecial m -> MHNewInvokeSpecial <$> link m + evolve g = case g of + MHInvokeVirtual m -> MHInvokeVirtual <$> link m + MHInvokeStatic m -> MHInvokeStatic <$> link m + MHInvokeSpecial m -> MHInvokeSpecial <$> link m + MHNewInvokeSpecial m -> MHNewInvokeSpecial <$> link m - devolve g = - case g of - MHInvokeVirtual m -> MHInvokeVirtual <$> unlink m - MHInvokeStatic m -> MHInvokeStatic <$> unlink m - MHInvokeSpecial m -> MHInvokeSpecial <$> unlink m - MHNewInvokeSpecial m -> MHNewInvokeSpecial <$> unlink m + devolve g = case g of + MHInvokeVirtual m -> MHInvokeVirtual <$> unlink m + MHInvokeStatic m -> MHInvokeStatic <$> unlink m + MHInvokeSpecial m -> MHInvokeSpecial <$> unlink m + MHNewInvokeSpecial m -> MHNewInvokeSpecial <$> unlink m instance Staged MethodHandleField where - evolve (MethodHandleField k ref) = - MethodHandleField k <$> link ref + evolve (MethodHandleField k ref) = MethodHandleField k <$> link ref - devolve (MethodHandleField k ref) = - MethodHandleField k <$> unlink ref + devolve (MethodHandleField k ref) = MethodHandleField k <$> unlink ref instance Staged MethodHandleInterface where - evolve (MethodHandleInterface ref) = - MethodHandleInterface <$> link ref + evolve (MethodHandleInterface ref) = MethodHandleInterface <$> link ref - devolve (MethodHandleInterface ref) = - MethodHandleInterface <$> unlink ref + devolve (MethodHandleInterface ref) = MethodHandleInterface <$> unlink ref diff --git a/src/Language/JVM/TextSerializable.hs b/src/Language/JVM/TextSerializable.hs new file mode 100644 --- /dev/null +++ b/src/Language/JVM/TextSerializable.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StandaloneDeriving #-} +{-| +Module : Language.JVM.TextSerializable +Copyright : (c) Christian Gram Kalhauge, 2019 +License : MIT +Maintainer : kalhuage@cs.ucla.edu + +This module can parse and serialize text to structures +-} +module Language.JVM.TextSerializable where + + +-- template-haskell +import Language.Haskell.TH + +-- base +import Data.String + +-- attoparsec +import Data.Attoparsec.Text + +-- text +import qualified Data.Text as Text +import qualified Data.Text.Lazy as Lazy +import Data.Text.Lazy.Builder as Builder + +-- | A class that indicates that something can be turned from and to +-- text. +class TextSerializable a where + -- | A `TypeParse` should be parsable + parseText :: Parser a + + -- | A `TypeParse` should be printable + toBuilder :: a -> Builder + + -- | Parse a type from text + deserialize :: Text.Text -> Either String a + deserialize = deserializeWith parseText + + -- | Print a type from text + serialize :: a -> Text.Text + serialize = serializeWith toBuilder + +-- | Parse a type from text +deserializeWith :: Parser a -> Text.Text -> Either String a +deserializeWith p = parseOnly (p <* endOfInput) + +-- | Print a type from text +serializeWith :: (a -> Builder) -> a -> Text.Text +serializeWith serializer = Lazy.toStrict . Builder.toLazyText . serializer + +showViaTextSerializable :: TextSerializable a => a -> String +showViaTextSerializable = show . serialize +{-# INLINE showViaTextSerializable #-} + +fromStringViaTextSerializable :: TextSerializable a => String -> a +fromStringViaTextSerializable a = + case deserialize (Text.pack a) of + Right a' -> a' + Left msg -> error $ + "While parsing a fromString instance we got this error message: " <> msg + <> "Maybe the string " <> show a <> " is wrongly formatted." + +{-# INLINE fromStringViaTextSerializable #-} + +-- -- | Parse a type from text +-- toLazyText :: TextSerializable a => a -> Lazy.Text +-- toLazyText = Builder.toLazyText . typeToBuilder + +deriveFromTextSerializable :: Name -> Q [Dec] +deriveFromTextSerializable name = + concat <$> sequence + [ [d|instance Show ($n) where show = showViaTextSerializable |] + , [d|instance IsString ($n) where fromString = fromStringViaTextSerializable |] + ] where n = conT name diff --git a/src/Language/JVM/Type.hs b/src/Language/JVM/Type.hs --- a/src/Language/JVM/Type.hs +++ b/src/Language/JVM/Type.hs @@ -1,4 +1,8 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleInstances #-} @@ -16,106 +20,217 @@ ( -- * Base types -- ** ClassName - ClassName (..) - , strCls + ClassName(classNameAsText) + , textCls + , textClsOrFail + , strClsOrFail , dotCls + , unsafeTextCls + , parseClassName + , serializeClassName -- ** JType - , JType (..) - , JBaseType (..) + , JType(..) + , jTypeSize + , parseJType + , serializeJType + , JBaseType(..) , jBaseTypeToChar - - , JRefType (..) + , jBaseTypeSize + , parseJBaseType + , serializeJBaseType + , JRefType(..) , refTypeDepth + , parseJRefType + , serializeJRefType + , parseFlatJRefType + , serializeFlatJRefType -- ** MethodDescriptor - , MethodDescriptor (..) - , ReturnDescriptor + , MethodDescriptor(..) + , parseMethodDescriptor + , serializeMethodDescriptor + , ReturnDescriptor(..) + , parseReturnDescriptor + , serializeReturnDescriptor -- ** FieldDescriptor - , FieldDescriptor (..) + , FieldDescriptor(..) + , parseFieldDescriptor + , serializeFieldDescriptor -- ** NameAndType - , NameAndType (..) - , (<:>) + , NameAndType(..) + , parseNameAndType + , serializeNameAndType + , WithName(..) + , AsNameAndType(..) - -- * TypeParse - , TypeParse (..) - , typeFromText - , typeToText - , parseOnly + -- ** MethodId + , MethodId(..) + , parseMethodId + , serializeMethodId - , parseFlatJRefType - , jRefTypeToFlatText - ) where + -- ** FieldId + , FieldId(..) + , parseFieldId + , serializeFieldId + -- ** InClass + , InClass(..) + , parseInClass + , serializeInClass + + -- ** InRefType + , InRefType(..) + , parseInRefType + , serializeInRefType + , inRefTypeAsInClass + + -- ** AbsMethodId + , AbsMethodId(..) + , parseAbsMethodId + , serializeAbsMethodId + + -- ** AbsFieldId + , AbsFieldId(..) + , parseAbsFieldId + , serializeAbsFieldId + + -- * Re-export + , module Language.JVM.TextSerializable + ) +where + -- base import Data.String import Control.Applicative import Data.Semigroup -import GHC.Generics (Generic) -import Prelude hiding (takeWhile) +import GHC.Generics ( Generic ) +import Prelude hiding ( takeWhile ) -- deepseq -import Control.DeepSeq (NFData) +import Control.DeepSeq ( NFData ) -- attoparsec import Data.Attoparsec.Text --- mtl -import Control.Monad.Writer hiding ((<>)) - -- text -import qualified Data.Text as Text -import qualified Data.Text.Lazy as Lazy -import qualified Data.Text.Lazy.Builder as Builder +import qualified Data.Text as Text +import Data.Text.Lazy.Builder as Builder +-- jvm-binary +import Language.JVM.TextSerializable + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> let parseTestOne p = parseTest (p <* endOfInput) + -- | A class name newtype ClassName = ClassName { classNameAsText :: Text.Text } deriving (Eq, Ord, Generic, NFData) -instance Show ClassName where - show = show . classNameAsText +-- | Parses a ClassName from Text, might fail. +textCls :: Text.Text -> Either String ClassName +textCls = deserialize --- | Wrapper method that converts a string representation of a class into --- a class. -strCls :: String -> ClassName -strCls = dotCls . Text.pack +-- | Converts a text directly into a ClassName, will fail silently and +-- might corrupt data. +unsafeTextCls :: Text.Text -> ClassName +unsafeTextCls = ClassName +-- | Parses a ClassName from String, might fail with an exception. +-- *warning* Unpure. +strClsOrFail :: String -> ClassName +strClsOrFail = textClsOrFail . Text.pack + +-- | Parses a ClassName from String, might fail with an exception. +-- *warning* Unpure. +textClsOrFail :: Text.Text -> ClassName +textClsOrFail = either error id . deserialize + -- | Takes the dot representation and converts it into a class. -dotCls :: Text.Text -> ClassName -dotCls = ClassName . Text.intercalate "/" . Text.splitOn "." +dotCls :: Text.Text -> Either String ClassName +dotCls = textCls . Text.map (\c -> if c == '.' then '/' else c) --- | The Jvm Primitive Types -data JBaseType - = JTByte - | JTChar - | JTDouble - | JTFloat - | JTInt - | JTLong - | JTShort - | JTBoolean - deriving (Show, Eq, Ord, Generic, NFData) +-- | Parse a 'ClassName', should not be any of '.;[<>:', +-- +-- >>> deserialize parseClassName "java/lang/Object" +-- Right "java/lang/Object" +-- +-- >>> deserialize parseClassName "java;" +-- Left "endOfInput" +parseClassName :: Parser ClassName +parseClassName = ClassName <$> takeWhile1 (notInClass ".;[<>:") "ClassName" +-- | Display a ClassName +serializeClassName :: ClassName -> Builder +serializeClassName = Builder.fromText . classNameAsText + +instance TextSerializable ClassName where + parseText = parseClassName + toBuilder = serializeClassName + +-- | A 'JRefType' is a Class or an Array. data JRefType = JTClass !ClassName | JTArray !JType - deriving (Show, Eq, Ord, Generic, NFData) + deriving (Eq, Ord, Generic, NFData) -- | The number of nested arrays refTypeDepth :: JRefType -> Int refTypeDepth = \case JTArray (JTRef a) -> 1 + refTypeDepth a - JTArray _ -> 1 - JTClass _ -> 0 + JTArray _ -> 1 + JTClass _ -> 0 -data JType - = JTBase JBaseType - | JTRef JRefType - deriving (Show, Eq, Ord, Generic, NFData) +-- | Parses a 'JRefType' +parseJRefType :: Parser JRefType +parseJRefType = + choice + [ JTArray <$> (char '[' *> parseJType) + , JTClass <$> (char 'L' *> parseClassName <* char ';') + ] + "JRefType" +serializeJRefType :: JRefType -> Builder +serializeJRefType = \case + JTArray a -> "[" <> serializeJType a + JTClass a -> "L" <> serializeClassName a <> ";" + +instance TextSerializable JRefType where + parseText = parseJRefType + toBuilder = serializeJRefType + +-- | Parses a 'JRefType' but does not require an 'L' infront of +-- the class name, and ';' +-- >>> deserialize parseFlatJRefType "java/lang/Object" +-- Right "Ljava/lang/Object;" +-- >>> deserialize parseFlatJRefType "[I" +-- Right "[I" +parseFlatJRefType :: Parser JRefType +parseFlatJRefType = + choice [JTArray <$> (char '[' *> parseJType), JTClass <$> parseClassName] + "flat JRefType" + +serializeFlatJRefType :: JRefType -> Builder +serializeFlatJRefType = \case + JTArray a -> "[" <> serializeJType a + JTClass a -> serializeClassName a + +-- | The Jvm Primitive Types +data JBaseType + = JTByte + | JTChar + | JTDouble + | JTFloat + | JTInt + | JTLong + | JTShort + | JTBoolean + deriving (Eq, Ord, Generic, NFData) + -- | Get the corresponding `Char` of a `JBaseType` jBaseTypeToChar :: JBaseType -> Char jBaseTypeToChar = \case @@ -128,153 +243,302 @@ JTShort -> 'S' JTBoolean -> 'Z' +-- | Doubles and Longs have size two in the stack. +jBaseTypeSize :: JBaseType -> Int +jBaseTypeSize = \case + JTDouble -> 2 + JTLong -> 2 + _ -> 1 + +-- | Parse a JBaseType +parseJBaseType :: Parser JBaseType +parseJBaseType = try . ( "JBaseType") $ anyChar >>= \case + 'B' -> return JTByte + 'C' -> return JTChar + 'D' -> return JTDouble + 'F' -> return JTFloat + 'I' -> return JTInt + 'J' -> return JTLong + 'S' -> return JTShort + 'Z' -> return JTBoolean + s -> fail $ "Unknown char " ++ show s + +-- | Serializes JBaseType +serializeJBaseType :: JBaseType -> Builder +serializeJBaseType = Builder.singleton . jBaseTypeToChar + +instance TextSerializable JBaseType where + parseText = parseJBaseType + toBuilder = serializeJBaseType + + +-- | A 'JType' is either a simple type or a Reftype +data JType + = JTBase !JBaseType + | JTRef !JRefType + deriving (Eq, Ord, Generic, NFData) + +-- | Parse a JType +parseJType :: Parser JType +parseJType = + choice [JTRef <$> parseJRefType, JTBase <$> parseJBaseType] "JType" + +-- | Serialize 'JType' +serializeJType :: JType -> Builder +serializeJType = \case + JTRef r -> serializeJRefType r + JTBase r -> serializeJBaseType r + +instance TextSerializable JType where + parseText = parseJType + toBuilder = serializeJType + +-- | jTypes also have different sizes. +jTypeSize :: JType -> Int +jTypeSize = \case + JTBase a -> jBaseTypeSize a + JTRef _ -> 1 + -- | A ReturnDescriptor is maybe a type, otherwise it is void. -- https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.3.3 -type ReturnDescriptor = Maybe JType +newtype ReturnDescriptor = + ReturnDescriptor { asMaybeJType :: Maybe JType } + deriving (Ord, Eq, Generic, NFData) +-- | A ReturnDescriptor is either A JType or A 'void' V annotaiton: +-- +-- >>> deserialize parseReturnDescriptor "V" +-- Right Nothing +-- +-- >>> parseTest parseReturnDescriptor "[I" +-- Right (Just "[I") +parseReturnDescriptor :: Parser ReturnDescriptor +parseReturnDescriptor = + ReturnDescriptor + <$> choice [char 'V' >> return Nothing, Just <$> parseJType] + "return type" + +serializeReturnDescriptor :: ReturnDescriptor -> Builder +serializeReturnDescriptor = + maybe (Builder.singleton 'V') serializeJType . asMaybeJType + +instance TextSerializable ReturnDescriptor where + toBuilder = serializeReturnDescriptor + parseText = parseReturnDescriptor + -- | Method Descriptor data MethodDescriptor = MethodDescriptor - { methodDescriptorArguments :: [JType] - , methodDescriptorReturnType :: ReturnDescriptor - } deriving (Show, Ord, Eq, Generic, NFData) + { methodDescriptorArguments :: ! [JType] + , methodDescriptorReturnType :: ! ReturnDescriptor + } deriving (Ord, Eq, Generic, NFData) +-- | A 'MethodDescriptor' is just a list of types +-- +-- >>> deserialize parseMethodDescriptor "(II)V" +-- Right "(II)V" +parseMethodDescriptor :: Parser MethodDescriptor +parseMethodDescriptor = ( "MethodDescriptor") $ do + args <- char '(' *> (many' parseJType "method arguments") <* char ')' + MethodDescriptor args <$> parseReturnDescriptor + +serializeMethodDescriptor :: MethodDescriptor -> Builder +serializeMethodDescriptor (MethodDescriptor args rt) = + singleton '(' + <> foldMap serializeJType args + <> singleton ')' + <> serializeReturnDescriptor rt + +instance TextSerializable MethodDescriptor where + toBuilder = serializeMethodDescriptor + parseText = parseMethodDescriptor + -- | Field Descriptor newtype FieldDescriptor = FieldDescriptor { fieldDescriptorType :: JType - } deriving (Show, Ord, Eq, Generic, NFData) + } deriving (Ord, Eq, Generic, NFData) +-- | A 'FieldDescriptor' is just a JType +-- +-- >>> deserialize parseMethodDescriptor "I" +-- Right "I" +parseFieldDescriptor :: Parser FieldDescriptor +parseFieldDescriptor = ( "FieldDescriptor") $ do + FieldDescriptor <$> parseJType + +serializeFieldDescriptor :: FieldDescriptor -> Builder +serializeFieldDescriptor = serializeJType . fieldDescriptorType + +instance TextSerializable FieldDescriptor where + parseText = parseFieldDescriptor + toBuilder = serializeFieldDescriptor + -- | A name and a type -data NameAndType a = NameAndType - { ntName :: Text.Text - , ntDescriptor :: a - } deriving (Show, Eq, Ord, Generic, NFData) +data NameAndType a = NameAndType !Text.Text !a + deriving (Show, Eq, Ord, Generic, NFData) -(<:>) :: Text.Text -> a -> NameAndType a -(<:>) = NameAndType +class WithName n where + type WithNameId n + (<:>) :: Text.Text -> n -> WithNameId n -class TypeParse a where - -- | A `TypeParse` should be parsable - parseType :: Parser a +class AsNameAndType n where + type TypeDescriptor n - -- | A `TypeParse` should be printable - typeToBuilder :: a -> Builder.Builder + toNameAndType :: n -> NameAndType (TypeDescriptor n) --- | Parse a type from text -typeFromText :: TypeParse a => Text.Text -> Either String a -typeFromText = parseOnly (parseType <* endOfInput) + ntDescriptor :: n -> TypeDescriptor n + ntDescriptor (toNameAndType -> NameAndType _ d) = d --- | Convert a type into text -typeToText :: TypeParse a => a -> Text.Text -typeToText = Lazy.toStrict . Builder.toLazyText . typeToBuilder + ntName :: n -> Text.Text + ntName (toNameAndType -> NameAndType t _) = t -instance TypeParse ClassName where - parseType = ClassName <$> takeWhile1 (notInClass ".;[<>:") "ClassName" - typeToBuilder = Builder.fromText . classNameAsText +instance AsNameAndType (NameAndType a) where + type TypeDescriptor (NameAndType a) = a + toNameAndType = id -instance TypeParse JBaseType where - parseType = try . ( "BaseType") $ anyChar >>= \case - 'B' -> return JTByte - 'C' -> return JTChar - 'D' -> return JTDouble - 'F' -> return JTFloat - 'I' -> return JTInt - 'J' -> return JTLong - 'S' -> return JTShort - 'Z' -> return JTBoolean - s -> fail $ "Unknown char " ++ show s - typeToBuilder = Builder.singleton . jBaseTypeToChar +-- | A 'FieldDescriptor' is just a JType +-- +-- >>> deserialize (parseNameAndType parseMethodDescriptor) "method:(I)V" +-- Right "method:(I)V" +parseNameAndType :: Parser a -> Parser (NameAndType a) +parseNameAndType parser = ( "NameAndType") $ do + _name <- many1 (notChar ':') <* char ':' + NameAndType (Text.pack _name) <$> parser -instance TypeParse JRefType where - parseType = try . ( "RefType") $ - anyChar >>= \case - 'L' -> do - txt <- takeWhile (/= ';') - _ <- char ';' - return $ JTClass (ClassName txt) - '[' -> JTArray <$> parseType - s -> fail $ "Unknown char " ++ show s +serializeNameAndType :: (a -> Builder) -> NameAndType a -> Builder +serializeNameAndType serializer (NameAndType _name descr) = + fromText _name <> ":" <> serializer descr - typeToBuilder = \case - JTClass cn -> - Builder.singleton 'L' <> typeToBuilder cn <> Builder.singleton ';' - JTArray t -> - Builder.singleton '[' <> typeToBuilder t +-- | A FieldId +newtype FieldId = + FieldId { fieldIdAsNameAndType :: NameAndType FieldDescriptor } + deriving (Ord, Eq, Generic, NFData) -parseFlatJRefType :: Parser JRefType -parseFlatJRefType = - JTArray <$> (char '[' *> parseType) - <|> JTClass <$> parseType +parseFieldId :: Parser FieldId +parseFieldId = FieldId <$> parseNameAndType parseFieldDescriptor -jRefTypeToFlatText :: JRefType -> Text.Text -jRefTypeToFlatText = \case - JTClass t' -> classNameAsText t' - JTArray t' -> Lazy.toStrict . Builder.toLazyText - $ Builder.singleton '[' <> typeToBuilder t' +serializeFieldId :: FieldId -> Builder +serializeFieldId = + serializeNameAndType serializeFieldDescriptor . fieldIdAsNameAndType -instance TypeParse JType where - parseType = - (JTRef <$> parseType <|> JTBase <$> parseType) - "JType" +instance TextSerializable FieldId where + parseText = parseFieldId + toBuilder = serializeFieldId - typeToBuilder = \case - JTRef r -> typeToBuilder r - JTBase r -> typeToBuilder r +instance WithName FieldDescriptor where + type WithNameId FieldDescriptor = FieldId + t <:> mt = FieldId (NameAndType t mt) -instance TypeParse ReturnDescriptor where - typeToBuilder = maybe (Builder.singleton 'V') typeToBuilder - parseType = choice - [ char 'V' >> return Nothing - , Just <$> parseType - ] "return type" +instance AsNameAndType FieldId where + type TypeDescriptor FieldId = FieldDescriptor + toNameAndType = fieldIdAsNameAndType -instance TypeParse MethodDescriptor where - typeToBuilder md = - execWriter $ do - tell $ Builder.singleton '(' - mapM_ (tell . typeToBuilder) (methodDescriptorArguments md) - tell $ Builder.singleton ')' - tell . typeToBuilder $ methodDescriptorReturnType md - parseType = do - _ <- char '(' - args <- many' parseType "method arguments" - _ <- char ')' - MethodDescriptor args <$> parseType +-- | A MethodId +newtype MethodId = + MethodId { methodIdAsNameAndType :: NameAndType MethodDescriptor } + deriving (Ord, Eq, Generic, NFData) -instance TypeParse FieldDescriptor where - parseType = FieldDescriptor <$> parseType - typeToBuilder (FieldDescriptor t) = typeToBuilder t +parseMethodId :: Parser MethodId +parseMethodId = MethodId <$> parseNameAndType parseMethodDescriptor -instance TypeParse t => TypeParse (NameAndType t) where - parseType = do - name <- many1 $ notChar ':' - _ <- char ':' - NameAndType (Text.pack name) <$> parseType +serializeMethodId :: MethodId -> Builder +serializeMethodId = + serializeNameAndType serializeMethodDescriptor . methodIdAsNameAndType - typeToBuilder (NameAndType name _type) = - Builder.fromText name - <> Builder.singleton ':' - <> typeToBuilder _type +instance TextSerializable MethodId where + parseText = parseMethodId + toBuilder = serializeMethodId -fromString' :: - TypeParse t - => String - -> t -fromString' = - either (error . ("Failed " ++)) id . typeFromText . Text.pack +instance WithName MethodDescriptor where + type WithNameId MethodDescriptor = MethodId + t <:> mt = MethodId (NameAndType t mt) -instance IsString ClassName where - fromString = strCls +instance AsNameAndType MethodId where + type TypeDescriptor MethodId = MethodDescriptor + toNameAndType = methodIdAsNameAndType -instance IsString JType where - fromString = fromString' +-- | A method or Field in a Class +data InClass a = InClass + { inClassName :: !ClassName + , inClassId :: !a + } deriving (Eq, Ord, Generic, NFData) -instance IsString FieldDescriptor where - fromString = fromString' +parseInClass :: Parser a -> Parser (InClass a) +parseInClass parseClassId = + InClass <$> parseClassName <*> (char '.' *> parseClassId) -instance IsString MethodDescriptor where - fromString = fromString' +serializeInClass :: (a -> Builder) -> InClass a -> Builder +serializeInClass serializeClassId (InClass n cid) = + serializeClassName n <> singleton '.' <> serializeClassId cid -instance TypeParse t => IsString (NameAndType t) where - fromString = fromString' +-- | A method or Field in a Class +data InRefType a = InRefType + { inRefType :: !JRefType + , inRefTypeId :: !a + } deriving (Eq, Ord, Generic, NFData) + +parseInRefType :: Parser a -> Parser (InRefType a) +parseInRefType parseRefTypeId = + InRefType <$> parseJRefType <*> (char '.' *> parseRefTypeId) + +serializeInRefType :: (a -> Builder) -> InRefType a -> Builder +serializeInRefType serializeRefTypeId (InRefType n cid) = + serializeJRefType n <> singleton '.' <> serializeRefTypeId cid + +-- | Convert a InRefType to a InClass by casting +-- all arrays to classes. +inRefTypeAsInClass :: InRefType a -> InClass a +inRefTypeAsInClass (InRefType rt rtid) = InClass + (case rt of + JTArray _ -> "java/lang/Object" + JTClass a -> a + ) + rtid + +-- | A FieldId +newtype AbsFieldId = + AbsFieldId { absFieldAsInClass :: InClass FieldId } + deriving (Ord, Eq, Generic, NFData) + +parseAbsFieldId :: Parser AbsFieldId +parseAbsFieldId = AbsFieldId <$> parseInClass parseFieldId + +serializeAbsFieldId :: AbsFieldId -> Builder +serializeAbsFieldId = serializeInClass serializeFieldId . absFieldAsInClass + +instance TextSerializable AbsFieldId where + parseText = parseAbsFieldId + toBuilder = serializeAbsFieldId + +-- | A MethodId +newtype AbsMethodId = + AbsMethodId { absMethodAsInClass :: InClass MethodId } + deriving (Ord, Eq, Generic, NFData) + +parseAbsMethodId :: Parser AbsMethodId +parseAbsMethodId = AbsMethodId <$> parseInClass parseMethodId + +serializeAbsMethodId :: AbsMethodId -> Builder +serializeAbsMethodId = serializeInClass serializeMethodId . absMethodAsInClass + +instance TextSerializable AbsMethodId where + parseText = parseAbsMethodId + toBuilder = serializeAbsMethodId + +deriveFromTextSerializable ''ClassName +deriveFromTextSerializable ''JType +deriveFromTextSerializable ''JRefType +deriveFromTextSerializable ''JBaseType +deriveFromTextSerializable ''FieldDescriptor +deriveFromTextSerializable ''MethodDescriptor +deriveFromTextSerializable ''ReturnDescriptor + +deriveFromTextSerializable ''MethodId +deriveFromTextSerializable ''FieldId + +deriveFromTextSerializable ''AbsMethodId +deriveFromTextSerializable ''AbsFieldId + +deriving instance Show a => Show (InClass a) +deriving instance Show a => Show (InRefType a) diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 --- a/stack.yaml +++ /dev/null @@ -1,5 +0,0 @@ -resolver: lts-13.19 -packages: -- . -flags: {} -extra-deps: [] diff --git a/test/Language/JVM/Attribute/AnnotationsSpec.hs b/test/Language/JVM/Attribute/AnnotationsSpec.hs --- a/test/Language/JVM/Attribute/AnnotationsSpec.hs +++ b/test/Language/JVM/Attribute/AnnotationsSpec.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} -- | module Language.JVM.Attribute.AnnotationsSpec where diff --git a/test/Language/JVM/Attribute/BootstrapMethodsSpec.hs b/test/Language/JVM/Attribute/BootstrapMethodsSpec.hs --- a/test/Language/JVM/Attribute/BootstrapMethodsSpec.hs +++ b/test/Language/JVM/Attribute/BootstrapMethodsSpec.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} module Language.JVM.Attribute.BootstrapMethodsSpec where diff --git a/test/Language/JVM/Attribute/CodeSpec.hs b/test/Language/JVM/Attribute/CodeSpec.hs --- a/test/Language/JVM/Attribute/CodeSpec.hs +++ b/test/Language/JVM/Attribute/CodeSpec.hs @@ -151,6 +151,9 @@ instance Arbitrary OneOrTwo where arbitrary = genericArbitraryU +instance Arbitrary NewArrayType where + arbitrary = genericArbitraryU `suchThat` (\(NewArrayType i _) -> i > 0) + instance Arbitrary SmallArithmeticType where arbitrary = genericArbitraryU @@ -174,4 +177,3 @@ instance Arbitrary (SwitchTable High) where arbitrary = genericArbitraryU - diff --git a/test/Language/JVM/Attribute/ConstantValueSpec.hs b/test/Language/JVM/Attribute/ConstantValueSpec.hs --- a/test/Language/JVM/Attribute/ConstantValueSpec.hs +++ b/test/Language/JVM/Attribute/ConstantValueSpec.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} @@ -13,7 +14,7 @@ spec :: Spec spec = do it "can do a roundtrip on a VClass" $ - prop_roundtrip_ConstantValue (ConstantValue (VClass "this/class")) + prop_roundtrip_ConstantValue (ConstantValue (VClass "Lthis/class;")) it "can do a roundtrip" $ property $ prop_roundtrip_ConstantValue prop_roundtrip_ConstantValue :: ConstantValue High -> Property diff --git a/test/Language/JVM/Attribute/EnclosingMethodSpec.hs b/test/Language/JVM/Attribute/EnclosingMethodSpec.hs --- a/test/Language/JVM/Attribute/EnclosingMethodSpec.hs +++ b/test/Language/JVM/Attribute/EnclosingMethodSpec.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} @@ -14,8 +15,8 @@ prop_roundtrip_EnclosingMethodSpec = isoRoundtrip spec :: Spec -spec = - -- spec_enclosing +spec = return () +-- spec_enclosing -- spec_enclosing :: SpecWith () -- spec_enclosing = do diff --git a/test/Language/JVM/Attribute/ExceptionsSpec.hs b/test/Language/JVM/Attribute/ExceptionsSpec.hs --- a/test/Language/JVM/Attribute/ExceptionsSpec.hs +++ b/test/Language/JVM/Attribute/ExceptionsSpec.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} module Language.JVM.Attribute.ExceptionsSpec where diff --git a/test/Language/JVM/Attribute/InnerClassesSpec.hs b/test/Language/JVM/Attribute/InnerClassesSpec.hs --- a/test/Language/JVM/Attribute/InnerClassesSpec.hs +++ b/test/Language/JVM/Attribute/InnerClassesSpec.hs @@ -1,10 +1,11 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} module Language.JVM.Attribute.InnerClassesSpec where import SpecHelper -import qualified Data.Set as S +-- import qualified Data.Set as S import Language.JVM.ConstantSpec () diff --git a/test/Language/JVM/Attribute/SignatureSpec.hs b/test/Language/JVM/Attribute/SignatureSpec.hs --- a/test/Language/JVM/Attribute/SignatureSpec.hs +++ b/test/Language/JVM/Attribute/SignatureSpec.hs @@ -1,22 +1,28 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Language.JVM.Attribute.SignatureSpec where import SpecHelper -import Language.JVM.ConstantSpec () +import Language.JVM.ConstantSpec ( ) import Language.JVM.Attribute.Signature import Language.JVM -import qualified Data.Text as Text -import Data.Attoparsec.Text +import qualified Data.Text as Text +import Data.Attoparsec.Text spec :: Spec spec = do it "can do a roundtrip" $ property $ prop_roundtrip_SignatureSpec + prop "can do handle field" $ prop_field_signature + prop "can do handle class" $ prop_class_signature + prop "can do handle method" $ prop_method_signature + spec_real_signatures prop_roundtrip_SignatureSpec :: Signature High -> Property @@ -24,122 +30,167 @@ prop_field_signature :: FieldSignature -> Property prop_field_signature sig = - let txt = fieldSignatureToText sig in - counterexample (Text.unpack txt) $ - fieldSignatureFromText txt === Right sig + let txt = fieldSignatureToText sig + in counterexample (Text.unpack txt) + $ fieldSignatureFromText txt + === Right sig prop_method_signature :: MethodSignature -> Property prop_method_signature sig = - let txt = methodSignatureToText sig in - counterexample (Text.unpack txt) $ - methodSignatureFromText txt === Right sig + let txt = methodSignatureToText sig + in counterexample (Text.unpack txt) + $ methodSignatureFromText txt + === Right sig prop_class_signature :: ClassSignature -> Property prop_class_signature sig = - let txt = classSignatureToText sig in - counterexample (Text.unpack txt) $ - classSignatureFromText txt === Right sig + let txt = classSignatureToText sig + in counterexample (Text.unpack txt) + $ classSignatureFromText txt + === Right sig spec_real_signatures :: SpecWith () spec_real_signatures = do it "can handle this class type Ljava/lang/Object;" $ do - let sig = "Ljava/lang/Object;" - parseOnly referenceTypeP sig `shouldBe` - Right (RefClassType (ClassType "java/lang/Object" [])) + let sig = "Ljava/lang/Object;" + parseOnly referenceTypeP sig `shouldBe` Right + (RefClassType (ClassType "java/lang/Object" Nothing [])) + it "can handle this class type Lqueues/Deque.Node;" $ do + let sig = "Lqueues/Deque.Node;" + parseOnly classTypeP sig `shouldBe` Right + (ClassType + "queues/Deque" + (Just (InnerClassType "Node" Nothing [])) + [Just (TypeArgument Nothing (RefTypeVariable (TypeVariable "Item")))] + ) + it "can handle this type parameter E:Ljava/lang/Object;" $ do - let sig = "E:Ljava/lang/Object;" - parseOnly typeParameterP sig `shouldBe` - Right (TypeParameter { - tpIndentifier = "E", - tpClassBound = Just (RefClassType (ClassType "java/lang/Object" [])), - tpInterfaceBound = [] - }) + let sig = "E:Ljava/lang/Object;" + parseOnly typeParameterP sig `shouldBe` Right + (TypeParameter + { tpIdentifier = "E" + , tpClassBound = + Just (RefClassType (ClassType "java/lang/Object" Nothing [])) + , tpInterfaceBound = [] + } + ) it "can handle this type parameter " $ do - let sig = "" - parseOnly typeParametersP sig `shouldBe` - Right [ - TypeParameter { - tpIndentifier = "E", - tpClassBound = Just (RefClassType (ClassType { - ctsClassName = "java/lang/Object", - ctsTypeArguments = [] - })), - tpInterfaceBound = [] - } - ] + let sig = "" + parseOnly typeParametersP sig `shouldBe` Right + [ TypeParameter + { tpIdentifier = "E" + , tpClassBound = Just + (RefClassType + (ClassType { ctsName = "java/lang/Object" + , ctsInnerClass = Nothing + , ctsTypeArguments = [] + } + ) + ) + , tpInterfaceBound = [] + } + ] it "can handle the class signature of Iterator" $ do - let sig = "Ljava/lang/Object;" - parseOnly classSignatureP sig `shouldBe` - Right (ClassSignature { - csTypeParameters = [ - TypeParameter { - tpIndentifier = "E", - tpClassBound = Just (RefClassType (ClassType { - ctsClassName = "java/lang/Object", - ctsTypeArguments = [] - })), - tpInterfaceBound = [] - } - ], - csSuperclassSignature = ClassType { - ctsClassName = "java/lang/Object", - ctsTypeArguments = [] - }, - csInterfaceSignatures = [] - }) + let sig = "Ljava/lang/Object;" + parseOnly classSignatureP sig `shouldBe` Right + (ClassSignature + { csTypeParameters = [ TypeParameter + { tpIdentifier = "E" + , tpClassBound = Just + (RefClassType + (ClassType + { ctsName = + "java/lang/Object" + , ctsInnerClass = + Nothing + , ctsTypeArguments = [] + } + ) + ) + , tpInterfaceBound = [] + } + ] + , csSuperclassSignature = ClassType { ctsName = "java/lang/Object" + , ctsInnerClass = Nothing + , ctsTypeArguments = [] + } + , csInterfaceSignatures = [] + } + ) it "can handle the method signature of Iterator" $ do let sig = "(Ljava/util/function/Consumer<-TE;>;)V" - parseOnly methodSignatureP sig `shouldBe` - Right (MethodSignature { - msTypeParameters = [], - msArguments = [ - ReferenceType (RefClassType (ClassType { - ctsClassName = "java/util/function/Consumer", - ctsTypeArguments = [ - Just (TypeArgument { - taWildcard = Just WildMinus, - taType = RefTypeVariable (TypeVariable { - tvAsText = "E" - }) - }) - ] - })) - ], - msResults = Nothing, - msThrows = [] - }) + parseOnly methodSignatureP sig `shouldBe` Right + (MethodSignature + { msTypeParameters = [] + , msArguments = + [ ReferenceType + (RefClassType + (ClassType + { ctsName = "java/util/function/Consumer" + , ctsInnerClass = Nothing + , ctsTypeArguments = + [ Just + (TypeArgument + { taWildcard = Just WildMinus + , taType = RefTypeVariable + (TypeVariable { tvAsText = "E" }) + } + ) + ] + } + ) + ) + ] + , msResults = Nothing + , msThrows = [] + } + ) it "can handle the simple method signature" $ do - parseOnly methodSignatureP "()V" `shouldBe` Right - ( MethodSignature [] [] Nothing []) + parseOnly methodSignatureP "()V" + `shouldBe` Right (MethodSignature [] [] Nothing []) it "can handle throws method signature" $ do parseOnly (methodSignatureP <* endOfInput) "()V^TE;" `shouldBe` Right - ( MethodSignature [] [] Nothing [ThrowsTypeVariable (TypeVariable "E")]) + (MethodSignature [] [] Nothing [ThrowsTypeVariable (TypeVariable "E")]) it "can handle throws method signature with class" $ do parseOnly (methodSignatureP) "()V^Ljava/lang/Exception;" `shouldBe` Right - ( MethodSignature [] [] Nothing [ - ThrowsClass ( - ClassType { - ctsClassName = "java/lang/Exception" - , ctsTypeArguments = [] - } - ) - ]) + (MethodSignature + [] + [] + Nothing + [ ThrowsClass + (ClassType { ctsName = "java/lang/Exception" + , ctsInnerClass = Nothing + , ctsTypeArguments = [] + } + ) + ] + ) it "can parse a type variable" $ do parseOnly typeVariableP "TE;" `shouldBe` Right (TypeVariable "E") it "can handle the simple field signature" $ do - parseOnly fieldSignatureP "Ljava/util/function/Consumer<-TE;>;" `shouldBe` Right - ( FieldSignature - (RefClassType - (ClassType "java/util/function/Consumer" - [Just (TypeArgument (Just WildMinus) . RefTypeVariable $ TypeVariable "E") ] - ))) + parseOnly fieldSignatureP "Ljava/util/function/Consumer<-TE;>;" + `shouldBe` Right + (FieldSignature + (RefClassType + (ClassType + "java/util/function/Consumer" + Nothing + [ Just + ( TypeArgument (Just WildMinus) + . RefTypeVariable + $ TypeVariable "E" + ) + ] + ) + ) + ) instance Arbitrary (Signature High) where @@ -149,38 +200,56 @@ arbitrary = genericArbitraryU instance Arbitrary (ReferenceType) where - arbitrary = do + arbitrary = scale (`div` 2) $ do n <- getSize if n == 0 then pure (RefTypeVariable $ TypeVariable "X") else scale (\s -> s `div` 2) $ genericArbitraryU instance Arbitrary (ClassType) where - arbitrary = do + arbitrary = scale (`div` 2) $ do s <- getSize n <- choose (0, s) x <- vectorOf n (resize (s `div` n) arbitrary) - oneof - [ ClassType <$> arbitrary <*> pure x - , InnerClassType <$> elements ["a", "subclass"] <*> resize (n `div` 2) arbitrary <*> pure x - ] + ClassType <$> arbitrary <*> genInnerClassType <*> pure x + where + genInnerClassType = sized + (\case + 0 -> pure $ Nothing + _ -> do + s <- getSize + n <- choose (0, s) + x <- vectorOf n (resize (s `div` n) arbitrary) + fmap Just + . scale (`div` 2) + $ InnerClassType + <$> elements ["a", "subclass"] + <*> genInnerClassType + <*> pure x + ) + instance Arbitrary (TypeVariable) where - arbitrary = TypeVariable <$> elements ["A","B", "C", "HJ"] + arbitrary = TypeVariable <$> elements ["A", "B", "C", "HJ"] instance Arbitrary (TypeSignature) where arbitrary = do n <- getSize if n == 0 - then BaseType <$> arbitrary - else resize (n `div` 2) $ ReferenceType <$> arbitrary + then BaseType <$> arbitrary + else resize (n `div` 2) $ ReferenceType <$> arbitrary instance Arbitrary (TypeArgument) where arbitrary = genericArbitraryU instance Arbitrary (TypeParameter) where - arbitrary = TypeParameter <$> elements ["A","B", "C", "HJ"] <*> arbitrary <*> arbitrary + arbitrary = + scale (`div` 2) + $ TypeParameter + <$> elements ["A", "B", "C", "HJ"] + <*> arbitrary + <*> arbitrary instance Arbitrary (Wildcard) where arbitrary = genericArbitraryU diff --git a/test/Language/JVM/ByteCodeSpec.hs b/test/Language/JVM/ByteCodeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/JVM/ByteCodeSpec.hs @@ -0,0 +1,56 @@ +{-# Language OverloadedStrings #-} +module Language.JVM.ByteCodeSpec where + +import SpecHelper +import Data.Either + +-- containers +import qualified Data.IntMap as IntMap + +import Language.JVM.ClassFileReader +import Language.JVM.ConstantPool +import Language.JVM.Constant +import Language.JVM.ByteCode + +spec :: Spec +spec = do + describe "new RefType" $ do + it "should evolve 1, [J -> [[J" $ do + let cp = ConstantPool (IntMap.singleton 0 (CClassRef "[J")) + let x = runEvolve (EvolveConfig [] cp (const True)) + (evolveBC undefined + (ByteCodeInst 0 (NewArray (ArrayReference 0 1))) + ) + x `shouldBe` Right (ByteCodeInst 0 (NewArray (NewArrayType 1 "[J"))) + + it "should evolve 2, [[J -> [[J" $ do + let cp = ConstantPool (IntMap.singleton 0 (CClassRef "[[J")) + let x = runEvolve (EvolveConfig [] cp (const True)) + (evolveBC undefined + (ByteCodeInst 0 (NewArray (ArrayReference 0 2))) + ) + x `shouldBe` Right (ByteCodeInst 0 (NewArray (NewArrayType 2 "J"))) + + -- it "should evolve New" $ do + -- let cp = ConstantPool (IntMap.singleton 0 (CClassRef "J")) + -- let x = runEvolve (EvolveConfig [] cp (const True)) + -- (evolveBC undefined (ByteCodeInst 0 (NewArray (ArrayReference 0 1)))) + -- x `shouldBe` Right (ByteCodeInst 0 (NewArray (NewArrayType 1 "[J")) + + -- it "should evolve New" $ do + -- let cp = ConstantPool (IntMap.singleton 0 (CClassRef "java/lang/Object")) + -- let x = runEvolve (EvolveConfig [] cp (const True)) + -- (evolveBC undefined (ByteCodeInst 0 (New (Reference 0 1)))) + -- x `shouldBe` Right (ByteCodeInst 0 (New "[Ljava/lang/Object;")) + + it "should roundtrip NewArray" $ do + let x = byteCodeRoundtrip (ByteCodeInst 0 (NewArray (NewArrayType 1 "J"))) + x `shouldSatisfy` isRight + + it "should roundtrip NewArray" $ do + let x = byteCodeRoundtrip (ByteCodeInst 0 (NewArray (NewArrayType 2 "J"))) + x `shouldSatisfy` isRight + + + +-- runEvolve :: EvolveConfig -> Evolve a -> Either ClassFileError a diff --git a/test/Language/JVM/ConstantSpec.hs b/test/Language/JVM/ConstantSpec.hs --- a/test/Language/JVM/ConstantSpec.hs +++ b/test/Language/JVM/ConstantSpec.hs @@ -14,6 +14,23 @@ spec :: Spec spec = do + it "can print things correctly" $ do + show ("java/lang/Object.hello:()V" :: AbsMethodId) + `shouldBe` (show ("java/lang/Object.hello:()V" :: String)) + + it "can print things correctly" $ do + show ("java/lang/Object.hello:I" :: AbsFieldId) + `shouldBe` (show ("java/lang/Object.hello:I" :: String)) + + it "can print things correctly" $ do + show ("hello:()V" :: MethodId) + `shouldBe` (show ("hello:()V" :: String)) + + it "can print things correctly" $ do + show ("hello:I" :: FieldId) + `shouldBe` (show ("hello:I" :: String)) + + it "can build a class pool" $ do let (a', cpb) = runConstantPoolBuilder (devolve (CClassRef "class/Name")) cpbEmpty @@ -26,11 +43,12 @@ it "can build a complex class pool" $ do let - a = CMethodRef (InClass "class/Name" "method:()V") + a = CMethodRef (InRefType "Lclass/Name;" "method:()V") (a', cpb) = runConstantPoolBuilder (devolve a) cpbEmpty cp = constantPoolFromBuilder cpb - cp `shouldBe` fromConstants [CString "class/Name", CClassRef 1, CString "method", CString "()V", CNameAndType 3 4] - a' `shouldBe` (CMethodRef (InClass 2 5)) + cp `shouldBe` fromConstants [ + CString "class/Name", CClassRef 1, CString "method", CString "()V", CNameAndType 3 4] + a' `shouldBe` (CMethodRef (2, 5)) let cp' = bootstrapConstantPool cp cp' `shouldBe` Right @@ -79,10 +97,10 @@ arbitrary = fromConstants <$> (arbitrary :: Gen [Constant High]) -instance Arbitrary (AbsInterfaceMethodId High) where +instance Arbitrary AbsInterfaceMethodId where arbitrary = genericArbitraryU -instance Arbitrary (AbsVariableMethodId High) where +instance Arbitrary AbsVariableMethodId where arbitrary = genericArbitraryU instance Arbitrary (Constant High) where @@ -111,15 +129,6 @@ , CMethodType <$> arbitrary , CInvokeDynamic <$> arbitrary ] - -instance (Arbitrary a) => Arbitrary (InClass a High) where - arbitrary = InClass <$> arbitrary <*> arbitrary - -instance Arbitrary (FieldId) where - arbitrary = FieldId <$> arbitrary - -instance Arbitrary (MethodId) where - arbitrary = MethodId <$> arbitrary instance Arbitrary (MethodHandle High) where arbitrary = diff --git a/test/Language/JVM/TypeSpec.hs b/test/Language/JVM/TypeSpec.hs --- a/test/Language/JVM/TypeSpec.hs +++ b/test/Language/JVM/TypeSpec.hs @@ -1,37 +1,48 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Language.JVM.TypeSpec where import SpecHelper -import Data.Attoparsec.Text import Data.Either import Language.JVM.Type --- import Text.Megaparsec --- import Spec.Hspec.Megaparsec - spec :: Spec spec = do describe "JType parsing" $ do it "can parse \"[B\" as an array" $ - parseOnly parseType "[B" `shouldBe` Right (JTRef (JTArray (JTBase JTByte))) + deserialize "[B" `shouldBe` Right (JTRef (JTArray (JTBase JTByte))) it "can parse an array of strings" $ - parseOnly parseType "[Ljava/lang/String;" `shouldBe` - Right (JTRef (JTArray (JTRef (JTClass (ClassName "java/lang/String"))))) + deserialize "[Ljava/lang/String;" `shouldBe` + Right (JTRef (JTArray (JTRef (JTClass "java/lang/String")))) describe "MethodDescriptor parsing" $ do it "can parse the empty method" $ - parseOnly parseType "()V" `shouldBe` - Right (MethodDescriptor [] Nothing) + deserialize "()V" `shouldBe` + Right (MethodDescriptor [] "V") it "can parse method arguments" $ - parseOnly parseType "(BZ)B" `shouldBe` - Right (MethodDescriptor [JTBase JTByte, JTBase JTBoolean] (Just (JTBase JTByte))) + deserialize "(BZ)B" `shouldBe` + Right (MethodDescriptor [JTBase JTByte, JTBase JTBoolean] "B") it "does not parse if there is too much" $ - (typeFromText "(BZ)Bx" :: Either String MethodDescriptor) `shouldSatisfy` isLeft + (deserialize "(BZ)Bx" :: Either String MethodDescriptor) `shouldSatisfy` isLeft + describe "serializes" $ do + it "JType" . property $ \(t :: JType) -> + deserialize (serialize t) === Right t + it "MethodDescriptor" . property $ \(t :: MethodDescriptor) -> + deserialize (serialize t) === Right t + it "FieldDescriptor" . property $ \(t :: FieldDescriptor) -> + deserialize (serialize t) === Right t + it "Flat JRefType" . property $ \(t :: JRefType) -> + deserializeWith parseFlatJRefType (serializeWith serializeFlatJRefType t) === Right t + it "AbsMethodId" . property $ \(t :: AbsMethodId) -> + deserialize (serialize t) === Right t + it "AbsFieldId" . property $ \(t :: AbsFieldId) -> + deserialize (serialize t) === Right t + instance Arbitrary ClassName where - arbitrary = pure $ ClassName "package/Main" + arbitrary = pure $ "package/Main" instance Arbitrary JType where arbitrary = genericArbitrary uniform @@ -42,11 +53,33 @@ instance Arbitrary JRefType where arbitrary = genericArbitrary uniform +instance Arbitrary ReturnDescriptor where + arbitrary = genericArbitrary uniform + instance Arbitrary MethodDescriptor where arbitrary = genericArbitrary uniform instance Arbitrary FieldDescriptor where arbitrary = genericArbitrary uniform + +instance Arbitrary FieldId where + arbitrary = FieldId <$> arbitrary + +instance Arbitrary MethodId where + arbitrary = MethodId <$> arbitrary + +instance Arbitrary a => Arbitrary (InClass a) where + arbitrary = InClass <$> arbitrary <*> arbitrary + +instance Arbitrary a => Arbitrary (InRefType a) where + arbitrary = InRefType <$> arbitrary <*> arbitrary + +instance Arbitrary AbsFieldId where + arbitrary = AbsFieldId <$> arbitrary + +instance Arbitrary AbsMethodId where + arbitrary = AbsMethodId <$> arbitrary + instance Arbitrary t => Arbitrary (NameAndType t) where arbitrary = diff --git a/test/Language/JVMSpec.hs b/test/Language/JVMSpec.hs --- a/test/Language/JVMSpec.hs +++ b/test/Language/JVMSpec.hs @@ -68,10 +68,10 @@ Left msg -> fail $ show msg - let classes = + let _classes = filter (\entry -> takeExtension (eRelativePath entry) == ".class") (zEntries archive) - forM_ classes $ \entry -> do + forM_ _classes $ \entry -> do it ("can read " ++ eRelativePath entry) $ do case readClassFile (fromEntry entry) of Right _ -> @@ -79,7 +79,7 @@ Left msg -> fail $ show msg - forM_ classes $ \entry -> do + forM_ _classes $ \entry -> do it ("can read " ++ eRelativePath entry) $ do case readClassFile (fromEntry entry) of Right _ -> diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -19,6 +19,8 @@ , it , xit , describe + , xdescribe + , fdescribe ) where import Test.Hspec.Expectations.Pretty diff --git a/test/data/Localizable.class b/test/data/Localizable.class new file mode 100644 Binary files /dev/null and b/test/data/Localizable.class differ diff --git a/test/data/project/Main.class b/test/data/project/Main.class new file mode 100644 Binary files /dev/null and b/test/data/project/Main.class differ diff --git a/test/data/project/Main.java b/test/data/project/Main.java new file mode 100644 --- /dev/null +++ b/test/data/project/Main.java @@ -0,0 +1,37 @@ + +public class Main implements Runnable { + + private int someAttr = 2; + private double someOtherAttr = 4.0; + + public static void main (String [] argv) { + System.out.println("Hello, World!"); + } + + public int addOne() { + someAttr = someAttr + 1; + return someAttr; + } + + public int aComplexExample(int a ) { + // This should produce a tableswitch + switch (a) { + case 0: return 2; + case 1: return 1; + case 2: return 0; + default: + System.out.println("Reached Table Default"); + } + // This should produce a LookupSwitch + switch (a) { + case 0: return 2; + case 23232: return 0; + case 23232233: return 1; + default: + System.out.println("Reached Lookup Default"); + } + return a; + } + + public void run () { } +}