Generate types from metamodel

lsp-test/bench/SimpleBench.hs

@@ -1,10 +1,12 @@
 {-# 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.Types hiding (options)
 import Control.Monad.IO.Class
 import Control.Monad
 import System.Process
@@ -15,16 +17,16 @@ 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 $ markedUpContent "lsp-demo-simple-server" "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 ()
@@ -54,9 +56,9 @@ main = do
     replicateM_ n $ do
       n <- liftIO $ readIORef i
       liftIO $ when (n `mod` 1000 == 0) $ putStrLn $ show n
-      ResponseMessage{_result=Right (Just _)} <- Test.request STextDocumentHover $
+      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

@@ -11,7 +11,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,7 @@ 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.Types hiding (options, error)
 import Control.Monad.IO.Class
 import System.IO
 import Control.Monad
@@ -41,7 +40,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 +54,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 (params . 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 (params . value . _workDoneProgressEnd) x
 
   describe "workspace folders" $
     it "keeps track of open workspace folders" $ do
@@ -77,9 +72,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 +87,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 +111,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] []

lsp-test/lsp-test.cabal

@@ -58,8 +58,8 @@ library
                      , mtl < 2.4
                      , parser-combinators >= 1.2
                      , process >= 1.6
+                     , row-types
                      , text
-                     , transformers
                      , unordered-containers
                      , some
   if os(windows)
@@ -83,6 +83,7 @@ test-suite tests
   ghc-options:         -W
   build-depends:       base >= 4.10 && < 5
                      , hspec
+                     , containers
                      , lens
                      , lsp == 1.6.*
                      , lsp-test