haskell-lsp 0.17.0.0 → 0.18.0.0

raw patch · 10 files changed

+283/−169 lines, 10 filesdep ~haskell-lsp-typesPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: haskell-lsp-types

API changes (from Hackage documentation)

Files

• ChangeLog.md +12/−0
• haskell-lsp.cabal +2/−2
• src/Language/Haskell/LSP/Capture.hs +2/−2
• src/Language/Haskell/LSP/Control.hs +4/−3
• src/Language/Haskell/LSP/Core.hs +193/−122
• src/Language/Haskell/LSP/VFS.hs +62/−37
• test/InitialConfigurationSpec.hs +3/−1
• test/JsonSpec.hs +1/−0
• test/VspSpec.hs +1/−1
• test/WorkspaceFoldersSpec.hs +3/−1

@@ -1,5 +1,17 @@ # Revision history for haskell-lsp +## 0.18.0.0 -- 2019-11-17++* Explain the use of NonEmpty in+  documentOnTypeFormattingTriggerCharacters (@bubba)+* Fix response type for CodeLensResolve, add the ContentModified error+  code (@SquidDev)+* Virtual file fixes, removing race conditions and other cleanups (@mpickering)+* Add missing fmClientPrepareRenameRequest to MessageFuncs export (@alanz)+* Make explicit GHC 8.6.5 stack file (@alanz)+* Rework Core.Options and infer all server capabilities from handlers (@bubba)+* Generate lenses for WorkDoneProgress data types (@alanz)+ ## 0.17.0.0 -- 2019-10-18  * Update progress reporting to match the LSP 3.15 specification (@cocreature)

@@ -1,5 +1,5 @@ name:                haskell-lsp-version:             0.17.0.0+version:             0.18.0.0 synopsis:            Haskell library for the Microsoft Language Server Protocol  description:         An implementation of the types, and basic message server to@@ -46,7 +46,7 @@                      , filepath                      , hslogger                      , hashable-                     , haskell-lsp-types == 0.17.*+                     , haskell-lsp-types == 0.18.*                      , lens >= 4.15.2                      , mtl                      , network-uri

@@ -18,7 +18,7 @@ captureFromServer msg (Just fp) = do   time <- getCurrentTime   let entry = FromServer time msg-  +   BSL.appendFile fp $ BSL.append (encode entry) "\n"  captureFromClient :: FromClientMessage -> Maybe FilePath -> IO ()@@ -26,5 +26,5 @@ captureFromClient msg (Just fp) = do   time <- getCurrentTime   let entry = FromClient time msg-  +   BSL.appendFile fp $ BSL.append (encode entry) "\n"

@@ -31,6 +31,7 @@ import           Language.Haskell.LSP.Capture import qualified Language.Haskell.LSP.Core as Core import           Language.Haskell.LSP.Messages+import           Language.Haskell.LSP.VFS import           Language.Haskell.LSP.Utility import           System.IO import           System.FilePath@@ -83,10 +84,10 @@   let lf = error "LifeCycle error, ClientCapabilities not set yet via initialize maessage"    tvarId <- atomically $ newTVar 0--  tvarDat <- atomically $ newTVar $ Core.defaultLanguageContextData h o lf tvarId sendFunc timestampCaptureFp+  initVFS $ \vfs -> do+    tvarDat <- atomically $ newTVar $ Core.defaultLanguageContextData h o lf tvarId sendFunc timestampCaptureFp vfs -  ioLoop hin initializeCallbacks tvarDat+    ioLoop hin initializeCallbacks tvarDat    return 1 

