Merge pull request #480 from joyfulmantis/mpjs-metamodel2-separatelens

Separate lens module, Have ResponseErrors also take LSPResponseErrors, and standardize SemanticToken fields

Author: michaelpj

lsp-test/bench/SimpleBench.hs

@@ -6,7 +6,7 @@ module Main where
 
 import Language.LSP.Server
 import qualified Language.LSP.Test as Test
-import Language.LSP.Protocol.Types hiding (options, range, start, end)
+import Language.LSP.Protocol.Types
 import Language.LSP.Protocol.Message
 import Control.Monad.IO.Class
 import Control.Monad

lsp-test/func-test/FuncTest.hs

@@ -4,8 +4,9 @@ module Main where
 
 import Language.LSP.Server
 import qualified Language.LSP.Test as Test
-import Language.LSP.Protocol.Types hiding (options, error)
-import Language.LSP.Protocol.Message hiding (options, error)
+import Language.LSP.Protocol.Types
+import qualified Language.LSP.Protocol.Lens as L
+import Language.LSP.Protocol.Message 
 import Control.Monad.IO.Class
 import System.IO
 import Control.Monad
@@ -56,15 +57,15 @@ main = hspec $ do
         -- First make sure that we get a $/progress begin notification
         skipManyTill Test.anyMessage $ do
           x <- Test.message SMethod_Progress
-          guard $ has (params . value . _workDoneProgressBegin) x
+          guard $ has (L.params . L.value . _workDoneProgressBegin) x
 
         -- Then kill the thread
         liftIO $ putMVar killVar ()
 
         -- Then make sure we still get a $/progress end notification
         skipManyTill Test.anyMessage $ do
           x <- Test.message SMethod_Progress
-          guard $ has (params . value . _workDoneProgressEnd) x
+          guard $ has (L.params . L.value . _workDoneProgressEnd) x
 
   describe "workspace folders" $
     it "keeps track of open workspace folders" $ do

lsp-test/lsp-test.cabal

@@ -105,6 +105,7 @@ test-suite tests
     , lsp           ^>=2.0
     , lsp-test
     , mtl           <2.4
+    , parser-combinators
     , process
     , text
     , unliftio
@@ -122,6 +123,7 @@ test-suite func-test
     , lens
     , lsp
     , lsp-test
+    , parser-combinators
     , process
     , unliftio
 

lsp-test/src/Language/LSP/Test.hs

@@ -118,10 +118,8 @@ import Data.Default
 import Data.List
 import Data.Maybe
 import Language.LSP.Protocol.Types
-  hiding (capabilities, message, executeCommand, applyEdit, rename, to, id)
 import Language.LSP.Protocol.Message
-import qualified Language.LSP.Protocol.Types as LSP
-import qualified Language.LSP.Protocol.Message as LSP
+import qualified Language.LSP.Protocol.Lens as L
 import qualified Language.LSP.Protocol.Capabilities as C
 import Language.LSP.VFS
 import Language.LSP.Test.Compat
@@ -229,7 +227,7 @@ runSessionWithHandles' serverProc serverIn serverOut config' caps rootDir sessio
     -- collect them and then...
     (inBetween, initRspMsg) <- manyTill_ anyMessage (responseForId SMethod_Initialize initReqId)
 
-    case initRspMsg ^. LSP.result of
+    case initRspMsg ^. L.result of
       Left error -> liftIO $ putStrLn ("Error while initializing: " ++ show error)
       Right _ -> pure ()
 
@@ -293,7 +291,7 @@ envOverrideConfig cfg = do
 documentContents :: TextDocumentIdentifier -> Session T.Text
 documentContents doc = do
   vfs <- vfs <$> get
-  let Just file = vfs ^. vfsMap . at (toNormalizedUri (doc ^. uri))
+  let Just file = vfs ^. vfsMap . at (toNormalizedUri (doc ^. L.uri))
   return (virtualFileText file)
 
 -- | Parses an ApplyEditRequest, checks that it is for the passed document
@@ -308,14 +306,14 @@ getDocumentEdit doc = do
   documentContents doc
   where
     checkDocumentChanges req =
-      let changes = req ^. params . edit . documentChanges
+      let changes = req ^. L.params . L.edit . L.documentChanges
           maybeDocs = fmap (fmap documentChangeUri) changes
       in case maybeDocs of
-        Just docs -> (doc ^. uri) `elem` docs
+        Just docs -> (doc ^. L.uri) `elem` docs
         Nothing -> False
     checkChanges req =
