jvm-binary 0.2.0 → 0.3.0
raw patch · 14 files changed
+298/−206 lines, 14 files
Files
- CHANGELOG.md +5/−0
- jvm-binary.cabal +5/−4
- package.yaml +1/−1
- src/Language/JVM/Attribute/Signature.hs +18/−22
- src/Language/JVM/Attribute/StackMapTable.hs +5/−0
- src/Language/JVM/ByteCode.hs +67/−66
- src/Language/JVM/ClassFileReader.hs +10/−1
- src/Language/JVM/Constant.hs +16/−7
- src/Language/JVM/Method.hs +1/−1
- src/Language/JVM/Type.hs +144/−74
- stack.yaml +1/−1
- test/Language/JVM/Attribute/CodeTest.hs +9/−16
- test/Language/JVM/TypeTest.hs +9/−6
- test/SpecHelper.hs +7/−7
CHANGELOG.md view
@@ -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
jvm-binary.cabal view
@@ -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
package.yaml view
@@ -1,5 +1,5 @@ name: jvm-binary-version: '0.2.0'+version: '0.3.0' author: Christian Gram Kalhauge maintainer: Christian Gram Kalhauge <kalhauge@cs.ucla.edu> synopsis: A library for reading Java class-files
src/Language/JVM/Attribute/Signature.hs view
@@ -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}
src/Language/JVM/Attribute/StackMapTable.hs view
@@ -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
src/Language/JVM/ByteCode.hs view
@@ -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)
src/Language/JVM/ClassFileReader.hs view
@@ -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
src/Language/JVM/Constant.hs view
@@ -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
src/Language/JVM/Method.hs view
@@ -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
src/Language/JVM/Type.hs view
@@ -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
stack.yaml view
@@ -1,4 +1,4 @@-resolver: lts-12.11+resolver: lts-12.24 packages: - . flags: {}
test/Language/JVM/Attribute/CodeTest.hs view
@@ -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
test/Language/JVM/TypeTest.hs view
@@ -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
test/SpecHelper.hs view
@@ -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 =