-- | Some CmdParser actions that add predefined commands.
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



-- | Adds a proper full help command. To obtain the 'CommandDesc' value, see
-- 'UI.Butcher.Monadic.cmdRunParserWithHelpDesc' or
-- 'UI.Butcher.Monadic.IO.mainFromCmdParserWithHelpDesc'.
--
-- > addHelpCommand = addHelpCommandWith
-- >   (pure . PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } . ppHelpShallow)
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)

-- | Adds a proper full help command. In contrast to 'addHelpCommand',
-- this version is a bit more verbose about available subcommands as it
-- includes their synopses.
--
-- To obtain the 'CommandDesc' value, see
-- 'UI.Butcher.Monadic.cmdRunParserWithHelpDesc' or
-- 'UI.Butcher.Monadic.IO.mainFromCmdParserWithHelpDesc'.
--
-- > addHelpCommand2 = addHelpCommandWith
-- >   (pure . PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } . ppHelpDepthOne)
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)

-- | Adds a proper full help command, using the specified function to turn
-- the relevant subcommand's 'CommandDesc' into a String.
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

-- | Adds a help command that prints help for the command currently in context.
--
-- This version does _not_ include further childcommands, i.e. "help foo" will
-- not print the help for subcommand "foo".
--
-- This also yields slightly different output depending on if it is used
-- before or after adding other subcommands. In general 'addHelpCommand'
-- should be preferred.
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

-- | Prints the raw CommandDesc structure.
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)

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

-- | 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' :: (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
      ]