diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,8 @@ # Change log +## Version 0.6.0 +- Add Annotations + ## Version 0.5.0 - Reintroduce AbsVariableMethodId - Small cleanups diff --git a/jvm-binary.cabal b/jvm-binary.cabal --- a/jvm-binary.cabal +++ b/jvm-binary.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: b0838b7237f06859c9ba16149ea4153fb80472faa6c7321eef053fdecc6236f7 +-- hash: ab8fcc898f0e79144b2d18c7b74d169753e038db47b3648aca3c7a76a9418494 name: jvm-binary -version: 0.5.0 +version: 0.6.0 synopsis: A library for reading Java class-files description: A library for reading Java class-files. category: Language, Java, JVM @@ -50,6 +50,7 @@ Language.JVM Language.JVM.AccessFlag Language.JVM.Attribute + Language.JVM.Attribute.Annotations Language.JVM.Attribute.Base Language.JVM.Attribute.BootstrapMethods Language.JVM.Attribute.Code @@ -105,6 +106,7 @@ , vector , zip-archive other-modules: + Language.JVM.Attribute.AnnotationsSpec Language.JVM.Attribute.BootstrapMethodsSpec Language.JVM.Attribute.CodeSpec Language.JVM.Attribute.ConstantValueSpec diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: jvm-binary -version: '0.5.0' +version: '0.6.0' author: Christian Gram Kalhauge maintainer: Christian Gram Kalhauge synopsis: A library for reading Java class-files 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,6 +23,19 @@ , LineNumberTable , StackMapTable , Signature + + , RuntimeVisibleAnnotations + , RuntimeInvisibleAnnotations + , RuntimeVisibleParameterAnnotations + , RuntimeInvisibleParameterAnnotations + , RuntimeVisibleTypeAnnotations + , RuntimeInvisibleTypeAnnotations + + , ClassTypeAnnotation + , MethodTypeAnnotation + , FieldTypeAnnotation + , CodeTypeAnnotation + , AnnotationDefault ) where import Language.JVM.Attribute.Base @@ -33,3 +46,15 @@ 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 + ) diff --git a/src/Language/JVM/Attribute/Annotations.hs b/src/Language/JVM/Attribute/Annotations.hs new file mode 100644 --- /dev/null +++ b/src/Language/JVM/Attribute/Annotations.hs @@ -0,0 +1,683 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-| +Module : Language.JVM.Attribute.RuntimeVisibleAnnotations +Copyright : (c) Christian Gram Kalhauge, 2018-2019 +License : MIT +Maintainer : kalhuage@cs.ucla.edu + +Based on the Annotations Attribute, as documented +[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 (..) + + -- * TypeAnnotations + + , TypeAnnotation (..) + + , TypePath + , TypePathItem (..) + , TypePathKind (..) + + , RuntimeVisibleTypeAnnotations (..) + , RuntimeInvisibleTypeAnnotations (..) + + , ClassTypeAnnotation (..) + , MethodTypeAnnotation (..) + , FieldTypeAnnotation (..) + , CodeTypeAnnotation (..) + + , TypeParameterTarget + , SupertypeTarget + , isInExtendsClause + , TypeParameterBoundTarget + , FormalParameterTarget + , ThrowsTarget + , LocalvarTarget + , LocalvarEntry (..) + , CatchTarget + , OffsetTarget + , TypeArgumentTarget (..) + + -- * AnnotationDefault + , AnnotationDefault (..) + ) where + +-- base +import Data.Char +import Numeric +import GHC.Generics +import Unsafe.Coerce + +-- text +import qualified Data.Text as Text + +-- nfdata +import Control.DeepSeq + +-- binary +import Data.Binary +import qualified Data.Binary.Get as Get + +-- jvm-binary +import Language.JVM.Attribute.Base +import Language.JVM.Constant +import Language.JVM.Staged +import Language.JVM.ByteCode +import Language.JVM.Type +import Language.JVM.Utils + +-- | 'RuntimeVisibleAnnotations' +newtype RuntimeVisibleAnnotations r = RuntimeVisibleAnnotations + { asListOfRuntimeVisibleAnnotations + :: SizedList16 (Annotation r) + } + +instance IsAttribute (RuntimeVisibleAnnotations Low) where + attrName = Const "RuntimeVisibleAnnotations" + +instance Staged RuntimeVisibleAnnotations where + stage f (RuntimeVisibleAnnotations m) = + label "RuntimeVisibleAnnotations" + $ RuntimeVisibleAnnotations <$> mapM f m + +newtype RuntimeInvisibleAnnotations r = RuntimeInvisibleAnnotations + { asListOfRuntimeInvisibleAnnotations :: SizedList16 (Annotation r) + } + +instance IsAttribute (RuntimeInvisibleAnnotations Low) where + attrName = Const "RuntimeInvisibleAnnotations" + +instance Staged RuntimeInvisibleAnnotations where + stage f (RuntimeInvisibleAnnotations m) = + label "RuntimeInvisibleAnnotations" + $ RuntimeInvisibleAnnotations <$> mapM f m + +newtype RuntimeVisibleParameterAnnotations r = + RuntimeVisibleParameterAnnotations + { asListOfVisibleParameterAnnotations + :: SizedList8 (SizedList16 (Annotation r)) + } + +-- | 'RuntimeVisibleParameterAnnotations' is an Attribute. +instance IsAttribute (RuntimeVisibleParameterAnnotations Low) where + attrName = Const "RuntimeVisibleParameterAnnotations" + +instance Staged RuntimeVisibleParameterAnnotations where + stage f (RuntimeVisibleParameterAnnotations m) = + label "RuntimeVisibleParameterAnnotations" + $ RuntimeVisibleParameterAnnotations <$> mapM (mapM f) m + +newtype RuntimeInvisibleParameterAnnotations r = + RuntimeInvisibleParameterAnnotations + { asListOfInvisibleParameterAnnotations + :: SizedList8 (SizedList16 (Annotation r)) + } + +-- | 'RuntimeInvisibleParameterAnnotations' is an Attribute. +instance IsAttribute (RuntimeInvisibleParameterAnnotations Low) where + attrName = Const "RuntimeInvisibleParameterAnnotations" + +instance Staged RuntimeInvisibleParameterAnnotations where + stage f (RuntimeInvisibleParameterAnnotations m) = + label "RuntimeInvisibleParameterAnnotations" + $ RuntimeInvisibleParameterAnnotations <$> mapM (mapM f) m + +data Annotation r = Annotation + { annotationType :: !(Ref Text.Text 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 + +data ValuePair r = ValuePair + { name :: !(Ref Text.Text r) + , value :: !(ElementValue r) + } + +instance Staged ValuePair where + evolve (ValuePair t b) = ValuePair <$> link t <*> evolve b + devolve (ValuePair t b) = ValuePair <$> unlink t <*> devolve b + +data ElementValue r + = EByte !(Ref VInteger r) + | EChar !(Ref VInteger r) + | EDouble !(Ref VDouble r) + | EFloat !(Ref VFloat r) + | EInt !(Ref VInteger r) + | ELong !(Ref VLong r) + | EShort !(Ref VInteger r) + | EBoolean !(Ref VInteger r) + | EString !(Ref VString r) + + | EEnum !(EnumValue r) + | EClass !(Ref ReturnDescriptor r) + | EAnnotationType !(Annotation r) + + | EArrayType !(SizedList16 (ElementValue r)) + +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 + EAnnotationType s -> EAnnotationType <$> 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 + EAnnotationType s -> EAnnotationType <$> devolve s + EArrayType s -> EArrayType <$> mapM devolve s + +instance Binary (ElementValue Low) where + get = Get.label "ElementValue" $ getChar8 >>= \case + 'B' -> EByte <$> get + 'C' -> EChar <$> get + 'D' -> EDouble <$> get + 'F' -> EFloat <$> get + 'I' -> EInt <$> get + 'J' -> ELong <$> get + 'S' -> EShort <$> get + 'Z' -> EBoolean <$> get + 's' -> EString <$> get + 'e' -> EEnum <$> get + 'c' -> EClass <$> get + '@' -> EAnnotationType <$> get + '[' -> EArrayType <$> get + 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 + EAnnotationType a -> putChar8 '@' >> put a + EArrayType a -> putChar8 '[' >> put a + + where putChar8 = putWord8 . fromIntegral . ord + +data EnumValue r = EnumValue + { enumTypeName :: !(Ref FieldDescriptor r) + , enunConstName :: !(Ref Text.Text r) + } + +instance Staged EnumValue where + 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. +data TypeAnnotation m r = TypeAnnotation + { typeAnnotationTarget :: m r + , typeAnnotationPath :: !TypePath + , typeAnnotationValuePairs :: SizedList16 (ValuePair r) + } + +instance Binary (m Low) => Binary (TypeAnnotation m Low) where + get = TypeAnnotation <$> get <*> get <*> get + put TypeAnnotation {..} = + put typeAnnotationTarget + >> put typeAnnotationPath + >> put typeAnnotationValuePairs + +instance Staged m => Staged (TypeAnnotation m) where + stage f TypeAnnotation {..} = + TypeAnnotation + <$> stage f typeAnnotationTarget + <*> pure typeAnnotationPath + <*> mapM f typeAnnotationValuePairs + +instance ByteCodeStaged m => ByteCodeStaged (TypeAnnotation m) where + evolveBC f TypeAnnotation {..} = + TypeAnnotation + <$> evolveBC f typeAnnotationTarget + <*> pure typeAnnotationPath + <*> mapM evolve typeAnnotationValuePairs + + devolveBC f TypeAnnotation {..} = + TypeAnnotation + <$> devolveBC f typeAnnotationTarget + <*> pure typeAnnotationPath + <*> mapM devolve typeAnnotationValuePairs + +deriving instance Show (m High) => Show (TypeAnnotation m High) +deriving instance Eq (m High) => Eq (TypeAnnotation m High) +deriving instance Generic (m High) => Generic (TypeAnnotation m High) +deriving instance (Generic (m High), NFData (m High)) => NFData (TypeAnnotation m High) + +deriving instance Show (m Low) => Show (TypeAnnotation m Low) +deriving instance Eq (m Low) => Eq (TypeAnnotation m Low) +deriving instance Ord (m Low) => Ord (TypeAnnotation m Low) +deriving instance Generic (m Low) => Generic (TypeAnnotation m Low) +deriving instance (Generic (m Low), NFData (m Low)) => NFData (TypeAnnotation m Low) + +type TypePath = SizedList8 TypePathItem + +data TypePathItem = TypePathItem + { typePathKind :: !TypePathKind + , typePathIndex :: !Word8 + } deriving (Show, Eq, Ord, Generic, NFData) + +data TypePathKind + = TPathInArray + | TPathInNested + | TPathWildcard + | TPathTypeArgument + deriving (Show, Eq, Ord, Generic, NFData) + +instance Binary TypePathItem where + get = do + typePathKind <- getWord8 >>= \case + 0 -> pure TPathInArray + 1 -> pure TPathInNested + 2 -> pure TPathWildcard + 3 -> pure TPathTypeArgument + a -> fail $ "Expected unsigned byte in range [0:3] got: " ++ show a + typePathIndex <- getWord8 + pure $ TypePathItem {..} + + put TypePathItem {..} = do + putWord8 $ case typePathKind of + TPathInArray -> 0 + TPathInNested -> 1 + TPathWildcard -> 2 + TPathTypeArgument -> 3 + putWord8 typePathIndex + + +-- | From [here](https://docs.oracle.com/javase/specs/jvms/se9/html/jvms-4.html#jvms-4.7.20-400) +data ClassTypeAnnotation r + = ClassTypeParameterDeclaration !TypeParameterTarget + -- ^ type parameter declaration of generic class or interface (0x00) + | ClassSuperType !SupertypeTarget + -- ^ type in extends clause of class or interface declaration, or in + -- implements clause of interface declaration (0x10) + | ClassBoundTypeParameterDeclaration !TypeParameterBoundTarget + -- ^ type in bound of type parameter declaration of generic class or + -- interface (0x11) + +instance Binary (ClassTypeAnnotation Low) where + get = getWord8 >>= \case + 0x00 -> ClassTypeParameterDeclaration <$> get + 0x10 -> ClassSuperType <$> get + 0x11 -> ClassBoundTypeParameterDeclaration <$> get + 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 + ClassBoundTypeParameterDeclaration a -> putWord8 0x11 >> put a + +instance Staged ClassTypeAnnotation where + stage _ = unsafeCoerce + +data MethodTypeAnnotation r + = MethodTypeParameterDeclaration !TypeParameterTarget + -- ^ type parameter declaration of generic method or constructor (0x01) + | MethodBoundTypeParameterDeclaration !TypeParameterBoundTarget + -- ^ type in bound of type parameter declaration of generic method or + -- constructor (0x12) + | MethodReturnType + -- ^ return type of method or constructor (0x14) + | MethodReceiverType + -- ^ receiver type of method or constructor (0x15) + | MethodFormalParameter !FormalParameterTarget + -- ^ type in formal parameter declaration of method, constructor, or lambda + -- expression (0x16) + | MethodThrowsClause !ThrowsTarget + -- ^ type in throws clause of method or constructor (0x17) + +instance Binary (MethodTypeAnnotation Low) where + get = getWord8 >>= \case + 0x01 -> MethodTypeParameterDeclaration <$> get + 0x12 -> MethodBoundTypeParameterDeclaration <$> get + 0x14 -> pure MethodReturnType + 0x15 -> pure MethodReceiverType + 0x16 -> MethodFormalParameter <$> get + 0x17 -> MethodThrowsClause <$> get + a -> fail $ "Unexpected target type " ++ showHex a "" ++ " in method type annotation" + + put = \case + 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 + +instance Staged MethodTypeAnnotation where + stage _ = unsafeCoerce + +data FieldTypeAnnotation r = + FieldTypeAnnotation + -- ^ type in field declaration (0x13) + +instance Staged FieldTypeAnnotation where + stage _ = unsafeCoerce + +instance Binary (FieldTypeAnnotation Low) where + get = getWord8 >>= \case + 0x13 -> pure FieldTypeAnnotation + a -> fail $ "Unexpected target type " ++ showHex a "" ++ " in field type annotation" + + put _ = putWord8 0x13 + +data CodeTypeAnnotation r + = LocalVariableDeclaration !(LocalvarTarget r) + -- ^ type in local variable declaration (0x40) + | ResourceVariableDeclaration !(LocalvarTarget r) + -- ^ type in resource variable declaration (0x41) + | ExceptionParameterDeclaration !CatchTarget + -- ^ type in exception parameter declaration (0x42) + | InstanceOfExpression !(OffsetTarget r) + -- ^ type in instanceof expression (0x43) + | NewExpression !(OffsetTarget r) + -- ^ type in new expression (0x44) + | NewMethodReferenceExpression !(OffsetTarget r) + -- ^ type in method reference expression using ::new (0x45) + | IdentifierMethodReferenceExpression !(OffsetTarget r) + -- ^ type in method reference expression using ::Identifier (0x46) + | CastExpression !(TypeArgumentTarget r) + -- ^ type in cast expression (0x47) + | ConstructorExpression !(TypeArgumentTarget r) + -- ^ type argument for generic constructor in new expression or explicit + -- constructor invocation statement (0x48) + | MethodIncovationExpression !(TypeArgumentTarget r) + -- ^ type argument for generic method in method invocation expression (0x49) + | GenericNewMethodReferenceExpression !(TypeArgumentTarget r) + -- ^ type argument for generic constructor in method reference expression using ::new (0x4A) + | GenericIdentifierwMethodReferenceExpression !(TypeArgumentTarget r) + -- ^ type argument for generic method in method reference expression using ::Identifier (0x4B) + +instance Binary (CodeTypeAnnotation Low) where + get = getWord8 >>= \case + 0x40 -> LocalVariableDeclaration <$> get + 0x41 -> ResourceVariableDeclaration <$> get + 0x42 -> ExceptionParameterDeclaration <$> get + 0x43 -> InstanceOfExpression <$> get + 0x44 -> NewExpression <$> get + 0x45 -> NewMethodReferenceExpression <$> get + 0x46 -> IdentifierMethodReferenceExpression <$> get + 0x47 -> CastExpression <$> get + 0x48 -> ConstructorExpression <$> get + 0x49 -> MethodIncovationExpression <$> get + 0x4A -> GenericNewMethodReferenceExpression <$> get + 0x4B -> GenericIdentifierwMethodReferenceExpression <$> get + 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 + 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 + 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 + ConstructorExpression a -> ConstructorExpression <$> 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 + 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 + ConstructorExpression a -> ConstructorExpression <$> 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, +-- generic method, or generic constructor. +type TypeParameterTarget = Word8 + +-- | The 'SupertypeTarget' item indicates that an annotation appears on a type in +-- the extends or implements clause of a class or interface declaration. +-- +-- A value of 65535 specifies that the annotation appears on the superclass in +-- an extends clause of a class declaration. +type SupertypeTarget = Word16 + +-- | Check if the 'SupertypeTarget' is in the extends clauses +isInExtendsClause :: SupertypeTarget -> Bool +isInExtendsClause st = st == 0xFFFF + +-- | The 'TypeParameterBoundTarget' item indicates that an annotation appears +-- on the i'th bound of the j'th type parameter declaration of a generic class, +-- interface, method, or constructor. +data TypeParameterBoundTarget = TypeParameterBoundTarget + { typeParameter :: !TypeParameterTarget + , typeBound :: !Word8 + } deriving (Eq, Show, Ord, Generic, NFData) + +instance Binary TypeParameterBoundTarget + +-- | The 'FormalParameterTarget' item indicates that an annotation appears on +-- the type in a formal parameter declaration of a method, constructor, or +-- lambda expression. The target is 0-indexed. +type FormalParameterTarget = Word8 + +-- | The 'ThrowsTarget' item indicates that an annotation appears on the i'th +-- type in the throws clause of a method or constructor declaration. +-- +-- The value is an index into the Exceptions attribute +type ThrowsTarget = Word16 + +-- | The 'LocalvarTarget' item indicates that an annotation appears on the type +-- in a local variable declaration, including a variable declared as a resource +-- in a try-with-resources statement. +-- +-- The table is needed because a variable might span multiple live ranges. +type LocalvarTarget r = SizedList16 (LocalvarEntry r) + +-- | An entry in the Localvar Table +data LocalvarEntry r = LocalvarEntry + { lvStartPc :: !(ByteCodeRef r) + , lvLength :: !Word16 + , lvLocalVarIndex :: !Word16 + } + +instance ByteCodeStaged LocalvarEntry where + evolveBC ev LocalvarEntry {..} = + LocalvarEntry <$> ev lvStartPc <*> pure lvLength <*> pure lvLocalVarIndex + + devolveBC dev LocalvarEntry {..} = + LocalvarEntry <$> dev lvStartPc <*> pure lvLength <*> pure lvLocalVarIndex + +-- | The 'CatchTarget' item indicates that an annotation appears on the i'th +-- type in an exception parameter declaration. +type CatchTarget = Word16 + +-- | The 'OffsetTarget' item indicates that an annotation appears on either the +-- type in an instanceof expression or a new expression, or the type before the +-- :: in a method reference expression. +type OffsetTarget r = ByteCodeRef r + +-- | The 'TypeArgumentTarget' item indicates that an annotation appears either +-- on the i'th type in a cast expression, or on the i'th type argument in the +-- explicit type argument list for any of the following: a new expression, an +-- explicit constructor invocation statement, a method invocation expression, or a +-- method reference expression. +data TypeArgumentTarget r = TypeArgumentTarget + { typeArgumentOffset :: !(ByteCodeRef r) + , typeArgumentIndex :: Word8 + } + +instance ByteCodeStaged TypeArgumentTarget where + evolveBC ev TypeArgumentTarget {..} = + TypeArgumentTarget <$> ev typeArgumentOffset <*> pure typeArgumentIndex + + devolveBC dev TypeArgumentTarget {..} = + TypeArgumentTarget <$> dev typeArgumentOffset <*> pure typeArgumentIndex + + +instance (Generic (m Low), Binary (m Low)) => IsAttribute (RuntimeVisibleTypeAnnotations m Low) where + attrName = Const "RuntimeVisibleTypeAnnotations" + +instance (Staged m) => Staged (RuntimeVisibleTypeAnnotations m) where + stage f (RuntimeVisibleTypeAnnotations a) = + RuntimeVisibleTypeAnnotations <$> mapM f a + +instance ByteCodeStaged m => ByteCodeStaged (RuntimeVisibleTypeAnnotations m) where + evolveBC f (RuntimeVisibleTypeAnnotations a) = + RuntimeVisibleTypeAnnotations <$> mapM (evolveBC f) a + + devolveBC f (RuntimeVisibleTypeAnnotations a) = + RuntimeVisibleTypeAnnotations <$> mapM (devolveBC f) a + +newtype RuntimeVisibleTypeAnnotations m r = + RuntimeVisibleTypeAnnotations + { asListOfVisibleTypeAnnotations + :: SizedList16 (TypeAnnotation m r) + } + +-- | 'RuntimeInvisibleTypeAnnotations' is an Attribute. +instance (Generic (m Low), Binary (m Low)) => IsAttribute (RuntimeInvisibleTypeAnnotations m Low) where + attrName = Const "RuntimeInvisibleTypeAnnotations" + +instance Staged m => Staged (RuntimeInvisibleTypeAnnotations m) where + stage f (RuntimeInvisibleTypeAnnotations a) = + RuntimeInvisibleTypeAnnotations <$> mapM f a + +instance ByteCodeStaged m => ByteCodeStaged (RuntimeInvisibleTypeAnnotations m) where + evolveBC f (RuntimeInvisibleTypeAnnotations a) = + RuntimeInvisibleTypeAnnotations <$> mapM (evolveBC f) a + + devolveBC f (RuntimeInvisibleTypeAnnotations a) = + RuntimeInvisibleTypeAnnotations <$> mapM (devolveBC f) a + +newtype RuntimeInvisibleTypeAnnotations m r = + RuntimeInvisibleTypeAnnotations + { asListOfInvisibleTypeAnnotations + :: SizedList16 (TypeAnnotation m r) + } + +deriving instance Show (m High) => Show (RuntimeVisibleTypeAnnotations m High) +deriving instance Eq (m High) => Eq (RuntimeVisibleTypeAnnotations m High) +deriving instance Generic (m High) => Generic (RuntimeVisibleTypeAnnotations m High) +deriving instance (Generic (m High), NFData (m High)) => NFData (RuntimeVisibleTypeAnnotations m High) + +deriving instance Show (m Low) => Show (RuntimeVisibleTypeAnnotations m Low) +deriving instance Eq (m Low) => Eq (RuntimeVisibleTypeAnnotations m Low) +deriving instance Ord (m Low) => Ord (RuntimeVisibleTypeAnnotations m Low) +deriving instance Generic (m Low) => Generic (RuntimeVisibleTypeAnnotations m Low) +deriving instance (Generic (m Low), NFData (m Low)) => NFData (RuntimeVisibleTypeAnnotations m Low) +deriving instance (Generic (m Low), Binary (m Low)) => Binary (RuntimeVisibleTypeAnnotations m Low) + +deriving instance Show (m High) => Show (RuntimeInvisibleTypeAnnotations m High) +deriving instance Eq (m High) => Eq (RuntimeInvisibleTypeAnnotations m High) +deriving instance Generic (m High) => Generic (RuntimeInvisibleTypeAnnotations m High) +deriving instance (Generic (m High), NFData (m High)) => NFData (RuntimeInvisibleTypeAnnotations m High) + +deriving instance Show (m Low) => Show (RuntimeInvisibleTypeAnnotations m Low) +deriving instance Eq (m Low) => Eq (RuntimeInvisibleTypeAnnotations m Low) +deriving instance Ord (m Low) => Ord (RuntimeInvisibleTypeAnnotations m Low) +deriving instance Generic (m Low) => Generic (RuntimeInvisibleTypeAnnotations m Low) +deriving instance (Generic (m Low), NFData (m Low)) => NFData (RuntimeInvisibleTypeAnnotations m Low) + +deriving instance (Generic (m Low), Binary (m Low)) => Binary (RuntimeInvisibleTypeAnnotations m Low) + +-- | The AnnotationDefault attribute is a variable-length attribute in the +-- attributes table of certain method_info structures (§4.6), namely those +-- representing elements of annotation types (JLS §9.6.1). The AnnotationDefault +-- attribute records the default value (JLS §9.6.2) for the element represented by +-- the method_info structure. The Java Virtual Machine must make this default value +-- available so it can be applied by appropriate reflective APIs. +newtype AnnotationDefault r = AnnotationDefault + { defaultValue :: ElementValue r + } + +instance IsAttribute (AnnotationDefault Low) where + attrName = Const "AnnotationDefault" + +instance Staged AnnotationDefault where + stage f AnnotationDefault {..} = AnnotationDefault <$> stage f defaultValue + + +$(deriveBaseWithBinary ''RuntimeInvisibleAnnotations) +$(deriveBaseWithBinary ''RuntimeVisibleAnnotations) +$(deriveBaseWithBinary ''RuntimeInvisibleParameterAnnotations) +$(deriveBaseWithBinary ''RuntimeVisibleParameterAnnotations) +$(deriveBaseWithBinary ''Annotation) +$(deriveBaseWithBinary ''ValuePair) +$(deriveBaseWithBinary ''AnnotationDefault) +$(deriveBase ''ElementValue) + +$(deriveBase ''ClassTypeAnnotation) +$(deriveBase ''MethodTypeAnnotation) +$(deriveBase ''FieldTypeAnnotation) +$(deriveBase ''CodeTypeAnnotation) + +$(deriveBaseWithBinary ''LocalvarEntry) +$(deriveBaseWithBinary ''TypeArgumentTarget) + +$(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 @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -14,6 +15,7 @@ ( Attribute (..) , aInfo , toAttribute + , toBCAttribute , devolveAttribute , fromAttribute' , toAttribute' @@ -22,22 +24,33 @@ , IsAttribute (..) , Attributes , fromAttributes - , toC - , toC' , collect + , collectBC + , AttributeCollector (..) + , ByteCodeAttributeCollector (..) , Const (..) , firstOne ) where +-- base +import Data.Monoid import Control.Monad +import Data.Maybe import Data.Bifunctor +import qualified Data.List as List + +-- binary import Data.Binary + +-- bytestring import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL -import qualified Data.List as List + +-- text import qualified Data.Text as Text import Language.JVM.Staged +import Language.JVM.ByteCode import Language.JVM.Utils -- | Maybe return the first element of a list @@ -48,7 +61,7 @@ -- contains info. data Attribute r = Attribute { aName :: ! (Ref Text.Text r) - , aInfo' :: ! (SizedByteString32) + , aInfo' :: ! SizedByteString32 } -- | A small helper function to extract the info as a @@ -94,6 +107,14 @@ toAttribute = devolveAttribute devolve +toBCAttribute :: + (IsAttribute (a Low), ByteCodeStaged a, DevolveM m) + => (ByteCodeIndex -> m ByteCodeOffset) + -> a High + -> m (Attribute Low) +toBCAttribute bcde = + devolveAttribute (devolveBC bcde) + devolveAttribute :: (IsAttribute (a Low), DevolveM m) => (a High -> m (a Low)) -> a High -> m (Attribute Low) devolveAttribute f a = do a' <- f a @@ -106,49 +127,72 @@ -> Maybe (m (a High)) fromAttribute as = if aName as == unConst (attrName :: Const Text.Text (a Low)) - then Just $ do - either attributeError evolve $ fromAttribute' as + then Just . label (Text.unpack $ aName as) . either attributeError evolve $ fromAttribute' as else Nothing --- | Generate an attribute in the 'EvolveM' monad -evolveAttribute :: - forall a m. (IsAttribute (a Low), EvolveM m) - => (a Low -> m (a High)) +-- | Generate an BCAttribute in the 'EvolveM' monad +fromBCAttribute :: + forall a m. (IsAttribute (a Low), ByteCodeStaged a, EvolveM m) + => (ByteCodeOffset -> m ByteCodeIndex) -> Attribute High -> Maybe (m (a High)) -evolveAttribute g as = +fromBCAttribute fn as = if aName as == unConst (attrName :: Const Text.Text (a Low)) - then Just $ do - either attributeError g $ fromAttribute' as + then Just . label (Text.unpack $ aName as) . either attributeError (evolveBC fn) $ fromAttribute' as else Nothing -toC :: (EvolveM m, Staged a, IsAttribute (a Low)) => (a High -> c) -> Attribute High -> Maybe (m c) -toC f attr = - case fromAttribute attr of - Just m -> Just $ f <$> m - Nothing -> Nothing +-- -- | Generate an attribute in the 'EvolveM' monad +-- evolveAttribute :: +-- forall a m. (IsAttribute (a Low), EvolveM m) +-- => (a Low -> m (a High)) +-- -> Attribute High +-- -> Maybe (m (a High)) +-- evolveAttribute g as = +-- if aName as == unConst (attrName :: Const Text.Text (a Low)) +-- then Just $ either attributeError g $ fromAttribute' as +-- else Nothing -toC' :: (EvolveM m, IsAttribute (a Low)) => (a Low -> m (a High)) -> (a High -> c) -> Attribute High -> Maybe (m c) -toC' g f attr = - case evolveAttribute g attr of - Just m -> Just $ f <$> m - Nothing -> Nothing +collect :: + forall c m. (EvolveM m) + => [AttributeCollector c] + -> (Attribute High -> c -> c) + -> Attribute High + -> m (Endo c) +collect options def attr = + fromMaybe (return $ Endo (def attr)) + . msum + $ (\(Attr fn) -> fmap (Endo . fn) <$> fromAttribute attr) <$> options -collect :: (Monad m) => c -> Attribute High -> [Attribute High -> Maybe (m c)] -> m c -collect c attr options = - case msum $ Prelude.map ($ attr) options of - Just x -> x - Nothing -> return c +data AttributeCollector c + = forall a. (IsAttribute (a Low), Staged a) + => Attr (a High -> c -> c) +collectBC :: + forall c m. (EvolveM m) + => (ByteCodeOffset -> m ByteCodeIndex) + -> [ByteCodeAttributeCollector c] + -> (Attribute High -> c -> c) + -> Attribute High + -> m (Endo c) +collectBC evolvefn options def attr = + fromMaybe (return $ Endo (def attr)) + . msum + $ (\(BCAttr fn) -> fmap (Endo . fn) <$> fromBCAttribute evolvefn attr) <$> options + +data ByteCodeAttributeCollector c + = forall a. (IsAttribute (a Low), ByteCodeStaged a) + => BCAttr (a High -> c -> c) + + -- | Given a 'Foldable' structure 'f', and a function that can calculate a -- monoid given an 'Attribute' calculate the monoid over all attributes. fromAttributes :: (Foldable f, EvolveM m, Monoid a) => AttributeLocation - -> (Attribute High -> m a) -> f (Attribute Low) + -> (Attribute High -> m a) -> m a -fromAttributes al f attrs = do +fromAttributes al attrs f = do afilter <- attributeFilter Prelude.foldl (g afilter) (return mempty) attrs where @@ -159,8 +203,7 @@ then do x <- f ah return $ b `mappend` x - else do - return b + else return b readFromStrict :: Binary a => Attribute r -> Either String a readFromStrict = diff --git a/src/Language/JVM/Attribute/Code.hs b/src/Language/JVM/Attribute/Code.hs --- a/src/Language/JVM/Attribute/Code.hs +++ b/src/Language/JVM/Attribute/Code.hs @@ -15,6 +15,7 @@ module Language.JVM.Attribute.Code ( Code (..) , CodeAttributes (..) + , emptyCodeAttributes , ExceptionTable (..) , codeStackMapTable , codeByteCodeOprs @@ -30,6 +31,7 @@ import Language.JVM.Attribute.Base import Language.JVM.Attribute.LineNumberTable import Language.JVM.Attribute.StackMapTable +import Language.JVM.Attribute.Annotations import Language.JVM.ByteCode import Language.JVM.Constant import Language.JVM.Staged @@ -78,25 +80,30 @@ data CodeAttributes r = CodeAttributes { caStackMapTable :: [ StackMapTable r ] , caLineNumberTable :: [ LineNumberTable r ] + , caVisibleTypeAnnotations :: + [ RuntimeVisibleTypeAnnotations CodeTypeAnnotation r ] + , caInvisibleTypeAnnotations :: + [ RuntimeInvisibleTypeAnnotations CodeTypeAnnotation r ] , caOthers :: [ Attribute r ] } +emptyCodeAttributes :: CodeAttributes High +emptyCodeAttributes = CodeAttributes [] [] [] [] [] + instance Staged Code where evolve Code{..} = label "Code" $ do (offsets, codeByteCode) <- evolveByteCode codeByteCode let evolver = (evolveOffset offsets) codeExceptionTable <- mapM (evolveBC evolver) codeExceptionTable - codeAttributes <- fromCollector <$> - fromAttributes CodeAttribute (collect' evolver) codeAttributes + codeAttributes <- fmap (`appEndo` emptyCodeAttributes) . fromAttributes CodeAttribute codeAttributes + $ collectBC evolver + [ BCAttr (\e a -> a {caStackMapTable = e : caStackMapTable a}) + , BCAttr (\e a -> a {caLineNumberTable = e : caLineNumberTable a}) + , BCAttr (\e a -> a {caVisibleTypeAnnotations = e : caVisibleTypeAnnotations a}) + , BCAttr (\e a -> a {caInvisibleTypeAnnotations = e : caInvisibleTypeAnnotations a}) + ] + (\e a -> a {caOthers = e : caOthers a}) return $ Code {..} - where - fromCollector (a, b, c) = - CodeAttributes (appEndo a []) (appEndo b []) (appEndo c []) - collect' evolver attr = - collect (mempty, mempty, Endo (attr:)) attr - [ toC' (evolveBC evolver) $ \e -> (Endo (e:), mempty, mempty) - , toC' (evolveBC evolver) $ \e -> (mempty, Endo (e:), mempty) - ] devolve Code{..} = do codeByteCode <- devolveByteCode codeByteCode @@ -106,16 +113,19 @@ codeAttributes <- SizedList <$> fromCodeAttributes bcdevolver codeAttributes return $ Code {..} where - fromCodeAttributes bcdevolver (CodeAttributes a b c) = do - a' <- mapM (devolveAttribute (devolveBC bcdevolver)) a - b' <- mapM (devolveAttribute (devolveBC bcdevolver)) b - c' <- mapM devolve c - return (a' ++ b' ++ c') + fromCodeAttributes bcdevolver CodeAttributes {..} = + concat <$> sequence + [ mapM (toBCAttribute bcdevolver) caStackMapTable + , mapM (toBCAttribute bcdevolver) caLineNumberTable + , mapM (toBCAttribute bcdevolver) caVisibleTypeAnnotations + , mapM (toBCAttribute bcdevolver) caInvisibleTypeAnnotations + , mapM devolve caOthers + ] instance ByteCodeStaged ExceptionTable where evolveBC f ExceptionTable{..} = label "ExceptionTable" $ do catchType <- case catchType of - 0 -> return $ Nothing + 0 -> return Nothing n -> Just <$> link n start <- f start end <- f end 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 @@ -1,5 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RecordWildCards #-} {-| Module : Language.JVM.ClassFile Copyright : (c) Christian Gram Kalhauge, 2017 @@ -8,10 +13,6 @@ The class file is described in this module. -} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} module Language.JVM.ClassFile ( ClassFile (..) , cAccessFlags @@ -23,6 +24,7 @@ -- * Attributes , ClassAttributes (..) + , emptyClassAttributes , cBootstrapMethods ) where @@ -106,13 +108,23 @@ maybe [] innerClasses . cInnerClasses' data ClassAttributes r = ClassAttributes - { caBootstrapMethods :: [ BootstrapMethods r] - , caSignature :: [ Signature r ] - , caEnclosingMethod :: [ EnclosingMethod r ] - , caInnerClasses :: [ InnerClasses r ] - , caOthers :: [ Attribute r ] + { caBootstrapMethods :: [ BootstrapMethods r] + , caSignature :: [ Signature r ] + , caEnclosingMethod :: [ EnclosingMethod r ] + , caInnerClasses :: [ InnerClasses r ] + , caVisibleAnnotations :: [ RuntimeVisibleAnnotations r ] + , caInvisibleAnnotations :: [ RuntimeInvisibleAnnotations r ] + , caVisibleTypeAnnotations :: + [ RuntimeVisibleTypeAnnotations ClassTypeAnnotation r ] + , caInvisibleTypeAnnotations :: + [ RuntimeInvisibleTypeAnnotations ClassTypeAnnotation r ] + , caOthers :: [ Attribute r ] } +emptyClassAttributes :: ClassAttributes High +emptyClassAttributes = + ClassAttributes [] [] [] [] [] [] [] [] [] + instance Staged ClassFile where evolve cf = label "ClassFile" $ do tci' <- link (cThisClass cf) @@ -125,7 +137,18 @@ cii' <- mapM link $ cInterfaces cf cf' <- mapM evolve $ cFields' cf cm' <- mapM evolve $ cMethods' cf - ca' <- fromCollector <$> fromAttributes ClassAttribute collect' (cAttributes cf) + ca' <- fmap (`appEndo` emptyClassAttributes) . fromAttributes ClassAttribute (cAttributes cf) + $ collect + [ Attr $ \e ca -> ca {caSignature = e : caSignature ca} + , Attr $ \e ca -> ca {caEnclosingMethod = e : caEnclosingMethod ca} + , Attr $ \e ca -> ca {caBootstrapMethods = e : caBootstrapMethods ca} + , Attr $ \e ca -> ca {caVisibleAnnotations = e : caVisibleAnnotations ca} + , Attr $ \e ca -> ca {caInvisibleAnnotations = e : caInvisibleAnnotations ca} + , Attr $ \e ca -> ca {caVisibleTypeAnnotations = e : caVisibleTypeAnnotations ca} + , Attr $ \e ca -> ca {caInvisibleTypeAnnotations = e : caInvisibleTypeAnnotations ca} + , Attr $ \e ca -> ca {caInnerClasses = e : caInnerClasses ca} + ] + (\e ca -> ca {caOthers = e : caOthers ca}) return $ cf { cConstantPool = () , cThisClass = tci' @@ -135,15 +158,6 @@ , cMethods' = cm' , cAttributes = ca' } - where - fromCollector = flip appEndo (ClassAttributes [] [] [] [] []) - collect' attr = - collect (Endo (\ca -> ca {caOthers = attr: caOthers ca})) attr - [ toC $ \e -> Endo (\ca -> ca {caSignature = e : caSignature ca}) - , toC $ \e -> Endo (\ca -> ca {caEnclosingMethod = e : caEnclosingMethod ca}) - , toC $ \e -> Endo (\ca -> ca {caBootstrapMethods = e : caBootstrapMethods ca}) - , toC $ \e -> Endo (\ca -> ca {caInnerClasses = e : caInnerClasses ca}) - ] devolve cf = do tci' <- unlink (cThisClass cf) @@ -167,13 +181,17 @@ , cAttributes = SizedList ca' } where - fromClassAttributes (ClassAttributes cm cs cem cin at) = do + fromClassAttributes (ClassAttributes {..}) = do concat <$> sequence - [ mapM toAttribute cm - , mapM toAttribute cs - , mapM toAttribute cem - , mapM toAttribute cin - , mapM devolve at + [ mapM toAttribute caBootstrapMethods + , mapM toAttribute caSignature + , mapM toAttribute caEnclosingMethod + , mapM toAttribute caInnerClasses + , mapM toAttribute caVisibleAnnotations + , mapM toAttribute caInvisibleAnnotations + , mapM toAttribute caVisibleTypeAnnotations + , mapM toAttribute caInvisibleTypeAnnotations + , mapM devolve caOthers ] $(deriveBase ''ClassAttributes) 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,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE StrictData #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -24,6 +25,11 @@ , Referenceable (..) , JValue (..) + , VInteger + , VLong + , VDouble + , VFloat + , VString -- * Special constants , ClassName (..) @@ -285,8 +291,8 @@ -> m (Constant High) instance Referenceable (Constant High) where - fromConst _ a = return a - toConst a = return a + fromConst _ = return + toConst = return instance TypeParse a => Referenceable (NameAndType a) where fromConst err (CNameAndType rn txt) = do @@ -335,10 +341,14 @@ either err return $ parseOnly parseFlatJRefType r fromConst err a = err $ wrongType "ClassRef" a - toConst = return . CClassRef . jRefTypeToFlatText +instance Referenceable ReturnDescriptor where + fromConst err = + fromConst err >=> either err return . typeFromText + toConst = toConst . typeToText + instance Referenceable MethodDescriptor where fromConst err = fromConst err >=> either err pure . typeFromText @@ -394,23 +404,21 @@ instance Referenceable (InvokeDynamic High) where - fromConst _ (CInvokeDynamic c) = do - return $ c + fromConst _ (CInvokeDynamic c) = return c fromConst err c = expected "CInvokeDynamic" err c toConst s = return $ CInvokeDynamic s instance Referenceable (MethodHandle High) where - fromConst _ (CMethodHandle c) = do - return $ c + fromConst _ (CMethodHandle c) = return c fromConst err c = expected "CMethodHandle" err c toConst s = return $ CMethodHandle s instance Referenceable (AbsInterfaceMethodId High) where - fromConst _ (CInterfaceMethodRef s) = do + fromConst _ (CInterfaceMethodRef s) = return . AbsInterfaceMethodId $ s fromConst err c = expected "CInterfaceMethodRef" err c @@ -445,41 +453,74 @@ $(deriveBaseWithBinary ''AbsInterfaceMethodId) $(deriveBaseWithBinary ''AbsVariableMethodId) +type VInteger = Int32 +type VLong = Int64 +type VFloat = Float +type VDouble = Double +type VString = BS.ByteString + +instance Referenceable VInteger where + fromConst err = \case + CInteger i -> return i + x -> expected "Integer" err x + toConst = return . CInteger + +instance Referenceable VLong where + fromConst err = \case + CLong i -> return i + x -> expected "Long" err x + toConst = return . CLong + +instance Referenceable VFloat where + fromConst err = \case + CFloat i -> return i + x -> expected "Float" err x + toConst = return . CFloat + +instance Referenceable VDouble where + fromConst err = \case + CDouble i -> return i + x -> expected "Double" err x + toConst = return . CDouble + +-- instance Referenceable VString where +-- fromConst err = \case +-- CStringRef i -> return i +-- x -> expected "StringRef" err x +-- toConst = return . CStringRef + -- | A constant pool value in java data JValue - = VInteger Int32 - | VLong Int64 - | VFloat Float - | VDouble Double - | VString BS.ByteString + = VInteger VInteger + | VLong VLong + | VFloat VFloat + | VDouble VDouble + | VString VString | VClass ClassName - | VMethodType (MethodDescriptor) + | VMethodType MethodDescriptor | VMethodHandle (MethodHandle High) deriving (Show, Eq, Generic, NFData) instance Referenceable JValue where - fromConst err c = do - case c of - 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) - CMethodHandle m -> return $ VMethodHandle m - CMethodType t -> return $ VMethodType t - x -> expected "Expected a Value" err x + 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) + CMethodHandle m -> return $ VMethodHandle m + CMethodType t -> return $ VMethodType t + x -> expected "Value" err x {-# INLINE fromConst #-} - - toConst c = - return $ case c of - 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 + 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 {-# INLINE toConst #-} 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 @@ -1,15 +1,15 @@ -{-# LANGUAGE TemplateHaskell #-} {-| Module : Language.JVM.Field Copyright : (c) Christian Gram Kalhauge, 2017 License : MIT Maintainer : kalhuage@cs.ucla.edu -} - +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RecordWildCards #-} module Language.JVM.Field ( Field (..) , fAccessFlags @@ -17,6 +17,7 @@ , fConstantValue , fSignature , FieldAttributes (..) + , emptyFieldAttributes ) where @@ -29,15 +30,16 @@ import Language.JVM.Constant import Language.JVM.Staged import Language.JVM.Utils +import Language.JVM.Type -- | A Field in the class-file, as described -- [here](http://docs.oracle.com/javase/specs/jvms/se7/html/jvms-4.html#jvms-4.5). data Field r = Field - { fAccessFlags' :: !(BitSet16 FAccessFlag) - , fName :: !(Ref Text.Text r) - , fDescriptor :: !(Ref FieldDescriptor r) - , fAttributes :: !(Attributes FieldAttributes r) + { fAccessFlags' :: !(BitSet16 FAccessFlag) + , fName :: !(Ref Text.Text r) + , fDescriptor :: !(Ref FieldDescriptor r) + , fAttributes :: !(Attributes FieldAttributes r) } -- | Get the set of access flags @@ -55,24 +57,36 @@ firstOne . faSignatures . fAttributes data FieldAttributes r = FieldAttributes - { faConstantValues :: [ ConstantValue r ] - , faSignatures :: [ Signature r ] - , faOthers :: [ Attribute r ] + { faConstantValues :: [ ConstantValue r ] + , faSignatures :: [ Signature r ] + , faVisibleAnnotations :: [ RuntimeVisibleAnnotations r ] + , faInvisibleAnnotations :: [ RuntimeInvisibleAnnotations r ] + , faVisibleTypeAnnotations :: + [ RuntimeVisibleTypeAnnotations FieldTypeAnnotation r ] + , faInvisibleTypeAnnotations :: + [ RuntimeInvisibleTypeAnnotations FieldTypeAnnotation r ] + , faOthers :: [ Attribute r ] } +emptyFieldAttributes :: FieldAttributes High +emptyFieldAttributes = + FieldAttributes [] [] [] [] [] [] [] + instance Staged Field where evolve field = label "Field" $ do fi <- link (fName field) fd <- link (fDescriptor field) - fattr <- fromCollector <$> fromAttributes FieldAttribute collect' (fAttributes field) - return $ Field (fAccessFlags' field) fi fd fattr - where - fromCollector (cv, sig, others) = - FieldAttributes (appEndo cv []) (appEndo sig []) (appEndo others []) - collect' attr = - collect (mempty, mempty, Endo(attr:)) attr - [ toC $ \x -> (Endo (x:), mempty, mempty) - , toC $ \x -> (mempty, Endo (x:), mempty) ] + label (Text.unpack . typeToText $ NameAndType fi fd) $ do + fattr <- fmap (`appEndo` emptyFieldAttributes) . fromAttributes FieldAttribute (fAttributes field) + $ collect + [ Attr (\e a -> a {faConstantValues = e : faConstantValues a }) + , Attr (\e a -> a {faSignatures = e : faSignatures a }) + , Attr (\e a -> a {faVisibleAnnotations = e : faVisibleAnnotations a }) + , Attr (\e a -> a {faInvisibleAnnotations = e : faInvisibleAnnotations a }) + , Attr (\e a -> a {faVisibleTypeAnnotations = e : faVisibleTypeAnnotations a }) + , Attr (\e a -> a {faInvisibleTypeAnnotations = e : faInvisibleTypeAnnotations a }) + ] (\e a -> a { faOthers = e : faOthers a }) + return $ Field (fAccessFlags' field) fi fd fattr devolve field = do fi <- unlink (fName field) @@ -81,11 +95,16 @@ return $ Field (fAccessFlags' field) fi fd (SizedList fattr) where - fromFieldAttributes (FieldAttributes cvs fsg attr) = - (\a b c -> a ++ b ++ c) - <$> mapM toAttribute cvs - <*> mapM toAttribute fsg - <*> mapM devolve attr + fromFieldAttributes (FieldAttributes {..}) = + concat <$> sequence + [ mapM toAttribute faConstantValues + , mapM toAttribute faSignatures + , mapM toAttribute faVisibleAnnotations + , mapM toAttribute faInvisibleAnnotations + , mapM toAttribute faVisibleTypeAnnotations + , mapM toAttribute faInvisibleTypeAnnotations + , mapM devolve faOthers + ] $(deriveBase ''FieldAttributes) $(deriveBaseWithBinary ''Field) 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 @@ -1,22 +1,24 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} {-| Module : Language.JVM.Method Copyright : (c) Christian Gram Kalhauge, 2017 License : MIT Maintainer : kalhuage@cs.ucla.edu -} - -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RecordWildCards #-} module Language.JVM.Method ( Method (..) , mAccessFlags -- * Attributes , MethodAttributes (..) + , emptyMethodAttributes , mCode , mExceptions' , mExceptions @@ -24,9 +26,13 @@ ) where -import Data.Maybe +-- base import Data.Monoid + +-- containers import Data.Set (Set) + +-- text import qualified Data.Text as Text import Language.JVM.AccessFlag @@ -51,12 +57,25 @@ mAccessFlags = toSet . mAccessFlags' data MethodAttributes r = MethodAttributes - { maCode :: [Code r] - , maExceptions :: [Exceptions r] - , maSignatures :: [Signature r] - , maOthers :: [Attribute r] + { maCode :: [Code r] + , maExceptions :: [Exceptions r] + , maSignatures :: [Signature r] + , maAnnotationDefault :: [AnnotationDefault r] + , maVisibleAnnotations :: [RuntimeVisibleAnnotations r] + , maInvisibleAnnotations :: [RuntimeInvisibleAnnotations r] + , maVisibleParameterAnnotations :: [RuntimeVisibleParameterAnnotations r] + , maInvisibleParamterAnnotations :: [RuntimeInvisibleParameterAnnotations r] + , maVisibleTypeAnnotations :: + [RuntimeVisibleTypeAnnotations MethodTypeAnnotation r] + , maInvisibleTypeAnnotations :: + [RuntimeInvisibleTypeAnnotations MethodTypeAnnotation r] + , maOthers :: [Attribute r] } +emptyMethodAttributes :: MethodAttributes High +emptyMethodAttributes = + MethodAttributes [] [] [] [] [] [] [] [] [] [] [] + -- | Fetch the 'Code' attribute, if any. -- There can only be one code attribute in a method. mCode :: Method High -> Maybe (Code High) @@ -73,7 +92,7 @@ -- If no exceptions field where found the empty list is returned mExceptions :: Method High -> [ClassName] mExceptions = - fromMaybe [] . fmap (unSizedList . exceptions) . mExceptions' + maybe [] (unSizedList . exceptions) . mExceptions' -- | Fetches the 'Signature' attribute, if any. mSignature :: Method High -> Maybe (Signature High) @@ -81,34 +100,46 @@ firstOne . maSignatures . mAttributes instance Staged Method where - evolve (Method mf mn md mattr) = do + evolve (Method mf mn md mattr) = label "Method" $ do mn' <- link mn md' <- link md - mattr' <- label (Text.unpack.typeToText $ NameAndType mn' md') - $ fromCollector <$> fromAttributes MethodAttribute collect' mattr - return $ Method mf mn' md' mattr' - where - fromCollector (a, b, c, d) = - MethodAttributes (appEndo a []) (appEndo b []) (appEndo c []) (appEndo d []) - collect' attr = - collect (mempty, mempty, mempty, Endo (attr:)) attr - [ toC $ \e -> (Endo (e:), mempty, mempty, mempty) - , toC $ \e -> (mempty, Endo (e:), mempty, mempty) - , toC $ \e -> (mempty, mempty, Endo (e:), mempty) + label (Text.unpack.typeToText $ NameAndType 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 }) + return $ Method mf mn' md' mattr' devolve (Method mf mn md mattr) = do mn' <- unlink mn md' <- unlink md - mattr' <- fromMethodAttributes $ mattr + mattr' <- fromMethodAttributes mattr return $ Method mf mn' md' (SizedList mattr') where - fromMethodAttributes (MethodAttributes a b c d) = do - a' <- mapM toAttribute a - b' <- mapM toAttribute b - c' <- mapM toAttribute c - d' <- mapM devolve d - return (a' ++ b' ++ c' ++ d') + 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 + ] $(deriveBase ''MethodAttributes) $(deriveBaseWithBinary ''Method) 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,7 +1,8 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-| Module : Language.JVM.Type Copyright : (c) Christian Gram Kalhauge, 2018 @@ -29,6 +30,7 @@ -- ** MethodDescriptor , MethodDescriptor (..) + , ReturnDescriptor -- ** FieldDescriptor , FieldDescriptor (..) @@ -68,7 +70,6 @@ import qualified Data.Text.Lazy as Lazy import qualified Data.Text.Lazy.Builder as Builder - -- | A class name newtype ClassName = ClassName { classNameAsText :: Text.Text @@ -106,7 +107,7 @@ -- | The number of nested arrays refTypeDepth :: JRefType -> Int refTypeDepth = \case - JTArray (JTRef a) -> 1 + (refTypeDepth a) + JTArray (JTRef a) -> 1 + refTypeDepth a JTArray _ -> 1 JTClass _ -> 0 @@ -115,23 +116,26 @@ | JTRef JRefType deriving (Show, Eq, Ord, Generic, NFData) - -- | Get the corresponding `Char` of a `JBaseType` jBaseTypeToChar :: JBaseType -> Char jBaseTypeToChar = \case - JTByte -> 'B' - JTChar -> 'C' - JTDouble -> 'D' - JTFloat -> 'F' - JTInt -> 'I' - JTLong -> 'J' - JTShort -> 'S' - JTBoolean -> 'Z' + JTByte -> 'B' + JTChar -> 'C' + JTDouble -> 'D' + JTFloat -> 'F' + JTInt -> 'I' + JTLong -> 'J' + JTShort -> 'S' + JTBoolean -> 'Z' +-- | 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 + -- | Method Descriptor data MethodDescriptor = MethodDescriptor { methodDescriptorArguments :: [JType] - , methodDescriptorReturnType :: Maybe JType + , methodDescriptorReturnType :: ReturnDescriptor } deriving (Show, Ord, Eq, Generic, NFData) -- | Field Descriptor @@ -168,22 +172,21 @@ typeToBuilder = Builder.fromText . classNameAsText instance TypeParse JBaseType where - parseType = try . ( "BaseType") $ do - 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 + 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 instance TypeParse JRefType where - parseType = try . ( "RefType") $ do + parseType = try . ( "RefType") $ anyChar >>= \case 'L' -> do txt <- takeWhile (/= ';') @@ -195,10 +198,10 @@ typeToBuilder = \case JTClass cn -> Builder.singleton 'L' <> typeToBuilder cn <> Builder.singleton ';' - JTArray t -> do + JTArray t -> Builder.singleton '[' <> typeToBuilder t -parseFlatJRefType :: Parser (JRefType) +parseFlatJRefType :: Parser JRefType parseFlatJRefType = JTArray <$> (char '[' *> parseType) <|> JTClass <$> parseType @@ -206,7 +209,8 @@ jRefTypeToFlatText :: JRefType -> Text.Text jRefTypeToFlatText = \case JTClass t' -> classNameAsText t' - JTArray t' -> Lazy.toStrict . Builder.toLazyText $ Builder.singleton '[' <> typeToBuilder t' + JTArray t' -> Lazy.toStrict . Builder.toLazyText + $ Builder.singleton '[' <> typeToBuilder t' instance TypeParse JType where parseType = @@ -217,35 +221,36 @@ JTRef r -> typeToBuilder r JTBase r -> typeToBuilder r +instance TypeParse ReturnDescriptor where + typeToBuilder = maybe (Builder.singleton 'V') typeToBuilder + parseType = choice + [ char 'V' >> return Nothing + , Just <$> parseType + ] "return type" + instance TypeParse MethodDescriptor where typeToBuilder md = execWriter $ do tell $ Builder.singleton '(' mapM_ (tell . typeToBuilder) (methodDescriptorArguments md) tell $ Builder.singleton ')' - tell . maybe (Builder.singleton 'V') typeToBuilder $ methodDescriptorReturnType md + tell . typeToBuilder $ methodDescriptorReturnType md parseType = do _ <- char '(' args <- many' parseType "method arguments" _ <- char ')' - returnType <- choice - [ char 'V' >> return Nothing - , Just <$> parseType - ] "return type" - return $ MethodDescriptor args returnType + MethodDescriptor args <$> parseType instance TypeParse FieldDescriptor where parseType = FieldDescriptor <$> parseType typeToBuilder (FieldDescriptor t) = typeToBuilder t instance TypeParse t => TypeParse (NameAndType t) where - parseType = do name <- many1 $ notChar ':' _ <- char ':' - _type <- parseType - return $ NameAndType (Text.pack name) _type + NameAndType (Text.pack name) <$> parseType typeToBuilder (NameAndType name _type) = Builder.fromText name diff --git a/src/Language/JVM/Utils.hs b/src/Language/JVM/Utils.hs --- a/src/Language/JVM/Utils.hs +++ b/src/Language/JVM/Utils.hs @@ -23,6 +23,7 @@ , byteStringSize -- ** Specific sizes + , SizedList8 , SizedList16 , SizedByteString32 , SizedByteString16 @@ -45,22 +46,29 @@ , trd ) where +-- binary import Data.Binary -import Data.Binary.Get +import Data.Binary.Get as Get import Data.Binary.Put + +-- base import Data.Bits import Data.List as List -import Data.Set as Set import Data.String +import Control.Monad +-- containers +import Data.Set as Set + +-- nfdata import Control.DeepSeq (NFData) -import Control.Monad +-- text import qualified Data.Text as Text - import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding.Error as TE +-- bytestring import qualified Data.ByteString as BS -- import Debug.Trace @@ -93,11 +101,14 @@ instance (Binary w, Integral w, Binary a) => Binary (SizedList w a) where get = do len <- get :: Get w - SizedList <$> replicateM (fromIntegral len) get + Get.label ("SizedList[" ++ show (fromIntegral len :: Int) ++ "]") $ + SizedList <$> replicateM (fromIntegral len) get + {-# INLINE get #-} put sl@(SizedList l) = do put (listSize sl) forM_ l put + {-# INLINE put #-} -- | A byte string with a size w. newtype SizedByteString w = SizedByteString @@ -191,6 +202,9 @@ return . BitSet $ Set.fromList [ x | (i, x) <- inOrder, testBit word i ] put = put . bitSetToWord + +-- | A sized list using a 8 bit word as length +type SizedList8 = SizedList Word8 -- | A sized list using a 16 bit word as length type SizedList16 = SizedList Word16 diff --git a/test/Language/JVM/Attribute/AnnotationsSpec.hs b/test/Language/JVM/Attribute/AnnotationsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/JVM/Attribute/AnnotationsSpec.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE FlexibleInstances #-} +-- | +module Language.JVM.Attribute.AnnotationsSpec where + +import SpecHelper + +import Language.JVM.ConstantSpec () +import Language.JVM +import Language.JVM.Attribute.Annotations + +spec :: Spec +spec = + prop "annotation can do a roundtrip" prop_roundtrip_Annotations + +prop_roundtrip_Annotations :: Annotation High -> Property +prop_roundtrip_Annotations = isoRoundtrip + +instance Arbitrary (Annotation High) where + arbitrary = genericArbitraryU + +instance Arbitrary (ValuePair High) where + arbitrary = genericArbitraryU + +instance Arbitrary (ElementValue High) where + arbitrary = oneof + [ EByte <$> arbitrary + , EChar <$> arbitrary + , EDouble <$> arbitrary + , EFloat <$> arbitrary + , EInt <$> arbitrary + , ELong <$> arbitrary + , EShort <$> arbitrary + , EString <$> arbitrary + + , EEnum <$> arbitrary + , EClass <$> arbitrary + ] + +instance Arbitrary (EnumValue High) where + arbitrary = genericArbitraryU + + +-- instance Arbitrary (BootstrapMethod High) where +-- arbitrary = +-- BootstrapMethod <$> arbitrary <*> (SizedList <$> pure []) 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 @@ -20,12 +20,11 @@ import Language.JVM import Language.JVM.Attribute.Code - spec :: Spec spec = do - it "can do a roundtrip on Code" $ property $ prop_roundtrip_Code - it "can do a roundtrip on ExceptionTable" $ property $ prop_roundtrip_ExceptionTable - it "can do a roundtrip on ByteCodeInst" $ property $ prop_roundtrip_ByteCodeInst + prop "can do a roundtrip on Code" prop_roundtrip_Code + prop "can do a roundtrip on ExceptionTable" prop_roundtrip_ExceptionTable + prop "can do a roundtrip on ByteCodeInst" prop_roundtrip_ByteCodeInst spec_ByteCode_examples prop_roundtrip_Code :: Code High -> Property @@ -59,22 +58,22 @@ <*> arbitrary <*> pure bc <*> (SizedList <$> listOf (genExceptionTable (fromIntegral . V.length . byteCodeInstructions $ bc))) - <*> pure (CodeAttributes [] [] []) + <*> pure emptyCodeAttributes genExceptionTable :: Int -> Gen (ExceptionTable High) genExceptionTable i = ExceptionTable - <$> (arbitraryRef i) - <*> (arbitraryRef i) - <*> (arbitraryRef i) + <$> arbitraryRef i + <*> arbitraryRef i + <*> arbitraryRef i <*> arbitrary arbitraryRef :: Int -> Gen Int arbitraryRef i = choose (0, i - 1) -instance Arbitrary (CodeAttributes High) where - arbitrary = genericArbitraryU +-- instance Arbitrary (CodeAttributes High) where +-- arbitrary = genericArbitraryU instance Arbitrary (ExceptionTable High) where arbitrary = diff --git a/test/Language/JVM/ClassFileSpec.hs b/test/Language/JVM/ClassFileSpec.hs --- a/test/Language/JVM/ClassFileSpec.hs +++ b/test/Language/JVM/ClassFileSpec.hs @@ -17,13 +17,13 @@ spec :: Spec spec = - it "can do a roundtrip" $ property $ prop_roundtrip_ClassFile + prop "can do a roundtrip" prop_roundtrip_ClassFile prop_roundtrip_ClassFile :: ClassFile High -> Property prop_roundtrip_ClassFile = isoRoundtrip instance Arbitrary (ClassAttributes High) where - arbitrary = pure $ ClassAttributes [] [] [] [] [] + arbitrary = pure emptyClassAttributes instance Arbitrary (ClassFile High) where arbitrary = ClassFile diff --git a/test/Language/JVM/FieldSpec.hs b/test/Language/JVM/FieldSpec.hs --- a/test/Language/JVM/FieldSpec.hs +++ b/test/Language/JVM/FieldSpec.hs @@ -8,19 +8,19 @@ import Language.JVM.ConstantSpec () import Language.JVM.AttributeSpec () import Language.JVM.Attribute.ConstantValueSpec () +import Language.JVM.Attribute.AnnotationsSpec () import Language.JVM spec :: Spec spec = - it "can do a roundtrip" $ property $ prop_roundtrip_Field + prop "can do a roundtrip" prop_roundtrip_Field prop_roundtrip_Field :: Field High -> Property prop_roundtrip_Field = isoRoundtrip instance Arbitrary (FieldAttributes High) where - arbitrary = - FieldAttributes <$> arbitrary <*> pure [] <*> pure [] + arbitrary = (\a -> emptyFieldAttributes { faConstantValues = a }) <$> arbitrary instance Arbitrary (Field High) where arbitrary = Field diff --git a/test/Language/JVM/MethodSpec.hs b/test/Language/JVM/MethodSpec.hs --- a/test/Language/JVM/MethodSpec.hs +++ b/test/Language/JVM/MethodSpec.hs @@ -1,6 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-} module Language.JVM.MethodSpec where import SpecHelper @@ -15,16 +16,16 @@ spec :: Spec spec = - it "can do a roundtrip" $ property $ prop_roundtrip_Method + prop "can do a roundtrip" prop_roundtrip_Method prop_roundtrip_Method :: Method High -> Property prop_roundtrip_Method = isoRoundtrip instance Arbitrary (MethodAttributes High) where arbitrary = - MethodAttributes <$> pure [] <*> arbitrary <*> pure [] <*> pure [] - shrink (MethodAttributes a b c d ) = - MethodAttributes <$> shrink a <*> shrink b <*> pure c <*> pure d + (\a -> emptyMethodAttributes { maExceptions = a }) <$> arbitrary + shrink a@MethodAttributes {..} = + (\e -> a { maExceptions = e }) <$> shrink maExceptions instance Arbitrary (Method High) where arbitrary =