{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE MultiWayIf          #-}
{-# LANGUAGE BinaryLiterals      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Language.Haskell.LSP.Core (
    handleMessage
  , LanguageContextData(..)
  , VFSData(..)
  , Handler
  , InitializeCallbacks(..)
  , LspFuncs(..)
  , Progress(..)
  , ProgressCancellable(..)
  , ProgressCancelledException
  , SendFunc
  , Handlers(..)
  , Options(..)
  , defaultLanguageContextData
  , makeResponseMessage
  , makeResponseError
  , setupLogger
  , sendErrorResponseS
  , sendErrorLogS
  , sendErrorShowS
  , reverseSortEdit
  , Priority(..)
  ) where

import           Control.Concurrent.Async
import           Control.Concurrent.STM
import qualified Control.Exception as E
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Lens ( (<&>), (^.), (^?), _Just )
import qualified Data.Aeson as J
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as B
import           Data.Default
import qualified Data.HashMap.Strict as HM
import qualified Data.List as L
import           Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Map as Map
import           Data.Maybe
import           Data.Monoid
import qualified Data.Text as T
import           Data.Text ( Text )
import           Language.Haskell.LSP.Capture
import           Language.Haskell.LSP.Constant
import           Language.Haskell.LSP.Messages
import qualified Language.Haskell.LSP.Types.Capabilities    as C
import qualified Language.Haskell.LSP.Types                 as J
import qualified Language.Haskell.LSP.Types.Lens            as J
import           Language.Haskell.LSP.Utility
import           Language.Haskell.LSP.VFS
import           Language.Haskell.LSP.Diagnostics
import           System.Directory
import           System.Exit
import           System.IO
import qualified System.Log.Formatter as L
import qualified System.Log.Handler as LH
import qualified System.Log.Handler.Simple as LHS
import           System.Log.Logger
import qualified System.Log.Logger as L

-- ---------------------------------------------------------------------
{-# ANN module ("HLint: ignore Eta reduce"         :: String) #-}
{-# ANN module ("HLint: ignore Redundant do"       :: String) #-}
{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
-- ---------------------------------------------------------------------

-- | A function to send a message to the client
type SendFunc = FromServerMessage -> IO ()

-- | state used by the LSP dispatcher to manage the message loop
data LanguageContextData config =
  LanguageContextData {
    LanguageContextData config -> Int
resSeqDebugContextData :: !Int
  , LanguageContextData config -> Handlers
resHandlers            :: !Handlers
  , LanguageContextData config -> Options
resOptions             :: !Options
  , LanguageContextData config -> SendFunc
resSendResponse        :: !SendFunc
  , LanguageContextData config -> VFSData
resVFS                 :: !VFSData
  , LanguageContextData config -> DiagnosticStore
resDiagnostics         :: !DiagnosticStore
  , LanguageContextData config -> Maybe config
resConfig              :: !(Maybe config)
  , LanguageContextData config -> TVar Int
resLspId               :: !(TVar Int)
  , LanguageContextData config -> LspFuncs config
resLspFuncs            :: LspFuncs config -- NOTE: Cannot be strict, lazy initialization
  , LanguageContextData config -> CaptureContext
resCaptureContext      :: !CaptureContext
  , LanguageContextData config -> [WorkspaceFolder]
resWorkspaceFolders    :: ![J.WorkspaceFolder]
  , LanguageContextData config -> ProgressData
resProgressData        :: !ProgressData
  }

data ProgressData = ProgressData { ProgressData -> Int
progressNextId :: !Int
                                 , ProgressData -> Map ProgressToken (IO ())
progressCancel :: !(Map.Map J.ProgressToken (IO ())) }

data VFSData =
  VFSData
    { VFSData -> VFS
vfsData :: !VFS
    , VFSData -> Map FilePath FilePath
reverseMap :: !(Map.Map FilePath FilePath)
    }

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

-- | Language Server Protocol options that the server may configure.
-- If you set handlers for some requests, you may need to set some of these options.
data Options =
  Options
    { Options -> Maybe TextDocumentSyncOptions
textDocumentSync                 :: Maybe J.TextDocumentSyncOptions
    -- |  The characters that trigger completion automatically.
    , Options -> Maybe FilePath
completionTriggerCharacters      :: Maybe [Char]
    -- | The list of all possible characters that commit a completion. This field can be used
    -- if clients don't support individual commmit characters per completion item. See
    -- `_commitCharactersSupport`.
    , Options -> Maybe FilePath
completionAllCommitCharacters    :: Maybe [Char]
    -- | The characters that trigger signature help automatically.
    , Options -> Maybe FilePath
signatureHelpTriggerCharacters   :: Maybe [Char]
    -- | List of characters that re-trigger signature help.
    -- These trigger characters are only active when signature help is already showing. All trigger characters
    -- are also counted as re-trigger characters.
    , Options -> Maybe FilePath
signatureHelpRetriggerCharacters :: Maybe [Char]
    -- | CodeActionKinds that this server may return.
    -- The list of kinds may be generic, such as `CodeActionKind.Refactor`, or the server
    -- may list out every specific kind they provide.
    , Options -> Maybe [CodeActionKind]
codeActionKinds                  :: Maybe [J.CodeActionKind]
    -- | The list of characters that triggers on type formatting.
    -- If you set `documentOnTypeFormattingHandler`, you **must** set this.
    -- The first character is mandatory, so a 'NonEmpty' should be passed.
    , Options -> Maybe (NonEmpty Char)
documentOnTypeFormattingTriggerCharacters :: Maybe (NonEmpty Char)
    -- | The commands to be executed on the server.
    -- If you set `executeCommandHandler`, you **must** set this.
    , Options -> Maybe [Text]
executeCommandCommands           :: Maybe [Text]
    }

instance Default Options where
  def :: Options
def = Maybe TextDocumentSyncOptions
-> Maybe FilePath
-> Maybe FilePath
-> Maybe FilePath
-> Maybe FilePath
-> Maybe [CodeActionKind]
-> Maybe (NonEmpty Char)
-> Maybe [Text]
-> Options
Options Maybe TextDocumentSyncOptions
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing
                Maybe [CodeActionKind]
forall a. Maybe a
Nothing Maybe (NonEmpty Char)
forall a. Maybe a
Nothing Maybe [Text]
forall a. Maybe a
Nothing

-- | A function to publish diagnostics. It aggregates all diagnostics pertaining
-- to a particular version of a document, by source, and sends a
-- 'textDocument/publishDiagnostics' notification with the total (limited by the
-- first parameter) whenever it is updated.
type PublishDiagnosticsFunc = Int -- Max number of diagnostics to send
                            -> J.NormalizedUri -> J.TextDocumentVersion -> DiagnosticsBySource -> IO ()

-- | A function to remove all diagnostics from a particular source, and send the updates to the client.
type FlushDiagnosticsBySourceFunc = Int -- Max number of diagnostics to send
                                  -> Maybe J.DiagnosticSource -> IO ()

-- | A package indicating the perecentage of progress complete and a
-- an optional message to go with it during a 'withProgress'
--
-- @since 0.10.0.0
data Progress = Progress (Maybe Double) (Maybe Text)

-- | Thrown if the user cancels a 'Cancellable' 'withProgress'/'withIndefiniteProgress'/ session
--
-- @since 0.11.0.0
data ProgressCancelledException = ProgressCancelledException
  deriving Int -> ProgressCancelledException -> ShowS
[ProgressCancelledException] -> ShowS
ProgressCancelledException -> FilePath
(Int -> ProgressCancelledException -> ShowS)
-> (ProgressCancelledException -> FilePath)
-> ([ProgressCancelledException] -> ShowS)
-> Show ProgressCancelledException
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ProgressCancelledException] -> ShowS
$cshowList :: [ProgressCancelledException] -> ShowS
show :: ProgressCancelledException -> FilePath
$cshow :: ProgressCancelledException -> FilePath
showsPrec :: Int -> ProgressCancelledException -> ShowS
$cshowsPrec :: Int -> ProgressCancelledException -> ShowS
Show
instance E.Exception ProgressCancelledException

-- | Whether or not the user should be able to cancel a 'withProgress'/'withIndefiniteProgress'
-- session
--
-- @since 0.11.0.0
data ProgressCancellable = Cancellable | NotCancellable

-- | Returned to the server on startup, providing ways to interact with the client.
data LspFuncs c =
  LspFuncs
    { LspFuncs c -> ClientCapabilities
clientCapabilities           :: !C.ClientCapabilities
    , LspFuncs c -> IO (Maybe c)
config                       :: !(IO (Maybe c))
      -- ^ Derived from the DidChangeConfigurationNotification message via a
      -- server-provided function.
    , LspFuncs c -> SendFunc
sendFunc                     :: !SendFunc
    , LspFuncs c -> NormalizedUri -> IO (Maybe VirtualFile)
getVirtualFileFunc           :: !(J.NormalizedUri -> IO (Maybe VirtualFile))
      -- ^ Function to return the 'VirtualFile' associated with a
      -- given 'NormalizedUri', if there is one.
    , LspFuncs c -> NormalizedUri -> IO (Maybe FilePath)
persistVirtualFileFunc       :: !(J.NormalizedUri -> IO (Maybe FilePath))
    , LspFuncs c -> IO ShowS
reverseFileMapFunc           :: !(IO (FilePath -> FilePath))
    , LspFuncs c -> PublishDiagnosticsFunc
publishDiagnosticsFunc       :: !PublishDiagnosticsFunc
    , LspFuncs c -> FlushDiagnosticsBySourceFunc
flushDiagnosticsBySourceFunc :: !FlushDiagnosticsBySourceFunc
    , LspFuncs c -> IO LspId
getNextReqId                 :: !(IO J.LspId)
    , LspFuncs c -> Maybe FilePath
rootPath                     :: !(Maybe FilePath)
    , LspFuncs c -> IO (Maybe [WorkspaceFolder])
getWorkspaceFolders          :: !(IO (Maybe [J.WorkspaceFolder]))
    , LspFuncs c
-> forall a.
   Text
   -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a
withProgress                 :: !(forall a . Text -> ProgressCancellable
                                        -> ((Progress -> IO ()) -> IO a) -> IO a)
      -- ^ Wrapper for reporting progress to the client during a long running
      -- task.
      -- 'withProgress' @title cancellable f@ starts a new progress reporting
      -- session, and finishes it once f is completed.
      -- f is provided with an update function that allows it to report on
      -- the progress during the session.
      -- If @cancellable@ is 'Cancellable', @f@ will be thrown a
      -- 'ProgressCancelledException' if the user cancels the action in
      -- progress.
      --
      -- @since 0.10.0.0
    , LspFuncs c -> forall a. Text -> ProgressCancellable -> IO a -> IO a
withIndefiniteProgress       :: !(forall a . Text -> ProgressCancellable
                                        -> IO a -> IO a)
    -- ^ Same as 'withProgress', but for processes that do not report the
    -- precentage complete.
    --
    -- @since 0.10.0.0
    }

-- | Contains all the callbacks to use for initialized the language server.
-- it is parameterized over a config type variable representing the type for the
-- specific configuration data the language server needs to use.
data InitializeCallbacks config =
  InitializeCallbacks
    { InitializeCallbacks config
-> InitializeRequest -> Either Text config
onInitialConfiguration :: J.InitializeRequest -> Either T.Text config
      -- ^ Invoked on the first message from the language client, containg the client configuration
      -- This callback should return either the parsed configuration data or an error indicating
      -- what went wrong. The parsed configuration object will be stored internally and passed to
      -- hanlder functions as context.
    , InitializeCallbacks config
-> DidChangeConfigurationNotification -> Either Text config
onConfigurationChange :: J.DidChangeConfigurationNotification-> Either T.Text config
      -- ^ Invoked whenever the clients sends a message with a changed client configuration.
      -- This callback should return either the parsed configuration data or an error indicating
      -- what went wrong. The parsed configuration object will be stored internally and passed to
      -- hanlder functions as context.
    , InitializeCallbacks config
-> LspFuncs config -> IO (Maybe ResponseError)
onStartup :: LspFuncs config -> IO (Maybe J.ResponseError)
      -- ^ Once the initial configuration has been received, this callback will be invoked to offer
      -- the language server implementation the chance to create any processes or start new threads
      -- that may be necesary for the server lifecycle.
    }

-- | The Handler type captures a function that receives local read-only state
-- 'a', a function to send a reply message once encoded as a ByteString, and a
-- received message of type 'b'
type Handler b =  b -> IO ()

-- | Callbacks from the language server to the language handler
data Handlers =
  Handlers
    {
    -- Capability-advertised handlers
      Handlers -> Maybe (Handler HoverRequest)
hoverHandler                   :: !(Maybe (Handler J.HoverRequest))
    , Handlers -> Maybe (Handler CompletionRequest)
completionHandler              :: !(Maybe (Handler J.CompletionRequest))
    , Handlers -> Maybe (Handler CompletionItemResolveRequest)
completionResolveHandler       :: !(Maybe (Handler J.CompletionItemResolveRequest))
    , Handlers -> Maybe (Handler SignatureHelpRequest)
signatureHelpHandler           :: !(Maybe (Handler J.SignatureHelpRequest))
    , Handlers -> Maybe (Handler DefinitionRequest)
definitionHandler              :: !(Maybe (Handler J.DefinitionRequest))
    , Handlers -> Maybe (Handler DefinitionRequest)
typeDefinitionHandler          :: !(Maybe (Handler J.TypeDefinitionRequest))
    , Handlers -> Maybe (Handler DefinitionRequest)
implementationHandler          :: !(Maybe (Handler J.ImplementationRequest))
    , Handlers -> Maybe (Handler ReferencesRequest)
referencesHandler              :: !(Maybe (Handler J.ReferencesRequest))
    , Handlers -> Maybe (Handler DocumentHighlightRequest)
documentHighlightHandler       :: !(Maybe (Handler J.DocumentHighlightRequest))
    , Handlers -> Maybe (Handler DocumentSymbolRequest)
documentSymbolHandler          :: !(Maybe (Handler J.DocumentSymbolRequest))
    , Handlers -> Maybe (Handler WorkspaceSymbolRequest)
workspaceSymbolHandler         :: !(Maybe (Handler J.WorkspaceSymbolRequest))
    , Handlers -> Maybe (Handler CodeActionRequest)
codeActionHandler              :: !(Maybe (Handler J.CodeActionRequest))
    , Handlers -> Maybe (Handler CodeLensRequest)
codeLensHandler                :: !(Maybe (Handler J.CodeLensRequest))
    , Handlers -> Maybe (Handler CodeLensResolveRequest)
codeLensResolveHandler         :: !(Maybe (Handler J.CodeLensResolveRequest))
    , Handlers -> Maybe (Handler DocumentColorRequest)
documentColorHandler           :: !(Maybe (Handler J.DocumentColorRequest))
    , Handlers -> Maybe (Handler ColorPresentationRequest)
colorPresentationHandler       :: !(Maybe (Handler J.ColorPresentationRequest))
    , Handlers -> Maybe (Handler DocumentFormattingRequest)
documentFormattingHandler      :: !(Maybe (Handler J.DocumentFormattingRequest))
    , Handlers -> Maybe (Handler DocumentRangeFormattingRequest)
documentRangeFormattingHandler :: !(Maybe (Handler J.DocumentRangeFormattingRequest))
    , Handlers -> Maybe (Handler DocumentOnTypeFormattingRequest)
documentOnTypeFormattingHandler :: !(Maybe (Handler J.DocumentOnTypeFormattingRequest))
    , Handlers -> Maybe (Handler RenameRequest)
renameHandler                  :: !(Maybe (Handler J.RenameRequest))
    , Handlers -> Maybe (Handler PrepareRenameRequest)
prepareRenameHandler           :: !(Maybe (Handler J.PrepareRenameRequest))
    , Handlers -> Maybe (Handler FoldingRangeRequest)
foldingRangeHandler            :: !(Maybe (Handler J.FoldingRangeRequest))
    -- new in 3.0
    , Handlers -> Maybe (Handler DocumentLinkRequest)
documentLinkHandler            :: !(Maybe (Handler J.DocumentLinkRequest))
    , Handlers -> Maybe (Handler DocumentLinkResolveRequest)
documentLinkResolveHandler     :: !(Maybe (Handler J.DocumentLinkResolveRequest))
    , Handlers -> Maybe (Handler ExecuteCommandRequest)
executeCommandHandler          :: !(Maybe (Handler J.ExecuteCommandRequest))
    -- Next 2 go from server -> client
    -- , registerCapabilityHandler      :: !(Maybe (Handler J.RegisterCapabilityRequest))
    -- , unregisterCapabilityHandler    :: !(Maybe (Handler J.UnregisterCapabilityRequest))
    , Handlers -> Maybe (Handler WillSaveWaitUntilTextDocumentRequest)
willSaveWaitUntilTextDocHandler:: !(Maybe (Handler J.WillSaveWaitUntilTextDocumentRequest))

    -- Notifications from the client
    , Handlers -> Maybe (Handler DidChangeConfigurationNotification)
didChangeConfigurationParamsHandler      :: !(Maybe (Handler J.DidChangeConfigurationNotification))
    , Handlers -> Maybe (Handler DidOpenTextDocumentNotification)
didOpenTextDocumentNotificationHandler   :: !(Maybe (Handler J.DidOpenTextDocumentNotification))
    , Handlers -> Maybe (Handler DidChangeTextDocumentNotification)
didChangeTextDocumentNotificationHandler :: !(Maybe (Handler J.DidChangeTextDocumentNotification))
    -- ^ Note: If you need to keep track of document changes,
    -- "Language.Haskell.LSP.VFS" will take care of these messages for you!
    , Handlers -> Maybe (Handler DidCloseTextDocumentNotification)
didCloseTextDocumentNotificationHandler  :: !(Maybe (Handler J.DidCloseTextDocumentNotification))
    , Handlers -> Maybe (Handler DidSaveTextDocumentNotification)
didSaveTextDocumentNotificationHandler   :: !(Maybe (Handler J.DidSaveTextDocumentNotification))
    , Handlers -> Maybe (Handler DidChangeWatchedFilesNotification)
didChangeWatchedFilesNotificationHandler :: !(Maybe (Handler J.DidChangeWatchedFilesNotification))
    , Handlers -> Maybe (Handler DidChangeWorkspaceFoldersNotification)
didChangeWorkspaceFoldersNotificationHandler :: !(Maybe (Handler J.DidChangeWorkspaceFoldersNotification))
    -- new in 3.0
    , Handlers -> Maybe (Handler InitializedNotification)
initializedHandler                       :: !(Maybe (Handler J.InitializedNotification))
    , Handlers -> Maybe (Handler WillSaveTextDocumentNotification)
willSaveTextDocumentNotificationHandler  :: !(Maybe (Handler J.WillSaveTextDocumentNotification))
    , Handlers -> Maybe (Handler CancelNotification)
cancelNotificationHandler                :: !(Maybe (Handler J.CancelNotification))

    -- Responses to Request messages originated from the server
    -- TODO: Properly decode response types and replace them with actual handlers
    , Handlers -> Maybe (Handler BareResponseMessage)
responseHandler                    :: !(Maybe (Handler J.BareResponseMessage))
    -- , registerCapabilityHandler                :: !(Maybe (Handler J.RegisterCapabilityResponse))
    -- , unregisterCapabilityHandler              :: !(Maybe (Handler J.RegisterCapabilityResponse))
    -- , showMessageHandler                       :: !(Maybe (Handler J.ShowMessageResponse))

    -- Initialization request on startup
    , Handlers -> Maybe (Handler InitializeRequest)
initializeRequestHandler                 :: !(Maybe (Handler J.InitializeRequest))
    -- Will default to terminating `exitMessage` if Nothing
    , Handlers -> Maybe (Handler ExitNotification)
exitNotificationHandler                  :: !(Maybe (Handler J.ExitNotification))

    , Handlers -> Maybe (Handler CustomClientRequest)
customRequestHandler                     :: !(Maybe (Handler J.CustomClientRequest))
    , Handlers -> Maybe (Handler CustomClientNotification)
customNotificationHandler                :: !(Maybe (Handler J.CustomClientNotification))

    }

instance Default Handlers where
  -- These already implicitly do stuff to the VFS, so silence warnings about no handler
  def :: Handlers
def = Handlers
nothings { didChangeTextDocumentNotificationHandler :: Maybe (Handler DidChangeTextDocumentNotification)
didChangeTextDocumentNotificationHandler = Handler DidChangeTextDocumentNotification
-> Maybe (Handler DidChangeTextDocumentNotification)
forall a. a -> Maybe a
Just Handler DidChangeTextDocumentNotification
forall b. b -> IO ()
ignore
                 , didOpenTextDocumentNotificationHandler :: Maybe (Handler DidOpenTextDocumentNotification)
didOpenTextDocumentNotificationHandler   = Handler DidOpenTextDocumentNotification
-> Maybe (Handler DidOpenTextDocumentNotification)
forall a. a -> Maybe a
Just Handler DidOpenTextDocumentNotification
forall b. b -> IO ()
ignore
                 , didCloseTextDocumentNotificationHandler :: Maybe (Handler DidCloseTextDocumentNotification)
didCloseTextDocumentNotificationHandler  = Handler DidCloseTextDocumentNotification
-> Maybe (Handler DidCloseTextDocumentNotification)
forall a. a -> Maybe a
Just Handler DidCloseTextDocumentNotification
forall b. b -> IO ()
ignore
                 }
    where ignore :: b -> IO ()
ignore = IO () -> b -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
          nothings :: Handlers
nothings = Maybe (Handler HoverRequest)
-> Maybe (Handler CompletionRequest)
-> Maybe (Handler CompletionItemResolveRequest)
-> Maybe (Handler SignatureHelpRequest)
-> Maybe (Handler DefinitionRequest)
-> Maybe (Handler DefinitionRequest)
-> Maybe (Handler DefinitionRequest)
-> Maybe (Handler ReferencesRequest)
-> Maybe (Handler DocumentHighlightRequest)
-> Maybe (Handler DocumentSymbolRequest)
-> Maybe (Handler WorkspaceSymbolRequest)
-> Maybe (Handler CodeActionRequest)
-> Maybe (Handler CodeLensRequest)
-> Maybe (Handler CodeLensResolveRequest)
-> Maybe (Handler DocumentColorRequest)
-> Maybe (Handler ColorPresentationRequest)
-> Maybe (Handler DocumentFormattingRequest)
-> Maybe (Handler DocumentRangeFormattingRequest)
-> Maybe (Handler DocumentOnTypeFormattingRequest)
-> Maybe (Handler RenameRequest)
-> Maybe (Handler PrepareRenameRequest)
-> Maybe (Handler FoldingRangeRequest)
-> Maybe (Handler DocumentLinkRequest)
-> Maybe (Handler DocumentLinkResolveRequest)
-> Maybe (Handler ExecuteCommandRequest)
-> Maybe (Handler WillSaveWaitUntilTextDocumentRequest)
-> Maybe (Handler DidChangeConfigurationNotification)
-> Maybe (Handler DidOpenTextDocumentNotification)
-> Maybe (Handler DidChangeTextDocumentNotification)
-> Maybe (Handler DidCloseTextDocumentNotification)
-> Maybe (Handler DidSaveTextDocumentNotification)
-> Maybe (Handler DidChangeWatchedFilesNotification)
-> Maybe (Handler DidChangeWorkspaceFoldersNotification)
-> Maybe (Handler InitializedNotification)
-> Maybe (Handler WillSaveTextDocumentNotification)
-> Maybe (Handler CancelNotification)
-> Maybe (Handler BareResponseMessage)
-> Maybe (Handler InitializeRequest)
-> Maybe (Handler ExitNotification)
-> Maybe (Handler CustomClientRequest)
-> Maybe (Handler CustomClientNotification)
-> Handlers
Handlers Maybe (Handler HoverRequest)
forall a. Maybe a
Nothing Maybe (Handler CompletionRequest)
forall a. Maybe a
Nothing Maybe (Handler CompletionItemResolveRequest)
forall a. Maybe a
Nothing Maybe (Handler SignatureHelpRequest)
forall a. Maybe a
Nothing Maybe (Handler DefinitionRequest)
forall a. Maybe a
Nothing Maybe (Handler DefinitionRequest)
forall a. Maybe a
Nothing
                              Maybe (Handler DefinitionRequest)
forall a. Maybe a
Nothing Maybe (Handler ReferencesRequest)
forall a. Maybe a
Nothing Maybe (Handler DocumentHighlightRequest)
forall a. Maybe a
Nothing Maybe (Handler DocumentSymbolRequest)
forall a. Maybe a
Nothing Maybe (Handler WorkspaceSymbolRequest)
forall a. Maybe a
Nothing Maybe (Handler CodeActionRequest)
forall a. Maybe a
Nothing
                              Maybe (Handler CodeLensRequest)
forall a. Maybe a
Nothing Maybe (Handler CodeLensResolveRequest)
forall a. Maybe a
Nothing Maybe (Handler DocumentColorRequest)
forall a. Maybe a
Nothing Maybe (Handler ColorPresentationRequest)
forall a. Maybe a
Nothing Maybe (Handler DocumentFormattingRequest)
forall a. Maybe a
Nothing Maybe (Handler DocumentRangeFormattingRequest)
forall a. Maybe a
Nothing
                              Maybe (Handler DocumentOnTypeFormattingRequest)
forall a. Maybe a
Nothing Maybe (Handler RenameRequest)
forall a. Maybe a
Nothing Maybe (Handler PrepareRenameRequest)
forall a. Maybe a
Nothing Maybe (Handler FoldingRangeRequest)
forall a. Maybe a
Nothing Maybe (Handler DocumentLinkRequest)
forall a. Maybe a
Nothing Maybe (Handler DocumentLinkResolveRequest)
forall a. Maybe a
Nothing
                              Maybe (Handler ExecuteCommandRequest)
forall a. Maybe a
Nothing Maybe (Handler WillSaveWaitUntilTextDocumentRequest)
forall a. Maybe a
Nothing Maybe (Handler DidChangeConfigurationNotification)
forall a. Maybe a
Nothing Maybe (Handler DidOpenTextDocumentNotification)
forall a. Maybe a
Nothing Maybe (Handler DidChangeTextDocumentNotification)
forall a. Maybe a
Nothing Maybe (Handler DidCloseTextDocumentNotification)
forall a. Maybe a
Nothing
                              Maybe (Handler DidSaveTextDocumentNotification)
forall a. Maybe a
Nothing Maybe (Handler DidChangeWatchedFilesNotification)
forall a. Maybe a
Nothing Maybe (Handler DidChangeWorkspaceFoldersNotification)
forall a. Maybe a
Nothing Maybe (Handler InitializedNotification)
forall a. Maybe a
Nothing Maybe (Handler WillSaveTextDocumentNotification)
forall a. Maybe a
Nothing Maybe (Handler CancelNotification)
forall a. Maybe a
Nothing
                              Maybe (Handler BareResponseMessage)
forall a. Maybe a
Nothing Maybe (Handler InitializeRequest)
forall a. Maybe a
Nothing Maybe (Handler ExitNotification)
forall a. Maybe a
Nothing Maybe (Handler CustomClientRequest)
forall a. Maybe a
Nothing Maybe (Handler CustomClientNotification)
forall a. Maybe a
Nothing

-- ---------------------------------------------------------------------
nop :: Maybe (a -> b -> (a,[String]))
nop :: Maybe (a -> b -> (a, [FilePath]))
nop = Maybe (a -> b -> (a, [FilePath]))
forall a. Maybe a
Nothing


helper :: J.FromJSON a => (TVar (LanguageContextData config) -> a -> IO ()) -> (TVar (LanguageContextData config) -> J.Value -> IO ())
helper :: (TVar (LanguageContextData config) -> a -> IO ())
-> TVar (LanguageContextData config) -> Value -> IO ()
helper TVar (LanguageContextData config) -> a -> IO ()
requestHandler TVar (LanguageContextData config)
tvarDat Value
json =
  case Value -> Result a
forall a. FromJSON a => Value -> Result a
J.fromJSON Value
json of
    J.Success a
req -> TVar (LanguageContextData config) -> a -> IO ()
requestHandler TVar (LanguageContextData config)
tvarDat a
req
    J.Error FilePath
err -> do
      let msg :: Text
msg = FilePath -> Text
T.pack (FilePath -> Text)
-> ([FilePath] -> FilePath) -> [FilePath] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
unwords ([FilePath] -> Text) -> [FilePath] -> Text
forall a b. (a -> b) -> a -> b
$ [FilePath
"haskell-lsp:parse error.", Value -> FilePath
forall a. Show a => a -> FilePath
show Value
json, ShowS
forall a. Show a => a -> FilePath
show FilePath
err] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
_ERR_MSG_URL
          failLog :: IO ()
failLog = TVar (LanguageContextData config) -> Text -> IO ()
forall config. TVar (LanguageContextData config) -> Text -> IO ()
sendErrorLog TVar (LanguageContextData config)
tvarDat Text
msg
      case Value
json of
        (J.Object Object
o) -> case Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
"id" Object
o of
          Just Value
olid -> case Value -> Result LspIdRsp
forall a. FromJSON a => Value -> Result a
J.fromJSON Value
olid of
            J.Success LspIdRsp
lid -> TVar (LanguageContextData config) -> LspIdRsp -> Text -> IO ()
forall config.
TVar (LanguageContextData config) -> LspIdRsp -> Text -> IO ()
sendErrorResponse TVar (LanguageContextData config)
tvarDat LspIdRsp
lid Text
msg
            Result LspIdRsp
_ -> IO ()
failLog
          Maybe Value
_ -> IO ()
failLog
        Value
_ -> IO ()
failLog

handlerMap :: (Show config)
           => InitializeCallbacks config -> Handlers -> J.ClientMethod
           -> (TVar (LanguageContextData config) -> J.Value -> IO ())
-- General
handlerMap :: InitializeCallbacks config
-> Handlers
-> ClientMethod
-> TVar (LanguageContextData config)
-> Value
-> IO ()
handlerMap InitializeCallbacks config
i Handlers
h ClientMethod
J.Initialize                      = InitializeCallbacks config
-> Maybe (Handler InitializeRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall config.
Show config =>
InitializeCallbacks config
-> Maybe (Handler InitializeRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
handleInitialConfig InitializeCallbacks config
i (Handlers -> Maybe (Handler InitializeRequest)
initializeRequestHandler Handlers
h)
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.Initialized                     = Maybe (VFS -> InitializedNotification -> (VFS, [FilePath]))
-> (InitializedNotification -> FromClientMessage)
-> Maybe (Handler InitializedNotification)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> InitializedNotification -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop InitializedNotification -> FromClientMessage
NotInitialized (Maybe (Handler InitializedNotification)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler InitializedNotification)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler InitializedNotification)
initializedHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
_ ClientMethod
J.Shutdown                        = (TVar (LanguageContextData config) -> ShutdownRequest -> IO ())
-> TVar (LanguageContextData config) -> Value -> IO ()
forall a config.
FromJSON a =>
(TVar (LanguageContextData config) -> a -> IO ())
-> TVar (LanguageContextData config) -> Value -> IO ()
helper TVar (LanguageContextData config) -> ShutdownRequest -> IO ()
forall config.
TVar (LanguageContextData config) -> ShutdownRequest -> IO ()
shutdownRequestHandler
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.Exit                            =
  case Handlers -> Maybe (Handler ExitNotification)
exitNotificationHandler Handlers
h of
    Just Handler ExitNotification
_ -> Maybe (VFS -> ExitNotification -> (VFS, [FilePath]))
-> (ExitNotification -> FromClientMessage)
-> Maybe (Handler ExitNotification)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> ExitNotification -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop ExitNotification -> FromClientMessage
NotExit (Maybe (Handler ExitNotification)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler ExitNotification)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler ExitNotification)
exitNotificationHandler Handlers
h
    Maybe (Handler ExitNotification)
Nothing -> \TVar (LanguageContextData config)
ctxVar Value
v -> do
      LanguageContextData config
ctx <- TVar (LanguageContextData config)
-> IO (LanguageContextData config)
forall a. TVar a -> IO a
readTVarIO TVar (LanguageContextData config)
ctxVar
      -- Capture exit notification
      case Value -> Result ExitNotification
forall a. FromJSON a => Value -> Result a
J.fromJSON Value
v :: J.Result J.ExitNotification of
        J.Success ExitNotification
n -> FromClientMessage -> CaptureContext -> IO ()
captureFromClient (ExitNotification -> FromClientMessage
NotExit ExitNotification
n) (LanguageContextData config -> CaptureContext
forall config. LanguageContextData config -> CaptureContext
resCaptureContext LanguageContextData config
ctx)
        J.Error FilePath
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      ByteString -> IO ()
logm (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
B.pack FilePath
"haskell-lsp:Got exit, exiting"
      IO ()
forall a. IO a
exitSuccess
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.CancelRequest                   = Maybe (VFS -> CancelNotification -> (VFS, [FilePath]))
-> (CancelNotification -> FromClientMessage)
-> Maybe (Handler CancelNotification)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> CancelNotification -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop CancelNotification -> FromClientMessage
NotCancelRequestFromClient (Maybe (Handler CancelNotification)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler CancelNotification)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler CancelNotification)
cancelNotificationHandler Handlers
h
-- Workspace
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.WorkspaceDidChangeWorkspaceFolders = Maybe (Handler DidChangeWorkspaceFoldersNotification)
-> TVar (LanguageContextData config) -> Value -> IO ()
forall config.
Maybe (Handler DidChangeWorkspaceFoldersNotification)
-> TVar (LanguageContextData config) -> Value -> IO ()
hwf (Maybe (Handler DidChangeWorkspaceFoldersNotification)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler DidChangeWorkspaceFoldersNotification)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler DidChangeWorkspaceFoldersNotification)
didChangeWorkspaceFoldersNotificationHandler Handlers
h
handlerMap InitializeCallbacks config
i Handlers
h ClientMethod
J.WorkspaceDidChangeConfiguration = InitializeCallbacks config
-> Maybe (Handler DidChangeConfigurationNotification)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall config.
Show config =>
InitializeCallbacks config
-> Maybe (Handler DidChangeConfigurationNotification)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hc InitializeCallbacks config
i (Maybe (Handler DidChangeConfigurationNotification)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler DidChangeConfigurationNotification)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler DidChangeConfigurationNotification)
didChangeConfigurationParamsHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.WorkspaceDidChangeWatchedFiles  = Maybe
  (VFS -> DidChangeWatchedFilesNotification -> (VFS, [FilePath]))
-> (DidChangeWatchedFilesNotification -> FromClientMessage)
-> Maybe (Handler DidChangeWatchedFilesNotification)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe
  (VFS -> DidChangeWatchedFilesNotification -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop DidChangeWatchedFilesNotification -> FromClientMessage
NotDidChangeWatchedFiles (Maybe (Handler DidChangeWatchedFilesNotification)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler DidChangeWatchedFilesNotification)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler DidChangeWatchedFilesNotification)
didChangeWatchedFilesNotificationHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.WorkspaceSymbol                 = Maybe (VFS -> WorkspaceSymbolRequest -> (VFS, [FilePath]))
-> (WorkspaceSymbolRequest -> FromClientMessage)
-> Maybe (Handler WorkspaceSymbolRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> WorkspaceSymbolRequest -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop WorkspaceSymbolRequest -> FromClientMessage
ReqWorkspaceSymbols (Maybe (Handler WorkspaceSymbolRequest)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler WorkspaceSymbolRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler WorkspaceSymbolRequest)
workspaceSymbolHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.WorkspaceExecuteCommand         = Maybe (VFS -> ExecuteCommandRequest -> (VFS, [FilePath]))
-> (ExecuteCommandRequest -> FromClientMessage)
-> Maybe (Handler ExecuteCommandRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> ExecuteCommandRequest -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop ExecuteCommandRequest -> FromClientMessage
ReqExecuteCommand (Maybe (Handler ExecuteCommandRequest)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler ExecuteCommandRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler ExecuteCommandRequest)
executeCommandHandler Handlers
h
-- Document
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.TextDocumentDidOpen             = Maybe (VFS -> DidOpenTextDocumentNotification -> (VFS, [FilePath]))
-> (DidOpenTextDocumentNotification -> FromClientMessage)
-> Maybe (Handler DidOpenTextDocumentNotification)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh ((VFS -> DidOpenTextDocumentNotification -> (VFS, [FilePath]))
-> Maybe
     (VFS -> DidOpenTextDocumentNotification -> (VFS, [FilePath]))
forall a. a -> Maybe a
Just VFS -> DidOpenTextDocumentNotification -> (VFS, [FilePath])
openVFS) DidOpenTextDocumentNotification -> FromClientMessage
NotDidOpenTextDocument (Maybe (Handler DidOpenTextDocumentNotification)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler DidOpenTextDocumentNotification)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler DidOpenTextDocumentNotification)
didOpenTextDocumentNotificationHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.TextDocumentDidChange           = Maybe
  (VFS -> DidChangeTextDocumentNotification -> (VFS, [FilePath]))
-> (DidChangeTextDocumentNotification -> FromClientMessage)
-> Maybe (Handler DidChangeTextDocumentNotification)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh ((VFS -> DidChangeTextDocumentNotification -> (VFS, [FilePath]))
-> Maybe
     (VFS -> DidChangeTextDocumentNotification -> (VFS, [FilePath]))
forall a. a -> Maybe a
Just VFS -> DidChangeTextDocumentNotification -> (VFS, [FilePath])
changeFromClientVFS) DidChangeTextDocumentNotification -> FromClientMessage
NotDidChangeTextDocument (Maybe (Handler DidChangeTextDocumentNotification)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler DidChangeTextDocumentNotification)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler DidChangeTextDocumentNotification)
didChangeTextDocumentNotificationHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.TextDocumentWillSave            = Maybe
  (VFS -> WillSaveTextDocumentNotification -> (VFS, [FilePath]))
-> (WillSaveTextDocumentNotification -> FromClientMessage)
-> Maybe (Handler WillSaveTextDocumentNotification)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe
  (VFS -> WillSaveTextDocumentNotification -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop WillSaveTextDocumentNotification -> FromClientMessage
NotWillSaveTextDocument (Maybe (Handler WillSaveTextDocumentNotification)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler WillSaveTextDocumentNotification)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler WillSaveTextDocumentNotification)
willSaveTextDocumentNotificationHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.TextDocumentWillSaveWaitUntil   = Maybe
  (VFS -> WillSaveWaitUntilTextDocumentRequest -> (VFS, [FilePath]))
-> (WillSaveWaitUntilTextDocumentRequest -> FromClientMessage)
-> Maybe (Handler WillSaveWaitUntilTextDocumentRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe
  (VFS -> WillSaveWaitUntilTextDocumentRequest -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop WillSaveWaitUntilTextDocumentRequest -> FromClientMessage
ReqWillSaveWaitUntil (Maybe (Handler WillSaveWaitUntilTextDocumentRequest)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler WillSaveWaitUntilTextDocumentRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler WillSaveWaitUntilTextDocumentRequest)
willSaveWaitUntilTextDocHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.TextDocumentDidSave             = Maybe (VFS -> DidSaveTextDocumentNotification -> (VFS, [FilePath]))
-> (DidSaveTextDocumentNotification -> FromClientMessage)
-> Maybe (Handler DidSaveTextDocumentNotification)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> DidSaveTextDocumentNotification -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop DidSaveTextDocumentNotification -> FromClientMessage
NotDidSaveTextDocument (Maybe (Handler DidSaveTextDocumentNotification)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler DidSaveTextDocumentNotification)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler DidSaveTextDocumentNotification)
didSaveTextDocumentNotificationHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.TextDocumentDidClose            = Maybe
  (VFS -> DidCloseTextDocumentNotification -> (VFS, [FilePath]))
-> (DidCloseTextDocumentNotification -> FromClientMessage)
-> Maybe (Handler DidCloseTextDocumentNotification)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh ((VFS -> DidCloseTextDocumentNotification -> (VFS, [FilePath]))
-> Maybe
     (VFS -> DidCloseTextDocumentNotification -> (VFS, [FilePath]))
forall a. a -> Maybe a
Just VFS -> DidCloseTextDocumentNotification -> (VFS, [FilePath])
closeVFS) DidCloseTextDocumentNotification -> FromClientMessage
NotDidCloseTextDocument (Maybe (Handler DidCloseTextDocumentNotification)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler DidCloseTextDocumentNotification)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler DidCloseTextDocumentNotification)
didCloseTextDocumentNotificationHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.TextDocumentCompletion          = Maybe (VFS -> CompletionRequest -> (VFS, [FilePath]))
-> (CompletionRequest -> FromClientMessage)
-> Maybe (Handler CompletionRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> CompletionRequest -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop CompletionRequest -> FromClientMessage
ReqCompletion (Maybe (Handler CompletionRequest)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler CompletionRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler CompletionRequest)
completionHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.CompletionItemResolve           = Maybe (VFS -> CompletionItemResolveRequest -> (VFS, [FilePath]))
-> (CompletionItemResolveRequest -> FromClientMessage)
-> Maybe (Handler CompletionItemResolveRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> CompletionItemResolveRequest -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop CompletionItemResolveRequest -> FromClientMessage
ReqCompletionItemResolve (Maybe (Handler CompletionItemResolveRequest)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler CompletionItemResolveRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler CompletionItemResolveRequest)
completionResolveHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.TextDocumentHover               = Maybe (VFS -> HoverRequest -> (VFS, [FilePath]))
-> (HoverRequest -> FromClientMessage)
-> Maybe (Handler HoverRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> HoverRequest -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop HoverRequest -> FromClientMessage
ReqHover (Maybe (Handler HoverRequest)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler HoverRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler HoverRequest)
hoverHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.TextDocumentSignatureHelp       = Maybe (VFS -> SignatureHelpRequest -> (VFS, [FilePath]))
-> (SignatureHelpRequest -> FromClientMessage)
-> Maybe (Handler SignatureHelpRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> SignatureHelpRequest -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop SignatureHelpRequest -> FromClientMessage
ReqSignatureHelp (Maybe (Handler SignatureHelpRequest)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler SignatureHelpRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler SignatureHelpRequest)
signatureHelpHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.TextDocumentDefinition          = Maybe (VFS -> DefinitionRequest -> (VFS, [FilePath]))
-> (DefinitionRequest -> FromClientMessage)
-> Maybe (Handler DefinitionRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> DefinitionRequest -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop DefinitionRequest -> FromClientMessage
ReqDefinition (Maybe (Handler DefinitionRequest)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler DefinitionRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler DefinitionRequest)
definitionHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.TextDocumentTypeDefinition      = Maybe (VFS -> DefinitionRequest -> (VFS, [FilePath]))
-> (DefinitionRequest -> FromClientMessage)
-> Maybe (Handler DefinitionRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> DefinitionRequest -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop DefinitionRequest -> FromClientMessage
ReqTypeDefinition (Maybe (Handler DefinitionRequest)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler DefinitionRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler DefinitionRequest)
typeDefinitionHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.TextDocumentImplementation      = Maybe (VFS -> DefinitionRequest -> (VFS, [FilePath]))
-> (DefinitionRequest -> FromClientMessage)
-> Maybe (Handler DefinitionRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> DefinitionRequest -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop DefinitionRequest -> FromClientMessage
ReqImplementation (Maybe (Handler DefinitionRequest)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler DefinitionRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler DefinitionRequest)
implementationHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.TextDocumentReferences          = Maybe (VFS -> ReferencesRequest -> (VFS, [FilePath]))
-> (ReferencesRequest -> FromClientMessage)
-> Maybe (Handler ReferencesRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> ReferencesRequest -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop ReferencesRequest -> FromClientMessage
ReqFindReferences (Maybe (Handler ReferencesRequest)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler ReferencesRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler ReferencesRequest)
referencesHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.TextDocumentDocumentHighlight   = Maybe (VFS -> DocumentHighlightRequest -> (VFS, [FilePath]))
-> (DocumentHighlightRequest -> FromClientMessage)
-> Maybe (Handler DocumentHighlightRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> DocumentHighlightRequest -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop DocumentHighlightRequest -> FromClientMessage
ReqDocumentHighlights (Maybe (Handler DocumentHighlightRequest)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler DocumentHighlightRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler DocumentHighlightRequest)
documentHighlightHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.TextDocumentDocumentSymbol      = Maybe (VFS -> DocumentSymbolRequest -> (VFS, [FilePath]))
-> (DocumentSymbolRequest -> FromClientMessage)
-> Maybe (Handler DocumentSymbolRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> DocumentSymbolRequest -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop DocumentSymbolRequest -> FromClientMessage
ReqDocumentSymbols (Maybe (Handler DocumentSymbolRequest)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler DocumentSymbolRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler DocumentSymbolRequest)
documentSymbolHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.TextDocumentFormatting          = Maybe (VFS -> DocumentFormattingRequest -> (VFS, [FilePath]))
-> (DocumentFormattingRequest -> FromClientMessage)
-> Maybe (Handler DocumentFormattingRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> DocumentFormattingRequest -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop DocumentFormattingRequest -> FromClientMessage
ReqDocumentFormatting (Maybe (Handler DocumentFormattingRequest)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler DocumentFormattingRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler DocumentFormattingRequest)
documentFormattingHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.TextDocumentRangeFormatting     = Maybe (VFS -> DocumentRangeFormattingRequest -> (VFS, [FilePath]))
-> (DocumentRangeFormattingRequest -> FromClientMessage)
-> Maybe (Handler DocumentRangeFormattingRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> DocumentRangeFormattingRequest -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop DocumentRangeFormattingRequest -> FromClientMessage
ReqDocumentRangeFormatting (Maybe (Handler DocumentRangeFormattingRequest)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler DocumentRangeFormattingRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler DocumentRangeFormattingRequest)
documentRangeFormattingHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.TextDocumentOnTypeFormatting    = Maybe (VFS -> DocumentOnTypeFormattingRequest -> (VFS, [FilePath]))
-> (DocumentOnTypeFormattingRequest -> FromClientMessage)
-> Maybe (Handler DocumentOnTypeFormattingRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> DocumentOnTypeFormattingRequest -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop DocumentOnTypeFormattingRequest -> FromClientMessage
ReqDocumentOnTypeFormatting (Maybe (Handler DocumentOnTypeFormattingRequest)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler DocumentOnTypeFormattingRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler DocumentOnTypeFormattingRequest)
documentOnTypeFormattingHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.TextDocumentCodeAction          = Maybe (VFS -> CodeActionRequest -> (VFS, [FilePath]))
-> (CodeActionRequest -> FromClientMessage)
-> Maybe (Handler CodeActionRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> CodeActionRequest -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop CodeActionRequest -> FromClientMessage
ReqCodeAction (Maybe (Handler CodeActionRequest)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler CodeActionRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler CodeActionRequest)
codeActionHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.TextDocumentCodeLens            = Maybe (VFS -> CodeLensRequest -> (VFS, [FilePath]))
-> (CodeLensRequest -> FromClientMessage)
-> Maybe (Handler CodeLensRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> CodeLensRequest -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop CodeLensRequest -> FromClientMessage
ReqCodeLens (Maybe (Handler CodeLensRequest)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler CodeLensRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler CodeLensRequest)
codeLensHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.CodeLensResolve                 = Maybe (VFS -> CodeLensResolveRequest -> (VFS, [FilePath]))
-> (CodeLensResolveRequest -> FromClientMessage)
-> Maybe (Handler CodeLensResolveRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> CodeLensResolveRequest -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop CodeLensResolveRequest -> FromClientMessage
ReqCodeLensResolve (Maybe (Handler CodeLensResolveRequest)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler CodeLensResolveRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler CodeLensResolveRequest)
codeLensResolveHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.TextDocumentDocumentColor       = Maybe (VFS -> DocumentColorRequest -> (VFS, [FilePath]))
-> (DocumentColorRequest -> FromClientMessage)
-> Maybe (Handler DocumentColorRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> DocumentColorRequest -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop DocumentColorRequest -> FromClientMessage
ReqDocumentColor (Maybe (Handler DocumentColorRequest)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler DocumentColorRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler DocumentColorRequest)
documentColorHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.TextDocumentColorPresentation   = Maybe (VFS -> ColorPresentationRequest -> (VFS, [FilePath]))
-> (ColorPresentationRequest -> FromClientMessage)
-> Maybe (Handler ColorPresentationRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> ColorPresentationRequest -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop ColorPresentationRequest -> FromClientMessage
ReqColorPresentation (Maybe (Handler ColorPresentationRequest)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler ColorPresentationRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler ColorPresentationRequest)
colorPresentationHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.TextDocumentDocumentLink        = Maybe (VFS -> DocumentLinkRequest -> (VFS, [FilePath]))
-> (DocumentLinkRequest -> FromClientMessage)
-> Maybe (Handler DocumentLinkRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> DocumentLinkRequest -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop DocumentLinkRequest -> FromClientMessage
ReqDocumentLink (Maybe (Handler DocumentLinkRequest)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler DocumentLinkRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler DocumentLinkRequest)
documentLinkHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.DocumentLinkResolve             = Maybe (VFS -> DocumentLinkResolveRequest -> (VFS, [FilePath]))
-> (DocumentLinkResolveRequest -> FromClientMessage)
-> Maybe (Handler DocumentLinkResolveRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> DocumentLinkResolveRequest -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop DocumentLinkResolveRequest -> FromClientMessage
ReqDocumentLinkResolve (Maybe (Handler DocumentLinkResolveRequest)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler DocumentLinkResolveRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler DocumentLinkResolveRequest)
documentLinkResolveHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.TextDocumentRename              = Maybe (VFS -> RenameRequest -> (VFS, [FilePath]))
-> (RenameRequest -> FromClientMessage)
-> Maybe (Handler RenameRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> RenameRequest -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop RenameRequest -> FromClientMessage
ReqRename (Maybe (Handler RenameRequest)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler RenameRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler RenameRequest)
renameHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.TextDocumentPrepareRename       = Maybe (VFS -> PrepareRenameRequest -> (VFS, [FilePath]))
-> (PrepareRenameRequest -> FromClientMessage)
-> Maybe (Handler PrepareRenameRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> PrepareRenameRequest -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop PrepareRenameRequest -> FromClientMessage
ReqPrepareRename (Maybe (Handler PrepareRenameRequest)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler PrepareRenameRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler PrepareRenameRequest)
prepareRenameHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
h ClientMethod
J.TextDocumentFoldingRange        = Maybe (VFS -> FoldingRangeRequest -> (VFS, [FilePath]))
-> (FoldingRangeRequest -> FromClientMessage)
-> Maybe (Handler FoldingRangeRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> FoldingRangeRequest -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop FoldingRangeRequest -> FromClientMessage
ReqFoldingRange (Maybe (Handler FoldingRangeRequest)
 -> TVar (LanguageContextData config) -> Value -> IO ())
-> Maybe (Handler FoldingRangeRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler FoldingRangeRequest)
foldingRangeHandler Handlers
h
handlerMap InitializeCallbacks config
_ Handlers
_ ClientMethod
J.WorkDoneProgressCancel          = (TVar (LanguageContextData config)
 -> WorkDoneProgressCancelNotification -> IO ())
-> TVar (LanguageContextData config) -> Value -> IO ()
forall a config.
FromJSON a =>
(TVar (LanguageContextData config) -> a -> IO ())
-> TVar (LanguageContextData config) -> Value -> IO ()
helper TVar (LanguageContextData config)
-> WorkDoneProgressCancelNotification -> IO ()
forall config.
TVar (LanguageContextData config)
-> WorkDoneProgressCancelNotification -> IO ()
progressCancelHandler
handlerMap InitializeCallbacks config
_ Handlers
h (J.CustomClientMethod Text
_)          = \TVar (LanguageContextData config)
ctxData Value
val ->
    case Value
val of
        J.Object Object
o | Text
"id" Text -> Object -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
`HM.member` Object
o ->
            -- Custom request
            Maybe (VFS -> CustomClientRequest -> (VFS, [FilePath]))
-> (CustomClientRequest -> FromClientMessage)
-> Maybe (Handler CustomClientRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> CustomClientRequest -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop CustomClientRequest -> FromClientMessage
ReqCustomClient (Handlers -> Maybe (Handler CustomClientRequest)
customRequestHandler Handlers
h) TVar (LanguageContextData config)
ctxData Value
val
        Value
_ -> -- Custom notification
            Maybe (VFS -> CustomClientNotification -> (VFS, [FilePath]))
-> (CustomClientNotification -> FromClientMessage)
-> Maybe (Handler CustomClientNotification)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> CustomClientNotification -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop CustomClientNotification -> FromClientMessage
NotCustomClient (Handlers -> Maybe (Handler CustomClientNotification)
customNotificationHandler Handlers
h) TVar (LanguageContextData config)
ctxData Value
val

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

-- | Adapter from the normal handlers exposed to the library users and the
-- internal message loop
hh :: forall b config. (J.FromJSON b)
   => Maybe (VFS -> b -> (VFS, [String])) -> (b -> FromClientMessage) -> Maybe (Handler b)
   -> TVar (LanguageContextData config) -> J.Value -> IO ()
hh :: Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe (VFS -> b -> (VFS, [FilePath]))
mVfs b -> FromClientMessage
wrapper Maybe (Handler b)
mh TVar (LanguageContextData config)
tvarDat Value
json = do
      case Value -> Result b
forall a. FromJSON a => Value -> Result a
J.fromJSON Value
json of
        J.Success b
req -> do
          case Maybe (VFS -> b -> (VFS, [FilePath]))
mVfs of
            Just VFS -> b -> (VFS, [FilePath])
modifyVfs -> do
              IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ TVar (LanguageContextData config)
-> (VFSData -> (VFSData, IO ())) -> STM (IO ())
forall config a.
TVar (LanguageContextData config)
-> (VFSData -> (VFSData, a)) -> STM a
modifyVFSData TVar (LanguageContextData config)
tvarDat ((VFSData -> (VFSData, IO ())) -> STM (IO ()))
-> (VFSData -> (VFSData, IO ())) -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ \(VFSData VFS
vfs Map FilePath FilePath
rm) ->
                let (VFS
vfs', [FilePath]
ls) = VFS -> b -> (VFS, [FilePath])
modifyVfs VFS
vfs b
req
                in (VFS -> Map FilePath FilePath -> VFSData
VFSData VFS
vfs' Map FilePath FilePath
rm, (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
logs [FilePath]
ls)
            Maybe (VFS -> b -> (VFS, [FilePath]))
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

          LanguageContextData config
ctx <- TVar (LanguageContextData config)
-> IO (LanguageContextData config)
forall a. TVar a -> IO a
readTVarIO TVar (LanguageContextData config)
tvarDat
          let req' :: FromClientMessage
req' = b -> FromClientMessage
wrapper b
req
          FromClientMessage -> CaptureContext -> IO ()
captureFromClient FromClientMessage
req' (LanguageContextData config -> CaptureContext
forall config. LanguageContextData config -> CaptureContext
resCaptureContext LanguageContextData config
ctx)

          case Maybe (Handler b)
mh of
            Just Handler b
h -> Handler b
h b
req
            Maybe (Handler b)
Nothing
              -- '$/' notifications should/could be ignored by server.
              -- Don't log errors in that case.
              -- See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#-notifications-and-requests.
              | FromClientMessage -> Bool
isOptionalNotification FromClientMessage
req' -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              | Bool
otherwise -> do
                  let msg :: Text
msg = FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords [FilePath
"haskell-lsp:no handler for.", Value -> FilePath
forall a. Show a => a -> FilePath
show Value
json]
                  TVar (LanguageContextData config) -> Text -> IO ()
forall config. TVar (LanguageContextData config) -> Text -> IO ()
sendErrorLog TVar (LanguageContextData config)
tvarDat Text
msg
        J.Error  FilePath
err -> do
          let msg :: Text
msg = FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ [FilePath
"haskell-lsp:parse error.", Value -> FilePath
forall a. Show a => a -> FilePath
show Value
json, ShowS
forall a. Show a => a -> FilePath
show FilePath
err] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
_ERR_MSG_URL
          TVar (LanguageContextData config) -> Text -> IO ()
forall config. TVar (LanguageContextData config) -> Text -> IO ()
sendErrorLog TVar (LanguageContextData config)
tvarDat Text
msg
  where
    isOptionalNotification :: FromClientMessage -> Bool
isOptionalNotification FromClientMessage
req
      | NotCustomClient CustomClientNotification
_ <- FromClientMessage
req
      , J.Object Object
object <- Value
json
      , Just (J.String Text
method) <- Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
"method" Object
object
      , Text
"$/" Text -> Text -> Bool
`T.isPrefixOf` Text
method
      = Bool
True
      | Bool
otherwise = Bool
False

handleInitialConfig
  :: (Show config)
  => InitializeCallbacks config
  -> Maybe (Handler J.InitializeRequest)
  -> TVar (LanguageContextData config)
  -> J.Value
  -> IO ()
handleInitialConfig :: InitializeCallbacks config
-> Maybe (Handler InitializeRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
handleInitialConfig (InitializeCallbacks { InitializeRequest -> Either Text config
onInitialConfiguration :: InitializeRequest -> Either Text config
onInitialConfiguration :: forall config.
InitializeCallbacks config
-> InitializeRequest -> Either Text config
onInitialConfiguration, LspFuncs config -> IO (Maybe ResponseError)
onStartup :: LspFuncs config -> IO (Maybe ResponseError)
onStartup :: forall config.
InitializeCallbacks config
-> LspFuncs config -> IO (Maybe ResponseError)
onStartup }) Maybe (Handler InitializeRequest)
mh TVar (LanguageContextData config)
tvarDat Value
json
  = (InitializeRequest -> FromClientMessage)
-> (InitializeRequest -> Either Text config)
-> Maybe (Handler InitializeRequest)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall reqParams err config.
(FromJSON reqParams, Show reqParams, Show err) =>
(reqParams -> FromClientMessage)
-> (reqParams -> Either err config)
-> Maybe (reqParams -> IO ())
-> TVar (LanguageContextData config)
-> Value
-> IO ()
handleMessageWithConfigChange InitializeRequest -> FromClientMessage
ReqInitialize
                                  InitializeRequest -> Either Text config
onInitialConfiguration
                                  (Handler InitializeRequest -> Maybe (Handler InitializeRequest)
forall a. a -> Maybe a
Just (Handler InitializeRequest -> Maybe (Handler InitializeRequest))
-> Handler InitializeRequest -> Maybe (Handler InitializeRequest)
forall a b. (a -> b) -> a -> b
$ (LspFuncs config -> IO (Maybe ResponseError))
-> Maybe (Handler InitializeRequest)
-> TVar (LanguageContextData config)
-> Handler InitializeRequest
forall config.
Show config =>
(LspFuncs config -> IO (Maybe ResponseError))
-> Maybe (Handler InitializeRequest)
-> TVar (LanguageContextData config)
-> Handler InitializeRequest
initializeRequestHandler' LspFuncs config -> IO (Maybe ResponseError)
onStartup Maybe (Handler InitializeRequest)
mh TVar (LanguageContextData config)
tvarDat)
                                  TVar (LanguageContextData config)
tvarDat
                                  Value
json


hc
  :: (Show config)
  => InitializeCallbacks config
  -> Maybe (Handler J.DidChangeConfigurationNotification)
  -> TVar (LanguageContextData config)
  -> J.Value
  -> IO ()
hc :: InitializeCallbacks config
-> Maybe (Handler DidChangeConfigurationNotification)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hc (InitializeCallbacks { DidChangeConfigurationNotification -> Either Text config
onConfigurationChange :: DidChangeConfigurationNotification -> Either Text config
onConfigurationChange :: forall config.
InitializeCallbacks config
-> DidChangeConfigurationNotification -> Either Text config
onConfigurationChange }) Maybe (Handler DidChangeConfigurationNotification)
mh TVar (LanguageContextData config)
tvarDat Value
json =
  (DidChangeConfigurationNotification -> FromClientMessage)
-> (DidChangeConfigurationNotification -> Either Text config)
-> Maybe (Handler DidChangeConfigurationNotification)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall reqParams err config.
(FromJSON reqParams, Show reqParams, Show err) =>
(reqParams -> FromClientMessage)
-> (reqParams -> Either err config)
-> Maybe (reqParams -> IO ())
-> TVar (LanguageContextData config)
-> Value
-> IO ()
handleMessageWithConfigChange DidChangeConfigurationNotification -> FromClientMessage
NotDidChangeConfiguration
                                DidChangeConfigurationNotification -> Either Text config
onConfigurationChange
                                Maybe (Handler DidChangeConfigurationNotification)
mh
                                TVar (LanguageContextData config)
tvarDat
                                Value
json

handleMessageWithConfigChange
  :: (J.FromJSON reqParams, Show reqParams, Show err)
  => (reqParams -> FromClientMessage) -- ^ The notification message from the client to expect
  -> (reqParams -> Either err config) -- ^ A function to parse the config out of the request
  -> Maybe (reqParams -> IO ()) -- ^ The upstream handler for the client request
  -> TVar (LanguageContextData config) -- ^ The context data containing the current configuration
  -> J.Value -- ^ The raw reqeust data
  -> IO ()
handleMessageWithConfigChange :: (reqParams -> FromClientMessage)
-> (reqParams -> Either err config)
-> Maybe (reqParams -> IO ())
-> TVar (LanguageContextData config)
-> Value
-> IO ()
handleMessageWithConfigChange reqParams -> FromClientMessage
notification reqParams -> Either err config
parseConfig Maybe (reqParams -> IO ())
mh TVar (LanguageContextData config)
tvarDat Value
json =
  -- logs $ "haskell-lsp:hc DidChangeConfigurationNotification entered"
  case Value -> Result reqParams
forall a. FromJSON a => Value -> Result a
J.fromJSON Value
json of
    J.Success reqParams
req -> do
      LanguageContextData config
ctx <- TVar (LanguageContextData config)
-> IO (LanguageContextData config)
forall a. TVar a -> IO a
readTVarIO TVar (LanguageContextData config)
tvarDat

      FromClientMessage -> CaptureContext -> IO ()
captureFromClient (reqParams -> FromClientMessage
notification reqParams
req) (LanguageContextData config -> CaptureContext
forall config. LanguageContextData config -> CaptureContext
resCaptureContext LanguageContextData config
ctx)

      case reqParams -> Either err config
parseConfig reqParams
req of
        Left err
err -> do
          let
            msg :: Text
msg =
              FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords
                [FilePath
"haskell-lsp:configuration parse error.", reqParams -> FilePath
forall a. Show a => a -> FilePath
show reqParams
req, err -> FilePath
forall a. Show a => a -> FilePath
show err
err]
          TVar (LanguageContextData config) -> Text -> IO ()
forall config. TVar (LanguageContextData config) -> Text -> IO ()
sendErrorLog TVar (LanguageContextData config)
tvarDat Text
msg
        Right config
newConfig ->
          STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (LanguageContextData config)
-> (LanguageContextData config -> LanguageContextData config)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (LanguageContextData config)
tvarDat (\LanguageContextData config
ctx' -> LanguageContextData config
ctx' { resConfig :: Maybe config
resConfig = config -> Maybe config
forall a. a -> Maybe a
Just config
newConfig })
      case Maybe (reqParams -> IO ())
mh of
        Just reqParams -> IO ()
h  -> reqParams -> IO ()
h reqParams
req
        Maybe (reqParams -> IO ())
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    J.Error FilePath
err -> do
      let msg :: Text
msg =
            FilePath -> Text
T.pack
              (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$  [FilePath] -> FilePath
unwords
              ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$  [FilePath
"haskell-lsp:parse error.", Value -> FilePath
forall a. Show a => a -> FilePath
show Value
json, ShowS
forall a. Show a => a -> FilePath
show FilePath
err]
              [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
_ERR_MSG_URL
      TVar (LanguageContextData config) -> Text -> IO ()
forall config. TVar (LanguageContextData config) -> Text -> IO ()
sendErrorLog TVar (LanguageContextData config)
tvarDat Text
msg

-- | Updates the list of workspace folders and then delegates back to 'hh'
hwf :: Maybe (Handler J.DidChangeWorkspaceFoldersNotification) -> TVar (LanguageContextData config) -> J.Value -> IO ()
hwf :: Maybe (Handler DidChangeWorkspaceFoldersNotification)
-> TVar (LanguageContextData config) -> Value -> IO ()
hwf Maybe (Handler DidChangeWorkspaceFoldersNotification)
h TVar (LanguageContextData config)
tvarDat Value
json = do
  case Value -> Result DidChangeWorkspaceFoldersNotification
forall a. FromJSON a => Value -> Result a
J.fromJSON Value
json :: J.Result J.DidChangeWorkspaceFoldersNotification of
    J.Success (J.NotificationMessage Text
_ ClientMethod
_ DidChangeWorkspaceFoldersParams
params) -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do

      [WorkspaceFolder]
oldWfs <- LanguageContextData config -> [WorkspaceFolder]
forall config. LanguageContextData config -> [WorkspaceFolder]
resWorkspaceFolders (LanguageContextData config -> [WorkspaceFolder])
-> STM (LanguageContextData config) -> STM [WorkspaceFolder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (LanguageContextData config)
-> STM (LanguageContextData config)
forall a. TVar a -> STM a
readTVar TVar (LanguageContextData config)
tvarDat
      let J.List [WorkspaceFolder]
toRemove = DidChangeWorkspaceFoldersParams
params DidChangeWorkspaceFoldersParams
-> Getting
     (List WorkspaceFolder)
     DidChangeWorkspaceFoldersParams
     (List WorkspaceFolder)
-> List WorkspaceFolder
forall s a. s -> Getting a s a -> a
^. (WorkspaceFoldersChangeEvent
 -> Const (List WorkspaceFolder) WorkspaceFoldersChangeEvent)
-> DidChangeWorkspaceFoldersParams
-> Const (List WorkspaceFolder) DidChangeWorkspaceFoldersParams
forall s a. HasEvent s a => Lens' s a
J.event ((WorkspaceFoldersChangeEvent
  -> Const (List WorkspaceFolder) WorkspaceFoldersChangeEvent)
 -> DidChangeWorkspaceFoldersParams
 -> Const (List WorkspaceFolder) DidChangeWorkspaceFoldersParams)
-> ((List WorkspaceFolder
     -> Const (List WorkspaceFolder) (List WorkspaceFolder))
    -> WorkspaceFoldersChangeEvent
    -> Const (List WorkspaceFolder) WorkspaceFoldersChangeEvent)
-> Getting
     (List WorkspaceFolder)
     DidChangeWorkspaceFoldersParams
     (List WorkspaceFolder)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (List WorkspaceFolder
 -> Const (List WorkspaceFolder) (List WorkspaceFolder))
-> WorkspaceFoldersChangeEvent
-> Const (List WorkspaceFolder) WorkspaceFoldersChangeEvent
forall s a. HasRemoved s a => Lens' s a
J.removed
          wfs0 :: [WorkspaceFolder]
wfs0 = (WorkspaceFolder -> [WorkspaceFolder] -> [WorkspaceFolder])
-> [WorkspaceFolder] -> [WorkspaceFolder] -> [WorkspaceFolder]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr WorkspaceFolder -> [WorkspaceFolder] -> [WorkspaceFolder]
forall a. Eq a => a -> [a] -> [a]
L.delete [WorkspaceFolder]
oldWfs [WorkspaceFolder]
toRemove
          J.List [WorkspaceFolder]
toAdd = DidChangeWorkspaceFoldersParams
params DidChangeWorkspaceFoldersParams
-> Getting
     (List WorkspaceFolder)
     DidChangeWorkspaceFoldersParams
     (List WorkspaceFolder)
-> List WorkspaceFolder
forall s a. s -> Getting a s a -> a
^. (WorkspaceFoldersChangeEvent
 -> Const (List WorkspaceFolder) WorkspaceFoldersChangeEvent)
-> DidChangeWorkspaceFoldersParams
-> Const (List WorkspaceFolder) DidChangeWorkspaceFoldersParams
forall s a. HasEvent s a => Lens' s a
J.event ((WorkspaceFoldersChangeEvent
  -> Const (List WorkspaceFolder) WorkspaceFoldersChangeEvent)
 -> DidChangeWorkspaceFoldersParams
 -> Const (List WorkspaceFolder) DidChangeWorkspaceFoldersParams)
-> ((List WorkspaceFolder
     -> Const (List WorkspaceFolder) (List WorkspaceFolder))
    -> WorkspaceFoldersChangeEvent
    -> Const (List WorkspaceFolder) WorkspaceFoldersChangeEvent)
-> Getting
     (List WorkspaceFolder)
     DidChangeWorkspaceFoldersParams
     (List WorkspaceFolder)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (List WorkspaceFolder
 -> Const (List WorkspaceFolder) (List WorkspaceFolder))
-> WorkspaceFoldersChangeEvent
-> Const (List WorkspaceFolder) WorkspaceFoldersChangeEvent
forall s a. HasAdded s a => Lens' s a
J.added
          wfs1 :: [WorkspaceFolder]
wfs1 = [WorkspaceFolder]
wfs0 [WorkspaceFolder] -> [WorkspaceFolder] -> [WorkspaceFolder]
forall a. Semigroup a => a -> a -> a
<> [WorkspaceFolder]
toAdd

      TVar (LanguageContextData config)
-> (LanguageContextData config -> LanguageContextData config)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (LanguageContextData config)
tvarDat (\LanguageContextData config
c -> LanguageContextData config
c {resWorkspaceFolders :: [WorkspaceFolder]
resWorkspaceFolders = [WorkspaceFolder]
wfs1})
    Result DidChangeWorkspaceFoldersNotification
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Maybe
  (VFS -> DidChangeWorkspaceFoldersNotification -> (VFS, [FilePath]))
-> (DidChangeWorkspaceFoldersNotification -> FromClientMessage)
-> Maybe (Handler DidChangeWorkspaceFoldersNotification)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall b config.
FromJSON b =>
Maybe (VFS -> b -> (VFS, [FilePath]))
-> (b -> FromClientMessage)
-> Maybe (Handler b)
-> TVar (LanguageContextData config)
-> Value
-> IO ()
hh Maybe
  (VFS -> DidChangeWorkspaceFoldersNotification -> (VFS, [FilePath]))
forall a b. Maybe (a -> b -> (a, [FilePath]))
nop DidChangeWorkspaceFoldersNotification -> FromClientMessage
NotDidChangeWorkspaceFolders Maybe (Handler DidChangeWorkspaceFoldersNotification)
h TVar (LanguageContextData config)
tvarDat Value
json

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

modifyVFSData :: TVar (LanguageContextData config) -> (VFSData -> (VFSData, a)) -> STM a
modifyVFSData :: TVar (LanguageContextData config)
-> (VFSData -> (VFSData, a)) -> STM a
modifyVFSData TVar (LanguageContextData config)
tvarDat VFSData -> (VFSData, a)
f = do
  (VFSData
vfs', a
a) <- VFSData -> (VFSData, a)
f (VFSData -> (VFSData, a))
-> (LanguageContextData config -> VFSData)
-> LanguageContextData config
-> (VFSData, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LanguageContextData config -> VFSData
forall config. LanguageContextData config -> VFSData
resVFS (LanguageContextData config -> (VFSData, a))
-> STM (LanguageContextData config) -> STM (VFSData, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (LanguageContextData config)
-> STM (LanguageContextData config)
forall a. TVar a -> STM a
readTVar TVar (LanguageContextData config)
tvarDat
  TVar (LanguageContextData config)
-> (LanguageContextData config -> LanguageContextData config)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (LanguageContextData config)
tvarDat ((LanguageContextData config -> LanguageContextData config)
 -> STM ())
-> (LanguageContextData config -> LanguageContextData config)
-> STM ()
forall a b. (a -> b) -> a -> b
$ \LanguageContextData config
vd -> LanguageContextData config
vd { resVFS :: VFSData
resVFS = VFSData
vfs' }
  a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

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

-- | Return the 'VirtualFile' associated with a given 'NormalizedUri', if there is one.
getVirtualFile :: TVar (LanguageContextData config) -> J.NormalizedUri -> IO (Maybe VirtualFile)
getVirtualFile :: TVar (LanguageContextData config)
-> NormalizedUri -> IO (Maybe VirtualFile)
getVirtualFile TVar (LanguageContextData config)
tvarDat NormalizedUri
uri = NormalizedUri -> Map NormalizedUri VirtualFile -> Maybe VirtualFile
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NormalizedUri
uri (Map NormalizedUri VirtualFile -> Maybe VirtualFile)
-> (LanguageContextData config -> Map NormalizedUri VirtualFile)
-> LanguageContextData config
-> Maybe VirtualFile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VFS -> Map NormalizedUri VirtualFile
vfsMap (VFS -> Map NormalizedUri VirtualFile)
-> (LanguageContextData config -> VFS)
-> LanguageContextData config
-> Map NormalizedUri VirtualFile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VFSData -> VFS
vfsData (VFSData -> VFS)
-> (LanguageContextData config -> VFSData)
-> LanguageContextData config
-> VFS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LanguageContextData config -> VFSData
forall config. LanguageContextData config -> VFSData
resVFS (LanguageContextData config -> Maybe VirtualFile)
-> IO (LanguageContextData config) -> IO (Maybe VirtualFile)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (LanguageContextData config)
-> IO (LanguageContextData config)
forall a. TVar a -> IO a
readTVarIO TVar (LanguageContextData config)
tvarDat

-- | Dump the current text for a given VFS file to a temporary file,
-- and return the path to the file.
persistVirtualFile :: TVar (LanguageContextData config) -> J.NormalizedUri -> IO (Maybe FilePath)
persistVirtualFile :: TVar (LanguageContextData config)
-> NormalizedUri -> IO (Maybe FilePath)
persistVirtualFile TVar (LanguageContextData config)
tvarDat NormalizedUri
uri = IO (IO (Maybe FilePath)) -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO (Maybe FilePath)) -> IO (Maybe FilePath))
-> IO (IO (Maybe FilePath)) -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ STM (IO (Maybe FilePath)) -> IO (IO (Maybe FilePath))
forall a. STM a -> IO a
atomically (STM (IO (Maybe FilePath)) -> IO (IO (Maybe FilePath)))
-> STM (IO (Maybe FilePath)) -> IO (IO (Maybe FilePath))
forall a b. (a -> b) -> a -> b
$ do
  LanguageContextData config
st <- TVar (LanguageContextData config)
-> STM (LanguageContextData config)
forall a. TVar a -> STM a
readTVar TVar (LanguageContextData config)
tvarDat
  let vfs_data :: VFSData
vfs_data = LanguageContextData config -> VFSData
forall config. LanguageContextData config -> VFSData
resVFS LanguageContextData config
st
      cur_vfs :: VFS
cur_vfs = VFSData -> VFS
vfsData VFSData
vfs_data
      revMap :: Map FilePath FilePath
revMap = VFSData -> Map FilePath FilePath
reverseMap VFSData
vfs_data

  case VFS -> NormalizedUri -> Maybe (FilePath, IO ())
persistFileVFS VFS
cur_vfs NormalizedUri
uri of
    Maybe (FilePath, IO ())
Nothing -> IO (Maybe FilePath) -> STM (IO (Maybe FilePath))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing)
    Just (FilePath
fn, IO ()
write) -> do
      let revMap' :: Map FilePath FilePath
revMap' =
        -- TODO: Does the VFS make sense for URIs which are not files?
        -- The reverse map should perhaps be (FilePath -> URI)
            case Uri -> Maybe FilePath
J.uriToFilePath (NormalizedUri -> Uri
J.fromNormalizedUri NormalizedUri
uri) of
              Just FilePath
uri_fp -> FilePath
-> FilePath -> Map FilePath FilePath -> Map FilePath FilePath
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FilePath
fn FilePath
uri_fp Map FilePath FilePath
revMap
              Maybe FilePath
Nothing -> Map FilePath FilePath
revMap

      TVar (LanguageContextData config)
-> (VFSData -> (VFSData, ())) -> STM ()
forall config a.
TVar (LanguageContextData config)
-> (VFSData -> (VFSData, a)) -> STM a
modifyVFSData TVar (LanguageContextData config)
tvarDat (\VFSData
d -> (VFSData
d { reverseMap :: Map FilePath FilePath
reverseMap = Map FilePath FilePath
revMap' }, ()))
      IO (Maybe FilePath) -> STM (IO (Maybe FilePath))
forall (m :: * -> *) a. Monad m => a -> m a
return ((FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
fn) Maybe FilePath -> IO () -> IO (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ IO ()
write)

-- TODO: should this function return a URI?
-- | If the contents of a VFS has been dumped to a temporary file, map
-- the temporary file name back to the original one.
reverseFileMap :: TVar (LanguageContextData config)
               -> IO (FilePath -> FilePath)
reverseFileMap :: TVar (LanguageContextData config) -> IO ShowS
reverseFileMap TVar (LanguageContextData config)
tvarDat = do
    VFSData
vfs <- LanguageContextData config -> VFSData
forall config. LanguageContextData config -> VFSData
resVFS (LanguageContextData config -> VFSData)
-> IO (LanguageContextData config) -> IO VFSData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (LanguageContextData config)
-> IO (LanguageContextData config)
forall a. TVar a -> IO a
readTVarIO TVar (LanguageContextData config)
tvarDat
    let f :: ShowS
f FilePath
fp = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
fp (Maybe FilePath -> FilePath)
-> (VFSData -> Maybe FilePath) -> VFSData -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Map FilePath FilePath -> Maybe FilePath
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FilePath
fp (Map FilePath FilePath -> Maybe FilePath)
-> (VFSData -> Map FilePath FilePath) -> VFSData -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VFSData -> Map FilePath FilePath
reverseMap (VFSData -> FilePath) -> VFSData -> FilePath
forall a b. (a -> b) -> a -> b
$ VFSData
vfs
    ShowS -> IO ShowS
forall (m :: * -> *) a. Monad m => a -> m a
return ShowS
f

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

getConfig :: TVar (LanguageContextData config) -> IO (Maybe config)
getConfig :: TVar (LanguageContextData config) -> IO (Maybe config)
getConfig TVar (LanguageContextData config)
tvar = LanguageContextData config -> Maybe config
forall config. LanguageContextData config -> Maybe config
resConfig (LanguageContextData config -> Maybe config)
-> IO (LanguageContextData config) -> IO (Maybe config)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (LanguageContextData config)
-> IO (LanguageContextData config)
forall a. TVar a -> IO a
readTVarIO TVar (LanguageContextData config)
tvar

-- ---------------------------------------------------------------------
-- |
--
--
_INITIAL_RESPONSE_SEQUENCE :: Int
_INITIAL_RESPONSE_SEQUENCE :: Int
_INITIAL_RESPONSE_SEQUENCE = Int
0


-- |
--
--
_SEP_WIN :: Char
_SEP_WIN :: Char
_SEP_WIN = Char
'\\'

-- |
--
--
_SEP_UNIX :: Char
_SEP_UNIX :: Char
_SEP_UNIX = Char
'/'

-- |
--
--
_ERR_MSG_URL :: [String]
_ERR_MSG_URL :: [FilePath]
_ERR_MSG_URL = [ FilePath
"`stack update` and install new haskell-lsp."
               , FilePath
"Or check information on https://marketplace.visualstudio.com/items?itemName=xxxxxxxxxxxxxxx"
               ]


-- |
--
--
defaultLanguageContextData :: Handlers -> Options -> LspFuncs config -> TVar Int -> SendFunc -> CaptureContext -> VFS -> LanguageContextData config
defaultLanguageContextData :: Handlers
-> Options
-> LspFuncs config
-> TVar Int
-> SendFunc
-> CaptureContext
-> VFS
-> LanguageContextData config
defaultLanguageContextData Handlers
h Options
o LspFuncs config
lf TVar Int
tv SendFunc
sf CaptureContext
cc VFS
vfs =
  Int
-> Handlers
-> Options
-> SendFunc
-> VFSData
-> DiagnosticStore
-> Maybe config
-> TVar Int
-> LspFuncs config
-> CaptureContext
-> [WorkspaceFolder]
-> ProgressData
-> LanguageContextData config
forall config.
Int
-> Handlers
-> Options
-> SendFunc
-> VFSData
-> DiagnosticStore
-> Maybe config
-> TVar Int
-> LspFuncs config
-> CaptureContext
-> [WorkspaceFolder]
-> ProgressData
-> LanguageContextData config
LanguageContextData Int
_INITIAL_RESPONSE_SEQUENCE Handlers
h Options
o SendFunc
sf (VFS -> Map FilePath FilePath -> VFSData
VFSData VFS
vfs Map FilePath FilePath
forall a. Monoid a => a
mempty) DiagnosticStore
forall a. Monoid a => a
mempty
                      Maybe config
forall a. Maybe a
Nothing TVar Int
tv LspFuncs config
lf CaptureContext
cc [WorkspaceFolder]
forall a. Monoid a => a
mempty ProgressData
defaultProgressData

defaultProgressData :: ProgressData
defaultProgressData :: ProgressData
defaultProgressData = Int -> Map ProgressToken (IO ()) -> ProgressData
ProgressData Int
0 Map ProgressToken (IO ())
forall k a. Map k a
Map.empty

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

handleMessage :: (Show config) => InitializeCallbacks config
              -> TVar (LanguageContextData config) -> BSL.ByteString -> IO ()
handleMessage :: InitializeCallbacks config
-> TVar (LanguageContextData config) -> ByteString -> IO ()
handleMessage InitializeCallbacks config
dispatcherProc TVar (LanguageContextData config)
tvarDat ByteString
jsonStr = do
  {-
  Message Types we must handle are the following

  Request      | jsonrpc | id | method | params?
  Response     | jsonrpc | id |        |         | response? | error?
  Notification | jsonrpc |    | method | params?

  -}

  case ByteString -> Either FilePath Object
forall a. FromJSON a => ByteString -> Either FilePath a
J.eitherDecode ByteString
jsonStr :: Either String J.Object of
    Left  FilePath
err -> do
      let msg :: Text
msg =  FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords [ FilePath
"haskell-lsp:incoming message parse error.", ByteString -> FilePath
lbs2str ByteString
jsonStr, ShowS
forall a. Show a => a -> FilePath
show FilePath
err]
              FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
L.intercalate FilePath
"\n" (FilePath
"" FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: FilePath
"" FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
_ERR_MSG_URL)
              FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"\n"
      TVar (LanguageContextData config) -> Text -> IO ()
forall config. TVar (LanguageContextData config) -> Text -> IO ()
sendErrorLog TVar (LanguageContextData config)
tvarDat Text
msg

    Right Object
o -> do

      case Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
"method" Object
o of
        Just cmd :: Value
cmd@(J.String Text
s) -> case Value -> Result ClientMethod
forall a. FromJSON a => Value -> Result a
J.fromJSON Value
cmd of
                                   J.Success ClientMethod
m -> Value -> ClientMethod -> IO ()
handle (Object -> Value
J.Object Object
o) ClientMethod
m
                                   J.Error FilePath
_ -> do
                                     let msg :: Text
msg = FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords [FilePath
"haskell-lsp:unknown message received:method='"
                                                                 FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
s FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"',", ByteString -> FilePath
lbs2str ByteString
jsonStr]
                                     TVar (LanguageContextData config) -> Text -> IO ()
forall config. TVar (LanguageContextData config) -> Text -> IO ()
sendErrorLog TVar (LanguageContextData config)
tvarDat Text
msg
        Just Value
oops -> FilePath -> IO ()
logs (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"haskell-lsp:got strange method param, ignoring:" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> FilePath
forall a. Show a => a -> FilePath
show Value
oops
        Maybe Value
Nothing -> do
          FilePath -> IO ()
logs (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"haskell-lsp:Got reply message:" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> FilePath
forall a. Show a => a -> FilePath
show ByteString
jsonStr
          Value -> IO ()
handleResponse (Object -> Value
J.Object Object
o)

  where
    handleResponse :: Value -> IO ()
handleResponse Value
json = do
      LanguageContextData config
ctx <- TVar (LanguageContextData config)
-> IO (LanguageContextData config)
forall a. TVar a -> IO a
readTVarIO TVar (LanguageContextData config)
tvarDat
      case Handlers -> Maybe (Handler BareResponseMessage)
responseHandler (Handlers -> Maybe (Handler BareResponseMessage))
-> Handlers -> Maybe (Handler BareResponseMessage)
forall a b. (a -> b) -> a -> b
$ LanguageContextData config -> Handlers
forall config. LanguageContextData config -> Handlers
resHandlers LanguageContextData config
ctx of
        Maybe (Handler BareResponseMessage)
Nothing -> TVar (LanguageContextData config) -> Text -> IO ()
forall config. TVar (LanguageContextData config) -> Text -> IO ()
sendErrorLog TVar (LanguageContextData config)
tvarDat (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
"haskell-lsp: responseHandler is not defined, ignoring response " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> FilePath
lbs2str ByteString
jsonStr
        Just Handler BareResponseMessage
h -> case Value -> Result BareResponseMessage
forall a. FromJSON a => Value -> Result a
J.fromJSON Value
json of
          J.Success BareResponseMessage
res -> Handler BareResponseMessage
h BareResponseMessage
res
          J.Error FilePath
err -> let msg :: Text
msg = FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ [FilePath
"haskell-lsp:response parse error.", ByteString -> FilePath
lbs2str ByteString
jsonStr, ShowS
forall a. Show a => a -> FilePath
show FilePath
err] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
_ERR_MSG_URL
                           in TVar (LanguageContextData config) -> Text -> IO ()
forall config. TVar (LanguageContextData config) -> Text -> IO ()
sendErrorLog TVar (LanguageContextData config)
tvarDat Text
msg
    -- capability based handlers
    handle :: Value -> ClientMethod -> IO ()
handle Value
json ClientMethod
cmd = do
      LanguageContextData config
ctx <- TVar (LanguageContextData config)
-> IO (LanguageContextData config)
forall a. TVar a -> IO a
readTVarIO TVar (LanguageContextData config)
tvarDat
      let h :: Handlers
h = LanguageContextData config -> Handlers
forall config. LanguageContextData config -> Handlers
resHandlers LanguageContextData config
ctx
      InitializeCallbacks config
-> Handlers
-> ClientMethod
-> TVar (LanguageContextData config)
-> Value
-> IO ()
forall config.
Show config =>
InitializeCallbacks config
-> Handlers
-> ClientMethod
-> TVar (LanguageContextData config)
-> Value
-> IO ()
handlerMap InitializeCallbacks config
dispatcherProc Handlers
h ClientMethod
cmd TVar (LanguageContextData config)
tvarDat Value
json

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

makeResponseMessage :: J.RequestMessage J.ClientMethod req resp -> resp -> J.ResponseMessage resp
makeResponseMessage :: RequestMessage ClientMethod req resp
-> resp -> ResponseMessage resp
makeResponseMessage RequestMessage ClientMethod req resp
req resp
result = Text
-> LspIdRsp -> Either ResponseError resp -> ResponseMessage resp
forall a.
Text -> LspIdRsp -> Either ResponseError a -> ResponseMessage a
J.ResponseMessage Text
"2.0" (LspId -> LspIdRsp
J.responseId (LspId -> LspIdRsp) -> LspId -> LspIdRsp
forall a b. (a -> b) -> a -> b
$ RequestMessage ClientMethod req resp
req RequestMessage ClientMethod req resp
-> Getting LspId (RequestMessage ClientMethod req resp) LspId
-> LspId
forall s a. s -> Getting a s a -> a
^. Getting LspId (RequestMessage ClientMethod req resp) LspId
forall s a. HasId s a => Lens' s a
J.id) (resp -> Either ResponseError resp
forall a b. b -> Either a b
Right resp
result)

makeResponseError :: J.LspIdRsp -> J.ResponseError -> J.ResponseMessage ()
makeResponseError :: LspIdRsp -> ResponseError -> ResponseMessage ()
makeResponseError LspIdRsp
origId ResponseError
err = Text -> LspIdRsp -> Either ResponseError () -> ResponseMessage ()
forall a.
Text -> LspIdRsp -> Either ResponseError a -> ResponseMessage a
J.ResponseMessage Text
"2.0" LspIdRsp
origId (ResponseError -> Either ResponseError ()
forall a b. a -> Either a b
Left ResponseError
err)

-- ---------------------------------------------------------------------
-- |
--
sendEvent :: TVar (LanguageContextData config) -> FromServerMessage -> IO ()
sendEvent :: TVar (LanguageContextData config) -> SendFunc
sendEvent TVar (LanguageContextData config)
tvarCtx FromServerMessage
msg = TVar (LanguageContextData config) -> SendFunc
forall config. TVar (LanguageContextData config) -> SendFunc
sendResponse TVar (LanguageContextData config)
tvarCtx FromServerMessage
msg

-- |
--
sendResponse :: TVar (LanguageContextData config) -> FromServerMessage -> IO ()
sendResponse :: TVar (LanguageContextData config) -> SendFunc
sendResponse TVar (LanguageContextData config)
tvarCtx FromServerMessage
msg = do
  LanguageContextData config
ctx <- TVar (LanguageContextData config)
-> IO (LanguageContextData config)
forall a. TVar a -> IO a
readTVarIO TVar (LanguageContextData config)
tvarCtx
  LanguageContextData config -> SendFunc
forall config. LanguageContextData config -> SendFunc
resSendResponse LanguageContextData config
ctx FromServerMessage
msg


-- ---------------------------------------------------------------------
-- |
--
--
sendErrorResponse :: TVar (LanguageContextData config) -> J.LspIdRsp -> Text -> IO ()
sendErrorResponse :: TVar (LanguageContextData config) -> LspIdRsp -> Text -> IO ()
sendErrorResponse TVar (LanguageContextData config)
tv LspIdRsp
origId Text
msg = SendFunc -> LspIdRsp -> ErrorCode -> Text -> IO ()
sendErrorResponseS (TVar (LanguageContextData config) -> SendFunc
forall config. TVar (LanguageContextData config) -> SendFunc
sendEvent TVar (LanguageContextData config)
tv) LspIdRsp
origId ErrorCode
J.InternalError Text
msg

sendErrorResponseS ::  SendFunc -> J.LspIdRsp -> J.ErrorCode -> Text -> IO ()
sendErrorResponseS :: SendFunc -> LspIdRsp -> ErrorCode -> Text -> IO ()
sendErrorResponseS SendFunc
sf LspIdRsp
origId ErrorCode
err Text
msg = do
  SendFunc
sf SendFunc -> SendFunc
forall a b. (a -> b) -> a -> b
$ ResponseMessage () -> FromServerMessage
RspError (Text -> LspIdRsp -> Either ResponseError () -> ResponseMessage ()
forall a.
Text -> LspIdRsp -> Either ResponseError a -> ResponseMessage a
J.ResponseMessage Text
"2.0" LspIdRsp
origId
                  (ResponseError -> Either ResponseError ()
forall a b. a -> Either a b
Left (ResponseError -> Either ResponseError ())
-> ResponseError -> Either ResponseError ()
forall a b. (a -> b) -> a -> b
$ ErrorCode -> Text -> Maybe Value -> ResponseError
J.ResponseError ErrorCode
err Text
msg Maybe Value
forall a. Maybe a
Nothing) :: J.ErrorResponse)

sendErrorLog :: TVar (LanguageContextData config) -> Text -> IO ()
sendErrorLog :: TVar (LanguageContextData config) -> Text -> IO ()
sendErrorLog TVar (LanguageContextData config)
tv Text
msg = SendFunc -> Text -> IO ()
sendErrorLogS (TVar (LanguageContextData config) -> SendFunc
forall config. TVar (LanguageContextData config) -> SendFunc
sendEvent TVar (LanguageContextData config)
tv) Text
msg

sendErrorLogS :: SendFunc -> Text -> IO ()
sendErrorLogS :: SendFunc -> Text -> IO ()
sendErrorLogS SendFunc
sf Text
msg =
  SendFunc
sf SendFunc -> SendFunc
forall a b. (a -> b) -> a -> b
$ LogMessageNotification -> FromServerMessage
NotLogMessage (LogMessageNotification -> FromServerMessage)
-> LogMessageNotification -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ MessageType -> Text -> LogMessageNotification
fmServerLogMessageNotification MessageType
J.MtError Text
msg

-- sendErrorShow :: String -> IO ()
-- sendErrorShow msg = sendErrorShowS sendEvent msg

sendErrorShowS :: SendFunc -> Text -> IO ()
sendErrorShowS :: SendFunc -> Text -> IO ()
sendErrorShowS SendFunc
sf Text
msg =
  SendFunc
sf SendFunc -> SendFunc
forall a b. (a -> b) -> a -> b
$ ShowMessageNotification -> FromServerMessage
NotShowMessage (ShowMessageNotification -> FromServerMessage)
-> ShowMessageNotification -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ MessageType -> Text -> ShowMessageNotification
fmServerShowMessageNotification MessageType
J.MtError Text
msg

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

defaultErrorHandlers :: (Show a) => TVar (LanguageContextData config) -> J.LspIdRsp -> a -> [E.Handler ()]
defaultErrorHandlers :: TVar (LanguageContextData config) -> LspIdRsp -> a -> [Handler ()]
defaultErrorHandlers TVar (LanguageContextData config)
tvarDat LspIdRsp
origId a
req = [ (SomeException -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler SomeException -> IO ()
someExcept ]
  where
    someExcept :: SomeException -> IO ()
someExcept (SomeException
e :: E.SomeException) = do
      let msg :: Text
msg = FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords [FilePath
"request error.", a -> FilePath
forall a. Show a => a -> FilePath
show a
req, SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e]
      TVar (LanguageContextData config) -> LspIdRsp -> Text -> IO ()
forall config.
TVar (LanguageContextData config) -> LspIdRsp -> Text -> IO ()
sendErrorResponse TVar (LanguageContextData config)
tvarDat LspIdRsp
origId Text
msg
      TVar (LanguageContextData config) -> Text -> IO ()
forall config. TVar (LanguageContextData config) -> Text -> IO ()
sendErrorLog TVar (LanguageContextData config)
tvarDat Text
msg


-- |=====================================================================
--
-- Handlers

-- |
--
initializeRequestHandler'
  :: (Show config)
  => (LspFuncs config -> IO (Maybe J.ResponseError))
  -> Maybe (Handler J.InitializeRequest)
  -> TVar (LanguageContextData config)
  -> J.InitializeRequest
  -> IO ()
initializeRequestHandler' :: (LspFuncs config -> IO (Maybe ResponseError))
-> Maybe (Handler InitializeRequest)
-> TVar (LanguageContextData config)
-> Handler InitializeRequest
initializeRequestHandler' LspFuncs config -> IO (Maybe ResponseError)
onStartup Maybe (Handler InitializeRequest)
mHandler TVar (LanguageContextData config)
tvarCtx req :: InitializeRequest
req@(J.RequestMessage Text
_ LspId
origId ClientMethod
_ InitializeParams
params) =
  (IO () -> [Handler ()] -> IO ()) -> [Handler ()] -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> [Handler ()] -> IO ()
forall a. IO a -> [Handler a] -> IO a
E.catches (TVar (LanguageContextData config)
-> LspIdRsp -> InitializeRequest -> [Handler ()]
forall a config.
Show a =>
TVar (LanguageContextData config) -> LspIdRsp -> a -> [Handler ()]
defaultErrorHandlers TVar (LanguageContextData config)
tvarCtx (LspId -> LspIdRsp
J.responseId LspId
origId) InitializeRequest
req) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do

    case Maybe (Handler InitializeRequest)
mHandler of
      Just Handler InitializeRequest
handler -> Handler InitializeRequest
handler InitializeRequest
req
      Maybe (Handler InitializeRequest)
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    let wfs :: [WorkspaceFolder]
wfs = case InitializeParams
params InitializeParams
-> Getting
     (Maybe (List WorkspaceFolder))
     InitializeParams
     (Maybe (List WorkspaceFolder))
-> Maybe (List WorkspaceFolder)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (List WorkspaceFolder))
  InitializeParams
  (Maybe (List WorkspaceFolder))
forall s a. HasWorkspaceFolders s a => Lens' s a
J.workspaceFolders of
                Just (J.List [WorkspaceFolder]
xs) -> [WorkspaceFolder]
xs
                Maybe (List WorkspaceFolder)
Nothing -> []

    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (LanguageContextData config)
-> (LanguageContextData config -> LanguageContextData config)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (LanguageContextData config)
tvarCtx (\LanguageContextData config
c -> LanguageContextData config
c { resWorkspaceFolders :: [WorkspaceFolder]
resWorkspaceFolders = [WorkspaceFolder]
wfs })

    LanguageContextData config
ctx0 <- TVar (LanguageContextData config)
-> IO (LanguageContextData config)
forall a. TVar a -> IO a
readTVarIO TVar (LanguageContextData config)
tvarCtx
    let rootDir :: Maybe FilePath
rootDir = First FilePath -> Maybe FilePath
forall a. First a -> Maybe a
getFirst (First FilePath -> Maybe FilePath)
-> First FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ (Maybe FilePath -> First FilePath)
-> [Maybe FilePath] -> First FilePath
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Maybe FilePath -> First FilePath
forall a. Maybe a -> First a
First [ InitializeParams
params InitializeParams
-> Getting (Maybe Uri) InitializeParams (Maybe Uri) -> Maybe Uri
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Uri) InitializeParams (Maybe Uri)
forall s a. HasRootUri s a => Lens' s a
J.rootUri  Maybe Uri -> (Uri -> Maybe FilePath) -> Maybe FilePath
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Uri -> Maybe FilePath
J.uriToFilePath
                                           , InitializeParams
params InitializeParams
-> Getting (Maybe Text) InitializeParams (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Text) InitializeParams (Maybe Text)
forall s a. HasRootPath s a => Lens' s a
J.rootPath Maybe Text -> (Text -> FilePath) -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Text -> FilePath
T.unpack ]

    case Maybe FilePath
rootDir of
      Maybe FilePath
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just FilePath
dir -> do
        FilePath -> IO ()
logs (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"haskell-lsp:initializeRequestHandler: setting current dir to project root:" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
dir
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
dir) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
setCurrentDirectory FilePath
dir

    let
      getCapabilities :: J.InitializeParams -> C.ClientCapabilities
      getCapabilities :: InitializeParams -> ClientCapabilities
getCapabilities (J.InitializeParams Maybe Int
_ Maybe Text
_ Maybe Uri
_ Maybe Value
_ ClientCapabilities
c Maybe Trace
_ Maybe (List WorkspaceFolder)
_) = ClientCapabilities
c
      getLspId :: TVar Int -> IO LspId
getLspId TVar Int
tvId = STM LspId -> IO LspId
forall a. STM a -> IO a
atomically (STM LspId -> IO LspId) -> STM LspId -> IO LspId
forall a b. (a -> b) -> a -> b
$ do
        Int
cid <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
tvId
        TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
tvId (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
        LspId -> STM LspId
forall (m :: * -> *) a. Monad m => a -> m a
return (LspId -> STM LspId) -> LspId -> STM LspId
forall a b. (a -> b) -> a -> b
$ Int -> LspId
J.IdInt Int
cid

      clientSupportsWfs :: Bool
clientSupportsWfs = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
        let (C.ClientCapabilities Maybe WorkspaceClientCapabilities
mw Maybe TextDocumentClientCapabilities
_ Maybe WindowClientCapabilities
_ Maybe Object
_) = InitializeParams
params InitializeParams
-> Getting ClientCapabilities InitializeParams ClientCapabilities
-> ClientCapabilities
forall s a. s -> Getting a s a -> a
^. Getting ClientCapabilities InitializeParams ClientCapabilities
forall s a. HasCapabilities s a => Lens' s a
J.capabilities
        (C.WorkspaceClientCapabilities Maybe Bool
_ Maybe WorkspaceEditClientCapabilities
_ Maybe DidChangeConfigurationClientCapabilities
_ Maybe DidChangeWatchedFilesClientCapabilities
_ Maybe SymbolClientCapabilities
_ Maybe ExecuteClientCapabilities
_ Maybe Bool
mwf Maybe Bool
_) <- Maybe WorkspaceClientCapabilities
mw
        Maybe Bool
mwf
      getWfs :: TVar (LanguageContextData config) -> IO (Maybe [WorkspaceFolder])
getWfs TVar (LanguageContextData config)
tvc
        | Bool
clientSupportsWfs = STM (Maybe [WorkspaceFolder]) -> IO (Maybe [WorkspaceFolder])
forall a. STM a -> IO a
atomically (STM (Maybe [WorkspaceFolder]) -> IO (Maybe [WorkspaceFolder]))
-> STM (Maybe [WorkspaceFolder]) -> IO (Maybe [WorkspaceFolder])
forall a b. (a -> b) -> a -> b
$ [WorkspaceFolder] -> Maybe [WorkspaceFolder]
forall a. a -> Maybe a
Just ([WorkspaceFolder] -> Maybe [WorkspaceFolder])
-> (LanguageContextData config -> [WorkspaceFolder])
-> LanguageContextData config
-> Maybe [WorkspaceFolder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LanguageContextData config -> [WorkspaceFolder]
forall config. LanguageContextData config -> [WorkspaceFolder]
resWorkspaceFolders (LanguageContextData config -> Maybe [WorkspaceFolder])
-> STM (LanguageContextData config)
-> STM (Maybe [WorkspaceFolder])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (LanguageContextData config)
-> STM (LanguageContextData config)
forall a. TVar a -> STM a
readTVar TVar (LanguageContextData config)
tvc
        | Bool
otherwise = Maybe [WorkspaceFolder] -> IO (Maybe [WorkspaceFolder])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [WorkspaceFolder]
forall a. Maybe a
Nothing

      clientSupportsProgress :: Bool
clientSupportsProgress = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
        let (C.ClientCapabilities Maybe WorkspaceClientCapabilities
_ Maybe TextDocumentClientCapabilities
_ Maybe WindowClientCapabilities
wc Maybe Object
_) = InitializeParams
params InitializeParams
-> Getting ClientCapabilities InitializeParams ClientCapabilities
-> ClientCapabilities
forall s a. s -> Getting a s a -> a
^. Getting ClientCapabilities InitializeParams ClientCapabilities
forall s a. HasCapabilities s a => Lens' s a
J.capabilities
        (C.WindowClientCapabilities Maybe Bool
mProgress) <- Maybe WindowClientCapabilities
wc
        Maybe Bool
mProgress

      storeProgress :: J.ProgressToken -> Async a -> IO ()
      storeProgress :: ProgressToken -> Async a -> IO ()
storeProgress ProgressToken
n Async a
a = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        ProgressData
pd <- LanguageContextData config -> ProgressData
forall config. LanguageContextData config -> ProgressData
resProgressData (LanguageContextData config -> ProgressData)
-> STM (LanguageContextData config) -> STM ProgressData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (LanguageContextData config)
-> STM (LanguageContextData config)
forall a. TVar a -> STM a
readTVar TVar (LanguageContextData config)
tvarCtx
        let pc :: Map ProgressToken (IO ())
pc = ProgressData -> Map ProgressToken (IO ())
progressCancel ProgressData
pd
            pc' :: Map ProgressToken (IO ())
pc' = ProgressToken
-> IO () -> Map ProgressToken (IO ()) -> Map ProgressToken (IO ())
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ProgressToken
n (Async a -> ProgressCancelledException -> IO ()
forall e a. Exception e => Async a -> e -> IO ()
cancelWith Async a
a ProgressCancelledException
ProgressCancelledException) Map ProgressToken (IO ())
pc
        TVar (LanguageContextData config)
-> (LanguageContextData config -> LanguageContextData config)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (LanguageContextData config)
tvarCtx (\LanguageContextData config
ctx -> LanguageContextData config
ctx { resProgressData :: ProgressData
resProgressData = ProgressData
pd { progressCancel :: Map ProgressToken (IO ())
progressCancel = Map ProgressToken (IO ())
pc' }})

      deleteProgress :: J.ProgressToken -> IO ()
      deleteProgress :: ProgressToken -> IO ()
deleteProgress ProgressToken
n = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        ProgressData
pd <- LanguageContextData config -> ProgressData
forall config. LanguageContextData config -> ProgressData
resProgressData (LanguageContextData config -> ProgressData)
-> STM (LanguageContextData config) -> STM ProgressData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (LanguageContextData config)
-> STM (LanguageContextData config)
forall a. TVar a -> STM a
readTVar TVar (LanguageContextData config)
tvarCtx
        let x :: Map ProgressToken (IO ())
x = ProgressData -> Map ProgressToken (IO ())
progressCancel ProgressData
pd
            x' :: Map ProgressToken (IO ())
x' = ProgressToken
-> Map ProgressToken (IO ()) -> Map ProgressToken (IO ())
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete ProgressToken
n Map ProgressToken (IO ())
x
        TVar (LanguageContextData config)
-> (LanguageContextData config -> LanguageContextData config)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (LanguageContextData config)
tvarCtx (\LanguageContextData config
ctx -> LanguageContextData config
ctx { resProgressData :: ProgressData
resProgressData = ProgressData
pd { progressCancel :: Map ProgressToken (IO ())
progressCancel = Map ProgressToken (IO ())
x' }})

      -- Get a new id for the progress session and make a new one
      getNewProgressId :: IO J.ProgressToken
      getNewProgressId :: IO ProgressToken
getNewProgressId = IO ProgressToken -> IO ProgressToken
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProgressToken -> IO ProgressToken)
-> IO ProgressToken -> IO ProgressToken
forall a b. (a -> b) -> a -> b
$ STM ProgressToken -> IO ProgressToken
forall a. STM a -> IO a
atomically (STM ProgressToken -> IO ProgressToken)
-> STM ProgressToken -> IO ProgressToken
forall a b. (a -> b) -> a -> b
$ do
        ProgressData
pd <- LanguageContextData config -> ProgressData
forall config. LanguageContextData config -> ProgressData
resProgressData (LanguageContextData config -> ProgressData)
-> STM (LanguageContextData config) -> STM ProgressData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (LanguageContextData config)
-> STM (LanguageContextData config)
forall a. TVar a -> STM a
readTVar TVar (LanguageContextData config)
tvarCtx
        let x :: Int
x = ProgressData -> Int
progressNextId ProgressData
pd
        TVar (LanguageContextData config)
-> (LanguageContextData config -> LanguageContextData config)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (LanguageContextData config)
tvarCtx (\LanguageContextData config
ctx -> LanguageContextData config
ctx { resProgressData :: ProgressData
resProgressData = ProgressData
pd { progressNextId :: Int
progressNextId = Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 }})
        ProgressToken -> STM ProgressToken
forall (m :: * -> *) a. Monad m => a -> m a
return (ProgressToken -> STM ProgressToken)
-> ProgressToken -> STM ProgressToken
forall a b. (a -> b) -> a -> b
$ Int -> ProgressToken
J.ProgressNumericToken Int
x

      withProgressBase :: Bool -> (Text -> ProgressCancellable
                    -> ((Progress -> IO ()) -> IO a) -> IO a)
      withProgressBase :: Bool
-> Text
-> ProgressCancellable
-> ((Progress -> IO ()) -> IO a)
-> IO a
withProgressBase Bool
indefinite Text
title ProgressCancellable
cancellable (Progress -> IO ()) -> IO a
f
        | Bool
clientSupportsProgress = do
          let sf :: SendFunc
sf = TVar (LanguageContextData config) -> SendFunc
forall config. TVar (LanguageContextData config) -> SendFunc
sendResponse TVar (LanguageContextData config)
tvarCtx

          ProgressToken
progId <- IO ProgressToken
getNewProgressId

          let initialPercentage :: Maybe Double
initialPercentage
                | Bool
indefinite = Maybe Double
forall a. Maybe a
Nothing
                | Bool
otherwise = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
0
              cancellable' :: Bool
cancellable' = case ProgressCancellable
cancellable of
                              ProgressCancellable
Cancellable -> Bool
True
                              ProgressCancellable
NotCancellable -> Bool
False

          LspId
rId <- TVar Int -> IO LspId
getLspId (TVar Int -> IO LspId) -> TVar Int -> IO LspId
forall a b. (a -> b) -> a -> b
$ LanguageContextData config -> TVar Int
forall config. LanguageContextData config -> TVar Int
resLspId LanguageContextData config
ctx0

          -- Create progress token
          IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ SendFunc
sf SendFunc -> SendFunc
forall a b. (a -> b) -> a -> b
$ WorkDoneProgressCreateRequest -> FromServerMessage
ReqWorkDoneProgressCreate (WorkDoneProgressCreateRequest -> FromServerMessage)
-> WorkDoneProgressCreateRequest -> FromServerMessage
forall a b. (a -> b) -> a -> b
$
            LspId
-> WorkDoneProgressCreateParams -> WorkDoneProgressCreateRequest
fmServerWorkDoneProgressCreateRequest LspId
rId (WorkDoneProgressCreateParams -> WorkDoneProgressCreateRequest)
-> WorkDoneProgressCreateParams -> WorkDoneProgressCreateRequest
forall a b. (a -> b) -> a -> b
$ ProgressToken -> WorkDoneProgressCreateParams
J.WorkDoneProgressCreateParams ProgressToken
progId

          -- Send initial notification
          IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ SendFunc
sf SendFunc -> SendFunc
forall a b. (a -> b) -> a -> b
$ WorkDoneProgressBeginNotification -> FromServerMessage
NotWorkDoneProgressBegin (WorkDoneProgressBeginNotification -> FromServerMessage)
-> WorkDoneProgressBeginNotification -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ ProgressParams WorkDoneProgressBeginParams
-> WorkDoneProgressBeginNotification
fmServerWorkDoneProgressBeginNotification (ProgressParams WorkDoneProgressBeginParams
 -> WorkDoneProgressBeginNotification)
-> ProgressParams WorkDoneProgressBeginParams
-> WorkDoneProgressBeginNotification
forall a b. (a -> b) -> a -> b
$
            ProgressToken
-> WorkDoneProgressBeginParams
-> ProgressParams WorkDoneProgressBeginParams
forall t. ProgressToken -> t -> ProgressParams t
J.ProgressParams ProgressToken
progId (WorkDoneProgressBeginParams
 -> ProgressParams WorkDoneProgressBeginParams)
-> WorkDoneProgressBeginParams
-> ProgressParams WorkDoneProgressBeginParams
forall a b. (a -> b) -> a -> b
$
            Text
-> Maybe Bool
-> Maybe Text
-> Maybe Double
-> WorkDoneProgressBeginParams
J.WorkDoneProgressBeginParams Text
title (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
cancellable') Maybe Text
forall a. Maybe a
Nothing Maybe Double
initialPercentage

          Async a
aid <- IO a -> IO (Async a)
forall a. IO a -> IO (Async a)
async (IO a -> IO (Async a)) -> IO a -> IO (Async a)
forall a b. (a -> b) -> a -> b
$ (Progress -> IO ()) -> IO a
f (ProgressToken -> SendFunc -> Progress -> IO ()
forall t.
ProgressToken -> (FromServerMessage -> t) -> Progress -> t
updater ProgressToken
progId SendFunc
sf)
          ProgressToken -> Async a -> IO ()
forall a. ProgressToken -> Async a -> IO ()
storeProgress ProgressToken
progId Async a
aid
          a
res <- Async a -> IO a
forall a. Async a -> IO a
wait Async a
aid

          -- Send done notification
          IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ SendFunc
sf SendFunc -> SendFunc
forall a b. (a -> b) -> a -> b
$ WorkDoneProgressEndNotification -> FromServerMessage
NotWorkDoneProgressEnd (WorkDoneProgressEndNotification -> FromServerMessage)
-> WorkDoneProgressEndNotification -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ ProgressParams WorkDoneProgressEndParams
-> WorkDoneProgressEndNotification
fmServerWorkDoneProgressEndNotification (ProgressParams WorkDoneProgressEndParams
 -> WorkDoneProgressEndNotification)
-> ProgressParams WorkDoneProgressEndParams
-> WorkDoneProgressEndNotification
forall a b. (a -> b) -> a -> b
$
            ProgressToken
-> WorkDoneProgressEndParams
-> ProgressParams WorkDoneProgressEndParams
forall t. ProgressToken -> t -> ProgressParams t
J.ProgressParams ProgressToken
progId (WorkDoneProgressEndParams
 -> ProgressParams WorkDoneProgressEndParams)
-> WorkDoneProgressEndParams
-> ProgressParams WorkDoneProgressEndParams
forall a b. (a -> b) -> a -> b
$
            Maybe Text -> WorkDoneProgressEndParams
J.WorkDoneProgressEndParams Maybe Text
forall a. Maybe a
Nothing
          -- Delete the progress cancellation from the map
          -- If we don't do this then it's easy to leak things as the map contains any IO action.
          ProgressToken -> IO ()
deleteProgress ProgressToken
progId


          a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
        | Bool
otherwise = (Progress -> IO ()) -> IO a
f (IO () -> Progress -> IO ()
forall a b. a -> b -> a
const (IO () -> Progress -> IO ()) -> IO () -> Progress -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
          where updater :: ProgressToken -> (FromServerMessage -> t) -> Progress -> t
updater ProgressToken
progId FromServerMessage -> t
sf (Progress Maybe Double
percentage Maybe Text
msg) =
                  FromServerMessage -> t
sf (FromServerMessage -> t) -> FromServerMessage -> t
forall a b. (a -> b) -> a -> b
$ WorkDoneProgressReportNotification -> FromServerMessage
NotWorkDoneProgressReport (WorkDoneProgressReportNotification -> FromServerMessage)
-> WorkDoneProgressReportNotification -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ ProgressParams WorkDoneProgressReportParams
-> WorkDoneProgressReportNotification
fmServerWorkDoneProgressReportNotification (ProgressParams WorkDoneProgressReportParams
 -> WorkDoneProgressReportNotification)
-> ProgressParams WorkDoneProgressReportParams
-> WorkDoneProgressReportNotification
forall a b. (a -> b) -> a -> b
$
                    ProgressToken
-> WorkDoneProgressReportParams
-> ProgressParams WorkDoneProgressReportParams
forall t. ProgressToken -> t -> ProgressParams t
J.ProgressParams ProgressToken
progId (WorkDoneProgressReportParams
 -> ProgressParams WorkDoneProgressReportParams)
-> WorkDoneProgressReportParams
-> ProgressParams WorkDoneProgressReportParams
forall a b. (a -> b) -> a -> b
$
                    Maybe Bool
-> Maybe Text -> Maybe Double -> WorkDoneProgressReportParams
J.WorkDoneProgressReportParams Maybe Bool
forall a. Maybe a
Nothing Maybe Text
msg Maybe Double
percentage

      withProgress' :: Text -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a
      withProgress' :: Text
-> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a
withProgress' = Bool
-> Text
-> ProgressCancellable
-> ((Progress -> IO ()) -> IO a)
-> IO a
forall a.
Bool
-> Text
-> ProgressCancellable
-> ((Progress -> IO ()) -> IO a)
-> IO a
withProgressBase Bool
False

      withIndefiniteProgress' :: Text -> ProgressCancellable -> IO a -> IO a
      withIndefiniteProgress' :: Text -> ProgressCancellable -> IO a -> IO a
withIndefiniteProgress' Text
title ProgressCancellable
cancellable IO a
f =
        Bool
-> Text
-> ProgressCancellable
-> ((Progress -> IO ()) -> IO a)
-> IO a
forall a.
Bool
-> Text
-> ProgressCancellable
-> ((Progress -> IO ()) -> IO a)
-> IO a
withProgressBase Bool
True Text
title ProgressCancellable
cancellable (IO a -> (Progress -> IO ()) -> IO a
forall a b. a -> b -> a
const IO a
f)

    -- Launch the given process once the project root directory has been set
    let lspFuncs :: LspFuncs config
lspFuncs = ClientCapabilities
-> IO (Maybe config)
-> SendFunc
-> (NormalizedUri -> IO (Maybe VirtualFile))
-> (NormalizedUri -> IO (Maybe FilePath))
-> IO ShowS
-> PublishDiagnosticsFunc
-> FlushDiagnosticsBySourceFunc
-> IO LspId
-> Maybe FilePath
-> IO (Maybe [WorkspaceFolder])
-> (forall a.
    Text
    -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a)
-> (forall a. Text -> ProgressCancellable -> IO a -> IO a)
-> LspFuncs config
forall c.
ClientCapabilities
-> IO (Maybe c)
-> SendFunc
-> (NormalizedUri -> IO (Maybe VirtualFile))
-> (NormalizedUri -> IO (Maybe FilePath))
-> IO ShowS
-> PublishDiagnosticsFunc
-> FlushDiagnosticsBySourceFunc
-> IO LspId
-> Maybe FilePath
-> IO (Maybe [WorkspaceFolder])
-> (forall a.
    Text
    -> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a)
-> (forall a. Text -> ProgressCancellable -> IO a -> IO a)
-> LspFuncs c
LspFuncs (InitializeParams -> ClientCapabilities
getCapabilities InitializeParams
params)
                            (TVar (LanguageContextData config) -> IO (Maybe config)
forall config.
TVar (LanguageContextData config) -> IO (Maybe config)
getConfig TVar (LanguageContextData config)
tvarCtx)
                            (LanguageContextData config -> SendFunc
forall config. LanguageContextData config -> SendFunc
resSendResponse LanguageContextData config
ctx0)
                            (TVar (LanguageContextData config)
-> NormalizedUri -> IO (Maybe VirtualFile)
forall config.
TVar (LanguageContextData config)
-> NormalizedUri -> IO (Maybe VirtualFile)
getVirtualFile TVar (LanguageContextData config)
tvarCtx)
                            (TVar (LanguageContextData config)
-> NormalizedUri -> IO (Maybe FilePath)
forall config.
TVar (LanguageContextData config)
-> NormalizedUri -> IO (Maybe FilePath)
persistVirtualFile TVar (LanguageContextData config)
tvarCtx)
                            (TVar (LanguageContextData config) -> IO ShowS
forall config. TVar (LanguageContextData config) -> IO ShowS
reverseFileMap TVar (LanguageContextData config)
tvarCtx)
                            (TVar (LanguageContextData config) -> PublishDiagnosticsFunc
forall config.
TVar (LanguageContextData config) -> PublishDiagnosticsFunc
publishDiagnostics TVar (LanguageContextData config)
tvarCtx)
                            (TVar (LanguageContextData config) -> FlushDiagnosticsBySourceFunc
forall config.
TVar (LanguageContextData config) -> FlushDiagnosticsBySourceFunc
flushDiagnosticsBySource TVar (LanguageContextData config)
tvarCtx)
                            (TVar Int -> IO LspId
getLspId (TVar Int -> IO LspId) -> TVar Int -> IO LspId
forall a b. (a -> b) -> a -> b
$ LanguageContextData config -> TVar Int
forall config. LanguageContextData config -> TVar Int
resLspId LanguageContextData config
ctx0)
                            Maybe FilePath
rootDir
                            (TVar (LanguageContextData config) -> IO (Maybe [WorkspaceFolder])
getWfs TVar (LanguageContextData config)
tvarCtx)
                            forall a.
Text
-> ProgressCancellable -> ((Progress -> IO ()) -> IO a) -> IO a
withProgress'
                            forall a. Text -> ProgressCancellable -> IO a -> IO a
withIndefiniteProgress'
    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (LanguageContextData config)
-> (LanguageContextData config -> LanguageContextData config)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (LanguageContextData config)
tvarCtx (\LanguageContextData config
cur_ctx -> LanguageContextData config
cur_ctx { resLspFuncs :: LspFuncs config
resLspFuncs = LspFuncs config
lspFuncs })

    LanguageContextData config
ctx <- TVar (LanguageContextData config)
-> IO (LanguageContextData config)
forall a. TVar a -> IO a
readTVarIO TVar (LanguageContextData config)
tvarCtx

    Maybe ResponseError
initializationResult <- LspFuncs config -> IO (Maybe ResponseError)
onStartup LspFuncs config
lspFuncs

    case Maybe ResponseError
initializationResult of
      Just ResponseError
errResp -> do
        TVar (LanguageContextData config) -> SendFunc
forall config. TVar (LanguageContextData config) -> SendFunc
sendResponse TVar (LanguageContextData config)
tvarCtx SendFunc -> SendFunc
forall a b. (a -> b) -> a -> b
$ ResponseMessage () -> FromServerMessage
RspError (ResponseMessage () -> FromServerMessage)
-> ResponseMessage () -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ LspIdRsp -> ResponseError -> ResponseMessage ()
makeResponseError (LspId -> LspIdRsp
J.responseId LspId
origId) ResponseError
errResp

      Maybe ResponseError
Nothing -> do
        let capa :: InitializeResponseCapabilitiesInner
capa = ClientCapabilities
-> Options -> Handlers -> InitializeResponseCapabilitiesInner
serverCapabilities (InitializeParams -> ClientCapabilities
getCapabilities InitializeParams
params) (LanguageContextData config -> Options
forall config. LanguageContextData config -> Options
resOptions LanguageContextData config
ctx) (LanguageContextData config -> Handlers
forall config. LanguageContextData config -> Handlers
resHandlers LanguageContextData config
ctx)
            -- TODO: wrap this up into a fn to create a response message
            res :: ResponseMessage InitializeResponseCapabilities
res  = Text
-> LspIdRsp
-> Either ResponseError InitializeResponseCapabilities
-> ResponseMessage InitializeResponseCapabilities
forall a.
Text -> LspIdRsp -> Either ResponseError a -> ResponseMessage a
J.ResponseMessage Text
"2.0" (LspId -> LspIdRsp
J.responseId LspId
origId) (InitializeResponseCapabilities
-> Either ResponseError InitializeResponseCapabilities
forall a b. b -> Either a b
Right (InitializeResponseCapabilities
 -> Either ResponseError InitializeResponseCapabilities)
-> InitializeResponseCapabilities
-> Either ResponseError InitializeResponseCapabilities
forall a b. (a -> b) -> a -> b
$ InitializeResponseCapabilitiesInner
-> InitializeResponseCapabilities
J.InitializeResponseCapabilities InitializeResponseCapabilitiesInner
capa)

        TVar (LanguageContextData config) -> SendFunc
forall config. TVar (LanguageContextData config) -> SendFunc
sendResponse TVar (LanguageContextData config)
tvarCtx SendFunc -> SendFunc
forall a b. (a -> b) -> a -> b
$ ResponseMessage InitializeResponseCapabilities -> FromServerMessage
RspInitialize ResponseMessage InitializeResponseCapabilities
res

-- | Infers the capabilities based on registered handlers, and sets the appropriate options.
-- A provider should be set to Nothing if the server does not support it, unless it is a
-- static option.
serverCapabilities :: C.ClientCapabilities -> Options -> Handlers -> J.InitializeResponseCapabilitiesInner
serverCapabilities :: ClientCapabilities
-> Options -> Handlers -> InitializeResponseCapabilitiesInner
serverCapabilities ClientCapabilities
clientCaps Options
o Handlers
h =
  InitializeResponseCapabilitiesInner :: Maybe TDS
-> Maybe Bool
-> Maybe CompletionOptions
-> Maybe SignatureHelpOptions
-> Maybe Bool
-> Maybe GotoOptions
-> Maybe GotoOptions
-> Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> Maybe CodeActionOptions
-> Maybe CodeLensOptions
-> Maybe Bool
-> Maybe Bool
-> Maybe DocumentOnTypeFormattingOptions
-> Maybe RenameOptions
-> Maybe DocumentLinkOptions
-> Maybe ColorOptions
-> Maybe FoldingRangeOptions
-> Maybe ExecuteCommandOptions
-> Maybe WorkspaceOptions
-> Maybe Value
-> InitializeResponseCapabilitiesInner
J.InitializeResponseCapabilitiesInner
    { $sel:_textDocumentSync:InitializeResponseCapabilitiesInner :: Maybe TDS
J._textDocumentSync                 = Maybe TDS
sync
    , $sel:_hoverProvider:InitializeResponseCapabilitiesInner :: Maybe Bool
J._hoverProvider                    = Maybe (Handler HoverRequest) -> Maybe Bool
forall a. Maybe a -> Maybe Bool
supported (Handlers -> Maybe (Handler HoverRequest)
hoverHandler Handlers
h)
    , $sel:_completionProvider:InitializeResponseCapabilitiesInner :: Maybe CompletionOptions
J._completionProvider               = Maybe CompletionOptions
completionProvider
    , $sel:_signatureHelpProvider:InitializeResponseCapabilitiesInner :: Maybe SignatureHelpOptions
J._signatureHelpProvider            = Maybe SignatureHelpOptions
signatureHelpProvider
    , $sel:_definitionProvider:InitializeResponseCapabilitiesInner :: Maybe Bool
J._definitionProvider               = Maybe (Handler DefinitionRequest) -> Maybe Bool
forall a. Maybe a -> Maybe Bool
supported (Handlers -> Maybe (Handler DefinitionRequest)
definitionHandler Handlers
h)
    , $sel:_typeDefinitionProvider:InitializeResponseCapabilitiesInner :: Maybe GotoOptions
J._typeDefinitionProvider           = GotoOptions -> Maybe GotoOptions
forall a. a -> Maybe a
Just (GotoOptions -> Maybe GotoOptions)
-> GotoOptions -> Maybe GotoOptions
forall a b. (a -> b) -> a -> b
$ Bool -> GotoOptions
J.GotoOptionsStatic (Bool -> GotoOptions) -> Bool -> GotoOptions
forall a b. (a -> b) -> a -> b
$ Maybe (Handler DefinitionRequest) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Handler DefinitionRequest) -> Bool)
-> Maybe (Handler DefinitionRequest) -> Bool
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler DefinitionRequest)
typeDefinitionHandler Handlers
h
    , $sel:_implementationProvider:InitializeResponseCapabilitiesInner :: Maybe GotoOptions
J._implementationProvider           = GotoOptions -> Maybe GotoOptions
forall a. a -> Maybe a
Just (GotoOptions -> Maybe GotoOptions)
-> GotoOptions -> Maybe GotoOptions
forall a b. (a -> b) -> a -> b
$ Bool -> GotoOptions
J.GotoOptionsStatic (Bool -> GotoOptions) -> Bool -> GotoOptions
forall a b. (a -> b) -> a -> b
$ Maybe (Handler DefinitionRequest) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Handler DefinitionRequest) -> Bool)
-> Maybe (Handler DefinitionRequest) -> Bool
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler DefinitionRequest)
typeDefinitionHandler Handlers
h
    , $sel:_referencesProvider:InitializeResponseCapabilitiesInner :: Maybe Bool
J._referencesProvider               = Maybe (Handler ReferencesRequest) -> Maybe Bool
forall a. Maybe a -> Maybe Bool
supported (Handlers -> Maybe (Handler ReferencesRequest)
referencesHandler Handlers
h)
    , $sel:_documentHighlightProvider:InitializeResponseCapabilitiesInner :: Maybe Bool
J._documentHighlightProvider        = Maybe (Handler DocumentHighlightRequest) -> Maybe Bool
forall a. Maybe a -> Maybe Bool
supported (Handlers -> Maybe (Handler DocumentHighlightRequest)
documentHighlightHandler Handlers
h)
    , $sel:_documentSymbolProvider:InitializeResponseCapabilitiesInner :: Maybe Bool
J._documentSymbolProvider           = Maybe (Handler DocumentSymbolRequest) -> Maybe Bool
forall a. Maybe a -> Maybe Bool
supported (Handlers -> Maybe (Handler DocumentSymbolRequest)
documentSymbolHandler Handlers
h)
    , $sel:_workspaceSymbolProvider:InitializeResponseCapabilitiesInner :: Maybe Bool
J._workspaceSymbolProvider          = Maybe (Handler WorkspaceSymbolRequest) -> Maybe Bool
forall a. Maybe a -> Maybe Bool
supported (Handlers -> Maybe (Handler WorkspaceSymbolRequest)
workspaceSymbolHandler Handlers
h)
    , $sel:_codeActionProvider:InitializeResponseCapabilitiesInner :: Maybe CodeActionOptions
J._codeActionProvider               = Maybe CodeActionOptions
codeActionProvider
    , $sel:_codeLensProvider:InitializeResponseCapabilitiesInner :: Maybe CodeLensOptions
J._codeLensProvider                 = Maybe (Handler CodeLensRequest)
-> CodeLensOptions -> Maybe CodeLensOptions
forall a a. Maybe a -> a -> Maybe a
supported' (Handlers -> Maybe (Handler CodeLensRequest)
codeLensHandler Handlers
h) (CodeLensOptions -> Maybe CodeLensOptions)
-> CodeLensOptions -> Maybe CodeLensOptions
forall a b. (a -> b) -> a -> b
$ Maybe Bool -> CodeLensOptions
J.CodeLensOptions (Maybe Bool -> CodeLensOptions) -> Maybe Bool -> CodeLensOptions
forall a b. (a -> b) -> a -> b
$
                                              Maybe (Handler CodeLensResolveRequest) -> Maybe Bool
forall a. Maybe a -> Maybe Bool
supported (Handlers -> Maybe (Handler CodeLensResolveRequest)
codeLensResolveHandler Handlers
h)
    , $sel:_documentFormattingProvider:InitializeResponseCapabilitiesInner :: Maybe Bool
J._documentFormattingProvider       = Maybe (Handler DocumentFormattingRequest) -> Maybe Bool
forall a. Maybe a -> Maybe Bool
supported (Handlers -> Maybe (Handler DocumentFormattingRequest)
documentFormattingHandler Handlers
h)
    , $sel:_documentRangeFormattingProvider:InitializeResponseCapabilitiesInner :: Maybe Bool
J._documentRangeFormattingProvider  = Maybe (Handler DocumentRangeFormattingRequest) -> Maybe Bool
forall a. Maybe a -> Maybe Bool
supported (Handlers -> Maybe (Handler DocumentRangeFormattingRequest)
documentRangeFormattingHandler Handlers
h)
    , $sel:_documentOnTypeFormattingProvider:InitializeResponseCapabilitiesInner :: Maybe DocumentOnTypeFormattingOptions
J._documentOnTypeFormattingProvider = Maybe DocumentOnTypeFormattingOptions
documentOnTypeFormattingProvider
    , $sel:_renameProvider:InitializeResponseCapabilitiesInner :: Maybe RenameOptions
J._renameProvider                   = RenameOptions -> Maybe RenameOptions
forall a. a -> Maybe a
Just (RenameOptions -> Maybe RenameOptions)
-> RenameOptions -> Maybe RenameOptions
forall a b. (a -> b) -> a -> b
$ Bool -> RenameOptions
J.RenameOptionsStatic (Bool -> RenameOptions) -> Bool -> RenameOptions
forall a b. (a -> b) -> a -> b
$ Maybe (Handler RenameRequest) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Handler RenameRequest) -> Bool)
-> Maybe (Handler RenameRequest) -> Bool
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler RenameRequest)
renameHandler Handlers
h
    , $sel:_documentLinkProvider:InitializeResponseCapabilitiesInner :: Maybe DocumentLinkOptions
J._documentLinkProvider             = Maybe (Handler DocumentLinkRequest)
-> DocumentLinkOptions -> Maybe DocumentLinkOptions
forall a a. Maybe a -> a -> Maybe a
supported' (Handlers -> Maybe (Handler DocumentLinkRequest)
documentLinkHandler Handlers
h) (DocumentLinkOptions -> Maybe DocumentLinkOptions)
-> DocumentLinkOptions -> Maybe DocumentLinkOptions
forall a b. (a -> b) -> a -> b
$ Maybe Bool -> DocumentLinkOptions
J.DocumentLinkOptions (Maybe Bool -> DocumentLinkOptions)
-> Maybe Bool -> DocumentLinkOptions
forall a b. (a -> b) -> a -> b
$
                                              Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ Maybe (Handler DocumentLinkResolveRequest) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Handler DocumentLinkResolveRequest) -> Bool)
-> Maybe (Handler DocumentLinkResolveRequest) -> Bool
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler DocumentLinkResolveRequest)
documentLinkResolveHandler Handlers
h
    , $sel:_colorProvider:InitializeResponseCapabilitiesInner :: Maybe ColorOptions
J._colorProvider                    = ColorOptions -> Maybe ColorOptions
forall a. a -> Maybe a
Just (ColorOptions -> Maybe ColorOptions)
-> ColorOptions -> Maybe ColorOptions
forall a b. (a -> b) -> a -> b
$ Bool -> ColorOptions
J.ColorOptionsStatic (Bool -> ColorOptions) -> Bool -> ColorOptions
forall a b. (a -> b) -> a -> b
$ Maybe (Handler DocumentColorRequest) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Handler DocumentColorRequest) -> Bool)
-> Maybe (Handler DocumentColorRequest) -> Bool
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler DocumentColorRequest)
documentColorHandler Handlers
h
    , $sel:_foldingRangeProvider:InitializeResponseCapabilitiesInner :: Maybe FoldingRangeOptions
J._foldingRangeProvider             = FoldingRangeOptions -> Maybe FoldingRangeOptions
forall a. a -> Maybe a
Just (FoldingRangeOptions -> Maybe FoldingRangeOptions)
-> FoldingRangeOptions -> Maybe FoldingRangeOptions
forall a b. (a -> b) -> a -> b
$ Bool -> FoldingRangeOptions
J.FoldingRangeOptionsStatic (Bool -> FoldingRangeOptions) -> Bool -> FoldingRangeOptions
forall a b. (a -> b) -> a -> b
$ Maybe (Handler FoldingRangeRequest) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Handler FoldingRangeRequest) -> Bool)
-> Maybe (Handler FoldingRangeRequest) -> Bool
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler FoldingRangeRequest)
foldingRangeHandler Handlers
h
    , $sel:_executeCommandProvider:InitializeResponseCapabilitiesInner :: Maybe ExecuteCommandOptions
J._executeCommandProvider           = Maybe ExecuteCommandOptions
executeCommandProvider
    , $sel:_workspace:InitializeResponseCapabilitiesInner :: Maybe WorkspaceOptions
J._workspace                        = WorkspaceOptions -> Maybe WorkspaceOptions
forall a. a -> Maybe a
Just WorkspaceOptions
workspace
    -- TODO: Add something for experimental
    , $sel:_experimental:InitializeResponseCapabilitiesInner :: Maybe Value
J._experimental                     = Maybe Value
forall a. Maybe a
Nothing :: Maybe J.Value
    }
  where
    supported :: Maybe a -> Maybe Bool
supported Maybe a
x = Maybe a -> Bool -> Maybe Bool
forall a a. Maybe a -> a -> Maybe a
supported' Maybe a
x Bool
True

    supported' :: Maybe a -> a -> Maybe a
supported' (Just a
_) = a -> Maybe a
forall a. a -> Maybe a
Just
    supported' Maybe a
Nothing = Maybe a -> a -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing

    singleton :: a -> [a]
    singleton :: a -> [a]
singleton a
x = [a
x]

    completionProvider :: Maybe CompletionOptions
completionProvider
      | Maybe (Handler CompletionRequest) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Handler CompletionRequest) -> Bool)
-> Maybe (Handler CompletionRequest) -> Bool
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler CompletionRequest)
completionHandler Handlers
h = CompletionOptions -> Maybe CompletionOptions
forall a. a -> Maybe a
Just (CompletionOptions -> Maybe CompletionOptions)
-> CompletionOptions -> Maybe CompletionOptions
forall a b. (a -> b) -> a -> b
$
          Maybe Bool
-> Maybe [FilePath] -> Maybe [FilePath] -> CompletionOptions
J.CompletionOptions
            (Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ Maybe (Handler CompletionItemResolveRequest) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Handler CompletionItemResolveRequest) -> Bool)
-> Maybe (Handler CompletionItemResolveRequest) -> Bool
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler CompletionItemResolveRequest)
completionResolveHandler Handlers
h)
            ((Char -> FilePath) -> FilePath -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Char -> FilePath
forall a. a -> [a]
singleton (FilePath -> [FilePath]) -> Maybe FilePath -> Maybe [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Maybe FilePath
completionTriggerCharacters Options
o)
            ((Char -> FilePath) -> FilePath -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Char -> FilePath
forall a. a -> [a]
singleton (FilePath -> [FilePath]) -> Maybe FilePath -> Maybe [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Maybe FilePath
completionAllCommitCharacters Options
o)
      | Bool
otherwise = Maybe CompletionOptions
forall a. Maybe a
Nothing

    clientSupportsCodeActionKinds :: Bool
clientSupportsCodeActionKinds = Maybe (Maybe CodeActionLiteralSupport) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Maybe CodeActionLiteralSupport) -> Bool)
-> Maybe (Maybe CodeActionLiteralSupport) -> Bool
forall a b. (a -> b) -> a -> b
$
      ClientCapabilities
clientCaps ClientCapabilities
-> Getting
     (First (Maybe CodeActionLiteralSupport))
     ClientCapabilities
     (Maybe CodeActionLiteralSupport)
-> Maybe (Maybe CodeActionLiteralSupport)
forall s a. s -> Getting (First a) s a -> Maybe a
^? (Maybe TextDocumentClientCapabilities
 -> Const
      (First (Maybe CodeActionLiteralSupport))
      (Maybe TextDocumentClientCapabilities))
-> ClientCapabilities
-> Const
     (First (Maybe CodeActionLiteralSupport)) ClientCapabilities
forall s a. HasTextDocument s a => Lens' s a
J.textDocument ((Maybe TextDocumentClientCapabilities
  -> Const
       (First (Maybe CodeActionLiteralSupport))
       (Maybe TextDocumentClientCapabilities))
 -> ClientCapabilities
 -> Const
      (First (Maybe CodeActionLiteralSupport)) ClientCapabilities)
-> ((Maybe CodeActionLiteralSupport
     -> Const
          (First (Maybe CodeActionLiteralSupport))
          (Maybe CodeActionLiteralSupport))
    -> Maybe TextDocumentClientCapabilities
    -> Const
         (First (Maybe CodeActionLiteralSupport))
         (Maybe TextDocumentClientCapabilities))
-> Getting
     (First (Maybe CodeActionLiteralSupport))
     ClientCapabilities
     (Maybe CodeActionLiteralSupport)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentClientCapabilities
 -> Const
      (First (Maybe CodeActionLiteralSupport))
      TextDocumentClientCapabilities)
-> Maybe TextDocumentClientCapabilities
-> Const
     (First (Maybe CodeActionLiteralSupport))
     (Maybe TextDocumentClientCapabilities)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((TextDocumentClientCapabilities
  -> Const
       (First (Maybe CodeActionLiteralSupport))
       TextDocumentClientCapabilities)
 -> Maybe TextDocumentClientCapabilities
 -> Const
      (First (Maybe CodeActionLiteralSupport))
      (Maybe TextDocumentClientCapabilities))
-> ((Maybe CodeActionLiteralSupport
     -> Const
          (First (Maybe CodeActionLiteralSupport))
          (Maybe CodeActionLiteralSupport))
    -> TextDocumentClientCapabilities
    -> Const
         (First (Maybe CodeActionLiteralSupport))
         TextDocumentClientCapabilities)
-> (Maybe CodeActionLiteralSupport
    -> Const
         (First (Maybe CodeActionLiteralSupport))
         (Maybe CodeActionLiteralSupport))
-> Maybe TextDocumentClientCapabilities
-> Const
     (First (Maybe CodeActionLiteralSupport))
     (Maybe TextDocumentClientCapabilities)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe CodeActionClientCapabilities
 -> Const
      (First (Maybe CodeActionLiteralSupport))
      (Maybe CodeActionClientCapabilities))
-> TextDocumentClientCapabilities
-> Const
     (First (Maybe CodeActionLiteralSupport))
     TextDocumentClientCapabilities
forall s a. HasCodeAction s a => Lens' s a
J.codeAction ((Maybe CodeActionClientCapabilities
  -> Const
       (First (Maybe CodeActionLiteralSupport))
       (Maybe CodeActionClientCapabilities))
 -> TextDocumentClientCapabilities
 -> Const
      (First (Maybe CodeActionLiteralSupport))
      TextDocumentClientCapabilities)
-> ((Maybe CodeActionLiteralSupport
     -> Const
          (First (Maybe CodeActionLiteralSupport))
          (Maybe CodeActionLiteralSupport))
    -> Maybe CodeActionClientCapabilities
    -> Const
         (First (Maybe CodeActionLiteralSupport))
         (Maybe CodeActionClientCapabilities))
-> (Maybe CodeActionLiteralSupport
    -> Const
         (First (Maybe CodeActionLiteralSupport))
         (Maybe CodeActionLiteralSupport))
-> TextDocumentClientCapabilities
-> Const
     (First (Maybe CodeActionLiteralSupport))
     TextDocumentClientCapabilities
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CodeActionClientCapabilities
 -> Const
      (First (Maybe CodeActionLiteralSupport))
      CodeActionClientCapabilities)
-> Maybe CodeActionClientCapabilities
-> Const
     (First (Maybe CodeActionLiteralSupport))
     (Maybe CodeActionClientCapabilities)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((CodeActionClientCapabilities
  -> Const
       (First (Maybe CodeActionLiteralSupport))
       CodeActionClientCapabilities)
 -> Maybe CodeActionClientCapabilities
 -> Const
      (First (Maybe CodeActionLiteralSupport))
      (Maybe CodeActionClientCapabilities))
-> ((Maybe CodeActionLiteralSupport
     -> Const
          (First (Maybe CodeActionLiteralSupport))
          (Maybe CodeActionLiteralSupport))
    -> CodeActionClientCapabilities
    -> Const
         (First (Maybe CodeActionLiteralSupport))
         CodeActionClientCapabilities)
-> (Maybe CodeActionLiteralSupport
    -> Const
         (First (Maybe CodeActionLiteralSupport))
         (Maybe CodeActionLiteralSupport))
-> Maybe CodeActionClientCapabilities
-> Const
     (First (Maybe CodeActionLiteralSupport))
     (Maybe CodeActionClientCapabilities)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe CodeActionLiteralSupport
 -> Const
      (First (Maybe CodeActionLiteralSupport))
      (Maybe CodeActionLiteralSupport))
-> CodeActionClientCapabilities
-> Const
     (First (Maybe CodeActionLiteralSupport))
     CodeActionClientCapabilities
forall s a. HasCodeActionLiteralSupport s a => Lens' s a
J.codeActionLiteralSupport

    codeActionProvider :: Maybe CodeActionOptions
codeActionProvider
      | Bool
clientSupportsCodeActionKinds
      , Maybe (Handler CodeActionRequest) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Handler CodeActionRequest) -> Bool)
-> Maybe (Handler CodeActionRequest) -> Bool
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler CodeActionRequest)
codeActionHandler Handlers
h = CodeActionOptions -> Maybe CodeActionOptions
forall a. a -> Maybe a
Just (CodeActionOptions -> Maybe CodeActionOptions)
-> CodeActionOptions -> Maybe CodeActionOptions
forall a b. (a -> b) -> a -> b
$ CodeActionOptions
-> ([CodeActionKind] -> CodeActionOptions)
-> Maybe [CodeActionKind]
-> CodeActionOptions
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> CodeActionOptions
J.CodeActionOptionsStatic Bool
True) (Maybe [CodeActionKind] -> CodeActionOptions
J.CodeActionOptions (Maybe [CodeActionKind] -> CodeActionOptions)
-> ([CodeActionKind] -> Maybe [CodeActionKind])
-> [CodeActionKind]
-> CodeActionOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CodeActionKind] -> Maybe [CodeActionKind]
forall a. a -> Maybe a
Just) (Options -> Maybe [CodeActionKind]
codeActionKinds Options
o)
      | Maybe (Handler CodeActionRequest) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Handler CodeActionRequest) -> Bool)
-> Maybe (Handler CodeActionRequest) -> Bool
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler CodeActionRequest)
codeActionHandler Handlers
h = CodeActionOptions -> Maybe CodeActionOptions
forall a. a -> Maybe a
Just (Bool -> CodeActionOptions
J.CodeActionOptionsStatic Bool
True)
      | Bool
otherwise = CodeActionOptions -> Maybe CodeActionOptions
forall a. a -> Maybe a
Just (Bool -> CodeActionOptions
J.CodeActionOptionsStatic Bool
False)

    signatureHelpProvider :: Maybe SignatureHelpOptions
signatureHelpProvider
      | Maybe (Handler SignatureHelpRequest) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Handler SignatureHelpRequest) -> Bool)
-> Maybe (Handler SignatureHelpRequest) -> Bool
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler SignatureHelpRequest)
signatureHelpHandler Handlers
h = SignatureHelpOptions -> Maybe SignatureHelpOptions
forall a. a -> Maybe a
Just (SignatureHelpOptions -> Maybe SignatureHelpOptions)
-> SignatureHelpOptions -> Maybe SignatureHelpOptions
forall a b. (a -> b) -> a -> b
$
          Maybe [FilePath] -> Maybe [FilePath] -> SignatureHelpOptions
J.SignatureHelpOptions
            ((Char -> FilePath) -> FilePath -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Char -> FilePath
forall a. a -> [a]
singleton (FilePath -> [FilePath]) -> Maybe FilePath -> Maybe [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Maybe FilePath
signatureHelpTriggerCharacters Options
o)
            ((Char -> FilePath) -> FilePath -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Char -> FilePath
forall a. a -> [a]
singleton (FilePath -> [FilePath]) -> Maybe FilePath -> Maybe [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Maybe FilePath
signatureHelpRetriggerCharacters Options
o)
      | Bool
otherwise = Maybe SignatureHelpOptions
forall a. Maybe a
Nothing

    documentOnTypeFormattingProvider :: Maybe DocumentOnTypeFormattingOptions
documentOnTypeFormattingProvider
      | Maybe (Handler DocumentOnTypeFormattingRequest) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Handler DocumentOnTypeFormattingRequest) -> Bool)
-> Maybe (Handler DocumentOnTypeFormattingRequest) -> Bool
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler DocumentOnTypeFormattingRequest)
documentOnTypeFormattingHandler Handlers
h
      , Just (Char
first :| FilePath
rest) <- Options -> Maybe (NonEmpty Char)
documentOnTypeFormattingTriggerCharacters Options
o = DocumentOnTypeFormattingOptions
-> Maybe DocumentOnTypeFormattingOptions
forall a. a -> Maybe a
Just (DocumentOnTypeFormattingOptions
 -> Maybe DocumentOnTypeFormattingOptions)
