{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MonoLocalBinds             #-}
{-# LANGUAGE RankNTypes                 #-}
module Language.JVM.ClassFileReader
  ( readClassFile
  , writeClassFile
  , writeClassFile'

  -- * Finer granularity commands
  , decodeClassFile
  , encodeClassFile
  , evolveClassFile
  , devolveClassFile
  , devolveClassFile'

  -- * Helpers
  , roundtripCopy

  -- * Evolve
  , Evolve
  , ClassFileError
  , EvolveConfig (..)
  , runEvolve
  , bootstrapConstantPool

  -- * Builder
  , ConstantPoolBuilder
  , runConstantPoolBuilder
  , CPBuilder (..)
  , builderFromConstantPool
  , constantPoolFromBuilder
  , cpbEmpty
  ) where

import           Control.DeepSeq (NFData)
import           Control.Monad.Except
import           Control.Monad.Reader
import           Control.Monad.State
import           Data.Binary
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as Map
import qualified Data.List as List
import qualified Data.Text as Text
import           GHC.Generics (Generic)

import           Language.JVM.ClassFile
import           Language.JVM.Constant
import           Language.JVM.ConstantPool as CP
import           Language.JVM.Staged

-- | Decode a class file from a lazy 'BL.ByteString'. Ensures that the lazy
-- bytestring is read to EOF, and thereby closing any open files.
decodeClassFile :: BL.ByteString -> Either ClassFileError (ClassFile Low)
decodeClassFile :: ByteString -> Either ClassFileError (ClassFile Low)
decodeClassFile ByteString
bs = do
  case ByteString
-> Either
     (ByteString, ByteOffset, String)
     (ByteString, ByteOffset, ClassFile Low)
forall a.
Binary a =>
ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
decodeOrFail ByteString
bs of
    Right (ByteString
rest, ByteOffset
off, ClassFile Low
cf)
      | ByteString -> ByteOffset
BL.length ByteString
rest ByteOffset -> ByteOffset -> Bool
forall a. Eq a => a -> a -> Bool
== ByteOffset
0 -> ClassFile Low -> Either ClassFileError (ClassFile Low)
forall a b. b -> Either a b
Right ClassFile Low
cf
      | Bool
otherwise ->
        ByteString
-> ByteOffset -> String -> Either ClassFileError (ClassFile Low)
forall a b.
Show a =>
ByteString -> a -> String -> Either ClassFileError b
unreadable ByteString
rest ByteOffset
off String
"expected end of file"
    Left (ByteString
rest, ByteOffset
off, String
msg) ->
      ByteString
-> ByteOffset -> String -> Either ClassFileError (ClassFile Low)
forall a b.
Show a =>
ByteString -> a -> String -> Either ClassFileError b
unreadable ByteString
rest ByteOffset
off String
msg
  where
    unreadable :: ByteString -> a -> String -> Either ClassFileError b
unreadable ByteString
rest a
off String
msg =
      ClassFileError -> Either ClassFileError b
forall a b. a -> Either a b
Left (ClassFileError -> Either ClassFileError b)
-> ClassFileError -> Either ClassFileError b
forall a b. (a -> b) -> a -> b
$ String -> ClassFileError
CFEUnreadableFile ((a -> String
forall a. Show a => a -> String
show a
off) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (ByteOffset -> String
forall a. Show a => a -> String
show (ByteOffset -> String) -> ByteOffset -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteOffset
BL.length ByteString
rest) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg)

-- | Create a lazy byte string from a class file
encodeClassFile :: ClassFile Low -> BL.ByteString
encodeClassFile :: ClassFile Low -> ByteString
encodeClassFile ClassFile Low
clf = do
  ClassFile Low -> ByteString
forall a. Binary a => a -> ByteString
encode ClassFile Low
clf

-- | Evolve the class file to inline the references. A filter function is
-- provided to remove some attributes. This will sometimes give faster loading
-- times.
evolveClassFile ::
  ((AttributeLocation, Text.Text) -> Bool)
  -> ClassFile Low
  -> Either ClassFileError (ClassFile High)
evolveClassFile :: ((AttributeLocation, Text) -> Bool)
-> ClassFile Low -> Either ClassFileError (ClassFile High)
evolveClassFile (AttributeLocation, Text) -> Bool
fn ClassFile Low
cf = do
  ConstantPool High
cp <- ConstantPool Low -> Either ClassFileError (ConstantPool High)
bootstrapConstantPool (ClassFile Low -> Choice (ConstantPool Low) () Low
forall r. ClassFile r -> Choice (ConstantPool r) () r
cConstantPool ClassFile Low
cf)
  EvolveConfig
-> Evolve (ClassFile High)
-> Either ClassFileError (ClassFile High)
forall a. EvolveConfig -> Evolve a -> Either ClassFileError a
runEvolve ([String]
-> ConstantPool High
-> ((AttributeLocation, Text) -> Bool)
-> EvolveConfig
EvolveConfig [] ConstantPool High
cp (AttributeLocation, Text) -> Bool
fn ) (ClassFile Low -> Evolve (ClassFile High)
forall (s :: * -> *) (m :: * -> *).
(Staged s, EvolveM m) =>
s Low -> m (s High)
evolve ClassFile Low
cf)

-- | Devolve a ClassFile from High to Low. This might make the 'ClassFile' contain
-- invalid attributes, since we can't read all attributes. If this this is a problem
-- see 'devolveClassFile''.
devolveClassFile :: ClassFile High -> ClassFile Low
devolveClassFile :: ClassFile High -> ClassFile Low
devolveClassFile ClassFile High
cf =
  let (ClassFile Low
cf', CPBuilder
cpb) = ConstantPoolBuilder (ClassFile Low)
-> CPBuilder -> (ClassFile Low, CPBuilder)
forall a. ConstantPoolBuilder a -> CPBuilder -> (a, CPBuilder)
runConstantPoolBuilder (ClassFile High -> ConstantPoolBuilder (ClassFile Low)
forall (s :: * -> *) (m :: * -> *).
(Staged s, DevolveM m) =>
s High -> m (s Low)
devolve ClassFile High
cf) CPBuilder
cpbEmpty in
  ClassFile Low
cf' { cConstantPool :: Choice (ConstantPool Low) () Low
cConstantPool = [Constant Low] -> ConstantPool Low
forall (f :: * -> *) r.
Foldable f =>
f (Constant r) -> ConstantPool r
fromConstants ([Constant Low] -> [Constant Low]
forall a. [a] -> [a]
reverse ([Constant Low] -> [Constant Low])
-> [Constant Low] -> [Constant Low]
forall a b. (a -> b) -> a -> b
$ CPBuilder -> [Constant Low]
cpbConstants CPBuilder
cpb)}

-- | Devolve a 'ClassFile' form 'High' to 'Low', while maintaining the class
-- pool of the original class file. This is useful if we care that unread
-- attributes are still valid. This can cause untended bloat as we do not
-- want to throw away anything in the program
devolveClassFile' :: ConstantPool Low -> ClassFile High -> ClassFile Low
devolveClassFile' :: ConstantPool Low -> ClassFile High -> ClassFile Low
devolveClassFile' ConstantPool Low
cp ClassFile High
cf =
  let (ClassFile Low
cf', CPBuilder
cpb) = ConstantPoolBuilder (ClassFile Low)
-> CPBuilder -> (ClassFile Low, CPBuilder)
forall a. ConstantPoolBuilder a -> CPBuilder -> (a, CPBuilder)
runConstantPoolBuilder (ClassFile High -> ConstantPoolBuilder (ClassFile Low)
forall (s :: * -> *) (m :: * -> *).
(Staged s, DevolveM m) =>
s High -> m (s Low)
devolve ClassFile High
cf) (ConstantPool Low -> CPBuilder
builderFromConstantPool ConstantPool Low
cp) in
  ClassFile Low
cf' { cConstantPool :: Choice (ConstantPool Low) () Low
cConstantPool = CPBuilder -> ConstantPool Low
constantPoolFromBuilder CPBuilder
cpb } 

