{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
module Language.JVM.Attribute.Signature
( Signature (..)
, signatureToText
, signatureFromText
, ClassSignature (..)
, classSignatureToText
, classSignatureFromText
, classSignatureP
, MethodSignature (..)
, methodSignatureToText
, methodSignatureFromText
, methodSignatureP
, FieldSignature (..)
, fieldSignatureToText
, fieldSignatureFromText
, fieldSignatureP
, ClassType (..)
, classTypeP
, ReferenceType (..)
, referenceTypeP
, ThrowsSignature (..)
, TypeArgument (..)
, TypeParameter (..)
, TypeSignature (..)
, TypeVariable (..)
, typeVariableP
, Wildcard (..)
, typeParameterP
, typeParametersP
) where
import Control.DeepSeq (NFData)
import qualified Data.Text as Text
import Data.Text.Lazy.Builder as Text
import qualified Data.Text.Lazy as LText
import Data.Functor
import GHC.Generics (Generic)
import Language.JVM.Attribute.Base
import Language.JVM.Staged
import Language.JVM.Type
import qualified Data.List as L
import Data.Attoparsec.Text
instance IsAttribute (Signature Low) where
attrName = Const "Signature"
data Signature a =
Signature (Ref Text.Text a)
signatureToText :: Signature High -> Text.Text
signatureToText (Signature s) = s
signatureFromText :: Text.Text -> Signature High
signatureFromText s = Signature s
data ClassSignature = ClassSignature
{ csTypeParameters :: [TypeParameter]
, csSuperclassSignature :: ClassType
, csInterfaceSignatures :: [ClassType]
}
deriving (Show, Eq, Generic, NFData)
classSignatureP :: Parser ClassSignature
classSignatureP = do
tp <- option [] typeParametersP
ss <- classTypeP
is <- many' classTypeP
return $ ClassSignature tp ss is
classSignatureToText :: ClassSignature -> Text.Text
classSignatureToText =
LText.toStrict . toLazyText . classSignatureT
classSignatureFromText :: Text.Text -> Either String ClassSignature
classSignatureFromText =
parseOnly classSignatureP
classSignatureT :: ClassSignature -> Builder
classSignatureT (ClassSignature tp ct its)= do
typeParametersT tp <> foldMap classTypeT (ct:its)
data TypeSignature
= ReferenceType ReferenceType
| BaseType JBaseType
deriving (Show, Eq, Generic, NFData)
typeSignatureP :: Parser TypeSignature
typeSignatureP = do
choice [ (ReferenceType <$> referenceTypeP) <?> "JRefereceType"
, (BaseType <$> jBaseTypeP) <?> "JBaseType" ]
typeSignatureT :: TypeSignature -> Builder
typeSignatureT (ReferenceType t) = referenceTypeT t
typeSignatureT (BaseType t) = singleton (jBaseTypeToChar t)
data ReferenceType
= RefClassType ClassType
| RefTypeVariable TypeVariable
| RefArrayType TypeSignature
deriving (Show, Eq, Generic, NFData)
referenceTypeP :: Parser ReferenceType
referenceTypeP = do
choice
[ RefClassType <$> classTypeP
, RefTypeVariable <$> typeVariableP
, RefArrayType <$> (char '[' >> typeSignatureP)
]
referenceTypeT :: ReferenceType -> Builder
referenceTypeT t =
case t of
RefClassType ct -> classTypeT ct
RefTypeVariable tv -> typeVariableT tv
RefArrayType at -> singleton '[' <> typeSignatureT at
data ClassType
= ClassType
{ ctsClassName :: ClassName
, ctsTypeArguments :: [Maybe TypeArgument]
}
| InnerClassType
{ ctsInnerClassName :: Text.Text
, ctsOuterClassType :: ClassType
, ctsTypeArguments :: [Maybe TypeArgument]
}
deriving (Show, Eq, Generic, NFData)
classTypeP :: Parser ClassType
classTypeP = nameit "ClassType" $ do
_ <- char 'L'
cn <- (ClassName <$> takeWhile1 (notInClass ".;[<>:")) <?> "ClassName"
ta <- option [] typeArgumentsP
ict <- many' $ do
_ <- char '.'
i <- identifierP
ta' <- option [] typeArgumentsP
return (i, ta')
_ <- char ';'
return $ L.foldl' (\a (i,ta') -> InnerClassType i a ta') (ClassType cn ta) ict
classTypeT :: ClassType -> Builder
classTypeT t =
go t <> singleton ';'
where
go t' =
case t' of
InnerClassType n ct arg ->
go ct <> singleton '.' <> Text.fromText n <> typeArgumentsT arg
ClassType cn arg ->
singleton 'L'
<> Text.fromText (classNameAsText cn)
<> typeArgumentsT arg
data TypeArgument = TypeArgument
{ taWildcard :: Maybe Wildcard
, taType :: ReferenceType
}
deriving (Show, Eq, Generic, NFData)
typeArgumentsP :: Parser [ Maybe TypeArgument ]
typeArgumentsP = do
_ <- char '<'
tas <- many1' typeArgumentP
_ <- char '>'
return tas
typeArgumentP :: Parser (Maybe TypeArgument)
typeArgumentP = do
choice [ Just
<$> ( TypeArgument
<$> option Nothing (Just <$> wildcardP)
<*> referenceTypeP
)
, char '*' $> Nothing
] <?> "TypeArgument"
typeArgumentsT :: [ Maybe TypeArgument ] -> Builder
typeArgumentsT args = do
if L.null args
then mempty
else singleton '<' <> foldMap typeArgumentT args <> singleton '>'
typeArgumentT :: Maybe TypeArgument -> Builder
typeArgumentT a = do
case a of
Nothing -> singleton '*'
Just (TypeArgument w rt) ->
(case w of
Just WildMinus -> singleton '-'
Just WildPlus -> singleton '+'
Nothing -> mempty) <> referenceTypeT rt
data Wildcard =
WildPlus | WildMinus
deriving (Show, Eq, Generic, NFData)
wildcardP :: Parser Wildcard
wildcardP = choice [ char '+' $> WildPlus, char '-' $> WildMinus]
newtype TypeVariable =
TypeVariable { tvAsText :: Text.Text }
deriving (Show, Eq, Generic, NFData)
typeVariableP :: Parser TypeVariable
typeVariableP = do
_ <- char 'T'
t <- identifierP
_ <- char ';'
return $ TypeVariable t
typeVariableT :: TypeVariable -> Builder
typeVariableT (TypeVariable t)= do
singleton 'T' <> Text.fromText t <> singleton ';'
data TypeParameter =
TypeParameter
{ tpIndentifier :: Text.Text
, tpClassBound :: Maybe ReferenceType
, tpInterfaceBound :: [ReferenceType]
}
deriving (Show, Eq, Generic, NFData)
typeParametersP :: Parser [TypeParameter]
typeParametersP = nameit "TypeParameters" $ do
_ <- char '<'
tps <- many1' typeParameterP
_ <- char '>'
return tps
typeParametersT :: [ TypeParameter ] -> Builder
typeParametersT args = do
if L.null args
then mempty
else singleton '<' <> foldMap typeParameterT args <> singleton '>'
typeParameterP :: Parser TypeParameter
typeParameterP = nameit "TypeParameter" $ do
id_ <- identifierP
_ <- char ':'
cb <- option Nothing (Just <$> referenceTypeP)
ib <- many' (char ':' >> referenceTypeP)
return $ TypeParameter id_ cb ib
typeParameterT :: TypeParameter -> Builder
typeParameterT (TypeParameter n cb ibs) =
Text.fromText n <> singleton ':' <> maybe mempty referenceTypeT cb <>
foldMap (\i -> singleton ':' <> referenceTypeT i) ibs
nameit :: String -> Parser a -> Parser a
nameit str m = m <?> str
identifierP :: Parser Text.Text
identifierP =
takeWhile1 (notInClass ".;[/<>:") <?> "Identifier"
data MethodSignature = MethodSignature
{ msTypeParameters :: [TypeParameter]
, msArguments :: [TypeSignature]
, msResults :: Maybe TypeSignature
, msThrows :: [ ThrowsSignature ]
}
deriving (Show, Eq, Generic, NFData)
methodSignatureP :: Parser MethodSignature
methodSignatureP = do
tps <- option [] typeParametersP
_ <- char '('
targ <- many' typeSignatureP
_ <- char ')'
res <- choice [ Just <$> typeSignatureP, char 'V' $> Nothing ]
thrws <- many' throwsSignatureP
return $ MethodSignature tps targ res thrws
methodSignatureToText :: MethodSignature -> Text.Text
methodSignatureToText =
LText.toStrict . toLazyText . methodSignatureT
methodSignatureFromText :: Text.Text -> Either String MethodSignature
methodSignatureFromText =
parseOnly methodSignatureP
fieldSignatureFromText :: Text.Text -> Either String FieldSignature
fieldSignatureFromText =
parseOnly fieldSignatureP
methodSignatureT :: MethodSignature -> Builder
methodSignatureT (MethodSignature tp args res thrws)= do
typeParametersT tp
<> singleton '('
<> foldMap typeSignatureT args
<> singleton ')'
<> (case res of Nothing -> singleton 'V'; Just r -> typeSignatureT r)
<> foldMap throwsSignatureT thrws
data ThrowsSignature
= ThrowsClass ClassType
| ThrowsTypeVariable TypeVariable
deriving (Show, Eq, Generic, NFData)
throwsSignatureP :: Parser ThrowsSignature
throwsSignatureP = do
_ <- char '^'
choice [ ThrowsClass <$> classTypeP, ThrowsTypeVariable <$> typeVariableP]
throwsSignatureT :: ThrowsSignature -> Builder
throwsSignatureT t =
singleton '^'
<> case t of
ThrowsClass ct -> classTypeT ct
ThrowsTypeVariable tt -> typeVariableT tt
newtype FieldSignature =
FieldSignature {fsRefType :: ReferenceType}
deriving (Show, Eq, Generic, NFData)
fieldSignatureP :: Parser FieldSignature
fieldSignatureP =
FieldSignature <$> referenceTypeP
fieldSignatureToText :: FieldSignature -> Text.Text
fieldSignatureToText =
LText.toStrict . toLazyText . referenceTypeT . fsRefType
instance Staged Signature where
evolve (Signature a) =
label "Signature" $ Signature <$> link a
devolve (Signature a) =
label "Signature" $ Signature <$> unlink a
$(deriveBaseWithBinary ''Signature)