@@ -9,6 +9,7 @@ module Language.Haskell.LSP.Core (     handleMessage   , LanguageContextData(..)+  , VFSData(..)   , Handler   , InitializeCallbacks(..)   , LspFuncs(..)@@ -28,18 +29,19 @@   , reverseSortEdit   ) where -import           Control.Concurrent.STM 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 ( (<&>), (^.) )+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@@ -79,8 +81,7 @@   , resHandlers            :: !Handlers   , resOptions             :: !Options   , resSendResponse        :: !SendFunc-  , resVFS                 :: !VFS-  , reverseMap             :: !(Map.Map FilePath FilePath)+  , resVFS                 :: !VFSData   , resDiagnostics         :: !DiagnosticStore   , resConfig              :: !(Maybe config)   , resLspId               :: !(TVar Int)@@ -93,31 +94,46 @@ data ProgressData = ProgressData { progressNextId :: !Int                                  , progressCancel :: !(Map.Map J.ProgressToken (IO ())) } +data VFSData =+  VFSData+    { vfsData :: !VFS+    , reverseMap :: !(Map.Map FilePath FilePath)+    }+ -- --------------------------------------------------------------------- --- | Language Server Protocol options supported by the given language server.--- These are automatically turned into capabilities reported to the client--- during initialization.+-- | 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     { textDocumentSync                 :: Maybe J.TextDocumentSyncOptions-    , completionProvider               :: Maybe J.CompletionOptions-    , signatureHelpProvider            :: Maybe J.SignatureHelpOptions-    , typeDefinitionProvider           :: Maybe J.GotoOptions-    , implementationProvider           :: Maybe J.GotoOptions-    , codeActionProvider               :: Maybe J.CodeActionOptions-    , codeLensProvider                 :: Maybe J.CodeLensOptions-    , documentOnTypeFormattingProvider :: Maybe J.DocumentOnTypeFormattingOptions-    , renameProvider                   :: Maybe J.RenameOptions-    , documentLinkProvider             :: Maybe J.DocumentLinkOptions-    , colorProvider                    :: Maybe J.ColorOptions-    , foldingRangeProvider             :: Maybe J.FoldingRangeOptions-    , executeCommandProvider           :: Maybe J.ExecuteCommandOptions+    -- |  The characters that trigger completion automatically.+    , 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`.+    , completionAllCommitCharacters    :: Maybe [Char]+    -- | The characters that trigger signature help automatically.+    , 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.+    , 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.+    , 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.+    , documentOnTypeFormattingTriggerCharacters :: Maybe (NonEmpty Char)+    -- | The commands to be executed on the server.+    -- If you set `executeCommandHandler`, you **must** set this.+    , executeCommandCommands           :: Maybe [Text]     }  instance Default Options where   def = Options Nothing Nothing Nothing Nothing Nothing-                Nothing Nothing Nothing Nothing Nothing                 Nothing Nothing Nothing  -- | A function to publish diagnostics. It aggregates all diagnostics pertaining@@ -159,6 +175,8 @@       -- server-provided function.     , sendFunc                     :: !SendFunc     , getVirtualFileFunc           :: !(J.NormalizedUri -> IO (Maybe VirtualFile))+      -- ^ Function to return the 'VirtualFile' associated with a+      -- given 'NormalizedUri', if there is one.     , persistVirtualFileFunc       :: !(J.NormalizedUri -> IO FilePath)     , reverseFileMapFunc           :: !(IO (FilePath -> FilePath))     , publishDiagnosticsFunc       :: !PublishDiagnosticsFunc@@ -236,7 +254,7 @@     , colorPresentationHandler       :: !(Maybe (Handler J.ColorPresentationRequest))     , documentFormattingHandler      :: !(Maybe (Handler J.DocumentFormattingRequest))     , documentRangeFormattingHandler :: !(Maybe (Handler J.DocumentRangeFormattingRequest))-    , documentTypeFormattingHandler  :: !(Maybe (Handler J.DocumentOnTypeFormattingRequest))+    , documentOnTypeFormattingHandler :: !(Maybe (Handler J.DocumentOnTypeFormattingRequest))     , renameHandler                  :: !(Maybe (Handler J.RenameRequest))     , prepareRenameHandler           :: !(Maybe (Handler J.PrepareRenameRequest))     , foldingRangeHandler            :: !(Maybe (Handler J.FoldingRangeRequest))@@ -297,8 +315,8 @@                               Nothing Nothing Nothing Nothing Nothing  -- ----------------------------------------------------------------------nop :: a -> b -> IO a-nop = const . return+nop :: Maybe (a -> b -> (a,[String]))+nop = Nothing   helper :: J.FromJSON a => (TVar (LanguageContextData config) -> a -> IO ()) -> (TVar (LanguageContextData config) -> J.Value -> IO ())@@ -316,8 +334,9 @@           _ -> failLog         _ -> failLog -handlerMap :: (Show config) => InitializeCallbacks config-           -> Handlers -> J.ClientMethod -> (TVar (LanguageContextData config) -> J.Value -> IO ())+handlerMap :: (Show config)+           => InitializeCallbacks config -> Handlers -> J.ClientMethod+           -> (TVar (LanguageContextData config) -> J.Value -> IO ()) -- General handlerMap i h J.Initialize                      = handleInitialConfig i (initializeRequestHandler h) handlerMap _ h J.Initialized                     = hh nop NotInitialized $ initializedHandler h@@ -341,12 +360,12 @@ handlerMap _ h J.WorkspaceSymbol                 = hh nop ReqWorkspaceSymbols $ workspaceSymbolHandler h handlerMap _ h J.WorkspaceExecuteCommand         = hh nop ReqExecuteCommand $ executeCommandHandler h -- Document-handlerMap _ h J.TextDocumentDidOpen             = hh openVFS NotDidOpenTextDocument $ didOpenTextDocumentNotificationHandler h-handlerMap _ h J.TextDocumentDidChange           = hh changeFromClientVFS NotDidChangeTextDocument $ didChangeTextDocumentNotificationHandler h+handlerMap _ h J.TextDocumentDidOpen             = hh (Just openVFS) NotDidOpenTextDocument $ didOpenTextDocumentNotificationHandler h+handlerMap _ h J.TextDocumentDidChange           = hh (Just changeFromClientVFS) NotDidChangeTextDocument $ didChangeTextDocumentNotificationHandler h handlerMap _ h J.TextDocumentWillSave            = hh nop NotWillSaveTextDocument $ willSaveTextDocumentNotificationHandler h handlerMap _ h J.TextDocumentWillSaveWaitUntil   = hh nop ReqWillSaveWaitUntil $ willSaveWaitUntilTextDocHandler h handlerMap _ h J.TextDocumentDidSave             = hh nop NotDidSaveTextDocument $ didSaveTextDocumentNotificationHandler h-handlerMap _ h J.TextDocumentDidClose            = hh closeVFS NotDidCloseTextDocument $ didCloseTextDocumentNotificationHandler h+handlerMap _ h J.TextDocumentDidClose            = hh (Just closeVFS) NotDidCloseTextDocument $ didCloseTextDocumentNotificationHandler h handlerMap _ h J.TextDocumentCompletion          = hh nop ReqCompletion $ completionHandler h handlerMap _ h J.CompletionItemResolve           = hh nop ReqCompletionItemResolve $ completionResolveHandler h handlerMap _ h J.TextDocumentHover               = hh nop ReqHover $ hoverHandler h@@ -359,7 +378,7 @@ handlerMap _ h J.TextDocumentDocumentSymbol      = hh nop ReqDocumentSymbols $ documentSymbolHandler h handlerMap _ h J.TextDocumentFormatting          = hh nop ReqDocumentFormatting $ documentFormattingHandler h handlerMap _ h J.TextDocumentRangeFormatting     = hh nop ReqDocumentRangeFormatting $ documentRangeFormattingHandler h-handlerMap _ h J.TextDocumentOnTypeFormatting    = hh nop ReqDocumentOnTypeFormatting $ documentTypeFormattingHandler h+handlerMap _ h J.TextDocumentOnTypeFormatting    = hh nop ReqDocumentOnTypeFormatting $ documentOnTypeFormattingHandler h handlerMap _ h J.TextDocumentCodeAction          = hh nop ReqCodeAction $ codeActionHandler h handlerMap _ h J.TextDocumentCodeLens            = hh nop ReqCodeLens $ codeLensHandler h handlerMap _ h J.CodeLensResolve                 = hh nop ReqCodeLensResolve $ codeLensResolveHandler h@@ -384,14 +403,19 @@ -- | Adapter from the normal handlers exposed to the library users and the -- internal message loop hh :: forall b config. (J.FromJSON b)-   => (VFS -> b -> IO VFS) -> (b -> FromClientMessage) -> Maybe (Handler b) -> TVar (LanguageContextData config) -> J.Value -> IO ()-hh getVfs wrapper mh tvarDat json = do+   => Maybe (VFS -> b -> (VFS, [String])) -> (b -> FromClientMessage) -> Maybe (Handler b)+   -> TVar (LanguageContextData config) -> J.Value -> IO ()+hh mVfs wrapper mh tvarDat json = do       case J.fromJSON json of         J.Success req -> do-          ctx <- readTVarIO tvarDat-          vfs' <- getVfs (resVFS ctx) req-          atomically $ modifyTVar' tvarDat (\c -> c {resVFS = vfs'})+          case mVfs of+            Just modifyVfs -> do+              join $ atomically $ modifyVFSData tvarDat $ \(VFSData vfs rm) ->+                let (vfs', ls) = modifyVfs vfs req+                in (VFSData vfs' rm, mapM_ logs ls)+            Nothing -> return () +          ctx <- readTVarIO tvarDat           captureFromClient (wrapper req) (resCaptureFile ctx)            case mh of@@ -455,10 +479,8 @@               T.pack $ unwords                 ["haskell-lsp:configuration parse error.", show req, show err]           sendErrorLog tvarDat msg-        Right newConfig -> do-          -- logs $ "haskell-lsp:hc DidChangeConfigurationNotification got newConfig:" ++ show newConfig-          let ctx' = ctx { resConfig = Just newConfig }-          atomically $ modifyTVar' tvarDat (const ctx')+        Right newConfig ->+          atomically $ modifyTVar' tvarDat (\ctx' -> ctx' { resConfig = Just newConfig })       case mh of         Just h  -> h req         Nothing -> return ()@@ -488,18 +510,28 @@  -- --------------------------------------------------------------------- +modifyVFSData :: TVar (LanguageContextData config) -> (VFSData -> (VFSData, a)) -> STM a+modifyVFSData tvarDat f = do+  (vfs', a) <- f . resVFS <$> readTVar tvarDat+  modifyTVar tvarDat $ \vd -> vd { resVFS = vfs' }+  return a++-- ---------------------------------------------------------------------++-- | Return the 'VirtualFile' associated with a given 'NormalizedUri', if there is one. getVirtualFile :: TVar (LanguageContextData config) -> J.NormalizedUri -> IO (Maybe VirtualFile)-getVirtualFile tvarDat uri = Map.lookup uri . resVFS <$> readTVarIO tvarDat+getVirtualFile tvarDat uri = Map.lookup uri . vfsMap . vfsData . resVFS <$> readTVarIO 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 FilePath-persistVirtualFile tvarDat uri = do-  st <- readTVarIO tvarDat-  let vfs = resVFS st-      revMap = reverseMap st+persistVirtualFile tvarDat uri = join $ atomically $ do+  st <- readTVar tvarDat+  let vfs_data = resVFS st+      cur_vfs = vfsData vfs_data+      revMap = reverseMap vfs_data -  (fn, new_vfs) <- persistFileVFS vfs uri+  let (fn, write) = persistFileVFS cur_vfs uri   let revMap' =         -- TODO: Does the VFS make sense for URIs which are not files?         -- The reverse map should perhaps be (FilePath -> URI)@@ -507,9 +539,8 @@           Just uri_fp -> Map.insert fn uri_fp revMap           Nothing -> revMap -  atomically $ modifyTVar' tvarDat (\d -> d { resVFS = new_vfs-                                            , reverseMap = revMap' })-  return fn+  modifyVFSData tvarDat (\d -> (d { reverseMap = revMap' }, ()))+  return (fn <$ write)  -- TODO: should this function return a URI? -- | If the contents of a VFS has been dumped to a temporary file, map@@ -517,9 +548,9 @@ reverseFileMap :: TVar (LanguageContextData config)                -> IO (FilePath -> FilePath) reverseFileMap tvarDat = do-  revMap <- reverseMap <$> readTVarIO tvarDat-  let f fp = fromMaybe fp $ Map.lookup fp revMap-  return f+    vfs <- resVFS <$> readTVarIO tvarDat+    let f fp = fromMaybe fp . Map.lookup fp . reverseMap $ vfs+    return f  -- --------------------------------------------------------------------- @@ -558,9 +589,9 @@ -- | -- ---defaultLanguageContextData :: Handlers -> Options -> LspFuncs config -> TVar Int -> SendFunc -> Maybe FilePath -> LanguageContextData config-defaultLanguageContextData h o lf tv sf cf =-  LanguageContextData _INITIAL_RESPONSE_SEQUENCE h o sf mempty mempty mempty+defaultLanguageContextData :: Handlers -> Options -> LspFuncs config -> TVar Int -> SendFunc -> Maybe FilePath -> VFS -> LanguageContextData config+defaultLanguageContextData h o lf tv sf cf vfs =+  LanguageContextData _INITIAL_RESPONSE_SEQUENCE h o sf (VFSData vfs mempty) mempty                       Nothing tv lf cf mempty defaultProgressData  defaultProgressData :: ProgressData@@ -758,7 +789,7 @@                     -> ((Progress -> IO ()) -> IO a) -> IO a)       withProgressBase indefinite title cancellable f         | clientSupportsProgress = do-          sf <- liftIO $ resSendResponse <$> readTVarIO tvarCtx+          let sf = sendResponse tvarCtx            progId <- getNewProgressId @@ -821,9 +852,10 @@                             (getWfs tvarCtx)                             withProgress'                             withIndefiniteProgress'-    let ctx = ctx0 { resLspFuncs = lspFuncs }-    atomically $ writeTVar tvarCtx ctx+    atomically $ modifyTVar tvarCtx (\cur_ctx -> cur_ctx { resLspFuncs = lspFuncs }) +    ctx <- readTVarIO tvarCtx+     initializationResult <- onStartup lspFuncs      case initializationResult of@@ -831,68 +863,106 @@         sendResponse tvarCtx $ RspError $ makeResponseError (J.responseId origId) errResp        Nothing -> do+        let capa = serverCapabilities (getCapabilities params) (resOptions ctx) (resHandlers ctx)+            -- TODO: wrap this up into a fn to create a response message+            res  = J.ResponseMessage "2.0" (J.responseId origId) (Just $ J.InitializeResponseCapabilities capa) Nothing -        let-          h = resHandlers ctx-          o = resOptions  ctx+        sendResponse tvarCtx $ RspInitialize res -          supported (Just _) = Just True-          supported Nothing   = Nothing+-- | 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 clientCaps o h =+  J.InitializeResponseCapabilitiesInner+    { J._textDocumentSync                 = sync+    , J._hoverProvider                    = supported (hoverHandler h)+    , J._completionProvider               = completionProvider+    , J._signatureHelpProvider            = signatureHelpProvider+    , J._definitionProvider               = supported (definitionHandler h)+    , J._typeDefinitionProvider           = Just $ J.GotoOptionsStatic $ isJust $ typeDefinitionHandler h+    , J._implementationProvider           = Just $ J.GotoOptionsStatic $ isJust $ typeDefinitionHandler h+    , J._referencesProvider               = supported (referencesHandler h)+    , J._documentHighlightProvider        = supported (documentHighlightHandler h)+    , J._documentSymbolProvider           = supported (documentSymbolHandler h)+    , J._workspaceSymbolProvider          = supported (workspaceSymbolHandler h)+    , J._codeActionProvider               = codeActionProvider+    , J._codeLensProvider                 = supported' (codeLensHandler h) $ J.CodeLensOptions $+                                              supported (codeLensResolveHandler h)+    , J._documentFormattingProvider       = supported (documentFormattingHandler h)+    , J._documentRangeFormattingProvider  = supported (documentRangeFormattingHandler h)+    , J._documentOnTypeFormattingProvider = documentOnTypeFormattingProvider+    , J._renameProvider                   = Just $ J.RenameOptionsStatic $ isJust $ renameHandler h+    , J._documentLinkProvider             = supported' (documentLinkHandler h) $ J.DocumentLinkOptions $+                                              Just $ isJust $ documentLinkResolveHandler h+    , J._colorProvider                    = Just $ J.ColorOptionsStatic $ isJust $ documentColorHandler h+    , J._foldingRangeProvider             = Just $ J.FoldingRangeOptionsStatic $ isJust $ foldingRangeHandler h+    , J._executeCommandProvider           = executeCommandProvider+    , J._workspace                        = Just workspace+    -- TODO: Add something for experimental+    , J._experimental                     = Nothing :: Maybe J.Value+    }+  where+    supported x = supported' x True -          -- If a dynamic setting is provided use it, else set a-          -- static True if there is a handler.-          static (Just d) _ = Just d-          static _ (Just _) = Just (J.GotoOptionsStatic True)-          static _ Nothing  = Nothing-          -          static' (Just d) (Just _) = Just d-          static' _ (Just _) = Just (J.CodeActionOptionsStatic True)-          static' _ _  = Nothing+    supported' (Just _) = Just+    supported' Nothing = const Nothing -          sync = case textDocumentSync o of-                  Just x -> Just (J.TDSOptions x)-                  Nothing -> Nothing+    singleton :: a -> [a]+    singleton x = [x] -          workspace = J.WorkspaceOptions workspaceFolder-          workspaceFolder = case didChangeWorkspaceFoldersNotificationHandler h of-            Just _ -> Just $-              -- sign up to receive notifications-              J.WorkspaceFolderOptions (Just True) (Just (J.WorkspaceFolderChangeNotificationsBool True))-            Nothing -> Nothing+    completionProvider+      | isJust $ completionHandler h = Just $+          J.CompletionOptions+            (Just $ isJust $ completionResolveHandler h)+            (map singleton <$> completionTriggerCharacters o)+            (map singleton <$> completionAllCommitCharacters o)+      | otherwise = Nothing -          capa =-            J.InitializeResponseCapabilitiesInner-              { J._textDocumentSync                 = sync-              , J._hoverProvider                    = supported (hoverHandler h)-              , J._completionProvider               = completionProvider o-              , J._signatureHelpProvider            = signatureHelpProvider o-              , J._definitionProvider               = supported (definitionHandler h)-              , J._typeDefinitionProvider           = static (typeDefinitionProvider o) (typeDefinitionHandler h)-              , J._implementationProvider           = implementationProvider o-              , J._referencesProvider               = supported (referencesHandler h)-              , J._documentHighlightProvider        = supported (documentHighlightHandler h)-              , J._documentSymbolProvider           = supported (documentSymbolHandler h)-              , J._workspaceSymbolProvider          = supported (workspaceSymbolHandler h)-              , J._codeActionProvider               = static' (codeActionProvider o) (codeActionHandler h)-              , J._codeLensProvider                 = codeLensProvider o-              , J._documentFormattingProvider       = supported (documentFormattingHandler h)-              , J._documentRangeFormattingProvider  = supported (documentRangeFormattingHandler h)-              , J._documentOnTypeFormattingProvider = documentOnTypeFormattingProvider o-              , J._renameProvider                   = renameProvider o-              , J._documentLinkProvider             = documentLinkProvider o-              , J._colorProvider                    = colorProvider o-              , J._foldingRangeProvider             = foldingRangeProvider o-              , J._executeCommandProvider           = executeCommandProvider o-              , J._workspace                        = Just workspace-              -- TODO: Add something for experimental-              , J._experimental                     = Nothing :: Maybe J.Value-              }+    clientSupportsCodeActionKinds = isJust $+      clientCaps ^? J.textDocument . _Just . J.codeAction . _Just . J.codeActionLiteralSupport -          -- TODO: wrap this up into a fn to create a response message-          res  = J.ResponseMessage "2.0" (J.responseId origId) (Just $ J.InitializeResponseCapabilities capa) Nothing+    codeActionProvider+      | clientSupportsCodeActionKinds+      , isJust $ codeActionHandler h = Just $ maybe (J.CodeActionOptionsStatic True) (J.CodeActionOptions . Just) (codeActionKinds o)+      | isJust $ codeActionHandler h = Just (J.CodeActionOptionsStatic True)+      | otherwise = Just (J.CodeActionOptionsStatic False) -        sendResponse tvarCtx $ RspInitialize res+    signatureHelpProvider+      | isJust $ signatureHelpHandler h = Just $+          J.SignatureHelpOptions+            (map singleton <$> signatureHelpTriggerCharacters o)+            (map singleton <$> signatureHelpRetriggerCharacters o)+      | otherwise = Nothing +    documentOnTypeFormattingProvider+      | isJust $ documentOnTypeFormattingHandler h+      , Just (first :| rest) <- documentOnTypeFormattingTriggerCharacters o = Just $+          J.DocumentOnTypeFormattingOptions (T.pack [first]) (Just (map (T.pack . singleton) rest))+      | isJust $ documentOnTypeFormattingHandler h+      , Nothing <- documentOnTypeFormattingTriggerCharacters o =+          error "documentOnTypeFormattingTriggerCharacters needs to be set if a documentOnTypeFormattingHandler is set"+      | otherwise = Nothing++    executeCommandProvider+      | isJust $ executeCommandHandler h+      , Just cmds <- executeCommandCommands o = Just (J.ExecuteCommandOptions (J.List cmds))+      | isJust $ executeCommandHandler h+      , Nothing <- executeCommandCommands o =+          error "executeCommandCommands needs to be set if a executeCommandHandler is set"+      | otherwise = Nothing++    sync = case textDocumentSync o of+            Just x -> Just (J.TDSOptions x)+            Nothing -> Nothing++    workspace = J.WorkspaceOptions workspaceFolder+    workspaceFolder = case didChangeWorkspaceFoldersNotificationHandler h of+      Just _ -> Just $+        -- sign up to receive notifications+        J.WorkspaceFolderOptions (Just True) (Just (J.WorkspaceFolderChangeNotificationsBool True))+      Nothing -> Nothing+ progressCancelHandler :: TVar (LanguageContextData config) -> J.WorkDoneProgressCancelNotification -> IO () progressCancelHandler tvarCtx (J.NotificationMessage _ _ (J.WorkDoneProgressCancelParams tid)) = do   mact <- Map.lookup tid . progressCancel . resProgressData <$> readTVarIO tvarCtx@@ -916,28 +986,29 @@ -- and version, and publish the total to the client. publishDiagnostics :: TVar (LanguageContextData config) -> PublishDiagnosticsFunc publishDiagnostics tvarDat maxDiagnosticCount uri version diags = do-  ctx <- readTVarIO tvarDat-  let ds = updateDiagnostics (resDiagnostics ctx) uri version diags-  atomically $ writeTVar tvarDat $ ctx{resDiagnostics = ds}-  let mdp = getDiagnosticParamsFor maxDiagnosticCount ds uri-  case mdp of-    Nothing -> return ()-    Just params -> do-      resSendResponse ctx $ NotPublishDiagnostics-        $ J.NotificationMessage "2.0" J.TextDocumentPublishDiagnostics params+  join $ atomically $ do+    ctx <- readTVar tvarDat+    let ds = updateDiagnostics (resDiagnostics ctx) uri version diags+    writeTVar tvarDat $ ctx{resDiagnostics = ds}+    let mdp = getDiagnosticParamsFor maxDiagnosticCount ds uri+    return $ case mdp of+      Nothing -> return ()+      Just params ->+        resSendResponse ctx $ NotPublishDiagnostics+          $ J.NotificationMessage "2.0" J.TextDocumentPublishDiagnostics 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 tvarDat maxDiagnosticCount msource = do+flushDiagnosticsBySource tvarDat maxDiagnosticCount msource = join $ atomically $ do   -- logs $ "haskell-lsp:flushDiagnosticsBySource:source=" ++ show source-  ctx <- readTVarIO tvarDat+  ctx <- readTVar tvarDat   let ds = flushBySource (resDiagnostics ctx) msource-  atomically $ writeTVar tvarDat $ ctx {resDiagnostics = ds}+  writeTVar tvarDat $ ctx {resDiagnostics = ds}   -- Send the updated diagnostics to the client-  forM_ (Map.keys ds) $ \uri -> do+  return $ forM_ (Map.keys ds) $ \uri -> do     -- logs $ "haskell-lsp:flushDiagnosticsBySource:uri=" ++ show uri     let mdp = getDiagnosticParamsFor maxDiagnosticCount ds uri     case mdp of

@@ -4,6 +4,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}  {-| Handles the "Language.Haskell.LSP.Types.TextDocumentDidChange" \/@@ -14,13 +15,15 @@ -} module Language.Haskell.LSP.VFS   (-    VFS+    VFS(..)   , VirtualFile(..)+  , initVFS   , openVFS   , changeFromClientVFS   , changeFromServerVFS   , persistFileVFS   , closeVFS+  , updateVFS    -- * manipulating the file contents   , rangeLinesFromVfs@@ -40,10 +43,6 @@ import qualified Data.Text as T import           Data.List import           Data.Ord-#if __GLASGOW_HASKELL__ < 804-import           Data.Monoid-#endif-import           System.IO.Temp import qualified Data.HashMap.Strict as HashMap import qualified Data.Map as Map import           Data.Maybe@@ -52,6 +51,10 @@ import qualified Language.Haskell.LSP.Types           as J import qualified Language.Haskell.LSP.Types.Lens      as J import           Language.Haskell.LSP.Utility+import           System.FilePath+import           Data.Hashable+import           System.Directory+import           System.IO.Temp  -- --------------------------------------------------------------------- {-# ANN module ("hlint: ignore Eta reduce" :: String) #-}@@ -62,35 +65,50 @@   VirtualFile {       _version :: Int     , _text    :: Rope-    , _tmp_file :: Maybe FilePath     } deriving (Show) -type VFS = Map.Map J.NormalizedUri VirtualFile+type VFSMap = Map.Map J.NormalizedUri VirtualFile +data VFS = VFS { vfsMap :: Map.Map J.NormalizedUri VirtualFile+               , vfsTempDir :: FilePath -- ^ This is where all the temporary files will be written to+               } deriving Show++---++initVFS :: (VFS -> IO r) -> IO r+initVFS k = withSystemTempDirectory "haskell-lsp" $ \temp_dir -> k (VFS mempty temp_dir)+ -- --------------------------------------------------------------------- -openVFS :: VFS -> J.DidOpenTextDocumentNotification -> IO VFS-openVFS vfs (J.NotificationMessage _ _ params) = do+openVFS :: VFS -> J.DidOpenTextDocumentNotification -> (VFS, [String])+openVFS vfs (J.NotificationMessage _ _ params) =   let J.DidOpenTextDocumentParams          (J.TextDocumentItem uri _ version text) = params-  return $ Map.insert (J.toNormalizedUri uri) (VirtualFile version (Rope.fromText text) Nothing) vfs+  in (updateVFS (Map.insert (J.toNormalizedUri uri) (VirtualFile version (Rope.fromText text))) vfs+     , []) + -- --------------------------------------------------------------------- -changeFromClientVFS :: VFS -> J.DidChangeTextDocumentNotification -> IO VFS-changeFromClientVFS vfs (J.NotificationMessage _ _ params) = do+changeFromClientVFS :: VFS -> J.DidChangeTextDocumentNotification -> (VFS,[String])+changeFromClientVFS vfs (J.NotificationMessage _ _ params) =   let     J.DidChangeTextDocumentParams vid (J.List changes) = params     J.VersionedTextDocumentIdentifier (J.toNormalizedUri -> uri) version = vid-  case Map.lookup uri vfs of-    Just (VirtualFile _ str _) -> do-      let str' = applyChanges str changes-      -- the client shouldn't be sending over a null version, only the server.-      return $ Map.insert uri (VirtualFile (fromMaybe 0 version) str' Nothing) vfs-    Nothing -> do-      logs $ "haskell-lsp:changeVfs:can't find uri:" ++ show uri-      return vfs+  in+    case Map.lookup uri (vfsMap vfs) of+      Just (VirtualFile _ str) ->+        let str' = applyChanges str changes+        -- the client shouldn't be sending over a null version, only the server.+        in (updateVFS (Map.insert uri (VirtualFile (fromMaybe 0 version) str')) vfs, [])+      Nothing ->+        -- logs $ "haskell-lsp:changeVfs:can't find uri:" ++ show uri+        -- return vfs+        (vfs, ["haskell-lsp:changeVfs:can't find uri:" ++ show uri]) +updateVFS :: (VFSMap -> VFSMap) -> VFS -> VFS+updateVFS f vfs@VFS{vfsMap} = vfs { vfsMap = f vfsMap }+ -- ---------------------------------------------------------------------  changeFromServerVFS :: VFS -> J.ApplyWorkspaceEditRequest -> IO VFS@@ -110,8 +128,11 @@     changeToTextDocumentEdit acc uri edits =       acc ++ [J.TextDocumentEdit (J.VersionedTextDocumentIdentifier uri (Just 0)) edits] +    -- applyEdits :: [J.TextDocumentEdit] -> VFS+    applyEdits :: [J.TextDocumentEdit] -> IO VFS     applyEdits = foldM f initVfs . sortOn (^. J.textDocument . J.version) +    f :: VFS -> J.TextDocumentEdit -> IO VFS     f vfs (J.TextDocumentEdit vid (J.List edits)) = do       -- all edits are supposed to be applied at once       -- so apply from bottom up so they don't affect others@@ -119,29 +140,34 @@           changeEvents = map editToChangeEvent sortedEdits           ps = J.DidChangeTextDocumentParams vid (J.List changeEvents)           notif = J.NotificationMessage "" J.TextDocumentDidChange ps-      changeFromClientVFS vfs notif+      let (vfs',ls) = changeFromClientVFS vfs notif+      mapM_ logs ls+      return vfs'      editToChangeEvent (J.TextEdit range text) = J.TextDocumentContentChangeEvent (Just range) Nothing text  -- ---------------------------------------------------------------------+virtualFileName :: FilePath -> J.NormalizedUri -> VirtualFile -> FilePath+virtualFileName prefix uri (VirtualFile ver _) =+  prefix </> show (hash (J.fromNormalizedUri uri)) ++ "-" ++ show ver ++ ".hs" -persistFileVFS :: VFS -> J.NormalizedUri -> IO (FilePath, VFS)+persistFileVFS :: VFS -> J.NormalizedUri -> (FilePath, IO ()) persistFileVFS vfs uri =-  case Map.lookup uri vfs of+  case Map.lookup uri (vfsMap vfs) of     Nothing -> error ("File not found in VFS: " ++ show uri ++ show vfs)-    Just (VirtualFile v txt tfile) ->-      case tfile of-        Just tfn -> return (tfn, vfs)-        Nothing  -> do-          fn <- writeSystemTempFile "VFS.hs" (Rope.toString txt)-          return (fn, Map.insert uri (VirtualFile v txt (Just fn)) vfs)+    Just vf@(VirtualFile _v txt) ->+      let tfn = virtualFileName (vfsTempDir vfs) uri vf+          action = do+            exists <- doesFileExist tfn+            unless exists (writeFile tfn (Rope.toString txt))+      in (tfn, action)  -- --------------------------------------------------------------------- -closeVFS :: VFS -> J.DidCloseTextDocumentNotification -> IO VFS-closeVFS vfs (J.NotificationMessage _ _ params) = do+closeVFS :: VFS -> J.DidCloseTextDocumentNotification -> (VFS, [String])+closeVFS vfs (J.NotificationMessage _ _ params) =   let J.DidCloseTextDocumentParams (J.TextDocumentIdentifier uri) = params-  return $ Map.delete (J.toNormalizedUri uri) vfs+  in (updateVFS (Map.delete (J.toNormalizedUri uri)) vfs,[])  -- --------------------------------------------------------------------- {-@@ -208,7 +234,7 @@   } deriving (Show,Eq)  getCompletionPrefix :: (Monad m) => J.Position -> VirtualFile -> m (Maybe PosPrefixInfo)-getCompletionPrefix pos@(J.Position l c) (VirtualFile _ yitext _) =+getCompletionPrefix pos@(J.Position l c) (VirtualFile _ ropetext) =       return $ Just $ fromMaybe (PosPrefixInfo "" "" "" pos) $ do -- Maybe monad         let headMaybe [] = Nothing             headMaybe (x:_) = Just x@@ -216,7 +242,7 @@             lastMaybe xs = Just $ last xs          curLine <- headMaybe $ T.lines $ Rope.toText-                             $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine l yitext+                             $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine l ropetext         let beforePos = T.take c curLine         curWord <- case T.last beforePos of                      ' ' -> return "" -- don't count abc as the curword in 'abc '@@ -235,10 +261,9 @@ -- ---------------------------------------------------------------------  rangeLinesFromVfs :: VirtualFile -> J.Range -> T.Text-rangeLinesFromVfs (VirtualFile _ yitext _) (J.Range (J.Position lf _cf) (J.Position lt _ct)) = r+rangeLinesFromVfs (VirtualFile _ ropetext) (J.Range (J.Position lf _cf) (J.Position lt _ct)) = r   where-    (_ ,s1) = Rope.splitAtLine lf yitext+    (_ ,s1) = Rope.splitAtLine lf ropetext     (s2, _) = Rope.splitAtLine (lt - lf) s1     r = Rope.toText s2- -- ---------------------------------------------------------------------

@@ -8,12 +8,13 @@ import           Data.Default import           Language.Haskell.LSP.Core import           Language.Haskell.LSP.Types+import           Language.Haskell.LSP.VFS import           Language.Haskell.LSP.Types.Capabilities import           Test.Hspec  spec :: Spec spec =-  describe "initial configuration" $ it "stores initial configuration data" $ do+  describe "initial configuration" $ it "stores initial configuration data" $ initVFS $ \vfs -> do      lfVar <- newEmptyMVar @@ -40,6 +41,7 @@                                                         tvarLspId                                                         (const $ return ())                                                         Nothing+                                                        vfs      let putMsg msg =           let jsonStr = encode msg in handleMessage initCb tvarCtx jsonStr

@@ -96,6 +96,7 @@       , ServerNotInitialized       , UnknownErrorCode       , RequestCancelled+      , ContentModified       ]  -- | make lists of maximum length 3 for test performance

@@ -31,7 +31,7 @@ mkRange ls cs le ce = Just $ J.Range (J.Position ls cs) (J.Position le ce)  vfsFromText :: T.Text -> VirtualFile-vfsFromText text = VirtualFile 0 (Rope.fromText text) Nothing+vfsFromText text = VirtualFile 0 (Rope.fromText text)  -- --------------------------------------------------------------------- 

@@ -8,12 +8,13 @@ import Data.Default import Language.Haskell.LSP.Core import Language.Haskell.LSP.Types+import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Types.Capabilities import Test.Hspec  spec :: Spec spec =-  describe "workspace folders" $ it "keeps track of open workspace folders" $ do+  describe "workspace folders" $ it "keeps track of open workspace folders" $ initVFS $ \vfs -> do      lfVar <- newEmptyMVar @@ -31,6 +32,7 @@                                                         tvarLspId                                                         (const $ return ())                                                         Nothing+                                                        vfs      let putMsg msg =           let jsonStr = encode msg