diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Change log +## Version 0.3.0 + +- Change API of TypeParse +- Merge together the New* commands + ## Version 0.2.0 - Add filter to evolveClassFile diff --git a/jvm-binary.cabal b/jvm-binary.cabal --- a/jvm-binary.cabal +++ b/jvm-binary.cabal @@ -1,11 +1,13 @@ --- This file has been generated from package.yaml by hpack version 0.28.2. +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.1. -- -- see: https://github.com/sol/hpack -- --- hash: 096c3cb1a26134c8a5bb271a50589aea060f4b5891e16c3f03102d2b1fb02660 +-- hash: de6a2ad84e6004a7f51bebd6de23e07284fc0008745bb848cfd6e699444fcd36 name: jvm-binary -version: 0.2.0 +version: 0.3.0 synopsis: A library for reading Java class-files description: A library for reading Java class-files. category: Language, Java, JVM @@ -16,7 +18,6 @@ license: MIT license-file: LICENSE.md build-type: Simple -cabal-version: >= 1.10 extra-source-files: CHANGELOG.md LICENSE.md diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: jvm-binary -version: '0.2.0' +version: '0.3.0' author: Christian Gram Kalhauge maintainer: Christian Gram Kalhauge synopsis: A library for reading Java class-files 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 @@ -52,36 +52,34 @@ ) where import Control.DeepSeq (NFData) --- import Data.Binary --- import qualified Data.IntMap as IM import qualified Data.Text as Text --- import Data.Monoid -import Data.Text.Lazy.Builder as Text -import qualified Data.Text.Lazy as LText +import qualified Data.Text.Lazy as LText +import Data.Text.Lazy.Builder as Text -import Data.Functor +import Data.Functor import GHC.Generics (Generic) + +import Data.Attoparsec.Text + +import qualified Data.List as L + import Language.JVM.Attribute.Base import Language.JVM.Staged import Language.JVM.Type -import qualified Data.List as L -import Data.Attoparsec.Text - instance IsAttribute (Signature Low) where attrName = Const "Signature" -data Signature a = +newtype Signature a = Signature (Ref Text.Text a) signatureToText :: Signature High -> Text.Text signatureToText (Signature s) = s signatureFromText :: Text.Text -> Signature High -signatureFromText s = Signature s - +signatureFromText = Signature ---------------------- -- Parsing @@ -121,11 +119,11 @@ typeSignatureP :: Parser TypeSignature typeSignatureP = do choice [ (ReferenceType <$> referenceTypeP) "JRefereceType" - , (BaseType <$> jBaseTypeP) "JBaseType" ] + , (BaseType <$> parseType) "JBaseType" ] typeSignatureT :: TypeSignature -> Builder typeSignatureT (ReferenceType t) = referenceTypeT t -typeSignatureT (BaseType t) = singleton (jBaseTypeToChar t) +typeSignatureT (BaseType t) = singleton (jBaseTypeToChar t) data ReferenceType = RefClassType ClassType @@ -144,9 +142,9 @@ referenceTypeT :: ReferenceType -> Builder referenceTypeT t = case t of - RefClassType ct -> classTypeT ct + RefClassType ct -> classTypeT ct RefTypeVariable tv -> typeVariableT tv - RefArrayType at -> singleton '[' <> typeSignatureT at + RefArrayType at -> singleton '[' <> typeSignatureT at data ClassType = ClassType @@ -163,7 +161,7 @@ classTypeP :: Parser ClassType classTypeP = nameit "ClassType" $ do _ <- char 'L' - cn <- (ClassName <$> takeWhile1 (notInClass ".;[<>:")) "ClassName" + cn <- parseType ta <- option [] typeArgumentsP ict <- many' $ do _ <- char '.' @@ -222,8 +220,8 @@ Just (TypeArgument w rt) -> (case w of Just WildMinus -> singleton '-' - Just WildPlus -> singleton '+' - Nothing -> mempty) <> referenceTypeT rt + Just WildPlus -> singleton '+' + Nothing -> mempty) <> referenceTypeT rt data Wildcard = WildPlus | WildMinus @@ -343,10 +341,8 @@ throwsSignatureT t = singleton '^' <> case t of - ThrowsClass ct -> classTypeT ct + ThrowsClass ct -> classTypeT ct ThrowsTypeVariable tt -> typeVariableT tt - - newtype FieldSignature = FieldSignature {fsRefType :: ReferenceType} diff --git a/src/Language/JVM/Attribute/StackMapTable.hs b/src/Language/JVM/Attribute/StackMapTable.hs --- a/src/Language/JVM/Attribute/StackMapTable.hs +++ b/src/Language/JVM/Attribute/StackMapTable.hs @@ -21,6 +21,7 @@ , DeltaOffset , StackMapFrame (..) , StackMapFrameType (..) + , emptyStackMapTable , VerificationTypeInfo (..) @@ -53,6 +54,9 @@ { stackMapTable :: Choice (SizedList16 (StackMapFrame Low)) [StackMapFrame High] r } +emptyStackMapTable :: StackMapTable High +emptyStackMapTable = StackMapTable [] + -- | A delta offset type DeltaOffset i = Choice Word16 Int i @@ -148,6 +152,7 @@ put ls1 put ls2 +-- TODO: Fix that ClassName can be an array. -- | The types info of the stack map frame. data VerificationTypeInfo r = VTTop 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,6 +1,7 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -funbox-strict-fields #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -35,6 +36,8 @@ , offsetIndex , offsetMap + , generateOffsets + -- * ByteCode Operations , ByteCodeOpr (..) @@ -58,7 +61,6 @@ , SmallArithmeticType (..) , LocalType (..) , ArrayType (..) - , ExactArrayType (..) -- * Renames , WordSize @@ -87,6 +89,7 @@ import Language.JVM.Constant import Language.JVM.Staged +import Language.JVM.Type -- | ByteCode is a newtype wrapper around a list of ByteCode instructions. -- if the ByteCode is in the Low stage then the byte code instructions are @@ -175,8 +178,6 @@ , opcode :: !(ByteCodeOpr r) } -(...) :: (b -> c) -> (a1 -> a2 -> b) -> a1 -> a2 -> c -(...) = (.) . (.) evolveByteCode :: EvolveM m => ByteCode Low -> m (OffsetMap, ByteCode High) evolveByteCode bc@(ByteCode (_, v)) = do @@ -187,10 +188,16 @@ devolveByteCode :: DevolveM m => ByteCode High -> m (ByteCode Low) devolveByteCode (ByteCode bc) = do -- Devolving byte code is not straight forward. - (len, vect) <- V.foldM' acc (0,[]) bc - let offsets = V.fromList . reverse $ vect + (len, offsets) <- generateOffsets bc ByteCode . (fromIntegral len,) - <$> V.zipWithM (devolveByteCodeInst (devolveOffset' offsets) ... ByteCodeInst) offsets bc + <$> V.mapM + (devolveByteCodeInst (devolveOffset' offsets)) + (V.zipWith ByteCodeInst offsets bc) + +generateOffsets :: DevolveM m => V.Vector (ByteCodeOpr High) -> m (Word16, V.Vector ByteCodeOffset) +generateOffsets bc = do + (len, vect) <- V.foldM' acc (0,[]) bc + return (len, V.fromList . reverse $ vect) where acc (off, lst) opr = do inst <- devolveByteCodeInst (const $ return 0) (ByteCodeInst off opr) @@ -218,6 +225,16 @@ evolveBC = evolveByteCodeInst devolveBC = devolveByteCodeInst +evolveRefType :: EvolveM m => RefType Low -> m JRefType +evolveRefType = \case + ArrayBaseType bt -> return $ JTArray (JTBase bt) + Reference m _ -> link m + +devolveRefType :: DevolveM m => JRefType -> m (RefType Low) +devolveRefType = \case + JTArray (JTBase bt) -> return $ ArrayBaseType bt + c -> flip Reference (fromIntegral $ refTypeDepth c) <$> unlink c + evolveByteCodeInst :: EvolveM m => (ByteCodeOffset -> m ByteCodeIndex) @@ -229,17 +246,17 @@ Get fa r -> label "Get" $ Get fa <$> link r Put fa r -> label "Put" $ Put fa <$> link r Invoke r -> label "Invoke" $ Invoke <$> evolve r - New r -> label "New" $ New <$> link r - NewArray r -> label "NewArray" $ NewArray <$> evolve r - MultiNewArray r u -> label "MultiNewArray" $ MultiNewArray <$> link r <*> pure u + New r -> label "New" $ New <$> evolveRefType r CheckCast r -> label "CheckCast" $ CheckCast <$> link r InstanceOf r -> label "InstanceOf" $ InstanceOf <$> link r If cp on r -> label "If" $ If cp on <$> calcOffset r IfRef b on r -> label "IfRef" $ IfRef b on <$> calcOffset r Goto r -> label "Goto" $ Goto <$> calcOffset r Jsr r -> label "Jsr" $ Jsr <$> calcOffset r - TableSwitch i (SwitchTable l ofss) -> - label "TableSwitch" $ (TableSwitch i . SwitchTable l <$> V.mapM calcOffset ofss) + TableSwitch i (SwitchTable l ofss) -> label "TableSwitch" $ + TableSwitch <$> calcOffset i <*> (SwitchTable l <$> V.mapM calcOffset ofss) + LookupSwitch i ofss -> label "LookupSwitch" $ + LookupSwitch <$> calcOffset i <*> V.mapM (\(a, b) -> (a,) <$> calcOffset b) ofss a -> return $ unsafeCoerce a return $ seq x (ByteCodeInst ofs x) where @@ -260,9 +277,7 @@ Get fa r -> label "Get" $ Get fa <$> unlink r Put fa r -> label "Put" $ Put fa <$> unlink r Invoke r -> label "Invoke" $ Invoke <$> devolve r - New r -> label "New" $ New <$> unlink r - NewArray r -> label "NewArray" $ NewArray <$> devolve r - MultiNewArray r u -> label "MultiNewArray" $ MultiNewArray <$> unlink r <*> pure u + New r -> label "New" $ New <$> devolveRefType r CheckCast r -> label "CheckCast" $ CheckCast <$> unlink r InstanceOf r -> label "InstanceOf" $ InstanceOf <$> unlink r If cp on r -> label "If" $ If cp on <$> calcOffset r @@ -270,7 +285,9 @@ Goto r -> label "Goto" $ Goto <$> calcOffset r Jsr r -> label "Jsr" $ Jsr <$> calcOffset r TableSwitch i (SwitchTable l ofss) -> label "TableSwitch" $ - (TableSwitch i . SwitchTable l <$> V.mapM calcOffset ofss) + TableSwitch <$> calcOffset i <*> (SwitchTable l <$> V.mapM calcOffset ofss) + LookupSwitch i ofss -> label "LookupSwitch" $ + LookupSwitch <$> calcOffset i <*> V.mapM (\(a, b) -> (a,) <$> calcOffset b) ofss a -> return $ unsafeCoerce a where calcOffset r = do @@ -295,17 +312,6 @@ InvkDynamic r -> label "InvkDynamic" $ InvkDynamic <$> unlink r -instance Staged ExactArrayType where - evolve x = - case x of - EARef r -> EARef <$> link r - a -> return $ unsafeCoerce a - devolve x = - case x of - EARef r -> EARef <$> unlink r - a -> return $ unsafeCoerce a - - instance Binary (ByteCode Low) where get = do x <- getWord32be @@ -347,6 +353,10 @@ data SmallArithmeticType = MByte | MChar | MShort deriving (Show, Ord, Eq, Enum, Bounded, Generic, NFData) +data RefType r + = ArrayBaseType JBaseType + | Reference (Ref JRefType r) Word8 + data LocalType = LInt | LLong | LFloat | LDouble | LRef deriving (Show, Ord, Eq, Enum, Bounded, Generic, NFData) @@ -355,10 +365,6 @@ | AFloat | ADouble | ARef deriving (Show, Eq, Ord, Generic, NFData) -data ExactArrayType r - = EABoolean | EAByte | EAChar | EAShort | EAInt | EALong - | EAFloat | EADouble | EARef !(Ref ClassName r) - data Invocation r = InvkSpecial !(DeepRef AbsVariableMethodId r) -- ^ Variable since 52.0 @@ -561,9 +567,9 @@ | Jsr !(LongRelativeRef r) | Ret !LocalAddress - | TableSwitch !Int32 !(SwitchTable r) + | TableSwitch !(LongRelativeRef r) !(SwitchTable r) -- ^ a table switch has 2 values a `default` and a `SwitchTable` - | LookupSwitch !Int32 (V.Vector (Int32, Int32)) + | LookupSwitch !(LongRelativeRef r) (V.Vector (Int32, (LongRelativeRef r))) -- ^ a lookup switch has a `default` value and a list of pairs. | Get !FieldAccess !(DeepRef (InClass FieldId) r) @@ -571,9 +577,7 @@ | Invoke !(Invocation r) - | New !(Ref ClassName r) - - | NewArray !(ExactArrayType r) + | New !(Choice (RefType Low) JRefType r) | ArrayLength @@ -585,11 +589,6 @@ | Monitor !Bool -- ^ True => Enter, False => Exit - -- TODO: Fix this so that its more clear what it points to. - | 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) | Nop @@ -874,22 +873,22 @@ zero <- getWord8 when (zero /= 0) $ fail "Should be zero" return $ Invoke (InvkDynamic ref) - 0xbb -> New <$> get + 0xbb -> New . (flip Reference 0) <$> get 0xbc -> do x <- getWord8 - NewArray <$> case x of - 4 -> return EABoolean - 5 -> return EAChar - 6 -> return EAFloat - 7 -> return EADouble - 8 -> return EAByte - 9 -> return EAShort - 10 -> return EAInt - 11 -> return EALong + New . ArrayBaseType <$> case x of + 4 -> return JTBoolean + 5 -> return JTChar + 6 -> return JTFloat + 7 -> return JTDouble + 8 -> return JTByte + 9 -> return JTShort + 10 -> return JTInt + 11 -> return JTLong _ -> fail $ "Unknown type '0x" ++ showHex x "'." - 0xbd -> NewArray . EARef <$> get + 0xbd -> New . (flip Reference 1) <$> get 0xbe -> return ArrayLength @@ -923,7 +922,7 @@ _ -> fail $ "Wide does not work for opcode '0x" ++ showHex subopcode "'" - 0xc5 -> MultiNewArray <$> get <*> get + 0xc5 -> New <$> (Reference <$> get <*> get) 0xc6 -> IfRef False One <$> get 0xc7 -> IfRef True One <$> get @@ -1294,18 +1293,21 @@ InvkDynamic a -> putWord8 0xba >> put a >> putWord8 0 >> putWord8 0 - New a -> putWord8 0xbb >> put a - NewArray x -> do - case x of - EABoolean -> putWord8 0xbc >> putWord8 4 - EAChar -> putWord8 0xbc >> putWord8 5 - EAFloat -> putWord8 0xbc >> putWord8 6 - EADouble -> putWord8 0xbc >> putWord8 7 - EAByte -> putWord8 0xbc >> putWord8 8 - EAShort -> putWord8 0xbc >> putWord8 9 - EAInt -> putWord8 0xbc >> putWord8 10 - EALong -> putWord8 0xbc >> putWord8 11 - EARef a -> putWord8 0xbd >> put a + New a -> + case a of + ArrayBaseType bt -> case bt of + JTBoolean -> putWord8 0xbc >> putWord8 4 + JTChar -> putWord8 0xbc >> putWord8 5 + JTFloat -> putWord8 0xbc >> putWord8 6 + JTDouble -> putWord8 0xbc >> putWord8 7 + JTByte -> putWord8 0xbc >> putWord8 8 + JTShort -> putWord8 0xbc >> putWord8 9 + JTInt -> putWord8 0xbc >> putWord8 10 + JTLong -> putWord8 0xbc >> putWord8 11 + Reference p 0 -> putWord8 0xbb >> put p + Reference p 1 -> putWord8 0xbd >> put p + Reference p n -> putWord8 0xc5 >> put p >> put n + ArrayLength -> putWord8 0xbe Throw -> putWord8 0xbf @@ -1315,7 +1317,6 @@ Monitor True -> putWord8 0xc2 Monitor False -> putWord8 0xc3 - MultiNewArray a b -> putWord8 0xc5 >> put a >> put b IfRef False One a -> putWord8 0xc6 >> put a IfRef True One a -> putWord8 0xc7 >> put a @@ -1326,5 +1327,5 @@ $(deriveBase ''ByteCodeOpr) $(deriveBase ''SwitchTable) $(deriveBase ''Invocation) +$(deriveBase ''RefType) $(deriveBase ''CConstant) -$(deriveBase ''ExactArrayType) 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 @@ -6,7 +6,6 @@ module Language.JVM.ClassFileReader ( readClassFile , writeClassFile - , writeClassFile' -- * Finer granularity commands @@ -16,6 +15,9 @@ , devolveClassFile , devolveClassFile' + -- * Helpers + , roundtripCopy + -- * Evolve , Evolve , ClassFileError @@ -114,6 +116,13 @@ writeClassFile' cp = encodeClassFile . devolveClassFile' cp + +-- | A test function, essentially reading the classfile and then writing it +-- to another file. +roundtripCopy :: FilePath -> FilePath -> IO () +roundtripCopy f1 f2 = do + Right cf <- readClassFile <$> BL.readFile f1 + BL.writeFile f2 $ writeClassFile cf -- $deref -- Dereffing is the flattening of the constant pool to get the values diff --git a/src/Language/JVM/Constant.hs b/src/Language/JVM/Constant.hs --- a/src/Language/JVM/Constant.hs +++ b/src/Language/JVM/Constant.hs @@ -289,12 +289,12 @@ instance TypeParse a => Referenceable (NameAndType a) where fromConst err (CNameAndType rn txt) = do - md <- either err return $ fromText txt + md <- either err return $ typeFromText txt return $ NameAndType rn md fromConst e c = expected "CNameAndType" e c toConst (NameAndType rn md) = - return $ CNameAndType rn (toText md) + return $ CNameAndType rn (typeToText md) -- TODO: Find good encoding of string. instance Referenceable Text.Text where @@ -329,20 +329,29 @@ toConst (ClassName txt) = do return . CClassRef $ txt +instance Referenceable JRefType where + fromConst err (CClassRef r) = + either err return $ parseOnly parseFlatJRefType r + fromConst err a = + err $ wrongType "ClassRef" a + + toConst = + return . CClassRef . jRefTypeToFlatText + instance Referenceable MethodDescriptor where fromConst err = - fromConst err >=> either err pure . fromText - toConst = toConst . toText + fromConst err >=> either err pure . typeFromText + toConst = toConst . typeToText instance Referenceable FieldDescriptor where fromConst err = - fromConst err >=> either err pure . fromText - toConst = toConst . toText + fromConst err >=> either err pure . typeFromText + toConst = toConst . typeToText -- instance TypeParse f => Referenceable (NameAndType f) where -- fromConst err = -- fromConst err >=> either err pure . fromText --- toConst = toConst . toText +-- toConst = toConst . typeToText instance Referenceable MethodId where fromConst err x = MethodId <$> fromConst err x 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 @@ -84,7 +84,7 @@ evolve (Method mf mn md mattr) = do mn' <- link mn md' <- link md - mattr' <- label (Text.unpack (mn' <> ":" <> toText md')) + mattr' <- label (Text.unpack.typeToText $ NameAndType mn' md') $ fromCollector <$> fromAttributes MethodAttribute collect' mattr return $ Method mf mn' md' mattr' 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 @@ -1,3 +1,7 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-| Module : Language.JVM.Type Copyright : (c) Christian Gram Kalhauge, 2018 @@ -7,9 +11,6 @@ This module contains the 'JType', 'ClassName', 'MethodDescriptor', and 'FieldDescriptor'. -} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} module Language.JVM.Type ( -- * Base types @@ -21,9 +22,11 @@ -- ** JType , JType (..) , JBaseType (..) - , jBaseTypeP , jBaseTypeToChar + , JRefType (..) + , refTypeDepth + -- ** MethodDescriptor , MethodDescriptor (..) @@ -34,16 +37,38 @@ , NameAndType (..) , (<:>) + -- * TypeParse , TypeParse (..) + , typeFromText + , typeToText + , parseOnly + + , parseFlatJRefType + , jRefTypeToFlatText ) where -import Control.DeepSeq (NFData) -import Data.Attoparsec.Text +-- base import Data.String -import qualified Data.Text as Text -import GHC.Generics (Generic) -import Prelude hiding (takeWhile) +import Control.Applicative +import Data.Semigroup +import GHC.Generics (Generic) +import Prelude hiding (takeWhile) +-- deepseq +import Control.DeepSeq (NFData) + +-- attoparsec +import Data.Attoparsec.Text + +-- mtl +import Control.Monad.Writer hiding ((<>)) + +-- text +import qualified Data.Text as Text +import qualified Data.Text.Lazy as Lazy +import qualified Data.Text.Lazy.Builder as Builder + + -- | A class name newtype ClassName = ClassName { classNameAsText :: Text.Text @@ -73,13 +98,36 @@ | JTBoolean deriving (Show, Eq, Ord, Generic, NFData) --- | The JVM types +data JRefType + = JTClass !ClassName + | JTArray !JType + deriving (Show, Eq, Ord, Generic, NFData) + +-- | The number of nested arrays +refTypeDepth :: JRefType -> Int +refTypeDepth = \case + JTArray (JTRef a) -> 1 + (refTypeDepth a) + JTArray _ -> 1 + JTClass _ -> 0 + data JType = JTBase JBaseType - | JTClass ClassName - | JTArray JType + | JTRef JRefType deriving (Show, Eq, Ord, Generic, NFData) + +-- | Get the corresponding `Char` of a `JBaseType` +jBaseTypeToChar :: JBaseType -> Char +jBaseTypeToChar = \case + JTByte -> 'B' + JTChar -> 'C' + JTDouble -> 'D' + JTFloat -> 'F' + JTInt -> 'I' + JTLong -> 'J' + JTShort -> 'S' + JTBoolean -> 'Z' + -- | Method Descriptor data MethodDescriptor = MethodDescriptor { methodDescriptorArguments :: [JType] @@ -101,93 +149,115 @@ (<:>) = NameAndType class TypeParse a where - fromText :: Text.Text -> Either String a - fromText = parseOnly (parseText <* endOfInput) - parseText :: Parser a - toText :: a -> Text.Text + -- | A `TypeParse` should be parsable + parseType :: Parser a -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" + -- | A `TypeParse` should be printable + typeToBuilder :: a -> Builder.Builder -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' +-- | Parse a type from text +typeFromText :: TypeParse a => Text.Text -> Either String a +typeFromText = parseOnly (parseType <* endOfInput) +-- | Convert a type into text +typeToText :: TypeParse a => a -> Text.Text +typeToText = Lazy.toStrict . Builder.toLazyText . typeToBuilder + +instance TypeParse ClassName where + parseType = ClassName <$> takeWhile1 (notInClass ".;[<>:") "ClassName" + typeToBuilder = Builder.fromText . classNameAsText + +instance TypeParse JBaseType where + parseType = try . ( "BaseType") $ do + anyChar >>= \case + 'B' -> return $ JTByte + 'C' -> return $ JTChar + 'D' -> return $ JTDouble + 'F' -> return $ JTFloat + 'I' -> return $ JTInt + 'J' -> return $ JTLong + 'S' -> return $ JTShort + 'Z' -> return $ JTBoolean + s -> fail $ "Unknown char " ++ show s + + typeToBuilder = Builder.singleton . jBaseTypeToChar + +instance TypeParse JRefType where + parseType = try . ( "RefType") $ do + anyChar >>= \case + 'L' -> do + txt <- takeWhile (/= ';') + _ <- char ';' + return $ JTClass (ClassName txt) + '[' -> JTArray <$> parseType + s -> fail $ "Unknown char " ++ show s + + typeToBuilder = \case + JTClass cn -> + Builder.singleton 'L' <> typeToBuilder cn <> Builder.singleton ';' + JTArray t -> do + Builder.singleton '[' <> typeToBuilder t + +parseFlatJRefType :: Parser (JRefType) +parseFlatJRefType = + JTArray <$> (char '[' *> parseType) + <|> JTClass <$> parseType + +jRefTypeToFlatText :: JRefType -> Text.Text +jRefTypeToFlatText = \case + JTClass t' -> classNameAsText t' + JTArray t' -> Lazy.toStrict . Builder.toLazyText $ Builder.singleton '[' <> typeToBuilder t' + instance TypeParse JType where - 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 -> (jBaseTypeToChar y :) - JTClass (ClassName cn) -> ((('L':Text.unpack cn) ++ ";") ++) - JTArray tp' -> ('[':) . go tp' + parseType = + (JTRef <$> parseType <|> JTBase <$> parseType) + "JType" + typeToBuilder = \case + JTRef r -> typeToBuilder r + JTBase r -> typeToBuilder r + instance TypeParse MethodDescriptor where - toText md = - Text.concat ( - ["("] - ++ map toText (methodDescriptorArguments md) - ++ [")", maybe "V" toText $ methodDescriptorReturnType md ] - ) - parseText = do + typeToBuilder md = + execWriter $ do + tell $ Builder.singleton '(' + mapM_ (tell . typeToBuilder) (methodDescriptorArguments md) + tell $ Builder.singleton ')' + tell . maybe (Builder.singleton 'V') typeToBuilder $ methodDescriptorReturnType md + + parseType = do _ <- char '(' - args <- many' parseText "method arguments" + args <- many' parseType "method arguments" _ <- char ')' returnType <- choice [ char 'V' >> return Nothing - , Just <$> parseText + , Just <$> parseType ] "return type" return $ MethodDescriptor args returnType instance TypeParse FieldDescriptor where - parseText = FieldDescriptor <$> parseText - toText (FieldDescriptor t) = toText t + parseType = FieldDescriptor <$> parseType + typeToBuilder (FieldDescriptor t) = typeToBuilder t instance TypeParse t => TypeParse (NameAndType t) where - parseText = do + + parseType = do name <- many1 $ notChar ':' _ <- char ':' - _type <- parseText + _type <- parseType return $ NameAndType (Text.pack name) _type - toText (NameAndType name _type) = - Text.concat [ name , ":" , toText _type ] + typeToBuilder (NameAndType name _type) = + Builder.fromText name + <> Builder.singleton ':' + <> typeToBuilder _type + fromString' :: TypeParse t => String -> t fromString' = - either (error . ("Failed " ++)) id . fromText . Text.pack + either (error . ("Failed " ++)) id . typeFromText . Text.pack instance IsString ClassName where fromString = strCls diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-12.11 +resolver: lts-12.24 packages: - . flags: {} diff --git a/test/Language/JVM/Attribute/CodeTest.hs b/test/Language/JVM/Attribute/CodeTest.hs --- a/test/Language/JVM/Attribute/CodeTest.hs +++ b/test/Language/JVM/Attribute/CodeTest.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.JVM.Attribute.CodeTest where @@ -95,8 +96,14 @@ IfRef b on _ -> IfRef b on <$> arbitraryRef i Goto _ -> Goto <$> arbitraryRef i Jsr _ -> Jsr <$> arbitraryRef i - TableSwitch r (SwitchTable l ofss) -> - TableSwitch r . SwitchTable l <$> V.mapM (const $ arbitraryRef i) ofss + TableSwitch _ (SwitchTable l ofss) -> + TableSwitch + <$> arbitraryRef i + <*> (SwitchTable l <$> V.mapM (const $ arbitraryRef i) ofss) + LookupSwitch _ ofss -> + LookupSwitch + <$> arbitraryRef i + <*> V.mapM (\(a, _) -> (a,) <$> arbitraryRef i) ofss _ -> return x instance Arbitrary a => Arbitrary (V.Vector a) where @@ -104,20 +111,6 @@ instance Arbitrary ArrayType where arbitrary = genericArbitrary uniform - -instance Arbitrary (ExactArrayType High) where - arbitrary = - oneof - [ pure EABoolean - , pure EAByte - , pure EAChar - , pure EAShort - , pure EAInt - , pure EALong - , pure EAFloat - , pure EADouble - , EARef <$> arbitrary - ] instance Arbitrary BinOpr where arbitrary = genericArbitrary uniform 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 @@ -14,21 +14,21 @@ spec_JType_parsing :: Spec spec_JType_parsing = do it "can parse \"[B\" as an array" $ - parseOnly parseText "[B" `shouldBe` Right (JTArray (JTBase JTByte)) + parseOnly parseType "[B" `shouldBe` Right (JTRef (JTArray (JTBase JTByte))) it "can parse an array of strings" $ - parseOnly parseText "[Ljava/lang/String;" `shouldBe` - Right (JTArray (JTClass (ClassName "java/lang/String"))) + parseOnly parseType "[Ljava/lang/String;" `shouldBe` + Right (JTRef (JTArray (JTRef (JTClass (ClassName "java/lang/String"))))) spec_MethodDescriptor_parsing :: Spec spec_MethodDescriptor_parsing = do it "can parse the empty method" $ - parseOnly parseText "()V" `shouldBe` + parseOnly parseType "()V" `shouldBe` Right (MethodDescriptor [] Nothing) it "can parse method arguments" $ - parseOnly parseText "(BZ)B" `shouldBe` + parseOnly parseType "(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 + (typeFromText "(BZ)Bx" :: Either String MethodDescriptor) `shouldSatisfy` isLeft instance Arbitrary ClassName where arbitrary = pure $ ClassName "package/Main" @@ -37,6 +37,9 @@ arbitrary = genericArbitrary uniform instance Arbitrary JBaseType where + arbitrary = genericArbitrary uniform + +instance Arbitrary JRefType where arbitrary = genericArbitrary uniform instance Arbitrary MethodDescriptor where diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -46,6 +46,7 @@ import Language.JVM.Utils import Language.JVM.Staged import Language.JVM.ClassFileReader +import Language.JVM.ConstantPool blReadFile :: FilePath -> IO BL.ByteString blReadFile = BL.readFile @@ -109,7 +110,7 @@ isoRoundtrip a = case roundtrip a of Right (_, a') -> - a' === a + property $ a' `shouldBe` a Left msg -> property $ P.failed { P.reason = msg } where roundtrip a1 = do @@ -123,23 +124,22 @@ -- | Test that a value can go from the Highest state to binary and back again -- without losing data. isoByteCodeRoundtrip :: - (ByteCodeStaged a, Eq (a High), Show (a High), Binary (a Low)) + (ByteCodeStaged a, Eq (a High), Show (a Low), Show (a High), Binary (a Low)) => (a High) -> Property isoByteCodeRoundtrip a = case byteCodeRoundtrip a of - Right (_, a') -> - a' === a + Right ((_, b, cp), a') -> + counterexample (show cp ++ "\n" ++ show b) $ a' `shouldBe` a Left msg -> property $ P.failed { P.reason = msg } - where -byteCodeRoundtrip :: (ByteCodeStaged s, Binary (s Low)) => s High -> Either String (BL.ByteString, s High) +byteCodeRoundtrip :: (ByteCodeStaged s, Binary (s Low)) => s High -> Either String ((BL.ByteString, s Low, ConstantPool High), s High) byteCodeRoundtrip a1 = do let (a', CPBuilder _ cp) = runConstantPoolBuilder (devolveBC (return . fromIntegral) a1) cpbEmpty let bs = encode a' a'' <- bimap trd trd $ decodeOrFail bs cp' <- first show $ bootstrapConstantPool cp a3 <- first show $ runEvolve (EvolveConfig [] cp' (const True)) (evolveBC (return . fromIntegral) a'') - return (bs, a3) + return ((bs, a', cp'), a3) folderContents :: FilePath -> IO [ FilePath ] folderContents fp =