-- | Top level command that combines 'decode' and 'evolve'.
readClassFile :: BL.ByteString -> Either ClassFileError (ClassFile High)
readClassFile :: ByteString -> Either ClassFileError (ClassFile High)
readClassFile ByteString
bs = do
  ClassFile Low
clf <- ByteString -> Either ClassFileError (ClassFile Low)
decodeClassFile ByteString
bs
  ((AttributeLocation, Text) -> Bool)
-> ClassFile Low -> Either ClassFileError (ClassFile High)
evolveClassFile (Bool -> (AttributeLocation, Text) -> Bool
forall a b. a -> b -> a
const Bool
True) ClassFile Low
clf

-- | Top level command that combines 'devolve' and 'encode'.
writeClassFile :: ClassFile High -> BL.ByteString
writeClassFile :: ClassFile High -> ByteString
writeClassFile =
  ClassFile Low -> ByteString
encodeClassFile (ClassFile Low -> ByteString)
-> (ClassFile High -> ClassFile Low)
-> ClassFile High
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClassFile High -> ClassFile Low
devolveClassFile

-- | Top level command that combines 'devolve' and 'encode', but tries
-- to retain exact syntax of a previous run using the class pool.
writeClassFile' :: ConstantPool Low -> ClassFile High -> BL.ByteString
writeClassFile' :: ConstantPool Low -> ClassFile High -> ByteString
writeClassFile' ConstantPool Low
cp =
  ClassFile Low -> ByteString
