jvm-binary 0.1.0 → 0.2.0

raw patch · 27 files changed

+1015/−204 lines, 27 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−0
• LICENSE.md +1/−1
• benchmark/Main.hs +5/−3
• jvm-binary.cabal +10/−7
• package.yaml +2/−2
• src/Language/JVM/AccessFlag.hs +35/−0
• src/Language/JVM/Attribute/Base.hs +13/−6
• src/Language/JVM/Attribute/Code.hs +1/−1
• src/Language/JVM/Attribute/EnclosingMethod.hs +49/−0
• src/Language/JVM/Attribute/InnerClasses.hs +71/−0
• src/Language/JVM/Attribute/Signature.hs +313/−40
• src/Language/JVM/ByteCode.hs +48/−40
• src/Language/JVM/ClassFile.hs +34/−11
• src/Language/JVM/ClassFileReader.hs +56/−31
• src/Language/JVM/ConstantPool.hs +1/−0
• src/Language/JVM/Field.hs +1/−1
• src/Language/JVM/Method.hs +1/−1
• src/Language/JVM/Staged.hs +14/−0
• src/Language/JVM/Type.hs +40/−29
• stack.yaml +1/−1
• test/Language/JVM/Attribute/EnclosingMethodTest.hs +39/−0
• test/Language/JVM/Attribute/InnerClassesTest.hs +64/−0
• test/Language/JVM/Attribute/SignatureTest.hs +171/−4
• test/Language/JVM/ClassFileTest.hs +1/−1
• test/Language/JVM/TypeTest.hs +20/−18
• test/Language/JVMTest.hs +4/−4
• test/SpecHelper.hs +8/−3

@@ -1,5 +1,17 @@ # Change log +## Version 0.2.0++- Add filter to evolveClassFile++## Version 0.1.1++- Add EnclosingMethod Attribute+- Add InnerClasses Attribute+- Add ICAccessFlag +- Add parseing and writing of Signatures+- General optimizations+ ## Version 0.1.0   - Fix documentation

@@ -1,6 +1,6 @@ [The MIT License (MIT)][] -Copyright (c) 2017 Christian Gram Kalhauge+Copyright (c) 2017-2018 Christian Gram Kalhauge  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in

