-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs                 #-}

module Development.IDE.LSP.Notifications
    ( whenUriFile
    , descriptor
    , Log(..)
    , ghcideNotificationsPluginPriority
    ) where

import qualified Language.LSP.Protocol.Message         as LSP
import           Language.LSP.Protocol.Types
import qualified Language.LSP.Protocol.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.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           Ide.Logger
import           Ide.Types
import           Numeric.Natural

data Log
  = LogShake Shake.Log
  | LogFileStore FileStore.Log
  deriving Int -> Log -> ShowS
[Log] -> ShowS
Log -> String
(Int -> Log -> ShowS)
-> (Log -> String) -> ([Log] -> ShowS) -> Show Log
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Log -> ShowS
showsPrec :: Int -> Log -> ShowS
$cshow :: Log -> String
show :: Log -> String
$cshowList :: [Log] -> ShowS
showList :: [Log] -> ShowS
Show

instance Pretty Log where
  pretty :: forall ann. Log -> Doc ann
pretty = \case
    LogShake Log
msg     -> Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Log -> Doc ann
pretty Log
msg
    LogFileStore Log
msg -> Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Log -> Doc ann
pretty Log
msg

whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
whenUriFile Uri
uri NormalizedFilePath -> IO ()
act = Maybe String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (Uri -> Maybe String
LSP.uriToFilePath Uri
uri) ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> IO ()
act (NormalizedFilePath -> IO ())
-> (String -> NormalizedFilePath) -> String -> IO ()
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 = (PluginId -> Text -> PluginDescriptor IdeState
forall ideState. PluginId -> Text -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId Text
desc) { pluginNotificationHandlers = mconcat
  [ mkPluginNotificationHandler LSP.SMethod_TextDocumentDidOpen $
      \IdeState
ide VFS
vfs PluginId
_ (DidOpenTextDocumentParams TextDocumentItem{Uri
_uri :: Uri
$sel:_uri:TextDocumentItem :: TextDocumentItem -> Uri
_uri,Int32
_version :: Int32
$sel:_version:TextDocumentItem :: TextDocumentItem -> Int32
_version}) -> IO () -> LspM Config ()
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspM Config ()) -> IO () -> LspM Config ()
forall a b. (a -> b) -> a -> b
$ do
      STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ IdeState
-> VersionedTextDocumentIdentifier
-> [TextDocumentContentChangeEvent]
-> STM ()
updatePositionMapping IdeState
ide (Uri -> Int32 -> VersionedTextDocumentIdentifier
VersionedTextDocumentIdentifier Uri
_uri Int32
_version) []
      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 -> NormalizedFilePath -> FileOfInterestStatus -> IO ()
addFileOfInterest IdeState
ide NormalizedFilePath
file Modified{firstOpen :: Bool
firstOpen=Bool
True}
          Recorder (WithPriority Log)
-> VFSModified -> IdeState -> Bool -> NormalizedFilePath -> IO ()
setFileModified ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
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) (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

  , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidChange $
      \IdeState
ide VFS
vfs PluginId
_ (DidChangeTextDocumentParams identifier :: VersionedTextDocumentIdentifier
identifier@VersionedTextDocumentIdentifier{Uri
_uri :: Uri
$sel:_uri:VersionedTextDocumentIdentifier :: VersionedTextDocumentIdentifier -> Uri
_uri} [TextDocumentContentChangeEvent]
changes) -> IO () -> LspM Config ()
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspM Config ()) -> IO () -> LspM Config ()
forall a b. (a -> b) -> a -> b
$ do
        STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ IdeState
-> VersionedTextDocumentIdentifier
-> [TextDocumentContentChangeEvent]
-> STM ()
updatePositionMapping IdeState
ide VersionedTextDocumentIdentifier
identifier [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 -> NormalizedFilePath -> FileOfInterestStatus -> IO ()
addFileOfInterest IdeState
ide NormalizedFilePath
file Modified{firstOpen :: Bool
firstOpen=Bool
False}
          Recorder (WithPriority Log)
-> VFSModified -> IdeState -> Bool -> NormalizedFilePath -> IO ()
setFileModified ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
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) (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

  , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidSave $
      \IdeState
ide VFS
vfs PluginId
_ (DidSaveTextDocumentParams TextDocumentIdentifier{Uri
_uri :: Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri} Maybe Text
_) -> IO () -> LspM Config ()
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspM Config ()) -> IO () -> LspM Config ()
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 -> NormalizedFilePath -> FileOfInterestStatus -> IO ()
addFileOfInterest IdeState
ide NormalizedFilePath
file FileOfInterestStatus
OnDisk
            Recorder (WithPriority Log)
