module UI.Butcher.Monadic.BuiltinCommands
( addHelpCommand
, addHelpCommand2
, addHelpCommandWith
, addHelpCommandShallow
, addButcherDebugCommand
, addShellCompletionCommand
, addShellCompletionCommand'
)
where
#include "prelude.inc"
import Control.Monad.Free
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS
import qualified Text.PrettyPrint as PP
import Data.HList.ContainsType
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
addHelpCommand :: Applicative f => CommandDesc a -> CmdParser f (IO ()) ()
addHelpCommand :: CommandDesc a -> CmdParser f (IO ()) ()
addHelpCommand = (CommandDesc a -> IO String)
-> CommandDesc a -> CmdParser f (IO ()) ()
forall (f :: * -> *) a.
Applicative f =>
(CommandDesc a -> IO String)
-> CommandDesc a -> CmdParser f (IO ()) ()
addHelpCommandWith
(String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String)
-> (CommandDesc a -> String) -> CommandDesc a -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Style -> Doc -> String
PP.renderStyle Style
PP.style { ribbonsPerLine :: Float
PP.ribbonsPerLine = 1.0 } (Doc -> String)
-> (CommandDesc a -> Doc) -> CommandDesc a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandDesc a -> Doc
forall a. CommandDesc a -> Doc
ppHelpShallow)
addHelpCommand2 :: Applicative f => CommandDesc a -> CmdParser f (IO ()) ()
addHelpCommand2 :: CommandDesc a -> CmdParser f (IO ()) ()
addHelpCommand2 = (CommandDesc a -> IO String)
-> CommandDesc a -> CmdParser f (IO ()) ()
forall (f :: * -> *) a.
Applicative f =>
(CommandDesc a -> IO String)
-> CommandDesc a -> CmdParser f (IO ()) ()
addHelpCommandWith
(String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String)
-> (CommandDesc a -> String) -> CommandDesc a -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Style -> Doc -> String
PP.renderStyle Style
PP.style { ribbonsPerLine :: Float
PP.ribbonsPerLine = 1.0 } (Doc -> String)
-> (CommandDesc a -> Doc) -> CommandDesc a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandDesc a -> Doc
forall a. CommandDesc a -> Doc
ppHelpDepthOne)
addHelpCommandWith
:: Applicative f
=> (CommandDesc a -> IO String)
-> CommandDesc a
-> CmdParser f (IO ()) ()
addHelpCommandWith :: (CommandDesc a -> IO String)
-> CommandDesc a -> CmdParser f (IO ()) ()
addHelpCommandWith f :: CommandDesc a -> IO String
f desc :: CommandDesc a
desc = String -> CmdParser f (IO ()) () -> CmdParser f (IO ()) ()
forall (f :: * -> *) out.
Applicative f =>
String -> CmdParser f out () -> CmdParser f out ()
addCmd "help" (CmdParser f (IO ()) () -> CmdParser f (IO ()) ())
-> CmdParser f (IO ()) () -> CmdParser f (IO ()) ()
forall a b. (a -> b) -> a -> b
$ do
String -> CmdParser f (IO ()) ()
forall (f :: * -> *) out. String -> CmdParser f out ()
addCmdSynopsis "print help about this command"
String
rest <- String -> Param Void -> CmdParser f (IO ()) String
forall (f :: * -> *) out.
Applicative f =>
String -> Param Void -> CmdParser f out String
addParamRestOfInput "SUBCOMMAND(s)" Param Void
forall a. Monoid a => a
mempty
IO () -> CmdParser f (IO ()) ()
forall out (f :: * -> *). out -> CmdParser f out ()
addCmdImpl (IO () -> CmdParser f (IO ()) ())
-> IO () -> CmdParser f (IO ()) ()
forall a b. (a -> b) -> a -> b
$ do
let restWords :: [String]
restWords = String -> [String]
List.words String
rest
let
descent :: [String] -> CommandDesc a -> CommandDesc a
descent :: [String] -> CommandDesc a -> CommandDesc a
descent [] curDesc :: CommandDesc a
curDesc = CommandDesc a
curDesc
descent (w :: String
w:wr :: [String]
wr) curDesc :: CommandDesc a
curDesc =
case
Maybe String
-> [(Maybe String, CommandDesc a)] -> Maybe (CommandDesc a)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup (String -> Maybe String
forall a. a -> Maybe a
Just String
w) ([(Maybe String, CommandDesc a)] -> Maybe (CommandDesc a))
-> [(Maybe String, CommandDesc a)] -> Maybe (CommandDesc a)
forall a b. (a -> b) -> a -> b
$ Deque (Maybe String, CommandDesc a)
-> [(Maybe String, CommandDesc a)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Data.Foldable.toList (Deque (Maybe String, CommandDesc a)
-> [(Maybe String, CommandDesc a)])
-> Deque (Maybe String, CommandDesc a)
-> [(Maybe String, CommandDesc a)]
forall a b. (a -> b) -> a -> b
$ CommandDesc a -> Deque (Maybe String, CommandDesc a)
forall out.
CommandDesc out -> Deque (Maybe String, CommandDesc out)
_cmd_children CommandDesc a
curDesc
of
Nothing -> CommandDesc a
curDesc
Just child :: CommandDesc a
child -> [String] -> CommandDesc a -> CommandDesc a
forall a. [String] -> CommandDesc a -> CommandDesc a
descent [String]
wr CommandDesc a
child
String
s <- CommandDesc a -> IO String
f (CommandDesc a -> IO String) -> CommandDesc a -> IO String
forall a b. (a -> b) -> a -> b
$ [String] -> CommandDesc a -> CommandDesc a
forall a. [String] -> CommandDesc a -> CommandDesc a
descent [String]
restWords CommandDesc a
desc
String -> IO ()
putStrLn String
s
addHelpCommandShallow :: Applicative f => CmdParser f (IO ()) ()
addHelpCommandShallow :: CmdParser f (IO ()) ()
addHelpCommandShallow = String -> CmdParser f (IO ()) () -> CmdParser f (IO ()) ()
forall (f :: * -> *) out.
Applicative f =>
String -> CmdParser f out () -> CmdParser f out ()
addCmd "help" (CmdParser f (IO ()) () -> CmdParser f (IO ()) ())
-> CmdParser f (IO ()) () -> CmdParser f (IO ()) ()
forall a b. (a -> b) -> a -> b
$ do
CommandDesc ()
desc <- CmdParser f (IO ()) (CommandDesc ())
forall (f :: * -> *) out. CmdParser f out (CommandDesc ())
peekCmdDesc
String
_rest <- String -> Param Void -> CmdParser f (IO ()) String
forall (f :: * -> *) out.
Applicative f =>
String -> Param Void -> CmdParser f out String
addParamRestOfInput "SUBCOMMAND(s)" Param Void
forall a. Monoid a => a
mempty
IO () -> CmdParser f (IO ()) ()
forall out (f :: * -> *). out -> CmdParser f out ()
addCmdImpl (IO () -> CmdParser f (IO ()) ())
-> IO () -> CmdParser f (IO ()) ()
forall a b. (a -> b) -> a -> b
$ do
let parentDesc :: CommandDesc ()
parentDesc = CommandDesc ()
-> ((Maybe String, CommandDesc ()) -> CommandDesc ())
-> Maybe (Maybe String, CommandDesc ())
-> CommandDesc ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe CommandDesc ()
forall a. HasCallStack => a
undefined (Maybe String, CommandDesc ()) -> CommandDesc ()
forall a b. (a, b) -> b
snd (CommandDesc () -> Maybe (Maybe String, CommandDesc ())
forall out.
CommandDesc out -> Maybe (Maybe String, CommandDesc out)
_cmd_mParent CommandDesc ()
desc)
Doc -> IO ()
forall a. Show a => a -> IO ()
print (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ CommandDesc () -> Doc
forall a. CommandDesc a -> Doc
ppHelpShallow (CommandDesc () -> Doc) -> CommandDesc () -> Doc
forall a b. (a -> b) -> a -> b
$ CommandDesc ()
parentDesc
addButcherDebugCommand :: Applicative f => CmdParser f (IO ()) ()
addButcherDebugCommand :: CmdParser f (IO ()) ()
addButcherDebugCommand = String -> CmdParser f (IO ()) () -> CmdParser f (IO ()) ()
forall (f :: * -> *) out.
Applicative f =>
String -> CmdParser f out () -> CmdParser f out ()
addCmd "butcherdebug" (CmdParser f (IO ()) () -> CmdParser f (IO ()) ())
-> CmdParser f (IO ()) () -> CmdParser f (IO ()) ()
forall a b. (a -> b) -> a -> b
$ do
CommandDesc ()
desc <- CmdParser f (IO ()) (CommandDesc ())
forall (f :: * -> *) out. CmdParser f out (CommandDesc ())
peekCmdDesc
IO () -> CmdParser f (IO ()) ()
forall out (f :: * -> *). out -> CmdParser f out ()
addCmdImpl (IO () -> CmdParser f (IO ()) ())
-> IO () -> CmdParser f (IO ()) ()
forall a b. (a -> b) -> a -> b
$ do
CommandDesc () -> IO ()
forall a. Show a => a -> IO ()
print (CommandDesc () -> IO ()) -> CommandDesc () -> IO ()
forall a b. (a -> b) -> a -> b
$ CommandDesc ()
-> ((Maybe String, CommandDesc ()) -> CommandDesc ())
-> Maybe (Maybe String, CommandDesc ())
-> CommandDesc ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe CommandDesc ()
forall a. HasCallStack => a
undefined (Maybe String, CommandDesc ()) -> CommandDesc ()
forall a b. (a, b) -> b
snd (CommandDesc () -> Maybe (Maybe String, CommandDesc ())
forall out.
CommandDesc out -> Maybe (Maybe String, CommandDesc out)
_cmd_mParent CommandDesc ()
desc)
addShellCompletionCommand
:: CmdParser Identity (IO ()) () -> CmdParser Identity (IO ()) ()
addShellCompletionCommand :: CmdParser Identity (IO ()) () -> CmdParser Identity (IO ()) ()
addShellCompletionCommand mainCmdParser :: CmdParser Identity (IO ()) ()
mainCmdParser = do
String
-> CmdParser Identity (IO ()) () -> CmdParser Identity (IO ()) ()
forall (f :: * -> *) out.
Applicative f =>
String -> CmdParser f out () -> CmdParser f out ()
addCmdHidden "completion" (CmdParser Identity (IO ()) () -> CmdParser Identity (IO ()) ())
-> CmdParser Identity (IO ()) () -> CmdParser Identity (IO ()) ()
forall a b. (a -> b) -> a -> b
$ do
String -> CmdParser Identity (IO ()) ()
forall (f :: * -> *) out. String -> CmdParser f out ()
addCmdSynopsis "utilites to enable bash-completion"
String
-> CmdParser Identity (IO ()) () -> CmdParser Identity (IO ()) ()
forall (f :: * -> *) out.
Applicative f =>
String -> CmdParser f out () -> CmdParser f out ()
addCmd "bash-script" (CmdParser Identity (IO ()) () -> CmdParser Identity (IO ()) ())
-> CmdParser Identity (IO ()) () -> CmdParser Identity (IO ()) ()
forall a b. (a -> b) -> a -> b
$ do
String -> CmdParser Identity (IO ()) ()
forall (f :: * -> *) out. String -> CmdParser f out ()
addCmdSynopsis "generate a bash script for completion functionality"
String
exeName <- String -> Param String -> CmdParser Identity (IO ()) String
forall (f :: * -> *) out.
Applicative f =>
String -> Param String -> CmdParser f out String
addParamString "EXENAME" Param String
forall a. Monoid a => a
mempty
IO () -> CmdParser Identity (IO ()) ()
forall out (f :: * -> *). out -> CmdParser f out ()
addCmdImpl (IO () -> CmdParser Identity (IO ()) ())
-> IO () -> CmdParser Identity (IO ()) ()
forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String
completionScriptBash String
exeName
String
-> CmdParser Identity (IO ()) () -> CmdParser Identity (IO ()) ()
forall (f :: * -> *) out.
Applicative f =>
String -> CmdParser f out () -> CmdParser f out ()
addCmd "bash-gen" (CmdParser Identity (IO ()) () -> CmdParser Identity (IO ()) ())
-> CmdParser Identity (IO ()) () -> CmdParser Identity (IO ()) ()
forall a b. (a -> b) -> a -> b
$ do
String -> CmdParser Identity (IO ()) ()
forall (f :: * -> *) out. String -> CmdParser f out ()
addCmdSynopsis
"generate possible completions for given input arguments"
Input
rest <- String -> Param Void -> CmdParser Identity (IO ()) Input
forall (f :: * -> *) out.
Applicative f =>
String -> Param Void -> CmdParser f out Input
addParamRestOfInputRaw "REALCOMMAND" Param Void
forall a. Monoid a => a
mempty
IO () -> CmdParser Identity (IO ()) ()
forall out (f :: * -> *). out -> CmdParser f out ()
addCmdImpl (IO () -> CmdParser Identity (IO ()) ())
-> IO () -> CmdParser Identity (IO ()) ()
forall a b. (a -> b) -> a -> b
$ do
let (cdesc :: CommandDesc ()
cdesc, remaining :: Input
remaining, _result :: Either ParsingError (CommandDesc (IO ()))
_result) =
Maybe String
-> Input
-> CmdParser Identity (IO ()) ()
-> (CommandDesc (), Input,
Either ParsingError (CommandDesc (IO ())))
forall out.
Maybe String
-> Input
-> CmdParser Identity out ()
-> (CommandDesc (), Input, Either ParsingError (CommandDesc out))
runCmdParserExt Maybe String
forall a. Maybe a
Nothing Input
rest CmdParser Identity (IO ()) ()
mainCmdParser
let
compls :: [CompletionItem]
compls = String -> CommandDesc () -> String -> [CompletionItem]
shellCompletionWords (Input -> String
inputString Input
rest)
CommandDesc ()
cdesc
(Input -> String
inputString Input
remaining)
let lastWord :: String
lastWord =
String -> String
forall a. [a] -> [a]
reverse (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
Char.isSpace) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Input -> String
inputString
Input
rest
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
List.unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [CompletionItem]
compls [CompletionItem] -> (CompletionItem -> String) -> [String]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
CompletionString s :: String
s -> String
s
CompletionFile -> "$(compgen -f -- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lastWord String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
CompletionDirectory -> "$(compgen -d -- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lastWord String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
where
inputString :: Input -> String
inputString (InputString s :: String
s ) = String
s
inputString (InputArgs as :: [String]
as) = [String] -> String
List.unwords [String]
as
addShellCompletionCommand'
:: (CommandDesc out -> CmdParser Identity (IO ()) ())
-> CmdParser Identity (IO ()) ()
addShellCompletionCommand' :: (CommandDesc out -> CmdParser Identity (IO ()) ())
-> CmdParser Identity (IO ()) ()
addShellCompletionCommand' f :: CommandDesc out -> CmdParser Identity (IO ()) ()
f = CmdParser Identity (IO ()) () -> CmdParser Identity (IO ()) ()
addShellCompletionCommand (CommandDesc out -> CmdParser Identity (IO ()) ()
f CommandDesc out
forall out. CommandDesc out
emptyCommandDesc)
completionScriptBash :: String -> String
completionScriptBash :: String -> String
completionScriptBash exeName :: String
exeName =
[String] -> String
List.unlines
([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [ "function _" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
exeName String -> String -> String
forall a. [a] -> [a] -> [a]
++ "()"
, "{"
, " local IFS=$'\\n'"
, " COMPREPLY=()"
, " local result=$("
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
exeName
String -> String -> String
forall a. [a] -> [a] -> [a]
++ " completion bash-gen \"${COMP_WORDS[@]:1}\")"
, " for r in ${result[@]}; do"
, " local IFS=$'\\n '"
, " for s in $(eval echo ${r}); do"
, " COMPREPLY+=(${s})"
, " done"
, " done"
, "}"
, "complete -F _" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
exeName String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
exeName
]