encodeClassFile (ClassFile Low -> ByteString)
-> (ClassFile High -> ClassFile Low)
-> ClassFile High
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstantPool Low -> ClassFile High -> ClassFile Low
devolveClassFile' ConstantPool Low
cp


-- | A test function, essentially reading the classfile and then writing it
-- to another file.
roundtripCopy :: FilePath -> FilePath -> IO ()
roundtripCopy :: String -> String -> IO ()
roundtripCopy String
f1 String
f2 = do
  Right ClassFile High
cf <- ByteString -> Either ClassFileError (ClassFile High)
readClassFile (ByteString -> Either ClassFileError (ClassFile High))
-> IO ByteString -> IO (Either ClassFileError (ClassFile High))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BL.readFile String
f1
  String -> ByteString -> IO ()
BL.writeFile String
f2 (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ClassFile High -> ByteString
writeClassFile ClassFile High
cf

-- $deref
-- Dereffing is the flattening of the constant pool to get the values
-- of all references.

-- | An error while reading a class file is represented using
-- this data structure
data ClassFileError
  = CFEPoolAccessError !String !PoolAccessError
  | CFEInconsistentClassPool !String !String
  | CFEConversionError !String !String
  | CFEUnreadableFile !String
  deriving (Int -> ClassFileError -> String -> String
[ClassFileError] -> String -> String
ClassFileError -> String
(Int -> ClassFileError -> String -> String)
-> (ClassFileError -> String)
-> ([ClassFileError] -> String -> String)
-> Show ClassFileError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ClassFileError] -> String -> String
$cshowList :: [ClassFileError] -> String -> String
show :: ClassFileError -> String
$cshow :: ClassFileError -> String
showsPrec :: Int -> ClassFileError -> String -> String
$cshowsPrec :: Int -> ClassFileError -> String -> String
Show, ClassFileError -> ClassFileError -> Bool
(ClassFileError -> ClassFileError -> Bool)
-> (ClassFileError -> ClassFileError -> Bool) -> Eq ClassFileError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ClassFileError -> ClassFileError -> Bool
$c/= :: ClassFileError -> ClassFileError -> Bool
== :: ClassFileError -> ClassFileError -> Bool
$c== :: ClassFileError -> ClassFileError -> Bool
Eq, (forall x. ClassFileError -> Rep ClassFileError x)
-> (forall x. Rep ClassFileError x -> ClassFileError)
-> Generic ClassFileError
forall x. Rep ClassFileError x -> ClassFileError
forall x. ClassFileError -> Rep ClassFileError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ClassFileError x -> ClassFileError
$cfrom :: forall x. ClassFileError -> Rep ClassFileError x
Generic)

instance NFData ClassFileError

data EvolveConfig =
  EvolveConfig
  { EvolveConfig -> [String]
ecLabel :: [String]
  , EvolveConfig -> ConstantPool High
ecConstantPool :: ConstantPool High
  , EvolveConfig -> (AttributeLocation, Text) -> Bool
ecAttributeFilter :: ((AttributeLocation, Text.Text) -> Bool)
  }

