jvm-binary 0.5.0 → 0.6.0
raw patch · 18 files changed
+1171/−232 lines, 18 files
Files
- CHANGELOG.md +3/−0
- jvm-binary.cabal +4/−2
- package.yaml +1/−1
- src/Language/JVM/Attribute.hs +25/−0
- src/Language/JVM/Attribute/Annotations.hs +683/−0
- src/Language/JVM/Attribute/Base.hs +75/−32
- src/Language/JVM/Attribute/Code.hs +26/−16
- src/Language/JVM/ClassFile.hs +43/−25
- src/Language/JVM/Constant.hs +78/−37
- src/Language/JVM/Field.hs +42/−23
- src/Language/JVM/Method.hs +63/−32
- src/Language/JVM/Type.hs +45/−40
- src/Language/JVM/Utils.hs +19/−5
- test/Language/JVM/Attribute/AnnotationsSpec.hs +45/−0
- test/Language/JVM/Attribute/CodeSpec.hs +9/−10
- test/Language/JVM/ClassFileSpec.hs +2/−2
- test/Language/JVM/FieldSpec.hs +3/−3
- test/Language/JVM/MethodSpec.hs +5/−4
CHANGELOG.md view
@@ -1,5 +1,8 @@ # Change log +## Version 0.6.0+- Add Annotations+ ## Version 0.5.0 - Reintroduce AbsVariableMethodId - Small cleanups
jvm-binary.cabal view
@@ -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
package.yaml view
@@ -1,5 +1,5 @@ name: jvm-binary-version: '0.5.0'+version: '0.6.0' author: Christian Gram Kalhauge maintainer: Christian Gram Kalhauge <kalhauge@cs.ucla.edu> synopsis: A library for reading Java class-files
src/Language/JVM/Attribute.hs view
@@ -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+ )
+ src/Language/JVM/Attribute/Annotations.hs view
@@ -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)
src/Language/JVM/Attribute/Base.hs view
@@ -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 =
src/Language/JVM/Attribute/Code.hs view
@@ -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
src/Language/JVM/ClassFile.hs view
@@ -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)
src/Language/JVM/Constant.hs view
@@ -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 #-}
src/Language/JVM/Field.hs view
@@ -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)
src/Language/JVM/Method.hs view
@@ -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)
src/Language/JVM/Type.hs view
@@ -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
src/Language/JVM/Utils.hs view
@@ -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
+ test/Language/JVM/Attribute/AnnotationsSpec.hs view
@@ -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 [])
test/Language/JVM/Attribute/CodeSpec.hs view
@@ -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 =
test/Language/JVM/ClassFileSpec.hs view
@@ -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
test/Language/JVM/FieldSpec.hs view
@@ -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
test/Language/JVM/MethodSpec.hs view
@@ -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 =