@@ -36,8 +36,10 @@ evolvebm fp =   env (decodeClassFile' fp)$ \clf ->     bgroup ("evolve " ++ fp)-    [ bench "strict"-        (nf evolveClassFile clf)+    [ bench "filter false"+        (nf (evolveClassFile (const False)) clf)+    , bench "filter true"+        (nf (evolveClassFile (const True)) clf)     ]  devolvebm :: FilePath -> Benchmark@@ -62,4 +64,4 @@ ex1 = "test/data/project/Main.class"  ex2 :: String-ex2 = "test/data/java/util/zip/ZipOutputStream.class"+ex2 = "test/data/SQLite.class"

@@ -1,11 +1,11 @@--- This file has been generated from package.yaml by hpack version 0.20.0.+-- This file has been generated from package.yaml by hpack version 0.28.2. -- -- see: https://github.com/sol/hpack ----- hash: 097c125068d4157309ad1e355ed38e1c038f019d7b88ee213afb43df08ad7784+-- hash: 096c3cb1a26134c8a5bb271a50589aea060f4b5891e16c3f03102d2b1fb02660  name:           jvm-binary-version:        0.1.0+version:        0.2.0 synopsis:       A library for reading Java class-files description:    A library for reading Java class-files. category:       Language, Java, JVM@@ -17,7 +17,6 @@ license-file:   LICENSE.md build-type:     Simple cabal-version:  >= 1.10- extra-source-files:     CHANGELOG.md     LICENSE.md@@ -35,7 +34,7 @@   ghc-options: -Wall   build-depends:       attoparsec-    , base >=4.9 && <4.11+    , base >=4.9 && <4.12     , binary     , bytestring     , containers@@ -54,7 +53,9 @@       Language.JVM.Attribute.BootstrapMethods       Language.JVM.Attribute.Code       Language.JVM.Attribute.ConstantValue+      Language.JVM.Attribute.EnclosingMethod       Language.JVM.Attribute.Exceptions+      Language.JVM.Attribute.InnerClasses       Language.JVM.Attribute.LineNumberTable       Language.JVM.Attribute.Signature       Language.JVM.Attribute.StackMapTable@@ -83,7 +84,7 @@   build-depends:       QuickCheck     , attoparsec-    , base >=4.9 && <4.11+    , base >=4.9 && <4.12     , binary     , bytestring     , containers@@ -107,7 +108,9 @@       Language.JVM.Attribute.BootstrapMethodsTest       Language.JVM.Attribute.CodeTest       Language.JVM.Attribute.ConstantValueTest+      Language.JVM.Attribute.EnclosingMethodTest       Language.JVM.Attribute.ExceptionsTest+      Language.JVM.Attribute.InnerClassesTest       Language.JVM.Attribute.LineNumberTableTest       Language.JVM.Attribute.SignatureTest       Language.JVM.Attribute.StackMapTableTest@@ -131,7 +134,7 @@   ghc-options: -rtsopts -threaded -funbox-strict-fields -with-rtsopts=-N   build-depends:       attoparsec-    , base >=4.9 && <4.11+    , base >=4.9 && <4.12     , binary     , bytestring     , containers

@@ -1,5 +1,5 @@ name: jvm-binary-version: '0.1.0'+version: '0.2.0' author: Christian Gram Kalhauge maintainer: Christian Gram Kalhauge <kalhauge@cs.ucla.edu> synopsis: A library for reading Java class-files@@ -19,7 +19,7 @@ - stack.yaml  dependencies:-- base >= 4.9 && < 4.11+- base >= 4.9 && < 4.12 - binary - bytestring - containers

@@ -12,6 +12,7 @@   ( MAccessFlag(..), mflags   , FAccessFlag(..), fflags   , CAccessFlag(..), cflags+  , ICAccessFlag(..), icflags   ) where  import           Language.JVM.Utils@@ -84,6 +85,40 @@  instance Enumish CAccessFlag where   inOrder = cflags+++-- | Access flags for the 'Language.JVM.Attribute.InnerClass'+data ICAccessFlag+  = ICPublic+  | ICPrivate+  | ICProtected+  | ICStatic+  | ICFinal+  | ICInterface+  | ICAbstract+  | ICSynthetic+  | ICAnnotation+  | ICEnum+  deriving (Ord, Show, Eq, NFData, Generic)++-- | The 'Enumish' mapping of the 'CAccessFlag'+icflags :: [(Int, ICAccessFlag)]+icflags =+  [ (0, ICPublic)+  , (1, ICPrivate)+  , (2, ICProtected)+  , (3, ICStatic)+  , (4, ICFinal)+  , (9, ICInterface)+  , (10, ICAbstract)+  , (12, ICSynthetic)+  , (13, ICAnnotation)+  , (14, ICEnum)+  ]++instance Enumish ICAccessFlag where+  inOrder = icflags+  -- | Access flags for the 'Language.JVM.Field.Field' data FAccessFlag

@@ -144,16 +144,23 @@ -- monoid given an 'Attribute' calculate the monoid over all attributes. fromAttributes ::   (Foldable f, EvolveM m, Monoid a)-  => (Attribute High -> m a)+  => AttributeLocation+  -> (Attribute High -> m a)   -> f (Attribute Low)   -> m a-fromAttributes f attrs =-  Prelude.foldl g (return mempty) attrs+fromAttributes al f attrs = do+  afilter <- attributeFilter+  Prelude.foldl (g afilter) (return mempty) attrs   where-    g m a' = do+    g afilter m a' = do       b <- m-      x <- f =<< evolve a'-      return $ b `mappend` x+      ah <- evolve a'+      if afilter (al, aName ah)+        then do+          x <- f ah+          return $ b `mappend` x+      else do+        return b  readFromStrict :: Binary a => Attribute r -> Either String a readFromStrict =

@@ -86,7 +86,7 @@     (offsets, codeByteCode) <- evolveByteCode codeByteCode     let evolver = (evolveOffset offsets)     codeExceptionTable <- mapM (evolveBC evolver) codeExceptionTable-    codeAttributes <- fromCollector <$> fromAttributes (collect' evolver) codeAttributes+    codeAttributes <- fromCollector <$> fromAttributes CodeAttribute (collect' evolver) codeAttributes     return $ Code {..}     where       fromCollector (a, b, c) =

@@ -0,0 +1,49 @@+{-# LANGUAGE DeriveAnyClass     #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell    #-}+{-|+Module      : Language.JVM.Attribute.EnclosingMethod+Copyright   : (c) Christian Gram Kalhauge, 2018+License     : MIT+Maintainer  : kalhuage@cs.ucla.edu++Based on the EnclosingMethod Attribute,+as documented [here](http://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.7).+-}++module Language.JVM.Attribute.EnclosingMethod+  ( EnclosingMethod (..)+  ) where++import           Language.JVM.Attribute.Base+import           Language.JVM.Constant+import           Language.JVM.Staged++-- | 'EnclosingMethod' is an Attribute.+instance IsAttribute (EnclosingMethod Low) where+  attrName = Const "EnclosingMethod"++-- | The 'EnclosingMethod' is a reference to the enclosing method of the class+data EnclosingMethod r = EnclosingMethod+  { enclosingClassName :: !(Ref ClassName r)+  , enclosingMethodName :: !(Ref (Maybe MethodId) r)+  }+++instance Staged EnclosingMethod where+  evolve (EnclosingMethod cn mn) = label "EnclosingMethod" $ do+    EnclosingMethod+      <$> link cn+      <*> if mn == 0 then return Nothing else Just <$> link mn++  devolve (EnclosingMethod cn mn) = label "EnclosingMethod" $ do+    EnclosingMethod+      <$> unlink cn+      <*> case mn of+            Nothing -> return 0+            Just mn' -> unlink mn'++$(deriveBaseWithBinary ''EnclosingMethod)

@@ -0,0 +1,71 @@+{-# LANGUAGE DeriveAnyClass     #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell    #-}+{-|+Module      : Language.JVM.Attribute.InnerClasses+Copyright   : (c) Christian Gram Kalhauge, 2018+License     : MIT+Maintainer  : kalhuage@cs.ucla.edu++Based on the InnerClasses Attribute,+as documented [here](http://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.6).+-}++module Language.JVM.Attribute.InnerClasses+  ( InnerClasses (..)+  , InnerClass (..)+  ) where+++import qualified Data.Text as Text++import           Language.JVM.Attribute.Base+import           Language.JVM.Constant+import           Language.JVM.Utils+import           Language.JVM.Staged+import           Language.JVM.AccessFlag++-- | 'InnerClasses' is an Attribute.+instance IsAttribute (InnerClasses Low) where+  attrName = Const "InnerClasses"++-- | The 'InnerClasses' is a reference to the enclosing method of the class+newtype InnerClasses r = InnerClasses+  { innerClasses :: Choice (SizedList16 (InnerClass Low)) [InnerClass High] r+  }++data InnerClass r = InnerClass+  { icClassName :: !(Ref ClassName r)+  , icOuterClassName :: !(Ref (Maybe ClassName) r)+  , icInnerName :: !(Ref (Maybe Text.Text) r)+  , icInnerAccessFlags :: !(BitSet16 ICAccessFlag)+  }++instance Staged InnerClasses where+  evolve (InnerClasses (SizedList r)) = InnerClasses <$> mapM evolve r+  devolve (InnerClasses r) = InnerClasses . SizedList <$> mapM devolve r++instance Staged InnerClass where+  evolve (InnerClass cn ocn inn iac) = label "InnerClass" $ do+    InnerClass+      <$> link cn+      <*> (if ocn == 0 then return Nothing else Just <$> link ocn)+      <*> (if inn == 0 then return Nothing else Just <$> link inn)+      <*> pure iac++  devolve (InnerClass cn mn inn iac) = label "InnerClass" $ do+    InnerClass+      <$> unlink cn+      <*> case mn of+            Nothing -> return 0+            Just mn' -> unlink mn'+      <*> case inn of+            Nothing -> return 0+            Just inn' -> unlink inn'+      <*> pure iac++$(deriveBaseWithBinary ''InnerClasses)+$(deriveBaseWithBinary ''InnerClass)

@@ -19,17 +19,57 @@   ( Signature (..)   , signatureToText   , signatureFromText++  -- * Top Level Definitions++  , ClassSignature (..)+  , classSignatureToText+  , classSignatureFromText+  , classSignatureP+  , MethodSignature (..)+  , methodSignatureToText+  , methodSignatureFromText+  , methodSignatureP+  , FieldSignature (..)+  , fieldSignatureToText+  , fieldSignatureFromText+  , fieldSignatureP++  -- * Lower Level Definitions+  , ClassType (..)+  , classTypeP+  , ReferenceType (..)+  , referenceTypeP+  , ThrowsSignature (..)+  , TypeArgument (..)+  , TypeParameter (..)+  , TypeSignature (..)+  , TypeVariable (..)+  , typeVariableP+  , Wildcard (..)+  , typeParameterP+  , typeParametersP   ) where --- import           Control.DeepSeq             (NFData)+import           Control.DeepSeq             (NFData) -- import           Data.Binary -- import qualified Data.IntMap                 as IM import qualified Data.Text                   as Text--- import           GHC.Generics                (Generic)+-- import Data.Monoid++import Data.Text.Lazy.Builder as Text+import qualified Data.Text.Lazy as LText++import Data.Functor+import           GHC.Generics                (Generic) import           Language.JVM.Attribute.Base import           Language.JVM.Staged--- import           Language.JVM.Type+import           Language.JVM.Type +import qualified Data.List                   as L++import           Data.Attoparsec.Text+ instance IsAttribute (Signature Low) where   attrName = Const "Signature" @@ -42,50 +82,283 @@ signatureFromText :: Text.Text -> Signature High signatureFromText s = Signature s --- data ClassSignature = ClassSignature---   { csTypeParameters :: [TypeParameter]---   , csSuperclassSignature :: ClassTypeSignature---   , csInterfaceSignatures :: [ClassTypeSignature]---   } --- data TypeParameter =---   TypeParameter---   { tpIndentifier :: Text.Text---   , tpClassBound :: Maybe ClassName---   , tpInterfaceBound :: [ClassName]---   }+----------------------+-- Parsing+---------------------- --- data ClassTypeSignature---   = ClassTypeSignature---     { ctsClassName :: ClassName---     , ctsTypeArguments :: [TypeArgument]---     }---   | InnerClassTypeSignature---     { ctsInnerClassName :: Text.Text---     , ctsTypeArguments :: [TypeArgument]---     }+data ClassSignature = ClassSignature+  { csTypeParameters      :: [TypeParameter]+  , csSuperclassSignature :: ClassType+  , csInterfaceSignatures :: [ClassType]+  }+  deriving (Show, Eq, Generic, NFData) --- data TypeArgument---   = AnyTypeArgument---   | TypeArgument---     { taWildcard :: Maybe Wildcard---     , taType :: ReferenceType---     }+classSignatureP :: Parser ClassSignature+classSignatureP = do+  tp <- option [] typeParametersP+  ss <- classTypeP+  is <- many' classTypeP+  return $ ClassSignature tp ss is --- data ReferenceType---   = RTClassType ClassTypeSignature---   | RTTypeVariable TypeVariableSignature---   | RTArrayType JavaTypeSignature+classSignatureToText :: ClassSignature -> Text.Text+classSignatureToText =+  LText.toStrict . toLazyText . classSignatureT --- newtype TypeVariableSignature---   = TypeVariableSignature Text.Text+classSignatureFromText :: Text.Text -> Either String ClassSignature+classSignatureFromText =+  parseOnly classSignatureP --- data JavaTypeSignature---   = ReferenceType ReferenceType---   | BaseType JBaseType+classSignatureT :: ClassSignature -> Builder+classSignatureT (ClassSignature tp ct its)= do+  typeParametersT tp <> foldMap classTypeT (ct:its) --- data Wildcard =---   WPlus | WMinus+data TypeSignature+  = ReferenceType ReferenceType+  | BaseType JBaseType+  deriving (Show, Eq, Generic, NFData)++typeSignatureP :: Parser TypeSignature+typeSignatureP = do+  choice [ (ReferenceType <$> referenceTypeP) <?> "JRefereceType"+         , (BaseType <$> jBaseTypeP) <?> "JBaseType" ]++typeSignatureT :: TypeSignature -> Builder+typeSignatureT (ReferenceType t) = referenceTypeT t+typeSignatureT (BaseType t) = singleton (jBaseTypeToChar t)++data ReferenceType+  = RefClassType ClassType+  | RefTypeVariable TypeVariable+  | RefArrayType TypeSignature+  deriving (Show, Eq, Generic, NFData)++referenceTypeP :: Parser ReferenceType+referenceTypeP = do+  choice+    [ RefClassType <$> classTypeP+    , RefTypeVariable <$> typeVariableP+    , RefArrayType <$> (char '[' >> typeSignatureP)+    ]++referenceTypeT :: ReferenceType -> Builder+referenceTypeT t =+  case t of+    RefClassType ct -> classTypeT ct+    RefTypeVariable tv -> typeVariableT tv+    RefArrayType at -> singleton '[' <> typeSignatureT at++data ClassType+  = ClassType+    { ctsClassName     :: ClassName+    , ctsTypeArguments :: [Maybe TypeArgument]+    }+  | InnerClassType+    { ctsInnerClassName :: Text.Text+    , ctsOuterClassType :: ClassType+    , ctsTypeArguments  :: [Maybe TypeArgument]+    }+  deriving (Show, Eq, Generic, NFData)++classTypeP :: Parser ClassType+classTypeP = nameit "ClassType" $ do+  _ <- char 'L'+  cn <- (ClassName <$> takeWhile1 (notInClass ".;[<>:")) <?> "ClassName"+  ta <- option [] typeArgumentsP+  ict <- many' $ do+      _ <- char '.'+      i <- identifierP+      ta' <- option [] typeArgumentsP+      return (i, ta')+  _ <- char ';'+  return $ L.foldl' (\a (i,ta') -> InnerClassType i a ta') (ClassType cn ta) ict++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++data TypeArgument = TypeArgument+  { taWildcard :: Maybe Wildcard+  , taType     :: ReferenceType+  }+  deriving (Show, Eq, Generic, NFData)++typeArgumentsP :: Parser [ Maybe TypeArgument ]+typeArgumentsP = do+  _ <- char '<'+  tas <- many1' typeArgumentP+  _ <- char '>'+  return tas++typeArgumentP :: Parser (Maybe TypeArgument)+typeArgumentP = do+  choice [ Just+           <$> ( TypeArgument+                  <$> option Nothing (Just <$> wildcardP)+                  <*> referenceTypeP+               )+         , char '*' $> Nothing+         ] <?> "TypeArgument"++typeArgumentsT :: [ Maybe TypeArgument ] -> Builder+typeArgumentsT args = do+  if L.null args+    then mempty+    else singleton '<' <> foldMap typeArgumentT args <> singleton '>'++typeArgumentT :: Maybe TypeArgument -> Builder+typeArgumentT a = do+  case a of+    Nothing -> singleton '*'+    Just (TypeArgument w rt) ->+      (case w of+        Just WildMinus -> singleton '-'+        Just WildPlus -> singleton '+'+        Nothing -> mempty) <> referenceTypeT rt++data Wildcard =+  WildPlus | WildMinus+  deriving (Show, Eq, Generic, NFData)++wildcardP :: Parser Wildcard+wildcardP = choice [ char '+' $> WildPlus, char '-' $> WildMinus]++newtype TypeVariable =+  TypeVariable { tvAsText :: Text.Text }+  deriving (Show, Eq, Generic, NFData)++typeVariableP :: Parser TypeVariable+typeVariableP = do+  _ <- char 'T'+  t <- identifierP+  _ <- char ';'+  return $ TypeVariable t++typeVariableT :: TypeVariable -> Builder+typeVariableT (TypeVariable t)= do+  singleton 'T' <> Text.fromText t <> singleton ';'++data TypeParameter =+  TypeParameter+  { tpIndentifier    :: Text.Text+  , tpClassBound     :: Maybe ReferenceType+  , tpInterfaceBound :: [ReferenceType]+  }+  deriving (Show, Eq, Generic, NFData)++typeParametersP :: Parser [TypeParameter]+typeParametersP = nameit "TypeParameters" $ do+  _ <- char '<'+  tps <- many1' typeParameterP+  _ <- char '>'+  return tps++typeParametersT :: [ TypeParameter ] -> Builder+typeParametersT args = do+  if L.null args+    then mempty+    else singleton '<' <> foldMap typeParameterT args <> singleton '>'++typeParameterP :: Parser TypeParameter+typeParameterP = nameit "TypeParameter" $ do+  id_ <- identifierP+  _ <- char ':'+  cb <- option Nothing (Just <$> 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++nameit :: String -> Parser a -> Parser a+nameit str m = m <?> str++identifierP :: Parser Text.Text+identifierP =+  takeWhile1 (notInClass ".;[/<>:") <?> "Identifier"+++data MethodSignature = MethodSignature+  { msTypeParameters :: [TypeParameter]+  , msArguments      :: [TypeSignature]+  , msResults        :: Maybe TypeSignature+  , msThrows         :: [ ThrowsSignature ]+  }+  deriving (Show, Eq, Generic, NFData)++methodSignatureP :: Parser MethodSignature+methodSignatureP = do+  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++methodSignatureFromText :: Text.Text -> Either String MethodSignature+methodSignatureFromText =+  parseOnly methodSignatureP++fieldSignatureFromText :: Text.Text -> Either String FieldSignature+fieldSignatureFromText =+  parseOnly fieldSignatureP++methodSignatureT :: MethodSignature -> Builder+methodSignatureT (MethodSignature tp args res thrws)= do+  typeParametersT tp+    <> singleton '('+    <> foldMap typeSignatureT args+    <> singleton ')'+    <> (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]+++throwsSignatureT :: ThrowsSignature -> Builder+throwsSignatureT t =+  singleton '^'+    <> case t of+         ThrowsClass ct -> classTypeT ct+         ThrowsTypeVariable tt -> typeVariableT tt++++newtype FieldSignature =+  FieldSignature {fsRefType :: ReferenceType}+  deriving (Show, Eq, Generic, NFData)++fieldSignatureP :: Parser FieldSignature+fieldSignatureP =+  FieldSignature <$> referenceTypeP++fieldSignatureToText :: FieldSignature -> Text.Text+fieldSignatureToText =+  LText.toStrict . toLazyText . referenceTypeT . fsRefType  instance Staged Signature where   evolve (Signature a) =

@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -funbox-strict-fields #-} {-# LANGUAGE DeriveAnyClass     #-} {-# LANGUAGE DeriveGeneric      #-} {-# LANGUAGE FlexibleContexts   #-}@@ -81,7 +82,7 @@ import           Data.Binary.Put       hiding (Put) import qualified Data.ByteString.Lazy  as BL import           Data.Int-import qualified Data.IntMap           as IM+import qualified Data.IntMap.Strict           as IM import qualified Data.Vector           as V  import           Language.JVM.Constant@@ -179,8 +180,9 @@  evolveByteCode :: EvolveM m => ByteCode Low -> m (OffsetMap, ByteCode High) evolveByteCode bc@(ByteCode (_, v)) = do-  let om = offsetMap bc-  (om,) . ByteCode <$> V.mapM (fmap opcode . evolveByteCodeInst (evolveOffset om)) v+  let !om = offsetMap bc+  x <- V.mapM (fmap opcode . evolveByteCodeInst (evolveOffset om)) v+  return . (om,) . ByteCode $! x  devolveByteCode :: DevolveM m => ByteCode High -> m (ByteCode Low) devolveByteCode (ByteCode bc) = do@@ -239,11 +241,14 @@     TableSwitch i (SwitchTable l ofss) ->       label "TableSwitch" $ (TableSwitch i . SwitchTable l <$> V.mapM calcOffset ofss)     a                 -> return $ unsafeCoerce a-  return (ByteCodeInst ofs x)+  return $ seq x (ByteCodeInst ofs x)   where     calcOffset r =       g (fromIntegral $ fromIntegral ofs + r) +{-# INLINABLE evolveByteCodeInst #-}++ devolveByteCodeInst ::   DevolveM m   => (ByteCodeIndex -> m ByteCodeOffset)@@ -322,8 +327,10 @@     putLazyByteString bs  instance Binary (ByteCodeInst Low) where-  get =-    ByteCodeInst <$> (fromIntegral <$> bytesRead) <*> get+  get = do+    i <- (fromIntegral <$> bytesRead)+    x <- get+    return $! ByteCodeInst i x   put x =     putByteCode (offset x) $ opcode x @@ -350,17 +357,17 @@  data ExactArrayType r   = EABoolean | EAByte | EAChar | EAShort | EAInt | EALong-  | EAFloat | EADouble | EARef (Ref ClassName r)+  | EAFloat | EADouble | EARef !(Ref ClassName r)  data Invocation r-  = InvkSpecial (DeepRef AbsVariableMethodId r)+  = InvkSpecial !(DeepRef AbsVariableMethodId r)   -- ^ Variable since 52.0-  | InvkVirtual (DeepRef AbsMethodId r)-  | InvkStatic (DeepRef AbsVariableMethodId r)+  | InvkVirtual !(DeepRef AbsMethodId r)+  | InvkStatic !(DeepRef AbsVariableMethodId r)   -- ^ Variable since 52.0-  | InvkInterface Word8 (DeepRef AbsInterfaceMethodId r)+  | InvkInterface !Word8 !(DeepRef AbsInterfaceMethodId r)   -- ^ Should be a positive number-  | InvkDynamic (DeepRef InvokeDynamic r)+  | InvkDynamic !(DeepRef InvokeDynamic r)  data FieldAccess   = FldStatic@@ -372,7 +379,6 @@  type WordSize = OneOrTwo - evolveBConstant :: EvolveM m => BConstant Low -> m (BConstant High) evolveBConstant ccnst = do   x <- evolve ccnst@@ -511,80 +517,80 @@     len = fromIntegral . V.length $ switchOffsets st  data ByteCodeOpr r-  = ArrayLoad ArrayType+  = ArrayLoad !ArrayType   -- ^ aaload baload ...-  | ArrayStore ArrayType+  | ArrayStore !ArrayType   -- ^ aastore bastore ... -  | Push (BConstant r)+  | Push !(BConstant r) -  | Load LocalType LocalAddress+  | Load !LocalType !LocalAddress   -- ^ aload_0, bload_2, iload 5 ...-  | Store LocalType LocalAddress+  | Store !LocalType !LocalAddress   -- ^ aload, bload ... -  | BinaryOpr BinOpr ArithmeticType+  | BinaryOpr !BinOpr !ArithmeticType   -- ^ iadd ...-  | Neg ArithmeticType+  | Neg !ArithmeticType   -- ^ ineg ... -  | BitOpr BitOpr WordSize+  | BitOpr !BitOpr !WordSize   -- ^ Exclusively on int and long, identified by the word-size    | IncrLocal !LocalAddress !IncrementAmount   -- ^ Only works on ints, increment local #1, with #2 -  | Cast CastOpr+  | Cast !CastOpr   -- ^ Only valid on different types    | CompareLongs -  | CompareFloating Bool WordSize+  | CompareFloating !Bool !WordSize   -- ^ Compare two floating values, #1 indicates if greater-than, #2   -- is if float or double should be used. -  | If CmpOpr OneOrTwo (ShortRelativeRef r)+  | If !CmpOpr !OneOrTwo !(ShortRelativeRef r)   -- ^ compare with 0 if #2 is False, and two ints from the stack if   -- True. the last value is the offset -  | IfRef Bool OneOrTwo (ShortRelativeRef r)+  | IfRef !Bool !OneOrTwo !(ShortRelativeRef r)   -- ^ check if two objects are equal, or not equal. If #2 is True, compare   -- with null. -  | Goto (LongRelativeRef r)-  | Jsr (LongRelativeRef r)-  | Ret LocalAddress+  | Goto !(LongRelativeRef r)+  | Jsr !(LongRelativeRef r)+  | Ret !LocalAddress -  | TableSwitch Int32 (SwitchTable r)+  | TableSwitch !Int32 !(SwitchTable r)   -- ^ a table switch has 2 values a `default` and a `SwitchTable`-  | LookupSwitch Int32 (V.Vector (Int32, Int32))+  | LookupSwitch !Int32 (V.Vector (Int32, Int32))   -- ^ 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 !(DeepRef (InClass FieldId) r)+  | Put !FieldAccess !(DeepRef (InClass FieldId) r) -  | Invoke (Invocation r)+  | Invoke !(Invocation r) -  | New (Ref ClassName r)+  | New !(Ref ClassName r) -  | NewArray (ExactArrayType r)+  | NewArray !(ExactArrayType r)    | ArrayLength    | Throw -  | CheckCast (Ref ClassName r)-  | InstanceOf (Ref ClassName r)+  | CheckCast !(Ref ClassName r)+  | InstanceOf !(Ref ClassName r) -  | Monitor Bool+  | Monitor !Bool   -- ^ True => Enter, False => Exit    -- TODO: Fix this so that its more clear what it points to.-  | MultiNewArray (Ref ClassName r) Word8+  | MultiNewArray !(Ref ClassName r) !Word8   -- ^ Create a new multi array of #1 and with #2 dimensions   -- ^ This might point to an array type. -  | Return (Maybe LocalType)+  | Return !(Maybe LocalType)    | Nop @@ -926,6 +932,8 @@       0xc9 -> Jsr <$> getInt32be        _ -> fail $ "I do not know this bytecode '0x" ++ showHex cmd "'."++  {-# INLINABLE get#-}    put = putByteCode 0 

@@ -18,6 +18,8 @@   , cFields   , cMethods   , cSignature+  , cEnclosingMethod+  , cInnerClasses    -- * Attributes   , ClassAttributes (..)@@ -31,6 +33,8 @@ import           Language.JVM.AccessFlag import           Language.JVM.Attribute import           Language.JVM.Attribute.BootstrapMethods+import           Language.JVM.Attribute.EnclosingMethod+import           Language.JVM.Attribute.InnerClasses -- import           Language.JVM.Attribute.Signature import           Language.JVM.Constant import           Language.JVM.ConstantPool               as CP@@ -89,9 +93,23 @@ cSignature =   firstOne . caSignature . cAttributes +cEnclosingMethod :: ClassFile High -> Maybe (EnclosingMethod High)+cEnclosingMethod =+  firstOne . caEnclosingMethod . cAttributes++cInnerClasses' :: ClassFile High -> Maybe (InnerClasses High)+cInnerClasses' =+  firstOne . caInnerClasses . cAttributes++cInnerClasses :: ClassFile High -> [InnerClass High]+cInnerClasses =+  maybe [] innerClasses . cInnerClasses'+ data ClassAttributes r = ClassAttributes   { caBootstrapMethods :: [ BootstrapMethods r]   , caSignature        :: [ Signature r ]+  , caEnclosingMethod  :: [ EnclosingMethod r ]+  , caInnerClasses     :: [ InnerClasses r ]   , caOthers           :: [ Attribute r ]   } @@ -107,7 +125,7 @@     cii' <- mapM link $ cInterfaces cf     cf' <- mapM evolve $ cFields' cf     cm' <- mapM evolve $ cMethods' cf-    ca' <- fromCollector <$> fromAttributes collect' (cAttributes cf)+    ca' <- fromCollector <$> fromAttributes ClassAttribute collect' (cAttributes cf)     return $ cf       { cConstantPool = ()       , cThisClass = tci'@@ -118,12 +136,14 @@       , cAttributes         = ca'       }     where-      fromCollector (a, b, c) =-        ClassAttributes (appEndo a []) (appEndo b []) (appEndo c [])+      fromCollector = flip appEndo (ClassAttributes [] [] [] [] [])       collect' attr =-        collect (mempty, mempty, Endo (attr:)) attr-          [ toC $ \e -> (Endo (e:), mempty, mempty)-          , toC $ \e -> (mempty, Endo (e:), mempty)]+        collect (Endo (\ca -> ca {caOthers = attr: caOthers ca})) attr+          [ toC $ \e -> Endo (\ca -> ca {caSignature = e : caSignature ca})+          , toC $ \e -> Endo (\ca -> ca {caEnclosingMethod = e : caEnclosingMethod ca})+          , toC $ \e -> Endo (\ca -> ca {caBootstrapMethods = e : caBootstrapMethods ca})+          , toC $ \e -> Endo (\ca -> ca {caInnerClasses = e : caInnerClasses ca})+          ]    devolve cf = do     tci' <- unlink (cThisClass cf)@@ -147,11 +167,14 @@       , cAttributes         = SizedList ca'       }     where-      fromClassAttributes (ClassAttributes cm cs at) = do-        cm' <- mapM toAttribute cm-        cs' <- mapM toAttribute cs-        at' <- mapM devolve at-        return (cm' ++ cs' ++ at')+      fromClassAttributes (ClassAttributes cm cs cem cin at) = do+        concat <$> sequence+          [ mapM toAttribute cm+          , mapM toAttribute cs+          , mapM toAttribute cem+          , mapM toAttribute cin+          , mapM devolve at+          ]  $(deriveBase ''ClassAttributes) $(deriveBaseWithBinary ''ClassFile)

@@ -19,6 +19,7 @@   -- * Evolve   , Evolve   , ClassFileError+  , EvolveConfig (..)   , runEvolve   , bootstrapConstantPool @@ -30,16 +31,18 @@   , cpbEmpty   ) where -import           Control.DeepSeq           (NFData)+import           Control.DeepSeq (NFData) import           Control.Monad.Except import           Control.Monad.Reader import           Control.Monad.State-import qualified Data.ByteString.Lazy      as BL-import qualified Data.IntMap               as IM-import qualified Data.Map                  as Map-import           Data.Monoid import           Data.Binary-import           GHC.Generics              (Generic)+import qualified Data.ByteString.Lazy as BL+import qualified Data.IntMap as IM+import qualified Data.Map as Map+import qualified Data.List as List+import qualified Data.Text as Text+import           Data.Monoid+import           GHC.Generics (Generic)  import           Language.JVM.ClassFile import           Language.JVM.Constant@@ -66,11 +69,16 @@ encodeClassFile clf = do   encode clf --- | Changed the stage from Index to Deref-evolveClassFile :: ClassFile Low -> Either ClassFileError (ClassFile High)-evolveClassFile cf = do+-- | Evolve the class file to inline the references. A filter function is+-- provided to remove some attributes. This will sometimes give faster loading+-- times.+evolveClassFile ::+  ((AttributeLocation, Text.Text) -> Bool)+  -> ClassFile Low+  -> Either ClassFileError (ClassFile High)+evolveClassFile fn cf = do   cp <- bootstrapConstantPool (cConstantPool cf)-  runEvolve cp (evolve cf)+  runEvolve (EvolveConfig [] cp fn ) (evolve cf)  -- | Devolve a ClassFile from High to Low. This might make the 'ClassFile' contain -- invalid attributes, since we can't read all attributes. If this this is a problem@@ -89,12 +97,11 @@   let (cf', cpb) = runConstantPoolBuilder (devolve cf) (builderFromConstantPool cp) in   cf' { cConstantPool = cpbConstantPool cpb } - -- | Top level command that combines 'decode' and 'evolve'. readClassFile :: BL.ByteString -> Either ClassFileError (ClassFile High) readClassFile bs = do   clf <- decodeClassFile bs-  evolveClassFile clf+  evolveClassFile (const True) clf  -- | Top level command that combines 'devolve' and 'encode'. writeClassFile :: ClassFile High -> BL.ByteString@@ -123,31 +130,45 @@  instance NFData ClassFileError +data EvolveConfig =+  EvolveConfig+  { ecLabel :: [String]+  , ecConstantPool :: ConstantPool High+  , ecAttributeFilter :: ((AttributeLocation, Text.Text) -> Bool)+  }+ newtype Evolve a =-  Evolve (ReaderT (String, ConstantPool High) (Either ClassFileError) a)+  Evolve (ReaderT EvolveConfig (Either ClassFileError) a)   deriving   ( Functor   , Applicative   , Monad-  , MonadReader (String, ConstantPool High)+  , MonadReader EvolveConfig   , MonadError ClassFileError   ) -runEvolve :: ConstantPool High -> Evolve a -> Either ClassFileError a-runEvolve cp (Evolve m) = runReaderT m ("", cp)+runEvolve :: EvolveConfig -> Evolve a -> Either ClassFileError a+runEvolve ev (Evolve m) = runReaderT m ev  instance LabelM Evolve where   label str (Evolve m) = do-    Evolve . withReaderT (\(x, cp) -> (x ++ "/" ++ str, cp)) $ m+    Evolve . withReaderT (\ec -> ec { ecLabel = str : ecLabel ec}) $ m +showLvl :: [String] -> String+showLvl = List.intercalate "/" . reverse+ instance EvolveM Evolve where   link w = do-    (lvl, cp) <- ask-    r <- either (throwError . CFEPoolAccessError lvl ) return $ access w cp+    ec <- ask+    let lvl = showLvl ( ecLabel ec )+    r <- either (throwError . CFEPoolAccessError lvl)  return $ access w (ecConstantPool ec)     fromConst (throwError . CFEInconsistentClassPool lvl) r +  attributeFilter =+    asks ecAttributeFilter+   attributeError msg = do-    (lvl, _) <- ask+    lvl <- asks (showLvl . ecLabel)     throwError (CFEConversionError lvl msg)  -- | Untie the constant pool, this requires a special operation as the constant pool@@ -162,20 +183,24 @@            $ "Could not load all constants in the constant pool: " ++ (show xs)   where     stage' cp mis =-      let (cp', mis') = foldMap (grow cp) mis in-      case appEndo mis' [] of-        [] | IM.null cp' -> Right cp-        xs-          | IM.null cp' ->-            Left xs-          | otherwise ->-            stage' (cp `IM.union` cp') (map snd xs)+      let (cp', mis') =+            foldMap (grow (EvolveConfig [] (ConstantPool cp) (const True))) mis+      in if IM.null cp'+        then+          case appEndo mis' [] of+            [] -> Right cp+            xs -> Left xs+        else+          stage' (cp `IM.union` cp') . map snd $ appEndo mis' [] -    grow cp (k,a) =-      case runEvolve (ConstantPool cp) $ evolve a of+    grow :: EvolveConfig -> (Int, Constant Low) -> (IM.IntMap (Constant High), Endo [(ClassFileError, (Int, Constant Low))])+    grow ec (k,a) =+      case runEvolve ec (evolve a) of         Right c -> (IM.singleton k c, Endo id)         Left msg  -> (IM.empty, Endo ((msg, (k,a)):)) +{-# SCC bootstrapConstantPool #-}+ -- $build  data CPBuilder = CPBuilder@@ -198,7 +223,7 @@   deriving (Monad, MonadState CPBuilder, Functor, Applicative)  runConstantPoolBuilder :: ConstantPoolBuilder a -> CPBuilder -> (a, CPBuilder)-runConstantPoolBuilder (ConstantPoolBuilder m) a=+runConstantPoolBuilder (ConstantPoolBuilder m) a =   runState m a  instance LabelM ConstantPoolBuilder

@@ -91,6 +91,7 @@     Just x -> Right x     Nothing -> Left $ PoolAccessError ref "No such element." + -- | Append a constant to the constant pool, and get the offset. append :: Constant r -> ConstantPool r -> (Index, ConstantPool r) append c (ConstantPool cp) =

@@ -64,7 +64,7 @@   evolve field = label "Field" $ do     fi <- link (fName field)     fd <- link (fDescriptor field)-    fattr <- fromCollector <$> fromAttributes collect' (fAttributes field)+    fattr <- fromCollector <$> fromAttributes FieldAttribute collect' (fAttributes field)     return $ Field (fAccessFlags' field) fi fd fattr     where       fromCollector (cv, sig, others) =

@@ -85,7 +85,7 @@     mn' <- link mn     md' <- link md     mattr' <- label (Text.unpack (mn' <> ":" <> toText md'))-      $ fromCollector <$> fromAttributes collect' mattr+      $ fromCollector <$> fromAttributes MethodAttribute collect' mattr     return $ Method mf mn' md' mattr'     where       fromCollector (a, b, c, d) =

@@ -15,11 +15,17 @@   , LabelM (..)   , EvolveM (..)   , DevolveM (..)++  -- * AttributeLocation+  , AttributeLocation (..)+   -- * Re-exports   , module Language.JVM.Stage   , module Language.JVM.TH   ) where +import qualified Data.Text as Text+ import Language.JVM.Constant import Language.JVM.Stage import Language.JVM.TH@@ -29,8 +35,16 @@   -- ^ label the current position in the class-file, good for debugging   label _ = id +data AttributeLocation+  = ClassAttribute+  | MethodAttribute+  | CodeAttribute+  | FieldAttribute+  deriving (Show, Eq, Ord)+ class LabelM m => EvolveM m where   link :: Referenceable r => Index -> m r+  attributeFilter :: m ((AttributeLocation, Text.Text) -> Bool)   attributeError :: String -> m r  class LabelM m => DevolveM m where

@@ -21,6 +21,8 @@   -- ** JType   , JType (..)   , JBaseType (..)+  , jBaseTypeP+  , jBaseTypeToChar    -- ** MethodDescriptor   , MethodDescriptor (..)@@ -100,46 +102,55 @@  class TypeParse a where   fromText :: Text.Text -> Either String a-  fromText = parseOnly parseText+  fromText = parseOnly (parseText <* endOfInput)   parseText :: Parser a   toText :: a -> Text.Text +jBaseTypeP :: Parser JBaseType+jBaseTypeP = do+  s <- satisfy (inClass "BCDFIJSZ") <?> "BaseType"+  case s of+    'B' -> return $ JTByte+    'C' -> return $ JTChar+    'D' -> return $ JTDouble+    'F' -> return $ JTFloat+    'I' -> return $ JTInt+    'J' -> return $ JTLong+    'S' -> return $ JTShort+    'Z' -> return $ JTBoolean+    _ -> error "should not happen"++jBaseTypeToChar :: JBaseType -> Char+jBaseTypeToChar y = do+  case y of+    JTByte    -> 'B'+    JTChar    -> 'C'+    JTDouble  -> 'D'+    JTFloat   -> 'F'+    JTInt     -> 'I'+    JTLong    -> 'J'+    JTShort   -> 'S'+    JTBoolean -> 'Z'+ instance TypeParse JType where-  parseText = try $ do-    s <- anyChar-    case s :: Char of-      'B' -> return $ JTBase JTByte-      'C' -> return $ JTBase JTChar-      'D' -> return $ JTBase JTDouble-      'F' -> return $ JTBase JTFloat-      'I' -> return $ JTBase JTInt-      'J' -> return $ JTBase JTLong-      'L' -> do-        txt <- takeWhile (/= ';')-        _ <- char ';'-        return $ JTClass (ClassName txt)-      'S' -> return $ JTBase JTShort-      'Z' -> return $ JTBase JTBoolean-      '[' -> JTArray <$> parseText-      _ -> fail $ "Unknown char " ++ show s+  parseText = do+    choice+      [ JTBase <$> jBaseTypeP+      , do+          _ <- char 'L'+          txt <- takeWhile (/= ';')+          _ <- char ';'+          return $ JTClass (ClassName txt)+      , char '[' >> JTArray <$> parseText+      ]   toText tp =     Text.pack $ go tp ""     where       go x =         case x of-          JTBase y               -> textbase y+          JTBase y               -> (jBaseTypeToChar y :)           JTClass (ClassName cn) -> ((('L':Text.unpack cn) ++ ";") ++)           JTArray tp'            -> ('[':) . go tp'-      textbase y =-        case y of-          JTByte    -> ('B':)-          JTChar    -> ('C':)-          JTDouble  -> ('D':)-          JTFloat   -> ('F':)-          JTInt     -> ('I':)-          JTLong    -> ('J':)-          JTShort   -> ('S':)-          JTBoolean -> ('Z':)  instance TypeParse MethodDescriptor where   toText md =

@@ -1,4 +1,4 @@-resolver: lts-10.5+resolver: lts-12.11 packages: - . flags: {}

@@ -0,0 +1,39 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.JVM.Attribute.EnclosingMethodTest where++import           SpecHelper++import           Language.JVM.ConstantTest               ()++import           Language.JVM.Attribute.EnclosingMethod+import           Language.JVM++prop_roundtrip_EnclosingMethodTest :: EnclosingMethod High -> Property+prop_roundtrip_EnclosingMethodTest = isoRoundtrip+++spec_enclosing ::  SpecWith ()+spec_enclosing = do+  it "can find an enclosing method in 'Streams$5'" $ do+    tc <- withTestClass "Streams$5"+    cEnclosingMethod tc `shouldBe`+       Just (EnclosingMethod+             "com/google/common/collect/Streams"+             (Just ("mapWithIndex:(Ljava/util/stream/DoubleStream;Lcom/google/common/collect/Streams$DoubleFunctionWithIndex;)Ljava/util/stream/Stream;"))+            )++-- test_real_signatures :: SpecWith ()+-- test_real_signatures = do+--   it "can handle Iterator" $ do+--    let signature = "<T:Ljava/lang/Object;>Ljava/lang/Object;"++instance Arbitrary (EnclosingMethod High) where+  arbitrary = genericArbitraryU+++  -- "Lcom/apple/eawt/_AppEventHandler$_AppEventDispatcher<Lcom/apple/eawt/QuitHandler;>;"+-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor<Lcom/apple/eawt/ScreenSleepListener;Lcom/apple/eawt/AppEvent$ScreenSleepEvent;>;"+-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor<Lcom/apple/eawt/SystemSleepListener;Lcom/apple/eawt/AppEvent$SystemSleepEvent;>;"+-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor<Lcom/apple/eawt/UserSessionListener;Lcom/apple/eawt/AppEvent$UserSessionEvent;>;"

@@ -0,0 +1,64 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.JVM.Attribute.InnerClassesTest where++import           SpecHelper+import qualified Data.Set as S++import           Language.JVM.ConstantTest               ()++import           Language.JVM.Attribute.InnerClasses+import           Language.JVM++prop_roundtrip_InnerClassesTest :: InnerClasses High -> Property+prop_roundtrip_InnerClassesTest = isoRoundtrip++spec_inner_classes ::  SpecWith ()+spec_inner_classes = do+  it "can find the inner classes of 'Streams$5'" $ do+    tc <- withTestClass "Streams$5"+    cInnerClasses tc `shouldBe`+      [+          InnerClass {+              icClassName = "java/util/PrimitiveIterator$OfDouble",+              icOuterClassName = Just "java/util/PrimitiveIterator",+              icInnerName = Just "OfDouble",+              icInnerAccessFlags = BitSet $ S.fromList [ICPublic, ICStatic, ICInterface, ICAbstract]+          },+          InnerClass {+              icClassName = "com/google/common/collect/Streams$DoubleFunctionWithIndex",+              icOuterClassName = Just "com/google/common/collect/Streams",+              icInnerName = Just "DoubleFunctionWithIndex",+              icInnerAccessFlags = BitSet $ S.fromList [ICPublic, ICStatic, ICInterface, ICAbstract]+          },+          InnerClass {+              icClassName = "com/google/common/collect/Streams$5",+              icOuterClassName = Nothing,+              icInnerName = Nothing,+              icInnerAccessFlags = BitSet $ S.fromList [ ICStatic ]+          },+          InnerClass {+              icClassName = "java/util/Spliterators$AbstractSpliterator",+              icOuterClassName = Just "java/util/Spliterators",+              icInnerName = Just "AbstractSpliterator",+              icInnerAccessFlags = BitSet $ S.fromList [ICPublic, ICStatic, ICAbstract]+          }+      ]++-- test_real_signatures :: SpecWith ()+-- test_real_signatures = do+--   it "can handle Iterator" $ do+--    let signature = "<T:Ljava/lang/Object;>Ljava/lang/Object;"++instance Arbitrary (InnerClasses High) where+  arbitrary = genericArbitraryU++instance Arbitrary (InnerClass High) where+  arbitrary = genericArbitraryU+++  -- "Lcom/apple/eawt/_AppEventHandler$_AppEventDispatcher<Lcom/apple/eawt/QuitHandler;>;"+-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor<Lcom/apple/eawt/ScreenSleepListener;Lcom/apple/eawt/AppEvent$ScreenSleepEvent;>;"+-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor<Lcom/apple/eawt/SystemSleepListener;Lcom/apple/eawt/AppEvent$SystemSleepEvent;>;"+-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor<Lcom/apple/eawt/UserSessionListener;Lcom/apple/eawt/AppEvent$UserSessionEvent;>;"

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}  module Language.JVM.Attribute.SignatureTest where @@ -9,17 +10,183 @@ import           Language.JVM.Attribute.Signature import           Language.JVM +import qualified Data.Text as Text+import Data.Attoparsec.Text+ prop_roundtrip_SignatureTest :: Signature High -> Property prop_roundtrip_SignatureTest = isoRoundtrip --- test_real_signatures :: SpecWith ()--- test_real_signatures = do---   it "can handle Iterator" $ do---    let signature = "<T:Ljava/lang/Object;>Ljava/lang/Object;"+prop_field_signature :: FieldSignature -> Property+prop_field_signature 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++prop_class_signature :: ClassSignature -> Property+prop_class_signature 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" []))++  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 = []+              })+  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 = []+           }+       ]+  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 = []+       })+  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 = []+      })+++  it "can handle the simple method signature" $ do+    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")])++  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 = []+                        }+                    )+            ])++  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") ]+           )))++ instance Arbitrary (Signature High) where   arbitrary = genericArbitraryU +instance Arbitrary (FieldSignature) where+  arbitrary = genericArbitraryU++instance Arbitrary (ReferenceType) where+  arbitrary = do+    n <- getSize+    if n == 0+      then pure (RefTypeVariable $ TypeVariable "X")+      else scale (\s -> s `div` 2) $ genericArbitraryU++instance Arbitrary (ClassType) where+  arbitrary = 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+      ]+++instance Arbitrary (TypeVariable) where+  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++instance Arbitrary (TypeArgument) where+  arbitrary = genericArbitraryU++instance Arbitrary (TypeParameter) where+  arbitrary = TypeParameter <$> elements ["A","B", "C", "HJ"] <*> arbitrary <*> arbitrary++instance Arbitrary (Wildcard) where+  arbitrary = genericArbitraryU++instance Arbitrary (MethodSignature) where+  arbitrary = genericArbitraryU++instance Arbitrary (ClassSignature) where+  arbitrary = genericArbitraryU++instance Arbitrary (ThrowsSignature) where+  arbitrary = genericArbitraryU  -- "Lcom/apple/eawt/_AppEventHandler$_AppEventDispatcher<Lcom/apple/eawt/QuitHandler;>;" -- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor<Lcom/apple/eawt/ScreenSleepListener;Lcom/apple/eawt/AppEvent$ScreenSleepEvent;>;"