-> DocumentOnTypeFormattingOptions
-> Maybe DocumentOnTypeFormattingOptions
forall a b. (a -> b) -> a -> b
$
          Text -> Maybe [Text] -> DocumentOnTypeFormattingOptions
J.DocumentOnTypeFormattingOptions (FilePath -> Text
T.pack [Char
first]) ([Text] -> Maybe [Text]
forall a. a -> Maybe a
Just ((Char -> Text) -> FilePath -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Text
T.pack (FilePath -> Text) -> (Char -> FilePath) -> Char -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> FilePath
forall a. a -> [a]
singleton) FilePath
rest))
      | Maybe (Handler DocumentOnTypeFormattingRequest) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Handler DocumentOnTypeFormattingRequest) -> Bool)
-> Maybe (Handler DocumentOnTypeFormattingRequest) -> Bool
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler DocumentOnTypeFormattingRequest)
documentOnTypeFormattingHandler Handlers
h
      , Maybe (NonEmpty Char)
Nothing <- Options -> Maybe (NonEmpty Char)
documentOnTypeFormattingTriggerCharacters Options
o =
          FilePath -> Maybe DocumentOnTypeFormattingOptions
forall a. HasCallStack => FilePath -> a
error FilePath
"documentOnTypeFormattingTriggerCharacters needs to be set if a documentOnTypeFormattingHandler is set"
      | Bool