-      let mMap = req ^. params . edit . changes
-        in maybe False (Map.member (doc ^. uri)) mMap
+      let mMap = req ^. L.params . L.edit . L.changes
+        in maybe False (Map.member (doc ^. L.uri)) mMap
 
 -- | Sends a request to the server and waits for its response.
 -- Will skip any messages in between the request and the response
@@ -434,10 +432,10 @@ createDoc file languageId contents = do
       createHits _ = False
 
       regHits :: TRegistration Method_WorkspaceDidChangeWatchedFiles -> Bool
-      regHits reg = foldl' (\acc w -> acc || watchHits w) False (reg ^. registerOptions . _Just . watchers)
+      regHits reg = foldl' (\acc w -> acc || watchHits w) False (reg ^. L.registerOptions . _Just . L.watchers)
 
       clientCapsSupports =
-          caps ^? workspace . _Just . didChangeWatchedFiles . _Just . dynamicRegistration . _Just
+          caps ^? L.workspace . _Just . L.didChangeWatchedFiles . _Just . L.dynamicRegistration . _Just
             == Just True
       shouldSend = clientCapsSupports && foldl' (\acc r -> acc || regHits r) False regs
 
@@ -469,14 +467,14 @@ openDoc' file languageId contents = do
 -- | Closes a text document and sends a textDocument/didOpen notification to the server.
 closeDoc :: TextDocumentIdentifier -> Session ()
 closeDoc docId = do
-  let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
+  let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. L.uri))
   sendNotification SMethod_TextDocumentDidClose params
 
 -- | Changes a text document and sends a textDocument/didOpen notification to the server.
 changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session ()
 changeDoc docId changes = do
   verDoc <- getVersionedDoc docId
-  let params = DidChangeTextDocumentParams (verDoc & version +~ 1) changes
+  let params = DidChangeTextDocumentParams (verDoc & L.version +~ 1) changes
   sendNotification SMethod_TextDocumentDidChange params
 
 -- | Gets the Uri for the file corrected to the session directory.
@@ -490,7 +488,7 @@ getDocUri file = do
 waitForDiagnostics :: Session [Diagnostic]
 waitForDiagnostics = do
   diagsNot <- skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics)
-  let diags = diagsNot ^. params . LSP.diagnostics
+  let diags = diagsNot ^. L.params . L.diagnostics
   return diags
 
 -- | The same as 'waitForDiagnostics', but will only match a specific
@@ -504,15 +502,15 @@ waitForDiagnosticsSource src = do
     else return res
   where
     matches :: Diagnostic -> Bool
-    matches d = d ^. source == Just (T.pack src)
+    matches d = d ^. L.source == Just (T.pack src)
 
 -- | Expects a 'PublishDiagnosticsNotification' and throws an
 -- 'UnexpectedDiagnostics' exception if there are any diagnostics
 -- returned.
 noDiagnostics :: Session ()
 noDiagnostics = do
   diagsNot <- message SMethod_TextDocumentPublishDiagnostics
-  when (diagsNot ^. params . LSP.diagnostics /= []) $ liftIO $ throw UnexpectedDiagnostics
+  when (diagsNot ^. L.params . L.diagnostics /= []) $ liftIO $ throw UnexpectedDiagnostics
 
 -- | Returns the symbols in a document.
 getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [SymbolInformation] [DocumentSymbol])
@@ -530,10 +528,10 @@ getCodeActions doc range = do
   ctx <- getCodeActionContextInRange doc range
   rsp <- request SMethod_TextDocumentCodeAction (CodeActionParams Nothing Nothing doc range ctx)
 
-  case rsp ^. result of
+  case rsp ^. L.result of
     Right (InL xs) -> return xs
     Right (InR _) -> return []
-    Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. LSP.id) error)
+    Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) error)
 
 -- | Returns all the code actions in a document by
 -- querying the code actions at each of the current
@@ -547,7 +545,7 @@ getAllCodeActions doc = do
   where
     go :: CodeActionContext -> [Command |? CodeAction] -> Diagnostic -> Session [Command |? CodeAction]
     go ctx acc diag = do
-      TResponseMessage _ rspLid res <- request SMethod_TextDocumentCodeAction (CodeActionParams Nothing Nothing doc (diag ^. range) ctx)
+      TResponseMessage _ rspLid res <- request SMethod_TextDocumentCodeAction (CodeActionParams Nothing Nothing doc (diag ^. L.range) ctx)
 
       case res of
         Left e -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) e)
