jvm-binary-0.9.0: test/SpecHelper.hs

module SpecHelper
  ( module Test.Hspec.Expectations.Pretty
  , module Test.Hspec.QuickCheck
  , module Test.QuickCheck
  , module Generic.Random
  , decode
  , encode
  , blReadFile
  , isoBinary
  , isoRoundtrip
  , isoByteCodeRoundtrip
  , byteCodeRoundtrip
  , testAllFiles
  , hexStringS
  , hexString
  , withTestClass
  , Spec
  , SpecWith
  , it
  , xit
  , describe
  , xdescribe
  , fdescribe
  ) where

import Test.Hspec.Expectations.Pretty

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

import Data.Bifunctor

import System.FilePath
import System.Directory
import           Generic.Random

import Control.Monad
import Data.Binary
import Data.Bits
import qualified Data.List as List

import Language.JVM.ByteCode
import Language.JVM.ClassFile
import Language.JVM.Utils
import Language.JVM.Staged
import Language.JVM.ClassFileReader
import Language.JVM.ConstantPool

blReadFile :: FilePath -> IO BL.ByteString
blReadFile = BL.readFile

toHex :: Word8 -> String
toHex x =
  [ alpha !! fromIntegral (x `shift` (-4))
  , alpha !! fromIntegral (x `mod` 16)
  ]
  where alpha = "0123456789abcdef"

testAllFiles :: (BL.ByteString -> Spec) -> Spec
testAllFiles spec = do
  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"
      && p /= "test/data/SQLite.class"

withTestClass :: String -> IO (ClassFile High)
withTestClass str = do
  Right rf <- readClassFile <$> (blReadFile $ "test/data/" ++ str ++ ".class")
  return rf

-- testSomeFiles :: SpecWith BL.ByteString -> IO [TestTree]
-- testSomeFiles spec =
--   forM files $ \file -> testSpec file (beforeAll (blReadFile file) spec)
--   where
--     files =
--       [ "test/data/java/util/zip/ZipOutputStream.class"
--       , "test/data/project/Main.class"
--       , "test/data/com/sun/istack/internal/localization/Localizable.class"
--       , "test/data/SQLite.class"
--       , "test/data/Emitter.class"
--       , "test/data/EventExecutorGroup.class"
--       , "test/data/NioEventLoopGroup.class"
--       ]

hexStringS :: BS.ByteString -> String
hexStringS =
  hexString . BL.fromStrict

hexString :: BL.ByteString -> String
hexString =
  List.intercalate " " . group 8 . concat . map toHex . BL.unpack

isoBinary :: (Binary a, Eq a, Show a) => a -> P.Property
isoBinary a =
  let bs = encode 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), Show (a Low))
  => (a High) -> P.Property
isoRoundtrip a =
  case roundtrip a of
    Right (_, a') ->
      P.property $ a' `shouldBe` a
    Left msg -> P.property $ P.failed { P.reason = msg }
  where
    roundtrip a1 = do
      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
      a3 <- first show $ runEvolve (EvolveConfig [] cp' (const True)) (evolve a'')
      return (bs, a3)

-- | Test that a value can go from the Highest state to binary and back again
-- without losing data.
isoByteCodeRoundtrip ::
  (ByteCodeStaged a, Eq (a High), Show (a Low), Show (a High), Binary (a Low))
  => (a High) -> P.Property
isoByteCodeRoundtrip a =
  case byteCodeRoundtrip a of
    Right ((_, b, cp), a') ->
      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', 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
  a3 <- first show $ runEvolve (EvolveConfig [] cp' (const True)) (evolveBC (return . fromIntegral) a'')
  return ((bs, a', cp'), a3)

folderContents :: FilePath -> IO [ FilePath ]
folderContents fp =
  map (fp </>) <$> listDirectory fp

recursiveContents :: FilePath -> IO [ FilePath ]
recursiveContents fp = do
  test <- doesDirectoryExist fp
  (fp:) <$> if test then do
    content <- folderContents fp
    concat <$> mapM recursiveContents content
  else return []

group :: Int -> [a] -> [[a]]
group _ [] = []
group n l
  | n > 0 = (take n l) : (group n (drop n l))
  | otherwise = error "Negative n"