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

-- | Converts between high level and low level representations
module H2JVM.Internal.Convert (jloName, convert) where

import Data.Maybe (fromMaybe)
import Effectful
import Effectful.Error.Static

import Data.Vector qualified as V

import H2JVM.ConstantPool (ConstantPoolEntry (CPClassEntry, CPUTF8Entry))
import H2JVM.Internal.Convert.AccessFlag (accessFlagsToWord16)
import H2JVM.Internal.Convert.ConstantPool
import H2JVM.Internal.Convert.Field (convertField)
import H2JVM.Internal.Convert.Method (convertMethod)
import H2JVM.Internal.Convert.Monad
import H2JVM.Internal.Raw.ClassFile (Attribute (BootstrapMethodsAttribute))
import H2JVM.JVMVersion (getMajor, getMinor)
import H2JVM.Name (QualifiedClassName, parseQualifiedClassName)
import H2JVM.Type (ClassInfoType (..))

import H2JVM.ClassFile qualified as Abs
import H2JVM.Data.TypeMergingList qualified as TML
import H2JVM.Internal.IndexedMap qualified as IM
import H2JVM.Internal.Raw.ClassFile qualified as Raw
import H2JVM.Internal.Raw.MagicNumbers qualified as MagicNumbers

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 :: [(* -> *) -> * -> *]}.
(State ConstantPoolState :> r, Error CodeConverterError :> 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 :: [(* -> *) -> * -> *]).
(HasCallStack, ConstantPoolEff 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 :: [(* -> *) -> * -> *]).
(HasCallStack, ConstantPoolEff 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 = CodeConverterError -> Eff r AttributeInfo
forall e (es :: [(* -> *) -> * -> *]) a.
(HasCallStack, Error e :> es, Show e) =>
e -> Eff es a
throwError (CodeConverterError -> Eff r AttributeInfo)
-> CodeConverterError -> Eff r AttributeInfo
forall a b. (a -> b) -> a -> b
$ String -> CodeConverterError
UnsupportedAttribute (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 :: [(* -> *) -> * -> *]).
(HasCallStack, ConstantPoolEff 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]
[ClassFileField]
[ClassFileMethod]
Maybe QualifiedClassName
QualifiedClassName
JVMVersion
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
..} = Eff '[] (Either CodeConverterError ClassFile)
-> Either CodeConverterError ClassFile
forall a. HasCallStack => Eff '[] a -> a
runPureEff (Eff '[] (Either CodeConverterError ClassFile)
 -> Either CodeConverterError ClassFile)
-> Eff '[] (Either CodeConverterError ClassFile)
-> Either CodeConverterError ClassFile
forall a b. (a -> b) -> a -> b
$ Eff '[Error CodeConverterError] ClassFile
-> Eff '[] (Either CodeConverterError ClassFile)
forall e (es :: [(* -> *) -> * -> *]) a.
HasCallStack =>
Eff (Error e : es) a -> Eff es (Either e a)
runErrorNoCallStack (Eff '[Error CodeConverterError] ClassFile
 -> Eff '[] (Either CodeConverterError ClassFile))
-> Eff '[Error CodeConverterError] ClassFile
-> Eff '[] (Either CodeConverterError ClassFile)
forall a b. (a -> b) -> a -> b
$ do
    (tempClass, cpState) <- Eff (ConstantPoolEffs '[]) ClassFile
-> Eff '[Error CodeConverterError] (ClassFile, ConstantPoolState)
forall (r :: [(* -> *) -> * -> *]) a.
Eff (ConstantPoolEffs r) a
-> Eff (Error CodeConverterError : r) (a, ConstantPoolState)
runConstantPool (Eff (ConstantPoolEffs '[]) ClassFile
 -> Eff '[Error CodeConverterError] (ClassFile, ConstantPoolState))
-> Eff (ConstantPoolEffs '[]) ClassFile
-> Eff '[Error CodeConverterError] (ClassFile, ConstantPoolState)
forall a b. (a -> b) -> a -> b
$ do
        nameIndex <- ConstantPoolEntry -> Eff (ConstantPoolEffs '[]) U2
forall (r :: [(* -> *) -> * -> *]).
(HasCallStack, ConstantPoolEff 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')

    (bmIndex, finalConstantPool) <- 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}