Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Switch to normal field selectors and generic-lens #562

Open
wants to merge 3 commits into
base: master
Choose a base branch
from
Open

Switch to normal field selectors and generic-lens #562

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
d98af68
Switch to normal field selectors and generic-lens
michaelpj Mar 28, 2024
1167017
Switch to using microlens and not having a separate component
michaelpj Dec 28, 2024
680d82e
Switch `lsp` to use microlens
michaelpj Dec 30, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
The table of contents is too big for display.
Diff view
Diff view
  •  
  •  
  •  
1 change: 1 addition & 0 deletions .gitignore
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -21,3 +21,4 @@ hie
hie.yaml
.envrc
**/.golden/*/actual
.jj
4 changes: 2 additions & 2 deletions lsp-test/bench/SimpleBench.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -61,10 +61,10 @@ main = do
replicateM_ n $ do
v <- liftIO $ readIORef i
liftIO $ when (v `mod` 1000 == 0) $ putStrLn $ show v
TResponseMessage{_result = Right (InL _)} <-
TResponseMessage{result = Right (InL _)} <-
Test.request SMethod_TextDocumentHover $
HoverParams (TextDocumentIdentifier $ Uri "test") (Position 1 100) Nothing
TResponseMessage{_result = Right (InL _)} <-
TResponseMessage{result = Right (InL _)} <-
Test.request SMethod_TextDocumentDefinition $
DefinitionParams (TextDocumentIdentifier $ Uri "test") (Position 1000 100) Nothing Nothing

Expand Down
52 changes: 28 additions & 24 deletions lsp-test/func-test/FuncTest.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,5 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}

Expand All @@ -14,10 +16,12 @@ import Control.Lens hiding (Iso, List)
import Control.Monad
import Control.Monad.IO.Class
import Data.Aeson qualified as J
import Data.Generics.Labels ()
import Data.Generics.Product.Fields (field')
import Data.Maybe
import Data.Proxy
import Language.LSP.Protocol.Lens qualified as L
import Language.LSP.Protocol.Message
import Data.Set qualified as Set
import Language.LSP.Protocol.Message hiding (error)
import Language.LSP.Protocol.Types
import Language.LSP.Server
import Language.LSP.Test qualified as Test
Expand Down Expand Up @@ -90,36 +94,36 @@ spec = do
-- has happened and the server has been able to send us a begin message
skipManyTill Test.anyMessage $ do
x <- Test.message SMethod_Progress
guard $ has (L.params . L.value . _workDoneProgressBegin) x
guard $ has (field' @"params" . #value . workDoneProgressBegin) x

-- allow the hander to send us updates
liftIO $ signalBarrier startBarrier ()

do
u <- Test.message SMethod_Progress
liftIO $ do
u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step1")
u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 25)
u ^? field' @"params" . #value . workDoneProgressReport . #message `shouldBe` Just (Just "step1")
u ^? field' @"params" . #value . workDoneProgressReport . #percentage `shouldBe` Just (Just 25)
liftIO $ signalBarrier b1 ()

do
u <- Test.message SMethod_Progress
liftIO $ do
u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step2")
u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 50)
u ^? field' @"params" . #value . workDoneProgressReport . #message `shouldBe` Just (Just "step2")
u ^? field' @"params" . #value . workDoneProgressReport . #percentage `shouldBe` Just (Just 50)
liftIO $ signalBarrier b2 ()

do
u <- Test.message SMethod_Progress
liftIO $ do
u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step3")
u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 75)
u ^? field' @"params" . #value . workDoneProgressReport . #message `shouldBe` Just (Just "step3")
u ^? field' @"params" . #value . workDoneProgressReport . #percentage `shouldBe` Just (Just 75)
liftIO $ signalBarrier b3 ()

-- Then make sure we get a $/progress end notification
skipManyTill Test.anyMessage $ do
x <- Test.message SMethod_Progress
guard $ has (L.params . L.value . _workDoneProgressEnd) x
guard $ has (field' @"params" . #value . workDoneProgressEnd) x

it "handles cancellation" $ do
wasCancelled <- newMVar False
Expand Down Expand Up @@ -150,19 +154,19 @@ spec = do
-- Wait until we have created the progress so the updates will be sent individually
token <- skipManyTill Test.anyMessage $ do
x <- Test.message SMethod_WindowWorkDoneProgressCreate
pure $ x ^. L.params . L.token
pure $ x ^. field' @"params" . #token

-- First make sure that we get a $/progress begin notification
skipManyTill Test.anyMessage $ do
x <- Test.message SMethod_Progress
guard $ has (L.params . L.value . _workDoneProgressBegin) x
guard $ has (field' @"params" . #value . workDoneProgressBegin) x

Test.sendNotification SMethod_WindowWorkDoneProgressCancel (WorkDoneProgressCancelParams token)

-- Then make sure we still get a $/progress end notification
skipManyTill Test.anyMessage $ do
x <- Test.message SMethod_Progress
guard $ has (L.params . L.value . _workDoneProgressEnd) x
guard $ has (field' @"params" . #value . workDoneProgressEnd) x

c <- readMVar wasCancelled
c `shouldBe` True
Expand Down Expand Up @@ -194,15 +198,15 @@ spec = do
-- First make sure that we get a $/progress begin notification
skipManyTill Test.anyMessage $ do
x <- Test.message SMethod_Progress
guard $ has (L.params . L.value . _workDoneProgressBegin) x
guard $ has (field' @"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 SMethod_Progress
guard $ has (L.params . L.value . _workDoneProgressEnd) x
guard $ has (field' @"params" . #value . workDoneProgressEnd) x

describe "client-initiated progress reporting" $ do
it "sends updates" $ do
Expand All @@ -226,7 +230,7 @@ spec = do
handlers :: Handlers (LspM ())
handlers =
requestHandler SMethod_TextDocumentCodeLens $ \req resp -> void $ forkIO $ do
withProgress "Doing something" (req ^. L.params . L.workDoneToken) NotCancellable $ \updater -> do
withProgress "Doing something" (req ^. field' @"params" . #workDoneToken) NotCancellable $ \updater -> do
liftIO $ waitBarrier startBarrier
updater $ ProgressAmount (Just 25) (Just "step1")
liftIO $ waitBarrier b1
Expand All @@ -241,35 +245,35 @@ spec = do
-- First make sure that we get a $/progress begin notification
skipManyTill Test.anyMessage $ do
x <- Test.message SMethod_Progress
guard $ has (L.params . L.value . _workDoneProgressBegin) x
guard $ has (field' @"params" . #value . workDoneProgressBegin) x

liftIO $ signalBarrier startBarrier ()

do
u <- Test.message SMethod_Progress
liftIO $ do
u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step1")
u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 25)
u ^? field' @"params" . #value . workDoneProgressReport . #message `shouldBe` Just (Just "step1")
u ^? field' @"params" . #value . workDoneProgressReport . #percentage `shouldBe` Just (Just 25)
liftIO $ signalBarrier b1 ()

do
u <- Test.message SMethod_Progress
liftIO $ do
u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step2")
u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 50)
u ^? field' @"params" . #value . workDoneProgressReport . #message `shouldBe` Just (Just "step2")
u ^? field' @"params" . #value . workDoneProgressReport . #percentage `shouldBe` Just (Just 50)
liftIO $ signalBarrier b2 ()

do
u <- Test.message SMethod_Progress
liftIO $ do
u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step3")
u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 75)
u ^? field' @"params" . #value . workDoneProgressReport . #message `shouldBe` Just (Just "step3")
u ^? field' @"params" . #value . workDoneProgressReport . #percentage `shouldBe` Just (Just 75)
liftIO $ signalBarrier b3 ()

-- Then make sure we get a $/progress end notification
skipManyTill Test.anyMessage $ do
x <- Test.message SMethod_Progress
guard $ has (L.params . L.value . _workDoneProgressEnd) x
guard $ has (field' @"params" . #value . workDoneProgressEnd) x

describe "workspace folders" $
it "keeps track of open workspace folders" $ do
Expand Down
6 changes: 5 additions & 1 deletion lsp-test/lsp-test.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
cabal-version: 2.4
cabal-version: 3.0
name: lsp-test
version: 0.17.1.0
synopsis: Functional test framework for LSP servers.
Expand Down Expand Up @@ -62,6 +62,7 @@ library
, exceptions ^>=0.10
, extra ^>=1.7
, filepath >=1.4 && < 1.6
, generic-lens ^>=2.2
, Glob >=0.9 && <0.11
, lens >=5.1 && <5.4
, lens-aeson ^>=1.2
Expand Down Expand Up @@ -108,6 +109,7 @@ test-suite tests
, directory
, extra
, filepath
, generic-lens
, hspec
, lens
, lsp
Expand All @@ -128,7 +130,9 @@ test-suite func-test
, base
, aeson
, co-log-core
, containers
, extra
, generic-lens
, hspec
, lens
, lsp
Expand Down
Loading