{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TemplateHaskell #-}

module Language.LSP.Protocol.Message.Registration where

import Language.LSP.Protocol.Internal.Method
import Language.LSP.Protocol.Message.Meta
import Language.LSP.Protocol.Message.Method
import Language.LSP.Protocol.Types
import Language.LSP.Protocol.Utils.Misc

import Data.Aeson
import Data.Text (Text)
import Data.Text qualified as T
import GHC.Generics
import Prettyprinter

-- | Typed registration type, with correct options.
data TRegistration (m :: Method ClientToServer t) = TRegistration
  { forall (t :: MessageKind) (m :: Method 'ClientToServer t).
TRegistration m -> Text
_id :: Text
  -- ^ The id used to register the request. The id can be used to deregister
  -- the request again.
  , forall (t :: MessageKind) (m :: Method 'ClientToServer t).
TRegistration m -> SClientMethod m
_method :: SClientMethod m
  -- ^ The method / capability to register for.
  , forall (t :: MessageKind) (m :: Method 'ClientToServer t).
TRegistration m -> Maybe (RegistrationOptions m)
_registerOptions :: !(Maybe (RegistrationOptions m))
  -- ^ Options necessary for the registration.
  -- Make this strict to aid the pattern matching exhaustiveness checker
  }
  deriving stock ((forall x. TRegistration m -> Rep (TRegistration m) x)
-> (forall x. Rep (TRegistration m) x -> TRegistration m)
-> Generic (TRegistration m)
forall x. Rep (TRegistration m) x -> TRegistration m
forall x. TRegistration m -> Rep (TRegistration m) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (t :: MessageKind) (m :: Method 'ClientToServer t) x.
Rep (TRegistration m) x -> TRegistration m
forall (t :: MessageKind) (m :: Method 'ClientToServer t) x.
TRegistration m -> Rep (TRegistration m) x
$cfrom :: forall (t :: MessageKind) (m :: Method 'ClientToServer t) x.
TRegistration m -> Rep (TRegistration m) x
from :: forall x. TRegistration m -> Rep (TRegistration m) x
$cto :: forall (t :: MessageKind) (m :: Method 'ClientToServer t) x.
Rep (TRegistration m) x -> TRegistration m
to :: forall x. Rep (TRegistration m) x -> TRegistration m
Generic)

deriving stock instance Eq (RegistrationOptions m) => Eq (TRegistration m)
deriving stock instance Show (RegistrationOptions m) => Show (TRegistration m)

-- TODO: can we do this generically somehow?
-- This generates the function
-- regHelper :: SMethod m
--           -> (( Show (RegistrationOptions m)
--               , ToJSON (RegistrationOptions m)
--               , FromJSON ($regOptTcon m)
--              => x)
--           -> x
makeRegHelper ''RegistrationOptions

instance ToJSON (TRegistration m) where
  toJSON :: TRegistration m -> Value
toJSON x :: TRegistration m
x@(TRegistration Text
_ SClientMethod m
m Maybe (RegistrationOptions m)
_) = SClientMethod m
-> ((Show (RegistrationOptions m), ToJSON (RegistrationOptions m),
     FromJSON (RegistrationOptions m)) =>
    Value)
-> Value
forall {f :: MessageDirection} {t :: MessageKind} (m :: Method f t)
       x.
SMethod m
-> ((Show (RegistrationOptions m), ToJSON (RegistrationOptions m),
     FromJSON (RegistrationOptions m)) =>
    x)
-> x
regHelper SClientMethod m
m (Options -> TRegistration m -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
lspOptions TRegistration m
x)

deriving via ViaJSON (TRegistration m) instance Pretty (TRegistration m)

data SomeRegistration = forall t (m :: Method ClientToServer t). SomeRegistration (TRegistration m)

instance ToJSON SomeRegistration where
  toJSON :: SomeRegistration -> Value
toJSON (SomeRegistration TRegistration m
r) = TRegistration m -> Value
forall a. ToJSON a => a -> Value
toJSON TRegistration m
r

instance FromJSON SomeRegistration where
  parseJSON :: Value -> Parser SomeRegistration
parseJSON = String
-> (Object -> Parser SomeRegistration)
-> Value
-> Parser SomeRegistration
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Registration" ((Object -> Parser SomeRegistration)
 -> Value -> Parser SomeRegistration)
-> (Object -> Parser SomeRegistration)
-> Value
-> Parser SomeRegistration
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    SomeClientMethod SMethod m
m <- Object
o Object -> Key -> Parser SomeClientMethod
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"method"
    TRegistration m
r <- Text
-> SMethod m -> Maybe (RegistrationOptions m) -> TRegistration m
forall (t :: MessageKind) (m :: Method 'ClientToServer t).
Text
-> SClientMethod m
-> Maybe (RegistrationOptions m)
-> TRegistration m
TRegistration (Text
 -> SMethod m -> Maybe (RegistrationOptions m) -> TRegistration m)
-> Parser Text
-> Parser
     (SMethod m -> Maybe (RegistrationOptions m) -> TRegistration m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"id" Parser
  (SMethod m -> Maybe (RegistrationOptions m) -> TRegistration m)
-> Parser (SMethod m)
-> Parser (Maybe (RegistrationOptions m) -> TRegistration m)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SMethod m -> Parser (SMethod m)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMethod m
m Parser (Maybe (RegistrationOptions m) -> TRegistration m)
-> Parser (Maybe (RegistrationOptions m))
-> Parser (TRegistration m)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SMethod m
-> ((Show (RegistrationOptions m), ToJSON (RegistrationOptions m),
     FromJSON (RegistrationOptions m)) =>
    Parser (Maybe (RegistrationOptions m)))
-> Parser (Maybe (RegistrationOptions m))
forall {f :: MessageDirection} {t :: MessageKind} (m :: Method f t)
       x.
SMethod m
-> ((Show (RegistrationOptions m), ToJSON (RegistrationOptions m),
     FromJSON (RegistrationOptions m)) =>
    x)
-> x
regHelper SMethod m
m (Object
o Object -> Key -> Parser (Maybe (RegistrationOptions m))
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"registerOptions")
    SomeRegistration -> Parser SomeRegistration
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TRegistration m -> SomeRegistration
forall (t :: MessageKind) (m :: Method 'ClientToServer t).
TRegistration m -> SomeRegistration
SomeRegistration TRegistration m
r)

instance Show SomeRegistration where
  show :: SomeRegistration -> String
show (SomeRegistration r :: TRegistration m
r@(TRegistration Text
_ SClientMethod m
m Maybe (RegistrationOptions m)
_)) = SClientMethod m
-> ((Show (RegistrationOptions m), ToJSON (RegistrationOptions m),
     FromJSON (RegistrationOptions m)) =>
    String)
-> String
forall {f :: MessageDirection} {t :: MessageKind} (m :: Method f t)
       x.
SMethod m
-> ((Show (RegistrationOptions m), ToJSON (RegistrationOptions m),
     FromJSON (RegistrationOptions m)) =>
    x)
-> x
regHelper SClientMethod m
m (TRegistration m -> String
forall a. Show a => a -> String
show TRegistration m
r)

deriving via ViaJSON SomeRegistration instance Pretty SomeRegistration

toUntypedRegistration :: TRegistration m -> Registration
toUntypedRegistration :: forall {t :: MessageKind} (m :: Method 'ClientToServer t).
TRegistration m -> Registration
toUntypedRegistration (TRegistration Text
i SClientMethod m
meth Maybe (RegistrationOptions m)
opts) = Text -> Text -> Maybe Value -> Registration
Registration Text
i (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeMethod -> String
someMethodToMethodString (SomeMethod -> String) -> SomeMethod -> String
forall a b. (a -> b) -> a -> b
$ SClientMethod m -> SomeMethod
forall {f :: MessageDirection} {t :: MessageKind}
       (m :: Method f t).
SMethod m -> SomeMethod
SomeMethod SClientMethod m
meth) (Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ SClientMethod m
-> ((Show (RegistrationOptions m), ToJSON (RegistrationOptions m),
     FromJSON (RegistrationOptions m)) =>
    Value)
-> Value
forall {f :: MessageDirection} {t :: MessageKind} (m :: Method f t)
       x.
SMethod m
-> ((Show (RegistrationOptions m), ToJSON (RegistrationOptions m),
     FromJSON (RegistrationOptions m)) =>
    x)
-> x
regHelper SClientMethod m
meth (Maybe (RegistrationOptions m) -> Value
forall a. ToJSON a => a -> Value
toJSON Maybe (RegistrationOptions m)
opts))

toSomeRegistration :: Registration -> Maybe SomeRegistration
toSomeRegistration :: Registration -> Maybe SomeRegistration
toSomeRegistration Registration
r =
  let v :: Value
v = Registration -> Value
forall a. ToJSON a => a -> Value
toJSON Registration
r
   in case Value -> Result SomeRegistration
forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
        Success SomeRegistration
r' -> SomeRegistration -> Maybe SomeRegistration
forall a. a -> Maybe a
Just SomeRegistration
r'
        Result SomeRegistration
_ -> Maybe SomeRegistration
forall a. Maybe a
Nothing

-- ---------------------------------------------------------------------

-- | Typed unregistration type.
data TUnregistration (m :: Method ClientToServer t) = TUnregistration
  { forall (t :: MessageKind) (m :: Method 'ClientToServer t).
TUnregistration m -> Text
_id :: Text
  -- ^ The id used to unregister the request or notification. Usually an id
  -- provided during the register request.
  , forall (t :: MessageKind) (m :: Method 'ClientToServer t).
TUnregistration m -> SMethod m
_method :: SMethod m
  -- ^ The method / capability to unregister for.
  }
  deriving stock ((forall x. TUnregistration m -> Rep (TUnregistration m) x)
-> (forall x. Rep (TUnregistration m) x -> TUnregistration m)
-> Generic (TUnregistration m)
forall x. Rep (TUnregistration m) x -> TUnregistration m
forall x. TUnregistration m -> Rep (TUnregistration m) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (t :: MessageKind) (m :: Method 'ClientToServer t) x.
Rep (TUnregistration m) x -> TUnregistration m
forall (t :: MessageKind) (m :: Method 'ClientToServer t) x.
TUnregistration m -> Rep (TUnregistration m) x
$cfrom :: forall (t :: MessageKind) (m :: Method 'ClientToServer t) x.
TUnregistration m -> Rep (TUnregistration m) x
from :: forall x. TUnregistration m -> Rep (TUnregistration m) x
$cto :: forall (t :: MessageKind) (m :: Method 'ClientToServer t) x.
Rep (TUnregistration m) x -> TUnregistration m
to :: forall x. Rep (TUnregistration m) x -> TUnregistration m
Generic)

deriving stock instance Eq (TUnregistration m)
deriving stock instance Show (TUnregistration m)

instance ToJSON (TUnregistration m) where
  toJSON :: TUnregistration m -> Value
toJSON x :: TUnregistration m
x@(TUnregistration Text
_ SMethod m
m) = SMethod m
-> ((Show (RegistrationOptions m), ToJSON (RegistrationOptions m),
     FromJSON (RegistrationOptions m)) =>
    Value)
-> Value
forall {f :: MessageDirection} {t :: MessageKind} (m :: Method f t)
       x.
SMethod m
-> ((Show (RegistrationOptions m), ToJSON (RegistrationOptions m),
     FromJSON (RegistrationOptions m)) =>
    x)
-> x
regHelper SMethod m
m (Options -> TUnregistration m -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
lspOptions TUnregistration m
x)

deriving via ViaJSON (TUnregistration m) instance Pretty (TUnregistration m)

data SomeUnregistration = forall t (m :: Method ClientToServer t). SomeUnregistration (TUnregistration m)

instance ToJSON SomeUnregistration where
  toJSON :: SomeUnregistration -> Value
toJSON (SomeUnregistration TUnregistration m
r) = TUnregistration m -> Value
forall a. ToJSON a => a -> Value
toJSON TUnregistration m
r

instance FromJSON SomeUnregistration where
  parseJSON :: Value -> Parser SomeUnregistration
parseJSON = String
-> (Object -> Parser SomeUnregistration)
-> Value
-> Parser SomeUnregistration
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Unregistration" ((Object -> Parser SomeUnregistration)
 -> Value -> Parser SomeUnregistration)
-> (Object -> Parser SomeUnregistration)
-> Value
-> Parser SomeUnregistration
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    SomeClientMethod SMethod m
m <- Object
o Object -> Key -> Parser SomeClientMethod
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"method"
    TUnregistration m
r <- Text -> SMethod m -> TUnregistration m
forall (t :: MessageKind) (m :: Method 'ClientToServer t).
Text -> SMethod m -> TUnregistration m
TUnregistration (Text -> SMethod m -> TUnregistration m)
-> Parser Text -> Parser (SMethod m -> TUnregistration m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"id" Parser (SMethod m -> TUnregistration m)
-> Parser (SMethod m) -> Parser (TUnregistration m)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SMethod m -> Parser (SMethod m)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMethod m
m
    SomeUnregistration -> Parser SomeUnregistration
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TUnregistration m -> SomeUnregistration
forall (t :: MessageKind) (m :: Method 'ClientToServer t).
TUnregistration m -> SomeUnregistration
SomeUnregistration TUnregistration m
r)

deriving via ViaJSON SomeUnregistration instance Pretty SomeUnregistration

toUntypedUnregistration :: TUnregistration m -> Unregistration
toUntypedUnregistration :: forall {t :: MessageKind} (m :: Method 'ClientToServer t).
TUnregistration m -> Unregistration
toUntypedUnregistration (TUnregistration Text
i SMethod m
meth) = Text -> Text -> Unregistration
Unregistration Text
i (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeMethod -> String
someMethodToMethodString (SomeMethod -> String) -> SomeMethod -> String
forall a b. (a -> b) -> a -> b
$ SMethod m -> SomeMethod
forall {f :: MessageDirection} {t :: MessageKind}
       (m :: Method f t).
SMethod m -> SomeMethod
SomeMethod SMethod m
meth)

toSomeUnregistration :: Unregistration -> Maybe SomeUnregistration
toSomeUnregistration :: Unregistration -> Maybe SomeUnregistration
toSomeUnregistration Unregistration
r =
  let v :: Value
v = Unregistration -> Value
forall a. ToJSON a => a -> Value
toJSON Unregistration
r
   in case Value -> Result SomeUnregistration
forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
        Success SomeUnregistration
r' -> SomeUnregistration -> Maybe SomeUnregistration
forall a. a -> Maybe a
Just SomeUnregistration
r'
        Result SomeUnregistration
_ -> Maybe SomeUnregistration
forall a. Maybe a
Nothing