Add bash-completion support (experimental)

src/UI/Butcher/Monadic.hs

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

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

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

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

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 :: [String] -> Param p
-paramSuggestions ss = mempty { _param_suggestions = Just ss }
+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
+ where
-    desc :: PartDesc
+  desc :: PartDesc
-    desc = (maybe id PartWithHelp $ _param_help par)
+  desc =
-         $ PartVariable name
+    addSuggestion (_param_suggestions par)
-    parseF :: Input -> Maybe (String, Input)
+      $ (maybe id PartWithHelp $ _param_help par)
-    parseF (InputString str) = Just (str, InputString "")
+      $ PartVariable name
-    parseF (InputArgs args)  = Just (List.unwords args, InputArgs [])
+  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 [])
+

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
+  PartDefault    _   p -> PP.brackets <$> rec p
-  PartSuggestion s p -> rec p <&> \d ->
+  PartSuggestion sgs p -> rec p <&> \d ->
-    PP.parens $ PP.fcat $ PP.punctuate (PP.text "|") $ fmap PP.text s ++ [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

src/UI/Butcher/Monadic/Types.hs

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