newtype Evolve a =
  Evolve (ReaderT EvolveConfig (Either ClassFileError) a)
  deriving
  ( a -> Evolve b -> Evolve a
(a -> b) -> Evolve a -> Evolve b
(forall a b. (a -> b) -> Evolve a -> Evolve b)
-> (forall a b. a -> Evolve b -> Evolve a) -> Functor Evolve
forall a b. a -> Evolve b -> Evolve a
forall a b. (a -> b) -> Evolve a -> Evolve b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Evolve b -> Evolve a
$c<$ :: forall a b. a -> Evolve b -> Evolve a
fmap :: (a -> b) -> Evolve a -> Evolve b
$cfmap :: forall a b. (a -> b) -> Evolve a -> Evolve b
Functor
  , Functor Evolve
a -> Evolve a
Functor Evolve
-> (forall a. a -> Evolve a)
-> (forall a b. Evolve (a -> b) -> Evolve a -> Evolve b)
-> (forall a b c.
    (a -> b -> c) -> Evolve a -> Evolve b -> Evolve c)
-> (forall a b. Evolve a -> Evolve b -> Evolve b)
-> (forall a b. Evolve a -> Evolve b -> Evolve a)
-> Applicative Evolve
Evolve a -> Evolve b -> Evolve b
Evolve a -> Evolve b -> Evolve a
Evolve (a -> b) -> Evolve a -> Evolve b
(a -> b -> c) -> Evolve a -> Evolve b -> Evolve c
forall a. a -> Evolve a
forall a b. Evolve a -> Evolve b -> Evolve a
forall a b. Evolve a -> Evolve b -> Evolve b
forall a b. Evolve (a -> b) -> Evolve a -> Evolve b
forall a b c. (a -> b -> c) -> Evolve a -> Evolve b -> Evolve c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Evolve a -> Evolve b -> Evolve a
$c<* :: forall a b. Evolve a -> Evolve b -> Evolve a
*> :: Evolve a -> Evolve b -> Evolve b
$c*> :: forall a b. Evolve a -> Evolve b -> Evolve b
liftA2 :: (a -> b -> c) -> Evolve a -> Evolve b -> Evolve c
$cliftA2 :: forall a b c. (a -> b -> c) -> Evolve a -> Evolve b -> Evolve c
<*> :: Evolve (a -> b) -> Evolve a -> Evolve b
$c<*> :: forall a b. Evolve (a -> b) -> Evolve a -> Evolve b
pure :: a -> Evolve a
$cpure :: forall a. a -> Evolve a
$cp1Applicative :: Functor Evolve
Applicative
  , Applicative Evolve
a -> Evolve a
Applicative Evolve
-> (forall a b. Evolve a -> (a -> Evolve b) -> Evolve b)
-> (forall a b. Evolve a -> Evolve b -> Evolve b)
-> (forall a. a -> Evolve a)
-> Monad Evolve
Evolve a -> (a -> Evolve b) -> Evolve b
Evolve a -> Evolve b -> Evolve b
forall a. a -> Evolve a
forall a b. Evolve a -> Evolve b -> Evolve b
forall a b. Evolve a -> (a -> Evolve b) -> Evolve b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Evolve a
$creturn :: forall a. a -> Evolve a
>> :: Evolve a -> Evolve b -> Evolve b
$c>> :: forall a b. Evolve a -> Evolve b -> Evolve b
>>= :: Evolve a -> (a -> Evolve b) -> Evolve b
$c>>= :: forall a b. Evolve a -> (a -> Evolve b) -> Evolve b
$cp1Monad :: Applicative Evolve
Monad
  , MonadReader EvolveConfig
  , MonadError ClassFileError
  )

runEvolve :: EvolveConfig -> Evolve a -> Either ClassFileError a
runEvolve :: EvolveConfig -> Evolve a -> Either ClassFileError a
runEvolve EvolveConfig
ev (Evolve ReaderT EvolveConfig (Either ClassFileError) a
m) = ReaderT EvolveConfig (Either ClassFileError) a
-> EvolveConfig -> Either ClassFileError a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT EvolveConfig (Either ClassFileError) a
m EvolveConfig
ev

instance LabelM Evolve where
  label :: String -> Evolve a -> Evolve a
label String
str (Evolve ReaderT EvolveConfig (Either ClassFileError) a
m) = do
    ReaderT EvolveConfig (Either ClassFileError) a -> Evolve a
forall a.
ReaderT EvolveConfig (Either ClassFileError) a -> Evolve a
Evolve (ReaderT EvolveConfig (Either ClassFileError) a -> Evolve a)
-> (ReaderT EvolveConfig (Either ClassFileError) a
    -> ReaderT EvolveConfig (Either ClassFileError) a)
-> ReaderT EvolveConfig (Either ClassFileError) a
-> Evolve a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EvolveConfig -> EvolveConfig)
-> ReaderT EvolveConfig (Either ClassFileError) a
-> ReaderT EvolveConfig (Either ClassFileError) a
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT (\EvolveConfig
ec -> EvolveConfig
ec { ecLabel :: [String]
ecLabel = String
str String -> [String] -> [String]
forall a. a -> [a] -> [a]
: EvolveConfig -> [String]
ecLabel EvolveConfig
ec}) (ReaderT EvolveConfig (Either ClassFileError) a -> Evolve a)
-> ReaderT EvolveConfig (Either ClassFileError) a -> Evolve a
forall a b. (a -> b) -> a -> b
$ ReaderT EvolveConfig (Either ClassFileError) a
m

showLvl :: [String] -> String
showLvl :: [String] -> String
showLvl = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"/" ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. [a] -> [a]
reverse

instance EvolveM Evolve where
  link :: Index -> Evolve r
link Index
w = do
    EvolveConfig
ec <- Evolve EvolveConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    let lvl :: String
lvl = [String] -> String
showLvl ( EvolveConfig -> [String]
ecLabel EvolveConfig
ec )
    Constant High
