From 714b0c7f4f953b363f4caddca5dc59a68857e625 Mon Sep 17 00:00:00 2001 From: Samuel Williams Date: Wed, 27 Mar 2024 10:49:23 +0000 Subject: [PATCH] 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 --- sdk/bazel-haskell-deps.bzl | 6 +- .../lsp-types-expose-other-modules.patch | 20 + sdk/compiler/daml-extension/package.json | 7 +- sdk/compiler/daml-extension/src/extension.ts | 24 +- sdk/compiler/damlc/BUILD.bazel | 5 + sdk/compiler/damlc/daml-ide/BUILD.bazel | 9 + .../daml-ide/src/DA/Daml/LanguageServer.hs | 5 +- .../LanguageServer/SplitGotoDefinition.hs | 239 +++++++++ .../daml-opts/daml-opts/DA/Daml/Options.hs | 1 + sdk/compiler/damlc/lib/DA/Cli/Damlc.hs | 19 +- .../lib/DA/Cli/Damlc/Command/MultiIde.hs | 501 ++++++++++++++++++ .../Cli/Damlc/Command/MultiIde/Forwarding.hs | 188 +++++++ .../DA/Cli/Damlc/Command/MultiIde/Parsing.hs | 188 +++++++ .../Cli/Damlc/Command/MultiIde/Prefixing.hs | 216 ++++++++ .../DA/Cli/Damlc/Command/MultiIde/Types.hs | 184 +++++++ .../lib/DA/Cli/Damlc/Command/MultiIde/Util.hs | 173 ++++++ sdk/release/sdk-config.yaml.tmpl | 3 + 17 files changed, 1779 insertions(+), 9 deletions(-) create mode 100644 sdk/bazel_tools/lsp-types-expose-other-modules.patch create mode 100644 sdk/compiler/damlc/daml-ide/src/DA/Daml/LanguageServer/SplitGotoDefinition.hs create mode 100644 sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde.hs create mode 100644 sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Forwarding.hs create mode 100644 sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Parsing.hs create mode 100644 sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Prefixing.hs create mode 100644 sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Types.hs create mode 100644 sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Util.hs diff --git a/sdk/bazel-haskell-deps.bzl b/sdk/bazel-haskell-deps.bzl index 8de97cc5a1..9451b4bfad 100644 --- a/sdk/bazel-haskell-deps.bzl +++ b/sdk/bazel-haskell-deps.bzl @@ -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", diff --git a/sdk/bazel_tools/lsp-types-expose-other-modules.patch b/sdk/bazel_tools/lsp-types-expose-other-modules.patch new file mode 100644 index 0000000000..eafabbfcc9 --- /dev/null +++ b/sdk/bazel_tools/lsp-types-expose-other-modules.patch @@ -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 diff --git a/sdk/compiler/daml-extension/package.json b/sdk/compiler/daml-extension/package.json index 0f22c061cb..4deae6d8a7 100644 --- a/sdk/compiler/daml-extension/package.json +++ b/sdk/compiler/daml-extension/package.json @@ -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": { diff --git a/sdk/compiler/daml-extension/src/extension.ts b/sdk/compiler/daml-extension/src/extension.ts index 732092f586..8296109fd7 100644 --- a/sdk/compiler/daml-extension/src/extension.ts +++ b/sdk/compiler/daml-extension/src/extension.ts @@ -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"); diff --git a/sdk/compiler/damlc/BUILD.bazel b/sdk/compiler/damlc/BUILD.bazel index 3287539d6a..c1e1f04f4e 100644 --- a/sdk/compiler/damlc/BUILD.bazel +++ b/sdk/compiler/damlc/BUILD.bazel @@ -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", diff --git a/sdk/compiler/damlc/daml-ide/BUILD.bazel b/sdk/compiler/damlc/daml-ide/BUILD.bazel index 3e9b8e580f..4b0895c7a3 100644 --- a/sdk/compiler/damlc/daml-ide/BUILD.bazel +++ b/sdk/compiler/damlc/daml-ide/BUILD.bazel @@ -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", ], ) diff --git a/sdk/compiler/damlc/daml-ide/src/DA/Daml/LanguageServer.hs b/sdk/compiler/damlc/daml-ide/src/DA/Daml/LanguageServer.hs index 5ea35a1f49..39a0a465d8 100644 --- a/sdk/compiler/damlc/daml-ide/src/DA/Daml/LanguageServer.hs +++ b/sdk/compiler/damlc/daml-ide/src/DA/Daml/LanguageServer.hs @@ -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 diff --git a/sdk/compiler/damlc/daml-ide/src/DA/Daml/LanguageServer/SplitGotoDefinition.hs b/sdk/compiler/damlc/daml-ide/src/DA/Daml/LanguageServer/SplitGotoDefinition.hs new file mode 100644 index 0000000000..a1e83e0ae5 --- /dev/null +++ b/sdk/compiler/damlc/daml-ide/src/DA/Daml/LanguageServer/SplitGotoDefinition.hs @@ -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 diff --git a/sdk/compiler/damlc/daml-opts/daml-opts/DA/Daml/Options.hs b/sdk/compiler/damlc/daml-opts/daml-opts/DA/Daml/Options.hs index 0f1d380087..0ff419e49b 100644 --- a/sdk/compiler/damlc/daml-opts/daml-opts/DA/Daml/Options.hs +++ b/sdk/compiler/damlc/daml-opts/daml-opts/DA/Daml/Options.hs @@ -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) diff --git a/sdk/compiler/damlc/lib/DA/Cli/Damlc.hs b/sdk/compiler/damlc/lib/DA/Cli/Damlc.hs index 10797dfd53..274058c0fc 100644 --- a/sdk/compiler/damlc/lib/DA/Cli/Damlc.hs +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc.hs @@ -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 = diff --git a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde.hs b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde.hs new file mode 100644 index 0000000000..597033402c --- /dev/null +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde.hs @@ -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 diff --git a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Forwarding.hs b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Forwarding.hs new file mode 100644 index 0000000000..82c7cc5387 --- /dev/null +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Forwarding.hs @@ -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 diff --git a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Parsing.hs b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Parsing.hs new file mode 100644 index 0000000000..505acaa7a2 --- /dev/null +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Parsing.hs @@ -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 () diff --git a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Prefixing.hs b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Prefixing.hs new file mode 100644 index 0000000000..7969a0ae80 --- /dev/null +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Prefixing.hs @@ -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 diff --git a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Types.hs b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Types.hs new file mode 100644 index 0000000000..dd9c6ae057 --- /dev/null +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Types.hs @@ -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) diff --git a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Util.hs b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Util.hs new file mode 100644 index 0000000000..f10bb1acc7 --- /dev/null +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Util.hs @@ -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 diff --git a/sdk/release/sdk-config.yaml.tmpl b/sdk/release/sdk-config.yaml.tmpl index e456f366f6..23d97572b3 100644 --- a/sdk/release/sdk-config.yaml.tmpl +++ b/sdk/release/sdk-config.yaml.tmpl @@ -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"]