@@ -582,7 +580,7 @@ getCodeActionContext doc = do
 -- | Returns the current diagnostics that have been sent to the client.
 -- Note that this does not wait for more to come in.
 getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic]
-getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. uri) . curDiagnostics <$> get
+getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. L.uri) . curDiagnostics <$> get
 
 -- | Returns the tokens of all progress sessions that have started but not yet ended.
 getIncompleteProgressSessions :: Session (Set.Set ProgressToken)
@@ -591,8 +589,8 @@ getIncompleteProgressSessions = curProgressSessions <$> get
 -- | Executes a command.
 executeCommand :: Command -> Session ()
 executeCommand cmd = do
-  let args = decode $ encode $ fromJust $ cmd ^. arguments
-      execParams = ExecuteCommandParams Nothing (cmd ^. command) args
+  let args = decode $ encode $ fromJust $ cmd ^. L.arguments
+      execParams = ExecuteCommandParams Nothing (cmd ^. L.command) args
   void $ sendRequest SMethod_WorkspaceExecuteCommand execParams
 
 -- | Executes a code action.
@@ -601,8 +599,8 @@ executeCommand cmd = do
 -- be applied first.
 executeCodeAction :: CodeAction -> Session ()
 executeCodeAction action = do
-  maybe (return ()) handleEdit $ action ^. edit
-  maybe (return ()) executeCommand $ action ^. command
+  maybe (return ()) handleEdit $ action ^. L.edit
+  maybe (return ()) executeCommand $ action ^. L.command
 
   where handleEdit :: WorkspaceEdit -> Session ()
         handleEdit e =
@@ -627,14 +625,14 @@ applyEdit doc edit = do
 
   caps <- asks sessionCapabilities
 
-  let supportsDocChanges = fromMaybe False $ caps ^? LSP.workspace . _Just . LSP.workspaceEdit . _Just . documentChanges . _Just
+  let supportsDocChanges = fromMaybe False $ caps ^? L.workspace . _Just . L.workspaceEdit . _Just . L.documentChanges . _Just
 
   let wEdit = if supportsDocChanges
       then
         let docEdit = TextDocumentEdit (review _versionedTextDocumentIdentifier verDoc) [InL edit]
         in WorkspaceEdit Nothing (Just [InL docEdit]) Nothing
       else
-        let changes = Map.singleton (doc ^. uri) [edit]
+        let changes = Map.singleton (doc ^. L.uri) [edit]
         in WorkspaceEdit (Just changes) Nothing Nothing
 
   let req = TRequestMessage "" (IdInt 0) SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit)
@@ -650,7 +648,7 @@ getCompletions doc pos = do
 
   case getResponseResult rsp of
     InL items -> return items
-    InR (InL c) -> return $ c ^. LSP.items
+    InR (InL c) -> return $ c ^. L.items
     InR (InR _) -> return []
 
 -- | Returns the references for the position in the document.
@@ -723,9 +721,9 @@ getHighlights doc pos =
 -- Returns the result if successful.
 getResponseResult :: (ToJSON (ErrorData m)) => TResponseMessage m -> MessageResult m
 getResponseResult rsp =
-  case rsp ^. result of
+  case rsp ^. L.result of
     Right x -> x
-    Left err -> throw $ UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. LSP.id) err
+    Left err -> throw $ UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) err
 
 -- | Applies formatting to the specified document.
 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
@@ -743,7 +741,7 @@ formatRange doc opts range = do
 
 applyTextEdits :: TextDocumentIdentifier -> [TextEdit] -> Session ()
 applyTextEdits doc edits =
-  let wEdit = WorkspaceEdit (Just (Map.singleton (doc ^. uri) edits)) Nothing Nothing
+  let wEdit = WorkspaceEdit (Just (Map.singleton (doc ^. L.uri) edits)) Nothing Nothing
       -- Send a dummy message to updateState so it can do bookkeeping
       req = TRequestMessage "" (IdInt 0) SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit)
   in updateState (FromServerMess SMethod_WorkspaceApplyEdit req)

lsp-test/src/Language/LSP/Test/Decoding.hs

@@ -15,8 +15,8 @@ import qualified Data.ByteString.Lazy.Char8    as B
 import           Data.Maybe
 import           System.IO
 import           System.IO.Error
-import           Language.LSP.Protocol.Message hiding (error)
-import           Language.LSP.Protocol.Types
+import           Language.LSP.Protocol.Message
+import qualified Language.LSP.Protocol.Lens as L
 import           Language.LSP.Test.Exceptions
 
 import Data.IxMap
