Virtual File System

.gitignore

@@ -4,3 +4,4 @@
 /tags
 /cabal.project.local
 .stack-work
+/.dir-locals.el

circle.yml

@@ -0,0 +1,19 @@
+dependencies:
+  cache_directories:
+    - "~/.stack"
+    - "~/.cabal"
+  pre:
+    - wget -q -O- https://s3.amazonaws.com/download.fpcomplete.com/ubuntu/fpco.key | sudo apt-key add -
+    - echo 'deb http://download.fpcomplete.com/ubuntu/precise stable main'|sudo tee /etc/apt/sources.list.d/fpco.list
+    - sudo apt-get update && sudo apt-get install stack -y
+  override:
+    - stack setup
+    - stack build -j 2 :
+        timeout: 3600
+    - stack build -j 2 --test --only-dependencies :
+        timeout: 3600
+
+test:
+  override:
+    - stack test haskell-lsp :
+        timeout: 3600

example/Main.hs

@@ -15,25 +15,20 @@ import           Control.Monad.IO.Class
 import           Control.Monad.STM
 import           Control.Monad.Trans.State.Lazy
 import qualified Data.Aeson as J
--- import qualified Data.Aeson.Types as J
--- import           Data.Algorithm.DiffOutput
 import qualified Data.ByteString.Lazy as BSL
 import           Data.Default
--- import           Data.Either
 import qualified Data.HashMap.Strict as H
--- import           Data.List
--- import qualified Data.Map as Map
 import           Data.Maybe
--- import qualified Data.Text as T
 import qualified Data.Vector as V
 import qualified Language.Haskell.LSP.Control  as CTRL
 import qualified Language.Haskell.LSP.Core     as Core
 import qualified Language.Haskell.LSP.TH.ClientCapabilities as C
 import qualified Language.Haskell.LSP.TH.DataTypesJSON as J
 import qualified Language.Haskell.LSP.Utility  as U
--- import           System.Directory
+import           Language.Haskell.LSP.VFS
 import           System.Exit
 import qualified System.Log.Logger as L
+import qualified Yi.Rope as Yi
 
 
 -- ---------------------------------------------------------------------
@@ -85,7 +80,10 @@ data ReactorInput
   = InitializeCallBack C.ClientCapabilities Core.SendFunc
       -- ^ called when the LSP ioLoop receives the `initialize` message from the
       -- client, providing the client capabilities (for LSP 3.0 and later)
-  | HandlerRequest (BSL.ByteString -> IO ()) Core.OutMessage
+  | HandlerRequest
+      (J.Uri -> IO (Maybe VirtualFile))
+      (BSL.ByteString -> IO ())
+      Core.OutMessage
       -- ^ injected into the reactor input by each of the individual callback handlers
 
 data ReactorState =
@@ -154,13 +152,13 @@ reactor st inp = do
 
       -- Handle any response from a message originating at the server, such as
       -- "workspace/applyEdit"
-      HandlerRequest sf (Core.RspFromClient rm) -> do
+      HandlerRequest _vf sf (Core.RspFromClient rm) -> do
         setSendFunc sf
         liftIO $ U.logs $ "reactor:got RspFromClient:" ++ show rm
 
       -- -------------------------------
 
-      HandlerRequest sf (Core.NotInitialized _notification) -> do
+      HandlerRequest _vf sf (Core.NotInitialized _notification) -> do
         setSendFunc sf
         liftIO $ U.logm $ "****** reactor: processing Initialized Notification"
         -- Server is ready, register any specific capabilities we need
@@ -198,7 +196,7 @@ reactor st inp = do
 
       -- -------------------------------
 
-      HandlerRequest sf (Core.NotDidOpenTextDocument notification) -> do
+      HandlerRequest _vf sf (Core.NotDidOpenTextDocument notification) -> do
         setSendFunc sf
         liftIO $ U.logm $ "****** reactor: processing NotDidOpenTextDocument"
         let
@@ -211,7 +209,24 @@ reactor st inp = do
 
       -- -------------------------------
 
