{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
module Language.JVM.ClassFile
( ClassFile (..)
, cAccessFlags
, cFields
, cMethods
, cSignature
, cEnclosingMethod
, cInnerClasses
, ClassAttributes (..)
, cBootstrapMethods
) where
import Data.Binary
import Data.Monoid
import Data.Set
import Language.JVM.AccessFlag
import Language.JVM.Attribute
import Language.JVM.Attribute.BootstrapMethods
import Language.JVM.Attribute.EnclosingMethod
import Language.JVM.Attribute.InnerClasses
import Language.JVM.Constant
import Language.JVM.ConstantPool as CP
import Language.JVM.Field (Field)
import Language.JVM.Method (Method)
import Language.JVM.Staged
import Language.JVM.Utils
data ClassFile r = ClassFile
{ cMagicNumber :: !Word32
, cMinorVersion :: !Word16
, cMajorVersion :: !Word16
, cConstantPool :: !(Choice (ConstantPool r) () r)
, cAccessFlags' :: !(BitSet16 CAccessFlag)
, cThisClass :: !(Ref ClassName r)
, cSuperClass :: !(Ref ClassName r)
, cInterfaces :: !(SizedList16 (Ref ClassName r))
, cFields' :: !(SizedList16 (Field r))
, cMethods' :: !(SizedList16 (Method r))
, cAttributes :: !(Attributes ClassAttributes r)
}
cAccessFlags :: ClassFile r -> Set CAccessFlag
cAccessFlags = toSet . cAccessFlags'
cFields :: ClassFile r -> [Field r]
cFields = unSizedList . cFields'
cMethods :: ClassFile r -> [Method r]
cMethods = unSizedList . cMethods'
cBootstrapMethods' :: ClassFile High -> Maybe (BootstrapMethods High)
cBootstrapMethods' =
firstOne . caBootstrapMethods . cAttributes
cBootstrapMethods :: ClassFile High -> [BootstrapMethod High]
cBootstrapMethods =
maybe [] methods . cBootstrapMethods'
cSignature :: ClassFile High -> Maybe (Signature High)
cSignature =
firstOne . caSignature . cAttributes
cEnclosingMethod :: ClassFile High -> Maybe (EnclosingMethod High)
cEnclosingMethod =
firstOne . caEnclosingMethod . cAttributes
cInnerClasses' :: ClassFile High -> Maybe (InnerClasses High)
cInnerClasses' =
firstOne . caInnerClasses . cAttributes
cInnerClasses :: ClassFile High -> [InnerClass High]
cInnerClasses =
maybe [] innerClasses . cInnerClasses'
data ClassAttributes r = ClassAttributes
{ caBootstrapMethods :: [ BootstrapMethods r]
, caSignature :: [ Signature r ]
, caEnclosingMethod :: [ EnclosingMethod r ]
, caInnerClasses :: [ InnerClasses r ]
, caOthers :: [ Attribute r ]
}
instance Staged ClassFile where
evolve cf = label "ClassFile" $ do
tci' <- link (cThisClass cf)
sci' <-
if tci' /= ClassName "java/lang/Object"
then do
link (cSuperClass cf)
else do
return $ ClassName "java/lang/Object"
cii' <- mapM link $ cInterfaces cf
cf' <- mapM evolve $ cFields' cf
cm' <- mapM evolve $ cMethods' cf
ca' <- fromCollector <$> fromAttributes ClassAttribute collect' (cAttributes cf)
return $ cf
{ cConstantPool = ()
, cThisClass = tci'
, cSuperClass = sci'
, cInterfaces = cii'
, cFields' = cf'
, cMethods' = cm'
, cAttributes = ca'
}
where
fromCollector = flip appEndo (ClassAttributes [] [] [] [] [])
collect' attr =
collect (Endo (\ca -> ca {caOthers = attr: caOthers ca})) attr
[ toC $ \e -> Endo (\ca -> ca {caSignature = e : caSignature ca})
, toC $ \e -> Endo (\ca -> ca {caEnclosingMethod = e : caEnclosingMethod ca})
, toC $ \e -> Endo (\ca -> ca {caBootstrapMethods = e : caBootstrapMethods ca})
, toC $ \e -> Endo (\ca -> ca {caInnerClasses = e : caInnerClasses ca})
]
devolve cf = do
tci' <- unlink (cThisClass cf)
sci' <-
if cThisClass cf /= ClassName "java/lang/Object" then
unlink (cSuperClass cf)
else
return $ 0
cii' <- mapM unlink $ cInterfaces cf
cf' <- mapM devolve $ cFields' cf
cm' <- mapM devolve $ cMethods' cf
ca' <- fromClassAttributes $ cAttributes cf
return $ cf
{ cConstantPool = CP.empty
, cThisClass = tci'
, cSuperClass = sci'
, cInterfaces = cii'
, cFields' = cf'
, cMethods' = cm'
, cAttributes = SizedList ca'
}
where
fromClassAttributes (ClassAttributes cm cs cem cin at) = do
concat <$> sequence
[ mapM toAttribute cm
, mapM toAttribute cs
, mapM toAttribute cem
, mapM toAttribute cin
, mapM devolve at
]
$(deriveBase ''ClassAttributes)
$(deriveBaseWithBinary ''ClassFile)