haskell-lsp 0.14.0.0 → 0.15.0.0

raw patch · 12 files changed

+344/−148 lines, 12 filesdep ~haskell-lsp-typesnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: haskell-lsp-types

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−0
• example/Main.hs +6/−5
• haskell-lsp.cabal +3/−2
• src/Language/Haskell/LSP/Control.hs +9/−9
• src/Language/Haskell/LSP/Core.hs +139/−73
• src/Language/Haskell/LSP/Diagnostics.hs +4/−4
• src/Language/Haskell/LSP/VFS.hs +12/−9
• test/DiagnosticsSpec.hs +45/−34
• test/InitialConfigurationSpec.hs +63/−0
• test/JsonSpec.hs +36/−6
• test/URIFilePathSpec.hs +7/−0
• test/WorkspaceFoldersSpec.hs +13/−6

@@ -1,5 +1,12 @@ # Revision history for haskell-lsp +## 0.15.0.0 -- 2019-07-01++* Fix decoding of `ResponseMessage` to account for `null` messages (@cocreature)+* Normalize URIs to avoid issues with percent encoding (@cocreature)+* Changed the initial callbacks type to also capture initial config (@lorenzo)+* Improved documentation (@bubba)+ ## 0.14.0.0 -- 2019-06-13  * Add support for custom request and notification methods

