diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE.md b/LICENSE.md --- a/LICENSE.md +++ b/LICENSE.md @@ -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 diff --git a/benchmark/Main.hs b/benchmark/Main.hs --- a/benchmark/Main.hs +++ b/benchmark/Main.hs @@ -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" diff --git a/jvm-binary.cabal b/jvm-binary.cabal --- a/jvm-binary.cabal +++ b/jvm-binary.cabal @@ -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 diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: jvm-binary -version: '0.1.0' +version: '0.2.0' author: Christian Gram Kalhauge maintainer: Christian Gram Kalhauge 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 diff --git a/src/Language/JVM/AccessFlag.hs b/src/Language/JVM/AccessFlag.hs --- a/src/Language/JVM/AccessFlag.hs +++ b/src/Language/JVM/AccessFlag.hs @@ -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 diff --git a/src/Language/JVM/Attribute/Base.hs b/src/Language/JVM/Attribute/Base.hs --- a/src/Language/JVM/Attribute/Base.hs +++ b/src/Language/JVM/Attribute/Base.hs @@ -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 = diff --git a/src/Language/JVM/Attribute/Code.hs b/src/Language/JVM/Attribute/Code.hs --- a/src/Language/JVM/Attribute/Code.hs +++ b/src/Language/JVM/Attribute/Code.hs @@ -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) = diff --git a/src/Language/JVM/Attribute/EnclosingMethod.hs b/src/Language/JVM/Attribute/EnclosingMethod.hs new file mode 100644 --- /dev/null +++ b/src/Language/JVM/Attribute/EnclosingMethod.hs @@ -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) diff --git a/src/Language/JVM/Attribute/InnerClasses.hs b/src/Language/JVM/Attribute/InnerClasses.hs new file mode 100644 --- /dev/null +++ b/src/Language/JVM/Attribute/InnerClasses.hs @@ -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) diff --git a/src/Language/JVM/Attribute/Signature.hs b/src/Language/JVM/Attribute/Signature.hs --- a/src/Language/JVM/Attribute/Signature.hs +++ b/src/Language/JVM/Attribute/Signature.hs @@ -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) = diff --git a/src/Language/JVM/ByteCode.hs b/src/Language/JVM/ByteCode.hs --- a/src/Language/JVM/ByteCode.hs +++ b/src/Language/JVM/ByteCode.hs @@ -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 diff --git a/src/Language/JVM/ClassFile.hs b/src/Language/JVM/ClassFile.hs --- a/src/Language/JVM/ClassFile.hs +++ b/src/Language/JVM/ClassFile.hs @@ -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) diff --git a/src/Language/JVM/ClassFileReader.hs b/src/Language/JVM/ClassFileReader.hs --- a/src/Language/JVM/ClassFileReader.hs +++ b/src/Language/JVM/ClassFileReader.hs @@ -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 diff --git a/src/Language/JVM/ConstantPool.hs b/src/Language/JVM/ConstantPool.hs --- a/src/Language/JVM/ConstantPool.hs +++ b/src/Language/JVM/ConstantPool.hs @@ -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) = diff --git a/src/Language/JVM/Field.hs b/src/Language/JVM/Field.hs --- a/src/Language/JVM/Field.hs +++ b/src/Language/JVM/Field.hs @@ -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) = diff --git a/src/Language/JVM/Method.hs b/src/Language/JVM/Method.hs --- a/src/Language/JVM/Method.hs +++ b/src/Language/JVM/Method.hs @@ -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) = diff --git a/src/Language/JVM/Staged.hs b/src/Language/JVM/Staged.hs --- a/src/Language/JVM/Staged.hs +++ b/src/Language/JVM/Staged.hs @@ -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 diff --git a/src/Language/JVM/Type.hs b/src/Language/JVM/Type.hs --- a/src/Language/JVM/Type.hs +++ b/src/Language/JVM/Type.hs @@ -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 = diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-10.5 +resolver: lts-12.11 packages: - . flags: {} diff --git a/test/Language/JVM/Attribute/EnclosingMethodTest.hs b/test/Language/JVM/Attribute/EnclosingMethodTest.hs new file mode 100644 --- /dev/null +++ b/test/Language/JVM/Attribute/EnclosingMethodTest.hs @@ -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 = "Ljava/lang/Object;" + +instance Arbitrary (EnclosingMethod High) where + arbitrary = genericArbitraryU + + + -- "Lcom/apple/eawt/_AppEventHandler$_AppEventDispatcher;" +-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor;" +-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor;" +-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor;" diff --git a/test/Language/JVM/Attribute/InnerClassesTest.hs b/test/Language/JVM/Attribute/InnerClassesTest.hs new file mode 100644 --- /dev/null +++ b/test/Language/JVM/Attribute/InnerClassesTest.hs @@ -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 = "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/_AppEventHandler$_BooleanAppEventMultiplexor;" +-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor;" +-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor;" diff --git a/test/Language/JVM/Attribute/SignatureTest.hs b/test/Language/JVM/Attribute/SignatureTest.hs --- a/test/Language/JVM/Attribute/SignatureTest.hs +++ b/test/Language/JVM/Attribute/SignatureTest.hs @@ -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 = "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 " $ do + let sig = "" + 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 = "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/_AppEventHandler$_BooleanAppEventMultiplexor;" diff --git a/test/Language/JVM/ClassFileTest.hs b/test/Language/JVM/ClassFileTest.hs --- a/test/Language/JVM/ClassFileTest.hs +++ b/test/Language/JVM/ClassFileTest.hs @@ -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 diff --git a/test/Language/JVM/TypeTest.hs b/test/Language/JVM/TypeTest.hs --- a/test/Language/JVM/TypeTest.hs +++ b/test/Language/JVM/TypeTest.hs @@ -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 diff --git a/test/Language/JVMTest.hs b/test/Language/JVMTest.hs --- a/test/Language/JVMTest.hs +++ b/test/Language/JVMTest.hs @@ -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 diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -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 ]