@@ -19,7 +19,7 @@ prop_roundtrip_ClassFile = isoRoundtrip  instance Arbitrary (ClassAttributes High) where-  arbitrary = ClassAttributes <$> pure [] <*> pure [] <*> pure []+  arbitrary = pure $ ClassAttributes [] [] [] [] []  instance Arbitrary (ClassFile High) where   arbitrary = ClassFile

@@ -4,32 +4,34 @@  import SpecHelper +import Data.Attoparsec.Text+import Data.Either import Language.JVM.Type  -- import Text.Megaparsec -- import Test.Hspec.Megaparsec --- spec_JType_parsing :: Spec--- spec_JType_parsing = do---   it "can parse \"[B\" as an array" $---     parse parseJType "" "[B" `shouldParse` JTArray JTByte---   it "can parse an array of strings" $---     parse parseJType "" "[Ljava/lang/String;" `shouldParse`---       JTArray (JTClass (ClassName "java/lang/String"))+spec_JType_parsing :: Spec+spec_JType_parsing = do+  it "can parse \"[B\" as an array" $+    parseOnly parseText "[B" `shouldBe` Right (JTArray (JTBase JTByte))+  it "can parse an array of strings" $+    parseOnly parseText "[Ljava/lang/String;" `shouldBe`+      Right (JTArray (JTClass (ClassName "java/lang/String"))) --- spec_MethodDescriptor_parsing :: Spec--- spec_MethodDescriptor_parsing = do---   it "can parse the empty method" $---     parse parseMethodDescriptor "" "()V" `shouldParse`---       MethodDescriptor [] Nothing---   it "can parse method arguments" $---     parse parseMethodDescriptor "" "(BZ)B" `shouldParse`---       MethodDescriptor [JTByte, JTBoolean] (Just JTByte)---   it "does not parse if there is too much" $---     methodDescriptorFromText "(BZ)Bx" `shouldBe` Nothing+spec_MethodDescriptor_parsing :: Spec+spec_MethodDescriptor_parsing = do+  it "can parse the empty method" $+    parseOnly parseText "()V" `shouldBe`+      Right (MethodDescriptor [] Nothing)+  it "can parse method arguments" $+    parseOnly parseText "(BZ)B" `shouldBe`+      Right (MethodDescriptor [JTBase JTByte, JTBase JTBoolean] (Just (JTBase JTByte)))+  it "does not parse if there is too much" $+    (fromText "(BZ)Bx" :: Either String MethodDescriptor) `shouldSatisfy` isLeft  instance Arbitrary ClassName where-  arbitrary = pure $ ClassName "package.Main"+  arbitrary = pure $ ClassName "package/Main"  instance Arbitrary JType where   arbitrary = genericArbitrary uniform