otherwise = Maybe DocumentOnTypeFormattingOptions
forall a. Maybe a
Nothing

    executeCommandProvider :: Maybe ExecuteCommandOptions
executeCommandProvider
      | Maybe (Handler ExecuteCommandRequest) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Handler ExecuteCommandRequest) -> Bool)
-> Maybe (Handler ExecuteCommandRequest) -> Bool
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler ExecuteCommandRequest)
executeCommandHandler Handlers
h
      , Just [Text]
cmds <- Options -> Maybe [Text]
executeCommandCommands Options
o = ExecuteCommandOptions -> Maybe ExecuteCommandOptions
forall a. a -> Maybe a
Just (List Text -> ExecuteCommandOptions
J.ExecuteCommandOptions ([Text] -> List Text
forall a. [a] -> List a
J.List [Text]
cmds))
      | Maybe (Handler ExecuteCommandRequest) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Handler ExecuteCommandRequest) -> Bool)
-> Maybe (Handler ExecuteCommandRequest) -> Bool
forall a b. (a -> b) -> a -> b
$ Handlers -> Maybe (Handler ExecuteCommandRequest)
executeCommandHandler Handlers
h
      , Maybe [Text]
Nothing <- Options -> Maybe [Text]
executeCommandCommands Options
o =
          FilePath -> Maybe ExecuteCommandOptions