r <- (PoolAccessError -> Evolve (Constant High))
-> (Constant High -> Evolve (Constant High))
-> Either PoolAccessError (Constant High)
-> Evolve (Constant High)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ClassFileError -> Evolve (Constant High)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ClassFileError -> Evolve (Constant High))
-> (PoolAccessError -> ClassFileError)
-> PoolAccessError
-> Evolve (Constant High)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> PoolAccessError -> ClassFileError
CFEPoolAccessError String
lvl)  Constant High -> Evolve (Constant High)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PoolAccessError (Constant High) -> Evolve (Constant High))
-> Either PoolAccessError (Constant High) -> Evolve (Constant High)
forall a b. (a -> b) -> a -> b
$ Index
-> ConstantPool High -> Either PoolAccessError (Constant High)
forall r.
Index -> ConstantPool r -> Either PoolAccessError (Constant r)
access Index
w (EvolveConfig -> ConstantPool High
ecConstantPool EvolveConfig
ec)
    (forall r. String -> Evolve r) -> Constant High -> Evolve r
forall a (m :: * -> *).
(Referenceable a, Monad m) =>
(forall a'. String -> m a') -> Constant High -> m a
fromConst (ClassFileError -> Evolve a'
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ClassFileError -> Evolve a')
-> (String -> ClassFileError) -> String -> Evolve a'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> ClassFileError
CFEInconsistentClassPool String
lvl) Constant High
r

  attributeFilter :: Evolve ((AttributeLocation, Text) -> Bool)
attributeFilter =
    (EvolveConfig -> (AttributeLocation, Text) -> Bool)
-> Evolve ((AttributeLocation, Text) -> Bool)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks EvolveConfig -> (AttributeLocation, Text) -> Bool
ecAttributeFilter

  evolveError :: String -> Evolve r
evolveError String
msg = do
    String
lvl <- (EvolveConfig -> String) -> Evolve String
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ([String] -> String
showLvl ([String] -> String)
-> (EvolveConfig -> [String]) -> EvolveConfig -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvolveConfig -> [String]
ecLabel)
    ClassFileError -> Evolve r
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> String -> ClassFileError
CFEConversionError String
lvl String
msg)

-- | Untie the constant pool, this requires a special operation as the constant pool
-- might reference itself.
bootstrapConstantPool :: ConstantPool Low -> Either ClassFileError (ConstantPool High)
bootstrapConstantPool :: ConstantPool Low -> Either ClassFileError (ConstantPool High)
bootstrapConstantPool ConstantPool Low
reffed =
  case (ConstantPool High
 -> Constant Low -> Either ClassFileError (Constant High))
-> ConstantPool Low
-> (ConstantPool High, [(ClassFileError, (Index, Constant Low))])
forall b.
(ConstantPool High -> Constant Low -> Either b (Constant High))
-> ConstantPool Low
-> (ConstantPool High, [(b, (Index, Constant Low))])
growPool ConstantPool High
-> Constant Low -> Either ClassFileError (Constant High)
forall (s :: * -> *).
Staged s =>
ConstantPool High -> s Low -> Either ClassFileError (s High)
improve ConstantPool Low
reffed of
    (ConstantPool High
cp, []) ->
      ConstantPool High -> Either ClassFileError (ConstantPool High)
forall a b. b -> Either a b
Right ConstantPool High
cp
    (ConstantPool High
_, [(ClassFileError, (Index, Constant Low))]
xs) ->
      ClassFileError -> Either ClassFileError (ConstantPool High)
forall a b. a -> Either a b
Left (ClassFileError -> Either ClassFileError (ConstantPool High))
-> (String -> ClassFileError)
-> String
-> Either ClassFileError (ConstantPool High)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> ClassFileError
CFEInconsistentClassPool String
"ConstantPool"
           (String -> Either ClassFileError (ConstantPool High))
-> String -> Either ClassFileError (ConstantPool High)
forall a b. (a -> b) -> a -> b
$ String
"Could not load all constants in the constant pool: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ([(ClassFileError, (Index, Constant Low))] -> String
forall a. Show a => a -> String
show [(ClassFileError, (Index, Constant Low))]
xs)
  where
    improve :: ConstantPool High -> s Low -> Either ClassFileError (s High)
improve ConstantPool High
cp s Low
low =
      EvolveConfig -> Evolve (s High) -> Either ClassFileError (s High)
forall a. EvolveConfig -> Evolve a -> Either ClassFileError a
runEvolve ([String]
-> ConstantPool High
-> ((AttributeLocation, Text) -> Bool)
-> EvolveConfig
EvolveConfig [] ConstantPool High
cp (Bool -> (AttributeLocation, Text) -> Bool
forall a b. a -> b -> a
const Bool
True)) (s Low -> Evolve (s High)
forall (s :: * -> *) (m :: * -> *).
(Staged s, EvolveM m) =>
s Low -> m (s High)
evolve s Low
low)