-> VFSModified -> IdeState -> Bool -> NormalizedFilePath -> IO ()
setFileModified ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
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) (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

  , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidClose $
        \IdeState
ide VFS
vfs PluginId
_ (DidCloseTextDocumentParams TextDocumentIdentifier{Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri :: Uri
_uri}) -> IO () -> LspM Config ()
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspM Config ()) -> IO () -> LspM Config ()
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 -> NormalizedFilePath -> IO ()
deleteFileOfInterest IdeState
ide NormalizedFilePath
file
              let msg :: Text
msg = Text
"Closed text document: " Text -> Text -> Text
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 [] (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
msg
              Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
ide) Text
msg

  , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWatchedFiles $
      \IdeState
ide VFS
vfs PluginId
_ (DidChangeWatchedFilesParams [FileEvent]
fileEvents) -> IO () -> LspM Config ()
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspM Config ()) -> IO () -> LspM Config ()
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
        -- filter out files of interest, since we already know all about those
        -- filter also uris that do not map to filenames, since we cannot handle them
        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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath
-> HashMap NormalizedFilePath FileOfInterestStatus -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
HM.member NormalizedFilePath
nfp HashMap NormalizedFilePath FileOfInterestStatus
filesOfInterest
                ]
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(NormalizedFilePath, FileChangeType)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(NormalizedFilePath, FileChangeType)]
fileEvents') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            let msg :: String
msg = [(NormalizedFilePath, FileChangeType)] -> String
forall a. Show a => a -> String
show [(NormalizedFilePath, FileChangeType)]
fileEvents'
            Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
ide) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Watched file events: " Text -> Text -> Text
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

  , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWorkspaceFolders $
      \IdeState
ide VFS
_ PluginId
_ (DidChangeWorkspaceFoldersParams WorkspaceFoldersChangeEvent
events) -> IO () -> LspM Config ()
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspM Config ()) -> IO () -> LspM Config ()
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 => 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)
-> [WorkspaceFolder] -> HashSet NormalizedUri
forall m a. Monoid m => (a -> m) -> [a] -> m
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 -> [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)
-> [WorkspaceFolder] -> HashSet NormalizedUri
forall m a. Monoid m => (a -> m) -> [a] -> m
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 -> [WorkspaceFolder]
_removed WorkspaceFoldersChangeEvent
events))

  -- Nothing additional to do here beyond what `lsp` does for us, but this prevents
  -- complaints about there being no handler defined
  , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeConfiguration mempty

  , mkPluginNotificationHandler LSP.SMethod_Initialized $ \IdeState
ide VFS
_ PluginId
_ MessageParams 'Method_Initialized
_ -> do
      --------- Initialize Shake session --------------------------------------------------------------------
      IO () -> LspM Config ()
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspM Config ()) -> IO () -> LspM Config ()
forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log) -> IdeState -> IO ()
shakeSessionInit ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) IdeState
ide

      --------- Set up file watchers ------------------------------------------------------------------------
      IdeOptions
opts <- IO IdeOptions -> LspT Config IO IdeOptions
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO IdeOptions -> LspT Config IO IdeOptions)
-> IO IdeOptions -> LspT Config 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
        -- 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'.
        -- We use multiple watchers instead of one using '{}' because lsp-test doesn't
        -- support that: https://github.com/bubba/lsp-test/issues/77
      let globs :: [String]
globs = IdeOptions -> [String]
watchedGlobs IdeOptions
opts
      Bool
success <- [String] -> LspT Config IO Bool
registerFileWatches [String]
globs
      Bool -> LspM Config () -> LspM Config ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success (LspM Config () -> LspM Config ())
-> LspM Config () -> LspM Config ()
forall a b. (a -> b) -> a -> b
$
        IO () -> LspM Config ()
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspM Config ()) -> IO () -> LspM Config ()
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"
  ],

    -- The ghcide descriptors should come last'ish so that the notification handlers
    -- (which restart the Shake build) run after everything else
        pluginPriority = ghcideNotificationsPluginPriority
    }
  where
    desc :: Text
desc = Text
"Handles basic notifications for ghcide"

ghcideNotificationsPluginPriority :: Natural
ghcideNotificationsPluginPriority :: Natural
ghcideNotificationsPluginPriority = Natural
defaultPluginPriority Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
900