{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE ExistentialQuantification       #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving  #-}
{-# LANGUAGE TemplateHaskell     #-}
{-|
Module      : Language.JVM.Attribute.Base
Copyright   : (c) Christian Gram Kalhauge, 2017
License     : MIT
Maintainer  : kalhuage@cs.ucla.edu
-}
module Language.JVM.Attribute.Base
  ( Attribute (..)
  , aInfo
  , toAttribute
  , toBCAttribute
  , devolveAttribute
  , fromAttribute'
  , toAttribute'

  -- * Helpers
  , IsAttribute (..)
  , Attributes
  , fromAttributes
  , collect
  , collectBC
  , AttributeCollector (..)
  , ByteCodeAttributeCollector (..)
  , firstOne

  -- * re-export
  , Const (..)
  ) where

-- base
import Data.Monoid
import           Control.Monad
import           Control.Applicative
import           Data.Maybe
import qualified Data.List            as List

-- binary
import           Data.Binary

-- bytestring
import qualified Data.ByteString      as BS
import qualified Data.ByteString.Lazy as BL

-- text
import qualified Data.Text            as Text

import           Language.JVM.Staged
import           Language.JVM.ByteCode
import           Language.JVM.Utils

-- | Maybe return the first element of a list
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

-- | An Attribute, simply contains of a reference to a name and
-- contains info.
data Attribute r = Attribute
  { Attribute r -> Ref Text r
aName  :: ! (Ref Text.Text r)
  , Attribute r -> SizedByteString32
aInfo' :: ! SizedByteString32
  }

-- | A small helper function to extract the info as a
-- lazy 'Data.ByteString.Lazy.ByteString'.
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)

-- | A list of attributes and described by the expected values.
type Attributes b r = Choice (SizedList16 (Attribute r)) (b r) r

-- | A class-type that describes a data-type 'a' as an Attribute. Most notable
-- it provides the 'fromAttribute'' method that enables converting an Attribute
-- to a data-type 'a'.
class (Binary a) => IsAttribute a where
  -- | The name of an attribute. This is used to lookup an attribute.
  attrName :: Const Text.Text a

-- | Generate an attribute in a low stage 'Low'.
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'

-- | Generate an attribute in the 'EvolveM' monad
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

-- | Generate an BCAttribute in the 'EvolveM' monad
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

-- -- | Generate an attribute in the 'EvolveM' monad
-- evolveAttribute ::
--   forall a m. (IsAttribute (a Low), EvolveM m)
--   => (a Low -> m (a High))
--   -> Attribute High
--   -> Maybe (m (a High))
-- evolveAttribute g as =
--   if aName as == getConst (attrName :: Const Text.Text (a Low))
--   then Just $ either attributeError g $ fromAttribute' as
--   else 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)


-- | Given a 'Foldable' structure 'f', and a function that can calculate a
-- monoid given an 'Attribute' calculate the monoid over all attributes.
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"