-- Copyright (c) 2019 The DAML Authors. All rights reserved.

-- SPDX-License-Identifier: Apache-2.0


{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE PolyKinds             #-}

module Development.IDE.LSP.Notifications
    ( setHandlersNotifications
    ) where

import qualified Language.LSP.Server      as LSP
import           Language.LSP.Types
import qualified Language.LSP.Types       as LSP
import qualified Language.LSP.Types.Capabilities as LSP

import           Development.IDE.Core.IdeConfiguration
import           Development.IDE.Core.Service
import           Development.IDE.LSP.Server
import           Development.IDE.Core.Shake
import           Development.IDE.Types.Location
import           Development.IDE.Types.Logger
import           Development.IDE.Types.Options

import           Control.Monad.Extra
import           Data.Foldable                    as F
import           Data.Maybe
import qualified Data.HashMap.Strict              as M
import qualified Data.HashSet                     as S
import qualified Data.Text                        as Text

import           Development.IDE.Core.FileStore   (setSomethingModified, setFileModified, typecheckParents)
import           Development.IDE.Core.FileExists  (modifyFileExists, watchedGlobs)
import           Development.IDE.Core.OfInterest
import Ide.Plugin.Config (CheckParents(CheckOnClose))
import Control.Monad.IO.Class


whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
whenUriFile Uri
uri NormalizedFilePath -> IO ()
act = Maybe FilePath -> (FilePath -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (Uri -> Maybe FilePath
LSP.uriToFilePath Uri
uri) ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> IO ()
act (NormalizedFilePath -> IO ())
-> (FilePath -> NormalizedFilePath) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> NormalizedFilePath
toNormalizedFilePath'

setHandlersNotifications :: LSP.Handlers (ServerM c)
setHandlersNotifications :: Handlers (ServerM c)
setHandlersNotifications = [Handlers (ServerM c)] -> Handlers (ServerM c)
forall a. Monoid a => [a] -> a
mconcat
  [ SMethod 'TextDocumentDidOpen
-> (IdeState -> MessageParams 'TextDocumentDidOpen -> LspM c ())
-> Handlers (ServerM c)
forall (m :: Method 'FromClient 'Notification) c.
HasTracing (MessageParams m) =>
SMethod m
-> (IdeState -> MessageParams m -> LspM c ())
-> Handlers (ServerM c)
notificationHandler SMethod 'TextDocumentDidOpen
LSP.STextDocumentDidOpen ((IdeState -> MessageParams 'TextDocumentDidOpen -> LspM c ())
 -> Handlers (ServerM c))
-> (IdeState -> MessageParams 'TextDocumentDidOpen -> LspM c ())
-> Handlers (ServerM c)
forall a b. (a -> b) -> a -> b
$
      \IdeState
ide (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> IO () -> LspM c ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspM c ()) -> IO () -> LspM c ()
forall a b. (a -> b) -> a -> b
$ do
      IdeState
-> VersionedTextDocumentIdentifier
-> List TextDocumentContentChangeEvent
-> IO ()
updatePositionMapping IdeState
ide (Uri -> TextDocumentVersion -> VersionedTextDocumentIdentifier
VersionedTextDocumentIdentifier Uri
_uri (Int -> TextDocumentVersion
forall a. a -> Maybe a
Just Int
_version)) ([TextDocumentContentChangeEvent]
-> List TextDocumentContentChangeEvent
forall a. [a] -> List a
List [])
      Uri -> (NormalizedFilePath -> IO ()) -> IO ()
whenUriFile Uri
_uri ((NormalizedFilePath -> IO ()) -> IO ())
-> (NormalizedFilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \NormalizedFilePath
file -> do
          -- We don't know if the file actually exists, or if the contents match those on disk

          -- For example, vscode restores previously unsaved contents on open

          IdeState
-> (HashMap NormalizedFilePath FileOfInterestStatus
    -> HashMap NormalizedFilePath FileOfInterestStatus)
-> IO ()
modifyFilesOfInterest IdeState
ide (NormalizedFilePath
-> FileOfInterestStatus
-> HashMap NormalizedFilePath FileOfInterestStatus
-> HashMap NormalizedFilePath FileOfInterestStatus
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert NormalizedFilePath
file Modified :: Bool -> FileOfInterestStatus
Modified{firstOpen :: Bool
firstOpen=Bool
True})
          IdeState -> Bool -> NormalizedFilePath -> IO ()
setFileModified IdeState
ide Bool
False NormalizedFilePath
file
          Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
ide) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Opened text document: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Uri -> Text
getUri Uri
_uri

  , SMethod 'TextDocumentDidChange
-> (IdeState -> MessageParams 'TextDocumentDidChange -> LspM c ())
-> Handlers (ServerM c)
forall (m :: Method 'FromClient 'Notification) c.
HasTracing (MessageParams m) =>
SMethod m
-> (IdeState -> MessageParams m -> LspM c ())
-> Handlers (ServerM c)
notificationHandler SMethod 'TextDocumentDidChange
LSP.STextDocumentDidChange ((IdeState -> MessageParams 'TextDocumentDidChange -> LspM c ())
 -> Handlers (ServerM c))
-> (IdeState -> MessageParams 'TextDocumentDidChange -> LspM c ())
-> Handlers (ServerM c)
forall a b. (a -> b) -> a -> b
$
      \IdeState
ide (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> IO () -> LspM c ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspM c ()) -> IO () -> LspM c ()
forall a b. (a -> b) -> a -> b
$ do
        IdeState
-> VersionedTextDocumentIdentifier
-> List TextDocumentContentChangeEvent
-> IO ()
updatePositionMapping IdeState
ide VersionedTextDocumentIdentifier
identifier List TextDocumentContentChangeEvent
changes
        Uri -> (NormalizedFilePath -> IO ()) -> IO ()
whenUriFile Uri
_uri ((NormalizedFilePath -> IO ()) -> IO ())
-> (NormalizedFilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \NormalizedFilePath
file -> do
          IdeState
-> (HashMap NormalizedFilePath FileOfInterestStatus
    -> HashMap NormalizedFilePath FileOfInterestStatus)
-> IO ()
modifyFilesOfInterest IdeState
ide (NormalizedFilePath
-> FileOfInterestStatus
-> HashMap NormalizedFilePath FileOfInterestStatus
-> HashMap NormalizedFilePath FileOfInterestStatus
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert NormalizedFilePath
file Modified :: Bool -> FileOfInterestStatus
Modified{firstOpen :: Bool
firstOpen=Bool
False})
          IdeState -> Bool -> NormalizedFilePath -> IO ()
setFileModified IdeState
ide Bool
False NormalizedFilePath
file
        Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
ide) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Modified text document: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Uri -> Text
getUri Uri
_uri

  , SMethod 'TextDocumentDidSave
-> (IdeState -> MessageParams 'TextDocumentDidSave -> LspM c ())
-> Handlers (ServerM c)
forall (m :: Method 'FromClient 'Notification) c.
HasTracing (MessageParams m) =>
SMethod m
-> (IdeState -> MessageParams m -> LspM c ())
-> Handlers (ServerM c)
notificationHandler SMethod 'TextDocumentDidSave
LSP.STextDocumentDidSave ((IdeState -> MessageParams 'TextDocumentDidSave -> LspM c ())
 -> Handlers (ServerM c))
-> (IdeState -> MessageParams 'TextDocumentDidSave -> LspM c ())
-> Handlers (ServerM c)
forall a b. (a -> b) -> a -> b
$
      \IdeState
ide (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> IO () -> LspM c ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspM c ()) -> IO () -> LspM c ()
forall a b. (a -> b) -> a -> b
$ do
        Uri -> (NormalizedFilePath -> IO ()) -> IO ()
whenUriFile Uri
_uri ((NormalizedFilePath -> IO ()) -> IO ())
-> (NormalizedFilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \NormalizedFilePath
file -> do
            IdeState
-> (HashMap NormalizedFilePath FileOfInterestStatus
    -> HashMap NormalizedFilePath FileOfInterestStatus)
-> IO ()
modifyFilesOfInterest IdeState
ide (NormalizedFilePath
-> FileOfInterestStatus
-> HashMap NormalizedFilePath FileOfInterestStatus
-> HashMap NormalizedFilePath FileOfInterestStatus
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert NormalizedFilePath
file FileOfInterestStatus
OnDisk)
            IdeState -> Bool -> NormalizedFilePath -> IO ()
setFileModified IdeState
ide Bool
True NormalizedFilePath
file
        Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
ide) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Saved text document: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Uri -> Text
getUri Uri
_uri

  , SMethod 'TextDocumentDidClose
-> (IdeState -> MessageParams 'TextDocumentDidClose -> LspM c ())
-> Handlers (ServerM c)
forall (m :: Method 'FromClient 'Notification) c.
HasTracing (MessageParams m) =>
SMethod m
-> (IdeState -> MessageParams m -> LspM c ())
-> Handlers (ServerM c)
notificationHandler SMethod 'TextDocumentDidClose
LSP.STextDocumentDidClose ((IdeState -> MessageParams 'TextDocumentDidClose -> LspM c ())
 -> Handlers (ServerM c))
-> (IdeState -> MessageParams 'TextDocumentDidClose -> LspM c ())
-> Handlers (ServerM c)
forall a b. (a -> b) -> a -> b
$
        \IdeState
ide (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> IO () -> LspM c ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspM c ()) -> IO () -> LspM c ()
forall a b. (a -> b) -> a -> b
$ do
          Uri -> (NormalizedFilePath -> IO ()) -> IO ()
whenUriFile Uri
_uri ((NormalizedFilePath -> IO ()) -> IO ())
-> (NormalizedFilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \NormalizedFilePath
file -> do
              IdeState
-> (HashMap NormalizedFilePath FileOfInterestStatus
    -> HashMap NormalizedFilePath FileOfInterestStatus)
-> IO ()
modifyFilesOfInterest IdeState
ide (NormalizedFilePath
-> HashMap NormalizedFilePath FileOfInterestStatus
-> HashMap NormalizedFilePath FileOfInterestStatus
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
M.delete NormalizedFilePath
file)
              -- Refresh all the files that depended on this

              CheckParents
checkParents <- IdeOptions -> IO CheckParents
optCheckParents (IdeOptions -> IO CheckParents) -> IO IdeOptions -> IO CheckParents
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ShakeExtras -> IO IdeOptions
getIdeOptionsIO (IdeState -> ShakeExtras
shakeExtras IdeState
ide)
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CheckParents
checkParents CheckParents -> CheckParents -> Bool
forall a. Ord a => a -> a -> Bool
>= CheckParents
CheckOnClose) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IdeState -> NormalizedFilePath -> IO ()
typecheckParents IdeState
ide NormalizedFilePath
file
              Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
ide) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Closed text document: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Uri -> Text
getUri Uri
_uri

  , SMethod 'WorkspaceDidChangeWatchedFiles
-> (IdeState
    -> MessageParams 'WorkspaceDidChangeWatchedFiles -> LspM c ())
-> Handlers (ServerM c)
forall (m :: Method 'FromClient 'Notification) c.
HasTracing (MessageParams m) =>
SMethod m
-> (IdeState -> MessageParams m -> LspM c ())
-> Handlers (ServerM c)
notificationHandler SMethod 'WorkspaceDidChangeWatchedFiles
LSP.SWorkspaceDidChangeWatchedFiles ((IdeState
  -> MessageParams 'WorkspaceDidChangeWatchedFiles -> LspM c ())
 -> Handlers (ServerM c))
-> (IdeState
    -> MessageParams 'WorkspaceDidChangeWatchedFiles -> LspM c ())
-> Handlers (ServerM c)
forall a b. (a -> b) -> a -> b
$
      \IdeState
ide (DidChangeWatchedFilesParams fileEvents) -> IO () -> LspM c ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspM c ()) -> IO () -> LspM c ()
forall a b. (a -> b) -> a -> b
$ do
        -- See Note [File existence cache and LSP file watchers] which explains why we get these notifications and

        -- what we do with them

        let events :: [(NormalizedFilePath, Bool)]
events =
                (FileEvent -> Maybe (NormalizedFilePath, Bool))
-> [FileEvent] -> [(NormalizedFilePath, Bool)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
                    (\(FileEvent Uri
uri FileChangeType
ev) ->
                        (, FileChangeType
ev FileChangeType -> FileChangeType -> Bool
forall a. Eq a => a -> a -> Bool
/= FileChangeType
FcDeleted) (NormalizedFilePath -> (NormalizedFilePath, Bool))
-> (FilePath -> NormalizedFilePath)
-> FilePath
-> (NormalizedFilePath, Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> NormalizedFilePath
toNormalizedFilePath'
                        (FilePath -> (NormalizedFilePath, Bool))
-> Maybe FilePath -> Maybe (NormalizedFilePath, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Uri -> Maybe FilePath
LSP.uriToFilePath Uri
uri
                    )
                    ( List FileEvent -> [FileEvent]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList List FileEvent
fileEvents )
        let msg :: Text
msg = FilePath -> Text
Text.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ [(NormalizedFilePath, Bool)] -> FilePath
forall a. Show a => a -> FilePath
show [(NormalizedFilePath, Bool)]
events
        Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
ide) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Files created or deleted: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
        IdeState -> [(NormalizedFilePath, Bool)] -> IO ()
modifyFileExists IdeState
ide [(NormalizedFilePath, Bool)]
events
        IdeState -> IO ()
setSomethingModified IdeState
ide

  , SMethod 'WorkspaceDidChangeWorkspaceFolders
-> (IdeState
    -> MessageParams 'WorkspaceDidChangeWorkspaceFolders -> LspM c ())
-> Handlers (ServerM c)
forall (m :: Method 'FromClient 'Notification) c.
HasTracing (MessageParams m) =>
SMethod m
-> (IdeState -> MessageParams m -> LspM c ())
-> Handlers (ServerM c)
notificationHandler SMethod 'WorkspaceDidChangeWorkspaceFolders
LSP.SWorkspaceDidChangeWorkspaceFolders ((IdeState
  -> MessageParams 'WorkspaceDidChangeWorkspaceFolders -> LspM c ())
 -> Handlers (ServerM c))
-> (IdeState
    -> MessageParams 'WorkspaceDidChangeWorkspaceFolders -> LspM c ())
-> Handlers (ServerM c)
forall a b. (a -> b) -> a -> b
$
      \IdeState
ide (DidChangeWorkspaceFoldersParams events) -> IO () -> LspM c ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspM c ()) -> IO () -> LspM c ()
forall a b. (a -> b) -> a -> b
$ do
        let add :: HashSet NormalizedUri
-> HashSet NormalizedUri -> HashSet NormalizedUri
add       = HashSet NormalizedUri
-> HashSet NormalizedUri -> HashSet NormalizedUri
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
S.union
            substract :: HashSet NormalizedUri
-> HashSet NormalizedUri -> HashSet NormalizedUri
substract = (HashSet NormalizedUri
 -> HashSet NormalizedUri -> HashSet NormalizedUri)
-> HashSet NormalizedUri
-> HashSet NormalizedUri
-> HashSet NormalizedUri
forall a b c. (a -> b -> c) -> b -> a -> c
flip HashSet NormalizedUri
-> HashSet NormalizedUri -> HashSet NormalizedUri
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
S.difference
        IdeState
-> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO ()
modifyWorkspaceFolders IdeState
ide
          ((HashSet NormalizedUri -> HashSet NormalizedUri) -> IO ())
-> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO ()
forall a b. (a -> b) -> a -> b
$ HashSet NormalizedUri
-> HashSet NormalizedUri -> HashSet NormalizedUri
add       ((WorkspaceFolder -> HashSet NormalizedUri)
-> List WorkspaceFolder -> HashSet NormalizedUri
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (NormalizedUri -> HashSet NormalizedUri
forall a. Hashable a => a -> HashSet a
S.singleton (NormalizedUri -> HashSet NormalizedUri)
-> (WorkspaceFolder -> NormalizedUri)
-> WorkspaceFolder
-> HashSet NormalizedUri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WorkspaceFolder -> NormalizedUri
parseWorkspaceFolder) (WorkspaceFoldersChangeEvent -> List WorkspaceFolder
_added   WorkspaceFoldersChangeEvent
events))
          (HashSet NormalizedUri -> HashSet NormalizedUri)
-> (HashSet NormalizedUri -> HashSet NormalizedUri)
-> HashSet NormalizedUri
-> HashSet NormalizedUri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashSet NormalizedUri
-> HashSet NormalizedUri -> HashSet NormalizedUri
substract ((WorkspaceFolder -> HashSet NormalizedUri)
-> List WorkspaceFolder -> HashSet NormalizedUri
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (NormalizedUri -> HashSet NormalizedUri
forall a. Hashable a => a -> HashSet a
S.singleton (NormalizedUri -> HashSet NormalizedUri)
-> (WorkspaceFolder -> NormalizedUri)
-> WorkspaceFolder
-> HashSet NormalizedUri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WorkspaceFolder -> NormalizedUri
parseWorkspaceFolder) (WorkspaceFoldersChangeEvent -> List WorkspaceFolder
_removed WorkspaceFoldersChangeEvent
events))

  , SMethod 'WorkspaceDidChangeConfiguration
-> (IdeState
    -> MessageParams 'WorkspaceDidChangeConfiguration -> LspM c ())
-> Handlers (ServerM c)
forall (m :: Method 'FromClient 'Notification) c.
HasTracing (MessageParams m) =>
SMethod m
-> (IdeState -> MessageParams m -> LspM c ())
-> Handlers (ServerM c)
notificationHandler SMethod 'WorkspaceDidChangeConfiguration
LSP.SWorkspaceDidChangeConfiguration ((IdeState
  -> MessageParams 'WorkspaceDidChangeConfiguration -> LspM c ())
 -> Handlers (ServerM c))
-> (IdeState
    -> MessageParams 'WorkspaceDidChangeConfiguration -> LspM c ())
-> Handlers (ServerM c)
forall a b. (a -> b) -> a -> b
$
      \IdeState
ide (DidChangeConfigurationParams cfg) -> IO () -> LspM c ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspM c ()) -> IO () -> LspM c ()
forall a b. (a -> b) -> a -> b
$ do
        let msg :: Text
msg = FilePath -> Text
Text.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Value -> FilePath
forall a. Show a => a -> FilePath
show Value
cfg
        Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
ide) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Configuration changed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
        IdeState -> (Maybe Value -> Maybe Value) -> IO ()
modifyClientSettings IdeState
ide (Maybe Value -> Maybe Value -> Maybe Value
forall a b. a -> b -> a
const (Maybe Value -> Maybe Value -> Maybe Value)
-> Maybe Value -> Maybe Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Value -> Maybe Value
forall a. a -> Maybe a
Just Value
cfg)
        IdeState -> IO ()
setSomethingModified IdeState
ide

  , SMethod 'Initialized
-> (IdeState -> MessageParams 'Initialized -> LspM c ())
-> Handlers (ServerM c)
forall (m :: Method 'FromClient 'Notification) c.
HasTracing (MessageParams m) =>
SMethod m
-> (IdeState -> MessageParams m -> LspM c ())
-> Handlers (ServerM c)
notificationHandler SMethod 'Initialized
LSP.SInitialized ((IdeState -> MessageParams 'Initialized -> LspM c ())
 -> Handlers (ServerM c))
-> (IdeState -> MessageParams 'Initialized -> LspM c ())
-> Handlers (ServerM c)
forall a b. (a -> b) -> a -> b
$ \IdeState
ide MessageParams 'Initialized
_ -> do
      ClientCapabilities
clientCapabilities <- LspT c IO ClientCapabilities
forall config (m :: * -> *).
MonadLsp config m =>
m ClientCapabilities
LSP.getClientCapabilities
      let watchSupported :: Bool
watchSupported = case () of
            ()
_ | LSP.ClientCapabilities{Maybe WorkspaceClientCapabilities
$sel:_workspace:ClientCapabilities :: ClientCapabilities -> Maybe WorkspaceClientCapabilities
_workspace :: Maybe WorkspaceClientCapabilities
_workspace} <- ClientCapabilities
clientCapabilities
              , Just LSP.WorkspaceClientCapabilities{Maybe DidChangeWatchedFilesClientCapabilities
$sel:_didChangeWatchedFiles:WorkspaceClientCapabilities :: WorkspaceClientCapabilities
-> Maybe DidChangeWatchedFilesClientCapabilities
_didChangeWatchedFiles :: Maybe DidChangeWatchedFilesClientCapabilities
_didChangeWatchedFiles} <- Maybe WorkspaceClientCapabilities
_workspace
              , Just LSP.DidChangeWatchedFilesClientCapabilities{Maybe Bool
$sel:_dynamicRegistration:DidChangeWatchedFilesClientCapabilities :: DidChangeWatchedFilesClientCapabilities -> Maybe Bool
_dynamicRegistration :: Maybe Bool
_dynamicRegistration} <- Maybe DidChangeWatchedFilesClientCapabilities
_didChangeWatchedFiles
              , Just Bool
True <- Maybe Bool
_dynamicRegistration
                -> Bool
True
              | Bool
otherwise -> Bool
False
      if Bool
watchSupported
      then do
        IdeOptions
opts <- IO IdeOptions -> LspT c IO IdeOptions
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO IdeOptions -> LspT c IO IdeOptions)
-> IO IdeOptions -> LspT c IO IdeOptions
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> IO IdeOptions
getIdeOptionsIO (ShakeExtras -> IO IdeOptions) -> ShakeExtras -> IO IdeOptions
forall a b. (a -> b) -> a -> b
$ IdeState -> ShakeExtras
shakeExtras IdeState
ide
        let
          regParams :: RegistrationParams
regParams    = List SomeRegistration -> RegistrationParams
RegistrationParams ([SomeRegistration] -> List SomeRegistration
forall a. [a] -> List a
List [Registration 'WorkspaceDidChangeWatchedFiles -> SomeRegistration
forall (t :: MethodType) (m :: Method 'FromClient t).
Registration m -> SomeRegistration
SomeRegistration Registration 'WorkspaceDidChangeWatchedFiles
registration])
          -- The registration ID is arbitrary and is only used in case we want to deregister (which we won't).

          -- We could also use something like a random UUID, as some other servers do, but this works for

          -- our purposes.

          registration :: Registration 'WorkspaceDidChangeWatchedFiles
registration = Text
-> SMethod 'WorkspaceDidChangeWatchedFiles
-> RegistrationOptions 'WorkspaceDidChangeWatchedFiles
-> Registration 'WorkspaceDidChangeWatchedFiles
forall (t :: MethodType) (m :: Method 'FromClient t).
Text -> SClientMethod m -> RegistrationOptions m -> Registration m
Registration Text
"globalFileWatches"
                                      SMethod 'WorkspaceDidChangeWatchedFiles
SWorkspaceDidChangeWatchedFiles
                                      RegistrationOptions 'WorkspaceDidChangeWatchedFiles
DidChangeWatchedFilesRegistrationOptions
regOptions
          regOptions :: DidChangeWatchedFilesRegistrationOptions
regOptions =
            DidChangeWatchedFilesRegistrationOptions :: List FileSystemWatcher -> DidChangeWatchedFilesRegistrationOptions
DidChangeWatchedFilesRegistrationOptions { $sel:_watchers:DidChangeWatchedFilesRegistrationOptions :: List FileSystemWatcher
_watchers = [FileSystemWatcher] -> List FileSystemWatcher
forall a. [a] -> List a
List [FileSystemWatcher]
watchers }
          -- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind

          watchKind :: WatchKind
watchKind = WatchKind :: Bool -> Bool -> Bool -> WatchKind
WatchKind { $sel:_watchCreate:WatchKind :: Bool
_watchCreate = Bool
True, $sel:_watchChange:WatchKind :: Bool
_watchChange = Bool
False, $sel:_watchDelete:WatchKind :: Bool
_watchDelete = Bool
True}
          -- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is

          -- The patterns will be something like "**/.hs", i.e. "any number of directory segments,

          -- followed by a file with an extension 'hs'.

          watcher :: Text -> FileSystemWatcher
watcher Text
glob = FileSystemWatcher :: Text -> Maybe WatchKind -> FileSystemWatcher
FileSystemWatcher { $sel:_globPattern:FileSystemWatcher :: Text
_globPattern = Text
glob, $sel:_kind:FileSystemWatcher :: Maybe WatchKind
_kind = WatchKind -> Maybe WatchKind
forall a. a -> Maybe a
Just WatchKind
watchKind }
          -- We use multiple watchers instead of one using '{}' because lsp-test doesn't

          -- support that: https://github.com/bubba/lsp-test/issues/77

          watchers :: [FileSystemWatcher]
watchers = [ Text -> FileSystemWatcher
watcher (FilePath -> Text
Text.pack FilePath
glob) | FilePath
glob <- IdeOptions -> [FilePath]
watchedGlobs IdeOptions
opts ]

        LspT c IO (LspId 'ClientRegisterCapability) -> LspM c ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (LspT c IO (LspId 'ClientRegisterCapability) -> LspM c ())
-> LspT c IO (LspId 'ClientRegisterCapability) -> LspM c ()
forall a b. (a -> b) -> a -> b
$ SServerMethod 'ClientRegisterCapability
-> MessageParams 'ClientRegisterCapability
-> (Either ResponseError (ResponseResult 'ClientRegisterCapability)
    -> LspM c ())
-> LspT c IO (LspId 'ClientRegisterCapability)
forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
LSP.sendRequest SServerMethod 'ClientRegisterCapability
SClientRegisterCapability MessageParams 'ClientRegisterCapability
RegistrationParams
regParams (LspM c () -> Either ResponseError Empty -> LspM c ()
forall a b. a -> b -> a
const (LspM c () -> Either ResponseError Empty -> LspM c ())
-> LspM c () -> Either ResponseError Empty -> LspM c ()
forall a b. (a -> b) -> a -> b
$ () -> LspM c ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) -- TODO handle response

      else IO () -> LspM c ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspM c ()) -> IO () -> LspM c ()
forall a b. (a -> b) -> a -> b
$ Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
ide) Text
"Warning: Client does not support watched files. Falling back to OS polling"
  ]