Switch to using microlens and not having a separate component

michaelpj · michaelpj · commit 11670179812f · 2024-12-30T21:22:27.000Z
diff --git a/lsp-test/func-test/FuncTest.hs b/lsp-test/func-test/FuncTest.hs
@@ -21,7 +21,6 @@ import Data.Generics.Product.Fields (field')
 import Data.Maybe
 import Data.Proxy
 import Data.Set qualified as Set
-import Language.LSP.Protocol.Lens
 import Language.LSP.Protocol.Message hiding (error)
 import Language.LSP.Protocol.Types
 import Language.LSP.Server
diff --git a/lsp-test/lsp-test.cabal b/lsp-test/lsp-test.cabal
@@ -68,7 +68,6 @@ library
     , lens-aeson          ^>=1.2
     , lsp                 ^>=2.7
     , lsp-types           ^>=2.3
-    , lsp-types:lsp-types-lens
     , mtl                 >=2.2   && <2.4
     , parser-combinators  ^>=1.3
     , process             ^>=1.6
@@ -138,7 +137,6 @@ test-suite func-test
     , lens
     , lsp
     , lsp-test
-    , lsp-types:lsp-types-lens
     , parser-combinators
     , process
     , unliftio
diff --git a/lsp-test/src/Language/LSP/Test.hs b/lsp-test/src/Language/LSP/Test.hs
@@ -167,7 +167,6 @@ import Data.Text qualified as T
 import Data.Text.IO qualified as T
 import Data.Traversable (for)
 import Language.LSP.Protocol.Capabilities qualified as C
-import Language.LSP.Protocol.Lens qualified as L
 import Language.LSP.Protocol.Message (MessageDirection (..), MessageKind (..), Method (..), SMethod (..))
 import Language.LSP.Protocol.Message qualified as L
 import Language.LSP.Protocol.Types (ClientCapabilities, type (|?) (..))
@@ -773,8 +772,8 @@ executeCommand cmd = do
 -}
 executeCodeAction :: L.CodeAction -> Session ()
 executeCodeAction action = do
-  maybe (return ()) handleEdit  action.edit
-  maybe (return ()) executeCommand  action.command
+  maybe (return ()) handleEdit action.edit
+  maybe (return ()) executeCommand action.command
  where
   handleEdit :: L.WorkspaceEdit -> Session ()
   handleEdit e =
diff --git a/lsp-test/src/Language/LSP/Test/Decoding.hs b/lsp-test/src/Language/LSP/Test/Decoding.hs
@@ -69,10 +69,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.id m
       IsClientEither -> case mess of
         NotMess _ -> acc
-        ReqMess msg -> fromJust $ updateRequestMap acc (msg.id) m
+        ReqMess msg -> fromJust $ updateRequestMap acc msg.id m
     _ -> acc
 
 decodeFromServerMsg :: RequestMap -> B.ByteString -> (RequestMap, FromServerMessage)
diff --git a/lsp-test/src/Language/LSP/Test/Session.hs b/lsp-test/src/Language/LSP/Test/Session.hs
@@ -68,7 +68,6 @@ import Data.Maybe
 import Data.Function
 import Language.LSP.Protocol.Types as LSP hiding (to)
 import Language.LSP.Protocol.Message as LSP hiding (error)
-import Language.LSP.Protocol.Lens
 import Language.LSP.VFS
 import Language.LSP.Test.Compat
 import Language.LSP.Test.Decoding
@@ -385,9 +384,9 @@ updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m)
             => FromServerMessage -> m ()
 updateState (FromServerMess SMethod_Progress req) = case req.params.value of
   v | Just _ <- v ^? workDoneProgressBegin ->
-    modify $ \s -> s { curProgressSessions = Set.insert (req.params.token) $ curProgressSessions s }
+    modify $ \s -> s { curProgressSessions = Set.insert req.params.token $ curProgressSessions s }
   v | Just _ <- v ^? workDoneProgressEnd ->
-    modify $ \s -> s { curProgressSessions = Set.delete (req.params.token) $ curProgressSessions s }
+    modify $ \s -> s { curProgressSessions = Set.delete req.params.token $ curProgressSessions s }
   _ -> pure ()
 
 -- Keep track of dynamic capability registration
diff --git a/lsp-types/lens/Language/LSP/Protocol/Lens.hs b/lsp-types/lens/Language/LSP/Protocol/Lens.hs
diff --git a/lsp-types/lsp-types.cabal b/lsp-types/lsp-types.cabal
@@ -78,6 +78,7 @@ library
     , mod                            ^>=0.2
     , mtl                            >=2.2   && <2.4
     , network-uri                    ^>=2.6
