{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# 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 (..)
  , classSignatureToText
  , classSignatureFromText
  , classSignatureP
  , MethodSignature (..)
  , methodSignatureToText
  , methodSignatureFromText
  , methodSignatureP
  , FieldSignature (..)
  , fieldSignatureToText
  , fieldSignatureFromText
  , fieldSignatureP

  -- * Lower Level Definitions
  , ClassType (..)
  , classTypeP
  , classTypeT
  , ReferenceType (..)
  , referenceTypeP
  , referenceTypeT
  , ThrowsSignature (..)
  , throwsSignatureP
  , throwsSignatureT
  , TypeArgument (..)
  , typeArgumentsT
  , typeArgumentsP
  , typeArgumentP
  , typeArgumentT
  , TypeParameter (..)
  , typeParameterP
  , typeParameterT
  , typeParametersT
  , typeParametersP
  , TypeSignature (..)
  , TypeVariable (..)
  , typeVariableP
  , Wildcard (..)
  ) 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           Data.Attoparsec.Text
import           Control.Applicative

import qualified Data.List                   as L

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


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

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

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, Generic, NFData)

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

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


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

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

data ClassType
  = ClassType
    { ctsClassName     :: ClassName
    , ctsTypeArguments :: [Maybe TypeArgument]
    }
  | InnerClassType
    { ctsInnerClassName :: Text.Text
    , ctsOuterClassType :: ClassType
    , ctsTypeArguments  :: [Maybe TypeArgument]
    }
  deriving (Show, Eq, Generic, NFData)

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

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

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

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


----------------------
-- 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 <$> parseType) <?> "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 <- parseType
  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


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


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


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

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

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)