@@ -41,11 +41,11 @@     cp `shouldSatisfy` isRight     let Right cp' = cp     forM_ (cMethods' cls) $ \m -> do-      case (runEvolve cp' (evolve m)) of+      case (runEvolve (EvolveConfig [] cp' (const True)) (evolve m)) of         Right _ -> return ()         Left err -> do           putStr (show err) >> putStr ": "-          print . runEvolve cp' $ do+          print . runEvolve (EvolveConfig [] cp' (const True)) $ do             x <- link (mDescriptor m)             n <- link (mName m)             return ((n, x) :: (MethodDescriptor, Text.Text))@@ -57,7 +57,7 @@                   putStr " -> " >> print i                  forM_ (C.codeAttributes c) $ \ca -> do-                  print $ runEvolve cp' (evolve ca)+                  print $ runEvolve (EvolveConfig [] cp' (const True)) (evolve ca)                   putStrLn (hexStringS $ aInfo ca)                   case fromAttribute' ca :: Either String (StackMapTable Low) of                     Right x ->@@ -76,7 +76,7 @@       decodeClassFile e `shouldBe` Right cls    describe "evolving/devolving" $ do-    let me = evolveClassFile cls+    let me = evolveClassFile (const True) cls     it "can evolve the whole class file" $ do       me `shouldSatisfy` isRight 

