{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeInType #-}

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 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
$cto :: forall (t :: MessageKind) (m :: Method 'ClientToServer t) x.
Rep (TRegistration m) x -> TRegistration m
$cfrom :: forall (t :: MessageKind) (m :: Method 'ClientToServer t) x.
TRegistration m -> Rep (TRegistration m) x
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)
_) = 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 (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) = forall a. ToJSON a => a -> Value
toJSON TRegistration m
r

instance FromJSON SomeRegistration where
  parseJSON :: Value -> Parser SomeRegistration
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Registration" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    SomeClientMethod SMethod m
m <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"method"
    TRegistration m
r <- forall (t :: MessageKind) (m :: Method 'ClientToServer t).
Text
-> SClientMethod m
-> Maybe (RegistrationOptions m)
-> TRegistration m
TRegistration forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"id" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure SMethod m
m forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"registerOptions")
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (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)
_)) = 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 (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 forall a b. (a -> b) -> a -> b
$ SomeMethod -> String
someMethodToMethodString forall a b. (a -> b) -> a -> b
$ forall {f :: MessageDirection} {t :: MessageKind}
       (m :: Method f t).
SMethod m -> SomeMethod
SomeMethod SClientMethod m
meth) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ 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 (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 = forall a. ToJSON a => a -> Value
toJSON Registration
r
   in case forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
        Success SomeRegistration
r' -> forall a. a -> Maybe a
Just SomeRegistration
r'
        Result 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 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
$cto :: forall (t :: MessageKind) (m :: Method 'ClientToServer t) x.
Rep (TUnregistration m) x -> TUnregistration m
$cfrom :: forall (t :: MessageKind) (m :: Method 'ClientToServer t) x.
TUnregistration m -> Rep (TUnregistration m) x
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) = 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 (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) = forall a. ToJSON a => a -> Value
toJSON TUnregistration m
r

instance FromJSON SomeUnregistration where
  parseJSON :: Value -> Parser SomeUnregistration
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Unregistration" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    SomeClientMethod SMethod m
m <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"method"
    TUnregistration m
r <- forall (t :: MessageKind) (m :: Method 'ClientToServer t).
Text -> SMethod m -> TUnregistration m
TUnregistration forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"id" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure SMethod m
m
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 forall a b. (a -> b) -> a -> b
$ SomeMethod -> String
someMethodToMethodString forall a b. (a -> b) -> a -> b
$ 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 = forall a. ToJSON a => a -> Value
toJSON Unregistration
r
   in case forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
        Success SomeUnregistration
r' -> forall a. a -> Maybe a
Just SomeUnregistration
r'
        Result SomeUnregistration
_ -> forall a. Maybe a
Nothing