Move DA.LanguageServer.Protocol to haskell-lsp-types (digital-asset#1437

) There are still a few types left over that I will replace in separate PRs.
TuranDev · May 28, 2019 · df674c5 · df674c5
1 parent c0f4585
commit df674c5
Show file tree

Hide file tree

Showing 11 changed files with 90 additions and 689 deletions.
diff --git a/.hlint.yaml b/.hlint.yaml
@@ -88,6 +88,7 @@
 - flags:
   - default: false
   - {name: [-Wno-missing-signatures, -Wno-orphans, -Wno-overlapping-patterns, -Wno-incomplete-patterns, -Wno-missing-fields, -Wno-unused-matches]}
+  - {name: -Wno-deprecations, within: DA.Service.Daml.LanguageServer.Hover}
 
 # - modules:
 #   - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'

diff --git a/daml-foundations/daml-ghc/language-server/BUILD.bazel b/daml-foundations/daml-ghc/language-server/BUILD.bazel
@@ -15,6 +15,7 @@ da_haskell_library(
         "base",
         "containers",
         "extra",
+        "haskell-lsp-types",
         "managed",
         "network-uri",
         "safe",

diff --git a/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer.hs b/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer.hs
@@ -1,6 +1,7 @@
 -- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
 -- SPDX-License-Identifier: Apache-2.0
 
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE OverloadedStrings  #-}
 {-# LANGUAGE TemplateHaskell    #-}
 
@@ -18,15 +19,13 @@ import qualified Control.Monad.Managed                     as Managed
 import           DA.LanguageServer.Protocol
 import           DA.LanguageServer.Server
 
-import Data.Tagged
 import Control.Monad
 import Data.List.Extra
 import Control.Monad.IO.Class
 import Safe
 import qualified DA.Daml.LF.Ast as LF
 import qualified DA.Service.Daml.Compiler.Impl.Handle as Compiler
 import qualified DA.Service.Daml.LanguageServer.CodeLens   as LS.CodeLens
-import           DA.Service.Daml.LanguageServer.Common
 import qualified DA.Service.Daml.LanguageServer.Definition as LS.Definition
 import qualified DA.Service.Daml.LanguageServer.Hover      as LS.Hover
 import qualified DA.Service.Logger                         as Logger
@@ -104,7 +103,7 @@ deriveDAToJSON "_wvp" ''WorkspaceValidationsParams
 
 serverCapabilities :: ServerCapabilities
 serverCapabilities = ServerCapabilities
-    { scTextDocumentSync                 = Just SyncFull
+    { scTextDocumentSync                 = Just TdSyncFull
     , scHoverProvider                    = True
     , scCompletionProvider               = Nothing
     , scSignatureHelpProvider            = Nothing
@@ -125,7 +124,7 @@ serverCapabilities = ServerCapabilities
 -- Request handlers
 ------------------------------------------------------------------------
 
-handleRequest :: IHandle () LF.Package -> ServerRequest -> IO (Either ServerError Aeson.Value)
+handleRequest :: IHandle () LF.Package -> ServerRequest -> IO (Either ErrorCode Aeson.Value)
 handleRequest (IHandle _stateRef loggerH compilerH _notifChan) = \case
     Initialize _params -> do
         pure $ Right $ Aeson.toJSON $ InitializeResult serverCapabilities
@@ -150,10 +149,10 @@ handleNotification :: IHandle () LF.Package -> ServerNotification -> IO ()
 handleNotification (IHandle stateRef loggerH compilerH _notifChan) = \case
 
     DidOpenTextDocument (DidOpenTextDocumentParams item) ->
-        case URI.parseURI $ T.unpack $ unTagged $ tdiUri item of
+        case URI.parseURI $ T.unpack $ getUri $ _uri (item :: TextDocumentItem) of
           Just uri
               | URI.uriScheme uri == "file:"
-              -> handleDidOpenFile (URI.unEscapeString (URI.uriPath uri)) (tdiText item)
+              -> handleDidOpenFile (URI.unEscapeString (URI.uriPath uri)) (_text (item :: TextDocumentItem))
 
               | URI.uriScheme uri == "daml:"
               -> handleDidOpenVirtualResource uri
@@ -163,33 +162,33 @@ handleNotification (IHandle stateRef loggerH compilerH _notifChan) = \case
                     <> T.show uri
 
           _ -> Logger.logError loggerH $ "Invalid URI in DidOpenTextDocument: "
-                    <> T.show (tdiUri item)
+                    <> T.show (_uri (item :: TextDocumentItem))
 
-    DidChangeTextDocument (DidChangeTextDocumentParams docId changes) ->
-        case documentUriToFilePath $ vtdiUri docId of
+    DidChangeTextDocument (DidChangeTextDocumentParams docId (List changes)) ->
+        case Compiler.uriToFilePath' $ _uri (docId :: VersionedTextDocumentIdentifier) of
           Just filePath -> do
             -- ISSUE DEL-3281: Add support for incremental synchronisation
             -- to language server.
-            let newContents = tdcceText <$> lastMay changes
+            let newContents = fmap (\ev -> _text (ev :: TextDocumentContentChangeEvent)) $ lastMay changes
             Compiler.onFileModified compilerH filePath newContents
 
             Logger.logInfo loggerH
               $ "Updated text document: " <> T.show filePath
 
           Nothing ->
             Logger.logError loggerH
-              $ "Invalid file path: " <> T.show (vtdiUri docId)
+              $ "Invalid file path: " <> T.show (_uri (docId :: VersionedTextDocumentIdentifier))
 
-    DidCloseTextDocument (DidCloseTextDocumentParams docId) ->
-        case URI.parseURI $ T.unpack $ unTagged $ tdidUri docId of
+    DidCloseTextDocument (DidCloseTextDocumentParams (TextDocumentIdentifier uri)) ->
+        case URI.parseURI $ T.unpack $ getUri uri of
           Just uri
               | URI.uriScheme uri == "file:" -> handleDidCloseFile (URI.unEscapeString $ URI.uriPath uri)
               | URI.uriScheme uri == "daml:" -> handleDidCloseVirtualResource uri
               | otherwise -> Logger.logWarning loggerH $ "Unknown scheme in URI: " <> T.show uri
 
           _ -> Logger.logError loggerH
                  $    "Invalid URI in DidCloseTextDocument: "
-                   <> T.show (tdidUri docId)
+                   <> T.show uri
 
     DidSaveTextDocument _params ->
       pure ()
@@ -304,8 +303,8 @@ eventSlinger loggerH eventChan notifChan =
                 writeTChan notifChan
                     $ PublishDiagnostics
                     $ PublishDiagnosticsParams
-                    (Tagged $ Compiler.getUri $ Compiler.filePathToUri fp)
-                    (map convertDiagnostic $ nubOrd diags)
+                    (Compiler.filePathToUri fp)
+                    (List $ nubOrd diags)
                 pure Nothing
 
             Compiler.EventVirtualResourceChanged vr content -> do

diff --git a/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/CodeLens.hs b/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/CodeLens.hs
@@ -14,6 +14,7 @@ import Data.Maybe
 import qualified DA.Service.Daml.Compiler.Impl.Handle as Compiler
 import           DA.Service.Daml.LanguageServer.Common
 import qualified DA.Service.Logger                     as Logger
+import Development.IDE.Types.Diagnostics
 
 import qualified Data.Aeson                            as Aeson
 import qualified Data.Text.Extended                    as T
@@ -25,7 +26,7 @@ handle
     -> CodeLensParams
     -> IO (Either a Aeson.Value)
 handle loggerH compilerH (CodeLensParams (TextDocumentIdentifier uri)) = do
-    mbResult <- case documentUriToFilePath uri of
+    mbResult <- case uriToFilePath' uri of
         Just filePath -> do
           Logger.logInfo loggerH $ "CodeLens request for file: " <> T.pack filePath
           vrs <- Compiler.getAssociatedVirtualResources compilerH filePath

diff --git a/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/Common.hs b/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/Common.hs
@@ -8,26 +8,15 @@ module DA.Service.Daml.LanguageServer.Common
     ( -- Defaults
       damlLanguageIdentifier
 
-      -- * Conversions
-    , documentUriToFilePath
-    , absoluteFilePathToDocumentUri
-    , convertDiagnostic
-
-    -- * Location conversions
-    , fromAstLocation
-    , fromAstRange
-    , fromAstPosition
-    , toAstPosition
-
     , virtualResourceToCodeLens
 
       -- * Pretty printing
     , Pretty.renderPretty
     ) where
 
-import           DA.LanguageServer.Protocol
+import DA.LanguageServer.Protocol hiding (CodeLens)
+import Language.Haskell.LSP.Types (CodeLens(..))
 
-import Data.Tagged
 import qualified DA.Pretty                        as Pretty
 
 import qualified Data.Aeson                       as Aeson
@@ -37,95 +26,24 @@ import qualified DA.Service.Daml.Compiler.Impl.Handle as Compiler
 import qualified Development.IDE.Types.Diagnostics as Base
 import qualified Development.IDE.Types.LSP as Compiler
 
-import qualified Network.URI.Encode               as URI
-
-------------------------------------------------------------------------------
--- Defaults
-------------------------------------------------------------------------------
-
 -- | DAML-Language identifier. Used to tell VS Code to highlight
 --  certain things as DAML Code.
-damlLanguageIdentifier :: LanguageIdentifier
-damlLanguageIdentifier = Tagged "daml"
-
-
-------------------------------------------------------------------------------
--- Conversions
-------------------------------------------------------------------------------
-
--- | Convert a document URI back to a file path.
-documentUriToFilePath :: DocumentUri -> Maybe FilePath
-documentUriToFilePath (Tagged u)
-  = adjust . URI.decode . T.unpack <$> T.stripPrefix "file://" u
-  where
-    adjust ('/':xs@(_:':':_)) = xs -- handle Windows paths
-    adjust xs = xs
-
-
--- | Convert a file path for a URI for display.
-absoluteFilePathToDocumentUri :: FilePath -> DocumentUri
-absoluteFilePathToDocumentUri p
-  = Tagged $ T.pack $ "file://" ++ URI.encode (adjust p)
-  where
-    adjust xs@('/':_) = xs
-    adjust xs = '/' : xs -- handle Windows paths
-
-
--- | Convert an compiler build diagnostic.
-convertDiagnostic :: Base.Diagnostic -> Diagnostic
-convertDiagnostic Base.Diagnostic{..} =
-    Diagnostic
-        (convRange _range)
-        (convSeverity <$> _severity)
-        Nothing
-        _source
-        _message
-  where
-    convSeverity = \case
-        Base.DsError -> Error
-        Base.DsWarning -> Warning
-        Base.DsInfo -> Information
-        Base.DsHint -> Hint
-
-    convRange (Base.Range start end) = Range (convPosition start) (convPosition end)
-    convPosition (Base.Position line char) = Position line char
-
-
--- | Convert an AST location value.
-fromAstLocation :: Base.Location -> Location
-fromAstLocation (Base.Location uri range)
- = Location
-    (Tagged $ Base.getUri uri)
-    (fromAstRange range)
-
-
--- | Convert an AST range value.
-fromAstRange :: Base.Range -> Range
-fromAstRange (Base.Range startPos endPos) =
-    Range (fromAstPosition startPos) (fromAstPosition endPos)
-
-
--- | Convert an AST position value.
-fromAstPosition :: Base.Position -> Position
-fromAstPosition (Base.Position line char) = Position line char
-
-
--- | Produce an AST position value.
-toAstPosition :: Position -> Base.Position
-toAstPosition (Position line char) = Base.Position line char
+damlLanguageIdentifier :: T.Text
+damlLanguageIdentifier = "daml"
 
 
 -- | Convert a compiler virtual resource into a code lens.
 virtualResourceToCodeLens
     :: (Base.Range, T.Text, Compiler.VirtualResource)
-    -> Maybe CodeLensEntry
+    -> Maybe CodeLens
 virtualResourceToCodeLens (range, title, vr) =
- Just CodeLensEntry
-    { cleRange = fromAstRange range
-    , cleCommand = Just $ Command
+ Just CodeLens
+    { _range = range
+    , _command = Just $ Command
         "Scenario results"
         "daml.showResource"
-        (Just [ Aeson.String title
+        (Just $ List
+              [ Aeson.String title
               , Aeson.String $ Compiler.virtualResourceToUri vr])
-    , cleData = Nothing
+    , _xdata = Nothing
     }
diff --git a/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/Definition.hs b/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/Definition.hs
@@ -9,9 +9,10 @@ module DA.Service.Daml.LanguageServer.Definition
     ) where
 
 import           DA.LanguageServer.Protocol
+import DA.Pretty
+import Development.IDE.Types.Diagnostics
 
 import qualified DA.Service.Daml.Compiler.Impl.Handle as Compiler
-import           DA.Service.Daml.LanguageServer.Common
 import qualified DA.Service.Logger                     as Logger
 
 import qualified Data.Aeson                            as Aeson
@@ -25,20 +26,20 @@ handle
     -> Compiler.IdeState
     -> TextDocumentPositionParams
     -> IO (Either a Aeson.Value)
-handle loggerH compilerH (TextDocumentPositionParams docId pos) = do
+handle loggerH compilerH (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = do
 
 
-    mbResult <- case documentUriToFilePath $ tdidUri docId of
+    mbResult <- case uriToFilePath' uri of
         Just filePath -> do
           Logger.logInfo loggerH $
-            "Definition request at position " <> renderPretty pos
+            "Definition request at position " <> renderPlain (prettyPosition pos)
             <> " in file: " <> T.pack filePath
-          Compiler.gotoDefinition compilerH filePath (toAstPosition pos)
+          Compiler.gotoDefinition compilerH filePath pos
         Nothing       -> pure Nothing
 
     case mbResult of
         Nothing ->
             pure $ Right $ Aeson.toJSON ([] :: [Base.Location])
 
         Just loc ->
-            pure $ Right $ Aeson.toJSON $ fromAstLocation loc
+            pure $ Right $ Aeson.toJSON loc
diff --git a/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/Hover.hs b/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/Hover.hs
@@ -1,14 +1,19 @@
 -- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
 -- SPDX-License-Identifier: Apache-2.0
 
+-- TODO MarkedString is deprecated in LSP protocol so we should move to MarkupContent at some point.
+{-# OPTIONS_GHC -Wno-deprecations #-}
+
 {-# LANGUAGE OverloadedStrings #-}
 
 -- | Display information on hover.
 module DA.Service.Daml.LanguageServer.Hover
     ( handle
     ) where
 
-import           DA.LanguageServer.Protocol
+import DA.Pretty
+import DA.LanguageServer.Protocol hiding (Hover)
+import Language.Haskell.LSP.Types (Hover(..))
 
 import qualified DA.Service.Daml.Compiler.Impl.Handle as Compiler
 import           DA.Service.Daml.LanguageServer.Common
@@ -18,36 +23,37 @@ import qualified Data.Aeson                            as Aeson
 import qualified Data.Text.Extended                    as T
 
 import           Development.IDE.Types.LSP as Compiler
+import Development.IDE.Types.Diagnostics
 
 -- | Display information on hover.
 handle
     :: Logger.Handle IO
     -> Compiler.IdeState
     -> TextDocumentPositionParams
     -> IO (Either a Aeson.Value)
-handle loggerH compilerH (TextDocumentPositionParams docId pos) = do
-    mbResult <- case documentUriToFilePath $ tdidUri docId of
+handle loggerH compilerH (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = do
+    mbResult <- case uriToFilePath' uri of
         Just filePath -> do
           Logger.logInfo loggerH $
-              "Hover request at position " <> renderPretty pos
+              "Hover request at position " <> renderPlain (prettyPosition pos)
               <> " in file: " <> T.pack filePath
-          Compiler.atPoint compilerH filePath (toAstPosition pos)
+          Compiler.atPoint compilerH filePath pos
         Nothing       -> pure Nothing
 
     case mbResult of
         Just (mbRange, contents) ->
             pure $ Right $ Aeson.toJSON
-                  $ HoverResult
-                        (map showHoverInformation contents)
-                        (fromAstRange <$> mbRange)
+                  $ Hover
+                        (HoverContentsMS $ List $ map showHoverInformation contents)
+                        mbRange
 
         Nothing -> pure $ Right Aeson.Null
   where
     showHoverInformation :: Compiler.HoverText -> MarkedString
     showHoverInformation = \case
-        Compiler.HoverHeading h -> MarkedString ("***" <> h <> "***:")
-        Compiler.HoverDamlCode damlCode -> MarkedStringWithLanguage
-            { mswlLanguage = damlLanguageIdentifier
-            , mswlValue = damlCode
+        Compiler.HoverHeading h -> PlainString ("***" <> h <> "***:")
+        Compiler.HoverDamlCode damlCode -> CodeString $ LanguageString
+            { _language = damlLanguageIdentifier
+            , _value = damlCode
             }
-        Compiler.HoverMarkdown md -> MarkedString md
+        Compiler.HoverMarkdown md -> PlainString md
diff --git a/daml-foundations/daml-tools/language-server-tests/tests/requests/initialize/request.json b/daml-foundations/daml-tools/language-server-tests/tests/requests/initialize/request.json
@@ -2,6 +2,7 @@
   "method": "initialize",
   "payload": {
     "processId": 1234,
-    "rootPath": "file:///foo/bar/"
+    "rootPath": "file:///foo/bar/",
+    "capabilities": {}
   }
 }