-      HandlerRequest sf (Core.NotDidSaveTextDocument notification) -> do
+      HandlerRequest vf sf (Core.NotDidChangeTextDocument notification) -> do
+        setSendFunc sf
+        let
+            params  = fromJust $ J._params (notification :: J.DidChangeTextDocumentNotification)
+            textDoc = J._textDocument (params :: J.DidChangeTextDocumentParams)
+            doc     = J._uri (textDoc :: J.VersionedTextDocumentIdentifier)
+        mdoc <- liftIO $ vf doc
+        case mdoc of
+          Just (VirtualFile version str) -> do
+            liftIO $ U.logs $ "reactor:processing NotDidChangeTextDocument: vf got:" ++ (show $ Yi.toString str)
+          Nothing -> do
+            liftIO $ U.logs $ "reactor:processing NotDidChangeTextDocument: vf returned Nothing"
+
+        liftIO $ U.logs $ "reactor:processing NotDidChangeTextDocument: uri=" ++ (show doc)
+
+      -- -------------------------------
+
+      HandlerRequest _vf sf (Core.NotDidSaveTextDocument notification) -> do
         setSendFunc sf
         liftIO $ U.logm "****** reactor: processing NotDidSaveTextDocument"
         let
@@ -221,12 +236,9 @@ reactor st inp = do
         liftIO $ U.logs $ "********* doc=" ++ show doc
         sendDiagnostics doc
 
-      HandlerRequest sf (Core.NotDidChangeTextDocument _notification) -> do
-        setSendFunc sf
-        liftIO $ U.logm "****** reactor: NOT processing NotDidChangeTextDocument"
-
       -- -------------------------------
-      HandlerRequest sf (Core.ReqRename req) -> do
+
+      HandlerRequest _vf sf (Core.ReqRename req) -> do
         setSendFunc sf
         liftIO $ U.logs $ "reactor:got RenameRequest:" ++ show req
         let params = fromJust $ J._params (req :: J.RenameRequest)
@@ -243,7 +255,7 @@ reactor st inp = do
 
       -- -------------------------------
 
-      HandlerRequest sf r@(Core.ReqHover req) -> do
+      HandlerRequest _vf sf r@(Core.ReqHover req) -> do
         setSendFunc sf
         liftIO $ U.logs $ "reactor:got HoverRequest:" ++ show req
         let J.TextDocumentPositionParams doc pos = fromJust $ J._params (req :: J.HoverRequest)
@@ -258,7 +270,7 @@ reactor st inp = do
 
       -- -------------------------------
 
-      HandlerRequest sf (Core.ReqCodeAction req) -> do
+      HandlerRequest _vf sf (Core.ReqCodeAction req) -> do
         setSendFunc sf
         liftIO $ U.logs $ "reactor:got CodeActionRequest:" ++ show req
         let params = fromJust $ J._params (req :: J.CodeActionRequest)
@@ -286,7 +298,7 @@ reactor st inp = do
 
       -- -------------------------------
 
-      HandlerRequest sf (Core.ReqExecuteCommand req) -> do
+      HandlerRequest _vf sf (Core.ReqExecuteCommand req) -> do
         setSendFunc sf
         liftIO $ U.logs $ "reactor:got ExecuteCommandRequest:" -- ++ show req
         let params = fromJust $ J._params (req :: J.ExecuteCommandRequest)
@@ -311,7 +323,7 @@ reactor st inp = do
 
       -- -------------------------------
 
-      HandlerRequest sf om -> do
+      HandlerRequest _vf sf om -> do
         setSendFunc sf
         liftIO $ U.logs $ "reactor:got HandlerRequest:" ++ show om
 
@@ -366,13 +378,13 @@ lspHandlers rin
 -- ---------------------------------------------------------------------
 
 passHandler :: TChan ReactorInput -> (a -> Core.OutMessage) -> Core.Handler a
