Make the hie-core server retargetable (#1873)

* Move mergeHandlers into Server

* Make partial handlers a proper newtype

* Pass the options in to runLanguageServer

* Take in user handlers

* Remove the code lens handler since we don't advertise it

* Add setSomethingModified, rather than faking it for the LSP VFS

* Rewrite the LSP notifications

* Improve the display of info messages around openning and modifying text documents

* Make sure stdout and stderr don't have buffering, so we see their output immediately

* Handle exit properly

* Make notifications forward on to their previous values

* Remove the exit handler, HIE already has a good default for it

* Add comments on FileStore

BUILD.bazel

@@ -71,6 +71,7 @@ da_haskell_binary(
     hazel_deps = [
         "base",
         "containers",
+        "data-default",
         "directory",
         "extra",
         "ghc-paths",

hie-core.cabal

@@ -111,6 +111,7 @@ executable hie-core
         directory,
         hie-bios,
         shake,
+        data-default,
         ghc-paths,
         ghc,
         extra,

src/Development/IDE/Core/FileStore.hs

@@ -6,6 +6,7 @@
 module Development.IDE.Core.FileStore(
     getFileExists, getFileContents,
     setBufferModified,
+    setSomethingModified,
     fileStoreRules,
     VFSHandle,
     makeVFSHandle,
@@ -44,7 +45,10 @@ import Language.Haskell.LSP.VFS
 -- like `setBufferModified` we abstract over the VFS implementation.
 data VFSHandle = VFSHandle
     { getVirtualFile :: NormalizedUri -> IO (Maybe VirtualFile)
-    , setVirtualFileContents :: NormalizedUri -> Maybe T.Text -> IO ()
+        -- ^ get the contents of a virtual file
+    , setVirtualFileContents :: Maybe (NormalizedUri -> Maybe T.Text -> IO ())
+        -- ^ set a specific file to a value. If Nothing then we are ignoring these
+        --   signals anyway so can just say something was modified
     }
 
 instance IsIdeGlobal VFSHandle
@@ -56,7 +60,7 @@ makeVFSHandle = do
         { getVirtualFile = \uri -> do
               (_nextVersion, vfs) <- readVar vfsVar
               pure $ Map.lookup uri vfs
-        , setVirtualFileContents = \uri content ->
+        , setVirtualFileContents = Just $ \uri content ->
               modifyVar_ vfsVar $ \(nextVersion, vfs) -> pure $ (nextVersion + 1, ) $
                   case content of
                     Nothing -> Map.delete uri vfs
@@ -66,8 +70,7 @@ makeVFSHandle = do
 makeLSPVFSHandle :: LspFuncs c -> VFSHandle
 makeLSPVFSHandle lspFuncs = VFSHandle
     { getVirtualFile = getVirtualFileFunc lspFuncs
-    , setVirtualFileContents = \_ _ -> pure ()
-    -- ^ Handled internally by haskell-lsp.
+    , setVirtualFileContents = Nothing
    }
 
 
@@ -158,11 +161,24 @@ fileStoreRules vfs = do
     getFileExistsRule vfs
 
 
--- | Notify the compiler service of a modified buffer
+-- | Notify the compiler service that a particular file has been modified.
+--   Use 'Nothing' to say the file is no longer in the virtual file system
+--   but should be sourced from disk, or 'Just' to give its new value.
 setBufferModified :: IdeState -> NormalizedFilePath -> Maybe T.Text -> IO ()
 setBufferModified state absFile contents = do
     VFSHandle{..} <- getIdeGlobalState state
-    setVirtualFileContents (filePathToUri' absFile) contents
+    whenJust setVirtualFileContents $ \set ->
+        set (filePathToUri' absFile) contents
+    void $ shakeRun state [] (const $ pure ())
+
+-- | Note that some buffer somewhere has been modified, but don't say what.
+--   Only valid if the virtual file system was initialised by LSP, as that
+--   independently tracks which files are modified.
+setSomethingModified :: IdeState -> IO ()
+setSomethingModified state = do
+    VFSHandle{..} <- getIdeGlobalState state
+    when (isJust setVirtualFileContents) $
+        fail "setSomethingModified can't be called on this type of VFSHandle"
     void $ shakeRun state [] (const $ pure ())
 
 

src/Development/IDE/LSP/Definition.hs

@@ -39,7 +39,7 @@ gotoDefinition ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos)
         Just loc -> SingleLoc loc
 
 
-setHandlersDefinition :: WithMessage -> LSP.Handlers -> IO LSP.Handlers
-setHandlersDefinition WithMessage{..} x = return x{
+setHandlersDefinition :: PartialHandlers
+setHandlersDefinition = PartialHandlers $ \WithMessage{..} x -> return x{
     LSP.definitionHandler = withResponse RspDefinition gotoDefinition
     }

src/Development/IDE/LSP/Hover.hs

@@ -43,7 +43,7 @@ onHover ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = do
 
         Nothing -> pure Nothing
 
-setHandlersHover :: WithMessage -> LSP.Handlers -> IO LSP.Handlers
-setHandlersHover WithMessage{..} x = return x{
+setHandlersHover :: PartialHandlers
+setHandlersHover = PartialHandlers $ \WithMessage{..} x -> return x{
     LSP.hoverHandler = withResponse RspHover onHover
     }

src/Development/IDE/LSP/LanguageServer.hs

@@ -18,9 +18,10 @@ import Control.Concurrent.Chan
 import Control.Concurrent.Extra
 import Control.Concurrent.Async
 import Data.Default
+import Data.Maybe
 import           GHC.IO.Handle                    (hDuplicate, hDuplicateTo)
 import System.IO
-import Control.Monad
+import Control.Monad.Extra
 
 import Development.IDE.LSP.Definition
 import Development.IDE.LSP.Hover
@@ -32,14 +33,18 @@ import Language.Haskell.LSP.Messages
 
 
 runLanguageServer
-    :: ((FromServerMessage -> IO ()) -> VFSHandle -> IO IdeState)
+    :: LSP.Options
+    -> PartialHandlers
+    -> ((FromServerMessage -> IO ()) -> VFSHandle -> IO IdeState)
     -> IO ()
-runLanguageServer getIdeState = do
+runLanguageServer options userHandlers getIdeState = do
     -- Move stdout to another file descriptor and duplicate stderr
     -- to stdout. This guards against stray prints from corrupting the JSON-RPC
     -- message stream.
     newStdout <- hDuplicate stdout
     stderr `hDuplicateTo` stdout
+    hSetBuffering stderr NoBuffering
+    hSetBuffering stdout NoBuffering
 
     -- Print out a single space to assert that the above redirection works.
     -- This is interleaved with the logger, hence we just print a space here in
@@ -57,9 +62,13 @@ runLanguageServer getIdeState = do
     clientMsgBarrier <- newBarrier
 
     let withResponse wrap f = Just $ \r -> writeChan clientMsgChan $ Response r wrap f
-    let withNotification f = Just $ \r -> writeChan clientMsgChan $ Notification r f
-    let runHandler = WithMessage{withResponse, withNotification}
-    handlers <- mergeHandlers [setHandlersDefinition, setHandlersHover, setHandlersNotifications, setHandlersIgnore] runHandler def
+    let withNotification old f = Just $ \r -> writeChan clientMsgChan $ Notification r (\ide x -> f ide x >> whenJust old ($ r))
+    let PartialHandlers parts =
+            setHandlersIgnore <> -- least important
+            setHandlersDefinition <> setHandlersHover <> -- useful features someone may override
+            userHandlers <>
+            setHandlersNotifications -- absolutely critical, join them with user notifications
+    handlers <- parts WithMessage{withResponse, withNotification} def
 
     void $ waitAnyCancel =<< traverse async
         [ void $ LSP.runWithHandles
@@ -69,7 +78,7 @@ runLanguageServer getIdeState = do
             , handleInit (signalBarrier clientMsgBarrier ()) clientMsgChan
             )
             handlers
-            options
+            (modifyOptions options)
             Nothing
         , void $ waitBarrier clientMsgBarrier
         ]
@@ -89,20 +98,14 @@ runLanguageServer getIdeState = do
 
 -- | Things that get sent to us, but we don't deal with.
 --   Set them to avoid a warning in VS Code output.
-setHandlersIgnore :: WithMessage -> LSP.Handlers -> IO LSP.Handlers
-setHandlersIgnore _ x = return x
+setHandlersIgnore :: PartialHandlers
+setHandlersIgnore = PartialHandlers $ \_ x -> return x
     {LSP.cancelNotificationHandler = none
     ,LSP.initializedHandler = none
-    ,LSP.codeLensHandler = none -- FIXME: Stop saying we support it in 'options'
     }
     where none = Just $ const $ return ()
 
 
-mergeHandlers :: [WithMessage -> LSP.Handlers -> IO LSP.Handlers] -> WithMessage -> LSP.Handlers -> IO LSP.Handlers
-mergeHandlers = foldl f (\_ a -> return a)
-    where f x1 x2 r a = x1 r a >>= x2 r
-
-
 -- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety
 --   and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)
 data Message
@@ -110,14 +113,7 @@ data Message
     | forall m req . Notification (NotificationMessage m req) (IdeState -> req -> IO ())
 
 
-options :: LSP.Options
-options = def
-    { LSP.textDocumentSync = Just TextDocumentSyncOptions
-          { _openClose = Just True
-          , _change = Just TdSyncIncremental
-          , _willSave = Nothing
-          , _willSaveWaitUntil = Nothing
-          , _save = Just $ SaveOptions $ Just False
-          }
-    , LSP.codeLensProvider = Just $ CodeLensOptions $ Just False
-    }
+modifyOptions :: LSP.Options -> LSP.Options
+modifyOptions x = x{LSP.textDocumentSync = Just orig{_openClose=Just True, _change=Just TdSyncIncremental}}
+    where orig = fromMaybe tdsDefault $ LSP.textDocumentSync x
+          tdsDefault = TextDocumentSyncOptions Nothing Nothing Nothing Nothing Nothing

src/Development/IDE/LSP/Notifications.hs

@@ -12,89 +12,41 @@ module Development.IDE.LSP.Notifications
 import           Development.IDE.LSP.Protocol
 import           Development.IDE.LSP.Server hiding (runServer)
 import qualified Language.Haskell.LSP.Core as LSP
+import qualified Language.Haskell.LSP.Types as LSP
 
 import Development.IDE.Types.Logger
 import Development.IDE.Core.Service
 import Development.IDE.Types.Location
 
 import qualified Data.Set                                  as S
-import qualified Data.Text as T
 
 import Development.IDE.Core.FileStore
 import Development.IDE.Core.OfInterest
 
-import qualified Network.URI                               as URI
 
+whenUriFile :: IdeState -> Uri -> (NormalizedFilePath -> IO ()) -> IO ()
+whenUriFile ide uri act = case LSP.uriToFilePath uri of
+    Just file -> act $ toNormalizedFilePath file
+    Nothing -> logWarning (ideLogger ide) $ "Unknown scheme in URI: " <> getUri uri
 
-textShow :: Show a => a -> T.Text
-textShow = T.pack . show
+setHandlersNotifications :: PartialHandlers
+setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x
+    {LSP.didOpenTextDocumentNotificationHandler = withNotification (LSP.didOpenTextDocumentNotificationHandler x) $
+        \ide (DidOpenTextDocumentParams TextDocumentItem{_uri}) -> do
+            setSomethingModified ide
+            whenUriFile ide _uri $ \file ->
+                modifyFilesOfInterest ide (S.insert file)
+            logInfo (ideLogger ide) $ "Opened text document: " <> getUri _uri
 
+    ,LSP.didChangeTextDocumentNotificationHandler = withNotification (LSP.didChangeTextDocumentNotificationHandler x) $
+        \ide (DidChangeTextDocumentParams VersionedTextDocumentIdentifier{_uri} _) -> do
+            setSomethingModified ide
+            logInfo (ideLogger ide) $ "Modified text document: " <> getUri _uri
 
-setHandlersNotifications :: WithMessage -> LSP.Handlers -> IO LSP.Handlers
-setHandlersNotifications WithMessage{..} x = return x{
-    LSP.didOpenTextDocumentNotificationHandler = withNotification $ \ide (DidOpenTextDocumentParams item) -> do
-        case URI.parseURI $ T.unpack $ getUri $ _uri (item :: TextDocumentItem) of
-          Just uri
-              | URI.uriScheme uri == "file:"
-              -> handleDidOpenFile ide item
-
-              | otherwise
-              -> logWarning (ideLogger ide) $ "Unknown scheme in URI: "
-                    <> textShow uri
-
-          _ -> logSeriousError (ideLogger ide) $ "Invalid URI in DidOpenTextDocument: "
-                    <> textShow (_uri (item :: TextDocumentItem))
-
-    ,LSP.didChangeTextDocumentNotificationHandler = withNotification $ \ide (DidChangeTextDocumentParams docId _) -> do
-        let uri = _uri (docId :: VersionedTextDocumentIdentifier)
-
-        case uriToFilePath' uri of
-          Just (toNormalizedFilePath -> filePath) -> do
-            onFileModified ide filePath
-            logInfo (ideLogger ide)
-              $ "Updated text document: " <> textShow (fromNormalizedFilePath filePath)
-
-          Nothing ->
-            logSeriousError (ideLogger ide)
-              $ "Invalid file path: " <> textShow (_uri (docId :: VersionedTextDocumentIdentifier))
-
-    ,LSP.didCloseTextDocumentNotificationHandler = withNotification $ \ide (DidCloseTextDocumentParams (TextDocumentIdentifier uri)) ->
-        case URI.parseURI $ T.unpack $ getUri uri of
-          Just uri'
-              | URI.uriScheme uri' == "file:" -> do
-                    Just fp <- pure $ toNormalizedFilePath <$> uriToFilePath' uri
-                    handleDidCloseFile ide fp
-              | otherwise -> logWarning (ideLogger ide) $ "Unknown scheme in URI: " <> textShow uri
-
-          _ -> logSeriousError (ideLogger ide)
-                 $    "Invalid URI in DidCloseTextDocument: "
-                   <> textShow uri
-
+    ,LSP.didCloseTextDocumentNotificationHandler = withNotification (LSP.didCloseTextDocumentNotificationHandler x) $
+        \ide (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> do
+            setSomethingModified ide
+            whenUriFile ide _uri $ \file ->
+                modifyFilesOfInterest ide (S.delete file)
+            logInfo (ideLogger ide) $ "Closed text document: " <> getUri _uri
   }
-  where
-    -- Note that the state changes here are not atomic.
-    -- When we have parallel compilation we could manage the state
-    -- changes in STM so that we can atomically change the state.
-    -- Internally it should be done via the IO oracle. See PROD-2808.
-    handleDidOpenFile ide (TextDocumentItem uri _ _ _) = do
-        Just filePath <- pure $ toNormalizedFilePath <$> uriToFilePath' uri
-        onFileModified ide filePath
-        modifyFilesOfInterest ide (S.insert filePath)
-        logInfo (ideLogger ide) $ "Opened text document: " <> textShow filePath
-
-    handleDidCloseFile ide filePath = do
-         logInfo (ideLogger ide) $ "Closed text document: " <> textShow (fromNormalizedFilePath filePath)
-         onFileModified ide filePath
-         modifyFilesOfInterest ide (S.delete filePath)
-
-
--- | Manages the file store (caching compilation results and unsaved content).
-onFileModified
-    :: IdeState
-    -> NormalizedFilePath
-    -> IO ()
-onFileModified service fp = do
-    logDebug (ideLogger service) $ "File modified " <> T.pack (show fp)
-    -- if we get here then we must be using the LSP framework, in which case we don't
-    -- need to bother sending file modifications, other than to force the database to rerun
-    setBufferModified service fp Nothing

src/Development/IDE/LSP/Server.hs

@@ -8,6 +8,7 @@ module Development.IDE.LSP.Server
   ( runServer
   , Handlers(..)
   , WithMessage(..)
+  , PartialHandlers(..)
   ) where
 
 
@@ -38,10 +39,26 @@ import Development.IDE.Core.Service
 
 
 data WithMessage = WithMessage
-    {withResponse :: forall m req resp . (ResponseMessage resp -> LSP.FromServerMessage) -> (IdeState -> req -> IO resp) -> Maybe (LSP.Handler (RequestMessage m req resp))
-    ,withNotification :: forall m req . (IdeState -> req -> IO ()) -> Maybe (LSP.Handler (NotificationMessage m req))
+    {withResponse :: forall m req resp .
+        (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
+        (IdeState -> req -> IO resp) -> -- actual work
+        Maybe (LSP.Handler (RequestMessage m req resp))
+    ,withNotification :: forall m req .
+        Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler
+        (IdeState -> req -> IO ()) -> -- actual work
+        Maybe (LSP.Handler (NotificationMessage m req))
     }
 
+newtype PartialHandlers = PartialHandlers (WithMessage -> LSP.Handlers -> IO LSP.Handlers)
+
+instance Default PartialHandlers where
+    def = PartialHandlers $ \_ x -> pure x
+
+instance Semigroup PartialHandlers where
+    PartialHandlers a <> PartialHandlers b = PartialHandlers $ \w x -> a w x >>= b w
+
+instance Monoid PartialHandlers where
+    mempty = def
 
 ------------------------------------------------------------------------
 -- Server execution

test/Demo.hs

@@ -6,6 +6,7 @@ module Demo(main) where
 import Data.Maybe
 import Control.Concurrent.Extra
 import Control.Monad
+import Data.Default
 import System.Time.Extra
 import Development.IDE.Core.FileStore
 import Development.IDE.Core.OfInterest
@@ -58,7 +59,7 @@ main = do
 
     if "--lsp" `elem` args then do
         hPutStrLn stderr "Starting IDE server"
-        runLanguageServer $ \event vfs -> do
+        runLanguageServer def def $ \event vfs -> do
             hPutStrLn stderr "Server started"
             initialise (mainRule >> action kick) event logger options vfs
     else do