@@ -64,10 +64,10 @@ getRequestMap = foldl' helper emptyIxMap
   helper acc msg = case msg of
     FromClientMess m mess -> case splitClientMethod m of
       IsClientNot -> acc
-      IsClientReq -> fromJust $ updateRequestMap acc (mess ^. id) m
+      IsClientReq -> fromJust $ updateRequestMap acc (mess ^. L.id) m
       IsClientEither -> case mess of
         NotMess _ -> acc
-        ReqMess msg -> fromJust $ updateRequestMap acc (msg ^. id) m
+        ReqMess msg -> fromJust $ updateRequestMap acc (msg ^. L.id) m
     _ -> acc
 
 decodeFromServerMsg :: RequestMap -> B.ByteString -> (RequestMap, FromServerMessage)

lsp-test/src/Language/LSP/Test/Files.hs

@@ -10,10 +10,11 @@ module Language.LSP.Test.Files
   )
 where
 
-import           Language.LSP.Protocol.Message hiding (error)
-import           Language.LSP.Protocol.Types hiding (id)
+import           Language.LSP.Protocol.Message
+import           Language.LSP.Protocol.Types
+import qualified Language.LSP.Protocol.Lens    as L
 import           Control.Lens
-import qualified Data.Map.Strict           as M
+import qualified Data.Map.Strict               as M
 import qualified Data.Text                     as T
 import           Data.Maybe
 import           System.Directory
@@ -40,7 +41,7 @@ swapFiles relCurBaseDir msgs = do
 rootDir :: [Event] -> FilePath
 rootDir (ClientEv _ (FromClientMess SMethod_Initialize req):_) =
   fromMaybe (error "Couldn't find root dir") $ do
-    rootUri <- case req ^. params . rootUri of
+    rootUri <- case req ^. L.params . L.rootUri of
         InL r -> Just r
         InR _ -> error "Couldn't find root dir"
     uriToFilePath rootUri
@@ -54,46 +55,46 @@ mapUris f event =
 
   where
     --TODO: Handle all other URIs that might need swapped
-    fromClientMsg (FromClientMess m@SMethod_Initialize                 r) = FromClientMess m $ params .~ transformInit (r ^. params) $ r
-    fromClientMsg (FromClientMess m@SMethod_TextDocumentDidOpen        n) = FromClientMess m $ swapUri (params . textDocument) n
-    fromClientMsg (FromClientMess m@SMethod_TextDocumentDidChange      n) = FromClientMess m $ swapUri (params . textDocument) n
-    fromClientMsg (FromClientMess m@SMethod_TextDocumentWillSave       n) = FromClientMess m $ swapUri (params . textDocument) n
-    fromClientMsg (FromClientMess m@SMethod_TextDocumentDidSave        n) = FromClientMess m $ swapUri (params . textDocument) n
-    fromClientMsg (FromClientMess m@SMethod_TextDocumentDidClose       n) = FromClientMess m $ swapUri (params . textDocument) n
-    fromClientMsg (FromClientMess m@SMethod_TextDocumentDocumentSymbol n) = FromClientMess m $ swapUri (params . textDocument) n
-    fromClientMsg (FromClientMess m@SMethod_TextDocumentRename         n) = FromClientMess m $ swapUri (params . textDocument) n
+    fromClientMsg (FromClientMess m@SMethod_Initialize                 r) = FromClientMess m $ L.params .~ transformInit (r ^. L.params) $ r
+    fromClientMsg (FromClientMess m@SMethod_TextDocumentDidOpen        n) = FromClientMess m $ swapUri (L.params . L.textDocument) n
+    fromClientMsg (FromClientMess m@SMethod_TextDocumentDidChange      n) = FromClientMess m $ swapUri (L.params . L.textDocument) n
+    fromClientMsg (FromClientMess m@SMethod_TextDocumentWillSave       n) = FromClientMess m $ swapUri (L.params . L.textDocument) n
+    fromClientMsg (FromClientMess m@SMethod_TextDocumentDidSave        n) = FromClientMess m $ swapUri (L.params . L.textDocument) n
+    fromClientMsg (FromClientMess m@SMethod_TextDocumentDidClose       n) = FromClientMess m $ swapUri (L.params . L.textDocument) n
+    fromClientMsg (FromClientMess m@SMethod_TextDocumentDocumentSymbol n) = FromClientMess m $ swapUri (L.params . L.textDocument) n
+    fromClientMsg (FromClientMess m@SMethod_TextDocumentRename         n) = FromClientMess m $ swapUri (L.params . L.textDocument) n
     fromClientMsg x = x
 
     fromServerMsg :: FromServerMessage -> FromServerMessage
