{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module Language.JVMSpec where

import SpecHelper

import Test.Hspec hiding (shouldBe, shouldMatchList, shouldSatisfy)

import qualified Data.ByteString.Lazy as BL
import Data.Either
import Data.Foldable
import Data.List as List
import qualified Data.Text as Text

-- prelude

import Control.Monad
import System.Environment

-- filepath
import System.FilePath

-- 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 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
  mAttributes ym `shouldMatchMethodAttributes` mAttributes xm

shouldMatchMethodAttributes :: MethodAttributes High -> MethodAttributes High -> IO ()
shouldMatchMethodAttributes ym xm = do
  case (firstOne $ maCode ym, firstOne $ maCode xm) of
    (Just yc, Just xc) -> do
      cmpOver C.codeByteCodeOprs yc xc $ \yb xb -> do
        yb `shouldBe` xb
    _ -> maCode ym `shouldBe` maCode xm
  ym `shouldBe` 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)
