jvm-binary 0.3.0 → 0.4.0
raw patch · 49 files changed
+1490/−1321 lines, 49 filesdep +hspecdep +hspec-discoverdep −tastydep −tasty-discoverdep −tasty-hspecdep ~base
Dependencies added: hspec, hspec-discover
Dependencies removed: tasty, tasty-discover, tasty-hspec, tasty-quickcheck
Dependency ranges changed: base
Files
- CHANGELOG.md +5/−0
- jvm-binary.cabal +27/−28
- package.yaml +7/−9
- src/Language/JVM/Attribute/Code.hs +6/−5
- src/Language/JVM/ByteCode.hs +52/−26
- src/Language/JVM/ClassFileReader.hs +27/−33
- src/Language/JVM/Constant.hs +8/−27
- src/Language/JVM/ConstantPool.hs +70/−18
- src/Language/JVM/Staged.hs +5/−1
- src/Language/JVM/TH.hs +14/−0
- stack.yaml +1/−1
- test/Language/JVM/Attribute/BootstrapMethodsSpec.hs +24/−0
- test/Language/JVM/Attribute/BootstrapMethodsTest.hs +0/−20
- test/Language/JVM/Attribute/CodeSpec.hs +178/−0
- test/Language/JVM/Attribute/CodeTest.hs +0/−171
- test/Language/JVM/Attribute/ConstantValueSpec.hs +23/−0
- test/Language/JVM/Attribute/ConstantValueTest.hs +0/−15
- test/Language/JVM/Attribute/EnclosingMethodSpec.hs +42/−0
- test/Language/JVM/Attribute/EnclosingMethodTest.hs +0/−39
- test/Language/JVM/Attribute/ExceptionsSpec.hs +19/−0
- test/Language/JVM/Attribute/ExceptionsTest.hs +0/−15
- test/Language/JVM/Attribute/InnerClassesSpec.hs +69/−0
- test/Language/JVM/Attribute/InnerClassesTest.hs +0/−64
- test/Language/JVM/Attribute/LineNumberTableSpec.hs +29/−0
- test/Language/JVM/Attribute/LineNumberTableTest.hs +0/−26
- test/Language/JVM/Attribute/SignatureSpec.hs +200/−0
- test/Language/JVM/Attribute/SignatureTest.hs +0/−194
- test/Language/JVM/Attribute/StackMapTableSpec.hs +80/−0
- test/Language/JVM/Attribute/StackMapTableTest.hs +0/−77
- test/Language/JVM/AttributeSpec.hs +24/−0
- test/Language/JVM/AttributeTest.hs +0/−23
- test/Language/JVM/ClassFileSpec.hs +47/−0
- test/Language/JVM/ClassFileTest.hs +0/−43
- test/Language/JVM/ConstantSpec.hs +140/−0
- test/Language/JVM/ConstantTest.hs +0/−124
- test/Language/JVM/FieldSpec.hs +30/−0
- test/Language/JVM/FieldTest.hs +0/−26
- test/Language/JVM/MethodSpec.hs +33/−0
- test/Language/JVM/MethodTest.hs +0/−29
- test/Language/JVM/TypeSpec.hs +55/−0
- test/Language/JVM/TypeTest.hs +0/−55
- test/Language/JVM/UtilsSpec.hs +64/−0
- test/Language/JVM/UtilsTest.hs +0/−64
- test/Language/JVMSpec.hs +179/−0
- test/Language/JVMTest.hs +0/−164
- test/Main.hs +4/−0
- test/Spec.hs +1/−0
- test/SpecHelper.hs +27/−23
- test/Test.hs +0/−1
CHANGELOG.md view
@@ -1,5 +1,10 @@ # Change log +## Version 0.4.0++- Add Offsets to ByteCode+- Small other changes+ ## Version 0.3.0 - Change API of TypeParse
jvm-binary.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: de6a2ad84e6004a7f51bebd6de23e07284fc0008745bb848cfd6e699444fcd36+-- hash: c647c3fda17f7dd5e2dfec53e2d17a639757b403bd624b71a5f60d831e136b7b name: jvm-binary-version: 0.3.0+version: 0.4.0 synopsis: A library for reading Java class-files description: A library for reading Java class-files. category: Language, Java, JVM@@ -35,7 +35,7 @@ ghc-options: -Wall build-depends: attoparsec- , base >=4.9 && <4.12+ , base >=4.9 && <4.13 , binary , bytestring , containers@@ -78,14 +78,14 @@ test-suite jvm-binary-test type: exitcode-stdio-1.0- main-is: Test.hs+ main-is: Main.hs hs-source-dirs: test ghc-options: -rtsopts -threaded -with-rtsopts=-N -fno-warn-orphans build-depends: QuickCheck , attoparsec- , base >=4.9 && <4.12+ , base >=4.9 && <4.13 , binary , bytestring , containers@@ -95,34 +95,33 @@ , directory , filepath , generic-random+ , hspec >=2.5.5+ , hspec-discover , hspec-expectations-pretty-diff , jvm-binary , mtl- , tasty- , tasty-discover- , tasty-hspec- , tasty-quickcheck , template-haskell , text , vector other-modules:- 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- Language.JVM.AttributeTest- Language.JVM.ClassFileTest- Language.JVM.ConstantTest- Language.JVM.FieldTest- Language.JVM.MethodTest- Language.JVM.TypeTest- Language.JVM.UtilsTest- Language.JVMTest+ Language.JVM.Attribute.BootstrapMethodsSpec+ Language.JVM.Attribute.CodeSpec+ Language.JVM.Attribute.ConstantValueSpec+ Language.JVM.Attribute.EnclosingMethodSpec+ Language.JVM.Attribute.ExceptionsSpec+ Language.JVM.Attribute.InnerClassesSpec+ Language.JVM.Attribute.LineNumberTableSpec+ Language.JVM.Attribute.SignatureSpec+ Language.JVM.Attribute.StackMapTableSpec+ Language.JVM.AttributeSpec+ Language.JVM.ClassFileSpec+ Language.JVM.ConstantSpec+ Language.JVM.FieldSpec+ Language.JVM.MethodSpec+ Language.JVM.TypeSpec+ Language.JVM.UtilsSpec+ Language.JVMSpec+ Spec SpecHelper Paths_jvm_binary default-language: Haskell2010@@ -132,10 +131,10 @@ main-is: Main.hs hs-source-dirs: benchmark- ghc-options: -rtsopts -threaded -funbox-strict-fields -with-rtsopts=-N+ ghc-options: -rtsopts -O2 -threaded -funbox-strict-fields -with-rtsopts=-N build-depends: attoparsec- , base >=4.9 && <4.12+ , base >=4.9 && <4.13 , binary , bytestring , containers
package.yaml view
@@ -1,5 +1,5 @@ name: jvm-binary-version: '0.3.0'+version: '0.4.0' author: Christian Gram Kalhauge maintainer: Christian Gram Kalhauge <kalhauge@cs.ucla.edu> synopsis: A library for reading Java class-files@@ -19,7 +19,7 @@ - stack.yaml dependencies:-- base >= 4.9 && < 4.12+- base >= 4.9 && < 4.13 - binary - bytestring - containers@@ -40,22 +40,19 @@ jvm-binary-test: dependencies: - jvm-binary- - tasty- - tasty-hspec- - tasty-discover- - tasty-quickcheck - QuickCheck- - filepath - directory- - text+ - filepath - generic-random+ - hspec >= 2.5.5+ - hspec-discover - hspec-expectations-pretty-diff ghc-options: - -rtsopts - -threaded - -with-rtsopts=-N - -fno-warn-orphans- main: Test.hs+ main: Main.hs source-dirs: test benchmarks:@@ -65,6 +62,7 @@ - criterion ghc-options: - -rtsopts+ - -O2 - -threaded - -funbox-strict-fields - -with-rtsopts=-N
src/Language/JVM/Attribute/Code.hs view
@@ -45,7 +45,7 @@ data Code r = Code { codeMaxStack :: !(Word16) , codeMaxLocals :: !(Word16)- , codeByteCode :: !((ByteCode r))+ , codeByteCode :: !(ByteCode r) , codeExceptionTable :: !(SizedList16 (ExceptionTable r)) , codeAttributes :: !(Attributes CodeAttributes r) }@@ -63,12 +63,12 @@ -- | Extracts a list of bytecode operation codeByteCodeOprs :: Code High -> V.Vector (ByteCodeOpr High) codeByteCodeOprs =- unByteCode . codeByteCode+ V.map opcode . codeByteCodeInsts -- | Extracts a list of bytecode instructions-codeByteCodeInsts :: Code Low -> V.Vector (ByteCodeInst Low)+codeByteCodeInsts :: Code i -> V.Vector (ByteCodeInst i) codeByteCodeInsts =- snd . unByteCode . codeByteCode+ byteCodeInstructions . codeByteCode -- | Returns the StackMapTable attribute if any codeStackMapTable :: Code High -> Maybe (StackMapTable High)@@ -86,7 +86,8 @@ (offsets, codeByteCode) <- evolveByteCode codeByteCode let evolver = (evolveOffset offsets) codeExceptionTable <- mapM (evolveBC evolver) codeExceptionTable- codeAttributes <- fromCollector <$> fromAttributes CodeAttribute (collect' evolver) codeAttributes+ codeAttributes <- fromCollector <$>+ fromAttributes CodeAttribute (collect' evolver) codeAttributes return $ Code {..} where fromCollector (a, b, c) =
src/Language/JVM/ByteCode.hs view
@@ -1,7 +1,9 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-}-{-# OPTIONS_GHC -funbox-strict-fields #-}+-- {-# OPTIONS_GHC -funbox-strict-fields #-} {-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -17,6 +19,7 @@ -} module Language.JVM.ByteCode ( ByteCode (..)+ , unByteCode -- * evolve and devolve , evolveByteCode@@ -91,14 +94,17 @@ import Language.JVM.Staged import Language.JVM.Type --- | ByteCode is a newtype wrapper around a list of ByteCode instructions.+-- | ByteCode constains a list of ByteCode instructions and the size of the bytecode. -- if the ByteCode is in the Low stage then the byte code instructions are -- annotated with the byte code offsets.-newtype ByteCode i = ByteCode- { unByteCode ::- Choice (Word32, V.Vector (ByteCodeInst Low)) (V.Vector (ByteCodeOpr High)) i+data ByteCode i = ByteCode+ { byteCodeSize :: !Word32+ , byteCodeInstructions :: V.Vector (ByteCodeInst i) } +unByteCode :: ByteCode i -> V.Vector (ByteCodeInst i)+unByteCode = byteCodeInstructions+ -- | The offset in the byte code type ByteCodeOffset = Word16 @@ -130,7 +136,7 @@ -- | Given low byte code we can create an `OffsetMap` offsetMap :: ByteCode Low -> OffsetMap-offsetMap (ByteCode (l, v)) =+offsetMap (ByteCode l v) = IM.fromList . ((fromIntegral l, V.length v):) . V.ifoldl' (\ls idx i -> (fromIntegral $ offset i, idx) : ls) []@@ -151,7 +157,7 @@ -- | Return the bytecode offset from the bytecode. indexOffset :: ByteCode Low -> ByteCodeIndex -> Maybe (ByteCodeOffset)-indexOffset (ByteCode (x, bc)) i =+indexOffset (ByteCode x bc) i = if i == V.length bc then return (fromIntegral x) else offset <$> bc V.!? i@@ -178,21 +184,20 @@ , opcode :: !(ByteCodeOpr r) } - evolveByteCode :: EvolveM m => ByteCode Low -> m (OffsetMap, ByteCode High)-evolveByteCode bc@(ByteCode (_, v)) = do+evolveByteCode bc@(ByteCode ln v) = do let !om = offsetMap bc- x <- V.mapM (fmap opcode . evolveByteCodeInst (evolveOffset om)) v- return . (om,) . ByteCode $! x+ x <- V.mapM (evolveByteCodeInst (evolveOffset om)) v+ return . (om,) $ ByteCode ln x devolveByteCode :: DevolveM m => ByteCode High -> m (ByteCode Low)-devolveByteCode (ByteCode bc) = do+devolveByteCode (ByteCode _ bc) = do -- Devolving byte code is not straight forward.- (len, offsets) <- generateOffsets bc- ByteCode . (fromIntegral len,)+ (len, offsets) <- generateOffsets (V.map opcode bc)+ ByteCode (fromIntegral len) <$> V.mapM (devolveByteCodeInst (devolveOffset' offsets))- (V.zipWith ByteCodeInst offsets bc)+ (V.zipWith (flip ByteCodeInst . opcode) bc offsets) generateOffsets :: DevolveM m => V.Vector (ByteCodeOpr High) -> m (Word16, V.Vector ByteCodeOffset) generateOffsets bc = do@@ -235,6 +240,7 @@ JTArray (JTBase bt) -> return $ ArrayBaseType bt c -> flip Reference (fromIntegral $ refTypeDepth c) <$> unlink c + evolveByteCodeInst :: EvolveM m => (ByteCodeOffset -> m ByteCodeIndex)@@ -263,9 +269,7 @@ calcOffset r = g (fromIntegral $ fromIntegral ofs + r) -{-# INLINABLE evolveByteCodeInst #-} - devolveByteCodeInst :: DevolveM m => (ByteCodeIndex -> m ByteCodeOffset)@@ -317,7 +321,7 @@ x <- getWord32be bs <- getLazyByteString (fromIntegral x) case runGetOrFail go bs of- Right (_,_,bcs) -> return . ByteCode . (x,) . V.fromList $ bcs+ Right (_,_,bcs) -> return . ByteCode x . V.fromList $ bcs Left (_,_,msg) -> fail msg where go = isEmpty >>= \t ->@@ -327,7 +331,7 @@ x <- get (x:) <$> go - put (ByteCode (_, lst))= do+ put (ByteCode _ lst)= do let bs = runPut (mapM_ put lst) putWord32be (fromIntegral $ BL.length bs) putLazyByteString bs@@ -336,7 +340,8 @@ get = do i <- (fromIntegral <$> bytesRead) x <- get- return $! ByteCodeInst i x+ return (ByteCodeInst i x)+ put x = putByteCode (offset x) $ opcode x @@ -366,10 +371,10 @@ deriving (Show, Eq, Ord, Generic, NFData) data Invocation r- = InvkSpecial !(DeepRef AbsVariableMethodId r)+ = InvkSpecial !(DeepRef AbsMethodId r) -- ^ Variable since 52.0 | InvkVirtual !(DeepRef AbsMethodId r)- | InvkStatic !(DeepRef AbsVariableMethodId r)+ | InvkStatic !(DeepRef AbsMethodId r) -- ^ Variable since 52.0 | InvkInterface !Word8 !(DeepRef AbsInterfaceMethodId r) -- ^ Should be a positive number@@ -932,10 +937,12 @@ _ -> fail $ "I do not know this bytecode '0x" ++ showHex cmd "'." - {-# INLINABLE get#-}+ {-# INLINABLE get #-} put = putByteCode 0 + {-# INLINE put #-}+ putByteCode :: Word16 -> ByteCodeOpr Low -> Put putByteCode n bc = case bc of@@ -1321,9 +1328,28 @@ IfRef False One a -> putWord8 0xc6 >> put a IfRef True One a -> putWord8 0xc7 >> put a +instance Eq (ByteCode High) where+ ByteCode _ a == ByteCode _ b =+ a == b -$(deriveBase ''ByteCode)-$(deriveBase ''ByteCodeInst)+instance Eq (ByteCode Low) where+ ByteCode i a == ByteCode j b =+ i == j && a == b++deriving instance Ord (ByteCode Low)++instance Eq (ByteCodeInst High) where+ ByteCodeInst _ a == ByteCodeInst _ b =+ a == b++instance Eq (ByteCodeInst Low) where+ ByteCodeInst i a == ByteCodeInst j b =+ i == j && a == b++deriving instance Ord (ByteCodeInst Low)++$(deriveThese ''ByteCode [''Show, ''Generic, ''NFData])+$(deriveThese ''ByteCodeInst [''Show, ''Generic, ''NFData]) $(deriveBase ''ByteCodeOpr) $(deriveBase ''SwitchTable) $(deriveBase ''Invocation)
src/Language/JVM/ClassFileReader.hs view
@@ -30,6 +30,7 @@ , runConstantPoolBuilder , CPBuilder (..) , builderFromConstantPool+ , constantPoolFromBuilder , cpbEmpty ) where @@ -39,11 +40,9 @@ import Control.Monad.State import Data.Binary 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@@ -88,7 +87,7 @@ devolveClassFile :: ClassFile High -> ClassFile Low devolveClassFile cf = let (cf', cpb) = runConstantPoolBuilder (devolve cf) cpbEmpty in- cf' { cConstantPool = cpbConstantPool cpb }+ cf' { cConstantPool = fromConstants (reverse $ cpbConstants cpb)} -- | Devolve a 'ClassFile' form 'High' to 'Low', while maintaining the class -- pool of the original class file. This is useful if we care that unread@@ -97,7 +96,7 @@ devolveClassFile' :: ConstantPool Low -> ClassFile High -> ClassFile Low devolveClassFile' cp cf = let (cf', cpb) = runConstantPoolBuilder (devolve cf) (builderFromConstantPool cp) in- cf' { cConstantPool = cpbConstantPool cpb }+ cf' { cConstantPool = constantPoolFromBuilder cpb } -- | Top level command that combines 'decode' and 'evolve'. readClassFile :: BL.ByteString -> Either ClassFileError (ClassFile High)@@ -184,29 +183,15 @@ -- might reference itself. bootstrapConstantPool :: ConstantPool Low -> Either ClassFileError (ConstantPool High) bootstrapConstantPool reffed =- case stage' IM.empty (IM.toList $ unConstantPool reffed) of- Right cp ->- Right $ ConstantPool cp- Left xs ->+ case growPool improve reffed of+ (cp, []) ->+ Right cp+ (_, xs) -> Left . CFEInconsistentClassPool "ConstantPool" $ "Could not load all constants in the constant pool: " ++ (show xs) where- stage' cp mis =- 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 :: 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)):))+ improve cp low =+ runEvolve (EvolveConfig [] cp (const True)) (evolve low) {-# SCC bootstrapConstantPool #-} @@ -214,19 +199,25 @@ data CPBuilder = CPBuilder { cpbMapper :: Map.Map (Constant Low) Index- , cpbConstantPool :: ConstantPool Low- }+ , cpbNextIndex :: Index+ , cpbConstants :: [Constant Low]+ } deriving (Show) cpbEmpty :: CPBuilder-cpbEmpty = CPBuilder Map.empty CP.empty+cpbEmpty = CPBuilder Map.empty 1 [] builderFromConstantPool :: ConstantPool Low -> CPBuilder builderFromConstantPool cp =- CPBuilder (Map.fromList . map change . IM.toList $ unConstantPool cp) cp+ CPBuilder (Map.fromList . map change . listConstants $ cp) (nextIndex cp) (map snd constants) where+ constants = listConstants cp change (a, b) = (b, fromIntegral a) +constantPoolFromBuilder :: CPBuilder -> ConstantPool Low+constantPoolFromBuilder cpb =+ fromConstants (reverse $ cpbConstants cpb) + newtype ConstantPoolBuilder a = ConstantPoolBuilder (State CPBuilder a) deriving (Monad, MonadState CPBuilder, Functor, Applicative)@@ -251,9 +242,12 @@ stateCPBuilder :: Constant Low -> CPBuilder- -> (Word16, CPBuilder)+ -> (Index, CPBuilder) stateCPBuilder c' cpb =- let (w, cp') = append c' . cpbConstantPool $ cpb in- (w, cpb { cpbConstantPool = cp'- , cpbMapper = Map.insert c' w . cpbMapper $ cpb- })+ let w = cpbNextIndex cpb+ in ( w+ , cpb+ { cpbNextIndex = w + constantSize c'+ , cpbConstants = c' : cpbConstants cpb+ , cpbMapper = Map.insert c' w . cpbMapper $ cpb+ })
src/Language/JVM/Constant.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE StrictData #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -32,7 +33,6 @@ , AbsMethodId , AbsFieldId , AbsInterfaceMethodId (..)- , AbsVariableMethodId (..) , MethodId (..) , FieldId (..)@@ -123,12 +123,6 @@ instance IsString MethodId where fromString = MethodId . fromString --- | In some cases we can both point to interface methods and--- regular methods.-data AbsVariableMethodId r- = VInterfaceMethodId !(AbsInterfaceMethodId r)- | VMethodId !(AbsMethodId r)- -- | The union type over the different method handles. data MethodHandle r = MHField !(MethodHandleField r)@@ -150,9 +144,9 @@ data MethodHandleMethod r = MHInvokeVirtual !(DeepRef AbsMethodId r)- | MHInvokeStatic !(DeepRef AbsVariableMethodId r)+ | MHInvokeStatic !(DeepRef AbsMethodId r) -- ^ Since version 52.0- | MHInvokeSpecial !(DeepRef AbsVariableMethodId r)+ | MHInvokeSpecial !(DeepRef AbsMethodId r) -- ^ Since version 52.0 | MHNewInvokeSpecial !(DeepRef AbsMethodId r) @@ -202,7 +196,7 @@ 15 -> CMethodHandle <$> get 16 -> CMethodType <$> get 18 -> CInvokeDynamic <$> get- _ -> fail $ "Unkown identifier " ++ show ident+ _ -> fail $ "Unknown identifier " ++ show ident put x = case x of@@ -264,7 +258,7 @@ -- 32, but is still awarded value 1. This is due to an -- [inconsistency](http://docs.oracle.com/javase/specs/jvms/se7/html/jvms-4.html#jvms-4.4.5) -- in JVM.-constantSize :: Constant r -> Int+constantSize :: Constant r -> Index constantSize x = case x of CDouble _ -> 2@@ -401,21 +395,6 @@ toConst (AbsInterfaceMethodId s) = return $ CInterfaceMethodRef s -instance Referenceable (AbsVariableMethodId High) where- fromConst _ (CInterfaceMethodRef s) = do- return . VInterfaceMethodId . AbsInterfaceMethodId $ s-- fromConst _ (CMethodRef s) = do- return . VMethodId $ s-- fromConst err c = expected "CInterfaceMethodRef or CMethodRef" err c-- toConst (VInterfaceMethodId (AbsInterfaceMethodId s)) =- return $ CInterfaceMethodRef s-- toConst (VMethodId s) =- return $ CMethodRef s- expected :: String -> (String -> a) -> (Constant r) -> a expected name err c = err $ wrongType name c@@ -441,7 +420,6 @@ $(deriveBaseWithBinary ''AbsMethodId) $(deriveBaseWithBinary ''AbsFieldId) $(deriveBaseWithBinary ''AbsInterfaceMethodId)-$(deriveBaseWithBinary ''AbsVariableMethodId) -- | A constant pool value in java data JValue@@ -467,7 +445,9 @@ CMethodHandle m -> return $ VMethodHandle m CMethodType t -> return $ VMethodType t x -> expected "Expected a Value" err x+ {-# INLINE fromConst #-} + toConst c = return $ case c of VString s -> CStringRef s@@ -478,3 +458,4 @@ VClass (ClassName r) -> CClassRef r VMethodHandle m -> CMethodHandle m VMethodType t -> CMethodType t+ {-# INLINE toConst #-}
src/Language/JVM/ConstantPool.hs view
@@ -1,6 +1,4 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE DeriveFunctor #-}--- {-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -9,6 +7,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-} {-| Copyright : (c) Christian Gram Kalhauge, 2018 License : MIT@@ -21,22 +21,36 @@ ( -- * Constant Pool -- $ConstantPool- ConstantPool (..)+ ConstantPool , access- , append++ , growPool++ , poolCount+ , nextIndex+ , listConstants+ , fromConstants+ , empty , PoolAccessError (..)++ , Index ) where -import Control.DeepSeq (NFData)+import Control.DeepSeq (NFData) import Control.Monad.Except import Data.Binary -- import Debug.Trace import Data.Binary.Get import Data.Binary.Put-import qualified Data.IntMap as IM-import GHC.Generics (Generic)+import GHC.Generics (Generic) +-- base+import Data.Monoid++-- containers+import qualified Data.IntMap as IM+ import Language.JVM.Constant import Language.JVM.Stage import Language.JVM.TH@@ -62,12 +76,12 @@ go len n | len > n = do constant <- get rest <- go len (n + constantSize constant)- return $ (n, constant) : rest+ return $ (fromIntegral n, constant) : rest go _ _ = return [] put (ConstantPool p) = do case IM.maxViewWithKey p of Just ((key, e), _) -> do- putInt16be (fromIntegral (key + constantSize e))+ putWord16be (fromIntegral key + constantSize e) forM_ (IM.toAscList p) (put . snd) Nothing -> do putInt16be 0@@ -88,19 +102,57 @@ access :: Index -> ConstantPool r -> Either PoolAccessError (Constant r) access ref (ConstantPool cp) = case IM.lookup (fromIntegral ref) cp of- Just x -> Right x+ Just x -> Right x Nothing -> Left $ PoolAccessError ref "No such element." +poolCount :: ConstantPool r -> Int+poolCount =+ IM.size . unConstantPool +listConstants :: ConstantPool r -> [(Index, Constant r)]+listConstants =+ map (\(i, a) -> (fromIntegral i, a)) . IM.toList . unConstantPool++nextIndex :: ConstantPool r -> Index+nextIndex (ConstantPool im) =+ fromIntegral $ case IM.toDescList im of+ (k, a):_ -> fromIntegral k + constantSize a+ _ -> 1++fromConstants :: Foldable f => f (Constant r) -> ConstantPool r+fromConstants =+ foldl (\b a -> snd . append a $ b) empty++growPool ::+ forall b.+ (ConstantPool High -> Constant Low -> Either b (Constant High))+ -> ConstantPool Low+ -> (ConstantPool High, [(b, (Index, Constant Low))])+growPool f reffed =+ stage' IM.empty (listConstants reffed)+ where+ stage' :: IM.IntMap (Constant High) -> [(Index, Constant Low)] -> (ConstantPool High, [(b, (Index, Constant Low))])+ stage' cp mis =+ case foldMap (grow (ConstantPool cp)) mis of+ (cp', flip appEndo [] -> mis')+ | IM.null cp' ->+ (ConstantPool cp, mis')+ | otherwise ->+ stage' (cp `IM.union` cp') . map snd $ mis'++ grow cp (k,a) =+ case f cp a of+ Right c -> (IM.singleton (fromIntegral k) c, mempty)+ Left b -> (IM.empty, Endo ((b, (k,a)):) )+++{-# INLINE growPool #-}+ -- | Append a constant to the constant pool, and get the offset. append :: Constant r -> ConstantPool r -> (Index, ConstantPool r)-append c (ConstantPool cp) =- (fromIntegral i, ConstantPool $ IM.insert i c cp)+append c cp@(ConstantPool im) =+ (i, ConstantPool $ IM.insert (fromIntegral i) c im) where- i =- case IM.toDescList cp of- (k, a):_ ->- k + constantSize a- _ -> 1+ i = nextIndex cp $(deriveBase ''ConstantPool)
src/Language/JVM/Staged.hs view
@@ -34,6 +34,7 @@ label :: String -> m a -> m a -- ^ label the current position in the class-file, good for debugging label _ = id+ {-# INLINE label #-} data AttributeLocation = ClassAttribute@@ -54,12 +55,15 @@ {-# MINIMAL stage | evolve, devolve #-} stage :: LabelM m => (forall s'. Staged s' => s' r -> m (s' r')) -> s r -> m (s r') stage f a = f a+ {-# INLINE stage #-} evolve :: EvolveM m => s Low -> m (s High) evolve = stage evolve+ {-# INLINE evolve #-} devolve :: DevolveM m => s High -> m (s Low) devolve = stage devolve+ {-# INLINE devolve #-} instance Staged Constant where evolve c =@@ -75,7 +79,7 @@ CMethodRef r -> label "CMethodRef" $ CMethodRef <$> evolve r CInterfaceMethodRef r -> label "CInterfaceMethodRef" $ CInterfaceMethodRef <$> evolve r CNameAndType r1 r2 -> label "CNameAndType" $ CNameAndType <$> link r1 <*> link r2- CMethodHandle mh -> label "CMetho" $ CMethodHandle <$> evolve mh+ CMethodHandle mh -> label "CMethodHandle" $ CMethodHandle <$> evolve mh CMethodType r -> label "CMethodType" $ CMethodType <$> link r CInvokeDynamic i -> label "CInvokeDynamic" $ CInvokeDynamic <$> evolve i
src/Language/JVM/TH.hs view
@@ -14,6 +14,7 @@ module Language.JVM.TH ( deriveBase , deriveBases+ , deriveThese , deriveBaseWithBinary ) where @@ -24,6 +25,19 @@ import Data.Binary import Language.JVM.Stage+++-- | Derives the 'NFData', 'Show', 'Eq', and 'Generic'+-- from something that is 'Staged'+deriveThese :: Name -> [Name] -> Q [Dec]+deriveThese name items =+ return . concat $ do+ x <- ConT <$> items+ return+ [ StandaloneDerivD Nothing [] (AppT x (AppT n (ConT ''High)))+ , StandaloneDerivD Nothing [] (AppT x (AppT n (ConT ''Low)))+ ]+ where n = ConT name -- | Derives the 'NFData', 'Show', 'Eq', and 'Generic' -- from something that is 'Staged'
stack.yaml view
@@ -1,4 +1,4 @@-resolver: lts-12.24+resolver: lts-12.26 packages: - . flags: {}
+ test/Language/JVM/Attribute/BootstrapMethodsSpec.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE FlexibleInstances #-}++module Language.JVM.Attribute.BootstrapMethodsSpec where++import SpecHelper++import Language.JVM.ConstantSpec ()++import Language.JVM.Attribute.BootstrapMethods+import Language.JVM++spec :: Spec+spec =+ it "can do a roundtrip" $ property $ prop_roundtrip_BootstrapMethods++prop_roundtrip_BootstrapMethods :: BootstrapMethods High -> Property+prop_roundtrip_BootstrapMethods = isoRoundtrip++instance Arbitrary (BootstrapMethods High) where+ arbitrary = genericArbitraryU++instance Arbitrary (BootstrapMethod High) where+ arbitrary =+ BootstrapMethod <$> arbitrary <*> (SizedList <$> pure [])
− test/Language/JVM/Attribute/BootstrapMethodsTest.hs
@@ -1,20 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}--module Language.JVM.Attribute.BootstrapMethodsTest where--import SpecHelper--import Language.JVM.ConstantTest ()--import Language.JVM.Attribute.BootstrapMethods-import Language.JVM--prop_roundtrip_BootstrapMethods :: BootstrapMethods High -> Property-prop_roundtrip_BootstrapMethods = isoRoundtrip--instance Arbitrary (BootstrapMethods High) where- arbitrary = genericArbitraryU--instance Arbitrary (BootstrapMethod High) where- arbitrary =- BootstrapMethod <$> arbitrary <*> (SizedList <$> listOf (resize 1 arbitrary))
+ test/Language/JVM/Attribute/CodeSpec.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Language.JVM.Attribute.CodeSpec where++import qualified Data.Vector as V+import Generic.Random+++import SpecHelper++import Language.JVM.Attribute.LineNumberTableSpec ()+import Language.JVM.Attribute.StackMapTableSpec ()+import Language.JVM.AttributeSpec ()+import Language.JVM.UtilsSpec ()++import Language.JVM+import Language.JVM.Attribute.Code+++spec :: Spec+spec = do+ it "can do a roundtrip on Code" $ property $ prop_roundtrip_Code+ it "can do a roundtrip on ExceptionTable" $ property $ prop_roundtrip_ExceptionTable+ it "can do a roundtrip on ByteCodeInst" $ property $ prop_roundtrip_ByteCodeInst+ spec_ByteCode_examples++prop_roundtrip_Code :: Code High -> Property+prop_roundtrip_Code = isoRoundtrip++-- prop_roundtrip_ByteCode :: ByteCode High -> Property+-- prop_roundtrip_ByteCode = isoRoundtrip++prop_roundtrip_ExceptionTable :: ExceptionTable High -> Property+prop_roundtrip_ExceptionTable = isoByteCodeRoundtrip++prop_roundtrip_ByteCodeInst :: ByteCodeInst High -> Property+prop_roundtrip_ByteCodeInst = isoByteCodeRoundtrip+++spec_ByteCode_examples :: SpecWith ()+spec_ByteCode_examples = do+ it "can round trip 'push (i127)'" $ do+ let opr = ByteCodeInst 0 (Push (Just (VInteger 127)))+ (snd <$> byteCodeRoundtrip opr) `shouldBe` Right opr++ it "can round trip 'push (i-129)'" $ do+ let opr = ByteCodeInst 0 (Push (Just (VInteger (-129))))+ (snd <$> byteCodeRoundtrip opr) `shouldBe` Right opr++instance Arbitrary (Code High) where+ arbitrary = do+ bc <- arbitrary+ Code+ <$> arbitrary+ <*> arbitrary+ <*> pure bc+ <*> (SizedList <$> listOf (genExceptionTable (fromIntegral . V.length . byteCodeInstructions $ bc)))+ <*> pure (CodeAttributes [] [] [])++genExceptionTable :: Int -> Gen (ExceptionTable High)+genExceptionTable i =+ ExceptionTable+ <$> (arbitraryRef i)+ <*> (arbitraryRef i)+ <*> (arbitraryRef i)+ <*> arbitrary++arbitraryRef :: Int -> Gen Int+arbitraryRef i =+ choose (0, i - 1)++instance Arbitrary (CodeAttributes High) where+ arbitrary = genericArbitraryU++instance Arbitrary (ExceptionTable High) where+ arbitrary =+ ExceptionTable <$> arbitraryRef 0xffff <*> arbitraryRef 0xffff <*> arbitraryRef 0xffff <*> arbitrary++instance Arbitrary (ByteCode High) where+ arbitrary = do+ s <- getSize+ ByteCode 0 . V.map (ByteCodeInst 0) . V.fromList <$> vectorOf s (genByteCodeOpr s)++instance Arbitrary (ByteCodeInst High) where+ arbitrary =+ ByteCodeInst 0 <$> genByteCodeOpr 0xffff++instance Arbitrary ArithmeticType where+ arbitrary = elements [ MInt, MLong, MFloat, MDouble ]++instance Arbitrary LocalType where+ arbitrary = elements [ LInt, LLong, LFloat, LDouble, LRef ]++genByteCodeOpr :: Int -> Gen (ByteCodeOpr High)+genByteCodeOpr i = do+ x <- (genericArbitraryU :: Gen (ByteCodeOpr High))+ case x of+ If cp on _ -> If cp on <$> arbitraryRef i+ IfRef b on _ -> IfRef b on <$> arbitraryRef i+ Goto _ -> Goto <$> arbitraryRef i+ Jsr _ -> Jsr <$> arbitraryRef i+ 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+ arbitrary = V.fromList <$> arbitrary++instance Arbitrary ArrayType where+ arbitrary = genericArbitrary uniform++instance Arbitrary BinOpr where+ arbitrary = genericArbitrary uniform++instance Arbitrary CastOpr where+ arbitrary =+ oneof . map pure $+ [ CastTo MInt MLong+ , CastTo MInt MFloat+ , CastTo MInt MDouble++ , CastTo MLong MInt+ , CastTo MLong MFloat+ , CastTo MLong MDouble++ , CastTo MFloat MInt+ , CastTo MFloat MLong+ , CastTo MFloat MDouble++ , CastTo MDouble MInt+ , CastTo MDouble MLong+ , CastTo MDouble MFloat++ , CastDown MByte+ , CastDown MChar+ , CastDown MShort+ ]++instance Arbitrary BitOpr where+ arbitrary = genericArbitraryU++instance Arbitrary OneOrTwo where+ arbitrary = genericArbitraryU++instance Arbitrary SmallArithmeticType where+ arbitrary = genericArbitraryU++instance Arbitrary CmpOpr where+ arbitrary = genericArbitraryU++instance Arbitrary FieldAccess where+ arbitrary = genericArbitrary uniform++instance Arbitrary (Invocation High) where+ arbitrary =+ oneof+ [ InvkSpecial <$> arbitrary+ , InvkVirtual <$> arbitrary+ , InvkStatic <$> arbitrary+ , InvkInterface <$> (arbitrary `suchThat` \i -> i > 0) <*> arbitrary+ , InvkDynamic <$> arbitrary+ ]+instance Arbitrary (CConstant High) where+ arbitrary = genericArbitraryU++instance Arbitrary (SwitchTable High) where+ arbitrary = genericArbitraryU+
− test/Language/JVM/Attribute/CodeTest.hs
@@ -1,171 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TupleSections #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Language.JVM.Attribute.CodeTest where--import qualified Data.Vector as V-import Generic.Random---import SpecHelper--import Language.JVM.Attribute.LineNumberTableTest ()-import Language.JVM.Attribute.StackMapTableTest ()-import Language.JVM.AttributeTest ()-import Language.JVM.UtilsTest ()--import Language.JVM-import Language.JVM.Attribute.Code--prop_roundtrip_Code :: Code High -> Property-prop_roundtrip_Code = isoRoundtrip---- prop_roundtrip_ByteCode :: ByteCode High -> Property--- prop_roundtrip_ByteCode = isoRoundtrip--prop_roundtrip_ExceptionTable :: ExceptionTable High -> Property-prop_roundtrip_ExceptionTable = isoByteCodeRoundtrip--prop_roundtrip_ByteCodeInst :: ByteCodeInst High -> Property-prop_roundtrip_ByteCodeInst = isoByteCodeRoundtrip---spec_ByteCode_examples :: SpecWith ()-spec_ByteCode_examples = do- it "can round trip 'push (i127)'" $ do- let opr = ByteCodeInst 0 (Push (Just (VInteger 127)))- (snd <$> byteCodeRoundtrip opr) `shouldBe` Right opr-- it "can round trip 'push (i-129)'" $ do- let opr = ByteCodeInst 0 (Push (Just (VInteger (-129))))- (snd <$> byteCodeRoundtrip opr) `shouldBe` Right opr--instance Arbitrary (Code High) where- arbitrary = do- bc <- arbitrary- Code- <$> arbitrary- <*> arbitrary- <*> pure bc- <*> (SizedList <$> listOf (genExceptionTable (fromIntegral . V.length . unByteCode $ bc)))- <*> pure (CodeAttributes [] [] [])--genExceptionTable :: Int -> Gen (ExceptionTable High)-genExceptionTable i =- ExceptionTable- <$> (arbitraryRef i)- <*> (arbitraryRef i)- <*> (arbitraryRef i)- <*> arbitrary--arbitraryRef :: Int -> Gen Int-arbitraryRef i =- choose (0, i - 1)--instance Arbitrary (CodeAttributes High) where- arbitrary = genericArbitraryU--instance Arbitrary (ExceptionTable High) where- arbitrary =- ExceptionTable <$> arbitraryRef 0xffff <*> arbitraryRef 0xffff <*> arbitraryRef 0xffff <*> arbitrary--instance Arbitrary (ByteCode High) where- arbitrary = do- s <- getSize- ByteCode . V.fromList <$> vectorOf s (genByteCodeOpr s)--instance Arbitrary (ByteCodeInst High) where- arbitrary =- ByteCodeInst <$> pure 0 <*> genByteCodeOpr 0xffff--instance Arbitrary ArithmeticType where- arbitrary = elements [ MInt, MLong, MFloat, MDouble ]--instance Arbitrary LocalType where- arbitrary = elements [ LInt, LLong, LFloat, LDouble, LRef ]---genByteCodeOpr :: Int -> Gen (ByteCodeOpr High)-genByteCodeOpr i = do- x <- (genericArbitraryU :: Gen (ByteCodeOpr High))- case x of- If cp on _ -> If cp on <$> arbitraryRef i- IfRef b on _ -> IfRef b on <$> arbitraryRef i- Goto _ -> Goto <$> arbitraryRef i- Jsr _ -> Jsr <$> arbitraryRef i- 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- arbitrary = V.fromList <$> arbitrary--instance Arbitrary ArrayType where- arbitrary = genericArbitrary uniform--instance Arbitrary BinOpr where- arbitrary = genericArbitrary uniform--instance Arbitrary CastOpr where- arbitrary =- oneof . map pure $- [ CastTo MInt MLong- , CastTo MInt MFloat- , CastTo MInt MDouble-- , CastTo MLong MInt- , CastTo MLong MFloat- , CastTo MLong MDouble-- , CastTo MFloat MInt- , CastTo MFloat MLong- , CastTo MFloat MDouble-- , CastTo MDouble MInt- , CastTo MDouble MLong- , CastTo MDouble MFloat-- , CastDown MByte- , CastDown MChar- , CastDown MShort- ]--instance Arbitrary BitOpr where- arbitrary = genericArbitraryU--instance Arbitrary OneOrTwo where- arbitrary = genericArbitraryU--instance Arbitrary SmallArithmeticType where- arbitrary = genericArbitraryU--instance Arbitrary CmpOpr where- arbitrary = genericArbitraryU--instance Arbitrary FieldAccess where- arbitrary = genericArbitrary uniform--instance Arbitrary (Invocation High) where- arbitrary =- oneof- [ InvkSpecial <$> arbitrary- , InvkVirtual <$> arbitrary- , InvkStatic <$> arbitrary- , InvkInterface <$> (arbitrary `suchThat` \i -> i > 0) <*> arbitrary- , InvkDynamic <$> arbitrary- ]-instance Arbitrary (CConstant High) where- arbitrary = genericArbitraryU--instance Arbitrary (SwitchTable High) where- arbitrary = genericArbitraryU-
+ test/Language/JVM/Attribute/ConstantValueSpec.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.JVM.Attribute.ConstantValueSpec where++import SpecHelper++import Language.JVM.ConstantSpec ()++import Language.JVM+import Language.JVM.Attribute.ConstantValue++spec :: Spec+spec = do+ it "can do a roundtrip on a VClass" $+ prop_roundtrip_ConstantValue (ConstantValue (VClass "this/class"))+ it "can do a roundtrip" $ property $ prop_roundtrip_ConstantValue++prop_roundtrip_ConstantValue :: ConstantValue High -> Property+prop_roundtrip_ConstantValue = isoRoundtrip++instance Arbitrary (ConstantValue High) where+ arbitrary = genericArbitraryU
− test/Language/JVM/Attribute/ConstantValueTest.hs
@@ -1,15 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}--module Language.JVM.Attribute.ConstantValueTest where--import SpecHelper--import Language.JVM.ConstantTest ()--import Language.JVM--prop_roundtrip_ConstantValue :: ConstantValue High -> Property-prop_roundtrip_ConstantValue = isoRoundtrip--instance Arbitrary (ConstantValue High) where- arbitrary = genericArbitraryU
+ test/Language/JVM/Attribute/EnclosingMethodSpec.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.JVM.Attribute.EnclosingMethodSpec where++import SpecHelper++import Language.JVM.ConstantSpec ()++import Language.JVM.Attribute.EnclosingMethod+import Language.JVM++prop_roundtrip_EnclosingMethodSpec :: EnclosingMethod High -> Property+prop_roundtrip_EnclosingMethodSpec = isoRoundtrip++spec :: Spec+spec =+ spec_enclosing++spec_enclosing :: SpecWith ()+spec_enclosing = do+ it "can find an enclosing method in 'Streams$5'" $ do+ tc <- withTestClass "Streams$5"+ cEnclosingMethod tc `shouldBe`+ Just (EnclosingMethod+ "com/google/common/collect/Streams"+ (Just ("mapWithIndex:(Ljava/util/stream/DoubleStream;Lcom/google/common/collect/Streams$DoubleFunctionWithIndex;)Ljava/util/stream/Stream;"))+ )++-- test_real_signatures :: SpecWith ()+-- test_real_signatures = do+-- it "can handle Iterator" $ do+-- let signature = "<T:Ljava/lang/Object;>Ljava/lang/Object;"++instance Arbitrary (EnclosingMethod High) where+ arbitrary = genericArbitraryU+++ -- "Lcom/apple/eawt/_AppEventHandler$_AppEventDispatcher<Lcom/apple/eawt/QuitHandler;>;"+-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor<Lcom/apple/eawt/ScreenSleepListener;Lcom/apple/eawt/AppEvent$ScreenSleepEvent;>;"+-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor<Lcom/apple/eawt/SystemSleepListener;Lcom/apple/eawt/AppEvent$SystemSleepEvent;>;"+-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor<Lcom/apple/eawt/UserSessionListener;Lcom/apple/eawt/AppEvent$UserSessionEvent;>;"
− test/Language/JVM/Attribute/EnclosingMethodTest.hs
@@ -1,39 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}--module Language.JVM.Attribute.EnclosingMethodTest where--import SpecHelper--import Language.JVM.ConstantTest ()--import Language.JVM.Attribute.EnclosingMethod-import Language.JVM--prop_roundtrip_EnclosingMethodTest :: EnclosingMethod High -> Property-prop_roundtrip_EnclosingMethodTest = isoRoundtrip---spec_enclosing :: SpecWith ()-spec_enclosing = do- it "can find an enclosing method in 'Streams$5'" $ do- tc <- withTestClass "Streams$5"- cEnclosingMethod tc `shouldBe`- Just (EnclosingMethod- "com/google/common/collect/Streams"- (Just ("mapWithIndex:(Ljava/util/stream/DoubleStream;Lcom/google/common/collect/Streams$DoubleFunctionWithIndex;)Ljava/util/stream/Stream;"))- )---- test_real_signatures :: SpecWith ()--- test_real_signatures = do--- it "can handle Iterator" $ do--- let signature = "<T:Ljava/lang/Object;>Ljava/lang/Object;"--instance Arbitrary (EnclosingMethod High) where- arbitrary = genericArbitraryU--- -- "Lcom/apple/eawt/_AppEventHandler$_AppEventDispatcher<Lcom/apple/eawt/QuitHandler;>;"--- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor<Lcom/apple/eawt/ScreenSleepListener;Lcom/apple/eawt/AppEvent$ScreenSleepEvent;>;"--- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor<Lcom/apple/eawt/SystemSleepListener;Lcom/apple/eawt/AppEvent$SystemSleepEvent;>;"--- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor<Lcom/apple/eawt/UserSessionListener;Lcom/apple/eawt/AppEvent$UserSessionEvent;>;"
+ test/Language/JVM/Attribute/ExceptionsSpec.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE FlexibleInstances #-}++module Language.JVM.Attribute.ExceptionsSpec where++import SpecHelper++import Language.JVM++import Language.JVM.ConstantSpec ()++spec :: Spec+spec =+ it "can do a roundtrip" $ property $ prop_roundtrip_Exceptions++prop_roundtrip_Exceptions :: Exceptions High -> Property+prop_roundtrip_Exceptions = isoRoundtrip++instance Arbitrary (Exceptions High) where+ arbitrary = genericArbitraryU
− test/Language/JVM/Attribute/ExceptionsTest.hs
@@ -1,15 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}--module Language.JVM.Attribute.ExceptionsTest where--import SpecHelper--import Language.JVM--import Language.JVM.ConstantTest ()--prop_roundtrip_Exceptions :: Exceptions High -> Property-prop_roundtrip_Exceptions = isoRoundtrip--instance Arbitrary (Exceptions High) where- arbitrary = genericArbitraryU
+ test/Language/JVM/Attribute/InnerClassesSpec.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.JVM.Attribute.InnerClassesSpec where++import SpecHelper+import qualified Data.Set as S++import Language.JVM.ConstantSpec ()++import Language.JVM.Attribute.InnerClasses+import Language.JVM++spec :: Spec+spec = do+ it "can do a roundtrip" $ property $ prop_roundtrip_InnerClassesSpec+ spec_inner_classes++prop_roundtrip_InnerClassesSpec :: InnerClasses High -> Property+prop_roundtrip_InnerClassesSpec = isoRoundtrip++spec_inner_classes :: SpecWith ()+spec_inner_classes = do+ it "can find the inner classes of 'Streams$5'" $ do+ tc <- withTestClass "Streams$5"+ cInnerClasses tc `shouldBe`+ [+ InnerClass {+ icClassName = "java/util/PrimitiveIterator$OfDouble",+ icOuterClassName = Just "java/util/PrimitiveIterator",+ icInnerName = Just "OfDouble",+ icInnerAccessFlags = BitSet $ S.fromList [ICPublic, ICStatic, ICInterface, ICAbstract]+ },+ InnerClass {+ icClassName = "com/google/common/collect/Streams$DoubleFunctionWithIndex",+ icOuterClassName = Just "com/google/common/collect/Streams",+ icInnerName = Just "DoubleFunctionWithIndex",+ icInnerAccessFlags = BitSet $ S.fromList [ICPublic, ICStatic, ICInterface, ICAbstract]+ },+ InnerClass {+ icClassName = "com/google/common/collect/Streams$5",+ icOuterClassName = Nothing,+ icInnerName = Nothing,+ icInnerAccessFlags = BitSet $ S.fromList [ ICStatic ]+ },+ InnerClass {+ icClassName = "java/util/Spliterators$AbstractSpliterator",+ icOuterClassName = Just "java/util/Spliterators",+ icInnerName = Just "AbstractSpliterator",+ icInnerAccessFlags = BitSet $ S.fromList [ICPublic, ICStatic, ICAbstract]+ }+ ]++-- test_real_signatures :: SpecWith ()+-- test_real_signatures = do+-- it "can handle Iterator" $ do+-- let signature = "<T:Ljava/lang/Object;>Ljava/lang/Object;"++instance Arbitrary (InnerClasses High) where+ arbitrary = genericArbitraryU++instance Arbitrary (InnerClass High) where+ arbitrary = genericArbitraryU+++ -- "Lcom/apple/eawt/_AppEventHandler$_AppEventDispatcher<Lcom/apple/eawt/QuitHandler;>;"+-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor<Lcom/apple/eawt/ScreenSleepListener;Lcom/apple/eawt/AppEvent$ScreenSleepEvent;>;"+-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor<Lcom/apple/eawt/SystemSleepListener;Lcom/apple/eawt/AppEvent$SystemSleepEvent;>;"+-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor<Lcom/apple/eawt/UserSessionListener;Lcom/apple/eawt/AppEvent$UserSessionEvent;>;"
− test/Language/JVM/Attribute/InnerClassesTest.hs
@@ -1,64 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}--module Language.JVM.Attribute.InnerClassesTest where--import SpecHelper-import qualified Data.Set as S--import Language.JVM.ConstantTest ()--import Language.JVM.Attribute.InnerClasses-import Language.JVM--prop_roundtrip_InnerClassesTest :: InnerClasses High -> Property-prop_roundtrip_InnerClassesTest = isoRoundtrip--spec_inner_classes :: SpecWith ()-spec_inner_classes = do- it "can find the inner classes of 'Streams$5'" $ do- tc <- withTestClass "Streams$5"- cInnerClasses tc `shouldBe`- [- InnerClass {- icClassName = "java/util/PrimitiveIterator$OfDouble",- icOuterClassName = Just "java/util/PrimitiveIterator",- icInnerName = Just "OfDouble",- icInnerAccessFlags = BitSet $ S.fromList [ICPublic, ICStatic, ICInterface, ICAbstract]- },- InnerClass {- icClassName = "com/google/common/collect/Streams$DoubleFunctionWithIndex",- icOuterClassName = Just "com/google/common/collect/Streams",- icInnerName = Just "DoubleFunctionWithIndex",- icInnerAccessFlags = BitSet $ S.fromList [ICPublic, ICStatic, ICInterface, ICAbstract]- },- InnerClass {- icClassName = "com/google/common/collect/Streams$5",- icOuterClassName = Nothing,- icInnerName = Nothing,- icInnerAccessFlags = BitSet $ S.fromList [ ICStatic ]- },- InnerClass {- icClassName = "java/util/Spliterators$AbstractSpliterator",- icOuterClassName = Just "java/util/Spliterators",- icInnerName = Just "AbstractSpliterator",- icInnerAccessFlags = BitSet $ S.fromList [ICPublic, ICStatic, ICAbstract]- }- ]---- test_real_signatures :: SpecWith ()--- test_real_signatures = do--- it "can handle Iterator" $ do--- let signature = "<T:Ljava/lang/Object;>Ljava/lang/Object;"--instance Arbitrary (InnerClasses High) where- arbitrary = genericArbitraryU--instance Arbitrary (InnerClass High) where- arbitrary = genericArbitraryU--- -- "Lcom/apple/eawt/_AppEventHandler$_AppEventDispatcher<Lcom/apple/eawt/QuitHandler;>;"--- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor<Lcom/apple/eawt/ScreenSleepListener;Lcom/apple/eawt/AppEvent$ScreenSleepEvent;>;"--- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor<Lcom/apple/eawt/SystemSleepListener;Lcom/apple/eawt/AppEvent$SystemSleepEvent;>;"--- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor<Lcom/apple/eawt/UserSessionListener;Lcom/apple/eawt/AppEvent$UserSessionEvent;>;"
+ test/Language/JVM/Attribute/LineNumberTableSpec.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Language.JVM.Attribute.LineNumberTableSpec where++import qualified Data.IntMap as IM++import SpecHelper++import Language.JVM.AttributeSpec ()+import Language.JVM.ConstantSpec ()+import Language.JVM.TypeSpec ()+import Language.JVM.UtilsSpec ()++import Language.JVM+import Language.JVM.Attribute.LineNumberTable++spec :: Spec+spec = return ()++-- prop_roundtrip_LineNumberTable :: LineNumberTable High -> Property+-- prop_roundtrip_LineNumberTable = isoRoundtrip++instance Arbitrary (LineNumberTable High) where+ arbitrary =+ LineNumberTable . IM.fromList . map f . unSizedList <$> (arbitrary :: Gen BinaryFormat)+ where+ f (a,b) = (fromIntegral a, b)
− test/Language/JVM/Attribute/LineNumberTableTest.hs
@@ -1,26 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Language.JVM.Attribute.LineNumberTableTest where--import qualified Data.IntMap as IM--import SpecHelper--import Language.JVM.AttributeTest ()-import Language.JVM.ConstantTest ()-import Language.JVM.TypeTest ()-import Language.JVM.UtilsTest ()--import Language.JVM-import Language.JVM.Attribute.LineNumberTable---- prop_roundtrip_LineNumberTable :: LineNumberTable High -> Property--- prop_roundtrip_LineNumberTable = isoRoundtrip--instance Arbitrary (LineNumberTable High) where- arbitrary =- LineNumberTable . IM.fromList . map f . unSizedList <$> (arbitrary :: Gen BinaryFormat)- where- f (a,b) = (fromIntegral a, b)
+ test/Language/JVM/Attribute/SignatureSpec.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.JVM.Attribute.SignatureSpec where++import SpecHelper++import Language.JVM.ConstantSpec ()++import Language.JVM.Attribute.Signature+import Language.JVM++import qualified Data.Text as Text+import Data.Attoparsec.Text++spec :: Spec+spec = do+ it "can do a roundtrip" $ property $ prop_roundtrip_SignatureSpec++ spec_real_signatures++prop_roundtrip_SignatureSpec :: Signature High -> Property+prop_roundtrip_SignatureSpec = isoRoundtrip++prop_field_signature :: FieldSignature -> Property+prop_field_signature sig =+ let txt = fieldSignatureToText sig in+ counterexample (Text.unpack txt) $+ fieldSignatureFromText txt === Right sig++prop_method_signature :: MethodSignature -> Property+prop_method_signature sig =+ let txt = methodSignatureToText sig in+ counterexample (Text.unpack txt) $+ methodSignatureFromText txt === Right sig++prop_class_signature :: ClassSignature -> Property+prop_class_signature sig =+ let txt = classSignatureToText sig in+ counterexample (Text.unpack txt) $+ classSignatureFromText txt === Right sig++spec_real_signatures :: SpecWith ()+spec_real_signatures = do+ it "can handle this class type Ljava/lang/Object;" $ do+ let sig = "Ljava/lang/Object;"+ parseOnly referenceTypeP sig `shouldBe`+ Right (RefClassType (ClassType "java/lang/Object" []))++ it "can handle this type parameter E:Ljava/lang/Object;" $ do+ let sig = "E:Ljava/lang/Object;"+ parseOnly typeParameterP sig `shouldBe`+ Right (TypeParameter {+ tpIndentifier = "E",+ tpClassBound = Just (RefClassType (ClassType "java/lang/Object" [])),+ tpInterfaceBound = []+ })+ it "can handle this type parameter <E:Ljava/lang/Object;>" $ do+ let sig = "<E:Ljava/lang/Object;>"+ parseOnly typeParametersP sig `shouldBe`+ Right [+ TypeParameter {+ tpIndentifier = "E",+ tpClassBound = Just (RefClassType (ClassType {+ ctsClassName = "java/lang/Object",+ ctsTypeArguments = []+ })),+ tpInterfaceBound = []+ }+ ]+ it "can handle the class signature of Iterator" $ do+ let sig = "<E:Ljava/lang/Object;>Ljava/lang/Object;"+ parseOnly classSignatureP sig `shouldBe`+ Right (ClassSignature {+ csTypeParameters = [+ TypeParameter {+ tpIndentifier = "E",+ tpClassBound = Just (RefClassType (ClassType {+ ctsClassName = "java/lang/Object",+ ctsTypeArguments = []+ })),+ tpInterfaceBound = []+ }+ ],+ csSuperclassSignature = ClassType {+ ctsClassName = "java/lang/Object",+ ctsTypeArguments = []+ },+ csInterfaceSignatures = []+ })+ it "can handle the method signature of Iterator" $ do+ let sig = "(Ljava/util/function/Consumer<-TE;>;)V"+ parseOnly methodSignatureP sig `shouldBe`+ Right (MethodSignature {+ msTypeParameters = [],+ msArguments = [+ ReferenceType (RefClassType (ClassType {+ ctsClassName = "java/util/function/Consumer",+ ctsTypeArguments = [+ Just (TypeArgument {+ taWildcard = Just WildMinus,+ taType = RefTypeVariable (TypeVariable {+ tvAsText = "E"+ })+ })+ ]+ }))+ ],+ msResults = Nothing,+ msThrows = []+ })+++ it "can handle the simple method signature" $ do+ parseOnly methodSignatureP "()V" `shouldBe` Right+ ( MethodSignature [] [] Nothing [])++ it "can handle throws method signature" $ do+ parseOnly (methodSignatureP <* endOfInput) "()V^TE;" `shouldBe` Right+ ( MethodSignature [] [] Nothing [ThrowsTypeVariable (TypeVariable "E")])++ it "can handle throws method signature with class" $ do+ parseOnly (methodSignatureP) "()V^Ljava/lang/Exception;" `shouldBe` Right+ ( MethodSignature [] [] Nothing [+ ThrowsClass (+ ClassType {+ ctsClassName = "java/lang/Exception"+ , ctsTypeArguments = []+ }+ )+ ])++ it "can parse a type variable" $ do+ parseOnly typeVariableP "TE;" `shouldBe` Right (TypeVariable "E")++ it "can handle the simple field signature" $ do+ parseOnly fieldSignatureP "Ljava/util/function/Consumer<-TE;>;" `shouldBe` Right+ ( FieldSignature+ (RefClassType+ (ClassType "java/util/function/Consumer"+ [Just (TypeArgument (Just WildMinus) . RefTypeVariable $ TypeVariable "E") ]+ )))+++instance Arbitrary (Signature High) where+ arbitrary = genericArbitraryU++instance Arbitrary (FieldSignature) where+ arbitrary = genericArbitraryU++instance Arbitrary (ReferenceType) where+ arbitrary = do+ n <- getSize+ if n == 0+ then pure (RefTypeVariable $ TypeVariable "X")+ else scale (\s -> s `div` 2) $ genericArbitraryU++instance Arbitrary (ClassType) where+ arbitrary = do+ s <- getSize+ n <- choose (0, s)+ x <- vectorOf n (resize (s `div` n) arbitrary)+ oneof+ [ ClassType <$> arbitrary <*> pure x+ , InnerClassType <$> elements ["a", "subclass"] <*> resize (n `div` 2) arbitrary <*> pure x+ ]+++instance Arbitrary (TypeVariable) where+ arbitrary = TypeVariable <$> elements ["A","B", "C", "HJ"]++instance Arbitrary (TypeSignature) where+ arbitrary = do+ n <- getSize+ if n == 0+ then BaseType <$> arbitrary+ else resize (n `div` 2) $ ReferenceType <$> arbitrary++instance Arbitrary (TypeArgument) where+ arbitrary = genericArbitraryU++instance Arbitrary (TypeParameter) where+ arbitrary = TypeParameter <$> elements ["A","B", "C", "HJ"] <*> arbitrary <*> arbitrary++instance Arbitrary (Wildcard) where+ arbitrary = genericArbitraryU++instance Arbitrary (MethodSignature) where+ arbitrary = genericArbitraryU++instance Arbitrary (ClassSignature) where+ arbitrary = genericArbitraryU++instance Arbitrary (ThrowsSignature) where+ arbitrary = genericArbitraryU++-- "Lcom/apple/eawt/_AppEventHandler$_AppEventDispatcher<Lcom/apple/eawt/QuitHandler;>;"+-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor<Lcom/apple/eawt/ScreenSleepListener;Lcom/apple/eawt/AppEvent$ScreenSleepEvent;>;"+-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor<Lcom/apple/eawt/SystemSleepListener;Lcom/apple/eawt/AppEvent$SystemSleepEvent;>;"+-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor<Lcom/apple/eawt/UserSessionListener;Lcom/apple/eawt/AppEvent$UserSessionEvent;>;"
− test/Language/JVM/Attribute/SignatureTest.hs
@@ -1,194 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}--module Language.JVM.Attribute.SignatureTest where--import SpecHelper--import Language.JVM.ConstantTest ()--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--prop_field_signature :: FieldSignature -> Property-prop_field_signature sig =- let txt = fieldSignatureToText sig in- counterexample (Text.unpack txt) $- fieldSignatureFromText txt === Right sig--prop_method_signature :: MethodSignature -> Property-prop_method_signature sig =- let txt = methodSignatureToText sig in- counterexample (Text.unpack txt) $- methodSignatureFromText txt === Right sig--prop_class_signature :: ClassSignature -> Property-prop_class_signature sig =- let txt = classSignatureToText sig in- counterexample (Text.unpack txt) $- classSignatureFromText txt === Right sig--spec_real_signatures :: SpecWith ()-spec_real_signatures = do- it "can handle this class type Ljava/lang/Object;" $ do- let sig = "Ljava/lang/Object;"- parseOnly referenceTypeP sig `shouldBe`- Right (RefClassType (ClassType "java/lang/Object" []))-- it "can handle this type parameter E:Ljava/lang/Object;" $ do- let sig = "E:Ljava/lang/Object;"- parseOnly typeParameterP sig `shouldBe`- Right (TypeParameter {- tpIndentifier = "E",- tpClassBound = Just (RefClassType (ClassType "java/lang/Object" [])),- tpInterfaceBound = []- })- it "can handle this type parameter <E:Ljava/lang/Object;>" $ do- let sig = "<E:Ljava/lang/Object;>"- parseOnly typeParametersP sig `shouldBe`- Right [- TypeParameter {- tpIndentifier = "E",- tpClassBound = Just (RefClassType (ClassType {- ctsClassName = "java/lang/Object",- ctsTypeArguments = []- })),- tpInterfaceBound = []- }- ]- it "can handle the class signature of Iterator" $ do- let sig = "<E:Ljava/lang/Object;>Ljava/lang/Object;"- parseOnly classSignatureP sig `shouldBe`- Right (ClassSignature {- csTypeParameters = [- TypeParameter {- tpIndentifier = "E",- tpClassBound = Just (RefClassType (ClassType {- ctsClassName = "java/lang/Object",- ctsTypeArguments = []- })),- tpInterfaceBound = []- }- ],- csSuperclassSignature = ClassType {- ctsClassName = "java/lang/Object",- ctsTypeArguments = []- },- csInterfaceSignatures = []- })- it "can handle the method signature of Iterator" $ do- let sig = "(Ljava/util/function/Consumer<-TE;>;)V"- parseOnly methodSignatureP sig `shouldBe`- Right (MethodSignature {- msTypeParameters = [],- msArguments = [- ReferenceType (RefClassType (ClassType {- ctsClassName = "java/util/function/Consumer",- ctsTypeArguments = [- Just (TypeArgument {- taWildcard = Just WildMinus,- taType = RefTypeVariable (TypeVariable {- tvAsText = "E"- })- })- ]- }))- ],- msResults = Nothing,- msThrows = []- })--- it "can handle the simple method signature" $ do- parseOnly methodSignatureP "()V" `shouldBe` Right- ( MethodSignature [] [] Nothing [])-- it "can handle throws method signature" $ do- parseOnly (methodSignatureP <* endOfInput) "()V^TE;" `shouldBe` Right- ( MethodSignature [] [] Nothing [ThrowsTypeVariable (TypeVariable "E")])-- it "can handle throws method signature with class" $ do- parseOnly (methodSignatureP) "()V^Ljava/lang/Exception;" `shouldBe` Right- ( MethodSignature [] [] Nothing [- ThrowsClass (- ClassType {- ctsClassName = "java/lang/Exception"- , ctsTypeArguments = []- }- )- ])-- it "can parse a type variable" $ do- parseOnly typeVariableP "TE;" `shouldBe` Right (TypeVariable "E")-- it "can handle the simple field signature" $ do- parseOnly fieldSignatureP "Ljava/util/function/Consumer<-TE;>;" `shouldBe` Right- ( FieldSignature- (RefClassType- (ClassType "java/util/function/Consumer"- [Just (TypeArgument (Just WildMinus) . RefTypeVariable $ TypeVariable "E") ]- )))---instance Arbitrary (Signature High) where- arbitrary = genericArbitraryU--instance Arbitrary (FieldSignature) where- arbitrary = genericArbitraryU--instance Arbitrary (ReferenceType) where- arbitrary = do- n <- getSize- if n == 0- then pure (RefTypeVariable $ TypeVariable "X")- else scale (\s -> s `div` 2) $ genericArbitraryU--instance Arbitrary (ClassType) where- arbitrary = do- s <- getSize- n <- choose (0, s)- x <- vectorOf n (resize (s `div` n) arbitrary)- oneof- [ ClassType <$> arbitrary <*> pure x- , InnerClassType <$> elements ["a", "subclass"] <*> resize (n `div` 2) arbitrary <*> pure x- ]---instance Arbitrary (TypeVariable) where- arbitrary = TypeVariable <$> elements ["A","B", "C", "HJ"]--instance Arbitrary (TypeSignature) where- arbitrary = do- n <- getSize- if n == 0- then BaseType <$> arbitrary- else resize (n `div` 2) $ ReferenceType <$> arbitrary--instance Arbitrary (TypeArgument) where- arbitrary = genericArbitraryU--instance Arbitrary (TypeParameter) where- arbitrary = TypeParameter <$> elements ["A","B", "C", "HJ"] <*> arbitrary <*> arbitrary--instance Arbitrary (Wildcard) where- arbitrary = genericArbitraryU--instance Arbitrary (MethodSignature) where- arbitrary = genericArbitraryU--instance Arbitrary (ClassSignature) where- arbitrary = genericArbitraryU--instance Arbitrary (ThrowsSignature) where- arbitrary = genericArbitraryU---- "Lcom/apple/eawt/_AppEventHandler$_AppEventDispatcher<Lcom/apple/eawt/QuitHandler;>;"--- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor<Lcom/apple/eawt/ScreenSleepListener;Lcom/apple/eawt/AppEvent$ScreenSleepEvent;>;"--- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor<Lcom/apple/eawt/SystemSleepListener;Lcom/apple/eawt/AppEvent$SystemSleepEvent;>;"--- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor<Lcom/apple/eawt/UserSessionListener;Lcom/apple/eawt/AppEvent$UserSessionEvent;>;"
+ test/Language/JVM/Attribute/StackMapTableSpec.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Language.JVM.Attribute.StackMapTableSpec where++import SpecHelper++import Data.Bifunctor+import Data.Binary+import qualified Data.ByteString.Lazy as BL+import Data.Either++import Language.JVM.Attribute.StackMapTable+import Language.JVM++import Language.JVM.AttributeSpec ()+import Language.JVM.ConstantSpec ()+import Language.JVM.TypeSpec ()++-- prop_encode_and_decode :: StackMapTable Low -> Property+-- prop_encode_and_decode = isoBinary++spec :: SpecWith ()+spec = do+ describe "decoding" $ do+ let+ bs = BL.fromStrict "\NUL\ACK\253\NUL\t\SOH\SOH\253\NUL%\SOH\SOH\t\ETB\249\NUL\t\249\NUL\r"+ -- 0006fd00 090101fd 00250101 0917f900 09f9000d+ it ("can decode " ++ hexString bs) $ do+ let+ r :: Either String (StackMapTable Low)+ r = bimap trd trd $ decodeOrFail bs++ r `shouldSatisfy` isRight++ describe "offsetDelta" $ do+ it "uphold that offesetDelta -| offsetDeltaInv" $ property $ prop_offset_delta++-- prop_offset_delta :: (Word16, Word16) -> Bool+prop_offset_delta :: (Word16, Word16) -> Property+prop_offset_delta (lidx, delta) =+ let tidx = offsetDelta lidx delta+ in counterexample (show tidx) $+ offsetDeltaInv lidx tidx === delta++-- prop_roundtrip_StackMapTable :: StackMapTable High -> Property+-- prop_roundtrip_StackMapTable = isoRoundtrip++-- prop_roundtrip_StackMapFrame :: StackMapFrame High -> Property+-- prop_roundtrip_StackMapFrame = isoRoundtrip++instance Arbitrary (StackMapTable High) where+ arbitrary = StackMapTable <$> arbitrary++instance Arbitrary ( StackMapFrame High) where+ arbitrary =+ StackMapFrame <$> arbitrary <*> arbitrary++instance Arbitrary (StackMapFrameType High) where+ arbitrary = oneof+ [ pure SameFrame+ , SameLocals1StackItemFrame <$> arbitrary+ , ChopFrame <$> choose (1,3)+ , AppendFrame <$> (choose (1,3) >>= flip vectorOf arbitrary)+ , FullFrame <$> arbitrary <*> arbitrary+ ]++instance Arbitrary (VerificationTypeInfo High) where+ arbitrary = oneof+ [ pure VTTop+ , pure VTInteger+ , pure VTFloat+ , pure VTLong+ , pure VTDouble+ , pure VTNull+ , pure VTUninitializedThis+ , VTObject <$> arbitrary+ , VTUninitialized <$> arbitrary+ ]
− test/Language/JVM/Attribute/StackMapTableTest.hs
@@ -1,77 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Language.JVM.Attribute.StackMapTableTest where--import SpecHelper--import Data.Bifunctor-import Data.Binary-import qualified Data.ByteString.Lazy as BL-import Data.Either--import Language.JVM.Attribute.StackMapTable-import Language.JVM--import Language.JVM.AttributeTest ()-import Language.JVM.ConstantTest ()-import Language.JVM.TypeTest ()---- prop_encode_and_decode :: StackMapTable Low -> Property--- prop_encode_and_decode = isoBinary--spec_parses :: SpecWith ()-spec_parses = do- describe "decoding" $ do- let- bs = BL.fromStrict "\NUL\ACK\253\NUL\t\SOH\SOH\253\NUL%\SOH\SOH\t\ETB\249\NUL\t\249\NUL\r"- -- 0006fd00 090101fd 00250101 0917f900 09f9000d- it ("can decode " ++ hexString bs) $ do- let- r :: Either String (StackMapTable Low)- r = bimap trd trd $ decodeOrFail bs-- r `shouldSatisfy` isRight---- prop_offset_delta :: (Word16, Word16) -> Bool-prop_offset_delta :: (Word16, Word16) -> Property-prop_offset_delta (lidx, delta) =- let tidx = offsetDelta lidx delta- in counterexample (show tidx) $- offsetDeltaInv lidx tidx === delta---- prop_roundtrip_StackMapTable :: StackMapTable High -> Property--- prop_roundtrip_StackMapTable = isoRoundtrip---- prop_roundtrip_StackMapFrame :: StackMapFrame High -> Property--- prop_roundtrip_StackMapFrame = isoRoundtrip--instance Arbitrary (StackMapTable High) where- arbitrary = StackMapTable <$> arbitrary--instance Arbitrary ( StackMapFrame High) where- arbitrary =- StackMapFrame <$> arbitrary <*> arbitrary--instance Arbitrary (StackMapFrameType High) where- arbitrary = oneof- [ pure SameFrame- , SameLocals1StackItemFrame <$> arbitrary- , ChopFrame <$> choose (1,3)- , AppendFrame <$> (choose (1,3) >>= flip vectorOf arbitrary)- , FullFrame <$> arbitrary <*> arbitrary- ]--instance Arbitrary (VerificationTypeInfo High) where- arbitrary = oneof- [ pure VTTop- , pure VTInteger- , pure VTFloat- , pure VTLong- , pure VTDouble- , pure VTNull- , pure VTUninitializedThis- , VTObject <$> arbitrary- , VTUninitialized <$> arbitrary- ]
+ test/Language/JVM/AttributeSpec.hs view
@@ -0,0 +1,24 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances #-}+module Language.JVM.AttributeSpec where++import SpecHelper++import Language.JVM++import Language.JVM.Attribute (Attribute (..))+import Language.JVM.ConstantSpec ()+import Language.JVM.UtilsSpec ()++import qualified Data.ByteString as BS++spec :: Spec+spec = do+ it "roundtrip" $ property $ (isoRoundtrip :: Attribute High -> Property)++instance Arbitrary (Attribute High) where+ arbitrary = do+ _idx <- arbitrary+ len <- choose (0, 50)+ bs <- SizedByteString . BS.pack <$> sequence (replicate len arbitrary)+ return $ Attribute _idx bs
− test/Language/JVM/AttributeTest.hs
@@ -1,23 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE FlexibleInstances #-}-module Language.JVM.AttributeTest where--import SpecHelper--import Language.JVM--import Language.JVM.Attribute (Attribute (..))-import Language.JVM.ConstantTest ()-import Language.JVM.UtilsTest ()--import qualified Data.ByteString as BS--prop_roundtrip_Attribute :: Attribute High -> Property-prop_roundtrip_Attribute = isoRoundtrip--instance Arbitrary (Attribute High) where- arbitrary = do- _idx <- arbitrary- len <- choose (0, 50)- bs <- SizedByteString . BS.pack <$> sequence (replicate len arbitrary)- return $ Attribute _idx bs
+ test/Language/JVM/ClassFileSpec.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE FlexibleInstances #-}+module Language.JVM.ClassFileSpec where++import SpecHelper++import Language.JVM++import Language.JVM.Attribute.BootstrapMethodsSpec ()+import Language.JVM.AttributeSpec ()+import Language.JVM.ConstantSpec ()+import Language.JVM.FieldSpec ()+import Language.JVM.MethodSpec ()+import Language.JVM.UtilsSpec ()++spec :: Spec+spec =+ it "can do a roundtrip" $ property $ prop_roundtrip_ClassFile++prop_roundtrip_ClassFile :: ClassFile High -> Property+prop_roundtrip_ClassFile = isoRoundtrip++instance Arbitrary (ClassAttributes High) where+ arbitrary = pure $ ClassAttributes [] [] [] [] []++instance Arbitrary (ClassFile High) where+ arbitrary = ClassFile+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> (pure ())+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> (resize 2 arbitrary)+ <*> (resize 2 arbitrary)+ <*> arbitrary++ shrink ClassFile{..} = do+ cInterfaces <- shrink cInterfaces+ cAttributes <- shrink cAttributes+ cMethods' <- shrink cMethods'+ cFields' <- shrink cFields'+ return $ClassFile {..}
− test/Language/JVM/ClassFileTest.hs
@@ -1,43 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-{-# LANGUAGE FlexibleInstances #-}-module Language.JVM.ClassFileTest where--import SpecHelper--import Language.JVM--import Language.JVM.Attribute.BootstrapMethodsTest ()-import Language.JVM.AttributeTest ()-import Language.JVM.ConstantTest ()-import Language.JVM.FieldTest ()-import Language.JVM.MethodTest ()-import Language.JVM.UtilsTest ()--prop_roundtrip_ClassFile :: ClassFile High -> Property-prop_roundtrip_ClassFile = isoRoundtrip--instance Arbitrary (ClassAttributes High) where- arbitrary = pure $ ClassAttributes [] [] [] [] []--instance Arbitrary (ClassFile High) where- arbitrary = ClassFile- <$> arbitrary- <*> arbitrary- <*> arbitrary- <*> (pure ())- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> (resize 2 arbitrary)- <*> (resize 2 arbitrary)- <*> arbitrary-- shrink ClassFile{..} = do- cInterfaces <- shrink cInterfaces- cAttributes <- shrink cAttributes- cMethods' <- shrink cMethods'- cFields' <- shrink cFields'- return $ClassFile {..}
+ test/Language/JVM/ConstantSpec.hs view
@@ -0,0 +1,140 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+module Language.JVM.ConstantSpec where++import SpecHelper++import qualified Data.Text as Text+import qualified Data.ByteString as BS++import Language.JVM+import Language.JVM.UtilsSpec ()+import Language.JVM.TypeSpec ()++spec :: Spec+spec = do+ it "can build a class pool" $ do+ let+ (a', cpb) = runConstantPoolBuilder (devolve (CClassRef "class/Name")) cpbEmpty+ cp = constantPoolFromBuilder cpb+ cp `shouldBe` fromConstants [CString "class/Name"]+ a' `shouldBe` (CClassRef 1)++ let cp' = bootstrapConstantPool cp+ cp' `shouldBe` Right (fromConstants [CString "class/Name"])++ it "can build a complex class pool" $ do+ let+ a = CMethodRef (InClass "class/Name" "method:()V")+ (a', cpb) = runConstantPoolBuilder (devolve a) cpbEmpty+ cp = constantPoolFromBuilder cpb+ cp `shouldBe` fromConstants [CString "class/Name", CClassRef 1, CString "method", CString "()V", CNameAndType 3 4]+ a' `shouldBe` (CMethodRef (InClass 2 5))++ let cp' = bootstrapConstantPool cp+ cp' `shouldBe` Right (fromConstants+ [ CString "class/Name", CClassRef "class/Name", CString "method"+ , CString "()V", CNameAndType "method" "()V"])++ let Right cp'' = cp'+ runEvolve (EvolveConfig [] cp'' (const True)) (evolve a') `shouldBe` Right a++ it "can encode and decode" $ property $+ (isoBinary :: ConstantPool Low -> Property)+ it "can do a roundtrip" $ property $+ (isoRoundtrip :: Constant High -> Property)++instance Arbitrary (ConstantPool Low) where+ arbitrary = do+ lst <- arbitrary :: Gen [Constant High]+ let (_, x) = runConstantPoolBuilder (mapM devolve lst) cpbEmpty+ return (constantPoolFromBuilder x)++instance Arbitrary Text.Text where+ arbitrary =+ elements+ [ "Package"+ , "test"+ , "number"+ , "stuff"+ , "\0 asd ßåæ∂ø∆œ˜˜¬å˚¬"+ ]++instance Arbitrary BS.ByteString where+ arbitrary =+ elements+ [ "Package"+ , "test"+ , "number"+ , "stuff"+ , "\0 asd ßåæ∂ø∆œ˜˜¬å˚¬"+ ]++instance Arbitrary (ConstantPool High) where+ arbitrary =+ fromConstants <$> (arbitrary :: Gen [Constant High])++instance Arbitrary (AbsInterfaceMethodId High) where+ arbitrary = genericArbitraryU++instance Arbitrary (Constant High) where+ arbitrary = sized $ \n ->+ if n < 2+ then oneof+ [ CString <$> arbitrary+ , CInteger <$> arbitrary+ , CFloat <$> arbitrary+ , CLong <$> arbitrary+ , CDouble <$> arbitrary+ ]+ else scale (flip div 2) $ oneof+ [ CString <$> arbitrary+ , CInteger <$> arbitrary+ , CFloat <$> arbitrary+ , CLong <$> arbitrary+ , CDouble <$> arbitrary+ , CClassRef <$> arbitrary+ , CStringRef <$> arbitrary+ , CFieldRef <$> arbitrary+ , CMethodRef <$> arbitrary+ , CInterfaceMethodRef <$> arbitrary+ , CNameAndType <$> arbitrary <*> arbitrary+ , CMethodHandle <$> arbitrary+ , CMethodType <$> arbitrary+ , CInvokeDynamic <$> arbitrary+ ]++instance (Arbitrary a) => Arbitrary (InClass a High) where+ arbitrary = InClass <$> arbitrary <*> arbitrary++instance Arbitrary (FieldId) where+ arbitrary = FieldId <$> arbitrary++instance Arbitrary (MethodId) where+ arbitrary = MethodId <$> arbitrary++instance Arbitrary (MethodHandle High) where+ arbitrary =+ oneof+ [ MHField <$> ( MethodHandleField <$> arbitrary <*> arbitrary)+ , MHMethod <$> arbitrary+ , MHInterface <$> ( MethodHandleInterface <$> arbitrary)+ ]++instance Arbitrary MethodHandleFieldKind where+ arbitrary =+ oneof [ pure x | x <- [ MHGetField, MHGetStatic, MHPutField, MHPutStatic ] ]++instance Arbitrary (MethodHandleMethod High) where+ arbitrary =+ genericArbitraryU++-- instance Arbitrary (AbsVariableMethodId High) where+-- arbitrary = genericArbitraryU++instance Arbitrary (InvokeDynamic High) where+ arbitrary = InvokeDynamic <$> arbitrary <*> arbitrary++instance Arbitrary JValue where+ arbitrary = genericArbitraryU
− test/Language/JVM/ConstantTest.hs
@@ -1,124 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-module Language.JVM.ConstantTest where--import SpecHelper--import qualified Data.IntMap as IM-import qualified Data.Text as Text-import qualified Data.ByteString as BS--import Language.JVM.Constant-import Language.JVM.Staged-import Language.JVM.ConstantPool-import Language.JVM.ClassFileReader-import Language.JVM.UtilsTest ()-import Language.JVM.TypeTest ()--prop_encode_and_decode :: ConstantPool Low -> Property-prop_encode_and_decode = isoBinary--instance Arbitrary (ConstantPool Low) where- arbitrary = do- lst <- arbitrary :: Gen [Constant High]- let (_, x) = runConstantPoolBuilder (mapM devolve lst) cpbEmpty- return (cpbConstantPool x)---- prop_Constant_encode_and_decode :: Constant Low -> Property--- prop_Constant_encode_and_decode = isoBinary--prop_roundtrip_Constant :: Constant High -> Property-prop_roundtrip_Constant = isoRoundtrip--instance Arbitrary Text.Text where- arbitrary =- elements- [ "Package"- , "test"- , "number"- , "stuff"- , "\0 asd ßåæ∂ø∆œ˜˜¬å˚¬"- ]--instance Arbitrary BS.ByteString where- arbitrary =- elements- [ "Package"- , "test"- , "number"- , "stuff"- , "\0 asd ßåæ∂ø∆œ˜˜¬å˚¬"- ]--instance Arbitrary (ConstantPool High) where- arbitrary =- ConstantPool . IM.fromList . go 1 <$> arbitrary- where- go n (e : lst) =- (n, e) : go (n + constantSize e) lst- go _ [] = []--instance Arbitrary (AbsInterfaceMethodId High) where- arbitrary = genericArbitraryU--instance Arbitrary (Constant High) where- arbitrary = sized $ \n ->- if n < 2- then oneof- [ CString <$> arbitrary- , CInteger <$> arbitrary- , CFloat <$> arbitrary- , CLong <$> arbitrary- , CDouble <$> arbitrary- ]- else scale (flip div 2) $ oneof- [ CString <$> arbitrary- , CInteger <$> arbitrary- , CFloat <$> arbitrary- , CLong <$> arbitrary- , CDouble <$> arbitrary- , CClassRef <$> arbitrary- , CStringRef <$> arbitrary- , CFieldRef <$> arbitrary- , CMethodRef <$> arbitrary- , CInterfaceMethodRef <$> arbitrary- , CNameAndType <$> arbitrary <*> arbitrary- , CMethodHandle <$> arbitrary- , CMethodType <$> arbitrary- , CInvokeDynamic <$> arbitrary- ]--instance (Arbitrary a) => Arbitrary (InClass a High) where- arbitrary = InClass <$> arbitrary <*> arbitrary--instance Arbitrary (FieldId) where- arbitrary = FieldId <$> arbitrary--instance Arbitrary (MethodId) where- arbitrary = MethodId <$> arbitrary--instance Arbitrary (MethodHandle High) where- arbitrary =- oneof- [ MHField <$> ( MethodHandleField <$> arbitrary <*> arbitrary)- , MHMethod <$> arbitrary- , MHInterface <$> ( MethodHandleInterface <$> arbitrary)- ]--instance Arbitrary MethodHandleFieldKind where- arbitrary =- oneof [ pure x | x <- [ MHGetField, MHGetStatic, MHPutField, MHPutStatic ] ]--instance Arbitrary (MethodHandleMethod High) where- arbitrary =- genericArbitraryU--instance Arbitrary (AbsVariableMethodId High) where- arbitrary = genericArbitraryU--instance Arbitrary (InvokeDynamic High) where- arbitrary = InvokeDynamic <$> arbitrary <*> arbitrary--instance Arbitrary JValue where- arbitrary = genericArbitraryU
+ test/Language/JVM/FieldSpec.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances #-}+module Language.JVM.FieldSpec where++import SpecHelper++import Language.JVM.UtilsSpec ()+import Language.JVM.ConstantSpec ()+import Language.JVM.AttributeSpec ()+import Language.JVM.Attribute.ConstantValueSpec ()++import Language.JVM++spec :: Spec+spec =+ it "can do a roundtrip" $ property $ prop_roundtrip_Field++prop_roundtrip_Field :: Field High -> Property+prop_roundtrip_Field = isoRoundtrip++instance Arbitrary (FieldAttributes High) where+ arbitrary =+ FieldAttributes <$> arbitrary <*> pure [] <*> pure []++instance Arbitrary (Field High) where+ arbitrary = Field+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary
− test/Language/JVM/FieldTest.hs
@@ -1,26 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE FlexibleInstances #-}-module Language.JVM.FieldTest where--import SpecHelper--import Language.JVM.UtilsTest ()-import Language.JVM.ConstantTest ()-import Language.JVM.AttributeTest ()-import Language.JVM.Attribute.ConstantValueTest ()--import Language.JVM--prop_roundtrip_Field :: Field High -> Property-prop_roundtrip_Field = isoRoundtrip--instance Arbitrary (FieldAttributes High) where- arbitrary =- FieldAttributes <$> arbitrary <*> pure [] <*> pure []--instance Arbitrary (Field High) where- arbitrary = Field- <$> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary
+ test/Language/JVM/MethodSpec.hs view
@@ -0,0 +1,33 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+module Language.JVM.MethodSpec where++import SpecHelper++import Language.JVM.Attribute.CodeSpec ()+import Language.JVM.Attribute.ExceptionsSpec ()+import Language.JVM.AttributeSpec ()+import Language.JVM.ConstantSpec ()+import Language.JVM.UtilsSpec ()++import Language.JVM++spec :: Spec+spec =+ it "can do a roundtrip" $ property $ prop_roundtrip_Method++prop_roundtrip_Method :: Method High -> Property+prop_roundtrip_Method = isoRoundtrip++instance Arbitrary (MethodAttributes High) where+ arbitrary =+ MethodAttributes <$> pure [] <*> arbitrary <*> pure [] <*> pure []+ shrink (MethodAttributes a b c d ) =+ MethodAttributes <$> shrink a <*> shrink b <*> pure c <*> pure d++instance Arbitrary (Method High) where+ arbitrary =+ Method <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+ shrink (Method a b c d) =+ Method <$> shrink a <*> shrink b <*> shrink c <*> shrink d
− test/Language/JVM/MethodTest.hs
@@ -1,29 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-module Language.JVM.MethodTest where--import SpecHelper--import Language.JVM.Attribute.CodeTest ()-import Language.JVM.Attribute.ExceptionsTest ()-import Language.JVM.AttributeTest ()-import Language.JVM.ConstantTest ()-import Language.JVM.UtilsTest ()--import Language.JVM--prop_roundtrip_Method :: Method High -> Property-prop_roundtrip_Method = isoRoundtrip--instance Arbitrary (MethodAttributes High) where- arbitrary =- MethodAttributes <$> pure [] <*> arbitrary <*> pure [] <*> pure []- shrink (MethodAttributes a b c d ) =- MethodAttributes <$> shrink a <*> shrink b <*> pure c <*> pure d--instance Arbitrary (Method High) where- arbitrary =- Method <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary- shrink (Method a b c d) =- Method <$> shrink a <*> shrink b <*> shrink c <*> shrink d
+ test/Language/JVM/TypeSpec.hs view
@@ -0,0 +1,55 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE OverloadedStrings #-}+module Language.JVM.TypeSpec where++import SpecHelper++import Data.Attoparsec.Text+import Data.Either+import Language.JVM.Type++-- import Text.Megaparsec+-- import Spec.Hspec.Megaparsec++spec :: Spec+spec = do+ describe "JType parsing" $ do+ it "can parse \"[B\" as an array" $+ parseOnly parseType "[B" `shouldBe` Right (JTRef (JTArray (JTBase JTByte)))+ it "can parse an array of strings" $+ parseOnly parseType "[Ljava/lang/String;" `shouldBe`+ Right (JTRef (JTArray (JTRef (JTClass (ClassName "java/lang/String")))))++ describe "MethodDescriptor parsing" $ do+ it "can parse the empty method" $+ parseOnly parseType "()V" `shouldBe`+ Right (MethodDescriptor [] Nothing)+ it "can parse method arguments" $+ parseOnly parseType "(BZ)B" `shouldBe`+ Right (MethodDescriptor [JTBase JTByte, JTBase JTBoolean] (Just (JTBase JTByte)))+ it "does not parse if there is too much" $+ (typeFromText "(BZ)Bx" :: Either String MethodDescriptor) `shouldSatisfy` isLeft++instance Arbitrary ClassName where+ arbitrary = pure $ ClassName "package/Main"++instance Arbitrary JType where+ arbitrary = genericArbitrary uniform++instance Arbitrary JBaseType where+ arbitrary = genericArbitrary uniform++instance Arbitrary JRefType where+ arbitrary = genericArbitrary uniform++instance Arbitrary MethodDescriptor where+ arbitrary = genericArbitrary uniform++instance Arbitrary FieldDescriptor where+ arbitrary = genericArbitrary uniform++instance Arbitrary t => Arbitrary (NameAndType t) where+ arbitrary =+ NameAndType+ <$> elements ["a", "f", "x", "y"]+ <*> arbitrary
− test/Language/JVM/TypeTest.hs
@@ -1,55 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE OverloadedStrings #-}-module Language.JVM.TypeTest where--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" $- parseOnly parseType "[B" `shouldBe` Right (JTRef (JTArray (JTBase JTByte)))- it "can parse an array of strings" $- parseOnly parseType "[Ljava/lang/String;" `shouldBe`- Right (JTRef (JTArray (JTRef (JTClass (ClassName "java/lang/String")))))--spec_MethodDescriptor_parsing :: Spec-spec_MethodDescriptor_parsing = do- it "can parse the empty method" $- parseOnly parseType "()V" `shouldBe`- Right (MethodDescriptor [] Nothing)- it "can parse method arguments" $- parseOnly parseType "(BZ)B" `shouldBe`- Right (MethodDescriptor [JTBase JTByte, JTBase JTBoolean] (Just (JTBase JTByte)))- it "does not parse if there is too much" $- (typeFromText "(BZ)Bx" :: Either String MethodDescriptor) `shouldSatisfy` isLeft--instance Arbitrary ClassName where- arbitrary = pure $ ClassName "package/Main"--instance Arbitrary JType where- arbitrary = genericArbitrary uniform--instance Arbitrary JBaseType where- arbitrary = genericArbitrary uniform--instance Arbitrary JRefType where- arbitrary = genericArbitrary uniform--instance Arbitrary MethodDescriptor where- arbitrary = genericArbitrary uniform--instance Arbitrary FieldDescriptor where- arbitrary = genericArbitrary uniform--instance Arbitrary t => Arbitrary (NameAndType t) where- arbitrary =- NameAndType- <$> elements ["a", "f", "x", "y"]- <*> arbitrary
+ test/Language/JVM/UtilsSpec.hs view
@@ -0,0 +1,64 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE OverloadedStrings #-}+module Language.JVM.UtilsSpec where++import SpecHelper++import qualified Data.ByteString as BS++import Data.Set as Set+import qualified Data.Text.Encoding as TE++import Language.JVM.Utils++spec :: Spec+spec = do+ describe "zero decoder" $ do+ -- it "can decode encoded text" $ property $+ -- \a -> tryDecode (TE.encodeUtf8 a) == Right a++ it "can read zero" $ do+ sizedByteStringToText "\192\128" `shouldBe` Right "\0"++ it "can read zero padded with text" $ do+ sizedByteStringToText "Some text \192\128 a x" `shouldBe` Right "Some text \0 a x"++ it "can convert a zero back again" $ do+ sizedByteStringFromText "\0" `shouldBe` "\192\128"++ it "can convert a padded zero back again" $ do+ sizedByteStringFromText "Some text \0 a x" `shouldBe` "Some text \192\128 a x"++ it "works on wierd strings" $ do+ tryDecode (TE.encodeUtf8 "\0 asd ßåæ∂ø∆œ˜˜¬å˚¬") `shouldBe` Right "\0 asd ßåæ∂ø∆œ˜˜¬å˚¬"++ it "works on chinese characters" $ do+ tryDecode (TE.encodeUtf8 "试一试中文") `shouldBe` Right "试一试中文"++ -- xit "works on http:/foo/p\237\160\128" $ do+ -- -- I don't know exactly the right result of this string, but it should be a correct java byte-string+ -- sizedByteStringToText "http:/foo/p\237\160\128" `shouldBe` Right "http:/foo/p?"++ -- xit "works on long and obscure byte string" $ do+ -- -- I don't know exactly the right result of this string, but it should be a correct java byte-string+ -- sizedByteStringToText obscureByteString `shouldBe` Right "?"++obscureByteString :: SizedByteString a+obscureByteString = SizedByteString+ "\192\128\DEL\194\128\195\191\196\128\197\191\198\128\201\143\201\144\202\175\202\176\203\191\204\128\205\175\205\176\207\191\224\144\128\224\147\191\224\148\176\224\150\143\224\150\144\224\151\191\224\152\128\224\155\191\224\156\128\224\157\143\224\158\128\224\158\191\224\164\128\224\165\191\224\166\128\224\167\191\224\168\128\224\169\191\224\170\128\224\171\191\224\172\128\224\173\191\224\174\128\224\175\191\224\176\128\224\177\191\224\178\128\224\179\191\224\180\128\224\181\191\224\182\128\224\183\191\224\184\128\224\185\191\224\186\128\224\187\191\224\188\128\224\191\191\225\128\128\225\130\159\225\130\160\225\131\191\225\132\128\225\135\191\225\136\128\225\141\191\225\142\160\225\143\191\225\144\128\225\153\191\225\154\128\225\154\159\225\154\160\225\155\191\225\158\128\225\159\191\225\160\128\225\162\175\225\184\128\225\187\191\225\188\128\225\191\191\226\128\128\226\129\175\226\129\176\226\130\159\226\130\160\226\131\143\226\131\144\226\131\191\226\132\128\226\133\143\226\133\144\226\134\143\226\134\144\226\135\191\226\136\128\226\139\191\226\140\128\226\143\191\226\144\128\226\144\191\226\145\128\226\145\159\226\145\160\226\147\191\226\148\128\226\149\191\226\150\128\226\150\159\226\150\160\226\151\191\226\152\128\226\155\191\226\156\128\226\158\191\226\160\128\226\163\191\226\186\128\226\187\191\226\188\128\226\191\159\226\191\176\226\191\191\227\128\128\227\128\191\227\129\128\227\130\159\227\130\160\227\131\191\227\132\128\227\132\175\227\132\176\227\134\143\227\134\144\227\134\159\227\134\160\227\134\191\227\136\128\227\139\191\227\140\128\227\143\191\227\144\128\228\182\181\228\184\128\233\191\191\234\128\128\234\146\143\234\146\144\234\147\143\234\176\128\237\158\163\238\128\128\239\163\191\239\164\128\239\171\191\239\172\128\239\173\143\239\173\144\239\183\191\239\184\160\239\184\175\239\184\176\239\185\143\239\185\144\239\185\175\239\185\176\239\187\190\239\187\191\239\187\191\239\188\128\239\191\175"+++instance Arbitrary a => Arbitrary (SizedList w a) where+ arbitrary =+ SizedList <$> arbitrary+ shrink (SizedList c) =+ SizedList <$> shrink c++instance Arbitrary (SizedByteString w) where+ arbitrary = do+ len <- choose (0, 50)+ SizedByteString . BS.pack <$> sequence (replicate len arbitrary)++instance (Enumish a) => Arbitrary (BitSet w a) where+ arbitrary =+ BitSet . Set.fromList <$> sublistOf (snd <$> inOrder)
− test/Language/JVM/UtilsTest.hs
@@ -1,64 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE OverloadedStrings #-}-module Language.JVM.UtilsTest where--import SpecHelper--import qualified Data.ByteString as BS--import Data.Set as Set-import qualified Data.Text.Encoding as TE-import qualified Data.Text as Text-import Language.JVM.Utils--prop_test_our_zero_decoder :: Text.Text -> Bool-prop_test_our_zero_decoder a =- tryDecode (TE.encodeUtf8 a) == Right a--spec_parse_zero_text :: SpecWith ()-spec_parse_zero_text = do- it "can read zero" $ do- sizedByteStringToText "\192\128" `shouldBe` Right "\0"-- it "can read zero padded with text" $ do- sizedByteStringToText "Some text \192\128 a x" `shouldBe` Right "Some text \0 a x"-- it "can convert a zero back again" $ do- sizedByteStringFromText "\0" `shouldBe` "\192\128"-- it "can convert a padded zero back again" $ do- sizedByteStringFromText "Some text \0 a x" `shouldBe` "Some text \192\128 a x"-- it "works on wierd strings" $ do- tryDecode (TE.encodeUtf8 "\0 asd ßåæ∂ø∆œ˜˜¬å˚¬") `shouldBe` Right "\0 asd ßåæ∂ø∆œ˜˜¬å˚¬"-- it "works on chinese characters" $ do- tryDecode (TE.encodeUtf8 "试一试中文") `shouldBe` Right "试一试中文"-- -- xit "works on http:/foo/p\237\160\128" $ do- -- -- I don't know exactly the right result of this string, but it should be a correct java byte-string- -- sizedByteStringToText "http:/foo/p\237\160\128" `shouldBe` Right "http:/foo/p?"-- -- xit "works on long and obscure byte string" $ do- -- -- I don't know exactly the right result of this string, but it should be a correct java byte-string- -- sizedByteStringToText obscureByteString `shouldBe` Right "?"--obscureByteString :: SizedByteString a-obscureByteString = SizedByteString- "\192\128\DEL\194\128\195\191\196\128\197\191\198\128\201\143\201\144\202\175\202\176\203\191\204\128\205\175\205\176\207\191\224\144\128\224\147\191\224\148\176\224\150\143\224\150\144\224\151\191\224\152\128\224\155\191\224\156\128\224\157\143\224\158\128\224\158\191\224\164\128\224\165\191\224\166\128\224\167\191\224\168\128\224\169\191\224\170\128\224\171\191\224\172\128\224\173\191\224\174\128\224\175\191\224\176\128\224\177\191\224\178\128\224\179\191\224\180\128\224\181\191\224\182\128\224\183\191\224\184\128\224\185\191\224\186\128\224\187\191\224\188\128\224\191\191\225\128\128\225\130\159\225\130\160\225\131\191\225\132\128\225\135\191\225\136\128\225\141\191\225\142\160\225\143\191\225\144\128\225\153\191\225\154\128\225\154\159\225\154\160\225\155\191\225\158\128\225\159\191\225\160\128\225\162\175\225\184\128\225\187\191\225\188\128\225\191\191\226\128\128\226\129\175\226\129\176\226\130\159\226\130\160\226\131\143\226\131\144\226\131\191\226\132\128\226\133\143\226\133\144\226\134\143\226\134\144\226\135\191\226\136\128\226\139\191\226\140\128\226\143\191\226\144\128\226\144\191\226\145\128\226\145\159\226\145\160\226\147\191\226\148\128\226\149\191\226\150\128\226\150\159\226\150\160\226\151\191\226\152\128\226\155\191\226\156\128\226\158\191\226\160\128\226\163\191\226\186\128\226\187\191\226\188\128\226\191\159\226\191\176\226\191\191\227\128\128\227\128\191\227\129\128\227\130\159\227\130\160\227\131\191\227\132\128\227\132\175\227\132\176\227\134\143\227\134\144\227\134\159\227\134\160\227\134\191\227\136\128\227\139\191\227\140\128\227\143\191\227\144\128\228\182\181\228\184\128\233\191\191\234\128\128\234\146\143\234\146\144\234\147\143\234\176\128\237\158\163\238\128\128\239\163\191\239\164\128\239\171\191\239\172\128\239\173\143\239\173\144\239\183\191\239\184\160\239\184\175\239\184\176\239\185\143\239\185\144\239\185\175\239\185\176\239\187\190\239\187\191\239\187\191\239\188\128\239\191\175"---instance Arbitrary a => Arbitrary (SizedList w a) where- arbitrary =- SizedList <$> arbitrary- shrink (SizedList c) =- SizedList <$> shrink c--instance Arbitrary (SizedByteString w) where- arbitrary = do- len <- choose (0, 50)- SizedByteString . BS.pack <$> sequence (replicate len arbitrary)--instance (Enumish a) => Arbitrary (BitSet w a) where- arbitrary =- BitSet . Set.fromList <$> sublistOf (snd <$> inOrder)
+ test/Language/JVMSpec.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE OverloadedStrings #-}+module Language.JVMSpec where++import SpecHelper++import Test.Hspec hiding (shouldBe, shouldSatisfy, shouldMatchList)++import qualified Data.ByteString.Lazy as BL+import Data.Either+import Data.Foldable+import Data.List as List+import qualified Data.Text as Text++-- vector+import qualified Data.Vector as V++import Language.JVM+import qualified Language.JVM.Attribute.Code as C+import Language.JVM.Attribute.StackMapTable+++spec :: Spec+spec = do+ describe "Main.class" $ do+ fl <- runIO $ BL.readFile "test/data/project/Main.class"++ it "can read classfile from file" $ do+ case readClassFile fl of+ Right clf -> do+ cThisClass clf `shouldBe` "Main"+ cSuperClass clf `shouldBe` "java/lang/Object"+ Left msg ->+ fail $ show msg+ it "can decode a classfile from file" $ do+ case decodeClassFile fl of+ Right _ ->+ True `shouldBe` True+ Left msg ->+ fail $ show msg++ -- spec_reading_classfile++spec_reading_classfile :: Spec+spec_reading_classfile = testAllFiles $ \bs -> do+ let d = decodeClassFile bs+ it "can parse the bytestring" $ do+ d `shouldSatisfy` isRight++ let Right cls = d+ it "has a the magic number: 0xCAFEBABE" $ do+ cMagicNumber cls `shouldBe` 0xCAFEBABE++ it "can bootstrap the constant pool" $ do+ let+ cp = bootstrapConstantPool (cConstantPool cls)+ cp `shouldSatisfy` isRight+ let Right cp' = cp+ forM_ (cMethods' cls) $ \m -> do+ case (runEvolve (EvolveConfig [] cp' (const True)) (evolve m)) of+ Right _ -> return ()+ Left err -> do+ putStr (show err) >> putStr ": "+ print . runEvolve (EvolveConfig [] cp' (const True)) $ do+ x <- link (mDescriptor m)+ n <- link (mName m)+ return ((n, x) :: (MethodDescriptor, Text.Text))+ forM_ (mAttributes m) $ \a -> do+ -- Assume code+ case fromAttribute' a :: Either String (C.Code Low) of+ Right c -> do+ forM_ (byteCodeInstructions . C.codeByteCode $ c) $ \i ->+ putStr " -> " >> print i++ forM_ (C.codeAttributes c) $ \ca -> do+ print $ runEvolve (EvolveConfig [] cp' (const True)) (evolve ca)+ putStrLn (hexStringS $ aInfo ca)+ case fromAttribute' ca :: Either String (StackMapTable Low) of+ Right x ->+ print x+ Left msg ->+ print msg+ Left x ->+ print x++ describe "encoding/decoding" $ do+ let e = encodeClassFile cls+ it "should encode to the original bytestring" $+ e `shouldBe` bs++ it "should decode to the same thing" $+ decodeClassFile e `shouldBe` Right cls++ describe "evolving/devolving" $ do+ let me = evolveClassFile (const True) cls+ it "can evolve the whole class file" $ do+ me `shouldSatisfy` isRight++ let Right x = me+ it "has same or smaller constant pool" $ do+ let d' = devolveClassFile x+ (poolCount $ cConstantPool d') `shouldSatisfy`+ (<= (poolCount $ cConstantPool cls))++ -- it "is the same when devolving with the original constant pool" $+ -- devolveClassFile' (cConstantPool cls) x `shouldMatchClass'` cls++ it "can do full read - write - read process" $ do+ let w = writeClassFile' (cConstantPool cls) x+ let y' = readClassFile w+ y' `shouldSatisfy` isRight+ let Right y = y'+ x `shouldMatchClass` y++shouldMatchClass :: ClassFile High -> ClassFile High -> IO ()+shouldMatchClass y x = do+ cAccessFlags' y `shouldBe` cAccessFlags' x+ cThisClass y `shouldBe` cThisClass x+ cSuperClass y `shouldBe` cSuperClass x+ cInterfaces y `shouldBe` cInterfaces x+ cFields' y `shouldBe` cFields' x+ forM_ (zip (cMethods y) (cMethods x)) $ \ (ym, xm) -> do+ ym `shouldMatchMethod` xm+ y `shouldBe` x++shouldMatchClass' :: ClassFile Low -> ClassFile Low -> IO ()+shouldMatchClass' y x = do+ cAccessFlags' y `shouldBe` cAccessFlags' x+ cThisClass y `shouldBe` cThisClass x+ cSuperClass y `shouldBe` cSuperClass x+ cInterfaces y `shouldBe` cInterfaces x+ cFields' y `shouldBe` cFields' x+ forM_ (zip (cMethods y) (cMethods x)) $ \(ym, xm) -> do+ shouldMatchMethod' ym xm++shouldMatchMethod :: Method High -> Method High -> IO ()+shouldMatchMethod ym xm = do+ mAccessFlags ym `shouldBe` mAccessFlags xm+ mName ym `shouldBe` mName xm+ mDescriptor ym `shouldBe` mDescriptor xm+ mExceptions ym `shouldMatchList` mExceptions xm+ case (mCode ym, mCode xm) of+ (Just yc, Just xc) -> do+ cmpOver C.codeByteCodeOprs yc xc $ \ yb xb -> do+ yb `shouldBe` xb+ _ -> mCode ym `shouldBe` mCode xm++shouldMatchMethod' :: Method Low -> Method Low -> IO ()+shouldMatchMethod' ym xm = do+ mAccessFlags ym `shouldBe` mAccessFlags xm+ mName ym `shouldBe` mName xm+ mDescriptor ym `shouldBe` mDescriptor xm+ forM_ (zip (unSizedList $ mAttributes ym ) (unSizedList $ mAttributes xm)) $ \(ya, xa) -> do+ case (fromAttribute' ya, fromAttribute' xa) of+ (Right yc, Right xc) -> do+ cmpOn C.codeMaxStack yc xc+ cmpOn C.codeMaxLocals yc xc+ cmpOn (C.codeByteCodeInsts :: Code Low -> V.Vector (ByteCodeInst Low)) yc xc+ cmpOn C.codeExceptionTable yc xc+ cmpOver (List.sort . unSizedList . C.codeAttributes) yc xc $ \ yca xca -> do+ case (fromAttribute' yca, fromAttribute' xca)+ :: (Either String (StackMapTable Low), Either String (StackMapTable Low)) of+ (Right yst, Right xst) -> do+ cmpOver stackMapTable yst xst $ shouldBe+ (yst, xst) ->+ yst `shouldBe` xst+ (yc, xc) ->+ yc `shouldBe` xc++cmpOn :: (Show b, Eq b) => (a -> b) -> a -> a -> IO ()+cmpOn f a b =+ f a `shouldBe` f b++cmpOver :: (Foldable t) => (a -> t b) -> a -> a -> (b -> b -> IO ()) -> IO ()+cmpOver g ta tb f =+ forM_ (zip (toList . g $ ta) (toList . g $ tb)) (uncurry f)++cmpPrefixes :: (Foldable t) => (a -> t b) -> a -> a -> ([b] -> [b] -> IO ()) -> IO ()+cmpPrefixes g ta tb f =+ forM_ (zip (inits . toList . g $ ta) (inits . toList . g $ tb)) (uncurry f)
− test/Language/JVMTest.hs
@@ -1,164 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Language.JVMTest where--import SpecHelper--import Data.Either-import qualified Data.IntMap as IM-import Data.List as List-import qualified Data.Text as Text-import qualified Data.ByteString.Lazy as BL-import Data.Foldable--import Language.JVM-import qualified Language.JVM.Attribute.Code as C-import Language.JVM.Attribute.StackMapTable--spec_testing_example :: SpecWith ()-spec_testing_example =- it "can read classfile from file" $ do- eclf <- readClassFile <$> BL.readFile "test/data/project/Main.class"- case eclf of- Right clf -> do- cThisClass clf `shouldBe` ClassName "Main"- cSuperClass clf `shouldBe` ClassName "java/lang/Object"- Left msg ->- fail $ show msg--test_reading_classfile :: IO [TestTree]-test_reading_classfile = testAllFiles $ \bs -> do- let d = decodeClassFile bs- it "can parse the bytestring" $ do- d `shouldSatisfy` isRight-- let Right cls = d- it "has a the magic number: 0xCAFEBABE" $ do- cMagicNumber cls `shouldBe` 0xCAFEBABE-- it "can bootstrap the constant pool" $ do- let- cp = bootstrapConstantPool (cConstantPool cls)- cp `shouldSatisfy` isRight- let Right cp' = cp- forM_ (cMethods' cls) $ \m -> do- case (runEvolve (EvolveConfig [] cp' (const True)) (evolve m)) of- Right _ -> return ()- Left err -> do- putStr (show err) >> putStr ": "- print . runEvolve (EvolveConfig [] cp' (const True)) $ do- x <- link (mDescriptor m)- n <- link (mName m)- return ((n, x) :: (MethodDescriptor, Text.Text))- forM_ (mAttributes m) $ \a -> do- -- Assume code- case fromAttribute' a :: Either String (C.Code Low) of- Right c -> do- forM_ (unByteCode . C.codeByteCode $ c) $ \i ->- putStr " -> " >> print i-- forM_ (C.codeAttributes c) $ \ca -> do- print $ runEvolve (EvolveConfig [] cp' (const True)) (evolve ca)- putStrLn (hexStringS $ aInfo ca)- case fromAttribute' ca :: Either String (StackMapTable Low) of- Right x ->- print x- Left msg ->- print msg- Left x ->- print x-- describe "encoding/decoding" $ do- let e = encodeClassFile cls- it "should encode to the original bytestring" $- e `shouldBe` bs-- it "should decode to the same thing" $- decodeClassFile e `shouldBe` Right cls-- describe "evolving/devolving" $ do- let me = evolveClassFile (const True) cls- it "can evolve the whole class file" $ do- me `shouldSatisfy` isRight-- let Right x = me- it "has same or smaller constant pool" $ do- let d' = devolveClassFile x- (IM.size . unConstantPool $ cConstantPool d') `shouldSatisfy`- (<= (IM.size . unConstantPool $ cConstantPool cls))-- -- it "is the same when devolving with the original constant pool" $- -- devolveClassFile' (cConstantPool cls) x `shouldMatchClass'` cls-- it "can do full read - write - read process" $ do- let w = writeClassFile' (cConstantPool cls) x- let y' = readClassFile w- y' `shouldSatisfy` isRight- let Right y = y'- x `shouldMatchClass` y--shouldMatchClass :: ClassFile High -> ClassFile High -> IO ()-shouldMatchClass y x = do- cAccessFlags' y `shouldBe` cAccessFlags' x- cThisClass y `shouldBe` cThisClass x- cSuperClass y `shouldBe` cSuperClass x- cInterfaces y `shouldBe` cInterfaces x- cFields' y `shouldBe` cFields' x- forM_ (zip (cMethods y) (cMethods x)) $ \ (ym, xm) -> do- ym `shouldMatchMethod` xm- y `shouldBe` x--shouldMatchClass' :: ClassFile Low -> ClassFile Low -> IO ()-shouldMatchClass' y x = do- cAccessFlags' y `shouldBe` cAccessFlags' x- cThisClass y `shouldBe` cThisClass x- cSuperClass y `shouldBe` cSuperClass x- cInterfaces y `shouldBe` cInterfaces x- cFields' y `shouldBe` cFields' x- forM_ (zip (cMethods y) (cMethods x)) $ \(ym, xm) -> do- shouldMatchMethod' ym xm--shouldMatchMethod :: Method High -> Method High -> IO ()-shouldMatchMethod ym xm = do- mAccessFlags ym `shouldBe` mAccessFlags xm- mName ym `shouldBe` mName xm- mDescriptor ym `shouldBe` mDescriptor xm- mExceptions ym `shouldMatchList` mExceptions xm- case (mCode ym, mCode xm) of- (Just yc, Just xc) -> do- cmpOver C.codeByteCodeOprs yc xc $ \ yb xb -> do- yb `shouldBe` xb- _ -> mCode ym `shouldBe` mCode xm--shouldMatchMethod' :: Method Low -> Method Low -> IO ()-shouldMatchMethod' ym xm = do- mAccessFlags ym `shouldBe` mAccessFlags xm- mName ym `shouldBe` mName xm- mDescriptor ym `shouldBe` mDescriptor xm- forM_ (zip (unSizedList $ mAttributes ym ) (unSizedList $ mAttributes xm)) $ \(ya, xa) -> do- case (fromAttribute' ya, fromAttribute' xa) of- (Right yc, Right xc) -> do- cmpOn C.codeMaxStack yc xc- cmpOn C.codeMaxLocals yc xc- cmpOn C.codeByteCodeInsts yc xc- cmpOn C.codeExceptionTable yc xc- cmpOver (List.sort . unSizedList .C.codeAttributes) yc xc $ \ yca xca -> do- case (fromAttribute' yca, fromAttribute' xca)- :: (Either String (StackMapTable Low), Either String (StackMapTable Low)) of- (Right yst, Right xst) -> do- cmpOver stackMapTable yst xst $ shouldBe- (yst, xst) ->- yst `shouldBe` xst- (yc, xc) ->- yc `shouldBe` xc--cmpOn :: (Show b, Eq b) => (a -> b) -> a -> a -> IO ()-cmpOn f a b =- f a `shouldBe` f b--cmpOver :: (Foldable t) => (a -> t b) -> a -> a -> (b -> b -> IO ()) -> IO ()-cmpOver g ta tb f =- forM_ (zip (toList . g $ ta) (toList . g $ tb)) (uncurry f)--cmpPrefixes :: (Foldable t) => (a -> t b) -> a -> a -> ([b] -> [b] -> IO ()) -> IO ()-cmpPrefixes g ta tb f =- forM_ (zip (inits . toList . g $ ta) (inits . toList . g $ tb)) (uncurry f)
+ test/Main.hs view
@@ -0,0 +1,4 @@+import qualified Spec++main :: IO ()+main = Spec.main
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}
test/SpecHelper.hs view
@@ -1,7 +1,7 @@ module SpecHelper- ( module Test.Tasty- , module Test.Hspec.Expectations.Pretty- , module Test.Tasty.QuickCheck+ ( module Test.Hspec.Expectations.Pretty+ , module Test.Hspec.QuickCheck+ , module Test.QuickCheck , module Generic.Random , decode , encode@@ -23,9 +23,9 @@ import Test.Hspec.Expectations.Pretty -import Test.Tasty-import Test.Tasty.Hspec hiding (shouldBe)-import Test.Tasty.QuickCheck+import Test.Hspec hiding (shouldBe)+import Test.Hspec.QuickCheck+import Test.QuickCheck import qualified Test.QuickCheck.Property as P import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString as BS@@ -58,12 +58,12 @@ ] where alpha = "0123456789abcdef" -testAllFiles :: (BL.ByteString -> Spec) -> IO [TestTree]+testAllFiles :: (BL.ByteString -> Spec) -> Spec testAllFiles spec = do- files <- filter isClass <$> recursiveContents "test/data"- forM files $ \file -> do- bs <- blReadFile file- testSpec file $ spec bs+ files <- runIO $ filter isClass <$> recursiveContents "test/data"+ forM_ files $ \file -> do+ bs <- runIO $ blReadFile file+ describe file $ spec bs where isClass p = takeExtension p == ".class"@@ -96,25 +96,27 @@ hexString = List.intercalate " " . group 8 . concat . map toHex . BL.unpack -isoBinary :: (Binary a, Eq a, Show a) => a -> Property+isoBinary :: (Binary a, Eq a, Show a) => a -> P.Property isoBinary a = let bs = encode a- in counterexample (hexString bs) $- decode bs === a+ in P.counterexample (hexString bs) $+ decode bs P.=== a -- | Test that a value can go from the Highest state to binary and back again -- without losing data. isoRoundtrip ::- (Staged a, Eq (a High), Show (a High), Binary (a Low))- => (a High) -> Property+ (Staged a, Eq (a High), Show (a High), Binary (a Low), Show (a Low))+ => (a High) -> P.Property isoRoundtrip a = case roundtrip a of Right (_, a') ->- property $ a' `shouldBe` a- Left msg -> property $ P.failed { P.reason = msg }+ P.property $ a' `shouldBe` a+ Left msg -> P.property $ P.failed { P.reason = msg } where roundtrip a1 = do- let (a', CPBuilder _ cp) = runConstantPoolBuilder (devolve a1) cpbEmpty+ let+ (a', cpb) = runConstantPoolBuilder (devolve a1) cpbEmpty+ cp = constantPoolFromBuilder cpb let bs = encode a' a'' <- bimap trd trd $ decodeOrFail bs cp' <- first show $ bootstrapConstantPool cp@@ -125,16 +127,18 @@ -- without losing data. isoByteCodeRoundtrip :: (ByteCodeStaged a, Eq (a High), Show (a Low), Show (a High), Binary (a Low))- => (a High) -> Property+ => (a High) -> P.Property isoByteCodeRoundtrip a = case byteCodeRoundtrip a of Right ((_, b, cp), a') ->- counterexample (show cp ++ "\n" ++ show b) $ a' `shouldBe` a- Left msg -> property $ P.failed { P.reason = msg }+ P.counterexample (show cp ++ "\n" ++ show b) $ a' `shouldBe` a+ Left msg -> P.property $ P.failed { P.reason = msg } 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+ (a', cbp) = runConstantPoolBuilder (devolveBC (return . fromIntegral) a1) cpbEmpty+ cp = constantPoolFromBuilder cbp let bs = encode a' a'' <- bimap trd trd $ decodeOrFail bs cp' <- first show $ bootstrapConstantPool cp
− test/Test.hs
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-}