{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
module Language.JVM.Attribute.Base
( Attribute (..)
, aInfo
, toAttribute
, toBCAttribute
, devolveAttribute
, fromAttribute'
, toAttribute'
, IsAttribute (..)
, Attributes
, fromAttributes
, collect
, collectBC
, AttributeCollector (..)
, ByteCodeAttributeCollector (..)
, firstOne
, Const (..)
) where
import Data.Monoid
import Control.Monad
import Control.Applicative
import Data.Maybe
import qualified Data.List as List
import Data.Binary
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as Text
import Language.JVM.Staged
import Language.JVM.ByteCode
import Language.JVM.Utils
firstOne :: [a] -> Maybe a
firstOne :: [a] -> Maybe a
firstOne [a]
as = (a, [a]) -> a
forall a b. (a, b) -> a
fst ((a, [a]) -> a) -> Maybe (a, [a]) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> Maybe (a, [a])
forall a. [a] -> Maybe (a, [a])
List.uncons [a]
as
data Attribute r = Attribute
{ Attribute r -> Ref Text r
aName :: ! (Ref Text.Text r)
, Attribute r -> SizedByteString32
aInfo' :: ! SizedByteString32
}
aInfo :: Attribute r -> BS.ByteString
aInfo :: Attribute r -> ByteString
aInfo = SizedByteString32 -> ByteString
forall w. SizedByteString w -> ByteString
unSizedByteString (SizedByteString32 -> ByteString)
-> (Attribute r -> SizedByteString32) -> Attribute r -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attribute r -> SizedByteString32
forall r. Attribute r -> SizedByteString32
aInfo'
instance Staged Attribute where
evolve :: Attribute Low -> m (Attribute High)
evolve (Attribute Ref Text Low
an SizedByteString32
ai) = do
Text
an' <- Index -> m Text
forall (m :: * -> *) r.
(EvolveM m, Referenceable r) =>
Index -> m r
link Index
Ref Text Low
an
Attribute High -> m (Attribute High)
forall (m :: * -> *) a. Monad m => a -> m a
return (Attribute High -> m (Attribute High))
-> Attribute High -> m (Attribute High)
forall a b. (a -> b) -> a -> b
$ Ref Text High -> SizedByteString32 -> Attribute High
forall r. Ref Text r -> SizedByteString32 -> Attribute r
Attribute Text
Ref Text High
an' SizedByteString32
ai
devolve :: Attribute High -> m (Attribute Low)
devolve (Attribute Ref Text High
an SizedByteString32
ai) = do
Index
an' <- Text -> m Index
forall (m :: * -> *) r.
(DevolveM m, Referenceable r) =>
r -> m Index
unlink Text
Ref Text High
an
Attribute Low -> m (Attribute Low)
forall (m :: * -> *) a. Monad m => a -> m a
return (Attribute Low -> m (Attribute Low))
-> Attribute Low -> m (Attribute Low)
forall a b. (a -> b) -> a -> b
$ Ref Text Low -> SizedByteString32 -> Attribute Low
forall r. Ref Text r -> SizedByteString32 -> Attribute r
Attribute Index
Ref Text Low
an' SizedByteString32
ai
$(deriveBaseWithBinary ''Attribute)
type Attributes b r = Choice (SizedList16 (Attribute r)) (b r) r
class (Binary a) => IsAttribute a where
attrName :: Const Text.Text a
fromAttribute' :: IsAttribute a => Attribute r -> Either String a
fromAttribute' :: Attribute r -> Either String a
fromAttribute' = Attribute r -> Either String a
forall a r. Binary a => Attribute r -> Either String a
readFromStrict
toAttribute' :: forall a. IsAttribute a => a -> Attribute High
toAttribute' :: a -> Attribute High
toAttribute' a
a =
let name :: Text
name = Const Text a -> Text
forall a k (b :: k). Const a b -> a
getConst (Const Text a
forall a. IsAttribute a => Const Text a
attrName :: Const Text.Text a)
bytes :: ByteString
bytes = a -> ByteString
forall a. Binary a => a -> ByteString
encode a
a
in Ref Text High -> SizedByteString32 -> Attribute High
forall r. Ref Text r -> SizedByteString32 -> Attribute r
Attribute Text
Ref Text High
name (ByteString -> SizedByteString32
forall w. ByteString -> SizedByteString w
SizedByteString (ByteString -> SizedByteString32)
-> (ByteString -> ByteString) -> ByteString -> SizedByteString32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict (ByteString -> SizedByteString32)
-> ByteString -> SizedByteString32
forall a b. (a -> b) -> a -> b
$ ByteString
bytes)
toAttribute :: (IsAttribute (a Low), Staged a, DevolveM m) => a High -> m (Attribute Low)
toAttribute :: a High -> m (Attribute Low)
toAttribute =
(a High -> m (a Low)) -> a High -> m (Attribute Low)
forall (a :: * -> *) (m :: * -> *).
(IsAttribute (a Low), DevolveM m) =>
(a High -> m (a Low)) -> a High -> m (Attribute Low)
devolveAttribute a High -> m (a Low)
forall (s :: * -> *) (m :: * -> *).
(Staged s, DevolveM m) =>
s High -> m (s Low)
devolve
toBCAttribute ::
(IsAttribute (a Low), ByteCodeStaged a, DevolveM m)
=> (ByteCodeIndex -> m ByteCodeOffset)
-> a High
-> m (Attribute Low)
toBCAttribute :: (Int -> m Index) -> a High -> m (Attribute Low)
toBCAttribute Int -> m Index
bcde =
(a High -> m (a Low)) -> a High -> m (Attribute Low)
forall (a :: * -> *) (m :: * -> *).
(IsAttribute (a Low), DevolveM m) =>
(a High -> m (a Low)) -> a High -> m (Attribute Low)
devolveAttribute ((Int -> m Index) -> a High -> m (a Low)
forall (s :: * -> *) (m :: * -> *).
(ByteCodeStaged s, DevolveM m) =>
(Int -> m Index) -> s High -> m (s Low)
devolveBC Int -> m Index
bcde)
devolveAttribute :: (IsAttribute (a Low), DevolveM m) => (a High -> m (a Low)) -> a High -> m (Attribute Low)
devolveAttribute :: (a High -> m (a Low)) -> a High -> m (Attribute Low)
devolveAttribute a High -> m (a Low)
f a High
a = do
a Low
a' <- a High -> m (a Low)
f a High
a
Attribute High -> m (Attribute Low)
forall (s :: * -> *) (m :: * -> *).
(Staged s, DevolveM m) =>
s High -> m (s Low)
devolve (Attribute High -> m (Attribute Low))
-> Attribute High -> m (Attribute Low)
forall a b. (a -> b) -> a -> b
$ a Low -> Attribute High
forall a. IsAttribute a => a -> Attribute High
toAttribute' a Low
a'
fromAttribute ::
forall a m. (IsAttribute (a Low), Staged a, EvolveM m)
=> Attribute High
-> Maybe (m (a High))
fromAttribute :: Attribute High -> Maybe (m (a High))
fromAttribute Attribute High
as =
if Attribute High -> Ref Text High
forall r. Attribute r -> Ref Text r
aName Attribute High
as Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Const Text (a Low) -> Text
forall a k (b :: k). Const a b -> a
getConst (Const Text (a Low)
forall a. IsAttribute a => Const Text a
attrName :: Const Text.Text (a Low))
then m (a High) -> Maybe (m (a High))
forall a. a -> Maybe a
Just (m (a High) -> Maybe (m (a High)))
-> (Either String (a Low) -> m (a High))
-> Either String (a Low)
-> Maybe (m (a High))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m (a High) -> m (a High)
forall (m :: * -> *) a. LabelM m => String -> m a -> m a
label (Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Attribute High -> Ref Text High
forall r. Attribute r -> Ref Text r
aName Attribute High
as) (m (a High) -> m (a High))
-> (Either String (a Low) -> m (a High))
-> Either String (a Low)
-> m (a High)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> m (a High))
-> (a Low -> m (a High)) -> Either String (a Low) -> m (a High)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m (a High)
forall (m :: * -> *) r. EvolveM m => String -> m r
evolveError a Low -> m (a High)
forall (s :: * -> *) (m :: * -> *).
(Staged s, EvolveM m) =>
s Low -> m (s High)
evolve (Either String (a Low) -> Maybe (m (a High)))
-> Either String (a Low) -> Maybe (m (a High))
forall a b. (a -> b) -> a -> b
$ Attribute High -> Either String (a Low)
forall a r. IsAttribute a => Attribute r -> Either String a
fromAttribute' Attribute High
as
else Maybe (m (a High))
forall a. Maybe a
Nothing
fromBCAttribute ::
forall a m. (IsAttribute (a Low), ByteCodeStaged a, EvolveM m)
=> (ByteCodeOffset -> m ByteCodeIndex)
-> Attribute High
-> Maybe (m (a High))
fromBCAttribute :: (Index -> m Int) -> Attribute High -> Maybe (m (a High))
fromBCAttribute Index -> m Int
fn Attribute High
as =
if Attribute High -> Ref Text High
forall r. Attribute r -> Ref Text r
aName Attribute High
as Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Const Text (a Low) -> Text
forall a k (b :: k). Const a b -> a
getConst (Const Text (a Low)
forall a. IsAttribute a => Const Text a
attrName :: Const Text.Text (a Low))
then m (a High) -> Maybe (m (a High))
forall a. a -> Maybe a
Just (m (a High) -> Maybe (m (a High)))
-> (Either String (a Low) -> m (a High))
-> Either String (a Low)
-> Maybe (m (a High))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m (a High) -> m (a High)
forall (m :: * -> *) a. LabelM m => String -> m a -> m a
label (Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Attribute High -> Ref Text High
forall r. Attribute r -> Ref Text r
aName Attribute High
as) (m (a High) -> m (a High))
-> (Either String (a Low) -> m (a High))
-> Either String (a Low)
-> m (a High)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> m (a High))
-> (a Low -> m (a High)) -> Either String (a Low) -> m (a High)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m (a High)
forall (m :: * -> *) r. EvolveM m => String -> m r
evolveError ((Index -> m Int) -> a Low -> m (a High)
forall (s :: * -> *) (m :: * -> *).
(ByteCodeStaged s, EvolveM m) =>
(Index -> m Int) -> s Low -> m (s High)
evolveBC Index -> m Int
fn) (Either String (a Low) -> Maybe (m (a High)))
-> Either String (a Low) -> Maybe (m (a High))
forall a b. (a -> b) -> a -> b
$ Attribute High -> Either String (a Low)
forall a r. IsAttribute a => Attribute r -> Either String a
fromAttribute' Attribute High
as
else Maybe (m (a High))
forall a. Maybe a
Nothing
collect ::
forall c m. (EvolveM m)
=> [AttributeCollector c]
-> (Attribute High -> c -> c)
-> Attribute High
-> m (Endo c)
collect :: [AttributeCollector c]
-> (Attribute High -> c -> c) -> Attribute High -> m (Endo c)
collect [AttributeCollector c]
options Attribute High -> c -> c
def Attribute High
attr =
m (Endo c) -> Maybe (m (Endo c)) -> m (Endo c)
forall a. a -> Maybe a -> a
fromMaybe (Endo c -> m (Endo c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Endo c -> m (Endo c)) -> Endo c -> m (Endo c)
forall a b. (a -> b) -> a -> b
$ (c -> c) -> Endo c
forall a. (a -> a) -> Endo a
Endo (Attribute High -> c -> c
def Attribute High
attr))
(Maybe (m (Endo c)) -> m (Endo c))
-> ([Maybe (m (Endo c))] -> Maybe (m (Endo c)))
-> [Maybe (m (Endo c))]
-> m (Endo c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (m (Endo c))] -> Maybe (m (Endo c))
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
([Maybe (m (Endo c))] -> m (Endo c))
-> [Maybe (m (Endo c))] -> m (Endo c)
forall a b. (a -> b) -> a -> b
$ (\(Attr a High -> c -> c
fn) -> (a High -> Endo c) -> m (a High) -> m (Endo c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((c -> c) -> Endo c
forall a. (a -> a) -> Endo a
Endo ((c -> c) -> Endo c) -> (a High -> c -> c) -> a High -> Endo c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a High -> c -> c
fn) (m (a High) -> m (Endo c))
-> Maybe (m (a High)) -> Maybe (m (Endo c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Attribute High -> Maybe (m (a High))
forall (a :: * -> *) (m :: * -> *).
(IsAttribute (a Low), Staged a, EvolveM m) =>
Attribute High -> Maybe (m (a High))
fromAttribute Attribute High
attr) (AttributeCollector c -> Maybe (m (Endo c)))
-> [AttributeCollector c] -> [Maybe (m (Endo c))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AttributeCollector c]
options
data AttributeCollector c
= forall a. (IsAttribute (a Low), Staged a)
=> Attr (a High -> c -> c)
collectBC ::
forall c m. (EvolveM m)
=> (ByteCodeOffset -> m ByteCodeIndex)
-> [ByteCodeAttributeCollector c]
-> (Attribute High -> c -> c)
-> Attribute High
-> m (Endo c)
collectBC :: (Index -> m Int)
-> [ByteCodeAttributeCollector c]
-> (Attribute High -> c -> c)
-> Attribute High
-> m (Endo c)
collectBC Index -> m Int
evolvefn [ByteCodeAttributeCollector c]
options Attribute High -> c -> c
def Attribute High
attr =
m (Endo c) -> Maybe (m (Endo c)) -> m (Endo c)
forall a. a -> Maybe a -> a
fromMaybe (Endo c -> m (Endo c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Endo c -> m (Endo c)) -> Endo c -> m (Endo c)
forall a b. (a -> b) -> a -> b
$ (c -> c) -> Endo c
forall a. (a -> a) -> Endo a
Endo (Attribute High -> c -> c
def Attribute High
attr))
(Maybe (m (Endo c)) -> m (Endo c))
-> ([Maybe (m (Endo c))] -> Maybe (m (Endo c)))
-> [Maybe (m (Endo c))]
-> m (Endo c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (m (Endo c))] -> Maybe (m (Endo c))
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
([Maybe (m (Endo c))] -> m (Endo c))
-> [Maybe (m (Endo c))] -> m (Endo c)
forall a b. (a -> b) -> a -> b
$ (\(BCAttr a High -> c -> c
fn) -> (a High -> Endo c) -> m (a High) -> m (Endo c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((c -> c) -> Endo c
forall a. (a -> a) -> Endo a
Endo ((c -> c) -> Endo c) -> (a High -> c -> c) -> a High -> Endo c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a High -> c -> c
fn) (m (a High) -> m (Endo c))
-> Maybe (m (a High)) -> Maybe (m (Endo c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Index -> m Int) -> Attribute High -> Maybe (m (a High))
forall (a :: * -> *) (m :: * -> *).
(IsAttribute (a Low), ByteCodeStaged a, EvolveM m) =>
(Index -> m Int) -> Attribute High -> Maybe (m (a High))
fromBCAttribute Index -> m Int
evolvefn Attribute High
attr) (ByteCodeAttributeCollector c -> Maybe (m (Endo c)))
-> [ByteCodeAttributeCollector c] -> [Maybe (m (Endo c))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ByteCodeAttributeCollector c]
options
data ByteCodeAttributeCollector c
= forall a. (IsAttribute (a Low), ByteCodeStaged a)
=> BCAttr (a High -> c -> c)
fromAttributes ::
(Foldable f, EvolveM m, Monoid a)
=> AttributeLocation
-> f (Attribute Low)
-> (Attribute High -> m a)
-> m a
fromAttributes :: AttributeLocation
-> f (Attribute Low) -> (Attribute High -> m a) -> m a
fromAttributes AttributeLocation
al f (Attribute Low)
attrs Attribute High -> m a
f = do
(AttributeLocation, Text) -> Bool
afilter <- m ((AttributeLocation, Text) -> Bool)
forall (m :: * -> *).
EvolveM m =>
m ((AttributeLocation, Text) -> Bool)
attributeFilter
(m a -> Attribute Low -> m a) -> m a -> f (Attribute Low) -> m a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Prelude.foldl (((AttributeLocation, Text) -> Bool) -> m a -> Attribute Low -> m a
g (AttributeLocation, Text) -> Bool
afilter) (a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
forall a. Monoid a => a
mempty) f (Attribute Low)
attrs
where
g :: ((AttributeLocation, Text) -> Bool) -> m a -> Attribute Low -> m a
g (AttributeLocation, Text) -> Bool
afilter m a
m Attribute Low
a' = do
a
b <- m a
m
Attribute High
ah <- Attribute Low -> m (Attribute High)
forall (s :: * -> *) (m :: * -> *).
(Staged s, EvolveM m) =>
s Low -> m (s High)
evolve Attribute Low
a'
if (AttributeLocation, Text) -> Bool
afilter (AttributeLocation
al, Attribute High -> Ref Text High
forall r. Attribute r -> Ref Text r
aName Attribute High
ah)
then do
a
x <- Attribute High -> m a
f Attribute High
ah
a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ a
b a -> a -> a
forall a. Monoid a => a -> a -> a
`mappend` a
x
else a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
b
readFromStrict :: Binary a => Attribute r -> Either String a
readFromStrict :: Attribute r -> Either String a
readFromStrict =
((ByteString, ByteOffset, String) -> Either String a)
-> ((ByteString, ByteOffset, a) -> Either String a)
-> Either
(ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
-> Either String a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a)
-> ((ByteString, ByteOffset, String) -> String)
-> (ByteString, ByteOffset, String)
-> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteOffset, String) -> String
forall a b c. (a, b, c) -> c
trd) (ByteString, ByteOffset, a) -> Either String a
forall a. (ByteString, ByteOffset, a) -> Either String a
tst (Either
(ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
-> Either String a)
-> (Attribute r
-> Either
(ByteString, ByteOffset, String) (ByteString, ByteOffset, a))
-> Attribute r
-> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString
-> Either
(ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
forall a.
Binary a =>
ByteString
-> Either
(ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
decodeOrFail (ByteString
-> Either
(ByteString, ByteOffset, String) (ByteString, ByteOffset, a))
-> (Attribute r -> ByteString)
-> Attribute r
-> Either
(ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict (ByteString -> ByteString)
-> (Attribute r -> ByteString) -> Attribute r -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attribute r -> ByteString
forall r. Attribute r -> ByteString
aInfo
where
tst :: (BL.ByteString, ByteOffset, a) -> Either String a
tst :: (ByteString, ByteOffset, a) -> Either String a
tst (ByteString
s, ByteOffset
_, a
a) =
if ByteString -> Bool
BL.null ByteString
s then a -> Either String a
forall a b. b -> Either a b
Right a
a else String -> Either String a
forall a b. a -> Either a b
Left String
"Incomplete attribute parsing"