Enhanced completions for the assistant (digital-asset#4420)

* Enhanced completions for the assistant changelog_begin - [DAML Assistant] The assistant can now do completions for SDK commands, e.g., ``daml ledger upl<TAB>`` will complete to ``daml ledger upload-dar``. changelog_end * Apply suggestions from code review Co-Authored-By: associahedron <231829+associahedron@users.noreply.github.com> Co-authored-by: associahedron <231829+associahedron@users.noreply.github.com>
iggy-da · Feb 6, 2020 · fc87953 · fc87953
1 parent 30afc76
commit fc87953
Show file tree

Hide file tree

Showing 5 changed files with 92 additions and 31 deletions.
diff --git a/daml-assistant/daml-project-config/DA/Daml/Project/Config.hs b/daml-assistant/daml-project-config/DA/Daml/Project/Config.hs
@@ -63,8 +63,8 @@ sdkVersionFromSdkConfig :: SdkConfig -> Either ConfigError SdkVersion
 sdkVersionFromSdkConfig = querySdkConfigRequired ["version"]
 
 -- | Read sdk config to get list of sdk commands.
-listSdkCommands :: SdkConfig -> Either ConfigError [SdkCommandInfo]
-listSdkCommands = querySdkConfigRequired ["commands"]
+listSdkCommands :: SdkPath -> EnrichedCompletion -> SdkConfig -> Either ConfigError [SdkCommandInfo]
+listSdkCommands sdkPath enriched sdkConf = map (\f -> f sdkPath enriched) <$> querySdkConfigRequired ["commands"] sdkConf
 
 -- | Query the daml config by passing a path to the desired property.
 -- See 'queryConfig' for more details.

diff --git a/daml-assistant/daml-project-config/DA/Daml/Project/Types.hs b/daml-assistant/daml-project-config/DA/Daml/Project/Types.hs
@@ -1,6 +1,6 @@
 -- Copyright (c) 2020 The DAML Authors. All rights reserved.
 -- SPDX-License-Identifier: Apache-2.0
-
+{-# LANGUAGE FlexibleInstances #-}
 
 module DA.Daml.Project.Types
     ( module DA.Daml.Project.Types
@@ -136,12 +136,34 @@ data SdkCommandInfo = SdkCommandInfo
     , sdkCommandPath :: SdkCommandPath -- ^ file path of binary relative to sdk directory
     , sdkCommandArgs :: SdkCommandArgs -- ^ extra args to pass before user-supplied args (defaults to [])
     , sdkCommandDesc :: Maybe Text     -- ^ description of sdk command (optional)
+    , sdkCommandForwardCompletion :: ForwardCompletion -- ^ Can we forward optparse-applicative completions to
+                                                       -- this command
+    , sdkCommandSdkPath :: SdkPath -- ^ SDK path so we can get the absolute path to the command.
     } deriving (Eq, Show)
 
-instance Y.FromJSON SdkCommandInfo where
-    parseJSON = Y.withObject "SdkCommandInfo" $ \p ->
-        SdkCommandInfo
-            <$> (p Y..: "name")
-            <*> (p Y..: "path")
-            <*> fmap (fromMaybe (SdkCommandArgs [])) (p Y..:? "args")
-            <*> (p Y..:? "desc")
+data ForwardCompletion
+    = Forward EnrichedCompletion -- ^ Forward completions
+    | NoForward -- ^ No forwarding, fall back to basic completion
+    deriving (Eq, Show)
+
+-- | True if --bash-completion-enriched was part of argv.
+newtype EnrichedCompletion = EnrichedCompletion { getEnrichedCompletion :: Bool }
+    deriving (Eq, Show)
+
+hasEnrichedCompletion :: [String] -> EnrichedCompletion
+hasEnrichedCompletion = EnrichedCompletion . elem "--bash-completion-enriched"
+
+instance Y.FromJSON (SdkPath -> EnrichedCompletion -> SdkCommandInfo) where
+    parseJSON = Y.withObject "SdkCommandInfo" $ \p -> do
+        name <- p Y..: "name"
+        path <- p Y..: "path"
+        args <- fmap (fromMaybe (SdkCommandArgs [])) (p Y..:? "args")
+        desc <- p Y..:? "desc"
+        completion <- fromMaybe False <$> p Y..:? "completion"
+        return $ \sdkPath enriched -> SdkCommandInfo
+          name
+          path
+          args
+          desc
+          (if completion then Forward enriched else NoForward)
+          sdkPath
diff --git a/daml-assistant/exe/DA/Daml/Assistant.hs b/daml-assistant/exe/DA/Daml/Assistant.hs
@@ -14,6 +14,7 @@ import DA.Daml.Assistant.Command
 import DA.Daml.Assistant.Version
 import DA.Daml.Assistant.Install
 import DA.Daml.Assistant.Util
+import System.Environment (getArgs)
 import System.FilePath
 import System.Directory
 import System.Process.Typed
@@ -53,24 +54,26 @@ main = displayErrors $ do
             -- So if we can't find it, let the user know. This will happen whenever
             -- auto-install is disabled and the project or environment specify a
             -- missing SDK version.
-            when (isNothing envSdkPath) $ do
-                let installTarget
-                        | Just v <- envSdkVersion = versionToString v
-                        | otherwise = "latest"
-                hPutStr stderr . unlines $
-                    [ "DAML SDK not installed. Cannot run command without SDK."
-                    , "To proceed, please install the SDK by running:"
-                    , ""
-                    , "    daml install " <> installTarget
-                    , ""
-                    ]
-                exitFailure
-
-            sdkConfig <- readSdkConfig (fromJust envSdkPath)
-            sdkCommands <- fromRightM throwIO (listSdkCommands sdkConfig)
-            userCommand <- getCommand sdkCommands
-            versionChecks env
-            handleCommand env userCommand
+            case envSdkPath of
+                Nothing -> do
+                    let installTarget
+                            | Just v <- envSdkVersion = versionToString v
+                            | otherwise = "latest"
+                    hPutStr stderr . unlines $
+                        [ "DAML SDK not installed. Cannot run command without SDK."
+                        , "To proceed, please install the SDK by running:"
+                        , ""
+                        , "    daml install " <> installTarget
+                        , ""
+                        ]
+                    exitFailure
+                Just sdkPath -> do
+                    sdkConfig <- readSdkConfig sdkPath
+                    enriched <- hasEnrichedCompletion <$> getArgs
+                    sdkCommands <- fromRightM throwIO (listSdkCommands sdkPath enriched sdkConfig)
+                    userCommand <- getCommand sdkCommands
+                    versionChecks env
+                    handleCommand env userCommand
 
 -- | Perform version checks, i.e. warn user if project SDK version or assistant SDK
 -- versions are out of date with the latest known release.

diff --git a/daml-assistant/src/DA/Daml/Assistant/Command.hs b/daml-assistant/src/DA/Daml/Assistant/Command.hs
@@ -18,8 +18,10 @@ import DA.Daml.Assistant.Types
 import Data.List
 import Data.Maybe
 import Data.Foldable
+import Options.Applicative.Types
 import Options.Applicative.Extended
 import System.Environment
+import System.FilePath
 import Data.Either.Extra
 import Control.Exception.Safe
 import System.Process
@@ -60,8 +62,30 @@ dispatch info = subcommand
     (unwrapSdkCommandName $ sdkCommandName info)
     (fromMaybe "" $ sdkCommandDesc info)
     forwardOptions
-    (Dispatch info . UserCommandArgs <$>
-        many (strArgument (metavar "ARGS" <> completer defaultCompleter)))
+    (Dispatch info . UserCommandArgs <$> sdkCommandArgsParser info)
+
+sdkCommandArgsParser :: SdkCommandInfo -> Parser [String]
+sdkCommandArgsParser info = fromM (go (unwrapSdkCommandArgs $ sdkCommandArgs info))
+  where go args = do
+          mx <- oneM $ optional $ strArgument $ completer $
+              case sdkCommandForwardCompletion info of
+                  Forward enriched -> nestedCompl enriched args
+                  NoForward -> defaultCompleter
+          case mx of
+            Nothing -> return []
+            Just x -> (x :) <$> go (args ++ [x])
+        nestedCompl enriched args = mkCompleter $ \arg -> do
+          let path = unwrapSdkPath (sdkCommandSdkPath info) </> unwrapSdkCommandPath (sdkCommandPath info)
+          let createProc = proc
+                  path
+                  ( [ "--bash-completion-enriched" | getEnrichedCompletion enriched ]
+                  <>
+                  ("--bash-completion-index"
+                  : show (length args + 1)
+                  : concatMap (\x -> ["--bash-completion-word", x]) ("daml" : args ++ [arg])
+                  ))
+          stdout <- readCreateProcess createProc (repeat ' ')
+          pure $ lines stdout
 
 commandParser :: [SdkCommandInfo] -> Parser Command
 commandParser cmds | (hidden, visible) <- partition isHidden cmds = asum
@@ -104,7 +128,7 @@ readSdkVersion =
     eitherReader (mapLeft displayException . parseVersion . pack)
 
 -- | Completer that uses the builtin bash completion.
--- We use this to ensure that `daml build -o foo` will still complete to `daml build -o foobar.dar`.
+-- We use this as a fallback for commands that do not use optparse-applicative to at least get file completions.
 defaultCompleter :: Completer
 defaultCompleter = mkCompleter $ \word -> do
 -- The implementation here is a variant of optparse-applicative’s `bashCompleter`.

diff --git a/release/sdk-config.yaml.tmpl b/release/sdk-config.yaml.tmpl
@@ -4,36 +4,45 @@ commands:
   path: daml-helper/daml-helper
   desc: "Launch DAML Studio"
   args: ["studio"]
+  completion: true
 - name: new
   path: daml-helper/daml-helper
   desc: "Create a new DAML project"
   args: ["new"]
+  completion: true
 - name: migrate
   path: daml-helper/daml-helper
   args: ["migrate"]
+  completion: true
 - name: init
   path: daml-helper/daml-helper
   desc: "Configure a folder as a DAML project"
   args: ["init"]
+  completion: true
 - name: build
   path: damlc/damlc
   args: ["build", "--project-check"]
   desc: "Build the DAML project into a DAR file"
+  completion: true
 - name: test
   path: damlc/damlc
   args: ["test"]
   desc: "Run the scenarios in the given DAML file and all dependencies"
+  completion: true
 - name: start
   path: daml-helper/daml-helper
   args: ["start"]
   desc: "Launch Sandbox and Navigator for current DAML project"
+  completion: true
 - name: clean
   path: damlc/damlc
   args: ["clean", "--project-check"]
   desc: "Delete build artifacts from project folder"
+  completion: true
 - name: damlc
   path: damlc/damlc
   desc: "Run the DAML compiler"
+  completion: true
 - name: sandbox
   path: daml-helper/daml-helper
   desc: "Launch the Sandbox"
@@ -50,14 +59,17 @@ commands:
   path: daml-helper/daml-helper
   desc: "Interact with a DAML ledger (experimental)"
   args: ["ledger"]
+  completion: true
 - name: codegen
   path: daml-helper/daml-helper
   desc: "Run a language bindings code generation tool"
   args: ["codegen"]
+  completion: true
 - name: deploy
   path: daml-helper/daml-helper
   desc: "Deploy DAML project to a ledger (experimental)"
   args: ["deploy"]
+  completion: true
 - name: ide
   path: damlc/damlc
   args: ["lax", "ide"]