-passHandler rin c sf notification = do
-  atomically $ writeTChan rin (HandlerRequest sf (c notification))
+passHandler rin c vf sf notification = do
+  atomically $ writeTChan rin (HandlerRequest vf sf (c notification))
 
 -- ---------------------------------------------------------------------
 
 responseHandlerCb :: TChan ReactorInput -> Core.Handler J.BareResponseMessage
-responseHandlerCb _rin _sf resp = do
+responseHandlerCb _rin _vf _sf resp = do
   U.logs $ "******** got ResponseMessage, ignoring:" ++ show resp
 
 -- ---------------------------------------------------------------------

haskell-lsp.cabal

@@ -29,6 +29,7 @@ library
                      , Language.Haskell.LSP.TH.Constants
                      , Language.Haskell.LSP.TH.DataTypesJSON
                      , Language.Haskell.LSP.Utility
+                     , Language.Haskell.LSP.VFS
   -- other-modules:
  -- other-extensions:
   ghc-options:         -Wall
@@ -53,6 +54,7 @@ library
                      , text
                      , time
                      , unordered-containers
+                     , yi-rope
   hs-source-dirs:      src
   default-language:    Haskell2010
 
@@ -67,6 +69,7 @@ executable lsp-hello
                      , Language.Haskell.LSP.Constant
                      , Language.Haskell.LSP.TH.DataTypesJSON
                      , Language.Haskell.LSP.Utility
+                     , Language.Haskell.LSP.VFS
 
   build-depends:       base >=4.9 && <4.10
                      , aeson
@@ -90,9 +93,32 @@ executable lsp-hello
                      , transformers
                      , unordered-containers
                      , vector
+                     , yi-rope
                      -- the package library. Comment this out if you want repl changes to propagate
                      , haskell-lsp
 
+test-suite haskell-lsp-test
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      test src
+  main-is:             Main.hs
+  other-modules:       Spec
+                       VspSpec
+  build-depends:       base
+                     , aeson
+                     , containers
+                     , directory
+                     , hspec
+                     -- , hspec-jenkins
+                     , yi-rope
+                     -- , haskell-lsp
+                     , data-default
+                     , bytestring
+                     , hslogger
+                     , text
+                     , unordered-containers
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall
+  default-language:    Haskell2010
+
 source-repository head
   type:     git
   location: https://github.com/alanz/haskell-lsp

src/Language/Haskell/LSP/Core.hs

@@ -27,18 +27,20 @@ module Language.Haskell.LSP.Core (
 
 import           Control.Concurrent
 import qualified Control.Exception as E
+import           Control.Monad
 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 qualified Data.Map as MAP
+import qualified Data.Map as Map
 import qualified Data.Text as T
 import           Language.Haskell.LSP.Constant
 import qualified Language.Haskell.LSP.TH.ClientCapabilities as C
 import qualified Language.Haskell.LSP.TH.DataTypesJSON      as J
 import           Language.Haskell.LSP.Utility
+import           Language.Haskell.LSP.VFS
 import           System.Directory
 import           System.Exit
 import           System.IO
@@ -62,7 +64,7 @@ data LanguageContextData =
   , resHandlers            :: !Handlers
   , resOptions             :: !Options
   , resSendResponse        :: !(BSL.ByteString -> IO ())
-  -- , resChanOut             :: !(TChan BSL.ByteString)
+  , resVFS                 :: !VFS
   }
 
 -- ---------------------------------------------------------------------