+    , profunctors                    ^>=5.6
     , prettyprinter                  ^>=1.7
     , row-types                      ^>=1.0
     , safe                           ^>=0.3
@@ -126,6 +127,7 @@ library
     Language.LSP.Protocol.Types.LspEnum
     Language.LSP.Protocol.Types.MarkupContent
     Language.LSP.Protocol.Types.Orphans
+    Language.LSP.Protocol.Types.Progress
     Language.LSP.Protocol.Types.SemanticTokens
     Language.LSP.Protocol.Types.Singletons
     Language.LSP.Protocol.Types.Uri
@@ -611,21 +613,6 @@ library lsp-types-quickcheck
     , generic-arbitrary
     , template-haskell
 
-library lsp-types-lens
-  visibility:         public
-  hs-source-dirs:     lens
-  default-language:   GHC2021
-
-  exposed-modules:
-    Language.LSP.Protocol.Lens
-
-  build-depends:
-    , aeson             >=2
-    , base              >=4.11    && <5
-    , lsp-types
-    , lens              >=5.1     && <5.3
-    , text              >=1       && <2.2
-
 executable generator
   hs-source-dirs:     generator
   default-language:   GHC2021
diff --git a/lsp-types/src/Language/LSP/Protocol/Capabilities.hs b/lsp-types/src/Language/LSP/Protocol/Capabilities.hs
@@ -1,8 +1,8 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE OverloadedLabels #-}
 
 module Language.LSP.Protocol.Capabilities (
   LSPVersion (..),
@@ -20,17 +20,17 @@ module Language.LSP.Protocol.Capabilities (
   serverCapability,
 ) where
 
+import Data.Function ((&))
+import Data.Generics.Labels ()
 import Data.Kind (Type)
 import Data.Maybe
 import Data.Set qualified as Set
 import Data.Void
 import Language.LSP.Protocol.Message
 import Language.LSP.Protocol.Types
-import Prelude hiding (min)
+import Lens.Micro (Lens', lens, non, (.~), (^.), (^?), _Just)
 import Lens.Micro qualified as L
-import Lens.Micro (Lens', (.~), (^.), lens, non, (^?), _Just)
-import Data.Generics.Labels ()
-import Data.Function ((&))
+import Prelude hiding (min)
 
 -- | A specific version of the LSP specification.
 data LSPVersion = LSPVersion Int Int
@@ -307,7 +307,7 @@ dynamicRegistrationSupported m caps = fromMaybe False $ case m of
   -- Notebook document methods alway support dynamic registration, it seems?
   _ -> Just False
  where
-  --dyn :: L.HasDynamicRegistration (ClientCapability m) (Maybe Bool) => SMethod m -> Traversal' ClientCapabilities Bool
+  -- dyn :: L.HasDynamicRegistration (ClientCapability m) (Maybe Bool) => SMethod m -> Traversal' ClientCapabilities Bool
   dyn m1 = clientCapability m1 . _Just . #dynamicRegistration . _Just
 
 -- | Client capabilities for full support of the current LSP specification.
@@ -328,12 +328,12 @@ fullClientCapsForVersion v@(LSPVersion maj min) = caps
 
   caps =
     ClientCapabilities
-       { workspace = Just workspace
-       , textDocument = Just td
-       , window = Just window
-       , general = since 3 16 general
-       , notebookDocument = NotebookDocumentClientCapabilities <$> methCaps SMethod_NotebookDocumentDidOpen
-       , experimental = Nothing
+      { workspace = Just workspace
+      , textDocument = Just td
+      , window = Just window
+      , general = since 3 16 general
+      , notebookDocument = NotebookDocumentClientCapabilities <$> methCaps SMethod_NotebookDocumentDidOpen
+      , experimental = Nothing
       }
 
   window =
@@ -353,8 +353,8 @@ fullClientCapsForVersion v@(LSPVersion maj min) = caps
 
   workspace =
     WorkspaceClientCapabilities
-       { applyEdit = methCaps SMethod_WorkspaceApplyEdit
-       , workspaceEdit =
+      { applyEdit = methCaps SMethod_WorkspaceApplyEdit
+      , workspaceEdit =
           Just
             ( WorkspaceEditClientCapabilities
                 (Just True)
diff --git a/lsp-types/src/Language/LSP/Protocol/Types.hs b/lsp-types/src/Language/LSP/Protocol/Types.hs
@@ -34,6 +34,9 @@ module Language.LSP.Protocol.Types (
   -- ** WatchKinds
   module WatchKinds,
 
+  -- ** Progress
+  module Progress,
+
   -- * Main LSP types and functions
   module Generated,
 ) where
@@ -46,6 +49,7 @@ import Language.LSP.Protocol.Types.Location as Locations
 import Language.LSP.Protocol.Types.LspEnum as LspEnum
 import Language.LSP.Protocol.Types.MarkupContent as Markup
 import Language.LSP.Protocol.Types.Orphans ()
+import Language.LSP.Protocol.Types.Progress as Progress
 import Language.LSP.Protocol.Types.SemanticTokens as SemanticTokens
 import Language.LSP.Protocol.Types.Singletons as Singletons
 import Language.LSP.Protocol.Types.Uri as Uri
diff --git a/lsp-types/src/Language/LSP/Protocol/Types/Edit.hs b/lsp-types/src/Language/LSP/Protocol/Types/Edit.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE OverloadedStrings #-}
 
 module Language.LSP.Protocol.Types.Edit where
 
@@ -8,6 +7,7 @@ import Data.Text qualified as T
 
 import Language.LSP.Protocol.Internal.Types
 import Language.LSP.Protocol.Types.Common
+import Language.LSP.Protocol.Utils.Misc (Prism, prism)
 
 -- | Convenience alias for the type in the 'WorkspaceEdit._documentChanges' field.
 type DocumentChange = TextDocumentEdit |? CreateFile |? RenameFile |? DeleteFile
@@ -48,3 +48,11 @@ editTextEdit :: TextEdit -> TextEdit -> TextEdit
 editTextEdit (TextEdit origRange origText) innerEdit =
   let newText = applyTextEdit innerEdit origText
    in TextEdit origRange newText
+
+-- | Conversion between 'OptionalVersionedTextDocumentIdentifier' and 'VersionedTextDocumentIdentifier'.
+versionedTextDocumentIdentifier :: Prism OptionalVersionedTextDocumentIdentifier OptionalVersionedTextDocumentIdentifier VersionedTextDocumentIdentifier VersionedTextDocumentIdentifier
+versionedTextDocumentIdentifier = prism down up
+ where
+  down (VersionedTextDocumentIdentifier uri v) = OptionalVersionedTextDocumentIdentifier uri (InL v)
+  up (OptionalVersionedTextDocumentIdentifier uri (InL v)) = Right $ VersionedTextDocumentIdentifier uri v
+  up i@(OptionalVersionedTextDocumentIdentifier _ (InR _)) = Left i
diff --git a/lsp-types/src/Language/LSP/Protocol/Types/Progress.hs b/lsp-types/src/Language/LSP/Protocol/Types/Progress.hs
@@ -0,0 +1,23 @@
+module Language.LSP.Protocol.Types.Progress (workDoneProgressBegin, workDoneProgressEnd, workDoneProgressReport) where
+
+import Data.Aeson
+import Language.LSP.Protocol.Internal.Types
+import Language.LSP.Protocol.Utils.Misc (Prism, prism)
+
+-- From lens-aeson
+_JSON :: (ToJSON a, FromJSON a) => Prism Value Value a a
+_JSON = prism toJSON $ \v -> case fromJSON v of
+  Success y -> Right y
+  _ -> Left v
+
+-- | Prism for extracting the 'WorkDoneProgressBegin' case from the unstructured 'value' field of 'ProgressParams'.
+workDoneProgressBegin :: Prism Value Value WorkDoneProgressBegin WorkDoneProgressBegin
+workDoneProgressBegin = _JSON
+
+-- | Prism for extracting the 'WorkDoneProgressEnd' case from the unstructured 'value' field of 'ProgressParams'.
+workDoneProgressEnd :: Prism Value Value WorkDoneProgressEnd WorkDoneProgressEnd
+workDoneProgressEnd = _JSON
+
+-- | Prism for extracting the 'WorkDoneProgressReport' case from the unstructured 'value' field of 'ProgressParams'.
+workDoneProgressReport :: Prism Value Value WorkDoneProgressReport WorkDoneProgressReport
+workDoneProgressReport = _JSON
diff --git a/lsp-types/src/Language/LSP/Protocol/Utils/Misc.hs b/lsp-types/src/Language/LSP/Protocol/Utils/Misc.hs
@@ -9,6 +9,8 @@ module Language.LSP.Protocol.Utils.Misc (
   lspOptionsUntagged,
   prettyJSON,
   ViaJSON (..),
+  Prism,
+  prism,
 ) where
 
 import Control.Monad
@@ -19,6 +21,8 @@ import Data.Foldable.WithIndex qualified as F
 import Data.Functor.WithIndex.Instances qualified ()
 import Data.List hiding (group)
 import Data.Maybe (mapMaybe)
+import Data.Profunctor (dimap)
+import Data.Profunctor.Choice (Choice, right')
 import Language.Haskell.TH as TH
 import Prettyprinter
 
@@ -132,3 +136,8 @@ newtype ViaJSON a = ViaJSON a
 
 instance ToJSON a => Pretty (ViaJSON a) where
   pretty (ViaJSON a) = prettyJSON $ toJSON a
+
+type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
+
+prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
+prism bt seta = dimap seta (either pure (fmap bt)) . right'
diff --git a/lsp/example/Reactor.hs b/lsp/example/Reactor.hs
@@ -37,7 +37,6 @@ import Data.Text qualified as T
 import GHC.Generics (Generic)
 import Language.LSP.Diagnostics
 import Language.LSP.Logging (defaultClientLogger)
-import Language.LSP.Protocol.Lens
 import Language.LSP.Protocol.Message qualified as LSP
 import Language.LSP.Protocol.Types qualified as LSP
 import Language.LSP.Server
@@ -241,7 +240,7 @@ handle logger =
     , notificationHandler LSP.SMethod_TextDocumentDidChange $ \msg -> do
         let
           params = msg.params
-          doc = LSP.toNormalizedUri (params.textDocument.uri)
+          doc = LSP.toNormalizedUri params.textDocument.uri
         logger <& ("Processing DidChangeTextDocument for: " <> T.pack (show doc)) `WithSeverity` Info
         mdoc <- getVirtualFile doc
         case mdoc of
@@ -261,10 +260,10 @@ handle logger =
         let params = req.params
             LSP.Position l c = params.position
             newName = params.newName
-        vdoc <- getVersionedTextDoc (params.textDocument)
+        vdoc <- getVersionedTextDoc params.textDocument
         -- Replace some text at the position with what the user entered
         let edit = LSP.InL $ LSP.TextEdit (LSP.mkRange l c l (c + fromIntegral (T.length newName))) newName
-            tde = LSP.TextDocumentEdit (versionedTextDocumentIdentifier # vdoc) [edit]
+            tde = LSP.TextDocumentEdit (LSP.versionedTextDocumentIdentifier # vdoc) [edit]
             -- "documentChanges" field is preferred over "changes"
             rsp = LSP.WorkspaceEdit Nothing (Just [LSP.InL tde]) Nothing
         responder (Right $ LSP.InL rsp)
@@ -279,7 +278,7 @@ handle logger =
     , requestHandler LSP.SMethod_TextDocumentDocumentSymbol $ \req responder -> do
         logger <& "Processing a textDocument/documentSymbol request" `WithSeverity` Info
         let LSP.DocumentSymbolParams _ _ doc = req.params
-            loc = LSP.Location (doc.uri) (LSP.Range (LSP.Position 0 0) (LSP.Position 0 0))
+            loc = LSP.Location doc.uri (LSP.Range (LSP.Position 0 0) (LSP.Position 0 0))
             rsp = [LSP.SymbolInformation "lsp-hello" LSP.SymbolKind_Function Nothing Nothing Nothing loc]
         responder (Right $ LSP.InL rsp)
     , requestHandler LSP.SMethod_TextDocumentCodeAction $ \req responder -> do
@@ -315,7 +314,7 @@ handle logger =
 
         logger <& ("The arguments are: " <> T.pack (show margs)) `WithSeverity` Debug
         responder (Right $ LSP.InL (J.Object mempty)) -- respond to the request
-        void $ withProgress "Executing some long running command" (params.workDoneToken) Cancellable $ \update ->
+        void $ withProgress "Executing some long running command" params.workDoneToken Cancellable $ \update ->
           forM [(0 :: LSP.UInt) .. 10] $ \i -> do
             update (ProgressAmount (Just (i * 10)) (Just "Doing stuff"))
             liftIO $ threadDelay (1 * 1000000)
diff --git a/lsp/lsp.cabal b/lsp/lsp.cabal
@@ -91,7 +91,6 @@ executable lsp-demo-reactor-server
     , co-log-core
     , lens
     , lsp
-    , lsp-types:lsp-types-lens
     , prettyprinter
     , stm
     , text