@@ -104,7 +104,7 @@  -- --------------------------------------------------------------------- -publishDiagnostics :: Int -> J.Uri -> J.TextDocumentVersion -> DiagnosticsBySource -> R () ()+publishDiagnostics :: Int -> J.NormalizedUri -> J.TextDocumentVersion -> DiagnosticsBySource -> R () () publishDiagnostics maxToPublish uri v diags = do   lf <- ask   liftIO $ (Core.publishDiagnosticsFunc lf) maxToPublish uri v diags@@ -183,15 +183,16 @@                                  . J.uri             fileName =  J.uriToFilePath doc         liftIO $ U.logs $ "********* fileName=" ++ show fileName-        sendDiagnostics doc (Just 0)+        sendDiagnostics (J.toNormalizedUri doc) (Just 0)        -- -------------------------------        HandlerRequest (NotDidChangeTextDocument notification) -> do-        let doc :: J.Uri+        let doc :: J.NormalizedUri             doc  = notification ^. J.params                                  . J.textDocument                                  . J.uri+                                 . to J.toNormalizedUri         mdoc <- liftIO $ Core.getVirtualFileFunc lf doc         case mdoc of           Just (VirtualFile _version str _) -> do@@ -211,7 +212,7 @@                                  . J.uri             fileName = J.uriToFilePath doc         liftIO $ U.logs $ "********* fileName=" ++ show fileName-        sendDiagnostics doc Nothing+        sendDiagnostics (J.toNormalizedUri doc) Nothing        -- ------------------------------- @@ -308,7 +309,7 @@  -- | Analyze the file and send any diagnostics to the client in a -- "textDocument/publishDiagnostics" notification-sendDiagnostics :: J.Uri -> Maybe Int -> R () ()+sendDiagnostics :: J.NormalizedUri -> Maybe Int -> R () () sendDiagnostics fileUri version = do   let     diags = [J.Diagnostic

@@ -1,5 +1,5 @@ name:                haskell-lsp-version:             0.14.0.0+version:             0.15.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.14.*+                     , haskell-lsp-types == 0.15.*                      , lens >= 4.15.2                      , mtl                      , network-uri@@ -111,6 +111,7 @@                        VspSpec                        WorkspaceEditSpec                        WorkspaceFoldersSpec+                       InitialConfigurationSpec   build-depends:       base                      , QuickCheck                      , aeson

@@ -38,7 +38,7 @@ -- ---------------------------------------------------------------------  -- | Convenience function for 'runWithHandles stdin stdout'.-run :: (Show c) => Core.InitializeCallback c+run :: (Show configs) => Core.InitializeCallbacks configs                 -- ^ function to be called once initialize has                 -- been received from the client. Further message                 -- processing will start only after this returns.@@ -51,17 +51,17 @@  -- | Starts listening and sending requests and responses -- at the specified handles.-runWithHandles :: (Show c) =>+runWithHandles :: (Show config) =>        Handle     -- ^ Handle to read client input from.     -> Handle     -- ^ Handle to write output to.-    -> Core.InitializeCallback c+    -> Core.InitializeCallbacks config     -> Core.Handlers     -> Core.Options     -> Maybe FilePath     -> IO Int         -- exit code-runWithHandles hin hout dp h o captureFp = do+runWithHandles hin hout initializeCallbacks h o captureFp = do    logm $ B.pack "\n\n\n\n\nhaskell-lsp:Starting up server ..."   hSetBuffering hin NoBuffering@@ -86,18 +86,18 @@    tvarDat <- atomically $ newTVar $ Core.defaultLanguageContextData h o lf tvarId sendFunc timestampCaptureFp -  ioLoop hin dp tvarDat+  ioLoop hin initializeCallbacks tvarDat    return 1   -- --------------------------------------------------------------------- -ioLoop :: (Show c) => Handle-                   -> Core.InitializeCallback c-                   -> TVar (Core.LanguageContextData c)+ioLoop :: (Show config) => Handle+                   -> Core.InitializeCallbacks config+                   -> TVar (Core.LanguageContextData config)                    -> IO ()-ioLoop hin dispatcherProc tvarDat = do+ioLoop hin dispatcherProc tvarDat =   go (parse parser "")   where     go :: Result BS.ByteString -> IO ()

@@ -1,3 +1,4 @@+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE GADTs               #-} {-# LANGUAGE MultiWayIf          #-} {-# LANGUAGE BinaryLiterals      #-}@@ -9,7 +10,7 @@     handleMessage   , LanguageContextData(..)   , Handler-  , InitializeCallback+  , InitializeCallbacks(..)   , LspFuncs(..)   , Progress(..)   , ProgressCancellable(..)@@ -72,7 +73,7 @@ type SendFunc = FromServerMessage -> IO ()  -- | state used by the LSP dispatcher to manage the message loop-data LanguageContextData a =+data LanguageContextData config =   LanguageContextData {     resSeqDebugContextData :: !Int   , resHandlers            :: !Handlers@@ -81,9 +82,9 @@   , resVFS                 :: !VFS   , reverseMap             :: !(Map.Map FilePath FilePath)   , resDiagnostics         :: !DiagnosticStore-  , resConfig              :: !(Maybe a)+  , resConfig              :: !(Maybe config)   , resLspId               :: !(TVar Int)-  , resLspFuncs            :: LspFuncs a -- NOTE: Cannot be strict, lazy initialization+  , resLspFuncs            :: LspFuncs config -- NOTE: Cannot be strict, lazy initialization   , resCaptureFile         :: !(Maybe FilePath)   , resWorkspaceFolders    :: ![J.WorkspaceFolder]   , resProgressData        :: !ProgressData@@ -122,7 +123,7 @@ -- 'textDocument/publishDiagnostics' notification with the total (limited by the -- first parameter) whenever it is updated. type PublishDiagnosticsFunc = Int -- Max number of diagnostics to send-                            -> J.Uri -> J.TextDocumentVersion -> DiagnosticsBySource -> IO ()+                            -> J.NormalizedUri -> J.TextDocumentVersion -> DiagnosticsBySource -> IO ()  -- | A function to remove all diagnostics from a particular source, and send the updates to the client. type FlushDiagnosticsBySourceFunc = Int -- Max number of diagnostics to send@@ -155,8 +156,8 @@       -- ^ Derived from the DidChangeConfigurationNotification message via a       -- server-provided function.     , sendFunc                     :: !SendFunc-    , getVirtualFileFunc           :: !(J.Uri -> IO (Maybe VirtualFile))-    , persistVirtualFileFunc       :: !(J.Uri -> IO FilePath)+    , getVirtualFileFunc           :: !(J.NormalizedUri -> IO (Maybe VirtualFile))+    , persistVirtualFileFunc       :: !(J.NormalizedUri -> IO FilePath)     , reverseFileMapFunc           :: !(IO (FilePath -> FilePath))     , publishDiagnosticsFunc       :: !PublishDiagnosticsFunc     , flushDiagnosticsBySourceFunc :: !FlushDiagnosticsBySourceFunc@@ -184,11 +185,26 @@     -- @since 0.10.0.0     } --- | The function in the LSP process that is called once the 'initialize'--- message is received. Message processing will only continue once this returns,--- so it should create whatever processes are needed.-type InitializeCallback c = ( J.DidChangeConfigurationNotification-> Either T.Text c-                            , LspFuncs c -> IO (Maybe J.ResponseError))+-- | Contains all the callbacks to use for initialized the language server.+-- it is parameterized over a config type variable representing the type for the+-- specific configuration data the language server needs to use.+data InitializeCallbacks config =+  InitializeCallbacks+    { onInitialConfiguration :: J.InitializeRequest -> Either T.Text config+      -- ^ Invoked on the first message from the language client, containg the client configuration+      -- This callback should return either the parsed configuration data or an error indicating+      -- what went wrong. The parsed configuration object will be stored internally and passed to+      -- hanlder functions as context.+    , onConfigurationChange :: J.DidChangeConfigurationNotification-> Either T.Text config+      -- ^ Invoked whenever the clients sends a message with a changed client configuration.+      -- This callback should return either the parsed configuration data or an error indicating+      -- what went wrong. The parsed configuration object will be stored internally and passed to+      -- hanlder functions as context.+    , onStartup :: LspFuncs config -> IO (Maybe J.ResponseError)+      -- ^ Once the initial configuration has been received, this callback will be invoked to offer+      -- the language server implementation the chance to create any processes or start new threads+      -- that may be necesary for the server lifecycle.+    }  -- | The Handler type captures a function that receives local read-only state -- 'a', a function to send a reply message once encoded as a ByteString, and a@@ -234,6 +250,8 @@     , didChangeConfigurationParamsHandler      :: !(Maybe (Handler J.DidChangeConfigurationNotification))     , didOpenTextDocumentNotificationHandler   :: !(Maybe (Handler J.DidOpenTextDocumentNotification))     , didChangeTextDocumentNotificationHandler :: !(Maybe (Handler J.DidChangeTextDocumentNotification))+    -- ^ Note: If you need to keep track of document changes,+    -- "Language.Haskell.LSP.VFS" will take care of these messages for you!     , didCloseTextDocumentNotificationHandler  :: !(Maybe (Handler J.DidCloseTextDocumentNotification))     , didSaveTextDocumentNotificationHandler   :: !(Maybe (Handler J.DidSaveTextDocumentNotification))     , didChangeWatchedFilesNotificationHandler :: !(Maybe (Handler J.DidChangeWatchedFilesNotification))@@ -261,18 +279,26 @@     }  instance Default Handlers where-  def = Handlers Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing-                 Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing-                 Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing-                 Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing-                 Nothing Nothing Nothing Nothing+  -- These already implicitly do stuff to the VFS, so silence warnings about no handler+  def = nothings { didChangeTextDocumentNotificationHandler = Just ignore+                 , didOpenTextDocumentNotificationHandler   = Just ignore+                 , didCloseTextDocumentNotificationHandler  = Just ignore+                 }+    where ignore = const (pure ())+          nothings = Handlers Nothing Nothing Nothing Nothing Nothing Nothing+                              Nothing Nothing Nothing Nothing Nothing Nothing+                              Nothing Nothing Nothing Nothing Nothing Nothing+                              Nothing Nothing Nothing Nothing Nothing Nothing+                              Nothing Nothing Nothing Nothing Nothing Nothing+                              Nothing Nothing Nothing Nothing Nothing Nothing+                              Nothing Nothing Nothing Nothing  -- --------------------------------------------------------------------- nop :: a -> b -> IO a nop = const . return  -helper :: J.FromJSON a => (TVar (LanguageContextData c) -> a -> IO ()) -> (TVar (LanguageContextData c) -> J.Value -> IO ())+helper :: J.FromJSON a => (TVar (LanguageContextData config) -> a -> IO ()) -> (TVar (LanguageContextData config) -> J.Value -> IO ()) helper requestHandler tvarDat json =   case J.fromJSON json of     J.Success req -> requestHandler tvarDat req@@ -287,10 +313,10 @@           _ -> failLog         _ -> failLog -handlerMap :: (Show c) => InitializeCallback c-           -> Handlers -> J.ClientMethod -> (TVar (LanguageContextData c) -> J.Value -> IO ())+handlerMap :: (Show config) => InitializeCallbacks config+           -> Handlers -> J.ClientMethod -> (TVar (LanguageContextData config) -> J.Value -> IO ()) -- General-handlerMap i h J.Initialize                      = helper (initializeRequestHandler' i (initializeRequestHandler h))+handlerMap i h J.Initialize                      = handleInitialConfig i (initializeRequestHandler h) handlerMap _ h J.Initialized                     = hh nop NotInitialized $ initializedHandler h handlerMap _ _ J.Shutdown                        = helper shutdownRequestHandler handlerMap _ h J.Exit                            =@@ -353,8 +379,8 @@  -- | Adapter from the normal handlers exposed to the library users and the -- internal message loop-hh :: forall b c. (J.FromJSON b)-   => (VFS -> b -> IO VFS) -> (b -> FromClientMessage) -> Maybe (Handler b) -> TVar (LanguageContextData c) -> J.Value -> IO ()+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       case J.fromJSON json of         J.Success req -> do@@ -373,33 +399,75 @@           let msg = T.pack $ unwords $ ["haskell-lsp:parse error.", show json, show err] ++ _ERR_MSG_URL           sendErrorLog tvarDat msg -hc :: (Show c) => InitializeCallback c -> Maybe (Handler J.DidChangeConfigurationNotification)-   -> TVar (LanguageContextData c) -> J.Value -> IO ()-hc (c,_) mh tvarDat json = do-      -- logs $ "haskell-lsp:hc DidChangeConfigurationNotification entered"-      case J.fromJSON json of-        J.Success req -> do-          ctx <- readTVarIO tvarDat+handleInitialConfig+  :: (Show config)+  => InitializeCallbacks config+  -> Maybe (Handler J.InitializeRequest)+  -> TVar (LanguageContextData config)+  -> J.Value+  -> IO ()+handleInitialConfig (InitializeCallbacks { onInitialConfiguration, onStartup }) mh tvarDat json+  = handleMessageWithConfigChange ReqInitialize+                                  onInitialConfiguration+                                  (Just $ initializeRequestHandler' onStartup mh tvarDat)+                                  tvarDat+                                  json -          captureFromClient (NotDidChangeConfiguration req) (resCaptureFile ctx) -          case c req of-            Left err -> do-              let msg = T.pack $ unwords ["haskell-lsp:didChangeConfiguration 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')-          case mh of-            Just h -> h req-            Nothing -> return ()-        J.Error  err -> do-          let msg = T.pack $ unwords $ ["haskell-lsp:parse error.", show json, show err] ++ _ERR_MSG_URL+hc+  :: (Show config)+  => InitializeCallbacks config+  -> Maybe (Handler J.DidChangeConfigurationNotification)+  -> TVar (LanguageContextData config)+  -> J.Value+  -> IO ()+hc (InitializeCallbacks { onConfigurationChange }) mh tvarDat json =+  handleMessageWithConfigChange NotDidChangeConfiguration+                                onConfigurationChange+                                mh+                                tvarDat+                                json++handleMessageWithConfigChange+  :: (J.FromJSON reqParams, Show reqParams, Show err)+  => (reqParams -> FromClientMessage) -- ^ The notification message from the client to expect+  -> (reqParams -> Either err config) -- ^ A function to parse the config out of the request+  -> Maybe (reqParams -> IO ()) -- ^ The upstream handler for the client request+  -> TVar (LanguageContextData config) -- ^ The context data containing the current configuration+  -> J.Value -- ^ The raw reqeust data+  -> IO ()+handleMessageWithConfigChange notification parseConfig mh tvarDat json =+  -- logs $ "haskell-lsp:hc DidChangeConfigurationNotification entered"+  case J.fromJSON json of+    J.Success req -> do+      ctx <- readTVarIO tvarDat++      captureFromClient (notification req) (resCaptureFile ctx)++      case parseConfig req of+        Left err -> do+          let+            msg =+              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')+      case mh of+        Just h  -> h req+        Nothing -> return ()+    J.Error err -> do+      let msg =+            T.pack+              $  unwords+              $  ["haskell-lsp:parse error.", show json, show err]+              ++ _ERR_MSG_URL+      sendErrorLog tvarDat msg  -- | Updates the list of workspace folders and then delegates back to 'hh'-hwf :: Maybe (Handler J.DidChangeWorkspaceFoldersNotification) -> TVar (LanguageContextData c) -> J.Value -> IO ()+hwf :: Maybe (Handler J.DidChangeWorkspaceFoldersNotification) -> TVar (LanguageContextData config) -> J.Value -> IO () hwf h tvarDat json = do   case J.fromJSON json :: J.Result J.DidChangeWorkspaceFoldersNotification of     J.Success (J.NotificationMessage _ _ params) -> atomically $ do@@ -416,12 +484,12 @@  -- --------------------------------------------------------------------- -getVirtualFile :: TVar (LanguageContextData c) -> J.Uri -> IO (Maybe VirtualFile)+getVirtualFile :: TVar (LanguageContextData config) -> J.NormalizedUri -> IO (Maybe VirtualFile) getVirtualFile tvarDat uri = Map.lookup uri . 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 c) -> J.Uri -> IO FilePath+persistVirtualFile :: TVar (LanguageContextData config) -> J.NormalizedUri -> IO FilePath persistVirtualFile tvarDat uri = do   st <- readTVarIO tvarDat   let vfs = resVFS st@@ -431,7 +499,7 @@   let revMap' =         -- TODO: Does the VFS make sense for URIs which are not files?         -- The reverse map should perhaps be (FilePath -> URI)-        case J.uriToFilePath uri of+        case J.uriToFilePath (J.fromNormalizedUri uri) of           Just uri_fp -> Map.insert fn uri_fp revMap           Nothing -> revMap @@ -442,7 +510,7 @@ -- TODO: should this function return a URI? -- | If the contents of a VFS has been dumped to a temporary file, map -- the temporary file name back to the original one.-reverseFileMap :: TVar (LanguageContextData c)+reverseFileMap :: TVar (LanguageContextData config)                -> IO (FilePath -> FilePath) reverseFileMap tvarDat = do   revMap <- reverseMap <$> readTVarIO tvarDat@@ -451,7 +519,7 @@  -- --------------------------------------------------------------------- -getConfig :: TVar (LanguageContextData c) -> IO (Maybe c)+getConfig :: TVar (LanguageContextData config) -> IO (Maybe config) getConfig tvar = resConfig <$> readTVarIO tvar  -- ---------------------------------------------------------------------@@ -486,7 +554,7 @@ -- | -- ---defaultLanguageContextData :: Handlers -> Options -> LspFuncs c -> TVar Int -> SendFunc -> Maybe FilePath -> LanguageContextData c+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                       Nothing tv lf cf mempty defaultProgressData@@ -496,8 +564,8 @@  -- --------------------------------------------------------------------- -handleMessage :: (Show c) => InitializeCallback c-              -> TVar (LanguageContextData c) -> BSL.ByteString -> IO ()+handleMessage :: (Show config) => InitializeCallbacks config+              -> TVar (LanguageContextData config) -> BSL.ByteString -> IO () handleMessage dispatcherProc tvarDat jsonStr = do   {-   Message Types we must handle are the following@@ -555,12 +623,12 @@ -- --------------------------------------------------------------------- -- | ---sendEvent :: TVar (LanguageContextData c) -> FromServerMessage -> IO ()+sendEvent :: TVar (LanguageContextData config) -> FromServerMessage -> IO () sendEvent tvarCtx msg = sendResponse tvarCtx msg  -- | ---sendResponse :: TVar (LanguageContextData c) -> FromServerMessage -> IO ()+sendResponse :: TVar (LanguageContextData config) -> FromServerMessage -> IO () sendResponse tvarCtx msg = do   ctx <- readTVarIO tvarCtx   resSendResponse ctx msg@@ -570,7 +638,7 @@ -- | -- ---sendErrorResponse :: TVar (LanguageContextData c) -> J.LspIdRsp -> Text -> IO ()+sendErrorResponse :: TVar (LanguageContextData config) -> J.LspIdRsp -> Text -> IO () sendErrorResponse tv origId msg = sendErrorResponseS (sendEvent tv) origId J.InternalError msg  sendErrorResponseS ::  SendFunc -> J.LspIdRsp -> J.ErrorCode -> Text -> IO ()@@ -578,7 +646,7 @@   sf $ RspError (J.ResponseMessage "2.0" origId Nothing                   (Just $ J.ResponseError err msg Nothing) :: J.ErrorResponse) -sendErrorLog :: TVar (LanguageContextData c) -> Text -> IO ()+sendErrorLog :: TVar (LanguageContextData config) -> Text -> IO () sendErrorLog tv msg = sendErrorLogS (sendEvent tv) msg  sendErrorLogS :: SendFunc -> Text -> IO ()@@ -594,7 +662,7 @@  -- --------------------------------------------------------------------- -defaultErrorHandlers :: (Show a) => TVar (LanguageContextData c) -> J.LspIdRsp -> a -> [E.Handler ()]+defaultErrorHandlers :: (Show a) => TVar (LanguageContextData config) -> J.LspIdRsp -> a -> [E.Handler ()] defaultErrorHandlers tvarDat origId req = [ E.Handler someExcept ]   where     someExcept (e :: E.SomeException) = do@@ -609,12 +677,14 @@  -- | ---initializeRequestHandler' :: (Show c) => InitializeCallback c-                         -> Maybe (Handler J.InitializeRequest)-                         -> TVar (LanguageContextData c)-                         -> J.InitializeRequest-                         -> IO ()-initializeRequestHandler' (_configHandler,dispatcherProc) mHandler tvarCtx req@(J.RequestMessage _ origId _ params) =+initializeRequestHandler'+  :: (Show config)+  => (LspFuncs config -> IO (Maybe J.ResponseError))+  -> Maybe (Handler J.InitializeRequest)+  -> TVar (LanguageContextData config)+  -> J.InitializeRequest+  -> IO ()+initializeRequestHandler' onStartup mHandler tvarCtx req@(J.RequestMessage _ origId _ params) =   flip E.catches (defaultErrorHandlers tvarCtx (J.responseId origId) req) $ do      case mHandler of@@ -628,10 +698,6 @@     atomically $ modifyTVar' tvarCtx (\c -> c { resWorkspaceFolders = wfs })      ctx0 <- readTVarIO tvarCtx--    -- capture initialize request-    captureFromClient (ReqInitialize req) (resCaptureFile ctx0)-     let rootDir = getFirst $ foldMap First [ params ^. J.rootUri  >>= J.uriToFilePath                                            , params ^. J.rootPath <&> T.unpack ] @@ -735,7 +801,7 @@     let ctx = ctx0 { resLspFuncs = lspFuncs }     atomically $ writeTVar tvarCtx ctx -    initializationResult <- dispatcherProc lspFuncs+    initializationResult <- onStartup lspFuncs      case initializationResult of       Just errResp -> do@@ -800,7 +866,7 @@          sendResponse tvarCtx $ RspInitialize res -progressCancelHandler :: TVar (LanguageContextData c) -> J.ProgressCancelNotification -> IO ()+progressCancelHandler :: TVar (LanguageContextData config) -> J.ProgressCancelNotification -> IO () progressCancelHandler tvarCtx (J.NotificationMessage _ _ (J.ProgressCancelParams tid)) = do   mact <- Map.lookup tid . progressCancel . resProgressData <$> readTVarIO tvarCtx   case mact of@@ -810,7 +876,7 @@  -- | ---shutdownRequestHandler :: TVar (LanguageContextData c) -> J.ShutdownRequest -> IO ()+shutdownRequestHandler :: TVar (LanguageContextData config) -> J.ShutdownRequest -> IO () shutdownRequestHandler tvarCtx req@(J.RequestMessage _ origId _ _) =   flip E.catches (defaultErrorHandlers tvarCtx (J.responseId origId) req) $ do   let res  = makeResponseMessage req "ok"@@ -821,7 +887,7 @@  -- | Take the new diagnostics, update the stored diagnostics for the given file -- and version, and publish the total to the client.-publishDiagnostics :: TVar (LanguageContextData c) -> PublishDiagnosticsFunc+publishDiagnostics :: TVar (LanguageContextData config) -> PublishDiagnosticsFunc publishDiagnostics tvarDat maxDiagnosticCount uri version diags = do   ctx <- readTVarIO tvarDat   let ds = updateDiagnostics (resDiagnostics ctx) uri version diags@@ -837,7 +903,7 @@  -- | Take the new diagnostics, update the stored diagnostics for the given file -- and version, and publish the total to the client.-flushDiagnosticsBySource :: TVar (LanguageContextData c) -> FlushDiagnosticsBySourceFunc+flushDiagnosticsBySource :: TVar (LanguageContextData config) -> FlushDiagnosticsBySourceFunc flushDiagnosticsBySource tvarDat maxDiagnosticCount msource = do   -- logs $ "haskell-lsp:flushDiagnosticsBySource:source=" ++ show source   ctx <- readTVarIO tvarDat

@@ -39,7 +39,7 @@  -} -type DiagnosticStore = Map.Map J.Uri StoreItem+type DiagnosticStore = Map.Map J.NormalizedUri StoreItem  data StoreItem   = StoreItem J.TextDocumentVersion DiagnosticsBySource@@ -63,7 +63,7 @@ -- ---------------------------------------------------------------------  updateDiagnostics :: DiagnosticStore-                  -> J.Uri -> J.TextDocumentVersion -> DiagnosticsBySource+                  -> J.NormalizedUri -> J.TextDocumentVersion -> DiagnosticsBySource                   -> DiagnosticStore updateDiagnostics store uri mv newDiagsBySource = r   where@@ -86,11 +86,11 @@  -- --------------------------------------------------------------------- -getDiagnosticParamsFor :: Int -> DiagnosticStore -> J.Uri -> Maybe J.PublishDiagnosticsParams+getDiagnosticParamsFor :: Int -> DiagnosticStore -> J.NormalizedUri -> Maybe J.PublishDiagnosticsParams getDiagnosticParamsFor maxDiagnostics ds uri =   case Map.lookup uri ds of     Nothing -> Nothing     Just (StoreItem _ diags) ->-      Just $ J.PublishDiagnosticsParams uri (J.List (take maxDiagnostics $ SL.fromSortedList $ mconcat $ Map.elems diags))+      Just $ J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (J.List (take maxDiagnostics $ SL.fromSortedList $ mconcat $ Map.elems diags))  -- ---------------------------------------------------------------------

