{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
module Language.JVM.ClassFile
( ClassFile (..)
, cAccessFlags
, cFields
, cMethods
, cSignature
, 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.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
data ClassAttributes r = ClassAttributes
{ caBootstrapMethods :: [ BootstrapMethods r]
, caSignature :: [ Signature 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 collect' (cAttributes cf)
return $ cf
{ cConstantPool = ()
, cThisClass = tci'
, cSuperClass = sci'
, cInterfaces = cii'
, cFields' = cf'
, cMethods' = cm'
, cAttributes = ca'
}
where
fromCollector (a, b, c) =
ClassAttributes (appEndo a []) (appEndo b []) (appEndo c [])
collect' attr =
collect (mempty, mempty, Endo (attr:)) attr
[ toC $ \e -> (Endo (e:), mempty, mempty)
, toC $ \e -> (mempty, Endo (e:), mempty)]
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 at) = do
cm' <- mapM toAttribute cm
cs' <- mapM toAttribute cs
at' <- mapM devolve at
return (cm' ++ cs' ++ at')
$(deriveBase ''ClassAttributes)
$(deriveBaseWithBinary ''ClassFile)