{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE RecordWildCards #-}

-- | Converts between high level and low level representations
module JVM.Data.Convert where

import Data.IndexedMap qualified as IM
import Data.Maybe (fromMaybe)
import Data.TypeMergingList qualified as TML
import Data.Vector qualified as V
import JVM.Data.Abstract.ClassFile qualified as Abs
import JVM.Data.Abstract.ConstantPool (ConstantPoolEntry (CPClassEntry, CPUTF8Entry))
import JVM.Data.Abstract.Name (QualifiedClassName, parseQualifiedClassName)
import JVM.Data.Abstract.Type (ClassInfoType (..))
import JVM.Data.Convert.AccessFlag (accessFlagsToWord16)
import JVM.Data.Convert.ConstantPool
import JVM.Data.Convert.Field (convertField)
import JVM.Data.Convert.Method (convertMethod)
import JVM.Data.Convert.Monad
import JVM.Data.JVMVersion (getMajor, getMinor)
import JVM.Data.Raw.ClassFile (Attribute (BootstrapMethodsAttribute))
import JVM.Data.Raw.ClassFile qualified as Raw
import JVM.Data.Raw.MagicNumbers qualified as MagicNumbers
import Effectful

jloName :: QualifiedClassName
jloName :: QualifiedClassName
jloName = Text -> QualifiedClassName
parseQualifiedClassName Text
"java.lang.Object"

convertClassAttributes :: (ConvertEff r) => [Abs.ClassFileAttribute] -> Eff r [Raw.AttributeInfo]
convertClassAttributes :: forall (r :: [(* -> *) -> * -> *]).
ConvertEff r =>
[ClassFileAttribute] -> Eff r [AttributeInfo]
convertClassAttributes = (ClassFileAttribute -> Eff r AttributeInfo)
-> [ClassFileAttribute] -> Eff r [AttributeInfo]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ClassFileAttribute -> Eff r AttributeInfo
forall {r :: [(* -> *) -> * -> *]}.
(ConstantPool :> r) =>
ClassFileAttribute -> Eff r AttributeInfo
convertClassAttribute
  where
    convertClassAttribute :: ClassFileAttribute -> Eff r AttributeInfo
convertClassAttribute (Abs.SourceFile Text
text) = do
        nameIndex <- ConstantPoolEntry -> Eff r U2
forall (r :: [(* -> *) -> * -> *]).
(ConstantPool :> r) =>
ConstantPoolEntry -> Eff r U2
findIndexOf (Text -> ConstantPoolEntry
CPUTF8Entry Text
"SourceFile")
        textIndex <- findIndexOf (CPUTF8Entry text)
        pure $ Raw.AttributeInfo nameIndex (Raw.SourceFileAttribute textIndex)
    convertClassAttribute (Abs.InnerClasses [InnerClassInfo]
classes) = do
        nameIndex <- ConstantPoolEntry -> Eff r U2
forall (r :: [(* -> *) -> * -> *]).
(ConstantPool :> r) =>
ConstantPoolEntry -> Eff r U2
findIndexOf (Text -> ConstantPoolEntry
CPUTF8Entry Text
"InnerClasses")
        classes' <- traverse convertInnerClass classes
        pure $ Raw.AttributeInfo nameIndex (Raw.InnerClassesAttribute (V.fromList classes'))
    convertClassAttribute ClassFileAttribute
other = String -> Eff r AttributeInfo
forall a. HasCallStack => String -> a
error (String -> Eff r AttributeInfo) -> String -> Eff r AttributeInfo
forall a b. (a -> b) -> a -> b
$ String
"Unsupported class attribute: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ClassFileAttribute -> String
forall a. Show a => a -> String
show ClassFileAttribute
other

    convertInnerClass :: InnerClassInfo -> Eff r InnerClassInfo
convertInnerClass Abs.InnerClassInfo{[ClassAccessFlag]
Text
QualifiedClassName
innerClassInfo :: QualifiedClassName
outerClassInfo :: QualifiedClassName
innerName :: Text
accessFlags :: [ClassAccessFlag]
accessFlags :: InnerClassInfo -> [ClassAccessFlag]
innerName :: InnerClassInfo -> Text
outerClassInfo :: InnerClassInfo -> QualifiedClassName
innerClassInfo :: InnerClassInfo -> QualifiedClassName
..} = do
        innerIndex <- ConstantPoolEntry -> Eff r U2
forall (r :: [(* -> *) -> * -> *]).
(ConstantPool :> r) =>
ConstantPoolEntry -> Eff r U2
findIndexOf (ClassInfoType -> ConstantPoolEntry
CPClassEntry (ClassInfoType -> ConstantPoolEntry)
-> ClassInfoType -> ConstantPoolEntry
forall a b. (a -> b) -> a -> b
$ QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
innerClassInfo)
        outerIndex <- (findIndexOf . CPClassEntry . ClassInfoType) outerClassInfo
        nameIndex <- (findIndexOf . CPUTF8Entry) innerName
        let innerFlags = [ClassAccessFlag] -> U2
forall a. ConvertAccessFlag a => [a] -> U2
accessFlagsToWord16 [ClassAccessFlag]
accessFlags
        pure $ Raw.InnerClassInfo innerIndex outerIndex nameIndex innerFlags

convert :: Abs.ClassFile -> Either CodeConverterError Raw.ClassFile
convert :: ClassFile -> Either CodeConverterError ClassFile
convert Abs.ClassFile{[QualifiedClassName]
[ClassAccessFlag]
[ClassFileMethod]
[ClassFileField]
Maybe QualifiedClassName
JVMVersion
QualifiedClassName
TypeMergingList ClassFileAttribute
name :: QualifiedClassName
version :: JVMVersion
accessFlags :: [ClassAccessFlag]
superClass :: Maybe QualifiedClassName
interfaces :: [QualifiedClassName]
fields :: [ClassFileField]
methods :: [ClassFileMethod]
attributes :: TypeMergingList ClassFileAttribute
attributes :: ClassFile -> TypeMergingList ClassFileAttribute
methods :: ClassFile -> [ClassFileMethod]
fields :: ClassFile -> [ClassFileField]
interfaces :: ClassFile -> [QualifiedClassName]
superClass :: ClassFile -> Maybe QualifiedClassName
accessFlags :: ClassFile -> [ClassAccessFlag]
version :: ClassFile -> JVMVersion
name :: ClassFile -> QualifiedClassName
..} = do
    (tempClass, cpState) <- Eff '[] (Either CodeConverterError (ClassFile, ConstantPoolState))
-> Either CodeConverterError (ClassFile, ConstantPoolState)
forall a. HasCallStack => Eff '[] a -> a
runPureEff (Eff '[] (Either CodeConverterError (ClassFile, ConstantPoolState))
 -> Either CodeConverterError (ClassFile, ConstantPoolState))
-> Eff
     '[] (Either CodeConverterError (ClassFile, ConstantPoolState))
-> Either CodeConverterError (ClassFile, ConstantPoolState)
forall a b. (a -> b) -> a -> b
$ Eff '[ConstantPool, Error CodeConverterError] ClassFile
-> Eff
     '[] (Either CodeConverterError (ClassFile, ConstantPoolState))
forall (r :: [(* -> *) -> * -> *]) a.
Eff (ConstantPool : Error CodeConverterError : r) a
-> Eff r (Either CodeConverterError (a, ConstantPoolState))
runConvertM (Eff '[ConstantPool, Error CodeConverterError] ClassFile
 -> Eff
      '[] (Either CodeConverterError (ClassFile, ConstantPoolState)))
-> Eff '[ConstantPool, Error CodeConverterError] ClassFile
-> Eff
     '[] (Either CodeConverterError (ClassFile, ConstantPoolState))
forall a b. (a -> b) -> a -> b
$ do
        nameIndex <- ConstantPoolEntry
-> Eff '[ConstantPool, Error CodeConverterError] U2
forall (r :: [(* -> *) -> * -> *]).
(ConstantPool :> r) =>
ConstantPoolEntry -> Eff r U2
findIndexOf (ClassInfoType -> ConstantPoolEntry
CPClassEntry (ClassInfoType -> ConstantPoolEntry)
-> ClassInfoType -> ConstantPoolEntry
forall a b. (a -> b) -> a -> b
$ QualifiedClassName -> ClassInfoType
ClassInfoType QualifiedClassName
name)
        superIndex <- findIndexOf (CPClassEntry $ ClassInfoType (fromMaybe jloName superClass))
        let flags = [ClassAccessFlag] -> U2
forall a. ConvertAccessFlag a => [a] -> U2
accessFlagsToWord16 [ClassAccessFlag]
accessFlags
        interfaces' <- traverse (findIndexOf . CPClassEntry . ClassInfoType) interfaces
        attributes' <- convertClassAttributes (TML.toList attributes)
        fields' <- traverse convertField fields
        methods' <- traverse convertMethod methods

        pure $
            Raw.ClassFile
                MagicNumbers.classMagic
                (getMinor version)
                (getMajor version)
                mempty -- temporary empty constant pool
                flags
                nameIndex
                superIndex
                (V.fromList interfaces')
                (V.fromList fields')
                (V.fromList methods')
                (V.fromList attributes')

    let (bmIndex, finalConstantPool) = runPureEff $ runConstantPoolWith cpState $ do
            let bootstrapAttr = Vector BootstrapMethod -> Attribute
BootstrapMethodsAttribute (IndexedMap BootstrapMethod -> Vector BootstrapMethod
forall a. IndexedMap a -> Vector a
IM.toVector ConstantPoolState
cpState.bootstrapMethods)
            attrNameIndex <- findIndexOf (CPUTF8Entry "BootstrapMethods")
            pure $ Raw.AttributeInfo attrNameIndex bootstrapAttr

    pure $ tempClass{Raw.constantPool = IM.toVector finalConstantPool.constantPool, Raw.attributes = bmIndex `V.cons` tempClass.attributes}