hexagoxel
/
butcher
1
0
Fork 0
Code Issues 2 Pull Requests Packages Projects Releases Wiki Activity

Add bash-completion support (experimental)

pull/5/head
Lennart Spitzner 2018-01-11 21:43:13 +01:00
parent a4e80cc8fc
commit 327f596d1d
7 changed files with 209 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/UI/Butcher/Monadic.hs
View File

@ -30,6 +30,8 @@ module UI.Butcher.Monadic
, addHelpCommand
, addHelpCommand2
, addButcherDebugCommand
, addShellCompletionCommand
, addShellCompletionCommand'
, mapOut
)
where

70
src/UI/Butcher/Monadic/BuiltinCommands.hs
View File

@ -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
]

58
src/UI/Butcher/Monadic/Interactive.hs
View File

@ -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{} -> []

14
src/UI/Butcher/Monadic/Internal/Types.hs
View File

@ -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

76
src/UI/Butcher/Monadic/Param.hs
View File

@ -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 [])

10
src/UI/Butcher/Monadic/Pretty.hs
View File

@ -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

1
src/UI/Butcher/Monadic/Types.hs
View File

@ -8,6 +8,7 @@ module UI.Butcher.Monadic.Types
, Input (..)
, ParsingError (..)
, PartDesc(..)
, emptyCommandDesc
)
where