-    fromServerMsg (FromServerMess m@SMethod_WorkspaceApplyEdit r) = FromServerMess m $ params . edit .~ swapWorkspaceEdit (r ^. params . edit) $ r
-    fromServerMsg (FromServerMess m@SMethod_TextDocumentPublishDiagnostics n) = FromServerMess m $ swapUri params n
+    fromServerMsg (FromServerMess m@SMethod_WorkspaceApplyEdit r) = FromServerMess m $ L.params . L.edit .~ swapWorkspaceEdit (r ^. L.params . L.edit) $ r
+    fromServerMsg (FromServerMess m@SMethod_TextDocumentPublishDiagnostics n) = FromServerMess m $ swapUri L.params n
     fromServerMsg (FromServerRsp m@SMethod_TextDocumentDocumentSymbol r) =
       let swapUri' :: ([SymbolInformation] |? [DocumentSymbol] |? Null) -> [SymbolInformation] |? [DocumentSymbol] |? Null
           swapUri' (InR (InL dss)) = InR $ InL dss -- no file locations here
           swapUri' (InR (InR n)) = InR $ InR n
-          swapUri' (InL si) = InL (swapUri location <$> si)
-      in FromServerRsp m $ r & result . _Right %~ swapUri'
-    fromServerMsg (FromServerRsp m@SMethod_TextDocumentRename r) = FromServerRsp m $ r & result . _Right . _L %~ swapWorkspaceEdit
+          swapUri' (InL si) = InL (swapUri L.location <$> si)
+      in FromServerRsp m $ r & L.result . _Right %~ swapUri'
+    fromServerMsg (FromServerRsp m@SMethod_TextDocumentRename r) = FromServerRsp m $ r & L.result . _Right . _L %~ swapWorkspaceEdit
     fromServerMsg x = x
 
     swapWorkspaceEdit :: WorkspaceEdit -> WorkspaceEdit
     swapWorkspaceEdit e =
       let swapDocumentChangeUri :: DocumentChange -> DocumentChange
-          swapDocumentChangeUri (InL textDocEdit) = InL $ swapUri textDocument textDocEdit
+          swapDocumentChangeUri (InL textDocEdit) = InL $ swapUri L.textDocument textDocEdit
           swapDocumentChangeUri (InR (InL createFile)) = InR $ InL $ swapUri id createFile
           -- for RenameFile, we swap `newUri`
-          swapDocumentChangeUri (InR (InR (InL renameFile))) = InR $ InR $ InL $ newUri .~ f (renameFile ^. newUri) $ renameFile
+          swapDocumentChangeUri (InR (InR (InL renameFile))) = InR $ InR $ InL $ L.newUri .~ f (renameFile ^. L.newUri) $ renameFile
           swapDocumentChangeUri (InR (InR (InR deleteFile))) = InR $ InR $ InR $ swapUri id deleteFile
-       in e & changes . _Just %~ swapKeys f
-            & documentChanges . _Just . traversed%~ swapDocumentChangeUri
+       in e & L.changes . _Just %~ swapKeys f
+            & L.documentChanges . _Just . traversed%~ swapDocumentChangeUri
 
     swapKeys :: (Uri -> Uri) -> M.Map Uri b -> M.Map Uri b
     swapKeys f = M.foldlWithKey' (\acc k v -> M.insert (f k) v acc) M.empty
 
-    swapUri :: HasUri b Uri => Lens' a b -> a -> a
+    swapUri :: L.HasUri b Uri => Lens' a b -> a -> a
     swapUri lens x =
-      let newUri = f (x ^. lens . uri)
-        in (lens . uri) .~ newUri $ x
+      let newUri = f (x ^. lens . L.uri)
+        in (lens . L.uri) .~ newUri $ x
 
     -- | Transforms rootUri/rootPath.
     transformInit :: InitializeParams -> InitializeParams
@@ -104,5 +105,5 @@ mapUris f event =
             in case uriToFilePath (f uri) of
               Just fp -> T.pack fp
               Nothing -> p
-      in x & rootUri . _L %~ f
-           & rootPath . _Just . _L %~ modifyRootPath
+      in x & L.rootUri . _L %~ f
+           & L.rootPath . _Just . _L %~ modifyRootPath