From 327f596d1d3c303de4a8a45aa7aa375ac8a2cd51 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 11 Jan 2018 21:43:13 +0100 Subject: [PATCH] Add bash-completion support (experimental) --- src/UI/Butcher/Monadic.hs | 2 + src/UI/Butcher/Monadic/BuiltinCommands.hs | 70 +++++++++++++++++++++ src/UI/Butcher/Monadic/Interactive.hs | 58 ++++++++++++++++- src/UI/Butcher/Monadic/Internal/Types.hs | 14 ++++- src/UI/Butcher/Monadic/Param.hs | 76 ++++++++++++++++++----- src/UI/Butcher/Monadic/Pretty.hs | 10 ++- src/UI/Butcher/Monadic/Types.hs | 1 + 7 files changed, 209 insertions(+), 22 deletions(-) diff --git a/src/UI/Butcher/Monadic.hs b/src/UI/Butcher/Monadic.hs index 4126187..35f527b 100644 --- a/src/UI/Butcher/Monadic.hs +++ b/src/UI/Butcher/Monadic.hs @@ -30,6 +30,8 @@ module UI.Butcher.Monadic , addHelpCommand , addHelpCommand2 , addButcherDebugCommand + , addShellCompletionCommand + , addShellCompletionCommand' , mapOut ) where diff --git a/src/UI/Butcher/Monadic/BuiltinCommands.hs b/src/UI/Butcher/Monadic/BuiltinCommands.hs index ff7e229..4d3ba8e 100644 --- a/src/UI/Butcher/Monadic/BuiltinCommands.hs +++ b/src/UI/Butcher/Monadic/BuiltinCommands.hs @@ -4,6 +4,8 @@ module UI.Butcher.Monadic.BuiltinCommands , addHelpCommand2 , addHelpCommandShallow , addButcherDebugCommand + , addShellCompletionCommand + , addShellCompletionCommand' ) where @@ -22,6 +24,7 @@ import UI.Butcher.Monadic.Internal.Types import UI.Butcher.Monadic.Internal.Core import UI.Butcher.Monadic.Pretty import UI.Butcher.Monadic.Param +import UI.Butcher.Monadic.Interactive import System.IO @@ -94,3 +97,70 @@ addButcherDebugCommand = addCmd "butcherdebug" $ do addCmdImpl $ do print $ maybe undefined snd (_cmd_mParent desc) +-- | Adds the "completion" command and several subcommands. +-- +-- This command can be used in the following manner: +-- +-- > $ source <(foo completion bash-script foo) +addShellCompletionCommand + :: CmdParser Identity (IO ()) () -> CmdParser Identity (IO ()) () +addShellCompletionCommand mainCmdParser = do + addCmdHidden "completion" $ do + addCmdSynopsis "utilites to enable bash-completion" + addCmd "bash-script" $ do + addCmdSynopsis "generate a bash script for completion functionality" + exeName <- addParamString "EXENAME" mempty + addCmdImpl $ do + putStr $ completionScriptBash exeName + addCmd "bash-gen" $ do + addCmdSynopsis + "generate possible completions for given input arguments" + rest <- addParamRestOfInputRaw "REALCOMMAND" mempty + addCmdImpl $ do + let (cdesc, remaining, _result) = + runCmdParserExt Nothing rest mainCmdParser + let + compls = shellCompletionWords (inputString rest) + cdesc + (inputString remaining) + let lastWord = + reverse $ takeWhile (not . Char.isSpace) $ reverse $ inputString + rest + putStrLn $ List.intercalate "\t" $ compls <&> \case + CompletionString s -> s + CompletionFile -> "$(compgen -f -- " ++ lastWord ++ ")" + CompletionDirectory -> "$(compgen -d -- " ++ lastWord ++ ")" + where + inputString (InputString s ) = s + inputString (InputArgs as) = List.unwords as + +-- | Adds the "completion" command and several subcommands +-- +-- This command can be used in the following manner: +-- +-- > $ source <(foo completion bash-script foo) +addShellCompletionCommand' + :: (CommandDesc out -> CmdParser Identity (IO ()) ()) + -> CmdParser Identity (IO ()) () +addShellCompletionCommand' f = addShellCompletionCommand (f emptyCommandDesc) + +completionScriptBash :: String -> String +completionScriptBash exeName = + List.unlines + $ [ "function _" ++ exeName ++ "()" + , "{" + , " local IFS=$'\\t'" + , " COMPREPLY=()" + , " local result=$(" + ++ exeName + ++ " completion bash-gen \"${COMP_WORDS[@]:1}\")" + , " for r in ${result[@]}; do" + , " local IFS=$'\\n\\t '" + , " for s in $(eval echo ${r}); do" + , " COMPREPLY+=(${s})" + , " done" + , " done" + , "}" + , "complete -F _" ++ exeName ++ " " ++ exeName + ] + diff --git a/src/UI/Butcher/Monadic/Interactive.hs b/src/UI/Butcher/Monadic/Interactive.hs index 6e95633..b2b9c7a 100644 --- a/src/UI/Butcher/Monadic/Interactive.hs +++ b/src/UI/Butcher/Monadic/Interactive.hs @@ -2,6 +2,7 @@ -- e.g. a REPL. module UI.Butcher.Monadic.Interactive ( simpleCompletion + , shellCompletionWords , interactiveHelpDoc , partDescStrings ) @@ -57,6 +58,39 @@ simpleCompletion line cdesc pcRest = ] +-- | Derives a list of completion items from a given input string and a given +-- 'CommandDesc'. Considers potential subcommands and where available the +-- completion info present in 'PartDesc's. +-- +-- See 'addShellCompletion' which uses this. +shellCompletionWords + :: String -- ^ input string + -> CommandDesc () -- ^ CommandDesc obtained on that input string + -> String -- ^ "remaining" input after the last successfully parsed + -- subcommand. See 'UI.Butcher.Monadic.runCmdParserExt'. + -> [CompletionItem] +shellCompletionWords line cdesc pcRest = choices + where + _nameDesc = case _cmd_mParent cdesc of + Nothing -> cdesc + Just (_, parent) | null pcRest -> parent + Just{} -> cdesc + lastWord = reverse $ takeWhile (not . Char.isSpace) $ reverse $ line + choices :: [CompletionItem] + choices = join + [ [ CompletionString r + | (Just r, _) <- Data.Foldable.toList (_cmd_children cdesc) + , lastWord `isPrefixOf` r + ] + , [ c + | c <- partDescCompletions =<< _cmd_parts cdesc + , case c of + CompletionString s -> lastWord `isPrefixOf` s + _ -> True + ] + ] + + -- | Produces a 'PP.Doc' as a hint for the user during interactive command -- input. Takes the current (incomplete) prompt line into account. For example -- when you have commands (among others) \'config set-email\' and @@ -124,10 +158,32 @@ partDescStrings = \case PartSeq [] -> [] PartSeq (x:_) -> partDescStrings x PartDefault _ x -> partDescStrings x - PartSuggestion ss x -> [ s | s <- ss ] ++ partDescStrings x + PartSuggestion ss x -> [ s | CompletionString s <- ss ] ++ partDescStrings x PartRedirect _ x -> partDescStrings x PartReorder xs -> xs >>= partDescStrings PartMany x -> partDescStrings x PartWithHelp _h x -> partDescStrings x -- TODO: handle help PartHidden{} -> [] + +-- | Obtains a list of "expected"/potential strings for a command part +-- described in the 'PartDesc'. In constrast to the 'simpleCompletion' +-- function this function does not take into account any current input, and +-- consequently the output elements can in general not be appended to partial +-- input to form valid input. +partDescCompletions :: PartDesc -> [CompletionItem] +partDescCompletions = \case + PartLiteral s -> [CompletionString s] + PartVariable _ -> [] + -- TODO: we could handle seq of optional and such much better + PartOptional x -> partDescCompletions x + PartAlts alts -> alts >>= partDescCompletions + PartSeq [] -> [] + PartSeq (x:_) -> partDescCompletions x + PartDefault _ x -> partDescCompletions x + PartSuggestion ss x -> ss ++ partDescCompletions x + PartRedirect _ x -> partDescCompletions x + PartReorder xs -> xs >>= partDescCompletions + PartMany x -> partDescCompletions x + PartWithHelp _h x -> partDescCompletions x -- TODO: handle help + PartHidden{} -> [] diff --git a/src/UI/Butcher/Monadic/Internal/Types.hs b/src/UI/Butcher/Monadic/Internal/Types.hs index 4153992..70c849e 100644 --- a/src/UI/Butcher/Monadic/Internal/Types.hs +++ b/src/UI/Butcher/Monadic/Internal/Types.hs @@ -23,6 +23,7 @@ module UI.Butcher.Monadic.Internal.Types , addSuggestion , ManyUpperBound (..) , Visibility (..) + , CompletionItem (..) ) where @@ -140,7 +141,7 @@ data PartDesc | PartSeq [PartDesc] | PartDefault String -- default representation PartDesc - | PartSuggestion [String] PartDesc + | PartSuggestion [CompletionItem] PartDesc | PartRedirect String -- name for the redirection PartDesc | PartReorder [PartDesc] @@ -149,10 +150,18 @@ data PartDesc | PartHidden PartDesc deriving Show -addSuggestion :: Maybe [String] -> PartDesc -> PartDesc +addSuggestion :: Maybe [CompletionItem] -> PartDesc -> PartDesc addSuggestion Nothing = id addSuggestion (Just sugs) = PartSuggestion sugs + +data CompletionItem + = CompletionString String + | CompletionDirectory + | CompletionFile + deriving Show + + {- command documentation structure 1. terminals. e.g. "--dry-run" @@ -174,6 +183,7 @@ deriving instance Functor CommandDesc -- +-- | Empty 'CommandDesc' value. Mostly for butcher-internal usage. emptyCommandDesc :: CommandDesc out emptyCommandDesc = CommandDesc Nothing Nothing Nothing [] Nothing mempty Visible diff --git a/src/UI/Butcher/Monadic/Param.hs b/src/UI/Butcher/Monadic/Param.hs index 3d5f46f..cb1b8a5 100644 --- a/src/UI/Butcher/Monadic/Param.hs +++ b/src/UI/Butcher/Monadic/Param.hs @@ -9,6 +9,8 @@ module UI.Butcher.Monadic.Param , paramHelpStr , paramDefault , paramSuggestions + , paramFile + , paramDirectory , addParamRead , addParamReadOpt , addParamString @@ -18,6 +20,7 @@ module UI.Butcher.Monadic.Param , addParamNoFlagStringOpt , addParamNoFlagStrings , addParamRestOfInput + , addParamRestOfInputRaw , -- * Deprecated for more consistent naming addReadParam , addReadParamOpt @@ -49,7 +52,7 @@ import UI.Butcher.Monadic.Internal.Core data Param p = Param { _param_default :: Maybe p , _param_help :: Maybe PP.Doc - , _param_suggestions :: Maybe [p] + , _param_suggestions :: Maybe [CompletionItem] } instance Monoid (Param p) where @@ -77,8 +80,17 @@ paramDefault :: p -> Param p paramDefault d = mempty { _param_default = Just d } -- | Create a 'Param' with just a list of suggestion values. -paramSuggestions :: [p] -> Param p -paramSuggestions ss = mempty { _param_suggestions = Just ss } +paramSuggestions :: [String] -> Param p +paramSuggestions ss = + mempty { _param_suggestions = Just $ CompletionString <$> ss } + +-- | Create a 'Param' that is a file path. +paramFile :: Param p +paramFile = mempty { _param_suggestions = Just [CompletionFile] } + +-- | Create a 'Param' that is a directory path. +paramDirectory :: Param p +paramDirectory = mempty { _param_suggestions = Just [CompletionDirectory] } -- | Add a parameter to the 'CmdParser' by making use of a 'Text.Read.Read' -- instance. Take care not to use this to return Strings unless you really @@ -99,7 +111,8 @@ addReadParam :: forall f out a addReadParam name par = addCmdPart desc parseF where desc :: PartDesc - desc = (maybe id PartWithHelp $ _param_help par) + desc = addSuggestion (_param_suggestions par) + $ (maybe id PartWithHelp $ _param_help par) $ (maybe id (PartDefault . show) $ _param_default par) $ PartVariable name parseF :: String -> Maybe (a, String) @@ -124,7 +137,8 @@ addReadParamOpt :: forall f out a addReadParamOpt name par = addCmdPart desc parseF where desc :: PartDesc - desc = PartOptional + desc = addSuggestion (_param_suggestions par) + $ PartOptional $ (maybe id PartWithHelp $ _param_help par) $ PartVariable name parseF :: String -> Maybe (Maybe a, String) @@ -180,7 +194,8 @@ addStringParamOpt addStringParamOpt name par = addCmdPartInp desc parseF where desc :: PartDesc - desc = PartOptional + desc = addSuggestion (_param_suggestions par) + $ PartOptional $ (maybe id PartWithHelp $ _param_help par) $ PartVariable name parseF :: Input -> Maybe (Maybe String, Input) @@ -213,7 +228,10 @@ addStringParams addStringParams name par = addCmdPartManyInp ManyUpperBoundN desc parseF where desc :: PartDesc - desc = (maybe id PartWithHelp $ _param_help par) $ PartVariable name + desc = + addSuggestion (_param_suggestions par) + $ (maybe id PartWithHelp $ _param_help par) + $ PartVariable name parseF :: Input -> Maybe (String, Input) parseF (InputString str) = case break Char.isSpace $ dropWhile Char.isSpace str of @@ -284,7 +302,10 @@ addParamNoFlagStrings addParamNoFlagStrings name par = addCmdPartManyInp ManyUpperBoundN desc parseF where desc :: PartDesc - desc = (maybe id PartWithHelp $ _param_help par) $ PartVariable name + desc = + addSuggestion (_param_suggestions par) + $ (maybe id PartWithHelp $ _param_help par) + $ PartVariable name parseF :: Input -> Maybe (String, Input) parseF (InputString str) = case break Char.isSpace $ dropWhile Char.isSpace str of @@ -307,15 +328,38 @@ addParamRestOfInput addParamRestOfInput = addRestOfInputStringParam {-# DEPRECATED addRestOfInputStringParam "use 'addParamRestOfInput'" #-} addRestOfInputStringParam - :: forall f out . (Applicative f) + :: forall f out + . (Applicative f) => String -> Param Void -> CmdParser f out String addRestOfInputStringParam name par = addCmdPartInp desc parseF - where - desc :: PartDesc - desc = (maybe id PartWithHelp $ _param_help par) - $ PartVariable name - parseF :: Input -> Maybe (String, Input) - parseF (InputString str) = Just (str, InputString "") - parseF (InputArgs args) = Just (List.unwords args, InputArgs []) + where + desc :: PartDesc + desc = + addSuggestion (_param_suggestions par) + $ (maybe id PartWithHelp $ _param_help par) + $ PartVariable name + parseF :: Input -> Maybe (String, Input) + parseF (InputString str ) = Just (str, InputString "") + parseF (InputArgs args) = Just (List.unwords args, InputArgs []) + + +-- | Add a parameter that consumes _all_ remaining input, returning a raw +-- 'Input' value. +addParamRestOfInputRaw + :: forall f out . (Applicative f) + => String + -> Param Void + -> CmdParser f out Input +addParamRestOfInputRaw name par = addCmdPartInp desc parseF + where + desc :: PartDesc + desc = + addSuggestion (_param_suggestions par) + $ (maybe id PartWithHelp $ _param_help par) + $ PartVariable name + parseF :: Input -> Maybe (Input, Input) + parseF i@InputString{} = Just (i, InputString "") + parseF i@InputArgs{} = Just (i, InputArgs []) + diff --git a/src/UI/Butcher/Monadic/Pretty.hs b/src/UI/Butcher/Monadic/Pretty.hs index 29e7f52..755b7a5 100644 --- a/src/UI/Butcher/Monadic/Pretty.hs +++ b/src/UI/Butcher/Monadic/Pretty.hs @@ -318,9 +318,13 @@ ppPartDescUsage = \case , not (null ds) ] PartSeq ps -> [ PP.fsep ds | let ds = Maybe.mapMaybe rec ps, not (null ds) ] - PartDefault _ p -> PP.brackets <$> rec p - PartSuggestion s p -> rec p <&> \d -> - PP.parens $ PP.fcat $ PP.punctuate (PP.text "|") $ fmap PP.text s ++ [d] + PartDefault _ p -> PP.brackets <$> rec p + PartSuggestion sgs p -> rec p <&> \d -> + PP.parens + $ PP.fcat + $ PP.punctuate (PP.text "|") + $ [ PP.text s | CompletionString s <- sgs ] + ++ [d] PartRedirect s _ -> Just $ PP.text s PartMany p -> rec p <&> (<> PP.text "+") PartWithHelp _ p -> rec p diff --git a/src/UI/Butcher/Monadic/Types.hs b/src/UI/Butcher/Monadic/Types.hs index 9d68943..136c69a 100644 --- a/src/UI/Butcher/Monadic/Types.hs +++ b/src/UI/Butcher/Monadic/Types.hs @@ -8,6 +8,7 @@ module UI.Butcher.Monadic.Types , Input (..) , ParsingError (..) , PartDesc(..) + , emptyCommandDesc ) where