{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DuplicateRecordFields #-}

{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
{-# OPTIONS_GHC -Werror=incomplete-patterns #-}

module Language.LSP.Types.Registration where

import           Data.Aeson
import           Data.Aeson.TH
import           Data.Text (Text)
import           Data.Function (on)
import           Data.Kind
import           Data.Void (Void)
import           GHC.Generics
import           Language.LSP.Types.CallHierarchy
import           Language.LSP.Types.CodeAction
import           Language.LSP.Types.CodeLens
import           Language.LSP.Types.Command
import           Language.LSP.Types.Common
import           Language.LSP.Types.Completion
import           Language.LSP.Types.Declaration
import           Language.LSP.Types.Definition
import           Language.LSP.Types.DocumentColor
import           Language.LSP.Types.DocumentHighlight
import           Language.LSP.Types.DocumentLink
import           Language.LSP.Types.DocumentSymbol
import           Language.LSP.Types.FoldingRange
import           Language.LSP.Types.Formatting
import           Language.LSP.Types.Hover
import           Language.LSP.Types.Implementation
import           Language.LSP.Types.Method
import           Language.LSP.Types.References
import           Language.LSP.Types.Rename
import           Language.LSP.Types.SignatureHelp
import           Language.LSP.Types.SelectionRange
import           Language.LSP.Types.SemanticTokens
import           Language.LSP.Types.TextDocument
import           Language.LSP.Types.TypeDefinition
import           Language.LSP.Types.Utils
import           Language.LSP.Types.WatchedFiles
import           Language.LSP.Types.WorkspaceSymbol


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

-- | Matches up the registration options for a specific method
type family RegistrationOptions (m :: Method FromClient t) :: Type where
  -- Workspace
  RegistrationOptions WorkspaceDidChangeWorkspaceFolders = Empty
  RegistrationOptions WorkspaceDidChangeConfiguration    = Empty
  RegistrationOptions WorkspaceDidChangeWatchedFiles     = DidChangeWatchedFilesRegistrationOptions
  RegistrationOptions WorkspaceSymbol                    = WorkspaceSymbolRegistrationOptions
  RegistrationOptions WorkspaceExecuteCommand            = ExecuteCommandRegistrationOptions

  -- Text synchronisation
  RegistrationOptions TextDocumentDidOpen                = TextDocumentRegistrationOptions
  RegistrationOptions TextDocumentDidChange              = TextDocumentChangeRegistrationOptions
  RegistrationOptions TextDocumentWillSave               = TextDocumentRegistrationOptions
  RegistrationOptions TextDocumentWillSaveWaitUntil      = TextDocumentRegistrationOptions
  RegistrationOptions TextDocumentDidSave                = TextDocumentSaveRegistrationOptions
  RegistrationOptions TextDocumentDidClose               = TextDocumentRegistrationOptions

  -- Language features
  RegistrationOptions TextDocumentCompletion             = CompletionRegistrationOptions
  RegistrationOptions TextDocumentHover                  = HoverRegistrationOptions
  RegistrationOptions TextDocumentSignatureHelp          = SignatureHelpRegistrationOptions
  RegistrationOptions TextDocumentDeclaration            = DeclarationRegistrationOptions
  RegistrationOptions TextDocumentDefinition             = DefinitionRegistrationOptions
  RegistrationOptions TextDocumentTypeDefinition         = TypeDefinitionRegistrationOptions
  RegistrationOptions TextDocumentImplementation         = ImplementationRegistrationOptions
  RegistrationOptions TextDocumentReferences             = ReferenceRegistrationOptions
  RegistrationOptions TextDocumentDocumentHighlight      = DocumentHighlightRegistrationOptions
  RegistrationOptions TextDocumentDocumentSymbol         = DocumentSymbolRegistrationOptions
  RegistrationOptions TextDocumentCodeAction             = CodeActionRegistrationOptions
  RegistrationOptions TextDocumentCodeLens               = CodeLensRegistrationOptions
  RegistrationOptions TextDocumentDocumentLink           = DocumentLinkRegistrationOptions
  RegistrationOptions TextDocumentDocumentColor          = DocumentColorRegistrationOptions
  RegistrationOptions TextDocumentFormatting             = DocumentFormattingRegistrationOptions
  RegistrationOptions TextDocumentRangeFormatting        = DocumentRangeFormattingRegistrationOptions
  RegistrationOptions TextDocumentOnTypeFormatting       = DocumentOnTypeFormattingRegistrationOptions
  RegistrationOptions TextDocumentRename                 = RenameRegistrationOptions
  RegistrationOptions TextDocumentFoldingRange           = FoldingRangeRegistrationOptions
  RegistrationOptions TextDocumentSelectionRange         = SelectionRangeRegistrationOptions
  RegistrationOptions TextDocumentPrepareCallHierarchy   = CallHierarchyRegistrationOptions
  RegistrationOptions TextDocumentSemanticTokens         = SemanticTokensRegistrationOptions
  RegistrationOptions m                                  = Void

data Registration (m :: Method FromClient t) =
  Registration
    { -- | The id used to register the request. The id can be used to deregister
      -- the request again.
      forall (t :: MethodType) (m :: Method 'FromClient t).
Registration m -> Text
_id :: Text
      -- | The method / capability to register for.
    , forall (t :: MethodType) (m :: Method 'FromClient t).
Registration m -> SClientMethod m
_method :: SClientMethod m
      -- | Options necessary for the registration.
      -- Make this strict to aid the pattern matching exhaustiveness checker
    , forall (t :: MethodType) (m :: Method 'FromClient t).
Registration m -> RegistrationOptions m
_registerOptions :: !(RegistrationOptions m)
    }
  deriving forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (t :: MethodType) (m :: Method 'FromClient t) x.
Rep (Registration m) x -> Registration m
forall (t :: MethodType) (m :: Method 'FromClient t) x.
Registration m -> Rep (Registration m) x
$cto :: forall (t :: MethodType) (m :: Method 'FromClient t) x.
Rep (Registration m) x -> Registration m
$cfrom :: forall (t :: MethodType) (m :: Method 'FromClient t) x.
Registration m -> Rep (Registration m) x
Generic

deriving instance Eq (RegistrationOptions m) => Eq (Registration m)
deriving instance Show (RegistrationOptions m) => Show (Registration m)

-- This generates the function
-- regHelper :: SMethod m
--           -> (( Show (RegistrationOptions m)
--               , ToJSON (RegistrationOptions m)
--               , FromJSON ($regOptTcon m)
--              => x)
--           -> x
makeRegHelper ''RegistrationOptions

instance ToJSON (Registration m) where
  toJSON :: Registration m -> Value
toJSON x :: Registration m
x@(Registration Text
_ SClientMethod m
m RegistrationOptions m
_) = forall {t :: MethodType} (m :: Method 'FromClient 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 Registration m
x)

data SomeRegistration = forall t (m :: Method FromClient t). SomeRegistration (Registration m)

instance ToJSON SomeRegistration where
  toJSON :: SomeRegistration -> Value
toJSON (SomeRegistration Registration m
r) = forall a. ToJSON a => a -> Value
toJSON Registration 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"
    Registration m
r <- forall (t :: MethodType) (m :: Method 'FromClient t).
Text -> SClientMethod m -> RegistrationOptions m -> Registration m
Registration 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 {t :: MethodType} (m :: Method 'FromClient 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 :: MethodType) (m :: Method 'FromClient t).
Registration m -> SomeRegistration
SomeRegistration Registration m
r)

instance Eq SomeRegistration where
  == :: SomeRegistration -> SomeRegistration -> Bool
(==) = forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a. ToJSON a => a -> Value
toJSON

instance Show SomeRegistration where
  show :: SomeRegistration -> String
show (SomeRegistration r :: Registration m
r@(Registration Text
_ SClientMethod m
m RegistrationOptions m
_)) = forall {t :: MethodType} (m :: Method 'FromClient 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 Registration m
r)

data RegistrationParams =
  RegistrationParams { RegistrationParams -> List SomeRegistration
_registrations :: List SomeRegistration }
  deriving (Int -> RegistrationParams -> ShowS
[RegistrationParams] -> ShowS
RegistrationParams -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RegistrationParams] -> ShowS
$cshowList :: [RegistrationParams] -> ShowS
show :: RegistrationParams -> String
$cshow :: RegistrationParams -> String
showsPrec :: Int -> RegistrationParams -> ShowS
$cshowsPrec :: Int -> RegistrationParams -> ShowS
Show, RegistrationParams -> RegistrationParams -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RegistrationParams -> RegistrationParams -> Bool
$c/= :: RegistrationParams -> RegistrationParams -> Bool
== :: RegistrationParams -> RegistrationParams -> Bool
$c== :: RegistrationParams -> RegistrationParams -> Bool
Eq)

deriveJSON lspOptions ''RegistrationParams


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

-- | General parameters to unregister a capability.
data Unregistration =
  Unregistration
    { -- | The id used to unregister the request or notification. Usually an id
      -- provided during the register request.
      Unregistration -> Text
_id     :: Text
      -- | The method / capability to unregister for.
    , Unregistration -> SomeClientMethod
_method :: SomeClientMethod
    } deriving (Int -> Unregistration -> ShowS
[Unregistration] -> ShowS
Unregistration -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Unregistration] -> ShowS
$cshowList :: [Unregistration] -> ShowS
show :: Unregistration -> String
$cshow :: Unregistration -> String
showsPrec :: Int -> Unregistration -> ShowS
$cshowsPrec :: Int -> Unregistration -> ShowS
Show, Unregistration -> Unregistration -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Unregistration -> Unregistration -> Bool
$c/= :: Unregistration -> Unregistration -> Bool
== :: Unregistration -> Unregistration -> Bool
$c== :: Unregistration -> Unregistration -> Bool
Eq)

deriveJSON lspOptions ''Unregistration

data UnregistrationParams =
  UnregistrationParams
    { -- | This should correctly be named @unregistrations@. However changing this
      -- is a breaking change and needs to wait until we deliver a 4.x version
      -- of the specification.
      UnregistrationParams -> List Unregistration
_unregisterations :: List Unregistration
    } deriving (Int -> UnregistrationParams -> ShowS
[UnregistrationParams] -> ShowS
UnregistrationParams -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnregistrationParams] -> ShowS
$cshowList :: [UnregistrationParams] -> ShowS
show :: UnregistrationParams -> String
$cshow :: UnregistrationParams -> String
showsPrec :: Int -> UnregistrationParams -> ShowS
$cshowsPrec :: Int -> UnregistrationParams -> ShowS
Show, UnregistrationParams -> UnregistrationParams -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnregistrationParams -> UnregistrationParams -> Bool
$c/= :: UnregistrationParams -> UnregistrationParams -> Bool
== :: UnregistrationParams -> UnregistrationParams -> Bool
$c== :: UnregistrationParams -> UnregistrationParams -> Bool
Eq)

deriveJSON lspOptions ''UnregistrationParams