{-# SCC bootstrapConstantPool #-}

-- $build

data CPBuilder = CPBuilder
   { CPBuilder -> Map (Constant Low) Index
cpbMapper       :: Map.Map (Constant Low) Index
   , CPBuilder -> Index
cpbNextIndex    :: Index
   , CPBuilder -> [Constant Low]
cpbConstants    :: [Constant Low]
   } deriving (Int -> CPBuilder -> String -> String
[CPBuilder] -> String -> String
CPBuilder -> String
(Int -> CPBuilder -> String -> String)
-> (CPBuilder -> String)
-> ([CPBuilder] -> String -> String)
-> Show CPBuilder
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [CPBuilder] -> String -> String
$cshowList :: [CPBuilder] -> String -> String
show :: CPBuilder -> String
$cshow :: CPBuilder -> String
showsPrec :: Int -> CPBuilder -> String -> String
$cshowsPrec :: Int -> CPBuilder -> String -> String
Show)

cpbEmpty :: CPBuilder
cpbEmpty :: CPBuilder
cpbEmpty = Map (Constant Low) Index -> Index -> [Constant Low] -> CPBuilder
CPBuilder Map (Constant Low) Index
forall k a. Map k a
Map.empty Index
1 []

builderFromConstantPool :: ConstantPool Low -> CPBuilder
builderFromConstantPool :: ConstantPool Low -> CPBuilder
builderFromConstantPool ConstantPool Low
cp =
  Map (Constant Low) Index -> Index -> [Constant Low] -> CPBuilder
CPBuilder ([(Constant Low, Index)] -> Map (Constant Low) Index
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Constant Low, Index)] -> Map (Constant Low) Index)
-> (ConstantPool Low -> [(Constant Low, Index)])
-> ConstantPool Low
-> Map (Constant Low) Index
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Index, Constant Low) -> (Constant Low, Index))
-> [(Index, Constant Low)] -> [(Constant Low, Index)]
forall a b. (a -> b) -> [a] -> [b]
map (Index, Constant Low) -> (Constant Low, Index)
forall a b a. (Integral a, Num b) => (a, a) -> (a, b)
change ([(Index, Constant Low)] -> [(Constant Low, Index)])
-> (ConstantPool Low -> [(Index, Constant Low)])
-> ConstantPool Low
-> [(Constant Low, Index)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstantPool Low -> [(Index, Constant Low)]
forall r. ConstantPool r -> [(Index, Constant r)]
listConstants (ConstantPool Low -> Map (Constant Low) Index)
-> ConstantPool Low -> Map (Constant Low) Index
forall a b. (a -> b) -> a -> b
$ ConstantPool Low
cp) (ConstantPool Low -> Index
forall r. ConstantPool r -> Index
nextIndex ConstantPool Low
cp)  (((Index, Constant Low) -> Constant Low)
-> [(Index, Constant Low)] -> [Constant Low]
forall a b. (a -> b) -> [a] -> [b]
map (Index, Constant Low) -> Constant Low
forall a b. (a, b) -> b
snd [(Index, Constant Low)]
constants)
  where
    constants :: [(Index, Constant Low)]
constants = ConstantPool Low -> [(Index, Constant Low)]
forall r. ConstantPool r -> [(Index, Constant r)]
listConstants ConstantPool Low
cp
    change :: (a, a) -> (a, b)
change (a
a, a
b) = (a
b, a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
a)

constantPoolFromBuilder :: CPBuilder -> ConstantPool Low
constantPoolFromBuilder :: CPBuilder -> ConstantPool Low
constantPoolFromBuilder CPBuilder
cpb =
 [Constant Low] -> ConstantPool Low
forall (f :: * -> *) r.
Foldable f =>
f (Constant r) -> ConstantPool r
fromConstants ([Constant Low] -> [Constant Low]
forall a. [a] -> [a]
reverse ([Constant Low] -> [Constant Low])
-> [Constant Low] -> [Constant Low]
forall a b. (a -> b) -> a -> b
$ CPBuilder -> [Constant Low]
cpbConstants CPBuilder
cpb)