@@ -95,7 +97,8 @@ type InitializeCallback = C.ClientCapabilities -> SendFunc -> IO (Maybe J.Respon
 -- | 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
 -- received message of type 'b'
-type Handler b = (BSL.ByteString -> IO ()) -> b -> IO ()
+type Handler b = (J.Uri -> IO (Maybe VirtualFile)) -> (BSL.ByteString -> IO ()) -> b -> IO ()
+-- TODO: change the sendFunc to take a ToJSON type instead
 
 -- | Callbacks from the language server to the language handler
 data Handlers =
@@ -153,8 +156,8 @@ instance Default Handlers where
 -- ---------------------------------------------------------------------
 
 handlerMap :: Handlers
-           -> MAP.Map String (MVar LanguageContextData -> String -> B.ByteString -> IO ())
-handlerMap h = MAP.fromList
+           -> Map.Map String (MVar LanguageContextData -> String -> B.ByteString -> IO ())
+handlerMap h = Map.fromList
   [ ("textDocument/completion",        hh $ completionHandler h)
   , ("completionItem/resolve",         hh $ completionResolveHandler h)
   , ("textDocument/hover",             hh $ hoverHandler h)
@@ -189,23 +192,33 @@ handlerMap h = MAP.fromList
 
 -- ---------------------------------------------------------------------
 
--- | Adapter from the handlers exposed to the library users and the internal message loop
+-- | Adapter from the normal handlers exposed to the library users and the
+-- internal message loop
 hh :: forall b. (J.FromJSON b)
    => Maybe (Handler b) -> MVar LanguageContextData -> String -> B.ByteString -> IO ()
 hh Nothing = \mvarDat cmd jsonStr -> do
       let msg = unwords ["haskell-lsp:no handler for.", cmd, lbs2str jsonStr]
       sendErrorLog mvarDat msg
-hh (Just h) = \mvarDat _cmd jsonStr -> do
+hh (Just h) = \mvarDat cmd jsonStr -> do
       case J.eitherDecode jsonStr of
         Right req -> do
           ctx <- readMVar mvarDat
-          h (resSendResponse ctx) req
+          vfs' <- getVfs (resVFS ctx) cmd jsonStr
+          modifyMVar_ mvarDat (\c -> return c {resVFS = vfs'})
+          h (getVirtualFile mvarDat) (resSendResponse ctx) req
         Left  err -> do
           let msg = unwords $ ["haskell-lsp:parse error.", lbs2str jsonStr, show err] ++ _ERR_MSG_URL
           sendErrorLog mvarDat msg
 
 -- ---------------------------------------------------------------------
 
+getVirtualFile :: MVar LanguageContextData -> J.Uri -> IO (Maybe (VirtualFile))
+getVirtualFile mvarDat uri = do
+  ctx <- readMVar mvarDat
+  return $ Map.lookup uri (resVFS ctx)
+
+-- ---------------------------------------------------------------------
+
 -- | Wrap all the protocol messages into a single type, for use in the language
 -- handler in storing the original message
 data OutMessage = ReqHover                    J.HoverRequest
@@ -291,7 +304,7 @@ _ERR_MSG_URL = [ "`stack update` and install new haskell-lsp."
 --
 --
 defaultLanguageContextData :: Handlers -> Options -> LanguageContextData
-defaultLanguageContextData h o = LanguageContextData _INITIAL_RESPONSE_SEQUENCE Nothing h o BSL.putStr
+defaultLanguageContextData h o = LanguageContextData _INITIAL_RESPONSE_SEQUENCE Nothing h o BSL.putStr mempty
 
 -- ---------------------------------------------------------------------
 
@@ -355,7 +368,7 @@ handleRequest dispatcherProc mvarDat contLenStr' jsonStr' = do
     handle jsonStr cmd = do
       ctx <- readMVar mvarDat
       let h = resHandlers ctx
-      case MAP.lookup cmd (handlerMap h) of
+      case Map.lookup cmd (handlerMap h) of
         Just f -> f mvarDat cmd jsonStr
         Nothing -> do
           let msg = unwords ["haskell-lsp:unknown message received:method='" ++ cmd ++ "',", lbs2str contLenStr', lbs2str jsonStr]
@@ -440,7 +453,7 @@ initializeRequestHandler dispatcherProc mvarCtx req@(J.RequestMessage _ origId _
       Nothing -> return ()
       Just dir -> do
         logs $ "haskell-lsp:initializeRequestHandler: setting current dir to project root:" ++ dir
-        setCurrentDirectory dir
+        unless (null dir) $ setCurrentDirectory dir
 
     let
       getCapabilities :: J.InitializeParams -> C.ClientCapabilities