@@ -3,11 +3,14 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}--{-+{-# LANGUAGE ViewPatterns #-} -Manage the J.TextDocumentDidChange messages to keep a local copy of the files-in the client workspace, so that tools at the server can operate on them.+{-|+Handles the "Language.Haskell.LSP.Types.TextDocumentDidChange" \/+"Language.Haskell.LSP.Types.TextDocumentDidOpen" \/+"Language.Haskell.LSP.Types.TextDocumentDidClose" messages to keep an in-memory+`filesystem` of the current client workspace.  The server can access and edit+files in the client workspace by operating on the "VFS" in "LspFuncs". -} module Language.Haskell.LSP.VFS   (@@ -62,7 +65,7 @@     , _tmp_file :: Maybe FilePath     } deriving (Show) -type VFS = Map.Map J.Uri VirtualFile+type VFS = Map.Map J.NormalizedUri VirtualFile  -- --------------------------------------------------------------------- @@ -70,7 +73,7 @@ openVFS vfs (J.NotificationMessage _ _ params) = do   let J.DidOpenTextDocumentParams          (J.TextDocumentItem uri _ version text) = params-  return $ Map.insert uri (VirtualFile version (Rope.fromText text) Nothing) vfs+  return $ Map.insert (J.toNormalizedUri uri) (VirtualFile version (Rope.fromText text) Nothing) vfs  -- --------------------------------------------------------------------- @@ -78,7 +81,7 @@ changeFromClientVFS vfs (J.NotificationMessage _ _ params) = do   let     J.DidChangeTextDocumentParams vid (J.List changes) = params-    J.VersionedTextDocumentIdentifier uri version = vid+    J.VersionedTextDocumentIdentifier (J.toNormalizedUri -> uri) version = vid   case Map.lookup uri vfs of     Just (VirtualFile _ str _) -> do       let str' = applyChanges str changes@@ -122,7 +125,7 @@  -- --------------------------------------------------------------------- -persistFileVFS :: VFS -> J.Uri -> IO (FilePath, VFS)+persistFileVFS :: VFS -> J.NormalizedUri -> IO (FilePath, VFS) persistFileVFS vfs uri =   case Map.lookup uri vfs of     Nothing -> error ("File not found in VFS: " ++ show uri ++ show vfs)@@ -138,7 +141,7 @@ closeVFS :: VFS -> J.DidCloseTextDocumentNotification -> IO VFS closeVFS vfs (J.NotificationMessage _ _ params) = do   let J.DidCloseTextDocumentParams (J.TextDocumentIdentifier uri) = params-  return $ Map.delete uri vfs+  return $ Map.delete (J.toNormalizedUri uri) vfs  -- --------------------------------------------------------------------- {-

@@ -54,9 +54,10 @@           [ mkDiagnostic (Just "hlint") "a"           , mkDiagnostic (Just "hlint") "b"           ]-      (updateDiagnostics Map.empty (J.Uri "uri") Nothing (partitionBySource diags)) `shouldBe`+        uri = J.toNormalizedUri $ J.Uri "uri"+      (updateDiagnostics Map.empty uri Nothing (partitionBySource diags)) `shouldBe`         Map.fromList-          [ ((J.Uri "uri"),StoreItem Nothing $ Map.fromList [(Just "hlint", SL.toSortedList diags) ] )+          [ (uri,StoreItem Nothing $ Map.fromList [(Just "hlint", SL.toSortedList diags) ] )           ]      -- ---------------------------------@@ -67,9 +68,10 @@           [ mkDiagnostic (Just "hlint") "a"           , mkDiagnostic (Just "ghcmod") "b"           ]-      (updateDiagnostics Map.empty (J.Uri "uri") Nothing (partitionBySource diags)) `shouldBe`+        uri = J.toNormalizedUri $ J.Uri "uri"+      (updateDiagnostics Map.empty uri Nothing (partitionBySource diags)) `shouldBe`         Map.fromList-          [ ((J.Uri "uri"),StoreItem Nothing $ Map.fromList+          [ (uri,StoreItem Nothing $ Map.fromList                 [(Just "hlint",  SL.singleton (mkDiagnostic (Just "hlint")  "a"))                 ,(Just "ghcmod", SL.singleton (mkDiagnostic (Just "ghcmod") "b"))                 ])@@ -83,9 +85,10 @@           [ mkDiagnostic (Just "hlint") "a"           , mkDiagnostic (Just "ghcmod") "b"           ]-      (updateDiagnostics Map.empty (J.Uri "uri") (Just 1) (partitionBySource diags)) `shouldBe`+        uri = J.toNormalizedUri $ J.Uri "uri"+      (updateDiagnostics Map.empty uri (Just 1) (partitionBySource diags)) `shouldBe`         Map.fromList-          [ ((J.Uri "uri"),StoreItem (Just 1) $ Map.fromList+          [ (uri,StoreItem (Just 1) $ Map.fromList                 [(Just "hlint",  SL.singleton (mkDiagnostic (Just "hlint")  "a"))                 ,(Just "ghcmod", SL.singleton (mkDiagnostic (Just "ghcmod") "b"))                 ])@@ -103,10 +106,11 @@         diags2 =           [ mkDiagnostic (Just "hlint") "a2"           ]-      let origStore = updateDiagnostics Map.empty (J.Uri "uri") Nothing (partitionBySource diags1)-      (updateDiagnostics origStore (J.Uri "uri") Nothing (partitionBySource diags2)) `shouldBe`+        uri = J.toNormalizedUri $ J.Uri "uri"+      let origStore = updateDiagnostics Map.empty uri Nothing (partitionBySource diags1)+      (updateDiagnostics origStore uri Nothing (partitionBySource diags2)) `shouldBe`         Map.fromList-          [ ((J.Uri "uri"),StoreItem Nothing $ Map.fromList [(Just "hlint", SL.toSortedList diags2) ] )+          [ (uri,StoreItem Nothing $ Map.fromList [(Just "hlint", SL.toSortedList diags2) ] )           ]      -- ---------------------------------@@ -120,10 +124,11 @@         diags2 =           [ mkDiagnostic (Just "hlint") "a2"           ]-      let origStore = updateDiagnostics Map.empty (J.Uri "uri") Nothing (partitionBySource diags1)-      (updateDiagnostics origStore (J.Uri "uri") Nothing (partitionBySource diags2)) `shouldBe`+        uri = J.toNormalizedUri $ J.Uri "uri"+      let origStore = updateDiagnostics Map.empty uri Nothing (partitionBySource diags1)+      (updateDiagnostics origStore uri Nothing (partitionBySource diags2)) `shouldBe`         Map.fromList-          [ ((J.Uri "uri"),StoreItem Nothing $ Map.fromList+          [ (uri,StoreItem Nothing $ Map.fromList                 [(Just "hlint",  SL.singleton (mkDiagnostic (Just "hlint")  "a2"))                 ,(Just "ghcmod", SL.singleton (mkDiagnostic (Just "ghcmod") "b1"))               ] )@@ -137,10 +142,11 @@           [ mkDiagnostic (Just "hlint") "a1"           , mkDiagnostic (Just "ghcmod") "b1"           ]-      let origStore = updateDiagnostics Map.empty (J.Uri "uri") Nothing (partitionBySource diags1)-      (updateDiagnostics origStore (J.Uri "uri") Nothing (Map.fromList [(Just "ghcmod",SL.toSortedList [])])) `shouldBe`+        uri = J.toNormalizedUri $ J.Uri "uri"+      let origStore = updateDiagnostics Map.empty uri Nothing (partitionBySource diags1)+      (updateDiagnostics origStore uri Nothing (Map.fromList [(Just "ghcmod",SL.toSortedList [])])) `shouldBe`         Map.fromList-          [ ((J.Uri "uri"),StoreItem Nothing $ Map.fromList+          [ (uri,StoreItem Nothing $ Map.fromList                 [(Just "ghcmod", SL.toSortedList [])                 ,(Just "hlint",  SL.singleton (mkDiagnostic (Just "hlint")  "a1"))                 ] )@@ -159,10 +165,11 @@         diags2 =           [ mkDiagnostic (Just "hlint") "a2"           ]-      let origStore = updateDiagnostics Map.empty (J.Uri "uri") (Just 1) (partitionBySource diags1)-      (updateDiagnostics origStore (J.Uri "uri") (Just 2) (partitionBySource diags2)) `shouldBe`+        uri = J.toNormalizedUri $ J.Uri "uri"+      let origStore = updateDiagnostics Map.empty uri (Just 1) (partitionBySource diags1)+      (updateDiagnostics origStore uri (Just 2) (partitionBySource diags2)) `shouldBe`         Map.fromList-          [ ((J.Uri "uri"),StoreItem (Just 2) $ Map.fromList [(Just "hlint", SL.toSortedList diags2) ] )+          [ (uri,StoreItem (Just 2) $ Map.fromList [(Just "hlint", SL.toSortedList diags2) ] )           ]      -- ---------------------------------@@ -176,10 +183,11 @@         diags2 =           [ mkDiagnostic (Just "hlint") "a2"           ]-      let origStore = updateDiagnostics Map.empty (J.Uri "uri") (Just 1) (partitionBySource diags1)-      (updateDiagnostics origStore (J.Uri "uri") (Just 2) (partitionBySource diags2)) `shouldBe`+        uri = J.toNormalizedUri $ J.Uri "uri"+      let origStore = updateDiagnostics Map.empty uri (Just 1) (partitionBySource diags1)+      (updateDiagnostics origStore uri (Just 2) (partitionBySource diags2)) `shouldBe`         Map.fromList-          [ ((J.Uri "uri"),StoreItem (Just 2) $ Map.fromList+          [ (uri,StoreItem (Just 2) $ Map.fromList                 [(Just "hlint", SL.singleton (mkDiagnostic (Just "hlint")  "a2"))               ] )           ]@@ -194,9 +202,10 @@           [ mkDiagnostic (Just "hlint") "a"           , mkDiagnostic (Just "ghcmod") "b"           ]-      let ds = updateDiagnostics Map.empty (J.Uri "uri") (Just 1) (partitionBySource diags)-      (getDiagnosticParamsFor 10 ds (J.Uri "uri")) `shouldBe`-        Just (J.PublishDiagnosticsParams (J.Uri "uri") (J.List $ reverse diags))+        uri = J.toNormalizedUri $ J.Uri "uri"+      let ds = updateDiagnostics Map.empty uri (Just 1) (partitionBySource diags)+      (getDiagnosticParamsFor 10 ds uri) `shouldBe`+        Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (J.List $ reverse diags))      -- --------------------------------- @@ -210,16 +219,17 @@           , mkDiagnostic  (Just "hlint") "c"           , mkDiagnostic  (Just "ghcmod") "d"           ]-      let ds = updateDiagnostics Map.empty (J.Uri "uri") (Just 1) (partitionBySource diags)-      (getDiagnosticParamsFor 2 ds (J.Uri "uri")) `shouldBe`-        Just (J.PublishDiagnosticsParams (J.Uri "uri")+        uri = J.toNormalizedUri $ J.Uri "uri"+      let ds = updateDiagnostics Map.empty uri (Just 1) (partitionBySource diags)+      (getDiagnosticParamsFor 2 ds uri) `shouldBe`+        Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri)               (J.List [                     mkDiagnostic  (Just "ghcmod") "d"                   , mkDiagnostic  (Just "hlint") "c"                   ])) -      (getDiagnosticParamsFor 1 ds (J.Uri "uri")) `shouldBe`-        Just (J.PublishDiagnosticsParams (J.Uri "uri")+      (getDiagnosticParamsFor 1 ds uri) `shouldBe`+        Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri)               (J.List [                     mkDiagnostic  (Just "ghcmod") "d"                   ]))@@ -236,9 +246,10 @@           , mkDiagnostic  (Just "hlint") "c"           , mkDiagnostic  (Just "ghcmod") "d"           ]-      let ds = updateDiagnostics Map.empty (J.Uri "uri") (Just 1) (partitionBySource diags)-      (getDiagnosticParamsFor 100 ds (J.Uri "uri")) `shouldBe`-        Just (J.PublishDiagnosticsParams (J.Uri "uri")+        uri = J.toNormalizedUri $ J.Uri "uri"+      let ds = updateDiagnostics Map.empty uri (Just 1) (partitionBySource diags)+      (getDiagnosticParamsFor 100 ds uri) `shouldBe`+        Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri)               (J.List [                     mkDiagnostic  (Just "ghcmod") "d"                   , mkDiagnostic  (Just "hlint") "c"@@ -247,8 +258,8 @@                   ]))        let ds' = flushBySource ds (Just "hlint")-      (getDiagnosticParamsFor 100 ds' (J.Uri "uri")) `shouldBe`-        Just (J.PublishDiagnosticsParams (J.Uri "uri")+      (getDiagnosticParamsFor 100 ds' uri) `shouldBe`+        Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri)               (J.List [                      mkDiagnostic  (Just "ghcmod") "d"                   ,  mkDiagnostic2 (Just "ghcmod") "b"

@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}++module InitialConfigurationSpec where++import           Control.Concurrent.MVar+import           Control.Concurrent.STM+import           Data.Aeson+import           Data.Default+import           Language.Haskell.LSP.Core+import           Language.Haskell.LSP.Types+import           Language.Haskell.LSP.Types.Capabilities+import           Test.Hspec++spec :: Spec+spec =+  describe "initial configuration" $ it "stores initial configuration data" $ do++    lfVar <- newEmptyMVar++    let+        initialConfigHandler (RequestMessage _ _ Initialize InitializeParams{_initializationOptions = Just opts}) =+          case (fromJSON opts :: Result String) of+                Success s -> Right s+                _         -> Left "Could not decode configuration"+        initialConfigHandler _ =+          error "Got the wrong request for the onInitialConfiguration callback"++        initCb :: InitializeCallbacks String+        initCb = InitializeCallbacks+          initialConfigHandler+          (const $ Left "")+          (\lf -> putMVar lfVar lf >> return Nothing)++        handlers = def++    tvarLspId <- newTVarIO 0+    tvarCtx   <- newTVarIO $ defaultLanguageContextData handlers+                                                        def+                                                        undefined+                                                        tvarLspId+                                                        (const $ return ())+                                                        Nothing++    let putMsg msg =+          let jsonStr = encode msg in handleMessage initCb tvarCtx jsonStr++    let+        initParams        = InitializeParams+          Nothing+          Nothing+          (Just (Uri "/foo"))+          (Just (Data.Aeson.String "configuration"))+          fullCaps+          Nothing+          Nothing++        initMsg :: InitializeRequest+        initMsg = RequestMessage "2.0" (IdInt 0) Initialize initParams++    putMsg initMsg+    contents <- readTVarIO tvarCtx+    resConfig contents  `shouldBe` Just "configuration"+

@@ -31,16 +31,17 @@ jsonSpec = do   describe "General JSON instances round trip" $ do   -- DataTypesJSON-    prop "LanguageString"    (propertyJsonRoundtrip :: LanguageString -> Bool)-    prop "MarkedString"      (propertyJsonRoundtrip :: MarkedString -> Bool)-    prop "MarkupContent"     (propertyJsonRoundtrip :: MarkupContent -> Bool)-    prop "HoverContents"     (propertyJsonRoundtrip :: HoverContents -> Bool)+    prop "LanguageString"    (propertyJsonRoundtrip :: LanguageString -> Property)+    prop "MarkedString"      (propertyJsonRoundtrip :: MarkedString -> Property)+    prop "MarkupContent"     (propertyJsonRoundtrip :: MarkupContent -> Property)+    prop "HoverContents"     (propertyJsonRoundtrip :: HoverContents -> Property)+    prop "ResponseMessage"   (propertyJsonRoundtrip :: ResponseMessage (Maybe ()) -> Property)   -- --------------------------------------------------------------------- -propertyJsonRoundtrip :: (Eq a, ToJSON a, FromJSON a) => a -> Bool-propertyJsonRoundtrip a = Success a == fromJSON (toJSON a)+propertyJsonRoundtrip :: (Eq a, Show a, ToJSON a, FromJSON a) => a -> Property+propertyJsonRoundtrip a = Success a === fromJSON (toJSON a)  -- --------------------------------------------------------------------- @@ -60,6 +61,35 @@   arbitrary = oneof [ HoverContentsMS <$> arbitrary                     , HoverContents <$> arbitrary                     ]++instance Arbitrary a => Arbitrary (ResponseMessage a) where+  arbitrary =+    ResponseMessage+      <$> arbitrary+      <*> arbitrary+      <*> arbitrary+      <*> arbitrary++instance Arbitrary LspIdRsp where+  arbitrary = oneof [IdRspInt <$> arbitrary, IdRspString <$> arbitrary, pure IdRspNull]++instance Arbitrary ResponseError where+  arbitrary = ResponseError <$> arbitrary <*> arbitrary <*> pure Nothing++instance Arbitrary ErrorCode where+  arbitrary =+    elements+      [ ParseError+      , InvalidRequest+      , MethodNotFound+      , InvalidParams+      , InternalError+      , ServerErrorStart+      , ServerErrorEnd+      , ServerNotInitialized+      , UnknownErrorCode+      , RequestCancelled+      ]  -- | make lists of maximum length 3 for test performance smallList :: Gen a -> Gen [a]

@@ -22,6 +22,7 @@ spec = do   describe "URI file path functions" uriFilePathSpec   describe "file path URI functions" filePathUriSpec+  describe "URI normalization functions" uriNormalizeSpec  testPosixUri :: Uri testPosixUri = Uri $ pack "file:///home/myself/example.hs"@@ -96,6 +97,12 @@     uri `shouldBe` Uri "file://myself/example.hs"     let back = platformAwareUriToFilePath "posix" uri     back `shouldBe` Just relativePosixFilePath++uriNormalizeSpec :: Spec+uriNormalizeSpec = do+  it "ignores differences in percent-encoding" $ property $ \uri -> do+    toNormalizedUri (Uri $ pack $ escapeURIString isUnescapedInURI uri) `shouldBe`+        toNormalizedUri (Uri $ pack $ escapeURIString (const False) uri)  genWindowsFilePath :: Gen FilePath genWindowsFilePath = do

@@ -12,18 +12,25 @@ import Test.Hspec  spec :: Spec-spec = describe "workspace folders" $-  it "keeps track of open workspace folders" $ do+spec =+  describe "workspace folders" $ it "keeps track of open workspace folders" $ do      lfVar <- newEmptyMVar -    let initCb :: InitializeCallback ()-        initCb = (const $ Left "", \lf -> putMVar lfVar lf >> return Nothing)+    let initCb :: InitializeCallbacks ()+        initCb = InitializeCallbacks+          (const $ Left "")+          (const $ Left "")+          (\lf -> putMVar lfVar lf >> return Nothing)         handlers = def      tvarLspId <- newTVarIO 0-    tvarCtx <- newTVarIO $-      defaultLanguageContextData handlers def undefined tvarLspId (const $ return ()) Nothing+    tvarCtx   <- newTVarIO $ defaultLanguageContextData handlers+                                                        def+                                                        undefined+                                                        tvarLspId+                                                        (const $ return ())+                                                        Nothing      let putMsg msg =           let jsonStr = encode msg