newtype ConstantPoolBuilder a =
  ConstantPoolBuilder (State CPBuilder a)
  deriving (Applicative ConstantPoolBuilder
a -> ConstantPoolBuilder a
Applicative ConstantPoolBuilder
-> (forall a b.
    ConstantPoolBuilder a
    -> (a -> ConstantPoolBuilder b) -> ConstantPoolBuilder b)
-> (forall a b.
    ConstantPoolBuilder a
    -> ConstantPoolBuilder b -> ConstantPoolBuilder b)
-> (forall a. a -> ConstantPoolBuilder a)
-> Monad ConstantPoolBuilder
ConstantPoolBuilder a
-> (a -> ConstantPoolBuilder b) -> ConstantPoolBuilder b
ConstantPoolBuilder a
-> ConstantPoolBuilder b -> ConstantPoolBuilder b
forall a. a -> ConstantPoolBuilder a
forall a b.
ConstantPoolBuilder a
-> ConstantPoolBuilder b -> ConstantPoolBuilder b
forall a b.
ConstantPoolBuilder a
-> (a -> ConstantPoolBuilder b) -> ConstantPoolBuilder b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> ConstantPoolBuilder a
$creturn :: forall a. a -> ConstantPoolBuilder a
>> :: ConstantPoolBuilder a
-> ConstantPoolBuilder b -> ConstantPoolBuilder b
$c>> :: forall a b.
ConstantPoolBuilder a
-> ConstantPoolBuilder b -> ConstantPoolBuilder b
>>= :: ConstantPoolBuilder a
-> (a -> ConstantPoolBuilder b) -> ConstantPoolBuilder b
$c>>= :: forall a b.
ConstantPoolBuilder a
-> (a -> ConstantPoolBuilder b) -> ConstantPoolBuilder b
$cp1Monad :: Applicative ConstantPoolBuilder
Monad, MonadState CPBuilder, a -> ConstantPoolBuilder b -> ConstantPoolBuilder a
(a -> b) -> ConstantPoolBuilder a -> ConstantPoolBuilder b
(forall a b.
 (a -> b) -> ConstantPoolBuilder a -> ConstantPoolBuilder b)
-> (forall a b.
    a -> ConstantPoolBuilder b -> ConstantPoolBuilder a)
-> Functor ConstantPoolBuilder
forall a b. a -> ConstantPoolBuilder b -> ConstantPoolBuilder a
forall a b.
(a -> b) -> ConstantPoolBuilder a -> ConstantPoolBuilder b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ConstantPoolBuilder b -> ConstantPoolBuilder a
$c<$ :: forall a b. a -> ConstantPoolBuilder b -> ConstantPoolBuilder a
fmap :: (a -> b) -> ConstantPoolBuilder a -> ConstantPoolBuilder b
$cfmap :: forall a b.
(a -> b) -> ConstantPoolBuilder a -> ConstantPoolBuilder b
Functor, Functor ConstantPoolBuilder
a -> ConstantPoolBuilder a
Functor ConstantPoolBuilder
-> (forall a. a -> ConstantPoolBuilder a)
-> (forall a b.
    ConstantPoolBuilder (a -> b)
    -> ConstantPoolBuilder a -> ConstantPoolBuilder b)
-> (forall a b c.
    (a -> b -> c)
    -> ConstantPoolBuilder a
    -> ConstantPoolBuilder b
    -> ConstantPoolBuilder c)
-> (forall a b.
    ConstantPoolBuilder a
    -> ConstantPoolBuilder b -> ConstantPoolBuilder b)
-> (forall a b.
    ConstantPoolBuilder a
    -> ConstantPoolBuilder b -> ConstantPoolBuilder a)
-> Applicative ConstantPoolBuilder
ConstantPoolBuilder a
-> ConstantPoolBuilder b -> ConstantPoolBuilder b
ConstantPoolBuilder a
-> ConstantPoolBuilder b -> ConstantPoolBuilder a
ConstantPoolBuilder (a -> b)
-> ConstantPoolBuilder a -> ConstantPoolBuilder b
(a -> b -> c)
-> ConstantPoolBuilder a
-> ConstantPoolBuilder b
-> ConstantPoolBuilder c
forall a. a -> ConstantPoolBuilder a
forall a b.
ConstantPoolBuilder a
-> ConstantPoolBuilder b -> ConstantPoolBuilder a
forall a b.
ConstantPoolBuilder a
-> ConstantPoolBuilder b -> ConstantPoolBuilder b
forall a b.
ConstantPoolBuilder (a -> b)
-> ConstantPoolBuilder a -> ConstantPoolBuilder b
forall a b c.
(a -> b -> c)
-> ConstantPoolBuilder a
-> ConstantPoolBuilder b
-> ConstantPoolBuilder c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: ConstantPoolBuilder a
-> ConstantPoolBuilder b -> ConstantPoolBuilder a
$c<* :: forall a b.
ConstantPoolBuilder a
-> ConstantPoolBuilder b -> ConstantPoolBuilder a
*> :: ConstantPoolBuilder a
-> ConstantPoolBuilder b -> ConstantPoolBuilder b
$c*> :: forall a b.
ConstantPoolBuilder a
-> ConstantPoolBuilder b -> ConstantPoolBuilder b
liftA2 :: (a -> b -> c)
-> ConstantPoolBuilder a
-> ConstantPoolBuilder b
-> ConstantPoolBuilder c
$cliftA2 :: forall a b c.
(a -> b -> c)
-> ConstantPoolBuilder a
-> ConstantPoolBuilder b
-> ConstantPoolBuilder c
<*> :: ConstantPoolBuilder (a -> b)
-> ConstantPoolBuilder a -> ConstantPoolBuilder b
$c<*> :: forall a b.
ConstantPoolBuilder (a -> b)
-> ConstantPoolBuilder a -> ConstantPoolBuilder b
pure :: a -> ConstantPoolBuilder a
$cpure :: forall a. a -> ConstantPoolBuilder a
$cp1Applicative :: Functor ConstantPoolBuilder
Applicative)