@@ -1,4 +1,3 @@- module SpecHelper   ( module Test.Tasty   , module Test.Hspec.Expectations.Pretty@@ -14,6 +13,7 @@   , testAllFiles   , hexStringS   , hexString+  , withTestClass   , Spec   , SpecWith   , it@@ -42,6 +42,7 @@ import qualified Data.List as List  import Language.JVM.ByteCode+import Language.JVM.ClassFile import Language.JVM.Utils import Language.JVM.Staged import Language.JVM.ClassFileReader@@ -67,6 +68,10 @@       takeExtension p == ".class"       && p /= "test/data/SQLite.class" +withTestClass :: String -> IO (ClassFile High)+withTestClass str = do+  Right rf <- readClassFile <$> (blReadFile $ "test/data/" ++ str ++ ".class")+  return rf  -- testSomeFiles :: SpecWith BL.ByteString -> IO [TestTree] -- testSomeFiles spec =@@ -112,7 +117,7 @@       let bs = encode a'       a'' <- bimap trd trd $ decodeOrFail bs       cp' <- first show $ bootstrapConstantPool cp-      a3 <- first show $ runEvolve cp' (evolve a'')+      a3 <- first show $ runEvolve (EvolveConfig [] cp' (const True)) (evolve a'')       return (bs, a3)  -- | Test that a value can go from the Highest state to binary and back again@@ -133,7 +138,7 @@   let bs = encode a'   a'' <- bimap trd trd $ decodeOrFail bs   cp' <- first show $ bootstrapConstantPool cp-  a3 <- first show $ runEvolve cp' (evolveBC (return . fromIntegral) a'')+  a3 <- first show $ runEvolve (EvolveConfig [] cp' (const True)) (evolveBC (return . fromIntegral) a'')   return (bs, a3)  folderContents :: FilePath -> IO [ FilePath ]