forall a. HasCallStack => FilePath -> a
error FilePath
"executeCommandCommands needs to be set if a executeCommandHandler is set"
      | Bool
otherwise = Maybe ExecuteCommandOptions
forall a. Maybe a
Nothing

    sync :: Maybe TDS
sync = case Options -> Maybe TextDocumentSyncOptions
textDocumentSync Options
o of
            Just TextDocumentSyncOptions
x -> TDS -> Maybe TDS
forall a. a -> Maybe a
Just (TextDocumentSyncOptions -> TDS
J.TDSOptions TextDocumentSyncOptions
x)
            Maybe TextDocumentSyncOptions
Nothing -> Maybe TDS
forall a. Maybe a
Nothing

    workspace :: WorkspaceOptions
workspace = Maybe WorkspaceFolderOptions -> WorkspaceOptions
J.WorkspaceOptions Maybe WorkspaceFolderOptions
workspaceFolder
    workspaceFolder :: Maybe WorkspaceFolderOptions
workspaceFolder = case Handlers -> Maybe (Handler DidChangeWorkspaceFoldersNotification)
didChangeWorkspaceFoldersNotificationHandler Handlers
h of
      Just Handler DidChangeWorkspaceFoldersNotification
_ -> WorkspaceFolderOptions -> Maybe WorkspaceFolderOptions
forall a. a -> Maybe a
Just (WorkspaceFolderOptions -> Maybe WorkspaceFolderOptions)
-> WorkspaceFolderOptions -> Maybe WorkspaceFolderOptions
forall a b. (a -> b) -> a -> b
$
        -- sign up to receive notifications
        Maybe Bool