runConstantPoolBuilder :: ConstantPoolBuilder a -> CPBuilder -> (a, CPBuilder)
runConstantPoolBuilder :: ConstantPoolBuilder a -> CPBuilder -> (a, CPBuilder)
runConstantPoolBuilder (ConstantPoolBuilder State CPBuilder a
m) CPBuilder
a =
  State CPBuilder a -> CPBuilder -> (a, CPBuilder)
forall s a. State s a -> s -> (a, s)
runState State CPBuilder a
m CPBuilder
a

instance LabelM ConstantPoolBuilder

instance DevolveM ConstantPoolBuilder where
  unlink :: r -> ConstantPoolBuilder Index
unlink r
r = do
    Constant High
c <- r -> ConstantPoolBuilder (Constant High)
forall a (m :: * -> *).
(Referenceable a, Monad m) =>
a -> m (Constant High)
toConst r
r
    Constant Low
c' <- Constant High -> ConstantPoolBuilder (Constant Low)
forall (s :: * -> *) (m :: * -> *).
(Staged s, DevolveM m) =>
s High -> m (s Low)
devolve Constant High
c
    Maybe Index
mw <- (CPBuilder -> Maybe Index) -> ConstantPoolBuilder (Maybe Index)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Constant Low -> Map (Constant Low) Index -> Maybe Index
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Constant Low
c' (Map (Constant Low) Index -> Maybe Index)
-> (CPBuilder -> Map (Constant Low) Index)
-> CPBuilder
-> Maybe Index
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CPBuilder -> Map (Constant Low) Index
cpbMapper)
    case Maybe Index
mw of
      Just Index
w -> Index -> ConstantPoolBuilder Index
forall (m :: * -> *) a. Monad m => a -> m a
return Index
w
      Maybe Index
Nothing -> do
        Index
w <- (CPBuilder -> (Index, CPBuilder)) -> ConstantPoolBuilder Index
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((CPBuilder -> (Index, CPBuilder)) -> ConstantPoolBuilder Index)
-> (Constant Low -> CPBuilder -> (Index, CPBuilder))
-> Constant Low
-> ConstantPoolBuilder Index
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constant Low -> CPBuilder -> (Index, CPBuilder)
stateCPBuilder (Constant Low -> ConstantPoolBuilder Index)
-> Constant Low -> ConstantPoolBuilder Index
forall a b. (a -> b) -> a -> b
$ Constant Low
c'
        Index -> ConstantPoolBuilder Index
forall (m :: * -> *) a. Monad m => a -> m a
return Index
w

stateCPBuilder
  :: Constant Low
  -> CPBuilder
  -> (Index, CPBuilder)
stateCPBuilder :: Constant Low -> CPBuilder -> (Index, CPBuilder)
stateCPBuilder Constant Low
c' CPBuilder
cpb =
  let w :: Index
w = CPBuilder -> Index
cpbNextIndex CPBuilder
cpb
  in ( Index
w
     , CPBuilder
cpb
       { cpbNextIndex :: Index
cpbNextIndex = Index
w Index -> Index -> Index
forall a. Num a => a -> a -> a
+ Constant Low -> Index
forall r. Constant r -> Index
constantSize Constant Low
c'
       , cpbConstants :: [Constant Low]
cpbConstants = Constant Low
c' Constant Low -> [Constant Low] -> [Constant Low]
forall a. a -> [a] -> [a]
: CPBuilder -> [Constant Low]
cpbConstants CPBuilder
cpb
       , cpbMapper :: Map (Constant Low) Index
cpbMapper = Constant Low
-> Index -> Map (Constant Low) Index -> Map (Constant Low) Index
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Constant Low
c' Index
w (Map (Constant Low) Index -> Map (Constant Low) Index)
-> (CPBuilder -> Map (Constant Low) Index)
-> CPBuilder
-> Map (Constant Low) Index
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CPBuilder -> Map (Constant Low) Index
cpbMapper (CPBuilder -> Map (Constant Low) Index)
-> CPBuilder -> Map (Constant Low) Index
forall a b. (a -> b) -> a -> b
$ CPBuilder
cpb
       })