{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
module Development.IDE.LSP.Notifications
( whenUriFile
, descriptor
, Log(..)
, ghcideNotificationsPluginPriority
) where
import Language.LSP.Types
import qualified Language.LSP.Types as LSP
import Control.Concurrent.STM.Stats (atomically)
import Control.Monad.Extra
import Control.Monad.IO.Class
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as S
import qualified Data.Text as Text
import Development.IDE.Core.FileExists (modifyFileExists,
watchedGlobs)
import Development.IDE.Core.FileStore (registerFileWatches,
resetFileStore,
setFileModified,
setSomethingModified)
import qualified Development.IDE.Core.FileStore as FileStore
import Development.IDE.Core.IdeConfiguration
import Development.IDE.Core.OfInterest hiding (Log, LogShake)
import Development.IDE.Core.RuleTypes (GetClientSettings (..))
import Development.IDE.Core.Service hiding (Log, LogShake)
import Development.IDE.Core.Shake hiding (Log, Priority)
import qualified Development.IDE.Core.Shake as Shake
import Development.IDE.Types.Location
import Development.IDE.Types.Logger
import Development.IDE.Types.Shake (toKey)
import Ide.Types
import Numeric.Natural
data Log
= LogShake Shake.Log
| LogFileStore FileStore.Log
deriving Int -> Log -> ShowS
[Log] -> ShowS
Log -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Log] -> ShowS
$cshowList :: [Log] -> ShowS
show :: Log -> String
$cshow :: Log -> String
showsPrec :: Int -> Log -> ShowS
$cshowsPrec :: Int -> Log -> ShowS
Show
instance Pretty Log where
pretty :: forall ann. Log -> Doc ann
pretty = \case
LogShake Log
log -> forall a ann. Pretty a => a -> Doc ann
pretty Log
log
LogFileStore Log
log -> forall a ann. Pretty a => a -> Doc ann
pretty Log
log
whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
whenUriFile Uri
uri NormalizedFilePath -> IO ()
act = forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (Uri -> Maybe String
LSP.uriToFilePath Uri
uri) forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> IO ()
act forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> NormalizedFilePath
toNormalizedFilePath'
descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
descriptor :: Recorder (WithPriority Log)
-> PluginId -> PluginDescriptor IdeState
descriptor Recorder (WithPriority Log)
recorder PluginId
plId = (forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId) { pluginNotificationHandlers :: PluginNotificationHandlers IdeState
pluginNotificationHandlers = forall a. Monoid a => [a] -> a
mconcat
[ forall (m :: Method 'FromClient 'Notification) ideState.
PluginNotificationMethod m =>
SClientMethod m
-> PluginNotificationMethodHandler ideState m
-> PluginNotificationHandlers ideState
mkPluginNotificationHandler SMethod 'TextDocumentDidOpen
LSP.STextDocumentDidOpen forall a b. (a -> b) -> a -> b
$
\IdeState
ide VFS
vfs PluginId
_ (DidOpenTextDocumentParams TextDocumentItem{Uri
$sel:_uri:TextDocumentItem :: TextDocumentItem -> Uri
_uri :: Uri
_uri,Int32
$sel:_version:TextDocumentItem :: TextDocumentItem -> Int32
_version :: Int32
_version}) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ IdeState
-> VersionedTextDocumentIdentifier
-> List TextDocumentContentChangeEvent
-> STM ()
updatePositionMapping IdeState
ide (Uri -> TextDocumentVersion -> VersionedTextDocumentIdentifier
VersionedTextDocumentIdentifier Uri
_uri (forall a. a -> Maybe a
Just Int32
_version)) (forall a. [a] -> List a
List [])
Uri -> (NormalizedFilePath -> IO ()) -> IO ()
whenUriFile Uri
_uri forall a b. (a -> b) -> a -> b
$ \NormalizedFilePath
file -> do
IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO ()
addFileOfInterest IdeState
ide NormalizedFilePath
file Modified{firstOpen :: Bool
firstOpen=Bool
True}
Recorder (WithPriority Log)
-> VFSModified -> IdeState -> Bool -> NormalizedFilePath -> IO ()
setFileModified (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogFileStore Recorder (WithPriority Log)
recorder) (VFS -> VFSModified
VFSModified VFS
vfs) IdeState
ide Bool
False NormalizedFilePath
file
Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
ide) forall a b. (a -> b) -> a -> b
$ Text
"Opened text document: " forall a. Semigroup a => a -> a -> a
<> Uri -> Text
getUri Uri
_uri
, forall (m :: Method 'FromClient 'Notification) ideState.
PluginNotificationMethod m =>
SClientMethod m
-> PluginNotificationMethodHandler ideState m
-> PluginNotificationHandlers ideState
mkPluginNotificationHandler SMethod 'TextDocumentDidChange
LSP.STextDocumentDidChange forall a b. (a -> b) -> a -> b
$
\IdeState
ide VFS
vfs PluginId
_ (DidChangeTextDocumentParams identifier :: VersionedTextDocumentIdentifier
identifier@VersionedTextDocumentIdentifier{Uri
$sel:_uri:VersionedTextDocumentIdentifier :: VersionedTextDocumentIdentifier -> Uri
_uri :: Uri
_uri} List TextDocumentContentChangeEvent
changes) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ IdeState
-> VersionedTextDocumentIdentifier
-> List TextDocumentContentChangeEvent
-> STM ()
updatePositionMapping IdeState
ide VersionedTextDocumentIdentifier
identifier List TextDocumentContentChangeEvent
changes
Uri -> (NormalizedFilePath -> IO ()) -> IO ()
whenUriFile Uri
_uri forall a b. (a -> b) -> a -> b
$ \NormalizedFilePath
file -> do
IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO ()
addFileOfInterest IdeState
ide NormalizedFilePath
file Modified{firstOpen :: Bool
firstOpen=Bool
False}
Recorder (WithPriority Log)
-> VFSModified -> IdeState -> Bool -> NormalizedFilePath -> IO ()
setFileModified (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogFileStore Recorder (WithPriority Log)
recorder) (VFS -> VFSModified
VFSModified VFS
vfs) IdeState
ide Bool
False NormalizedFilePath
file
Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
ide) forall a b. (a -> b) -> a -> b
$ Text
"Modified text document: " forall a. Semigroup a => a -> a -> a
<> Uri -> Text
getUri Uri
_uri
, forall (m :: Method 'FromClient 'Notification) ideState.
PluginNotificationMethod m =>
SClientMethod m
-> PluginNotificationMethodHandler ideState m
-> PluginNotificationHandlers ideState
mkPluginNotificationHandler SMethod 'TextDocumentDidSave
LSP.STextDocumentDidSave forall a b. (a -> b) -> a -> b
$
\IdeState
ide VFS
vfs PluginId
_ (DidSaveTextDocumentParams TextDocumentIdentifier{Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri :: Uri
_uri} Maybe Text
_) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Uri -> (NormalizedFilePath -> IO ()) -> IO ()
whenUriFile Uri
_uri forall a b. (a -> b) -> a -> b
$ \NormalizedFilePath
file -> do
IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO ()
addFileOfInterest IdeState
ide NormalizedFilePath
file FileOfInterestStatus
OnDisk
Recorder (WithPriority Log)
-> VFSModified -> IdeState -> Bool -> NormalizedFilePath -> IO ()
setFileModified (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogFileStore Recorder (WithPriority Log)
recorder) (VFS -> VFSModified
VFSModified VFS
vfs) IdeState
ide Bool
True NormalizedFilePath
file
Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
ide) forall a b. (a -> b) -> a -> b
$ Text
"Saved text document: " forall a. Semigroup a => a -> a -> a
<> Uri -> Text
getUri Uri
_uri
, forall (m :: Method 'FromClient 'Notification) ideState.
PluginNotificationMethod m =>
SClientMethod m
-> PluginNotificationMethodHandler ideState m
-> PluginNotificationHandlers ideState
mkPluginNotificationHandler SMethod 'TextDocumentDidClose
LSP.STextDocumentDidClose forall a b. (a -> b) -> a -> b
$
\IdeState
ide VFS
vfs PluginId
_ (DidCloseTextDocumentParams TextDocumentIdentifier{Uri
_uri :: Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri}) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Uri -> (NormalizedFilePath -> IO ()) -> IO ()
whenUriFile Uri
_uri forall a b. (a -> b) -> a -> b
$ \NormalizedFilePath
file -> do
IdeState -> NormalizedFilePath -> IO ()
deleteFileOfInterest IdeState
ide NormalizedFilePath
file
let msg :: Text
msg = Text
"Closed text document: " forall a. Semigroup a => a -> a -> a
<> Uri -> Text
getUri Uri
_uri
IdeState -> IO ()
scheduleGarbageCollection IdeState
ide
VFSModified -> IdeState -> [Key] -> String -> IO ()
setSomethingModified (VFS -> VFSModified
VFSModified VFS
vfs) IdeState
ide [] forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
msg
Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
ide) Text
msg
, forall (m :: Method 'FromClient 'Notification) ideState.
PluginNotificationMethod m =>
SClientMethod m
-> PluginNotificationMethodHandler ideState m
-> PluginNotificationHandlers ideState
mkPluginNotificationHandler SMethod 'WorkspaceDidChangeWatchedFiles
LSP.SWorkspaceDidChangeWatchedFiles forall a b. (a -> b) -> a -> b
$
\IdeState
ide VFS
vfs PluginId
_ (DidChangeWatchedFilesParams (List [FileEvent]
fileEvents)) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
HashMap NormalizedFilePath FileOfInterestStatus
filesOfInterest <- IdeState -> IO (HashMap NormalizedFilePath FileOfInterestStatus)
getFilesOfInterest IdeState
ide
let fileEvents' :: [(NormalizedFilePath, FileChangeType)]
fileEvents' =
[ (NormalizedFilePath
nfp, FileChangeType
event) | (FileEvent Uri
uri FileChangeType
event) <- [FileEvent]
fileEvents
, Just String
fp <- [Uri -> Maybe String
uriToFilePath Uri
uri]
, let nfp :: NormalizedFilePath
nfp = String -> NormalizedFilePath
toNormalizedFilePath String
fp
, Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
HM.member NormalizedFilePath
nfp HashMap NormalizedFilePath FileOfInterestStatus
filesOfInterest
]
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(NormalizedFilePath, FileChangeType)]
fileEvents') forall a b. (a -> b) -> a -> b
$ do
let msg :: String
msg = forall a. Show a => a -> String
show [(NormalizedFilePath, FileChangeType)]
fileEvents'
Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
ide) forall a b. (a -> b) -> a -> b
$ Text
"Watched file events: " forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
msg
IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO ()
modifyFileExists IdeState
ide [(NormalizedFilePath, FileChangeType)]
fileEvents'
IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO ()
resetFileStore IdeState
ide [(NormalizedFilePath, FileChangeType)]
fileEvents'
VFSModified -> IdeState -> [Key] -> String -> IO ()
setSomethingModified (VFS -> VFSModified
VFSModified VFS
vfs) IdeState
ide [] String
msg
, forall (m :: Method 'FromClient 'Notification) ideState.
PluginNotificationMethod m =>
SClientMethod m
-> PluginNotificationMethodHandler ideState m
-> PluginNotificationHandlers ideState
mkPluginNotificationHandler SMethod 'WorkspaceDidChangeWorkspaceFolders
LSP.SWorkspaceDidChangeWorkspaceFolders forall a b. (a -> b) -> a -> b
$
\IdeState
ide VFS
_ PluginId
_ (DidChangeWorkspaceFoldersParams WorkspaceFoldersChangeEvent
events) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
let add :: HashSet NormalizedUri
-> HashSet NormalizedUri -> HashSet NormalizedUri
add = forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
S.union
substract :: HashSet NormalizedUri
-> HashSet NormalizedUri -> HashSet NormalizedUri
substract = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
S.difference
IdeState
-> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO ()
modifyWorkspaceFolders IdeState
ide
forall a b. (a -> b) -> a -> b
$ HashSet NormalizedUri
-> HashSet NormalizedUri -> HashSet NormalizedUri
add (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. Hashable a => a -> HashSet a
S.singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. WorkspaceFolder -> NormalizedUri
parseWorkspaceFolder) (WorkspaceFoldersChangeEvent -> List WorkspaceFolder
_added WorkspaceFoldersChangeEvent
events))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashSet NormalizedUri
-> HashSet NormalizedUri -> HashSet NormalizedUri
substract (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. Hashable a => a -> HashSet a
S.singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. WorkspaceFolder -> NormalizedUri
parseWorkspaceFolder) (WorkspaceFoldersChangeEvent -> List WorkspaceFolder
_removed WorkspaceFoldersChangeEvent
events))
, forall (m :: Method 'FromClient 'Notification) ideState.
PluginNotificationMethod m =>
SClientMethod m
-> PluginNotificationMethodHandler ideState m
-> PluginNotificationHandlers ideState
mkPluginNotificationHandler SMethod 'WorkspaceDidChangeConfiguration
LSP.SWorkspaceDidChangeConfiguration forall a b. (a -> b) -> a -> b
$
\IdeState
ide VFS
vfs PluginId
_ (DidChangeConfigurationParams Value
cfg) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
let msg :: Text
msg = String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Value
cfg
Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
ide) forall a b. (a -> b) -> a -> b
$ Text
"Configuration changed: " forall a. Semigroup a => a -> a -> a
<> Text
msg
IdeState -> (Maybe Value -> Maybe Value) -> IO ()
modifyClientSettings IdeState
ide (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Value
cfg)
VFSModified -> IdeState -> [Key] -> String -> IO ()
setSomethingModified (VFS -> VFSModified
VFSModified VFS
vfs) IdeState
ide [forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey GetClientSettings
GetClientSettings NormalizedFilePath
emptyFilePath] String
"config change"
, forall (m :: Method 'FromClient 'Notification) ideState.
PluginNotificationMethod m =>
SClientMethod m
-> PluginNotificationMethodHandler ideState m
-> PluginNotificationHandlers ideState
mkPluginNotificationHandler SMethod 'Initialized
LSP.SInitialized forall a b. (a -> b) -> a -> b
$ \IdeState
ide VFS
_ PluginId
_ MessageParams 'Initialized
_ -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log) -> IdeState -> IO ()
shakeSessionInit (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) IdeState
ide
IdeOptions
opts <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ShakeExtras -> IO IdeOptions
getIdeOptionsIO forall a b. (a -> b) -> a -> b
$ IdeState -> ShakeExtras
shakeExtras IdeState
ide
let globs :: [String]
globs = IdeOptions -> [String]
watchedGlobs IdeOptions
opts
Bool
success <- [String] -> LspT Config IO Bool
registerFileWatches [String]
globs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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"
],
pluginPriority :: Natural
pluginPriority = Natural
ghcideNotificationsPluginPriority
}
ghcideNotificationsPluginPriority :: Natural
ghcideNotificationsPluginPriority :: Natural
ghcideNotificationsPluginPriority = Natural
defaultPluginPriority forall a. Num a => a -> a -> a
- Natural
900