mirror of
https://github.com/digital-asset/daml.git
synced 2024-09-17 15:57:21 +03:00
Daml ide multi ide (#17345)
* add -fobject-code to fix da-ghci[d] * stage everything for Sam :-) * Staging up last changes for Sam - track pending requests & SMethod types * Some cleanup, get vscode working again with full parsing * Cleanup * Add TODO notes * First multiple SubIDE support * Cleanup and polish initial multi-ide * First version of cross IDE goto definition * Small cleanup * Update TODO * Linting * Fix shutdown logic for windows * Update ghcide, fix merge warning * Read multi-package.yaml * First review comments addressed * Second batch of fixes * Penultimate batch of changes * Add errors as shown messages * Add client progress token prefixing * Review/ci fixes * Update ghcide to main * Update comment --------- Co-authored-by: Dylan Thinnes <dylan.thinnes@digitalasset.com>
This commit is contained in:
Samuel Williams
GitHub
parent
75b748198b
commit
714b0c7f4f
@ -18,8 +18,8 @@ load("@dadew//:dadew.bzl", "dadew_tool_home")
|
||||
load("@rules_haskell//haskell:cabal.bzl", "stack_snapshot")
|
||||
load("//bazel_tools/ghc-lib:repositories.bzl", "ghc_lib_and_dependencies")
|
||||
|
||||
GHCIDE_REV = "223e571d3cac214d131b85330bf09a1762e88671"
|
||||
GHCIDE_SHA256 = "5604a0e30f6e0a2ca8b2d8f9883698d4c97efdcf7d84d27539d433a49d40cf74"
|
||||
GHCIDE_REV = "96d92b9b5b5abea5e1d3df2ae06e26094d986139"
|
||||
GHCIDE_SHA256 = "a1a4b9157f81491d9dc580b638fec61e42c6c1b44e30d7ceee8c38a57e308ab6"
|
||||
GHCIDE_LOCAL_PATH = None
|
||||
JS_JQUERY_VERSION = "3.3.1"
|
||||
JS_DGTABLE_VERSION = "0.5.2"
|
||||
@ -55,6 +55,7 @@ haskell_cabal_library(
|
||||
patch_args = ["-p1"],
|
||||
patches = [
|
||||
"@com_github_digital_asset_daml//bazel_tools:lsp-types-normalisation.patch",
|
||||
"@com_github_digital_asset_daml//bazel_tools:lsp-types-expose-other-modules.patch",
|
||||
],
|
||||
sha256 = LSP_TYPES_SHA256,
|
||||
strip_prefix = "lsp-types-{}".format(LSP_TYPES_VERSION),
|
||||
@ -463,6 +464,7 @@ exports_files(["stack.exe"], visibility = ["//visibility:public"])
|
||||
"ansi-wl-pprint",
|
||||
"array",
|
||||
"async",
|
||||
"attoparsec",
|
||||
"base",
|
||||
"base16-bytestring",
|
||||
"base64",
|
||||
|
||||
20
sdk/bazel_tools/lsp-types-expose-other-modules.patch
Normal file
20
sdk/bazel_tools/lsp-types-expose-other-modules.patch
Normal file
@ -0,0 +1,20 @@
|
||||
diff --git a/lsp-types.cabal b/lsp-types.cabal
|
||||
index 1af6907..1443cc0 100644
|
||||
--- a/lsp-types.cabal
|
||||
+++ b/lsp-types.cabal
|
||||
@@ -21,6 +21,7 @@ library
|
||||
, Language.LSP.Types.Capabilities
|
||||
, Language.LSP.Types.Lens
|
||||
, Language.LSP.Types.SMethodMap
|
||||
+ , Language.LSP.Types.Utils
|
||||
, Language.LSP.VFS
|
||||
, Data.IxMap
|
||||
other-modules: Language.LSP.Types.CallHierarchy
|
||||
@@ -63,7 +64,6 @@ library
|
||||
, Language.LSP.Types.TextDocument
|
||||
, Language.LSP.Types.TypeDefinition
|
||||
, Language.LSP.Types.Uri
|
||||
- , Language.LSP.Types.Utils
|
||||
, Language.LSP.Types.Window
|
||||
, Language.LSP.Types.WatchedFiles
|
||||
, Language.LSP.Types.WorkspaceEdit
|
||||
@ -111,7 +111,12 @@
|
||||
"type": "string",
|
||||
"default": "",
|
||||
"description": "Extra arguments passed to `damlc ide`. This can be used to enable additional warnings via `--ghc-option -W`"
|
||||
}
|
||||
},
|
||||
"daml.multiPackageIdeSupport": {
|
||||
"type": "boolean",
|
||||
"default": false,
|
||||
"description": "VERY EXPERIMENTAL: Enables the incomplete and experimental multi-ide feature."
|
||||
}
|
||||
}
|
||||
},
|
||||
"menus": {
|
||||
|
||||
@ -87,6 +87,26 @@ export async function activate(context: vscode.ExtensionContext) {
|
||||
params.startedAt,
|
||||
),
|
||||
);
|
||||
vscode.workspace.onDidChangeConfiguration(
|
||||
(event: vscode.ConfigurationChangeEvent) => {
|
||||
if (event.affectsConfiguration("daml.multiPackageIdeSupport")) {
|
||||
const enabled = vscode.workspace
|
||||
.getConfiguration("daml")
|
||||
.get("multiPackageIdeSupport");
|
||||
let msg = "VSCode must be reloaded for this change to take effect.";
|
||||
if (enabled)
|
||||
msg =
|
||||
msg +
|
||||
"\nWARNING - The Multi-IDE support is experimental, has bugs, and will likely change without warning. Use at your own risk.";
|
||||
window
|
||||
.showInformationMessage(msg, { modal: true }, "Reload now")
|
||||
.then((option: string | undefined) => {
|
||||
if (option == "Reload now")
|
||||
vscode.commands.executeCommand("workbench.action.reloadWindow");
|
||||
});
|
||||
}
|
||||
},
|
||||
);
|
||||
});
|
||||
|
||||
damlLanguageClient.start();
|
||||
@ -242,8 +262,10 @@ export function createLanguageClient(
|
||||
documentSelector: ["daml"],
|
||||
};
|
||||
|
||||
const multiIDESupport = config.get("multiPackageIdeSupport");
|
||||
|
||||
let command: string;
|
||||
let args: string[] = ["ide", "--"];
|
||||
let args: string[] = [multiIDESupport ? "multi-ide" : "ide", "--"];
|
||||
|
||||
try {
|
||||
command = which.sync("daml");
|
||||
|
||||
@ -169,6 +169,8 @@ da_haskell_library(
|
||||
hackage_deps = [
|
||||
"aeson",
|
||||
"aeson-pretty",
|
||||
"async",
|
||||
"attoparsec",
|
||||
"ansi-wl-pprint",
|
||||
"ansi-terminal",
|
||||
"base",
|
||||
@ -195,15 +197,18 @@ da_haskell_library(
|
||||
"memory",
|
||||
"mtl",
|
||||
"network",
|
||||
"network-uri",
|
||||
"optparse-applicative",
|
||||
"prettyprinter",
|
||||
"process",
|
||||
"typed-process",
|
||||
"proto3-suite",
|
||||
"regex-tdfa",
|
||||
"safe",
|
||||
"safe-exceptions",
|
||||
"shake",
|
||||
"split",
|
||||
"stm",
|
||||
"tasty",
|
||||
"tasty-ant-xml",
|
||||
"tasty-hunit",
|
||||
|
||||
@ -17,7 +17,11 @@ da_haskell_library(
|
||||
"containers",
|
||||
"data-default",
|
||||
"extra",
|
||||
"filepath",
|
||||
"ghc-lib",
|
||||
"ghc-lib-parser",
|
||||
"ghcide",
|
||||
"lens",
|
||||
"lsp",
|
||||
"lsp-types",
|
||||
"network-uri",
|
||||
@ -25,9 +29,11 @@ da_haskell_library(
|
||||
"rope-utf16-splay",
|
||||
"safe",
|
||||
"safe-exceptions",
|
||||
"shake",
|
||||
"stm",
|
||||
"tagged",
|
||||
"text",
|
||||
"transformers",
|
||||
"uri-encode",
|
||||
"unordered-containers",
|
||||
],
|
||||
@ -35,9 +41,12 @@ da_haskell_library(
|
||||
visibility = ["//visibility:public"],
|
||||
deps = [
|
||||
"//compiler/daml-lf-ast",
|
||||
"//compiler/damlc/daml-compiler",
|
||||
"//compiler/damlc/daml-ide-core",
|
||||
"//compiler/damlc/daml-lf-util",
|
||||
"//compiler/damlc/daml-package-config",
|
||||
"//compiler/damlc/daml-rule-types",
|
||||
"//daml-assistant:daml-project-config",
|
||||
"//libs-haskell/da-hs-base",
|
||||
],
|
||||
)
|
||||
|
||||
@ -15,6 +15,7 @@ import qualified Data.Aeson as Aeson
|
||||
import Data.Default
|
||||
|
||||
import qualified DA.Daml.LanguageServer.CodeLens as VirtualResource
|
||||
import qualified DA.Daml.LanguageServer.SplitGotoDefinition as SplitGotoDefinition
|
||||
import Development.IDE.Types.Logger
|
||||
|
||||
import qualified Data.HashSet as HS
|
||||
@ -43,7 +44,7 @@ setHandlersKeepAlive :: Plugin c
|
||||
setHandlersKeepAlive = Plugin
|
||||
{ pluginCommands = mempty
|
||||
, pluginRules = mempty
|
||||
, pluginHandlers = pluginHandler (SCustomMethod "daml/keepAlive") $ \_ _ -> pure (Right Aeson.Null)
|
||||
, pluginHandlers = pluginHandler (SCustomMethod "daml/keepAlive") $ \_ _ -> pure (Right Aeson.Null)
|
||||
, pluginNotificationHandlers = mempty
|
||||
}
|
||||
|
||||
@ -87,7 +88,7 @@ runLanguageServer
|
||||
-> (LSP.LanguageContextEnv c -> VFSHandle -> Maybe FilePath -> IO IdeState)
|
||||
-> IO ()
|
||||
runLanguageServer lgr plugins conf getIdeState = SessionTelemetry.withPlugin lgr $ \sessionHandlerPlugin -> do
|
||||
let allPlugins = plugins <> setHandlersKeepAlive <> setHandlersVirtualResource <> VirtualResource.plugin <> sessionHandlerPlugin
|
||||
let allPlugins = plugins <> setHandlersKeepAlive <> setHandlersVirtualResource <> VirtualResource.plugin <> sessionHandlerPlugin <> SplitGotoDefinition.plugin
|
||||
let onConfigurationChange c _ = Right c
|
||||
let options = def { LSP.executeCommandCommands = Just (commandIds allPlugins) }
|
||||
LS.runLanguageServer options conf onConfigurationChange allPlugins getIdeState
|
||||
|
||||
@ -0,0 +1,239 @@
|
||||
-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
-- | Custom methods for interupting the usual goto definition flow for multi-ide deferring
|
||||
module DA.Daml.LanguageServer.SplitGotoDefinition
|
||||
( GotoDefinitionByNameParams (..)
|
||||
, GotoDefinitionByNameResult
|
||||
, TryGetDefinitionName (..)
|
||||
, TryGetDefinitionNameSpace (..)
|
||||
, TryGetDefinitionParams (..)
|
||||
, TryGetDefinitionResult (..)
|
||||
, fromTryGetDefinitionNameSpace
|
||||
, plugin
|
||||
, toTryGetDefinitionNameSpace
|
||||
) where
|
||||
|
||||
import Control.Lens ((^.))
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
|
||||
import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE, except)
|
||||
import DA.Daml.Compiler.Dar (getDamlFiles)
|
||||
import DA.Daml.Package.Config (PackageConfigFields (pSrc), parseProjectConfig)
|
||||
import DA.Daml.Project.Config (readProjectConfig)
|
||||
import DA.Daml.Project.Types (ProjectPath (..))
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.Aeson.TH
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
import Data.Bifunctor (first)
|
||||
import Data.List (find, isSuffixOf, sortOn)
|
||||
import Data.Maybe (listToMaybe)
|
||||
import qualified Data.Text as T
|
||||
import Development.IDE.Core.Rules.Daml
|
||||
import Development.IDE.Core.RuleTypes
|
||||
import Development.IDE.Core.Service.Daml
|
||||
import Development.IDE.Core.Shake (IdeRule, use)
|
||||
import Development.IDE.GHC.Error (srcSpanToLocation)
|
||||
import Development.IDE.Plugin
|
||||
import Development.IDE.Spans.Type (getNameM, spaninfoSource, spansExprs)
|
||||
import Development.IDE.Types.Location
|
||||
import Development.Shake (Action)
|
||||
import qualified Language.LSP.Server as LSP
|
||||
import Language.LSP.Types
|
||||
import qualified Language.LSP.Types as LSP
|
||||
import qualified Language.LSP.Types.Lens as LSP
|
||||
import qualified Language.LSP.Types.Utils as LSP
|
||||
import System.FilePath ((</>))
|
||||
import "ghc-lib" GhcPlugins (
|
||||
Module,
|
||||
isGoodSrcSpan,
|
||||
moduleName,
|
||||
moduleNameString,
|
||||
moduleUnitId,
|
||||
occNameString,
|
||||
unitIdString,
|
||||
)
|
||||
import "ghc-lib-parser" Name (
|
||||
Name,
|
||||
NameSpace,
|
||||
dataName,
|
||||
isDataConNameSpace,
|
||||
isExternalName,
|
||||
isTcClsNameSpace,
|
||||
isTvNameSpace,
|
||||
mkOccName,
|
||||
nameModule_maybe,
|
||||
nameOccName,
|
||||
nameSrcSpan,
|
||||
occNameSpace,
|
||||
tcClsName,
|
||||
tvName,
|
||||
varName,
|
||||
)
|
||||
|
||||
data TryGetDefinitionParams = TryGetDefinitionParams
|
||||
{ tgdpTextDocument :: TextDocumentIdentifier
|
||||
, tgdpPosition :: Position
|
||||
}
|
||||
deriving Show
|
||||
deriveJSON LSP.lspOptions ''TryGetDefinitionParams
|
||||
|
||||
data TryGetDefinitionNameSpace
|
||||
= VariableName
|
||||
| DataName
|
||||
| TypeVariableName
|
||||
| TypeCnstrOrClassName
|
||||
deriving Show
|
||||
deriveJSON LSP.lspOptions ''TryGetDefinitionNameSpace
|
||||
|
||||
fromTryGetDefinitionNameSpace :: TryGetDefinitionNameSpace -> NameSpace
|
||||
fromTryGetDefinitionNameSpace = \case
|
||||
VariableName -> varName
|
||||
DataName -> dataName
|
||||
TypeVariableName -> tvName
|
||||
TypeCnstrOrClassName -> tcClsName
|
||||
|
||||
toTryGetDefinitionNameSpace :: NameSpace -> TryGetDefinitionNameSpace
|
||||
toTryGetDefinitionNameSpace ns = if
|
||||
| isDataConNameSpace ns -> DataName
|
||||
| isTcClsNameSpace ns -> TypeCnstrOrClassName
|
||||
| isTvNameSpace ns -> TypeVariableName
|
||||
| otherwise -> VariableName
|
||||
|
||||
data TryGetDefinitionName = TryGetDefinitionName
|
||||
{ tgdnModuleName :: String
|
||||
, tgdnPackageUnitId :: String
|
||||
, tgdnIdentifierName :: String
|
||||
, tgdnIdentifierNameSpace :: TryGetDefinitionNameSpace
|
||||
}
|
||||
deriving Show
|
||||
deriveJSON LSP.lspOptions ''TryGetDefinitionName
|
||||
|
||||
data TryGetDefinitionResult = TryGetDefinitionResult
|
||||
{ tgdrLocation :: Location
|
||||
, tgdrName :: Maybe TryGetDefinitionName
|
||||
}
|
||||
deriving Show
|
||||
deriveJSON LSP.lspOptions ''TryGetDefinitionResult
|
||||
|
||||
data GotoDefinitionByNameParams = GotoDefinitionByNameParams
|
||||
{ gdnpBackupLocation :: Location
|
||||
, gdnpName :: TryGetDefinitionName
|
||||
}
|
||||
deriving Show
|
||||
deriveJSON LSP.lspOptions ''GotoDefinitionByNameParams
|
||||
|
||||
type GotoDefinitionByNameResult = Location
|
||||
|
||||
{-
|
||||
2 methods:
|
||||
tryGotoDefinition :: position -> location + Maybe (name + package)
|
||||
-- locationsAtPoint but if its an unhelpful name, we provide that too
|
||||
gotoDefinitionByName :: name -> location
|
||||
-- try to lookup the name (by its module) in own modules, give back the source
|
||||
|
||||
|
||||
flow
|
||||
call tryGotoDefinition on package of given location
|
||||
if no (name + package), or we don't have an ide/source for that package, return the location immediately
|
||||
else
|
||||
call gotoDefinitionByName on returned package
|
||||
-}
|
||||
|
||||
plugin :: Plugin c
|
||||
plugin = Plugin
|
||||
{ pluginCommands = mempty
|
||||
, pluginRules = mempty
|
||||
, pluginHandlers =
|
||||
customMethodHandler "tryGetDefinition" tryGetDefinition
|
||||
<> customMethodHandler "gotoDefinitionByName" gotoDefinitionByName
|
||||
, pluginNotificationHandlers = mempty
|
||||
}
|
||||
|
||||
customMethodHandler
|
||||
:: forall req res c
|
||||
. (Aeson.FromJSON req, Aeson.ToJSON res)
|
||||
=> T.Text
|
||||
-> (IdeState -> req -> LSP.LspM c (Either LSP.ResponseError res))
|
||||
-> PluginHandlers c
|
||||
customMethodHandler name f = pluginHandler (SCustomMethod $ "daml/" <> name) $ \ideState value ->
|
||||
let (!params :: req) =
|
||||
either
|
||||
(\err -> error $ "Failed to parse message of daml/" <> T.unpack name <> ": " <> err) id
|
||||
$ Aeson.parseEither Aeson.parseJSON value
|
||||
in fmap Aeson.toJSON <$> f ideState params
|
||||
|
||||
nameSortExternalModule :: Name -> Maybe Module
|
||||
nameSortExternalModule m | isExternalName m = nameModule_maybe m
|
||||
nameSortExternalModule _ = Nothing
|
||||
|
||||
-- daml/tryGetDefinition :: TryGetDefinitionParams -> Maybe TryGetDefinitionResult
|
||||
tryGetDefinition :: IdeState -> TryGetDefinitionParams -> LSP.LspM c (Either ResponseError (Maybe TryGetDefinitionResult))
|
||||
tryGetDefinition ideState params = Right <$>
|
||||
case uriToFilePath' $ tgdpTextDocument params ^. LSP.uri of
|
||||
Nothing -> pure Nothing
|
||||
Just (toNormalizedFilePath' -> file) ->
|
||||
liftIO $ runActionSync ideState $ runMaybeT $ do
|
||||
(loc, mName) <- MaybeT $ getDefinitionWithName file $ tgdpPosition params
|
||||
let tgdName = do
|
||||
name <- mName
|
||||
m <- nameSortExternalModule name
|
||||
pure $ TryGetDefinitionName
|
||||
(moduleNameString $ moduleName m)
|
||||
(unitIdString $ moduleUnitId m)
|
||||
(occNameString $ nameOccName name)
|
||||
(toTryGetDefinitionNameSpace $ occNameSpace $ nameOccName name)
|
||||
pure $ TryGetDefinitionResult loc tgdName
|
||||
|
||||
replaceChar :: Char -> Char -> String -> String
|
||||
replaceChar val replacement = fmap (\c -> if c == val then replacement else c)
|
||||
|
||||
-- daml/gotoDefinitionByName :: GotoDefinitionByNameParams -> GotoDefinitionByNameResult
|
||||
gotoDefinitionByName :: IdeState -> GotoDefinitionByNameParams -> LSP.LspM c (Either ResponseError GotoDefinitionByNameResult)
|
||||
gotoDefinitionByName ideState params = do
|
||||
mRoot <- LSP.getRootPath
|
||||
liftIO $ runActionSync ideState $ exceptTToResult $ do
|
||||
-- Working out the file by getting the IDE root and pSrc from daml.yaml, getting all the source files for it, then searching for our module
|
||||
-- We search rather than explicitly building the path to account for pSrc being a daml file, whereby file discovery logic is via dependencies
|
||||
-- I tried to do this better, by looking up the module name in IDE state, but it seems the IDE doesn't load
|
||||
-- modules until you open the file, so it doesn't hold any context about "all" modules.
|
||||
-- (trust me I tried so hard to make this work)
|
||||
root <- hoistMaybe (Just "Failed to get IDE root") mRoot
|
||||
projectConfig <- liftIO $ readProjectConfig (ProjectPath root)
|
||||
config <- except $ first (Just . show) $ parseProjectConfig projectConfig
|
||||
|
||||
srcFiles <- maybeTToExceptT "Failed to get source files" $ getDamlFiles $ root </> pSrc config
|
||||
-- Must be sorted shorted to longest, since we always want the shortest path that matches our suffix
|
||||
-- to avoid accidentally picking Main.A.B.C if we're just looking for A.B.C
|
||||
-- We also prefix all paths with "/" and search for our suffix starting with "/"
|
||||
-- This is avoid incorrectly picking MA.B.C if we were looking for A.B.C and it didnt exist
|
||||
let sortedSrcFiles = sortOn (Prelude.length . fromNormalizedFilePath) srcFiles
|
||||
moduleSuffix = "/" <> replaceChar '.' '/' (tgdnModuleName $ gdnpName params) <> ".daml"
|
||||
file <-
|
||||
hoistMaybe (Just "Failed to find module") $
|
||||
find (isSuffixOf moduleSuffix . ("/" <> ) . fromNormalizedFilePath) sortedSrcFiles
|
||||
|
||||
-- It might be better to get the typechecked module and look for the identifier in there?
|
||||
spans <- useOrThrow "Failed to get span info" GetSpanInfo file
|
||||
let expectedOccName = mkOccName (fromTryGetDefinitionNameSpace $ tgdnIdentifierNameSpace $ gdnpName params) (tgdnIdentifierName $ gdnpName params)
|
||||
locations =
|
||||
[ srcSpanToLocation $ nameSrcSpan name
|
||||
| Just name <- getNameM . spaninfoSource <$> spansExprs spans
|
||||
, expectedOccName == nameOccName name && isGoodSrcSpan (nameSrcSpan name)
|
||||
]
|
||||
|
||||
hoistMaybe Nothing $ listToMaybe locations
|
||||
where
|
||||
-- A Nothing error means no location, a string error means a response error
|
||||
exceptTToResult :: ExceptT (Maybe String) Action GotoDefinitionByNameResult -> Action (Either ResponseError GotoDefinitionByNameResult)
|
||||
exceptTToResult t = fmap (either (maybe (Right $ gdnpBackupLocation params) (\msg -> Left $ ResponseError ParseError (T.pack msg) Nothing)) Right) $ runExceptT t
|
||||
useOrThrow :: IdeRule k v => String -> k -> NormalizedFilePath -> ExceptT (Maybe String) Action v
|
||||
useOrThrow msg k path = ExceptT $ maybe (Left $ Just msg) Right <$> use k path
|
||||
hoistMaybe :: Monad m => x -> Maybe a -> ExceptT x m a
|
||||
hoistMaybe err = maybe (throwE err) pure
|
||||
maybeTToExceptT :: String -> MaybeT Action a -> ExceptT (Maybe String) Action a
|
||||
maybeTToExceptT err m = ExceptT $ maybe (Left $ Just err) Right <$> runMaybeT m
|
||||
@ -136,6 +136,7 @@ getDamlGhcSession = do
|
||||
-- | Find the daml.yaml given a starting file or directory.
|
||||
findProjectRoot :: FilePath -> IO (Maybe FilePath)
|
||||
findProjectRoot file = do
|
||||
-- TODO[SW]: This logic appears to be wrong, doesFileExist (takeDirectory file) will always be false for wellformed paths.
|
||||
isFile <- doesFileExist (takeDirectory file)
|
||||
let dir = if isFile then takeDirectory file else file
|
||||
findM hasProjectConfig (ascendants dir)
|
||||
|
||||
@ -3,10 +3,10 @@
|
||||
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
-- | Main entry-point of the Daml compiler
|
||||
module DA.Cli.Damlc (main, Command (..), fullParseArgs) where
|
||||
@ -14,7 +14,8 @@ module DA.Cli.Damlc (main, Command (..), fullParseArgs) where
|
||||
import qualified "zip-archive" Codec.Archive.Zip as ZipArchive
|
||||
import Control.Exception (bracket, catch, displayException, handle, throwIO, throw)
|
||||
import Control.Exception.Safe (catchIO)
|
||||
import Control.Monad.Except (forM, forM_, liftIO, unless, void, when)
|
||||
import Control.Monad (forM, forM_, unless, void, when)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Extra (allM, mapMaybeM, whenM, whenJust)
|
||||
import Control.Monad.Trans.Cont (ContT (..), evalContT)
|
||||
import DA.Bazel.Runfiles (setRunfilesEnv)
|
||||
@ -56,6 +57,7 @@ import DA.Cli.Options (Debug(..),
|
||||
targetFileNameOpt,
|
||||
telemetryOpt)
|
||||
import DA.Cli.Damlc.BuildInfo (buildInfo)
|
||||
import DA.Cli.Damlc.Command.MultiIde (runMultiIde)
|
||||
import qualified DA.Daml.Dar.Reader as InspectDar
|
||||
import qualified DA.Cli.Damlc.Command.Damldoc as Damldoc
|
||||
import DA.Cli.Damlc.Packaging (createProjectPackageDb, mbErr)
|
||||
@ -294,9 +296,19 @@ data CommandName =
|
||||
| MergeDars
|
||||
| Package
|
||||
| Test
|
||||
| MultiIde
|
||||
deriving (Ord, Show, Eq)
|
||||
data Command = Command CommandName (Maybe ProjectOpts) (IO ())
|
||||
|
||||
cmdMultiIde :: Int -> Mod CommandFields Command
|
||||
cmdMultiIde _numProcessors =
|
||||
command "multi-ide" $ info (helper <*> cmd) $
|
||||
progDesc
|
||||
"Start the Daml language server on standard input/output."
|
||||
<> fullDesc
|
||||
where
|
||||
cmd = pure $ Command MultiIde Nothing runMultiIde
|
||||
|
||||
cmdIde :: SdkVersion.Class.SdkVersioned => Int -> Mod CommandFields Command
|
||||
cmdIde numProcessors =
|
||||
command "ide" $ info (helper <*> cmd) $
|
||||
@ -853,7 +865,6 @@ execBuild projectOpts opts mbOutFile incrementalBuild initPkgDb enableMultiPacka
|
||||
withMultiPackageConfig multiPackageConfigPath $ \multiPackageConfig ->
|
||||
multiPackageBuildEffect relativize mPkgConfig multiPackageConfig projectOpts opts mbOutFile incrementalBuild initPkgDb noCache
|
||||
|
||||
-- TODO: This throws if you have the sdk-version only daml.yaml, ideally it should return Nothing
|
||||
mPkgConfig <- ContT $ withMaybeConfig $ withPackageConfig defaultProjectPath
|
||||
liftIO $ if getEnableMultiPackage enableMultiPackage then do
|
||||
mMultiPackagePath <- getMultiPackagePath multiPackageLocation
|
||||
@ -1471,6 +1482,7 @@ options :: SdkVersion.Class.SdkVersioned => Int -> Parser Command
|
||||
options numProcessors =
|
||||
subparser
|
||||
( cmdIde numProcessors
|
||||
<> cmdMultiIde numProcessors
|
||||
<> cmdLicense
|
||||
-- cmdPackage can go away once we kill the old assistant.
|
||||
<> cmdPackage numProcessors
|
||||
@ -1657,6 +1669,7 @@ cmdUseDamlYamlArgs = \case
|
||||
MergeDars -> False -- just reads the dars
|
||||
Package -> False -- deprecated
|
||||
Test -> True
|
||||
MultiIde -> False
|
||||
|
||||
withProjectRoot' :: ProjectOpts -> ((FilePath -> IO FilePath) -> IO a) -> IO a
|
||||
withProjectRoot' ProjectOpts{..} act =
|
||||
|
||||
501
sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde.hs
Normal file
501
sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde.hs
Normal file
@ -0,0 +1,501 @@
|
||||
-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE DisambiguateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
|
||||
module DA.Cli.Damlc.Command.MultiIde (runMultiIde) where
|
||||
|
||||
import Control.Concurrent.Async (async, cancel, pollSTM)
|
||||
import Control.Concurrent.STM.TChan
|
||||
import Control.Concurrent.STM.TMVar
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Exception(AsyncException, handle, throwIO)
|
||||
import Control.Lens
|
||||
import Control.Monad
|
||||
import Control.Monad.STM
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
import qualified Data.ByteString as B
|
||||
import DA.Cli.Damlc.Command.MultiIde.Forwarding
|
||||
import DA.Cli.Damlc.Command.MultiIde.Prefixing
|
||||
import DA.Cli.Damlc.Command.MultiIde.Util
|
||||
import DA.Cli.Damlc.Command.MultiIde.Parsing
|
||||
import DA.Cli.Damlc.Command.MultiIde.Types
|
||||
import DA.Daml.LanguageServer.SplitGotoDefinition
|
||||
import DA.Daml.Package.Config (MultiPackageConfigFields(..), findMultiPackageConfig, withMultiPackageConfig)
|
||||
import DA.Daml.Project.Types (ProjectPath (..))
|
||||
import Data.Either (lefts)
|
||||
import Data.Functor.Product
|
||||
import Data.List (find, isPrefixOf)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe (catMaybes, fromMaybe)
|
||||
import qualified Data.Text as T
|
||||
import GHC.Conc (unsafeIOToSTM)
|
||||
import qualified Language.LSP.Types as LSP
|
||||
import qualified Language.LSP.Types.Lens as LSP
|
||||
import System.Environment (getEnv)
|
||||
import System.IO.Extra
|
||||
import System.Process (getPid)
|
||||
import System.Process.Typed (
|
||||
Process,
|
||||
createPipe,
|
||||
getExitCodeSTM,
|
||||
getStdin,
|
||||
getStdout,
|
||||
nullStream,
|
||||
proc,
|
||||
setStderr,
|
||||
setStdin,
|
||||
setStdout,
|
||||
setWorkingDir,
|
||||
startProcess,
|
||||
unsafeProcessHandle,
|
||||
)
|
||||
|
||||
-- Spin-up logic
|
||||
|
||||
-- add IDE, send initialize, do not send further messages until we get the initialize response and have sent initialized
|
||||
-- we can do this by locking the sending thread, but still allowing the channel to be pushed
|
||||
-- we also atomically send a message to the channel, without dropping the lock on the subIDEs var
|
||||
addNewSubIDEAndSend
|
||||
:: MultiIdeState
|
||||
-> FilePath
|
||||
-> LSP.FromClientMessage
|
||||
-> IO SubIDE
|
||||
addNewSubIDEAndSend miState home msg = do
|
||||
debugPrint "Trying to make a SubIDE"
|
||||
ides <- atomically $ takeTMVar $ subIDEsVar miState
|
||||
|
||||
let mExistingIde = Map.lookup home $ onlyActiveSubIdes ides
|
||||
case mExistingIde of
|
||||
Just ide -> do
|
||||
debugPrint "SubIDE already exists"
|
||||
unsafeSendSubIDE ide msg
|
||||
atomically $ putTMVar (subIDEsVar miState) ides
|
||||
pure ide
|
||||
Nothing -> do
|
||||
debugPrint "Making a SubIDE"
|
||||
|
||||
unitId <- either (\cErr -> error $ "Failed to get unit ID from daml.yaml: " <> show cErr) id <$> unitIdFromDamlYaml home
|
||||
|
||||
subIdeProcess <- runSubProc home
|
||||
let inHandle = getStdin subIdeProcess
|
||||
outHandle = getStdout subIdeProcess
|
||||
|
||||
-- Handles blocking the sender thread until the IDE is initialized.
|
||||
sendBlocker <- newEmptyMVar @()
|
||||
let unblock = putMVar sendBlocker ()
|
||||
onceUnblocked = (readMVar sendBlocker >>)
|
||||
|
||||
-- ***** -> SubIDE
|
||||
toSubIDEChan <- atomically newTChan
|
||||
toSubIDE <- async $ onceUnblocked $ forever $ do
|
||||
msg <- atomically $ readTChan toSubIDEChan
|
||||
debugPrint "Pushing message to subIDE"
|
||||
putChunk inHandle msg
|
||||
|
||||
-- Coord <- SubIDE
|
||||
subIDEToCoord <- async $ do
|
||||
-- Wait until our own IDE exists then pass it forward
|
||||
ide <- atomically $ fromMaybe (error "Failed to get own IDE") . Map.lookup home . onlyActiveSubIdes <$> readTMVar (subIDEsVar miState)
|
||||
chunks <- getChunks outHandle
|
||||
mapM_ (subIDEMessageHandler miState unblock ide) chunks
|
||||
|
||||
pid <- fromMaybe (error "SubIDE has no PID") <$> getPid (unsafeProcessHandle subIdeProcess)
|
||||
|
||||
mInitParams <- tryReadMVar (initParamsVar miState)
|
||||
let !initParams = fromMaybe (error "Attempted to create a SubIDE before initialization!") mInitParams
|
||||
initId = LSP.IdString $ T.pack $ show pid
|
||||
(initMsg :: LSP.FromClientMessage) = LSP.FromClientMess LSP.SInitialize LSP.RequestMessage
|
||||
{ _id = initId
|
||||
, _method = LSP.SInitialize
|
||||
, _params = initParams
|
||||
{ LSP._rootPath = Just $ T.pack home
|
||||
, LSP._rootUri = Just $ LSP.filePathToUri home
|
||||
}
|
||||
, _jsonrpc = "2.0"
|
||||
}
|
||||
ide =
|
||||
SubIDE
|
||||
{ ideInhandleAsync = toSubIDE
|
||||
, ideInHandle = inHandle
|
||||
, ideInHandleChannel = toSubIDEChan
|
||||
, ideOutHandleAsync = subIDEToCoord
|
||||
, ideProcess = subIdeProcess
|
||||
, ideHomeDirectory = home
|
||||
, ideMessageIdPrefix = T.pack $ show pid
|
||||
, ideActive = True
|
||||
, ideUnitId = unitId
|
||||
}
|
||||
|
||||
|
||||
putReqMethodSingleFromClient (fromClientMethodTrackerVar miState) initId LSP.SInitialize
|
||||
putChunk inHandle $ Aeson.encode initMsg
|
||||
-- Dangerous call is okay here because we're already holding the subIDEsVar lock
|
||||
unsafeSendSubIDE ide msg
|
||||
|
||||
atomically $ putTMVar (subIDEsVar miState) $ Map.insert home ide ides
|
||||
|
||||
pure ide
|
||||
|
||||
runSubProc :: FilePath -> IO (Process Handle Handle ())
|
||||
runSubProc home = do
|
||||
assistantPath <- getEnv "DAML_ASSISTANT"
|
||||
|
||||
startProcess $
|
||||
proc assistantPath ["ide"] &
|
||||
setStdin createPipe &
|
||||
setStdout createPipe &
|
||||
-- setStderr (useHandleOpen stderr) &
|
||||
setStderr nullStream &
|
||||
setWorkingDir home
|
||||
|
||||
-- Spin-down logic
|
||||
|
||||
-- Sends a shutdown message and sets active to false, disallowing any further messages to be sent to the subIDE
|
||||
-- given queue nature of TChan, all other pending messages will be sent first before handling shutdown
|
||||
shutdownIde :: MultiIdeState -> SubIDE -> IO ()
|
||||
shutdownIde miState ide = do
|
||||
ides <- atomically $ takeTMVar (subIDEsVar miState)
|
||||
let shutdownId = LSP.IdString $ ideMessageIdPrefix ide <> "-shutdown"
|
||||
(shutdownMsg :: LSP.FromClientMessage) = LSP.FromClientMess LSP.SShutdown LSP.RequestMessage
|
||||
{ _id = shutdownId
|
||||
, _method = LSP.SShutdown
|
||||
, _params = LSP.Empty
|
||||
, _jsonrpc = "2.0"
|
||||
}
|
||||
|
||||
putReqMethodSingleFromClient (fromClientMethodTrackerVar miState) shutdownId LSP.SShutdown
|
||||
unsafeSendSubIDE ide shutdownMsg
|
||||
|
||||
atomically $ putTMVar (subIDEsVar miState) $ Map.adjust (\ide' -> ide' {ideActive = False}) (ideHomeDirectory ide) ides
|
||||
|
||||
-- To be called once we receive the Shutdown response
|
||||
-- Safe to assume that the sending channel is empty, so we can end the thread and send the final notification directly on the handle
|
||||
handleExit :: MultiIdeState -> SubIDE -> IO ()
|
||||
handleExit miState ide = do
|
||||
let (exitMsg :: LSP.FromClientMessage) = LSP.FromClientMess LSP.SExit LSP.NotificationMessage
|
||||
{ _method = LSP.SExit
|
||||
, _params = LSP.Empty
|
||||
, _jsonrpc = "2.0"
|
||||
}
|
||||
-- This will cause the subIDE process to exit
|
||||
putChunk (ideInHandle ide) $ Aeson.encode exitMsg
|
||||
atomically $ modifyTMVar (subIDEsVar miState) $ Map.delete (ideHomeDirectory ide)
|
||||
cancel $ ideInhandleAsync ide
|
||||
cancel $ ideOutHandleAsync ide
|
||||
|
||||
-- Communication logic
|
||||
|
||||
-- Dangerous as does not hold the subIDEsVar lock. If a shutdown is called whiled this is running, the message may not be sent.
|
||||
unsafeSendSubIDE :: SubIDE -> LSP.FromClientMessage -> IO ()
|
||||
unsafeSendSubIDE ide = atomically . writeTChan (ideInHandleChannel ide) . Aeson.encode
|
||||
|
||||
sendClient :: MultiIdeState -> LSP.FromServerMessage -> IO ()
|
||||
sendClient miState = atomically . writeTChan (toClientChan miState) . Aeson.encode
|
||||
|
||||
sendAllSubIDEs :: MultiIdeState -> LSP.FromClientMessage -> IO [FilePath]
|
||||
sendAllSubIDEs miState msg = atomically $ do
|
||||
idesUnfiltered <- takeTMVar (subIDEsVar miState)
|
||||
let ides = onlyActiveSubIdes idesUnfiltered
|
||||
when (null ides) $ error "Got a broadcast to nothing :("
|
||||
homes <- forM (Map.elems ides) $ \ide -> ideHomeDirectory ide <$ writeTChan (ideInHandleChannel ide) (Aeson.encode msg)
|
||||
putTMVar (subIDEsVar miState) idesUnfiltered
|
||||
pure homes
|
||||
|
||||
sendAllSubIDEs_ :: MultiIdeState -> LSP.FromClientMessage -> IO ()
|
||||
sendAllSubIDEs_ miState = void . sendAllSubIDEs miState
|
||||
|
||||
sendSubIDEByPath :: MultiIdeState -> FilePath -> LSP.FromClientMessage -> IO ()
|
||||
sendSubIDEByPath miState path msg = do
|
||||
mHome <- sendSubIDEByPath_ path msg
|
||||
-- Lock is dropped then regained here for new IDE. This is acceptable as it's impossible for a shutdown
|
||||
-- of the new ide to be sent before its created.
|
||||
-- Note that if sendSubIDEByPath is called multiple times concurrently for a new IDE, addNewSubIDEAndSend may be called twice for the same home
|
||||
-- addNewSubIDEAndSend handles this internally with its own checks, so this is acceptable.
|
||||
forM_ mHome $ \home -> addNewSubIDEAndSend miState home msg
|
||||
where
|
||||
-- If a SubIDE is needed, returns the path out of the STM transaction
|
||||
sendSubIDEByPath_ :: FilePath -> LSP.FromClientMessage -> IO (Maybe FilePath)
|
||||
sendSubIDEByPath_ path msg = atomically $ do
|
||||
idesUnfiltered <- takeTMVar (subIDEsVar miState)
|
||||
let ides = onlyActiveSubIdes idesUnfiltered
|
||||
-- Map.keys gives keys in ascending order, so first match will be the shortest.
|
||||
-- No possibility to accidentally pick a nested package.
|
||||
mHome = find (`isPrefixOf` path) $ Map.keys ides
|
||||
mIde = mHome >>= flip Map.lookup ides
|
||||
|
||||
case mIde of
|
||||
Just ide -> do
|
||||
writeTChan (ideInHandleChannel ide) (Aeson.encode msg)
|
||||
unsafeIOToSTM $ debugPrint $ "Found relevant SubIDE: " <> ideHomeDirectory ide
|
||||
putTMVar (subIDEsVar miState) idesUnfiltered
|
||||
pure Nothing
|
||||
Nothing -> do
|
||||
putTMVar (subIDEsVar miState) idesUnfiltered
|
||||
-- Safe as findHome only does reads
|
||||
mHome <- unsafeIOToSTM $ findHome path
|
||||
case mHome of
|
||||
-- Returned out of the transaction to be handled in IO
|
||||
Just home -> pure $ Just home
|
||||
Nothing -> do
|
||||
-- We get here if we cannot find a daml.yaml file for a file mentioned in a request
|
||||
-- if we're sending a response, ignore it, as this means the server that sent the request has been killed already.
|
||||
-- if we're sending a request, respond to the client with an error.
|
||||
-- if we're sending a notification, ignore it - theres nothing the protocol allows us to do to signify notification failures.
|
||||
let replyError :: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request). LSP.SMethod m -> LSP.LspId m -> STM ()
|
||||
replyError method id =
|
||||
writeTChan (toClientChan miState) $ Aeson.encode $
|
||||
LSP.FromServerRsp method $ LSP.ResponseMessage "2.0" (Just id) $ Left $
|
||||
LSP.ResponseError LSP.InvalidParams ("Could not find daml.yaml for package containing " <> T.pack path) Nothing
|
||||
case msg of
|
||||
LSP.FromClientMess method params ->
|
||||
case (LSP.splitClientMethod method, params) of
|
||||
(LSP.IsClientReq, LSP.RequestMessage {_id}) -> Nothing <$ replyError method _id
|
||||
(LSP.IsClientEither, LSP.ReqMess (LSP.RequestMessage {_id})) -> Nothing <$ replyError method _id
|
||||
_ -> pure Nothing
|
||||
_ -> pure Nothing
|
||||
|
||||
parseCustomResult :: Aeson.FromJSON a => String -> Either LSP.ResponseError Aeson.Value -> Either LSP.ResponseError a
|
||||
parseCustomResult name =
|
||||
fmap $ either (\err -> error $ "Failed to parse response of " <> name <> ": " <> err) id
|
||||
. Aeson.parseEither Aeson.parseJSON
|
||||
|
||||
-- Handlers
|
||||
|
||||
subIDEMessageHandler :: MultiIdeState -> IO () -> SubIDE -> B.ByteString -> IO ()
|
||||
subIDEMessageHandler miState unblock ide bs = do
|
||||
debugPrint "Called subIDEMessageHandler"
|
||||
|
||||
-- Decode a value, parse
|
||||
let val :: Aeson.Value
|
||||
val = er "eitherDecode" $ Aeson.eitherDecodeStrict bs
|
||||
mMsg <- either error id <$> parseServerMessageWithTracker (fromClientMethodTrackerVar miState) (ideHomeDirectory ide) val
|
||||
|
||||
-- Adds the various prefixes needed for from server messages to not clash with those from other IDEs
|
||||
mPrefixedMsg <-
|
||||
mapM
|
||||
( addProgressTokenPrefixToServerMessage (progessTokenPrefixesVar miState) (ideHomeDirectory ide) (ideMessageIdPrefix ide)
|
||||
. addLspPrefixToServerMessage ide
|
||||
)
|
||||
mMsg
|
||||
|
||||
forM_ mPrefixedMsg $ \msg -> do
|
||||
-- If its a request (builtin or custom), save it for response handling.
|
||||
putServerReq (fromServerMethodTrackerVar miState) (ideHomeDirectory ide) msg
|
||||
|
||||
debugPrint "Message successfully parsed and prefixed."
|
||||
case msg of
|
||||
LSP.FromServerRsp LSP.SInitialize LSP.ResponseMessage {_result} -> do
|
||||
debugPrint "Got initialization reply, sending initialized and unblocking"
|
||||
-- Dangerous call here is acceptable as this only happens while the ide is booting, before unblocking
|
||||
unsafeSendSubIDE ide $ LSP.FromClientMess LSP.SInitialized $ LSP.NotificationMessage "2.0" LSP.SInitialized (Just LSP.InitializedParams)
|
||||
unblock
|
||||
LSP.FromServerRsp LSP.SShutdown _ -> handleExit miState ide
|
||||
|
||||
-- See STextDocumentDefinition in client handle for description of this path
|
||||
LSP.FromServerRsp (LSP.SCustomMethod "daml/tryGetDefinition") LSP.ResponseMessage {_id, _result} -> do
|
||||
debugPrint "Got tryGetDefinition response, handling..."
|
||||
let parsedResult = parseCustomResult @(Maybe TryGetDefinitionResult) "daml/tryGetDefinition" _result
|
||||
reply :: Either LSP.ResponseError (LSP.ResponseResult 'LSP.TextDocumentDefinition) -> IO ()
|
||||
reply rsp = do
|
||||
debugPrint $ "Replying directly to client with " <> show rsp
|
||||
sendClient miState $ LSP.FromServerRsp LSP.STextDocumentDefinition $ LSP.ResponseMessage "2.0" (castLspId <$> _id) rsp
|
||||
replyLocations :: [LSP.Location] -> IO ()
|
||||
replyLocations = reply . Right . LSP.InR . LSP.InL . LSP.List
|
||||
case parsedResult of
|
||||
-- Request failed, forwrd error
|
||||
Left err -> reply $ Left err
|
||||
-- Request didn't find any location information, forward "nothing"
|
||||
Right Nothing -> replyLocations []
|
||||
-- SubIDE containing the reference also contained the definition, so returned no name to lookup
|
||||
-- Simply forward this location
|
||||
Right (Just (TryGetDefinitionResult loc Nothing)) -> replyLocations [loc]
|
||||
-- SubIDE containing the reference did not contain the definition, it returns a fake location in .daml and the name
|
||||
-- Send a new request to a new SubIDE to find the source of this name
|
||||
Right (Just (TryGetDefinitionResult loc (Just name))) -> do
|
||||
debugPrint $ "Got name in result! Backup location is " <> show loc
|
||||
let mHome = Map.lookup (tgdnPackageUnitId name) $ multiPackageMapping miState
|
||||
case mHome of
|
||||
-- Didn't find a home for this name, we do not know where this is defined, so give back the (known to be wrong)
|
||||
-- .daml data-dependency path
|
||||
-- This is the worst case, we'll later add logic here to unpack and spinup an SubIDE for the read-only dependency
|
||||
Nothing -> replyLocations [loc]
|
||||
-- We found a daml.yaml for this definition, send the getDefinitionByName request to its SubIDE
|
||||
Just home -> do
|
||||
debugPrint $ "Found unit ID in multi-package mapping, forwarding to " <> home
|
||||
let method = LSP.SCustomMethod "daml/gotoDefinitionByName"
|
||||
lspId = maybe (error "No LspId provided back from tryGetDefinition") castLspId _id
|
||||
putReqMethodSingleFromClient (fromClientMethodTrackerVar miState) lspId method
|
||||
sendSubIDEByPath miState home $ LSP.FromClientMess method $ LSP.ReqMess $
|
||||
LSP.RequestMessage "2.0" lspId method $ Aeson.toJSON $
|
||||
GotoDefinitionByNameParams loc name
|
||||
|
||||
-- See STextDocumentDefinition in client handle for description of this path
|
||||
LSP.FromServerRsp (LSP.SCustomMethod "daml/gotoDefinitionByName") LSP.ResponseMessage {_id, _result} -> do
|
||||
debugPrint "Got gotoDefinitionByName response, handling..."
|
||||
let parsedResult = parseCustomResult @GotoDefinitionByNameResult "daml/gotoDefinitionByName" _result
|
||||
reply :: Either LSP.ResponseError (LSP.ResponseResult 'LSP.TextDocumentDefinition) -> IO ()
|
||||
reply rsp = do
|
||||
debugPrint $ "Replying directly to client with " <> show rsp
|
||||
sendClient miState $ LSP.FromServerRsp LSP.STextDocumentDefinition $ LSP.ResponseMessage "2.0" (castLspId <$> _id) rsp
|
||||
case parsedResult of
|
||||
Left err -> reply $ Left err
|
||||
Right loc -> reply $ Right $ LSP.InR $ LSP.InL $ LSP.List [loc]
|
||||
|
||||
LSP.FromServerMess method _ -> do
|
||||
debugPrint $ "Backwarding request " <> show method
|
||||
sendClient miState msg
|
||||
LSP.FromServerRsp method _ -> do
|
||||
debugPrint $ "Backwarding response to " <> show method
|
||||
sendClient miState msg
|
||||
|
||||
clientMessageHandler :: MultiIdeState -> B.ByteString -> IO ()
|
||||
clientMessageHandler miState bs = do
|
||||
debugPrint "Called clientMessageHandler"
|
||||
|
||||
-- Decode a value, parse
|
||||
let castFromClientMessage :: LSP.FromClientMessage' (Product LSP.SMethod (Const FilePath)) -> LSP.FromClientMessage
|
||||
castFromClientMessage = \case
|
||||
LSP.FromClientMess method params -> LSP.FromClientMess method params
|
||||
LSP.FromClientRsp (Pair method _) params -> LSP.FromClientRsp method params
|
||||
|
||||
val :: Aeson.Value
|
||||
val = er "eitherDecode" $ Aeson.eitherDecodeStrict bs
|
||||
|
||||
unPrefixedMsg <- either error id <$> parseClientMessageWithTracker (fromServerMethodTrackerVar miState) val
|
||||
msg <- addProgressTokenPrefixToClientMessage (progessTokenPrefixesVar miState) unPrefixedMsg
|
||||
|
||||
case msg of
|
||||
-- Store the initialize params for starting subIDEs, respond statically with what ghc-ide usually sends.
|
||||
LSP.FromClientMess LSP.SInitialize LSP.RequestMessage {_id, _method, _params} -> do
|
||||
putMVar (initParamsVar miState) _params
|
||||
sendClient miState $ LSP.FromServerRsp _method $ LSP.ResponseMessage "2.0" (Just _id) (Right initializeResult)
|
||||
LSP.FromClientMess LSP.SWindowWorkDoneProgressCancel notif -> do
|
||||
(newNotif, mHome) <- removeWorkDoneProgressCancelTokenPrefix (progessTokenPrefixesVar miState) notif
|
||||
let newMsg = LSP.FromClientMess LSP.SWindowWorkDoneProgressCancel newNotif
|
||||
case mHome of
|
||||
Nothing -> void $ sendAllSubIDEs miState newMsg
|
||||
Just home -> void $ sendSubIDEByPath miState home newMsg
|
||||
|
||||
-- Special handing for STextDocumentDefinition to ask multiple IDEs (the W approach)
|
||||
-- When a getDefinition is requested, we cast this request into a tryGetDefinition
|
||||
-- This is a method that will take the same logic path as getDefinition, but will also return an
|
||||
-- identifier in the cases where it knows the identifier wasn't defined in the package that referenced it
|
||||
-- When we receive this name, we lookup against the multi-package.yaml for a package that matches where the identifier
|
||||
-- came from. If we find one, we ask (and create if needed) the SubIDE that contains the identifier where its defined.
|
||||
-- (this is via the getDefinitionByName message)
|
||||
-- We also send the backup known incorrect location from the tryGetDefinition, such that if the subIDE containing the identifier
|
||||
-- can't find the definition, it'll fall back to the known incorrect location.
|
||||
-- Once we have this, we return it as a response to the original STextDocumentDefinition request.
|
||||
LSP.FromClientMess LSP.STextDocumentDefinition req@LSP.RequestMessage {_id, _method, _params} -> do
|
||||
let path = filePathFromParamsWithTextDocument req
|
||||
lspId = castLspId _id
|
||||
method = LSP.SCustomMethod "daml/tryGetDefinition"
|
||||
putReqMethodSingleFromClient (fromClientMethodTrackerVar miState) lspId method
|
||||
sendSubIDEByPath miState path $ LSP.FromClientMess method $ LSP.ReqMess $
|
||||
LSP.RequestMessage "2.0" lspId method $ Aeson.toJSON $
|
||||
TryGetDefinitionParams (_params ^. LSP.textDocument) (_params ^. LSP.position)
|
||||
|
||||
LSP.FromClientMess meth params ->
|
||||
case getMessageForwardingBehaviour meth params of
|
||||
ForwardRequest mess (Single path) -> do
|
||||
debugPrint $ "single req on method " <> show meth <> " over path " <> path
|
||||
let LSP.RequestMessage {_id, _method} = mess
|
||||
putReqMethodSingleFromClient (fromClientMethodTrackerVar miState) _id _method
|
||||
sendSubIDEByPath miState path (castFromClientMessage msg)
|
||||
|
||||
ForwardRequest mess (AllRequest combine) -> do
|
||||
debugPrint $ "all req on method " <> show meth
|
||||
let LSP.RequestMessage {_id, _method} = mess
|
||||
ides <- sendAllSubIDEs miState (castFromClientMessage msg)
|
||||
putReqMethodAll (fromClientMethodTrackerVar miState) _id _method ides combine
|
||||
|
||||
ForwardNotification _ (Single path) -> do
|
||||
debugPrint $ "single not on method " <> show meth <> " over path " <> path
|
||||
sendSubIDEByPath miState path (castFromClientMessage msg)
|
||||
|
||||
ForwardNotification _ AllNotification -> do
|
||||
debugPrint $ "all not on method " <> show meth
|
||||
sendAllSubIDEs_ miState (castFromClientMessage msg)
|
||||
|
||||
ExplicitHandler handler -> do
|
||||
handler (sendClient miState) (sendSubIDEByPath miState)
|
||||
LSP.FromClientRsp (Pair method (Const home)) rMsg ->
|
||||
sendSubIDEByPath miState home $ LSP.FromClientRsp method $
|
||||
rMsg & LSP.id %~ fmap removeLspPrefix
|
||||
|
||||
getMultiPackageYamlMapping :: IO MultiPackageYamlMapping
|
||||
getMultiPackageYamlMapping = do
|
||||
-- TODO: this will find the "closest" multi-package.yaml, but in a case where we have multiple referring to each other, we'll not see the outer one
|
||||
-- in that case, code jump won't work. Its unclear which the user would want, so we may want to prompt them with either closest or furthest (that links up)
|
||||
mPkgConfig <- findMultiPackageConfig $ ProjectPath "."
|
||||
case mPkgConfig of
|
||||
Nothing ->
|
||||
Map.empty <$ debugPrint "No multi-package.yaml found"
|
||||
Just path -> do
|
||||
debugPrint "Found multi-package.yaml"
|
||||
withMultiPackageConfig path $ \multiPackage -> do
|
||||
eUnitIds <- traverse unitIdFromDamlYaml (mpPackagePaths multiPackage)
|
||||
let eMapping = Map.fromList . flip zip (mpPackagePaths multiPackage) <$> sequence eUnitIds
|
||||
either throwIO pure eMapping
|
||||
|
||||
{-
|
||||
Expect a multi-package.yaml at the workspace root
|
||||
If we do not get one, we continue as normal (no popups) until the user attempts to open/use files in a different package to the first one
|
||||
When this occurs, this send a popup:
|
||||
Make a multi-package.yaml at the root and reload the editor please :)
|
||||
OR tell me where the multi-package.yaml(s) is
|
||||
if the user provides multiple, we union that lookup, allowing "cross project boundary" jumps
|
||||
-}
|
||||
|
||||
-- Main loop logic
|
||||
|
||||
runMultiIde :: IO ()
|
||||
runMultiIde = do
|
||||
multiPackageMapping <- getMultiPackageYamlMapping
|
||||
miState <- newMultiIdeState multiPackageMapping
|
||||
|
||||
debugPrint "Listening for bytes"
|
||||
-- Client <- *****
|
||||
toClientThread <- async $ forever $ do
|
||||
msg <- atomically $ readTChan $ toClientChan miState
|
||||
debugPrint "Pushing message to client"
|
||||
-- BSLC.hPutStrLn stderr msg
|
||||
putChunk stdout msg
|
||||
|
||||
-- Client -> Coord
|
||||
clientToCoordThread <- async $ do
|
||||
chunks <- getChunks stdin
|
||||
mapM_ (clientMessageHandler miState) chunks
|
||||
|
||||
let killAll :: IO ()
|
||||
killAll = do
|
||||
debugPrint "Killing subIDEs"
|
||||
subIDEs <- atomically $ onlyActiveSubIdes <$> readTMVar (subIDEsVar miState)
|
||||
forM_ subIDEs (shutdownIde miState)
|
||||
|
||||
handle (\(_ :: AsyncException) -> killAll) $ do
|
||||
atomically $ do
|
||||
unsafeIOToSTM $ debugPrint "Running main loop"
|
||||
subIDEs <- readTMVar $ subIDEsVar miState
|
||||
let asyncs = concatMap (\subIDE -> [ideInhandleAsync subIDE, ideOutHandleAsync subIDE]) subIDEs
|
||||
errs <- lefts . catMaybes <$> traverse pollSTM (asyncs ++ [toClientThread, clientToCoordThread])
|
||||
when (not $ null errs) $
|
||||
unsafeIOToSTM $ debugPrint $ "A thread handler errored with: " <> show (head errs)
|
||||
|
||||
let procs = ideProcess <$> subIDEs
|
||||
exits <- catMaybes <$> traverse getExitCodeSTM (Map.elems procs)
|
||||
when (not $ null exits) $
|
||||
unsafeIOToSTM $ debugPrint $ "A subIDE finished with code: " <> show (head exits)
|
||||
|
||||
when (null exits && null errs) retry
|
||||
|
||||
-- If we get here, something failed/stopped, so stop everything
|
||||
killAll
|
||||
@ -0,0 +1,188 @@
|
||||
-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE DisambiguateRecordFields #-}
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
|
||||
-- We generate missing instances for SignatureHelpParams
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module DA.Cli.Damlc.Command.MultiIde.Forwarding (
|
||||
getMessageForwardingBehaviour,
|
||||
filePathFromParamsWithTextDocument,
|
||||
Forwarding (..),
|
||||
ForwardingBehaviour (..),
|
||||
ResponseCombiner,
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Lens
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.Aeson.Lens as Aeson
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Text as T
|
||||
import Development.IDE.Core.Rules.Daml (uriToVirtualResource)
|
||||
import Development.IDE.Core.RuleTypes.Daml (VirtualResource (..))
|
||||
import qualified Language.LSP.Types as LSP
|
||||
import qualified Language.LSP.Types.Lens as LSP
|
||||
import qualified Network.URI as URI
|
||||
import DA.Cli.Damlc.Command.MultiIde.Types
|
||||
|
||||
{-# ANN module ("HLint: ignore Avoid restricted flags" :: String) #-}
|
||||
|
||||
-- SignatureHelpParams has no lenses from Language.LSP.Types.Lens
|
||||
-- We just need this one, so we'll write it ourselves
|
||||
makeLensesFor [("_textDocument", "signatureHelpParamsTextDocumentLens")] ''LSP.SignatureHelpParams
|
||||
instance LSP.HasTextDocument LSP.SignatureHelpParams LSP.TextDocumentIdentifier where
|
||||
textDocument = signatureHelpParamsTextDocumentLens
|
||||
|
||||
pullMonadThroughTuple :: Monad m => (a, m b) -> m (a, b)
|
||||
pullMonadThroughTuple (a, mb) = (a,) <$> mb
|
||||
|
||||
-- Takes a natural transformation of responses and lifts it to forward the first error
|
||||
assumeSuccessCombiner
|
||||
:: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request)
|
||||
. ([(FilePath, LSP.ResponseResult m)] -> LSP.ResponseResult m)
|
||||
-> ResponseCombiner m
|
||||
assumeSuccessCombiner f res = f <$> mapM pullMonadThroughTuple res
|
||||
|
||||
ignore :: Forwarding m
|
||||
ignore = ExplicitHandler $ \_ _ -> pure ()
|
||||
|
||||
showError :: T.Text -> Forwarding m
|
||||
showError err = ExplicitHandler $ \sendClient _ ->
|
||||
sendClient $ LSP.FromServerMess LSP.SWindowShowMessage
|
||||
$ LSP.NotificationMessage "2.0" LSP.SWindowShowMessage
|
||||
$ LSP.ShowMessageParams LSP.MtError err
|
||||
|
||||
showFatal :: T.Text -> Forwarding m
|
||||
showFatal err = showError $ "FATAL ERROR:\n" <> err <> "\nPlease report this on the daml forums."
|
||||
|
||||
handleElsewhere :: T.Text -> Forwarding m
|
||||
handleElsewhere name = showFatal $ "Got unexpected " <> name <> " message in forwarding handler, this message should have been handled elsewhere."
|
||||
|
||||
unsupported :: T.Text -> Forwarding m
|
||||
unsupported name = showFatal $ "Attempted to call a method that is unsupported by the underlying IDEs: " <> name
|
||||
|
||||
uriFilePathPrism :: Prism' LSP.Uri FilePath
|
||||
uriFilePathPrism = prism' LSP.filePathToUri LSP.uriToFilePath
|
||||
|
||||
getMessageForwardingBehaviour
|
||||
:: forall t (m :: LSP.Method 'LSP.FromClient t)
|
||||
. LSP.SMethod m
|
||||
-> LSP.Message m
|
||||
-> Forwarding m
|
||||
getMessageForwardingBehaviour meth params =
|
||||
case meth of
|
||||
LSP.SInitialize -> handleElsewhere "Initialize"
|
||||
LSP.SInitialized -> ignore
|
||||
-- send to all then const reply
|
||||
LSP.SShutdown -> ForwardRequest params $ AllRequest (assumeSuccessCombiner @m $ const LSP.Empty)
|
||||
LSP.SExit -> ForwardNotification params AllNotification
|
||||
LSP.SWorkspaceDidChangeWorkspaceFolders -> ForwardNotification params AllNotification
|
||||
LSP.SWorkspaceDidChangeConfiguration -> ForwardNotification params AllNotification
|
||||
LSP.SWorkspaceDidChangeWatchedFiles -> ForwardNotification params AllNotification
|
||||
LSP.STextDocumentDidOpen -> ForwardNotification params $ forwardingBehaviourFromParamsWithTextDocument params
|
||||
LSP.STextDocumentDidChange -> ForwardNotification params $ forwardingBehaviourFromParamsWithTextDocument params
|
||||
LSP.STextDocumentWillSave -> ForwardNotification params $ forwardingBehaviourFromParamsWithTextDocument params
|
||||
LSP.STextDocumentWillSaveWaitUntil -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument params
|
||||
LSP.STextDocumentDidSave -> ForwardNotification params $ forwardingBehaviourFromParamsWithTextDocument params
|
||||
LSP.STextDocumentDidClose -> ForwardNotification params $ forwardingBehaviourFromParamsWithTextDocument params
|
||||
LSP.STextDocumentCompletion -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument params
|
||||
LSP.STextDocumentHover -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument params
|
||||
LSP.STextDocumentSignatureHelp -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument params
|
||||
LSP.STextDocumentDeclaration -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument params
|
||||
LSP.STextDocumentDefinition -> handleElsewhere "TextDocumentDefinition"
|
||||
LSP.STextDocumentDocumentSymbol -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument params
|
||||
LSP.STextDocumentCodeAction -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument params
|
||||
LSP.STextDocumentCodeLens -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument params
|
||||
LSP.STextDocumentDocumentLink -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument params
|
||||
LSP.STextDocumentColorPresentation -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument params
|
||||
LSP.STextDocumentOnTypeFormatting -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument params
|
||||
|
||||
LSP.SCustomMethod "daml/keepAlive" ->
|
||||
case params of
|
||||
LSP.ReqMess LSP.RequestMessage {_id, _method, _params} -> ExplicitHandler $ \sendClient _ ->
|
||||
sendClient $ LSP.FromServerRsp _method $ LSP.ResponseMessage "2.0" (Just _id) (Right Aeson.Null)
|
||||
_ -> showFatal "Got unpexpected daml/keepAlive response type from client"
|
||||
|
||||
-- Other custom messages are notifications from server
|
||||
LSP.SCustomMethod _ -> ignore
|
||||
|
||||
-- We only add the typesignature.add command, which simply sends a WorkspaceEdit with a single file modification
|
||||
-- We can take the file path from that modification
|
||||
LSP.SWorkspaceExecuteCommand ->
|
||||
case params ^. LSP.params . LSP.command of
|
||||
"typesignature.add" ->
|
||||
-- Fun lens:
|
||||
-- RequestMessage -> ExecuteCommandParams -> Aeson.Value -> WorkspaceEdit -> WorkspaceEditMap -> Uri
|
||||
let path =
|
||||
fromMaybe "Invalid arguments from typesignature.add" $
|
||||
params
|
||||
^? LSP.params
|
||||
. LSP.arguments
|
||||
. _Just
|
||||
. to (\(LSP.List a) -> a)
|
||||
. _head
|
||||
. Aeson._JSON @Aeson.Value @LSP.WorkspaceEdit
|
||||
. LSP.changes
|
||||
. _Just
|
||||
. to HM.keys
|
||||
. _head
|
||||
. uriFilePathPrism
|
||||
in ForwardRequest params $ Single path
|
||||
cmd -> showFatal $ "Unknown execute command: " <> cmd
|
||||
|
||||
LSP.SWindowWorkDoneProgressCancel -> handleElsewhere "WindowWorkDoneProgressCancel"
|
||||
LSP.SCancelRequest -> ForwardNotification params AllNotification
|
||||
-- Unsupported by GHCIDE:
|
||||
LSP.SWorkspaceSymbol -> unsupported "WorkspaceSymbol"
|
||||
LSP.STextDocumentTypeDefinition -> unsupported "TextDocumentTypeDefinition"
|
||||
LSP.STextDocumentImplementation -> unsupported "TextDocumentImplementation"
|
||||
LSP.STextDocumentReferences -> unsupported "TextDocumentReferences"
|
||||
LSP.STextDocumentDocumentHighlight -> unsupported "TextDocumentDocumentHighlight"
|
||||
LSP.STextDocumentDocumentColor -> unsupported "TextDocumentDocumentColor"
|
||||
LSP.SDocumentLinkResolve -> unsupported "DocumentLinkResolve"
|
||||
LSP.STextDocumentFormatting -> unsupported "TextDocumentFormatting"
|
||||
LSP.STextDocumentRangeFormatting -> unsupported "TextDocumentRangeFormatting"
|
||||
LSP.STextDocumentRename -> unsupported "TextDocumentRename"
|
||||
LSP.STextDocumentPrepareRename -> unsupported "TextDocumentPrepareRename"
|
||||
LSP.STextDocumentFoldingRange -> unsupported "TextDocumentFoldingRange"
|
||||
LSP.STextDocumentSelectionRange -> unsupported "TextDocumentSelectionRange"
|
||||
LSP.STextDocumentPrepareCallHierarchy -> unsupported "TextDocumentPrepareCallHierarchy"
|
||||
LSP.SCompletionItemResolve -> unsupported "CompletionItemResolve"
|
||||
LSP.SCodeLensResolve -> unsupported "CodeLensResolve"
|
||||
LSP.SCallHierarchyIncomingCalls -> unsupported "CallHierarchyIncomingCalls"
|
||||
LSP.SCallHierarchyOutgoingCalls -> unsupported "CallHierarchyOutgoingCalls"
|
||||
LSP.STextDocumentSemanticTokens -> unsupported "TextDocumentSemanticTokens"
|
||||
LSP.STextDocumentSemanticTokensFull -> unsupported "TextDocumentSemanticTokensFull"
|
||||
LSP.STextDocumentSemanticTokensFullDelta -> unsupported "TextDocumentSemanticTokensFullDelta"
|
||||
LSP.STextDocumentSemanticTokensRange -> unsupported "TextDocumentSemanticTokensRange"
|
||||
LSP.SWorkspaceSemanticTokensRefresh -> unsupported "WorkspaceSemanticTokensRefresh"
|
||||
|
||||
filePathFromParamsWithTextDocument :: (LSP.HasParams p a, LSP.HasTextDocument a t, LSP.HasUri t LSP.Uri) => p -> FilePath
|
||||
filePathFromParamsWithTextDocument params =
|
||||
let uri = params ^. LSP.params . LSP.textDocument . LSP.uri
|
||||
in fromMaybe (error $ "Failed to extract path: " <> show uri) $ filePathFromURI uri
|
||||
|
||||
forwardingBehaviourFromParamsWithTextDocument :: (LSP.HasParams p a, LSP.HasTextDocument a t, LSP.HasUri t LSP.Uri) => p -> ForwardingBehaviour m
|
||||
forwardingBehaviourFromParamsWithTextDocument params = Single $ filePathFromParamsWithTextDocument params
|
||||
|
||||
-- Attempts to convert the URI directly to a filepath
|
||||
-- If the URI is a virtual resource, we instead parse it as such and extract the file from that
|
||||
filePathFromURI :: LSP.Uri -> Maybe FilePath
|
||||
filePathFromURI uri =
|
||||
LSP.uriToFilePath uri
|
||||
<|> do
|
||||
parsedUri <- URI.parseURI $ T.unpack $ LSP.getUri uri
|
||||
vr <- uriToVirtualResource parsedUri
|
||||
pure $ LSP.fromNormalizedFilePath $ vrScenarioFile vr
|
||||
188
sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Parsing.hs
Normal file
188
sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Parsing.hs
Normal file
@ -0,0 +1,188 @@
|
||||
-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE DisambiguateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
|
||||
module DA.Cli.Damlc.Command.MultiIde.Parsing (
|
||||
getChunks,
|
||||
parseClientMessageWithTracker,
|
||||
parseServerMessageWithTracker,
|
||||
putChunk,
|
||||
putReqMethodAll,
|
||||
putReqMethodSingleFromClient,
|
||||
putReqMethodSingleFromServer,
|
||||
putServerReq,
|
||||
) where
|
||||
|
||||
import Control.Concurrent.STM.TVar
|
||||
import Control.Lens
|
||||
import Control.Monad.STM
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
import qualified Data.Attoparsec.ByteString.Lazy as Attoparsec
|
||||
import qualified Data.ByteString as B
|
||||
import Data.ByteString.Builder.Extra (defaultChunkSize)
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
import qualified Data.ByteString.Lazy.Char8 as BSLC
|
||||
import Data.Foldable (forM_)
|
||||
import DA.Cli.Damlc.Command.MultiIde.Types
|
||||
import Data.Functor.Product
|
||||
import qualified Data.IxMap as IM
|
||||
import Data.List (delete)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Language.LSP.Types as LSP
|
||||
import System.IO.Extra
|
||||
import System.IO.Unsafe (unsafeInterleaveIO)
|
||||
|
||||
|
||||
{-# ANN allBytes ("HLint: ignore Avoid restricted function" :: String) #-}
|
||||
-- unsafeInterleaveIO used to create a chunked lazy bytestring over IO for a given Handle
|
||||
allBytes :: Handle -> IO BSL.ByteString
|
||||
allBytes hin = fmap BSL.fromChunks go
|
||||
where
|
||||
go :: IO [B.ByteString]
|
||||
go = do
|
||||
first <- unsafeInterleaveIO $ B.hGetSome hin defaultChunkSize
|
||||
rest <- unsafeInterleaveIO go
|
||||
pure (first : rest)
|
||||
|
||||
-- Missing from Data.Attoparsec.ByteString.Lazy, copied from Data.Attoparsec.ByteString.Char8
|
||||
decimal :: Attoparsec.Parser Int
|
||||
decimal = B.foldl' step 0 `fmap` Attoparsec.takeWhile1 (\w -> w - 48 <= 9)
|
||||
where step a w = a * 10 + fromIntegral (w - 48)
|
||||
|
||||
contentChunkParser :: Attoparsec.Parser B.ByteString
|
||||
contentChunkParser = do
|
||||
_ <- Attoparsec.string "Content-Length: "
|
||||
len <- decimal
|
||||
_ <- Attoparsec.string "\r\n\r\n"
|
||||
Attoparsec.take len
|
||||
|
||||
getChunks :: Handle -> IO [B.ByteString]
|
||||
getChunks handle =
|
||||
let loop bytes =
|
||||
case Attoparsec.parse contentChunkParser bytes of
|
||||
Attoparsec.Done leftovers result -> result : loop leftovers
|
||||
_ -> []
|
||||
in
|
||||
loop <$> allBytes handle
|
||||
|
||||
putChunk :: Handle -> BSL.ByteString -> IO ()
|
||||
putChunk handle payload = do
|
||||
let fullMessage = "Content-Length: " <> BSLC.pack (show (BSL.length payload)) <> "\r\n\r\n" <> payload
|
||||
BSL.hPut handle fullMessage
|
||||
hFlush handle
|
||||
|
||||
putReqMethodSingleFromServer
|
||||
:: forall (m :: LSP.Method 'LSP.FromServer 'LSP.Request)
|
||||
. MethodTrackerVar 'LSP.FromServer -> FilePath -> LSP.LspId m -> LSP.SMethod m -> IO ()
|
||||
putReqMethodSingleFromServer tracker home id method = putReqMethod tracker id $ TrackedSingleMethodFromServer method home
|
||||
|
||||
putReqMethodSingleFromClient
|
||||
:: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request)
|
||||
. MethodTrackerVar 'LSP.FromClient -> LSP.LspId m -> LSP.SMethod m -> IO ()
|
||||
putReqMethodSingleFromClient tracker id method = putReqMethod tracker id $ TrackedSingleMethodFromClient method
|
||||
|
||||
putReqMethodAll
|
||||
:: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request)
|
||||
. MethodTrackerVar 'LSP.FromClient
|
||||
-> LSP.LspId m
|
||||
-> LSP.SMethod m
|
||||
-> [FilePath]
|
||||
-> ResponseCombiner m
|
||||
-> IO ()
|
||||
putReqMethodAll tracker id method ides combine =
|
||||
putReqMethod tracker id $ TrackedAllMethod method id combine ides []
|
||||
|
||||
putReqMethod
|
||||
:: forall (f :: LSP.From) (m :: LSP.Method f 'LSP.Request)
|
||||
. MethodTrackerVar f -> LSP.LspId m -> TrackedMethod m -> IO ()
|
||||
putReqMethod tracker id method = atomically $ modifyTVar' tracker $ \im ->
|
||||
fromMaybe im $ IM.insertIxMap id method im
|
||||
|
||||
pickReqMethodTo
|
||||
:: forall (f :: LSP.From) r
|
||||
. MethodTrackerVar f
|
||||
-> ((forall (m :: LSP.Method f 'LSP.Request)
|
||||
. LSP.LspId m
|
||||
-> (Maybe (TrackedMethod m), MethodTracker f)
|
||||
) -> (r, Maybe (MethodTracker f)))
|
||||
-> IO r
|
||||
pickReqMethodTo tracker handler = atomically $ do
|
||||
im <- readTVar tracker
|
||||
let (r, mayNewIM) = handler (flip IM.pickFromIxMap im)
|
||||
forM_ mayNewIM $ writeTVar tracker
|
||||
pure r
|
||||
|
||||
-- We're forced to give a result of type `(SMethod m, a m)` by parseServerMessage and parseClientMessage, but we want to include the updated MethodTracker
|
||||
-- so we use Product to ensure our result has the SMethod and our MethodTracker
|
||||
wrapParseMessageLookup
|
||||
:: forall (f :: LSP.From) (m :: LSP.Method f 'LSP.Request)
|
||||
. (Maybe (TrackedMethod m), MethodTracker f)
|
||||
-> Maybe
|
||||
( LSP.SMethod m
|
||||
, Product TrackedMethod (Const (MethodTracker f)) m
|
||||
)
|
||||
wrapParseMessageLookup (mayTM, newIM) =
|
||||
fmap (\tm -> (tmMethod tm, Pair tm (Const newIM))) mayTM
|
||||
|
||||
-- Parses a message from the server providing context about previous requests from client
|
||||
-- allowing the server parser to reconstruct typed responses to said requests
|
||||
-- Handles TrackedAllMethod by returning Nothing for messages that do not have enough replies yet.
|
||||
parseServerMessageWithTracker :: MethodTrackerVar 'LSP.FromClient -> FilePath -> Aeson.Value -> IO (Either String (Maybe LSP.FromServerMessage))
|
||||
parseServerMessageWithTracker tracker selfIde val = pickReqMethodTo tracker $ \extract ->
|
||||
case Aeson.parseEither (LSP.parseServerMessage (wrapParseMessageLookup . extract)) val of
|
||||
Right (LSP.FromServerMess meth mess) -> (Right (Just $ LSP.FromServerMess meth mess), Nothing)
|
||||
Right (LSP.FromServerRsp (Pair (TrackedSingleMethodFromClient method) (Const newIxMap)) rsp) -> (Right (Just (LSP.FromServerRsp method rsp)), Just newIxMap)
|
||||
-- Multi reply logic, for requests that are sent to all IDEs with responses unified. Required for some queries
|
||||
Right (LSP.FromServerRsp (Pair tm@TrackedAllMethod {} (Const newIxMap)) rsp) -> do
|
||||
-- Haskell gets a little confused when updating existential records, so we need to build a new one
|
||||
let tm' = TrackedAllMethod
|
||||
{ tamMethod = tamMethod tm
|
||||
, tamLspId = tamLspId tm
|
||||
, tamCombiner = tamCombiner tm
|
||||
, tamResponses = (selfIde, LSP._result rsp) : tamResponses tm
|
||||
, tamRemainingResponseIDERoots = delete selfIde $ tamRemainingResponseIDERoots tm
|
||||
}
|
||||
if null $ tamRemainingResponseIDERoots tm'
|
||||
then let msg = LSP.FromServerRsp (tamMethod tm) $ rsp {LSP._result = tamCombiner tm' (tamResponses tm')}
|
||||
in (Right $ Just msg, Just newIxMap)
|
||||
else let insertedIxMap = fromMaybe newIxMap $ IM.insertIxMap (tamLspId tm) tm' newIxMap
|
||||
in (Right Nothing, Just insertedIxMap)
|
||||
Left msg -> (Left msg, Nothing)
|
||||
|
||||
-- Similar to parseServerMessageWithTracker but using Client message types, and checking previous requests from server
|
||||
-- Also does not include the multi-reply logic
|
||||
-- For responses, gives the ide that sent the initial request
|
||||
parseClientMessageWithTracker
|
||||
:: MethodTrackerVar 'LSP.FromServer
|
||||
-> Aeson.Value
|
||||
-> IO (Either String (LSP.FromClientMessage' (Product LSP.SMethod (Const FilePath))))
|
||||
parseClientMessageWithTracker tracker val = pickReqMethodTo tracker $ \extract ->
|
||||
case Aeson.parseEither (LSP.parseClientMessage (wrapParseMessageLookup . extract)) val of
|
||||
Right (LSP.FromClientMess meth mess) -> (Right (LSP.FromClientMess meth mess), Nothing)
|
||||
Right (LSP.FromClientRsp (Pair (TrackedSingleMethodFromServer method home) (Const newIxMap)) rsp) ->
|
||||
(Right (LSP.FromClientRsp (Pair method (Const home)) rsp), Just newIxMap)
|
||||
Left msg -> (Left msg, Nothing)
|
||||
|
||||
-- Takes a message from server and stores it if its a request, so that later messages from the client can deduce response context
|
||||
putServerReq :: MethodTrackerVar 'LSP.FromServer -> FilePath -> LSP.FromServerMessage -> IO ()
|
||||
putServerReq tracker home msg =
|
||||
case msg of
|
||||
LSP.FromServerMess meth mess ->
|
||||
case LSP.splitServerMethod meth of
|
||||
LSP.IsServerReq ->
|
||||
let LSP.RequestMessage {_id, _method} = mess
|
||||
in putReqMethodSingleFromServer tracker home _id _method
|
||||
LSP.IsServerEither ->
|
||||
case mess of
|
||||
LSP.ReqMess LSP.RequestMessage {_id, _method} -> putReqMethodSingleFromServer tracker home _id _method
|
||||
_ -> pure ()
|
||||
_ -> pure ()
|
||||
_ -> pure ()
|
||||
@ -0,0 +1,216 @@
|
||||
-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE DisambiguateRecordFields #-}
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
|
||||
-- This module handles prefixing of identifiers generated by the SubIDEs, so that they are unique to the client, but are returned in the same form to the servers.
|
||||
module DA.Cli.Damlc.Command.MultiIde.Prefixing (
|
||||
addProgressTokenPrefixToClientMessage,
|
||||
addProgressTokenPrefixToServerMessage,
|
||||
addLspPrefixToServerMessage,
|
||||
removeLspPrefix,
|
||||
removeWorkDoneProgressCancelTokenPrefix,
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Lens
|
||||
import Data.Foldable (find)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Text as T
|
||||
import qualified Language.LSP.Types as LSP
|
||||
import qualified Language.LSP.Types.Lens as LSP
|
||||
import DA.Cli.Damlc.Command.MultiIde.Types
|
||||
|
||||
-- ProgressToken Prefixing
|
||||
|
||||
-- Progress tokens are created in 2 ways:
|
||||
-- The subIDE sends a CreateToken
|
||||
-- In this case, we need to prefix the token, as multiple subIDEs might use the same name
|
||||
-- The client sends any message with a progress token attached
|
||||
-- In this case, we can assume the token is unique to the client, and not modify it
|
||||
-- There are then 2 messages that can use these tokens:
|
||||
-- Progress message from the subIDE
|
||||
-- This includes the token id, but we don't know if said token id was created by the subIDE (so needs prefixing) or client
|
||||
-- Therefore, whenever we see a token created by the server, we store it in a var (along with the subIde it came from)
|
||||
-- Then when we see a progress message with a token, if the token is in the var, we know it needs the prefix, otherwise its unmodified
|
||||
-- Cancel message from the client
|
||||
-- This has a token id, but again we dont know where it came from, so if it needs its prefix removed
|
||||
-- We again lookup in the map, if we find it, we remove the prefix, and send it to the subIDE that created it
|
||||
-- If we don't find it, we know its unique to the client, and only exists on one of the SubIDEs
|
||||
-- We are then safe to broadcast the cancel message to all IDEs, as those that don't have it will ignore the message
|
||||
-- TODO: Verify what happens if the client creates a token and sends to SUbIDE1, then subIDE tries to create one with the same name
|
||||
-- This gets prefixed and submitted to client
|
||||
-- after this, the client tries to cancel the token it created for SubIDE1, which gets submitted to all SubIDEs
|
||||
-- will this cancel the one subIDE2 made - yes
|
||||
-- So, can the server and client create clashing token names? Likely :(
|
||||
|
||||
|
||||
-- GHCIDE generates essentially counting numbers from 1
|
||||
-- vscode generates full UUIDs
|
||||
-- Neither will clash if we prefix with `client`
|
||||
-- All requests from client with the workdone or partial result token will get prefixed with `client` (using addProgressTokenPrefix)
|
||||
-- On cancel request, if we dont have the token in our mapping, we prefix with client and broadcast as usual
|
||||
-- on Progress notification from server, if we dont have the token, we drop the client prefix and forward it - implying the prefix is reversible, which it isn't
|
||||
-- might instead want to store the prefixing, with the FilePath changed to a Maybe FilePath, Nothing = from client?
|
||||
-- Also, listing all the methods with the HasToken thing will be annoying and potentially wrong, check if we can achieve it with overlapping instances (and look up if thats safe)
|
||||
|
||||
-- Adds the prefix, doesn't need to be reversible as we'll keep a backwards lookup
|
||||
-- Just needs to be unique
|
||||
addProgressTokenPrefix :: T.Text -> LSP.ProgressToken -> LSP.ProgressToken
|
||||
addProgressTokenPrefix prefix (LSP.ProgressNumericToken t) = LSP.ProgressTextToken $ prefix <> "-" <> T.pack (show t)
|
||||
addProgressTokenPrefix prefix (LSP.ProgressTextToken t) = LSP.ProgressTextToken $ prefix <> "-" <> t
|
||||
|
||||
-- Added to WindowWorkDoneProgressCreate and Progress
|
||||
-- If its create, add the prefix and store the change (and source IDE) in the mapping var
|
||||
-- if its progress, attempt to read the correct prefixed name from the mapping var, on failure, call back to the initial token id
|
||||
-- Safe as we assume this was created by client, so is already unique.
|
||||
addProgressTokenPrefixToServerMessage :: ProgressTokenPrefixesVar -> FilePath -> T.Text -> LSP.FromServerMessage -> IO LSP.FromServerMessage
|
||||
addProgressTokenPrefixToServerMessage tokensVar home prefix (LSP.FromServerMess LSP.SWindowWorkDoneProgressCreate req) = do
|
||||
let unPrefixedToken = req ^. LSP.params . LSP.token
|
||||
prefixedToken = addProgressTokenPrefix prefix unPrefixedToken
|
||||
modifyMVar_ tokensVar (pure . Map.insert (unPrefixedToken, Just home) prefixedToken)
|
||||
pure $ LSP.FromServerMess LSP.SWindowWorkDoneProgressCreate $ req & LSP.params . LSP.token .~ prefixedToken
|
||||
addProgressTokenPrefixToServerMessage tokensVar home _ (LSP.FromServerMess LSP.SProgress notif) = do
|
||||
let unPrefixedToken = notif ^. LSP.params . LSP.token
|
||||
-- for lookup and delete, try no home then given home, abstract as a function. This ensures the progress lookup still works for client created tokens
|
||||
prefixedToken <- fromMaybe unPrefixedToken . lookupHomeAndNot (unPrefixedToken, home) <$> readMVar tokensVar
|
||||
case notif ^. LSP.params . LSP.value of
|
||||
LSP.End _ -> modifyMVar_ tokensVar (pure . Map.delete (unPrefixedToken, Just home) . Map.delete (unPrefixedToken, Nothing))
|
||||
_ -> pure ()
|
||||
pure $ LSP.FromServerMess LSP.SProgress $ notif & LSP.params . LSP.token .~ prefixedToken
|
||||
addProgressTokenPrefixToServerMessage _ _ _ msg = pure msg
|
||||
|
||||
lookupHomeAndNot :: (LSP.ProgressToken, FilePath) -> ProgressTokenPrefixes -> Maybe LSP.ProgressToken
|
||||
lookupHomeAndNot (t, home) m = Map.lookup (t, Nothing) m <|> Map.lookup (t, Just home) m
|
||||
|
||||
-- Adds the "client" prefix to all workDone and partial result Progress tokens
|
||||
addProgressTokenPrefixToClientMessage :: ProgressTokenPrefixesVar -> LSP.FromClientMessage' a -> IO (LSP.FromClientMessage' a)
|
||||
addProgressTokenPrefixToClientMessage tokensVar = \case
|
||||
mess@(LSP.FromClientMess method params) ->
|
||||
case LSP.splitClientMethod method of
|
||||
LSP.IsClientReq -> do
|
||||
let progressLenses = getProgressLenses method
|
||||
params' <-
|
||||
maybe pure (\lens -> runLens lens $ traverse addClientProgressTokenPrefix) (workDoneLens progressLenses) params
|
||||
>>= maybe pure (\lens -> runLens lens $ traverse addClientProgressTokenPrefix) (partialResultLens progressLenses)
|
||||
pure $ LSP.FromClientMess method params'
|
||||
_ -> pure mess
|
||||
rsp@LSP.FromClientRsp {} -> pure rsp
|
||||
where
|
||||
addClientProgressTokenPrefix :: LSP.ProgressToken -> IO LSP.ProgressToken
|
||||
addClientProgressTokenPrefix unPrefixedToken = do
|
||||
let prefixedToken = addProgressTokenPrefix "client" unPrefixedToken
|
||||
-- We insert to the mapping backwards, as the mapping goes from server token to client token, and for client -> server messages, this should add, not remove, the prefix.
|
||||
modifyMVar_ tokensVar (pure . Map.insert (prefixedToken, Nothing) unPrefixedToken)
|
||||
pure prefixedToken
|
||||
|
||||
data ProgressLenses (m :: LSP.Method 'LSP.FromClient 'LSP.Request) = ProgressLenses
|
||||
{ workDoneLens :: Maybe (ReifiedLens' (LSP.RequestMessage m) (Maybe LSP.ProgressToken))
|
||||
, partialResultLens :: Maybe (ReifiedLens' (LSP.RequestMessage m) (Maybe LSP.ProgressToken))
|
||||
}
|
||||
|
||||
getProgressLenses :: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request). LSP.SMethod m -> ProgressLenses m
|
||||
getProgressLenses = \case
|
||||
LSP.SInitialize -> workDone
|
||||
LSP.SWorkspaceSymbol -> both
|
||||
LSP.SWorkspaceExecuteCommand -> workDone
|
||||
LSP.STextDocumentCompletion -> both
|
||||
LSP.STextDocumentHover -> workDone
|
||||
LSP.STextDocumentDeclaration -> both
|
||||
LSP.STextDocumentDefinition -> both
|
||||
LSP.STextDocumentTypeDefinition -> both
|
||||
LSP.STextDocumentImplementation -> both
|
||||
LSP.STextDocumentReferences -> both
|
||||
LSP.STextDocumentDocumentHighlight -> both
|
||||
LSP.STextDocumentDocumentSymbol -> both
|
||||
LSP.STextDocumentCodeAction -> both
|
||||
LSP.STextDocumentCodeLens -> both
|
||||
LSP.STextDocumentDocumentLink -> both
|
||||
LSP.STextDocumentDocumentColor -> both
|
||||
LSP.STextDocumentColorPresentation -> both
|
||||
LSP.STextDocumentFormatting -> workDone
|
||||
LSP.STextDocumentRangeFormatting -> workDone
|
||||
LSP.STextDocumentRename -> workDone
|
||||
LSP.STextDocumentFoldingRange -> both
|
||||
LSP.STextDocumentSelectionRange -> both
|
||||
LSP.STextDocumentPrepareCallHierarchy -> workDone
|
||||
LSP.SCallHierarchyIncomingCalls -> both
|
||||
LSP.SCallHierarchyOutgoingCalls -> both
|
||||
LSP.STextDocumentSemanticTokensFull -> both
|
||||
LSP.STextDocumentSemanticTokensFullDelta -> both
|
||||
LSP.STextDocumentSemanticTokensRange -> both
|
||||
_ -> ProgressLenses Nothing Nothing
|
||||
where
|
||||
workDone
|
||||
:: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request)
|
||||
. LSP.HasWorkDoneToken (LSP.MessageParams m) (Maybe LSP.ProgressToken)
|
||||
=> ProgressLenses m
|
||||
workDone = ProgressLenses (Just $ Lens $ LSP.params . LSP.workDoneToken) Nothing
|
||||
both
|
||||
:: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request)
|
||||
. ( LSP.HasWorkDoneToken (LSP.MessageParams m) (Maybe LSP.ProgressToken)
|
||||
, LSP.HasPartialResultToken (LSP.MessageParams m) (Maybe LSP.ProgressToken)
|
||||
)
|
||||
=> ProgressLenses m
|
||||
both = ProgressLenses (Just $ Lens $ LSP.params . LSP.workDoneToken) (Just $ Lens $ LSP.params . LSP.partialResultToken)
|
||||
|
||||
findKeyByValue :: Eq v => v -> Map.Map k v -> Maybe k
|
||||
findKeyByValue val = fmap fst . find ((==val) . snd) . Map.toList
|
||||
|
||||
-- Remove the prefix from WindowWorkDoneProgressCancel, and return the source SubIDE if we knew it.
|
||||
removeWorkDoneProgressCancelTokenPrefix
|
||||
:: ProgressTokenPrefixesVar
|
||||
-> LSP.NotificationMessage 'LSP.WindowWorkDoneProgressCancel
|
||||
-> IO (LSP.NotificationMessage 'LSP.WindowWorkDoneProgressCancel, Maybe FilePath)
|
||||
removeWorkDoneProgressCancelTokenPrefix tokensVar notif = do
|
||||
let token = notif ^. LSP.params . LSP.token
|
||||
mKey <- findKeyByValue token <$> readMVar tokensVar
|
||||
case mKey of
|
||||
Nothing -> error "Got a cancel request for a ProgressToken that was never created."
|
||||
Just key@(unPrefixedToken, mHome) -> do
|
||||
modifyMVar_ tokensVar (pure . Map.delete key)
|
||||
pure (notif & LSP.params . LSP.token .~ unPrefixedToken, mHome)
|
||||
|
||||
-- LspId Prefixing
|
||||
|
||||
-- We need to ensure all IDs from different subIDEs are unique to the client, so we prefix them.
|
||||
-- Given IDs can be int or text, we encode them as text as well as a tag to say if the original was an int
|
||||
-- Such that IdInt 10 -> IdString "iPREFIX-10"
|
||||
-- and IdString "hello" -> IdString "tPREFIX-hello"
|
||||
addLspPrefix
|
||||
:: forall (f :: LSP.From) (m :: LSP.Method f 'LSP.Request)
|
||||
. T.Text
|
||||
-> LSP.LspId m
|
||||
-> LSP.LspId m
|
||||
addLspPrefix prefix (LSP.IdInt t) = LSP.IdString $ "i" <> prefix <> "-" <> T.pack (show t)
|
||||
addLspPrefix prefix (LSP.IdString t) = LSP.IdString $ "t" <> prefix <> "-" <> t
|
||||
|
||||
removeLspPrefix
|
||||
:: forall (f :: LSP.From) (m :: LSP.Method f 'LSP.Request)
|
||||
. LSP.LspId m
|
||||
-> LSP.LspId m
|
||||
removeLspPrefix (LSP.IdString (T.unpack -> ('i':rest))) = LSP.IdInt $ read $ tail $ dropWhile (/='-') rest
|
||||
removeLspPrefix (LSP.IdString (T.uncons -> Just ('t', rest))) = LSP.IdString $ T.tail $ T.dropWhile (/='-') rest
|
||||
-- Maybe this should error? This method should only be called on LspIds that we know have been prefixed
|
||||
removeLspPrefix t = t
|
||||
|
||||
addLspPrefixToServerMessage :: SubIDE -> LSP.FromServerMessage -> LSP.FromServerMessage
|
||||
addLspPrefixToServerMessage _ res@(LSP.FromServerRsp _ _) = res
|
||||
addLspPrefixToServerMessage ide res@(LSP.FromServerMess method params) =
|
||||
case LSP.splitServerMethod method of
|
||||
LSP.IsServerReq -> LSP.FromServerMess method $ params & LSP.id %~ addLspPrefix (ideMessageIdPrefix ide)
|
||||
LSP.IsServerNot -> res
|
||||
LSP.IsServerEither ->
|
||||
case params of
|
||||
LSP.ReqMess params' -> LSP.FromServerMess method $ LSP.ReqMess $ params' & LSP.id %~ addLspPrefix (ideMessageIdPrefix ide)
|
||||
LSP.NotMess _ -> res
|
||||
184
sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Types.hs
Normal file
184
sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Types.hs
Normal file
@ -0,0 +1,184 @@
|
||||
-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE DisambiguateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
|
||||
module DA.Cli.Damlc.Command.MultiIde.Types (
|
||||
module DA.Cli.Damlc.Command.MultiIde.Types
|
||||
) where
|
||||
|
||||
import Control.Concurrent.Async (Async)
|
||||
import Control.Concurrent.STM.TChan
|
||||
import Control.Concurrent.STM.TVar
|
||||
import Control.Concurrent.STM.TMVar
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Monad.STM
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
import qualified Data.IxMap as IM
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as T
|
||||
import qualified Language.LSP.Types as LSP
|
||||
import System.IO.Extra
|
||||
import System.Process.Typed (Process)
|
||||
|
||||
data TrackedMethod (m :: LSP.Method from 'LSP.Request) where
|
||||
TrackedSingleMethodFromClient
|
||||
:: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request)
|
||||
. LSP.SMethod m
|
||||
-> TrackedMethod m
|
||||
TrackedSingleMethodFromServer
|
||||
:: forall (m :: LSP.Method 'LSP.FromServer 'LSP.Request)
|
||||
. LSP.SMethod m
|
||||
-> FilePath -- Also store the IDE that sent the request
|
||||
-> TrackedMethod m
|
||||
TrackedAllMethod :: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request).
|
||||
{ tamMethod :: LSP.SMethod m
|
||||
-- ^ The method of the initial request
|
||||
, tamLspId :: LSP.LspId m
|
||||
, tamCombiner :: ResponseCombiner m
|
||||
-- ^ How to combine the results from each IDE
|
||||
, tamRemainingResponseIDERoots :: [FilePath]
|
||||
-- ^ The IDES that have not yet replied to this message
|
||||
, tamResponses :: [(FilePath, Either LSP.ResponseError (LSP.ResponseResult m))]
|
||||
} -> TrackedMethod m
|
||||
|
||||
tmMethod
|
||||
:: forall (from :: LSP.From) (m :: LSP.Method from 'LSP.Request)
|
||||
. TrackedMethod m
|
||||
-> LSP.SMethod m
|
||||
tmMethod (TrackedSingleMethodFromClient m) = m
|
||||
tmMethod (TrackedSingleMethodFromServer m _) = m
|
||||
tmMethod (TrackedAllMethod {tamMethod}) = tamMethod
|
||||
|
||||
type MethodTracker (from :: LSP.From) = IM.IxMap @(LSP.Method from 'LSP.Request) LSP.LspId TrackedMethod
|
||||
type MethodTrackerVar (from :: LSP.From) = TVar (MethodTracker from)
|
||||
|
||||
data SubIDE = SubIDE
|
||||
{ ideInhandleAsync :: Async ()
|
||||
, ideInHandle :: Handle
|
||||
, ideInHandleChannel :: TChan BSL.ByteString
|
||||
, ideOutHandleAsync :: Async ()
|
||||
-- ^ For sending messages to that SubIDE
|
||||
, ideProcess :: Process Handle Handle ()
|
||||
, ideHomeDirectory :: FilePath
|
||||
, ideMessageIdPrefix :: T.Text
|
||||
-- ^ Some unique string used to prefix message ids created by the SubIDE, to avoid collisions with other SubIDEs
|
||||
-- We use the stringified process ID
|
||||
, ideActive :: Bool
|
||||
, ideUnitId :: String
|
||||
-- ^ Unit ID of the package this SubIDE handles
|
||||
-- Of the form "daml-script-0.0.1"
|
||||
}
|
||||
|
||||
-- SubIDEs placed in a TMVar. The emptyness representents a modification lock.
|
||||
-- The lock unsures the following properties:
|
||||
-- If multiple messages are sent to a new IDE at the same time, the first will create and hold a lock, while the rest wait on that lock (avoid multiple create)
|
||||
-- We never attempt to send messages on a stale IDE. If we ever read SubIDEsVar with the intent to send a message on a SubIDE, we must hold the so a shutdown
|
||||
-- cannot be sent on that IDE until we are done. This ensures that when a shutdown does occur, it is impossible for non-shutdown messages to be added to the
|
||||
-- queue after the shutdown.
|
||||
type SubIDEs = Map.Map FilePath SubIDE
|
||||
type SubIDEsVar = TMVar SubIDEs
|
||||
|
||||
onlyActiveSubIdes :: SubIDEs -> SubIDEs
|
||||
onlyActiveSubIdes = Map.filter ideActive
|
||||
|
||||
-- Stores the initialize messages sent by the client to be forwarded to SubIDEs when they are created.
|
||||
type InitParams = LSP.InitializeParams
|
||||
type InitParamsVar = MVar InitParams
|
||||
|
||||
-- Stores the mapping of progress tokens and their IDEs home (or Nothing if client created) to their prefixed counterpart
|
||||
-- We need this so we know which of the Progress messages from the server need to be prefixed
|
||||
-- since ProgressTokens created by the client are prefixed differently
|
||||
-- This is a Bimap, keys and values are unique
|
||||
type ProgressTokenPrefixes = Map.Map (LSP.ProgressToken, Maybe FilePath) LSP.ProgressToken
|
||||
type ProgressTokenPrefixesVar = MVar ProgressTokenPrefixes
|
||||
|
||||
-- Maps a packages unit id to its source file path, for all packages listed in a multi-package.yaml
|
||||
type MultiPackageYamlMapping = Map.Map String FilePath
|
||||
|
||||
data MultiIdeState = MultiIdeState
|
||||
{ fromClientMethodTrackerVar :: MethodTrackerVar 'LSP.FromClient
|
||||
-- ^ The client will track its own IDs to ensure they're unique, so no worries about collisions
|
||||
, fromServerMethodTrackerVar :: MethodTrackerVar 'LSP.FromServer
|
||||
-- ^ We will prefix LspIds before they get here based on their SubIDE messageIdPrefix, to avoid collisions
|
||||
, progessTokenPrefixesVar :: ProgressTokenPrefixesVar
|
||||
, subIDEsVar :: SubIDEsVar
|
||||
, initParamsVar :: InitParamsVar
|
||||
, toClientChan :: TChan BSL.ByteString
|
||||
, multiPackageMapping :: MultiPackageYamlMapping
|
||||
}
|
||||
|
||||
newMultiIdeState :: MultiPackageYamlMapping -> IO MultiIdeState
|
||||
newMultiIdeState multiPackageMapping = do
|
||||
(fromClientMethodTrackerVar :: MethodTrackerVar 'LSP.FromClient) <- newTVarIO IM.emptyIxMap
|
||||
(fromServerMethodTrackerVar :: MethodTrackerVar 'LSP.FromServer) <- newTVarIO IM.emptyIxMap
|
||||
progessTokenPrefixesVar <- newMVar @ProgressTokenPrefixes mempty
|
||||
subIDEsVar <- newTMVarIO @SubIDEs mempty
|
||||
initParamsVar <- newEmptyMVar @InitParams
|
||||
toClientChan <- atomically newTChan
|
||||
pure MultiIdeState {..}
|
||||
|
||||
-- Forwarding
|
||||
|
||||
{-
|
||||
Types of behaviour we want:
|
||||
|
||||
Regularly handling by a single IDE - works for requests and notifications
|
||||
e.g. TextDocumentDidOpen
|
||||
Ignore it
|
||||
e.g. Initialize
|
||||
Forward a notification to all IDEs
|
||||
e.g. workspace folders changed, exit
|
||||
Forward a request to all IDEs and somehow combine the result
|
||||
e.g.
|
||||
symbol lookup -> combine monoidically
|
||||
shutdown -> response is empty, so identity after all responses
|
||||
This is the hard one as we need some way to define the combination logic
|
||||
which will ideally wait for all IDEs to reply to the request and apply this function over the (possibly failing) result
|
||||
This mostly covers FromClient requests that we can't pull a filepath from
|
||||
|
||||
Previously thought we would need this more, now we only really use it for shutdown - ensuring all SubIdes shutdown before replying.
|
||||
We'll keep it in though since we'll likely get more capabilities supported when we upgrade ghc/move to HLS
|
||||
-}
|
||||
|
||||
-- TODO: Consider splitting this into one data type for request and one for notification
|
||||
-- rather than reusing the Single constructor over both and restricting via types
|
||||
data ForwardingBehaviour (m :: LSP.Method 'LSP.FromClient t) where
|
||||
Single
|
||||
:: forall t (m :: LSP.Method 'LSP.FromClient t)
|
||||
. FilePath
|
||||
-> ForwardingBehaviour m
|
||||
AllRequest
|
||||
:: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request)
|
||||
. ResponseCombiner m
|
||||
-> ForwardingBehaviour m
|
||||
AllNotification
|
||||
:: ForwardingBehaviour (m :: LSP.Method 'LSP.FromClient 'LSP.Notification)
|
||||
|
||||
-- Akin to ClientNotOrReq tagged with ForwardingBehaviour, and CustomMethod realised to req/not
|
||||
data Forwarding (m :: LSP.Method 'LSP.FromClient t) where
|
||||
ForwardRequest
|
||||
:: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request)
|
||||
. LSP.RequestMessage m
|
||||
-> ForwardingBehaviour m
|
||||
-> Forwarding m
|
||||
ForwardNotification
|
||||
:: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Notification)
|
||||
. LSP.NotificationMessage m
|
||||
-> ForwardingBehaviour m
|
||||
-> Forwarding m
|
||||
ExplicitHandler
|
||||
:: ( (LSP.FromServerMessage -> IO ())
|
||||
-> (FilePath -> LSP.FromClientMessage -> IO ())
|
||||
-> IO ()
|
||||
)
|
||||
-> Forwarding (m :: LSP.Method 'LSP.FromClient t)
|
||||
|
||||
type ResponseCombiner (m :: LSP.Method 'LSP.FromClient 'LSP.Request) =
|
||||
[(FilePath, Either LSP.ResponseError (LSP.ResponseResult m))] -> Either LSP.ResponseError (LSP.ResponseResult m)
|
||||
173
sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Util.hs
Normal file
173
sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Util.hs
Normal file
@ -0,0 +1,173 @@
|
||||
-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE DisambiguateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
|
||||
module DA.Cli.Damlc.Command.MultiIde.Util (
|
||||
module DA.Cli.Damlc.Command.MultiIde.Util
|
||||
) where
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Concurrent.STM.TMVar
|
||||
import Control.Exception (handle)
|
||||
import Control.Monad.STM
|
||||
import DA.Daml.Project.Config (readProjectConfig, queryProjectConfigRequired)
|
||||
import DA.Daml.Project.Types (ConfigError, ProjectPath (..))
|
||||
import qualified Language.LSP.Types as LSP
|
||||
import qualified Language.LSP.Types.Capabilities as LSP
|
||||
import System.Directory (doesDirectoryExist, listDirectory)
|
||||
import System.FilePath (takeDirectory)
|
||||
import System.IO.Extra
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
|
||||
-- Stop mangling my prints! >:(
|
||||
{-# ANN printLock ("HLint: ignore Avoid restricted function" :: String) #-}
|
||||
{-# NOINLINE printLock #-}
|
||||
printLock :: MVar ()
|
||||
printLock = unsafePerformIO $ newMVar ()
|
||||
|
||||
debugPrint :: String -> IO ()
|
||||
debugPrint msg = withMVar printLock $ \_ -> do
|
||||
hPutStrLn stderr msg
|
||||
hFlush stderr
|
||||
|
||||
er :: Show x => String -> Either x a -> a
|
||||
er _msg (Right a) = a
|
||||
er msg (Left e) = error $ msg <> ": " <> show e
|
||||
|
||||
modifyTMVar :: TMVar a -> (a -> a) -> STM ()
|
||||
modifyTMVar var f = do
|
||||
x <- takeTMVar var
|
||||
putTMVar var (f x)
|
||||
|
||||
-- Taken directly from the Initialize response
|
||||
initializeResult :: LSP.InitializeResult
|
||||
initializeResult = LSP.InitializeResult
|
||||
{ _capabilities = LSP.ServerCapabilities
|
||||
{ _textDocumentSync = Just $ LSP.InL $ LSP.TextDocumentSyncOptions
|
||||
{ _openClose = Just True
|
||||
, _change = Just LSP.TdSyncIncremental
|
||||
, _willSave = Nothing
|
||||
, _willSaveWaitUntil = Nothing
|
||||
, _save = Just (LSP.InR (LSP.SaveOptions {_includeText = Nothing}))
|
||||
}
|
||||
, _hoverProvider = true
|
||||
, _completionProvider = Just $ LSP.CompletionOptions
|
||||
{ _workDoneProgress = Nothing
|
||||
, _triggerCharacters = Nothing
|
||||
, _allCommitCharacters = Nothing
|
||||
, _resolveProvider = Just False
|
||||
}
|
||||
, _signatureHelpProvider = Nothing
|
||||
, _declarationProvider = false
|
||||
, _definitionProvider = true
|
||||
, _typeDefinitionProvider = false
|
||||
, _implementationProvider = false
|
||||
, _referencesProvider = false
|
||||
, _documentHighlightProvider = false
|
||||
, _documentSymbolProvider = true
|
||||
, _codeActionProvider = true
|
||||
, _codeLensProvider = Just (LSP.CodeLensOptions {_workDoneProgress = Just False, _resolveProvider = Just False})
|
||||
, _documentLinkProvider = Nothing
|
||||
, _colorProvider = false
|
||||
, _documentFormattingProvider = false
|
||||
, _documentRangeFormattingProvider = false
|
||||
, _documentOnTypeFormattingProvider = Nothing
|
||||
, _renameProvider = false
|
||||
, _foldingRangeProvider = false
|
||||
, _executeCommandProvider = Just (LSP.ExecuteCommandOptions {_workDoneProgress = Nothing, _commands = LSP.List ["typesignature.add"]})
|
||||
, _selectionRangeProvider = false
|
||||
, _callHierarchyProvider = false
|
||||
, _semanticTokensProvider = Just $ LSP.InR $ LSP.SemanticTokensRegistrationOptions
|
||||
{ _documentSelector = Nothing
|
||||
, _workDoneProgress = Nothing
|
||||
, _legend = LSP.SemanticTokensLegend
|
||||
{ _tokenTypes = LSP.List
|
||||
[ LSP.SttType
|
||||
, LSP.SttClass
|
||||
, LSP.SttEnum
|
||||
, LSP.SttInterface
|
||||
, LSP.SttStruct
|
||||
, LSP.SttTypeParameter
|
||||
, LSP.SttParameter
|
||||
, LSP.SttVariable
|
||||
, LSP.SttProperty
|
||||
, LSP.SttEnumMember
|
||||
, LSP.SttEvent
|
||||
, LSP.SttFunction
|
||||
, LSP.SttMethod
|
||||
, LSP.SttMacro
|
||||
, LSP.SttKeyword
|
||||
, LSP.SttModifier
|
||||
, LSP.SttComment
|
||||
, LSP.SttString
|
||||
, LSP.SttNumber
|
||||
, LSP.SttRegexp
|
||||
, LSP.SttOperator
|
||||
]
|
||||
, _tokenModifiers = LSP.List
|
||||
[ LSP.StmDeclaration
|
||||
, LSP.StmDefinition
|
||||
, LSP.StmReadonly
|
||||
, LSP.StmStatic
|
||||
, LSP.StmDeprecated
|
||||
, LSP.StmAbstract
|
||||
, LSP.StmAsync
|
||||
, LSP.StmModification
|
||||
, LSP.StmDocumentation
|
||||
, LSP.StmDefaultLibrary
|
||||
]
|
||||
}
|
||||
|
||||
, _range = Nothing
|
||||
, _full = Nothing
|
||||
, _id = Nothing
|
||||
}
|
||||
, _workspaceSymbolProvider = Just False
|
||||
, _workspace = Just $ LSP.WorkspaceServerCapabilities
|
||||
{ _workspaceFolders =
|
||||
Just (LSP.WorkspaceFoldersServerCapabilities {_supported = Just True, _changeNotifications = Just (LSP.InR True)})
|
||||
}
|
||||
, _experimental = Nothing
|
||||
}
|
||||
, _serverInfo = Nothing
|
||||
}
|
||||
where
|
||||
true = Just (LSP.InL True)
|
||||
false = Just (LSP.InL False)
|
||||
|
||||
castLspId :: LSP.LspId m -> LSP.LspId m'
|
||||
castLspId (LSP.IdString s) = LSP.IdString s
|
||||
castLspId (LSP.IdInt i) = LSP.IdInt i
|
||||
|
||||
-- Given a file path, move up directory until we find a daml.yaml and give its path (if it exists)
|
||||
findHome :: FilePath -> IO (Maybe FilePath)
|
||||
findHome path = do
|
||||
exists <- doesDirectoryExist path
|
||||
if exists then aux path else aux (takeDirectory path)
|
||||
where
|
||||
aux :: FilePath -> IO (Maybe FilePath)
|
||||
aux path = do
|
||||
hasDamlYaml <- elem "daml.yaml" <$> listDirectory path
|
||||
if hasDamlYaml
|
||||
then pure $ Just path
|
||||
else do
|
||||
let newPath = takeDirectory path
|
||||
if path == newPath
|
||||
then pure Nothing
|
||||
else aux newPath
|
||||
|
||||
unitIdFromDamlYaml :: FilePath -> IO (Either ConfigError String)
|
||||
unitIdFromDamlYaml path = do
|
||||
handle (\(e :: ConfigError) -> return $ Left e) $ do
|
||||
project <- readProjectConfig $ ProjectPath path
|
||||
pure $ do
|
||||
name <- queryProjectConfigRequired ["name"] project
|
||||
version <- queryProjectConfigRequired ["version"] project
|
||||
pure $ name <> "-" <> version
|
||||
@ -66,6 +66,9 @@ commands:
|
||||
- name: ide
|
||||
path: damlc/damlc
|
||||
args: ["ide"]
|
||||
- name: multi-ide
|
||||
path: damlc/damlc
|
||||
args: ["lax", "multi-ide"]
|
||||
- name: script
|
||||
path: daml-helper/daml-helper
|
||||
args: ["run-jar", "--logback-config=daml-sdk/script-logback.xml", "daml-sdk/daml-sdk.jar", "script"]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user