-> Maybe WorkspaceFolderChangeNotifications
-> WorkspaceFolderOptions
J.WorkspaceFolderOptions (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) (WorkspaceFolderChangeNotifications
-> Maybe WorkspaceFolderChangeNotifications
forall a. a -> Maybe a
Just (Bool -> WorkspaceFolderChangeNotifications
J.WorkspaceFolderChangeNotificationsBool Bool
True))
      Maybe (Handler DidChangeWorkspaceFoldersNotification)
Nothing -> Maybe WorkspaceFolderOptions
forall a. Maybe a
Nothing

progressCancelHandler :: TVar (LanguageContextData config) -> J.WorkDoneProgressCancelNotification -> IO ()
progressCancelHandler :: TVar (LanguageContextData config)
-> WorkDoneProgressCancelNotification -> IO ()
progressCancelHandler TVar (LanguageContextData config)
tvarCtx (J.NotificationMessage Text
_ ClientMethod
_ (J.WorkDoneProgressCancelParams ProgressToken
tid)) = do
  Maybe (IO ())
mact <- ProgressToken -> Map ProgressToken (IO ()) -> Maybe (IO ())
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ProgressToken
tid (Map ProgressToken (IO ()) -> Maybe (IO ()))
-> (LanguageContextData config -> Map ProgressToken (IO ()))
-> LanguageContextData config
-> Maybe (IO ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgressData -> Map ProgressToken (IO ())
progressCancel (ProgressData -> Map ProgressToken (IO ()))
-> (LanguageContextData config -> ProgressData)
-> LanguageContextData config
-> Map ProgressToken (IO ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LanguageContextData config -> ProgressData
forall config. LanguageContextData config -> ProgressData
resProgressData (LanguageContextData config -> Maybe (IO ()))
-> IO (LanguageContextData config) -> IO (Maybe (IO ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (LanguageContextData config)
-> IO (LanguageContextData config)
forall a. TVar a -> IO a
readTVarIO TVar (LanguageContextData config)
tvarCtx
  case Maybe (IO ())
mact of
    Maybe (IO ())
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just IO ()
cancelAction -> IO ()
cancelAction


-- |
--
shutdownRequestHandler :: TVar (LanguageContextData config) -> J.ShutdownRequest -> IO ()
shutdownRequestHandler :: TVar (LanguageContextData config) -> ShutdownRequest -> IO ()
shutdownRequestHandler TVar (LanguageContextData config)
tvarCtx req :: ShutdownRequest
req@(J.RequestMessage Text
_ LspId
origId ClientMethod
_ Maybe Value
_) =
  (IO () -> [Handler ()] -> IO ()) -> [Handler ()] -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> [Handler ()] -> IO ()
forall a. IO a -> [Handler a] -> IO a
E.catches (TVar (LanguageContextData config)
-> LspIdRsp -> ShutdownRequest -> [Handler ()]
forall a config.
Show a =>
TVar (LanguageContextData config) -> LspIdRsp -> a -> [Handler ()]
defaultErrorHandlers TVar (LanguageContextData config)
tvarCtx (LspId -> LspIdRsp
J.responseId LspId
origId) ShutdownRequest
req) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  let res :: ResponseMessage (Maybe ())
res  = ShutdownRequest -> Maybe () -> ResponseMessage (Maybe ())
forall req resp.
RequestMessage ClientMethod req resp
-> resp -> ResponseMessage resp
makeResponseMessage ShutdownRequest
req Maybe ()
forall a. Maybe a
Nothing

  TVar (LanguageContextData config) -> SendFunc
forall config. TVar (LanguageContextData config) -> SendFunc
sendResponse TVar (LanguageContextData config)
tvarCtx SendFunc -> SendFunc
forall a b. (a -> b) -> a -> b
$ ResponseMessage (Maybe ()) -> FromServerMessage
RspShutdown ResponseMessage (Maybe ())
res

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

-- | Take the new diagnostics, update the stored diagnostics for the given file
-- and version, and publish the total to the client.
publishDiagnostics :: TVar (LanguageContextData config) -> PublishDiagnosticsFunc
publishDiagnostics :: TVar (LanguageContextData config) -> PublishDiagnosticsFunc
publishDiagnostics TVar (LanguageContextData config)
tvarDat Int
maxDiagnosticCount NormalizedUri
uri Maybe Int
version DiagnosticsBySource
diags = do
  IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ do
    LanguageContextData config
ctx <- TVar (LanguageContextData config)
-> STM (LanguageContextData config)
forall a. TVar a -> STM a
readTVar TVar (LanguageContextData config)
tvarDat
    let ds :: DiagnosticStore
ds = DiagnosticStore
-> NormalizedUri
-> Maybe Int
-> DiagnosticsBySource
-> DiagnosticStore
updateDiagnostics (LanguageContextData config -> DiagnosticStore
forall config. LanguageContextData config -> DiagnosticStore
resDiagnostics LanguageContextData config
ctx) NormalizedUri
uri Maybe Int
version DiagnosticsBySource
diags
    TVar (LanguageContextData config)
-> LanguageContextData config -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (LanguageContextData config)
tvarDat (LanguageContextData config -> STM ())
-> LanguageContextData config -> STM ()
forall a b. (a -> b) -> a -> b
$ LanguageContextData config
ctx{resDiagnostics :: DiagnosticStore
resDiagnostics = DiagnosticStore
ds}
    let mdp :: Maybe PublishDiagnosticsParams
mdp = Int
-> DiagnosticStore
-> NormalizedUri
-> Maybe PublishDiagnosticsParams
getDiagnosticParamsFor Int
maxDiagnosticCount DiagnosticStore
ds NormalizedUri
uri
    IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ case Maybe PublishDiagnosticsParams
mdp of
      Maybe PublishDiagnosticsParams
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just PublishDiagnosticsParams
params ->
        LanguageContextData config -> SendFunc
forall config. LanguageContextData config -> SendFunc
resSendResponse LanguageContextData config
ctx SendFunc -> SendFunc
forall a b. (a -> b) -> a -> b
$ PublishDiagnosticsNotification -> FromServerMessage
NotPublishDiagnostics
          (PublishDiagnosticsNotification -> FromServerMessage)
-> PublishDiagnosticsNotification -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Text
-> ServerMethod
-> PublishDiagnosticsParams
-> PublishDiagnosticsNotification
forall m a. Text -> m -> a -> NotificationMessage m a
J.NotificationMessage Text
"2.0" ServerMethod
J.TextDocumentPublishDiagnostics PublishDiagnosticsParams
params

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

-- | Take the new diagnostics, update the stored diagnostics for the given file
-- and version, and publish the total to the client.
flushDiagnosticsBySource :: TVar (LanguageContextData config) -> FlushDiagnosticsBySourceFunc
flushDiagnosticsBySource :: TVar (LanguageContextData config) -> FlushDiagnosticsBySourceFunc
flushDiagnosticsBySource TVar (LanguageContextData config)
tvarDat Int
maxDiagnosticCount Maybe Text
msource = IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ do
  -- logs $ "haskell-lsp:flushDiagnosticsBySource:source=" ++ show source
  LanguageContextData config
ctx <- TVar (LanguageContextData config)
-> STM (LanguageContextData config)
forall a. TVar a -> STM a
readTVar TVar (LanguageContextData config)
tvarDat
  let ds :: DiagnosticStore
ds = DiagnosticStore -> Maybe Text -> DiagnosticStore
flushBySource (LanguageContextData config -> DiagnosticStore
forall config. LanguageContextData config -> DiagnosticStore
resDiagnostics LanguageContextData config
ctx) Maybe Text
msource
  TVar (LanguageContextData config)
-> LanguageContextData config -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (LanguageContextData config)
tvarDat (LanguageContextData config -> STM ())
-> LanguageContextData config -> STM ()
forall a b. (a -> b) -> a -> b
$ LanguageContextData config
ctx {resDiagnostics :: DiagnosticStore
resDiagnostics = DiagnosticStore
ds}
  -- Send the updated diagnostics to the client
  IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ [NormalizedUri] -> (NormalizedUri -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (DiagnosticStore -> [NormalizedUri]
forall k v. HashMap k v -> [k]
HM.keys DiagnosticStore
ds) ((NormalizedUri -> IO ()) -> IO ())
-> (NormalizedUri -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \NormalizedUri
uri -> do
    -- logs $ "haskell-lsp:flushDiagnosticsBySource:uri=" ++ show uri
    let mdp :: Maybe PublishDiagnosticsParams
mdp = Int
-> DiagnosticStore
-> NormalizedUri
-> Maybe PublishDiagnosticsParams
getDiagnosticParamsFor Int
maxDiagnosticCount DiagnosticStore
ds NormalizedUri
uri
    case Maybe PublishDiagnosticsParams
mdp of
      Maybe PublishDiagnosticsParams
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just PublishDiagnosticsParams
params -> do
        LanguageContextData config -> SendFunc
forall config. LanguageContextData config -> SendFunc
resSendResponse LanguageContextData config
ctx SendFunc -> SendFunc
forall a b. (a -> b) -> a -> b
$ PublishDiagnosticsNotification -> FromServerMessage
NotPublishDiagnostics
          (PublishDiagnosticsNotification -> FromServerMessage)
-> PublishDiagnosticsNotification -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Text
-> ServerMethod
-> PublishDiagnosticsParams
-> PublishDiagnosticsNotification
forall m a. Text -> m -> a -> NotificationMessage m a
J.NotificationMessage Text
"2.0" ServerMethod
J.TextDocumentPublishDiagnostics PublishDiagnosticsParams
params

-- =====================================================================
--
--  utility


--
--  Logger
--
setupLogger :: Maybe FilePath -> [String] -> Priority -> IO ()
setupLogger :: Maybe FilePath -> [FilePath] -> Priority -> IO ()
setupLogger Maybe FilePath
mLogFile [FilePath]
extraLogNames Priority
level = do

  Handle
logStream <- case Maybe FilePath
mLogFile of
    Just FilePath
logFile -> FilePath -> IOMode -> IO Handle
openFile FilePath
logFile IOMode
AppendMode
    Maybe FilePath
Nothing      -> Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stderr
  Handle -> TextEncoding -> IO ()
hSetEncoding Handle
logStream TextEncoding
utf8

  GenericHandler Handle
logH <- Handle -> Priority -> IO (GenericHandler Handle)
LHS.streamHandler Handle
logStream Priority
level

  let logHandle :: GenericHandler Handle
logHandle  = GenericHandler Handle
logH {closeFunc :: Handle -> IO ()
LHS.closeFunc = Handle -> IO ()
hClose}
      logFormat :: LogFormatter a
logFormat  = FilePath -> FilePath -> LogFormatter a
forall a. FilePath -> FilePath -> LogFormatter a
L.tfLogFormatter FilePath
_LOG_FORMAT_DATE FilePath
_LOG_FORMAT
      logHandler :: GenericHandler Handle
logHandler = GenericHandler Handle
-> LogFormatter (GenericHandler Handle) -> GenericHandler Handle
forall a. LogHandler a => a -> LogFormatter a -> a
LH.setFormatter GenericHandler Handle
logHandle LogFormatter (GenericHandler Handle)
forall a. LogFormatter a
logFormat

  FilePath -> (Logger -> Logger) -> IO ()
L.updateGlobalLogger FilePath
L.rootLoggerName ((Logger -> Logger) -> IO ()) -> (Logger -> Logger) -> IO ()
forall a b. (a -> b) -> a -> b
$ [GenericHandler Handle] -> Logger -> Logger
forall a. LogHandler a => [a] -> Logger -> Logger
L.setHandlers ([] :: [LHS.GenericHandler Handle])
  FilePath -> (Logger -> Logger) -> IO ()
L.updateGlobalLogger FilePath
_LOG_NAME ((Logger -> Logger) -> IO ()) -> (Logger -> Logger) -> IO ()
forall a b. (a -> b) -> a -> b
$ [GenericHandler Handle] -> Logger -> Logger
forall a. LogHandler a => [a] -> Logger -> Logger
L.setHandlers [GenericHandler Handle
logHandler]
  FilePath -> (Logger -> Logger) -> IO ()
L.updateGlobalLogger FilePath
_LOG_NAME ((Logger -> Logger) -> IO ()) -> (Logger -> Logger) -> IO ()
forall a b. (a -> b) -> a -> b
$ Priority -> Logger -> Logger
L.setLevel Priority
level

  -- Also route the additional log names to the same log
  [FilePath] -> (FilePath -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
extraLogNames ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
logName -> do
    FilePath -> (Logger -> Logger) -> IO ()
L.updateGlobalLogger FilePath
logName ((Logger -> Logger) -> IO ()) -> (Logger -> Logger) -> IO ()
forall a b. (a -> b) -> a -> b
$ [GenericHandler Handle] -> Logger -> Logger
forall a. LogHandler a => [a] -> Logger -> Logger
L.setHandlers [GenericHandler Handle
logHandler]
    FilePath -> (Logger -> Logger) -> IO ()
L.updateGlobalLogger FilePath
logName ((Logger -> Logger) -> IO ()) -> (Logger -> Logger) -> IO ()
forall a b. (a -> b) -> a -> b
$ Priority -> Logger -> Logger
L.setLevel Priority
level


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

-- | The changes in a workspace edit should be applied from the end of the file
-- toward the start. Sort them into this order.
reverseSortEdit :: J.WorkspaceEdit -> J.WorkspaceEdit
reverseSortEdit :: WorkspaceEdit -> WorkspaceEdit
reverseSortEdit (J.WorkspaceEdit Maybe WorkspaceEditMap
cs Maybe (List TextDocumentEdit)
dcs) = Maybe WorkspaceEditMap
-> Maybe (List TextDocumentEdit) -> WorkspaceEdit
J.WorkspaceEdit Maybe WorkspaceEditMap
cs' Maybe (List TextDocumentEdit)
dcs'
  where
    cs' :: Maybe J.WorkspaceEditMap
    cs' :: Maybe WorkspaceEditMap
cs' = ((WorkspaceEditMap -> WorkspaceEditMap)
-> Maybe WorkspaceEditMap -> Maybe WorkspaceEditMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((WorkspaceEditMap -> WorkspaceEditMap)
 -> Maybe WorkspaceEditMap -> Maybe WorkspaceEditMap)
-> ((List TextEdit -> List TextEdit)
    -> WorkspaceEditMap -> WorkspaceEditMap)
-> (List TextEdit -> List TextEdit)
-> Maybe WorkspaceEditMap
-> Maybe WorkspaceEditMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (List TextEdit -> List TextEdit)
-> WorkspaceEditMap -> WorkspaceEditMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ) List TextEdit -> List TextEdit
sortTextEdits Maybe WorkspaceEditMap
cs

    dcs' :: Maybe (J.List J.TextDocumentEdit)
    dcs' :: Maybe (List TextDocumentEdit)
dcs' = ((List TextDocumentEdit -> List TextDocumentEdit)
-> Maybe (List TextDocumentEdit) -> Maybe (List TextDocumentEdit)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((List TextDocumentEdit -> List TextDocumentEdit)
 -> Maybe (List TextDocumentEdit) -> Maybe (List TextDocumentEdit))
-> ((TextDocumentEdit -> TextDocumentEdit)
    -> List TextDocumentEdit -> List TextDocumentEdit)
-> (TextDocumentEdit -> TextDocumentEdit)
-> Maybe (List TextDocumentEdit)
-> Maybe (List TextDocumentEdit)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentEdit -> TextDocumentEdit)
-> List TextDocumentEdit -> List TextDocumentEdit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ) TextDocumentEdit -> TextDocumentEdit
sortTextDocumentEdits Maybe (List TextDocumentEdit)
dcs

    sortTextEdits :: J.List J.TextEdit -> J.List J.TextEdit
    sortTextEdits :: List TextEdit -> List TextEdit
sortTextEdits (J.List [TextEdit]
edits) = [TextEdit] -> List TextEdit
forall a. [a] -> List a
J.List ((TextEdit -> TextEdit -> Ordering) -> [TextEdit] -> [TextEdit]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy TextEdit -> TextEdit -> Ordering
down [TextEdit]
edits)

    sortTextDocumentEdits :: J.TextDocumentEdit -> J.TextDocumentEdit
    sortTextDocumentEdits :: TextDocumentEdit -> TextDocumentEdit
sortTextDocumentEdits (J.TextDocumentEdit VersionedTextDocumentIdentifier
td (J.List [TextEdit]
edits)) = VersionedTextDocumentIdentifier
-> List TextEdit -> TextDocumentEdit
J.TextDocumentEdit VersionedTextDocumentIdentifier
td ([TextEdit] -> List TextEdit
forall a. [a] -> List a
J.List [TextEdit]
edits')
      where
        edits' :: [TextEdit]
edits' = (TextEdit -> TextEdit -> Ordering) -> [TextEdit] -> [TextEdit]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy TextEdit -> TextEdit -> Ordering
down [TextEdit]
edits

    down :: TextEdit -> TextEdit -> Ordering
down (J.TextEdit Range
r1 Text
_) (J.TextEdit Range
r2 Text
_) = Range
r2 Range -> Range -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Range
r1