{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}

{- |
Module      : Language.JVM.Attribute.Signature
Copyright   : (c) Christian Gram Kalhauge, 2018
License     : MIT
Maintainer  : kalhuage@cs.ucla.edu

Based on the Signature Attribute,
as documented [here](http://docs.oracle.com/javase/specs/jvms/se9/html/jvms-4.html#jvms-4.7.9),
and the signature syntax defined [here](https://docs.oracle.com/javase/specs/jvms/se9/html/jvms-4.html#jvms-4.7.9.1).
-}
module Language.JVM.Attribute.Signature (
  Signature (..),
  signatureToText,
  signatureFromText,

  -- * Top Level Definitions
  ClassSignature (..),
  isSimpleClassSignature,
  classSignatureToText,
  classSignatureFromText,
  MethodSignature (..),
  isSimpleMethodSignature,
  methodSignatureToText,
  methodSignatureFromText,
  FieldSignature (..),
  isSimpleFieldSignature,
  fieldSignatureToText,
  fieldSignatureFromText,

  -- ** Handlers

  -- * Lower Level Definitions
  ClassType (..),
  isSimpleClassType,
  classTypeToName,
  classTypeFromName,
  InnerClassType (..),
  ReferenceType (..),
  isSimpleReferenceType,
  referenceTypeFromRefType,
  ThrowsSignature (..),
  isSimpleThrowsSignature,
  throwsSignatureFromName,
  TypeSignature (..),
  isSimpleTypeSignature,
  typeSignatureFromType,
  TypeArgument (..),
  TypeParameter (..),
  TypeVariable (..),
  Wildcard (..),

  -- * Parsers
  classSignatureP,
  methodSignatureP,
  fieldSignatureP,
  classTypeP,
  classTypeT,
  referenceTypeP,
  referenceTypeT,
  throwsSignatureP,
  throwsSignatureT,
  typeArgumentsT,
  typeArgumentsP,
  typeArgumentP,
  typeArgumentT,
  typeParameterP,
  typeParameterT,
  typeParametersT,
  typeParametersP,
  typeSignatureP,
  typeSignatureT,
  typeVariableP,
)
where

import Control.DeepSeq (NFData)
import qualified Data.Text as Text

import qualified Data.Text.Lazy as LText
import Data.Text.Lazy.Builder as Text

import Data.Functor
import GHC.Generics (Generic)

import Control.Applicative
import Data.Attoparsec.Text

import qualified Data.List as L

import Language.JVM.Attribute.Base
import Language.JVM.Staged
import Language.JVM.Type

newtype Signature a
  = Signature (Ref Text.Text a)

$(deriveBaseWithBinary ''Signature)

instance IsAttribute (Signature Low) where
  attrName = Const "Signature"

signatureToText :: Signature High -> Text.Text
signatureToText (Signature s) = s

signatureFromText :: Text.Text -> Signature High
signatureFromText = Signature

data ClassSignature = ClassSignature
  { csTypeParameters :: [TypeParameter]
  , csSuperclassSignature :: ClassType
  , csInterfaceSignatures :: [ClassType]
  }
  deriving (Show, Eq, Ord, Generic, NFData)

data MethodSignature = MethodSignature
  { msTypeParameters :: [TypeParameter]
  , msArguments :: [TypeSignature]
  , msResults :: Maybe TypeSignature
  , msThrows :: [ThrowsSignature]
  }
  deriving (Show, Eq, Ord, Generic, NFData)

newtype FieldSignature = FieldSignature {fsRefType :: ReferenceType}
  deriving (Show, Eq, Ord, Generic, NFData)

data TypeSignature
  = ReferenceType ReferenceType
  | BaseType JBaseType
  deriving (Show, Eq, Ord, Generic, NFData)

data ReferenceType
  = RefClassType ClassType
  | RefTypeVariable TypeVariable
  | RefArrayType TypeSignature
  deriving (Show, Eq, Ord, Generic, NFData)

data ClassType = ClassType
  { ctsName :: !ClassName
  , ctsInnerClass :: !(Maybe InnerClassType)
  , ctsTypeArguments :: [Maybe TypeArgument]
  }
  deriving (Show, Eq, Ord, Generic, NFData)

data InnerClassType = InnerClassType
  { ictsName :: !Text.Text
  , ictsInnerClass :: !(Maybe InnerClassType)
  , ictsTypeArguments :: [Maybe TypeArgument]
  }
  deriving (Show, Eq, Ord, Generic, NFData)

data TypeArgument = TypeArgument
  { taWildcard :: Maybe Wildcard
  , taType :: ReferenceType
  }
  deriving (Show, Eq, Ord, Generic, NFData)

data Wildcard
  = WildPlus
  | WildMinus
  deriving (Show, Eq, Ord, Generic, NFData)

newtype TypeVariable = TypeVariable {tvAsText :: Text.Text}
  deriving (Show, Eq, Ord, Generic, NFData)

data TypeParameter = TypeParameter
  { tpIdentifier :: Text.Text
  , tpClassBound :: Maybe ReferenceType
  , tpInterfaceBound :: [ReferenceType]
  }
  deriving (Show, Eq, Ord, Generic, NFData)

data ThrowsSignature
  = ThrowsClass ClassType
  | ThrowsTypeVariable TypeVariable
  deriving (Show, Eq, Ord, Generic, NFData)

-- Conversion

classTypeToName :: ClassType -> ClassName
classTypeToName =
  (either error id . textCls . Text.intercalate "$" . getClassName)
 where
  getClassName (ClassType{..}) =
    classNameAsText ctsName : getInnerClassName ctsInnerClass

  getInnerClassName = \case
    Just (InnerClassType{..}) -> ictsName : getInnerClassName ictsInnerClass
    Nothing -> []

{- | Create a classType from a Name
 Note the language is wierd here! Main.A is not Main$A, but Main<T>.A is!
-}
classTypeFromName :: ClassName -> ClassType
classTypeFromName cn = ClassType cn Nothing []

throwsSignatureFromName :: ClassName -> ThrowsSignature
throwsSignatureFromName cn = ThrowsClass (classTypeFromName cn)

referenceTypeFromRefType :: JRefType -> ReferenceType
referenceTypeFromRefType = \case
  JTArray a -> RefArrayType (typeSignatureFromType a)
  JTClass a -> RefClassType (classTypeFromName a)

typeSignatureFromType :: JType -> TypeSignature
typeSignatureFromType = \case
  JTBase a -> BaseType a
  JTRef a -> ReferenceType (referenceTypeFromRefType a)

isSimpleMethodSignature :: MethodSignature -> Bool
isSimpleMethodSignature MethodSignature{..} =
  and
    [ null msTypeParameters
    , all isSimpleTypeSignature msArguments
    , all isSimpleTypeSignature msResults
    , all isSimpleThrowsSignature msThrows
    ]

isSimpleClassSignature :: ClassSignature -> Bool
isSimpleClassSignature ClassSignature{..} =
  and
    [ null csTypeParameters
    , isSimpleClassType csSuperclassSignature
    , all isSimpleClassType csInterfaceSignatures
    ]

isSimpleFieldSignature :: FieldSignature -> Bool
isSimpleFieldSignature FieldSignature{..} = isSimpleReferenceType fsRefType

isSimpleTypeSignature :: TypeSignature -> Bool
isSimpleTypeSignature = \case
  BaseType _ -> True
  ReferenceType a -> isSimpleReferenceType a

isSimpleReferenceType :: ReferenceType -> Bool
isSimpleReferenceType = \case
  RefArrayType a -> isSimpleTypeSignature a
  RefClassType a -> isSimpleClassType a
  RefTypeVariable _ -> False

isSimpleClassType :: ClassType -> Bool
isSimpleClassType = \case
  ClassType _ Nothing [] -> True
  _ -> False

isSimpleThrowsSignature :: ThrowsSignature -> Bool
isSimpleThrowsSignature = \case
  ThrowsClass a -> isSimpleClassType a
  ThrowsTypeVariable _ -> False

instance TextSerializable ClassSignature where
  parseText = classSignatureP
  toBuilder = classSignatureT

instance TextSerializable MethodSignature where
  parseText = methodSignatureP
  toBuilder = methodSignatureT

instance TextSerializable FieldSignature where
  parseText = fieldSignatureP
  toBuilder = fieldSignatureT

instance TextSerializable TypeSignature where
  parseText = typeSignatureP
  toBuilder = typeSignatureT

instance TextSerializable ReferenceType where
  parseText = referenceTypeP
  toBuilder = referenceTypeT

instance TextSerializable ClassType where
  parseText = classTypeP
  toBuilder = classTypeT

instance TextSerializable Wildcard where
  parseText = wildcardP
  toBuilder = wildcardT

instance TextSerializable TypeVariable where
  parseText = typeVariableP
  toBuilder = typeVariableT

instance TextSerializable TypeParameter where
  parseText = typeParameterP
  toBuilder = typeParameterT

instance TextSerializable ThrowsSignature where
  parseText = throwsSignatureP
  toBuilder = throwsSignatureT

----------------------
-- Parsing
----------------------

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)

typeSignatureP :: Parser TypeSignature
typeSignatureP = do
  choice
    [ (ReferenceType <$> referenceTypeP) <?> "JRefereceType"
    , (BaseType <$> parseJBaseType) <?> "JBaseType"
    ]

typeSignatureT :: TypeSignature -> Builder
typeSignatureT (ReferenceType t) = referenceTypeT t
typeSignatureT (BaseType t) = singleton (jBaseTypeToChar t)

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

classTypeP :: Parser ClassType
classTypeP = nameit "ClassType" $ do
  _ <- char 'L'
  cn <- parseClassName
  ta <- option [] typeArgumentsP
  ict <- many' $ do
    _ <- char '.'
    i <- identifierP
    ta' <- option [] typeArgumentsP
    return (i, ta')
  _ <- char ';'
  return $
    ClassType
      cn
      (L.foldr (\(i, ta') a -> Just $ InnerClassType i a ta') Nothing ict)
      ta

classTypeT :: ClassType -> Builder
classTypeT (ClassType n ic arg) =
  singleton 'L'
    <> Text.fromText (classNameAsText n)
    <> typeArgumentsT arg
    <> go ic
    <> singleton ';'
 where
  go = \case
    Nothing -> mempty
    Just (InnerClassType n' ic' arg') ->
      singleton '.' <> Text.fromText n' <> typeArgumentsT arg' <> go ic'

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 m -> wildcardT m
          Nothing -> mempty
      )
        <> referenceTypeT rt

wildcardP :: Parser Wildcard
wildcardP = choice [char '+' $> WildPlus, char '-' $> WildMinus]

wildcardT :: Wildcard -> Builder
wildcardT = \case
  WildPlus -> singleton '+'
  WildMinus -> singleton '-'

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 ';'

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 <- optional 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"

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

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

fieldSignatureP :: Parser FieldSignature
fieldSignatureP = FieldSignature <$> referenceTypeP

fieldSignatureToText :: FieldSignature -> Text.Text
fieldSignatureToText = LText.toStrict . toLazyText . referenceTypeT . fsRefType

fieldSignatureT :: FieldSignature -> Builder
fieldSignatureT = referenceTypeT . fsRefType

instance Staged Signature where
  evolve (Signature a) = label "Signature" $ Signature <$> link a

  devolve (Signature a) = label "Signature" $ Signature <$> unlink a
