Merge pull request #478 from haskell/mpj/metamodel2

Generate types from the metamodel (attempt 2)

Author: michaelpj

.gitattributes

@@ -0,0 +1 @@
+lsp-types/generated linguist-generated=true

cabal.project

@@ -6,7 +6,7 @@ packages:
 package lsp
   flags: +demo
 
-index-state: 2023-01-01T00:00:00Z
+index-state: 2023-05-18T00:00:00Z
 
 tests: True
 benchmarks: True

lsp-test/ChangeLog.md

@@ -1,5 +1,9 @@
 # Revision history for lsp-test
 
+## 0.15.0.0
+
+* Support `lsp-types-2.0.0.0` and `lsp-2.0.0.0`.
+
 ## 0.14.1.0
 
 * Compatibility with new `lsp-types` major version.

lsp-test/bench/SimpleBench.hs

@@ -1,30 +1,33 @@
 {-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE GADTs, OverloadedStrings #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 module Main where
 
 import Language.LSP.Server
 import qualified Language.LSP.Test as Test
-import Language.LSP.Types
+import Language.LSP.Protocol.Types
+import Language.LSP.Protocol.Message
 import Control.Monad.IO.Class
 import Control.Monad
-import System.Process
+import System.Process hiding (env)
 import System.Environment
 import System.Time.Extra
 import Control.Concurrent
 import Data.IORef
 
 handlers :: Handlers (LspM ())
 handlers = mconcat
-  [ requestHandler STextDocumentHover $ \req responder -> do
-      let RequestMessage _ _ _ (HoverParams _doc pos _workDone) = req
+  [ requestHandler SMethod_TextDocumentHover $ \req responder -> do
+      let TRequestMessage _ _ _ (HoverParams _doc pos _workDone) = req
           Position _l _c' = pos
           rsp = Hover ms (Just range)
-          ms = HoverContents $ markedUpContent "lsp-demo-simple-server" "Hello world"
+          ms = InL $ mkMarkdown "Hello world"
           range = Range pos pos
-      responder (Right $ Just rsp)
-  , requestHandler STextDocumentDefinition $ \req responder -> do
-      let RequestMessage _ _ _ (DefinitionParams (TextDocumentIdentifier doc) pos _ _) = req
-      responder (Right $ InL $ Location doc $ Range pos pos)
+      responder (Right $ InL rsp)
+  , requestHandler SMethod_TextDocumentDefinition $ \req responder -> do
+      let TRequestMessage _ _ _ (DefinitionParams (TextDocumentIdentifier doc) pos _ _) = req
+      responder (Right $ InL $ Definition $ InL $ Location doc $ Range pos pos)
   ]
 
 server :: ServerDefinition ()
@@ -44,19 +47,19 @@ main = do
 
   n <- read . head <$> getArgs
 
-  forkIO $ void $ runServerWithHandles mempty mempty hinRead houtWrite server
+  _ <- forkIO $ void $ runServerWithHandles mempty mempty hinRead houtWrite server
   liftIO $ putStrLn $ "Starting " <> show n <> " rounds"
 
-  i <- newIORef 0
+  i <- newIORef (0 :: Integer)
 
   Test.runSessionWithHandles hinWrite houtRead Test.defaultConfig Test.fullCaps "." $ do
     start <- liftIO offsetTime
     replicateM_ n $ do
-      n <- liftIO $ readIORef i
-      liftIO $ when (n `mod` 1000 == 0) $ putStrLn $ show n
-      ResponseMessage{_result=Right (Just _)} <- Test.request STextDocumentHover $
+      v <- liftIO $ readIORef i
+      liftIO $ when (v `mod` 1000 == 0) $ putStrLn $ show v
+      TResponseMessage{_result=Right (InL _)} <- Test.request SMethod_TextDocumentHover $
                                                               HoverParams (TextDocumentIdentifier $ Uri "test") (Position 1 100) Nothing
-      ResponseMessage{_result=Right (InL _)} <- Test.request STextDocumentDefinition $
+      TResponseMessage{_result=Right (InL _)} <- Test.request SMethod_TextDocumentDefinition $
                                                               DefinitionParams (TextDocumentIdentifier $ Uri "test") (Position 1000 100) Nothing Nothing
 
       liftIO $ modifyIORef' i (+1)

lsp-test/example/Test.hs

@@ -2,7 +2,8 @@
 import Control.Applicative.Combinators
 import Control.Monad.IO.Class
 import Language.LSP.Test
-import Language.LSP.Types
+import Language.LSP.Protocol.Types
+import Language.LSP.Protocol.Message
 
 main = runSession "lsp-demo-reactor-server" fullCaps "test/data/" $ do
   doc <- openDoc "Rename.hs" "haskell"
@@ -11,7 +12,7 @@ main = runSession "lsp-demo-reactor-server" fullCaps "test/data/" $ do
   skipManyTill loggingNotification (count 1 publishDiagnosticsNotification)
 
   -- Send requests and notifications and receive responses
-  rsp <- request STextDocumentDocumentSymbol $
+  rsp <- request SMethod_TextDocumentDocumentSymbol $
           DocumentSymbolParams Nothing Nothing doc
   liftIO $ print rsp
 

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.Types
-import Language.LSP.Types.Lens hiding (options)
+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
@@ -41,7 +42,7 @@ main = hspec $ do
 
           handlers :: MVar () -> Handlers (LspM ())
           handlers killVar =
-            notificationHandler SInitialized $ \noti -> do
+            notificationHandler SMethod_Initialized $ \noti -> do
               tid <- withRunInIO $ \runInIO ->
                 forkIO $ runInIO $
                   withProgress "Doing something" NotCancellable $ \updater ->
@@ -55,20 +56,16 @@ main = hspec $ do
       Test.runSessionWithHandles hinWrite houtRead Test.defaultConfig Test.fullCaps "." $ do
         -- First make sure that we get a $/progress begin notification
         skipManyTill Test.anyMessage $ do
-          x <- Test.message SProgress
-          let isBegin (Begin _) = True
-              isBegin _ = False
-          guard $ isBegin $ x ^. params . value
+          x <- Test.message SMethod_Progress
+          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 SProgress
-          let isEnd (End _) = True
-              isEnd _ = False
-          guard $ isEnd $ x ^. params . value
+          x <- Test.message SMethod_Progress
+          guard $ has (L.params . L.value . _workDoneProgressEnd) x
 
   describe "workspace folders" $
     it "keeps track of open workspace folders" $ do
@@ -77,9 +74,9 @@ main = hspec $ do
 
       countVar <- newMVar 0
 
-      let wf0 = WorkspaceFolder "one" "Starter workspace"
-          wf1 = WorkspaceFolder "/foo/bar" "My workspace"
-          wf2 = WorkspaceFolder "/foo/baz" "My other workspace"
+      let wf0 = WorkspaceFolder (filePathToUri "one") "Starter workspace"
+          wf1 = WorkspaceFolder (filePathToUri "/foo/bar") "My workspace"
+          wf2 = WorkspaceFolder (filePathToUri "/foo/baz") "My other workspace"
 
           definition = ServerDefinition
             { onConfigurationChange = const $ const $ Right ()
@@ -92,10 +89,10 @@ main = hspec $ do
 
           handlers :: Handlers (LspM ())
           handlers = mconcat
-            [ notificationHandler SInitialized $ \noti -> do
+            [ notificationHandler SMethod_Initialized $ \noti -> do
                 wfs <- fromJust <$> getWorkspaceFolders
                 liftIO $ wfs `shouldContain` [wf0]
-            , notificationHandler SWorkspaceDidChangeWorkspaceFolders $ \noti -> do
+            , notificationHandler SMethod_WorkspaceDidChangeWorkspaceFolders $ \noti -> do
                 i <- liftIO $ modifyMVar countVar (\i -> pure (i + 1, i))
                 wfs <- fromJust <$> getWorkspaceFolders
                 liftIO $ case i of
@@ -116,11 +113,9 @@ main = hspec $ do
             }
 
           changeFolders add rmv =
-            let addedFolders = List add
-                removedFolders = List rmv
-                ev = WorkspaceFoldersChangeEvent addedFolders removedFolders
+            let ev = WorkspaceFoldersChangeEvent add rmv
                 ps = DidChangeWorkspaceFoldersParams ev
-            in Test.sendNotification SWorkspaceDidChangeWorkspaceFolders ps
+            in Test.sendNotification SMethod_WorkspaceDidChangeWorkspaceFolders ps
 
       Test.runSessionWithHandles hinWrite houtRead config Test.fullCaps "." $ do
         changeFolders [wf1] []