packages feed

jvm-binary 0.8.0 → 0.9.0

raw patch · 38 files changed

+2050/−1200 lines, 38 filesdep +doctestbinary-added

Dependencies added: doctest

Files

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

binary file changed (absent → 338 bytes)

+ test/data/project/Main.class view

binary file changed (absent → 940 bytes)

+ test/data/project/Main.java view
@@ -0,0 +1,37 @@++public class Main implements Runnable {++    private int someAttr = 2;+    private double someOtherAttr = 4.0;++    public static void main (String [] argv) { +        System.out.println("Hello, World!");+    }++    public int addOne() {+        someAttr = someAttr + 1;+        return someAttr;+    }++    public int aComplexExample(int a ) {+      // This should produce a tableswitch+      switch (a) {+      case 0: return 2;+      case 1: return 1;+      case 2: return 0;+      default:+        System.out.println("Reached Table Default");+      }+      // This should produce a LookupSwitch+      switch (a) {+      case 0: return 2;+      case 23232: return 0;+      case 23232233: return 1;+      default:+        System.out.println("Reached Lookup Default");+      }+      return a;+    }++    public void run () { }+}