diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/jvm-binary.cabal b/jvm-binary.cabal --- a/jvm-binary.cabal +++ b/jvm-binary.cabal @@ -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 diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: jvm-binary -version: '0.3.0' +version: '0.4.0' author: Christian Gram Kalhauge maintainer: Christian Gram Kalhauge synopsis: A library for reading Java class-files @@ -19,7 +19,7 @@ - stack.yaml dependencies: -- base >= 4.9 && < 4.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 diff --git a/src/Language/JVM/Attribute/Code.hs b/src/Language/JVM/Attribute/Code.hs --- a/src/Language/JVM/Attribute/Code.hs +++ b/src/Language/JVM/Attribute/Code.hs @@ -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) = diff --git a/src/Language/JVM/ByteCode.hs b/src/Language/JVM/ByteCode.hs --- a/src/Language/JVM/ByteCode.hs +++ b/src/Language/JVM/ByteCode.hs @@ -1,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) diff --git a/src/Language/JVM/ClassFileReader.hs b/src/Language/JVM/ClassFileReader.hs --- a/src/Language/JVM/ClassFileReader.hs +++ b/src/Language/JVM/ClassFileReader.hs @@ -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 + }) diff --git a/src/Language/JVM/Constant.hs b/src/Language/JVM/Constant.hs --- a/src/Language/JVM/Constant.hs +++ b/src/Language/JVM/Constant.hs @@ -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 #-} diff --git a/src/Language/JVM/ConstantPool.hs b/src/Language/JVM/ConstantPool.hs --- a/src/Language/JVM/ConstantPool.hs +++ b/src/Language/JVM/ConstantPool.hs @@ -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) diff --git a/src/Language/JVM/Staged.hs b/src/Language/JVM/Staged.hs --- a/src/Language/JVM/Staged.hs +++ b/src/Language/JVM/Staged.hs @@ -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 diff --git a/src/Language/JVM/TH.hs b/src/Language/JVM/TH.hs --- a/src/Language/JVM/TH.hs +++ b/src/Language/JVM/TH.hs @@ -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' diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-12.24 +resolver: lts-12.26 packages: - . flags: {} diff --git a/test/Language/JVM/Attribute/BootstrapMethodsSpec.hs b/test/Language/JVM/Attribute/BootstrapMethodsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/JVM/Attribute/BootstrapMethodsSpec.hs @@ -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 []) diff --git a/test/Language/JVM/Attribute/BootstrapMethodsTest.hs b/test/Language/JVM/Attribute/BootstrapMethodsTest.hs deleted file mode 100644 --- a/test/Language/JVM/Attribute/BootstrapMethodsTest.hs +++ /dev/null @@ -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)) diff --git a/test/Language/JVM/Attribute/CodeSpec.hs b/test/Language/JVM/Attribute/CodeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/JVM/Attribute/CodeSpec.hs @@ -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 + diff --git a/test/Language/JVM/Attribute/CodeTest.hs b/test/Language/JVM/Attribute/CodeTest.hs deleted file mode 100644 --- a/test/Language/JVM/Attribute/CodeTest.hs +++ /dev/null @@ -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 - diff --git a/test/Language/JVM/Attribute/ConstantValueSpec.hs b/test/Language/JVM/Attribute/ConstantValueSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/JVM/Attribute/ConstantValueSpec.hs @@ -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 diff --git a/test/Language/JVM/Attribute/ConstantValueTest.hs b/test/Language/JVM/Attribute/ConstantValueTest.hs deleted file mode 100644 --- a/test/Language/JVM/Attribute/ConstantValueTest.hs +++ /dev/null @@ -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 diff --git a/test/Language/JVM/Attribute/EnclosingMethodSpec.hs b/test/Language/JVM/Attribute/EnclosingMethodSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/JVM/Attribute/EnclosingMethodSpec.hs @@ -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 = "Ljava/lang/Object;" + +instance Arbitrary (EnclosingMethod High) where + arbitrary = genericArbitraryU + + + -- "Lcom/apple/eawt/_AppEventHandler$_AppEventDispatcher;" +-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor;" +-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor;" +-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor;" diff --git a/test/Language/JVM/Attribute/EnclosingMethodTest.hs b/test/Language/JVM/Attribute/EnclosingMethodTest.hs deleted file mode 100644 --- a/test/Language/JVM/Attribute/EnclosingMethodTest.hs +++ /dev/null @@ -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 = "Ljava/lang/Object;" - -instance Arbitrary (EnclosingMethod High) where - arbitrary = genericArbitraryU - - - -- "Lcom/apple/eawt/_AppEventHandler$_AppEventDispatcher;" --- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor;" --- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor;" --- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor;" diff --git a/test/Language/JVM/Attribute/ExceptionsSpec.hs b/test/Language/JVM/Attribute/ExceptionsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/JVM/Attribute/ExceptionsSpec.hs @@ -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 diff --git a/test/Language/JVM/Attribute/ExceptionsTest.hs b/test/Language/JVM/Attribute/ExceptionsTest.hs deleted file mode 100644 --- a/test/Language/JVM/Attribute/ExceptionsTest.hs +++ /dev/null @@ -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 diff --git a/test/Language/JVM/Attribute/InnerClassesSpec.hs b/test/Language/JVM/Attribute/InnerClassesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/JVM/Attribute/InnerClassesSpec.hs @@ -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 = "Ljava/lang/Object;" + +instance Arbitrary (InnerClasses High) where + arbitrary = genericArbitraryU + +instance Arbitrary (InnerClass High) where + arbitrary = genericArbitraryU + + + -- "Lcom/apple/eawt/_AppEventHandler$_AppEventDispatcher;" +-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor;" +-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor;" +-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor;" diff --git a/test/Language/JVM/Attribute/InnerClassesTest.hs b/test/Language/JVM/Attribute/InnerClassesTest.hs deleted file mode 100644 --- a/test/Language/JVM/Attribute/InnerClassesTest.hs +++ /dev/null @@ -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 = "Ljava/lang/Object;" - -instance Arbitrary (InnerClasses High) where - arbitrary = genericArbitraryU - -instance Arbitrary (InnerClass High) where - arbitrary = genericArbitraryU - - - -- "Lcom/apple/eawt/_AppEventHandler$_AppEventDispatcher;" --- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor;" --- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor;" --- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor;" diff --git a/test/Language/JVM/Attribute/LineNumberTableSpec.hs b/test/Language/JVM/Attribute/LineNumberTableSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/JVM/Attribute/LineNumberTableSpec.hs @@ -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) diff --git a/test/Language/JVM/Attribute/LineNumberTableTest.hs b/test/Language/JVM/Attribute/LineNumberTableTest.hs deleted file mode 100644 --- a/test/Language/JVM/Attribute/LineNumberTableTest.hs +++ /dev/null @@ -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) diff --git a/test/Language/JVM/Attribute/SignatureSpec.hs b/test/Language/JVM/Attribute/SignatureSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/JVM/Attribute/SignatureSpec.hs @@ -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 " $ do + let sig = "" + parseOnly typeParametersP sig `shouldBe` + Right [ + TypeParameter { + tpIndentifier = "E", + tpClassBound = Just (RefClassType (ClassType { + ctsClassName = "java/lang/Object", + ctsTypeArguments = [] + })), + tpInterfaceBound = [] + } + ] + it "can handle the class signature of Iterator" $ do + let sig = "Ljava/lang/Object;" + parseOnly classSignatureP sig `shouldBe` + Right (ClassSignature { + csTypeParameters = [ + TypeParameter { + tpIndentifier = "E", + tpClassBound = Just (RefClassType (ClassType { + ctsClassName = "java/lang/Object", + ctsTypeArguments = [] + })), + tpInterfaceBound = [] + } + ], + csSuperclassSignature = ClassType { + ctsClassName = "java/lang/Object", + ctsTypeArguments = [] + }, + csInterfaceSignatures = [] + }) + it "can handle the method signature of Iterator" $ do + let sig = "(Ljava/util/function/Consumer<-TE;>;)V" + parseOnly methodSignatureP sig `shouldBe` + Right (MethodSignature { + msTypeParameters = [], + msArguments = [ + ReferenceType (RefClassType (ClassType { + ctsClassName = "java/util/function/Consumer", + ctsTypeArguments = [ + Just (TypeArgument { + taWildcard = Just WildMinus, + taType = RefTypeVariable (TypeVariable { + tvAsText = "E" + }) + }) + ] + })) + ], + msResults = Nothing, + msThrows = [] + }) + + + it "can handle the simple method signature" $ do + parseOnly methodSignatureP "()V" `shouldBe` Right + ( MethodSignature [] [] Nothing []) + + it "can handle throws method signature" $ do + parseOnly (methodSignatureP <* endOfInput) "()V^TE;" `shouldBe` Right + ( MethodSignature [] [] Nothing [ThrowsTypeVariable (TypeVariable "E")]) + + it "can handle throws method signature with class" $ do + parseOnly (methodSignatureP) "()V^Ljava/lang/Exception;" `shouldBe` Right + ( MethodSignature [] [] Nothing [ + ThrowsClass ( + ClassType { + ctsClassName = "java/lang/Exception" + , ctsTypeArguments = [] + } + ) + ]) + + it "can parse a type variable" $ do + parseOnly typeVariableP "TE;" `shouldBe` Right (TypeVariable "E") + + it "can handle the simple field signature" $ do + parseOnly fieldSignatureP "Ljava/util/function/Consumer<-TE;>;" `shouldBe` Right + ( FieldSignature + (RefClassType + (ClassType "java/util/function/Consumer" + [Just (TypeArgument (Just WildMinus) . RefTypeVariable $ TypeVariable "E") ] + ))) + + +instance Arbitrary (Signature High) where + arbitrary = genericArbitraryU + +instance Arbitrary (FieldSignature) where + arbitrary = genericArbitraryU + +instance Arbitrary (ReferenceType) where + arbitrary = do + n <- getSize + if n == 0 + then pure (RefTypeVariable $ TypeVariable "X") + else scale (\s -> s `div` 2) $ genericArbitraryU + +instance Arbitrary (ClassType) where + arbitrary = do + s <- getSize + n <- choose (0, s) + x <- vectorOf n (resize (s `div` n) arbitrary) + oneof + [ ClassType <$> arbitrary <*> pure x + , InnerClassType <$> elements ["a", "subclass"] <*> resize (n `div` 2) arbitrary <*> pure x + ] + + +instance Arbitrary (TypeVariable) where + arbitrary = TypeVariable <$> elements ["A","B", "C", "HJ"] + +instance Arbitrary (TypeSignature) where + arbitrary = do + n <- getSize + if n == 0 + then BaseType <$> arbitrary + else resize (n `div` 2) $ ReferenceType <$> arbitrary + +instance Arbitrary (TypeArgument) where + arbitrary = genericArbitraryU + +instance Arbitrary (TypeParameter) where + arbitrary = TypeParameter <$> elements ["A","B", "C", "HJ"] <*> arbitrary <*> arbitrary + +instance Arbitrary (Wildcard) where + arbitrary = genericArbitraryU + +instance Arbitrary (MethodSignature) where + arbitrary = genericArbitraryU + +instance Arbitrary (ClassSignature) where + arbitrary = genericArbitraryU + +instance Arbitrary (ThrowsSignature) where + arbitrary = genericArbitraryU + +-- "Lcom/apple/eawt/_AppEventHandler$_AppEventDispatcher;" +-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor;" +-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor;" +-- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor;" diff --git a/test/Language/JVM/Attribute/SignatureTest.hs b/test/Language/JVM/Attribute/SignatureTest.hs deleted file mode 100644 --- a/test/Language/JVM/Attribute/SignatureTest.hs +++ /dev/null @@ -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 " $ do - let sig = "" - parseOnly typeParametersP sig `shouldBe` - Right [ - TypeParameter { - tpIndentifier = "E", - tpClassBound = Just (RefClassType (ClassType { - ctsClassName = "java/lang/Object", - ctsTypeArguments = [] - })), - tpInterfaceBound = [] - } - ] - it "can handle the class signature of Iterator" $ do - let sig = "Ljava/lang/Object;" - parseOnly classSignatureP sig `shouldBe` - Right (ClassSignature { - csTypeParameters = [ - TypeParameter { - tpIndentifier = "E", - tpClassBound = Just (RefClassType (ClassType { - ctsClassName = "java/lang/Object", - ctsTypeArguments = [] - })), - tpInterfaceBound = [] - } - ], - csSuperclassSignature = ClassType { - ctsClassName = "java/lang/Object", - ctsTypeArguments = [] - }, - csInterfaceSignatures = [] - }) - it "can handle the method signature of Iterator" $ do - let sig = "(Ljava/util/function/Consumer<-TE;>;)V" - parseOnly methodSignatureP sig `shouldBe` - Right (MethodSignature { - msTypeParameters = [], - msArguments = [ - ReferenceType (RefClassType (ClassType { - ctsClassName = "java/util/function/Consumer", - ctsTypeArguments = [ - Just (TypeArgument { - taWildcard = Just WildMinus, - taType = RefTypeVariable (TypeVariable { - tvAsText = "E" - }) - }) - ] - })) - ], - msResults = Nothing, - msThrows = [] - }) - - - it "can handle the simple method signature" $ do - parseOnly methodSignatureP "()V" `shouldBe` Right - ( MethodSignature [] [] Nothing []) - - it "can handle throws method signature" $ do - parseOnly (methodSignatureP <* endOfInput) "()V^TE;" `shouldBe` Right - ( MethodSignature [] [] Nothing [ThrowsTypeVariable (TypeVariable "E")]) - - it "can handle throws method signature with class" $ do - parseOnly (methodSignatureP) "()V^Ljava/lang/Exception;" `shouldBe` Right - ( MethodSignature [] [] Nothing [ - ThrowsClass ( - ClassType { - ctsClassName = "java/lang/Exception" - , ctsTypeArguments = [] - } - ) - ]) - - it "can parse a type variable" $ do - parseOnly typeVariableP "TE;" `shouldBe` Right (TypeVariable "E") - - it "can handle the simple field signature" $ do - parseOnly fieldSignatureP "Ljava/util/function/Consumer<-TE;>;" `shouldBe` Right - ( FieldSignature - (RefClassType - (ClassType "java/util/function/Consumer" - [Just (TypeArgument (Just WildMinus) . RefTypeVariable $ TypeVariable "E") ] - ))) - - -instance Arbitrary (Signature High) where - arbitrary = genericArbitraryU - -instance Arbitrary (FieldSignature) where - arbitrary = genericArbitraryU - -instance Arbitrary (ReferenceType) where - arbitrary = do - n <- getSize - if n == 0 - then pure (RefTypeVariable $ TypeVariable "X") - else scale (\s -> s `div` 2) $ genericArbitraryU - -instance Arbitrary (ClassType) where - arbitrary = do - s <- getSize - n <- choose (0, s) - x <- vectorOf n (resize (s `div` n) arbitrary) - oneof - [ ClassType <$> arbitrary <*> pure x - , InnerClassType <$> elements ["a", "subclass"] <*> resize (n `div` 2) arbitrary <*> pure x - ] - - -instance Arbitrary (TypeVariable) where - arbitrary = TypeVariable <$> elements ["A","B", "C", "HJ"] - -instance Arbitrary (TypeSignature) where - arbitrary = do - n <- getSize - if n == 0 - then BaseType <$> arbitrary - else resize (n `div` 2) $ ReferenceType <$> arbitrary - -instance Arbitrary (TypeArgument) where - arbitrary = genericArbitraryU - -instance Arbitrary (TypeParameter) where - arbitrary = TypeParameter <$> elements ["A","B", "C", "HJ"] <*> arbitrary <*> arbitrary - -instance Arbitrary (Wildcard) where - arbitrary = genericArbitraryU - -instance Arbitrary (MethodSignature) where - arbitrary = genericArbitraryU - -instance Arbitrary (ClassSignature) where - arbitrary = genericArbitraryU - -instance Arbitrary (ThrowsSignature) where - arbitrary = genericArbitraryU - --- "Lcom/apple/eawt/_AppEventHandler$_AppEventDispatcher;" --- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor;" --- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor;" --- "Lcom/apple/eawt/_AppEventHandler$_BooleanAppEventMultiplexor;" diff --git a/test/Language/JVM/Attribute/StackMapTableSpec.hs b/test/Language/JVM/Attribute/StackMapTableSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/JVM/Attribute/StackMapTableSpec.hs @@ -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 + ] diff --git a/test/Language/JVM/Attribute/StackMapTableTest.hs b/test/Language/JVM/Attribute/StackMapTableTest.hs deleted file mode 100644 --- a/test/Language/JVM/Attribute/StackMapTableTest.hs +++ /dev/null @@ -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 - ] diff --git a/test/Language/JVM/AttributeSpec.hs b/test/Language/JVM/AttributeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/JVM/AttributeSpec.hs @@ -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 diff --git a/test/Language/JVM/AttributeTest.hs b/test/Language/JVM/AttributeTest.hs deleted file mode 100644 --- a/test/Language/JVM/AttributeTest.hs +++ /dev/null @@ -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 diff --git a/test/Language/JVM/ClassFileSpec.hs b/test/Language/JVM/ClassFileSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/JVM/ClassFileSpec.hs @@ -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 {..} diff --git a/test/Language/JVM/ClassFileTest.hs b/test/Language/JVM/ClassFileTest.hs deleted file mode 100644 --- a/test/Language/JVM/ClassFileTest.hs +++ /dev/null @@ -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 {..} diff --git a/test/Language/JVM/ConstantSpec.hs b/test/Language/JVM/ConstantSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/JVM/ConstantSpec.hs @@ -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 diff --git a/test/Language/JVM/ConstantTest.hs b/test/Language/JVM/ConstantTest.hs deleted file mode 100644 --- a/test/Language/JVM/ConstantTest.hs +++ /dev/null @@ -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 diff --git a/test/Language/JVM/FieldSpec.hs b/test/Language/JVM/FieldSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/JVM/FieldSpec.hs @@ -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 diff --git a/test/Language/JVM/FieldTest.hs b/test/Language/JVM/FieldTest.hs deleted file mode 100644 --- a/test/Language/JVM/FieldTest.hs +++ /dev/null @@ -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 diff --git a/test/Language/JVM/MethodSpec.hs b/test/Language/JVM/MethodSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/JVM/MethodSpec.hs @@ -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 diff --git a/test/Language/JVM/MethodTest.hs b/test/Language/JVM/MethodTest.hs deleted file mode 100644 --- a/test/Language/JVM/MethodTest.hs +++ /dev/null @@ -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 diff --git a/test/Language/JVM/TypeSpec.hs b/test/Language/JVM/TypeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/JVM/TypeSpec.hs @@ -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 diff --git a/test/Language/JVM/TypeTest.hs b/test/Language/JVM/TypeTest.hs deleted file mode 100644 --- a/test/Language/JVM/TypeTest.hs +++ /dev/null @@ -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 diff --git a/test/Language/JVM/UtilsSpec.hs b/test/Language/JVM/UtilsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/JVM/UtilsSpec.hs @@ -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) diff --git a/test/Language/JVM/UtilsTest.hs b/test/Language/JVM/UtilsTest.hs deleted file mode 100644 --- a/test/Language/JVM/UtilsTest.hs +++ /dev/null @@ -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) diff --git a/test/Language/JVMSpec.hs b/test/Language/JVMSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/JVMSpec.hs @@ -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) diff --git a/test/Language/JVMTest.hs b/test/Language/JVMTest.hs deleted file mode 100644 --- a/test/Language/JVMTest.hs +++ /dev/null @@ -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) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,4 @@ +import qualified Spec + +main :: IO () +main = Spec.main diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -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 diff --git a/test/Test.hs b/test/Test.hs deleted file mode 100644 --- a/test/Test.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-}