-- |
--
-- Copyright:
--   This file is part of the package byline. It is subject to the
--   license terms in the LICENSE file found in the top-level
--   directory of this distribution and at:
--
--     https://github.com/pjones/byline
--
--   No part of this package, including this file, may be copied,
--   modified, propagated, or distributed except according to the
--   terms contained in the LICENSE file.
--
-- License: BSD-2-Clause
--
-- Interactive shells.
module Byline.Shell
  ( -- * Shell-like Interfaces
    Shell (..),
    runShell,
    shellHelp,
    shellCompletion,

    -- * Re-exports
    module Byline.Completion,
  )
where

import Byline
import Byline.Completion
import qualified Data.Attoparsec.Text as Atto
import Data.Char
import qualified Data.Text as Text
import qualified Options.Applicative as O
import qualified Options.Applicative.Common as O
import qualified Options.Applicative.Types as O
import Relude.Extra.Map

-- | A type that describes how to process user-entered shells.
--
-- @since 1.1.0.0
data Shell a = Shell
  { -- | Optparse-applicative parser preferences.  If you don't have
    -- any specific needs you can use 'O.defaultPrefs' to get the
    -- default parser preferences.
    forall a. Shell a -> ParserPrefs
shellPrefs :: O.ParserPrefs,
    -- | The shell parser wrapped in a 'O.ParserInfo'.  This is
    -- generally created with the 'O.info' function.
    forall a. Shell a -> ParserInfo a
shellInfo :: O.ParserInfo a,
    -- | The prompt to display.
    forall a. Shell a -> Stylized Text
shellPrompt :: Stylized Text
  }

-- | Run a single iteration of the shell.
--
-- @since 1.1.0.0
runShell ::
  MonadByline m =>
  (a -> m ()) ->
  Shell a ->
  m ()
runShell :: forall (m :: * -> *) a.
MonadByline m =>
(a -> m ()) -> Shell a -> m ()
runShell a -> m ()
dispatch Shell {ParserInfo a
ParserPrefs
Stylized Text
shellPrompt :: Stylized Text
shellInfo :: ParserInfo a
shellPrefs :: ParserPrefs
shellPrompt :: forall a. Shell a -> Stylized Text
shellInfo :: forall a. Shell a -> ParserInfo a
shellPrefs :: forall a. Shell a -> ParserPrefs
..} = do
  Text
input <- forall (m :: * -> *) a.
(MonadByline m, ToStylizedText a) =>
a -> Maybe Text -> m Text
askLn Stylized Text
shellPrompt forall a. Maybe a
Nothing
  [Text]
words <- forall (m :: * -> *). MonadByline m => Text -> m [Text]
shellSplit Text
input
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
words) ([String] -> m ()
go (forall a b. (a -> b) -> [a] -> [b]
map forall a. ToString a => a -> String
toString [Text]
words))
  where
    go :: [String] -> m ()
go [String]
words = do
      case forall a. ParserPrefs -> ParserInfo a -> [String] -> ParserResult a
O.execParserPure ParserPrefs
shellPrefs ParserInfo a
shellInfo [String]
words of
        O.Success a
a ->
          a -> m ()
dispatch a
a
        O.Failure ParserFailure ParserHelp
help -> do
          let str :: String
str = forall a b. (a, b) -> a
fst (ParserFailure ParserHelp -> String -> (String, ExitCode)
O.renderFailure ParserFailure ParserHelp
help String
"")
          forall (m :: * -> *) a.
(MonadByline m, ToStylizedText a) =>
a -> m ()
sayLn (Text -> Stylized Text
text forall a b. (a -> b) -> a -> b
$ forall a. ToText a => a -> Text
toText String
str)
        O.CompletionInvoked CompletionResult
_ ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Print a list of shell commands.
--
-- @since 1.1.0.0
shellHelp ::
  MonadByline m =>
  Shell a ->
  m ()
shellHelp :: forall (m :: * -> *) a. MonadByline m => Shell a -> m ()
shellHelp Shell {ParserInfo a
ParserPrefs
Stylized Text
shellPrompt :: Stylized Text
shellInfo :: ParserInfo a
shellPrefs :: ParserPrefs
shellPrompt :: forall a. Shell a -> Stylized Text
shellInfo :: forall a. Shell a -> ParserInfo a
shellPrefs :: forall a. Shell a -> ParserPrefs
..} = do
  let h :: ParserFailure ParserHelp
h = forall a.
ParserPrefs
-> ParserInfo a
-> ParseError
-> [Context]
-> ParserFailure ParserHelp
O.parserFailure ParserPrefs
shellPrefs ParserInfo a
shellInfo (Maybe String -> ParseError
O.ShowHelpText forall a. Maybe a
Nothing) forall a. Monoid a => a
mempty
      s :: String
s = forall a b. (a, b) -> a
fst (ParserFailure ParserHelp -> String -> (String, ExitCode)
O.renderFailure ParserFailure ParserHelp
h String
"")
  forall (m :: * -> *) a.
(MonadByline m, ToStylizedText a) =>
a -> m ()
sayLn (Text -> Stylized Text
text forall a b. (a -> b) -> a -> b
$ forall a. ToText a => a -> Text
toText String
s)

-- | A completion function for shell commands.
--
-- Adds completion for subcommand names and their flags.
--
-- @since 1.1.0.0
shellCompletion :: Applicative m => Shell a -> CompletionFunc m
shellCompletion :: forall (m :: * -> *) a.
Applicative m =>
Shell a -> CompletionFunc m
shellCompletion Shell a
shell input :: (Text, Text)
input@(Text
left, Text
_) = do
  if Text -> Bool
Text.null Text
left Bool -> Bool -> Bool
|| (Char -> Bool) -> Text -> Bool
Text.all (Char -> Bool
isSpace forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Bool -> Bool
not) Text
left
    then forall (m :: * -> *).
Applicative m =>
CompLoc -> [Text] -> CompletionFunc m
completionFromList CompLoc
CompHead (forall t a b. (IsList t, Item t ~ (a, b)) => t -> [a]
keys HashMap Text [OptName]
commands) (Text, Text)
input
    else forall (m :: * -> *).
Applicative m =>
CompLoc -> [Text] -> CompletionFunc m
completionFromList CompLoc
CompTail [Text]
flags (Text, Text)
input
  where
    -- Get a list of flags for the current subcommand.
    flags :: [Text]
    flags :: [Text]
flags = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ do
      Text
cmd <- Text -> [Text]
Text.words Text
left forall a b. a -> (a -> b) -> b
& forall a b. (NonEmpty a -> b) -> [a] -> Maybe b
viaNonEmpty forall (f :: * -> *) a. IsNonEmpty f a a "head" => f a -> a
head
      [OptName]
names <- forall t. StaticMap t => Key t -> t -> Maybe (Val t)
lookup Text
cmd HashMap Text [OptName]
commands
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [OptName]
names forall a b. (a -> b) -> a -> b
$ \case
          O.OptShort Char
c -> forall a. ToText a => a -> Text
toText [Char
'-', Char
c]
          O.OptLong String
s -> Text
"--" forall a. Semigroup a => a -> a -> a
<> forall a. ToText a => a -> Text
toText String
s

    -- A map of command names and their flags.
    commands :: HashMap Text [O.OptName]
    commands :: HashMap Text [OptName]
commands =
      forall l. IsList l => [Item l] -> l
fromList forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
          forall b a.
(forall x. ArgumentReachability -> Option x -> b)
-> Parser a -> [b]
O.mapParser
            (forall a b. a -> b -> a
const forall {a}. Option a -> [(Text, [OptName])]
nameAndFlags)
            (forall a. ParserInfo a -> Parser a
O.infoParser forall a b. (a -> b) -> a -> b
$ forall a. Shell a -> ParserInfo a
shellInfo Shell a
shell)
      where
        nameAndFlags :: Option a -> [(Text, [OptName])]
nameAndFlags Option a
opt =
          case forall a. Option a -> OptReader a
O.optMain Option a
opt of
            O.CmdReader Maybe String
_ [String]
cmds String -> Maybe (ParserInfo a)
p -> (forall a b. (a -> b) -> [a] -> [b]
`map` [String]
cmds) forall a b. (a -> b) -> a -> b
$ \String
cmd ->
              ( forall a. ToText a => a -> Text
toText String
cmd,
                forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                  []
                  ( forall a. ParserInfo a -> Parser a
O.infoParser
                      forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall b a.
(forall x. ArgumentReachability -> Option x -> b)
-> Parser a -> [b]
O.mapParser (forall a b. a -> b -> a
const forall {a}. Option a -> [OptName]
optnames)
                      forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                  )
                  (String -> Maybe (ParserInfo a)
p String
cmd)
              )
            OptReader a
_ -> forall a. Monoid a => a
mempty
        optnames :: Option a -> [OptName]
optnames Option a
opt =
          case forall a. Option a -> OptReader a
O.optMain Option a
opt of
            O.OptReader [OptName]
ns CReader a
_ String -> ParseError
_ -> [OptName]
ns
            O.FlagReader [OptName]
ns a
_ -> [OptName]
ns
            OptReader a
_ -> forall a. Monoid a => a
mempty

-- | Internal function to split user input into words similar to what
-- a POSIX shell does.
shellSplit :: MonadByline m => Text -> m [Text]
shellSplit :: forall (m :: * -> *). MonadByline m => Text -> m [Text]
shellSplit Text
t =
  let input :: Text
input = Text -> Text
Text.strip Text
t
   in if Text -> Bool
Text.null Text
input
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        else case forall a. Parser a -> Text -> Either String a
Atto.parseOnly Parser [Text]
go Text
input of
          Left String
e -> do
            forall (m :: * -> *) a.
(MonadByline m, ToStylizedText a) =>
a -> m ()
sayLn ((Stylized Text
"invalid input" forall a b. a -> (a -> b) -> b
& Color -> Stylized Text -> Stylized Text
fg Color
red) forall a. Semigroup a => a -> a -> a
<> Stylized Text
": " forall a. Semigroup a => a -> a -> a
<> Text -> Stylized Text
text (forall a. ToText a => a -> Text
toText String
e))
            forall (f :: * -> *) a. Applicative f => a -> f a
pure []
          Right [Text]
ws ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text]
ws
  where
    go :: Atto.Parser [Text]
    go :: Parser [Text]
go = forall (f :: * -> *) a. Alternative f => f a -> f [a]
Atto.many1 (Parser Text Text
bare forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Text
quoted) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
expectEndOfInput

    expectEndOfInput :: Atto.Parser ()
    expectEndOfInput :: Parser ()
expectEndOfInput = (forall t. Chunk t => Parser t ()
Atto.endOfInput forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>) forall a b. (a -> b) -> a -> b
$ do
      String
leftover <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
Atto.many1 Parser Char
Atto.anyChar
      forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"unexpected input: " forall a. Semigroup a => a -> a -> a
<> String
leftover)

    -- A bare word (not wrapped in quotes).
    bare :: Atto.Parser Text
    bare :: Parser Text Text
bare = (forall i a. Parser i a -> String -> Parser i a
Atto.<?> String
"unquoted word") forall a b. (a -> b) -> a -> b
$ do
      String
word <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
Atto.many1 Parser Char
bareChar
      forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall (f :: * -> *) a. Alternative f => f a -> f [a]
Atto.many1 Parser Char
Atto.space) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall t. Chunk t => Parser t ()
Atto.endOfInput
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. ToText a => a -> Text
toText String
word)

    -- A run of characters that may have quoted characters.
    --
    -- Just like with the POSIX shell, the quotes don't have to be on
    -- the outsides of the final string.
    quoted :: Atto.Parser Text
    quoted :: Parser Text Text
quoted = do
      String
prefix <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser Char
bareChar
      Char
quote <- (Char -> Bool) -> Parser Char
Atto.satisfy (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
== Char
'\'' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'"') forall i a. Parser i a -> String -> Parser i a
Atto.<?> String
"quote"
      (Text
_, ScanState {Bool
String
scanEscape :: ScanState -> Bool
scanResult :: ScanState -> String
scanEscape :: Bool
scanResult :: String
..}) <-
        forall s. s -> (s -> Char -> Maybe s) -> Parser (Text, s)
Atto.runScanner (String -> Bool -> ScanState
ScanState [] Bool
False) (Char -> ScanState -> Char -> Maybe ScanState
quoteScanner Char
quote)
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
scanEscape (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expecting a character after a backslash")
      Char
_ <- Char -> Parser Char
Atto.char Char
quote forall i a. Parser i a -> String -> Parser i a
Atto.<?> String
"closing quotation character"
      let str :: Text
str = forall a. ToText a => a -> Text
toText String
prefix forall a. Semigroup a => a -> a -> a
<> forall a. ToText a => a -> Text
toText (forall a. [a] -> [a]
reverse String
scanResult)
      Bool
end <-
        (forall (f :: * -> *) a. Alternative f => f a -> f [a]
Atto.many1 Parser Char
Atto.space forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True)
          forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall t. Chunk t => Parser t ()
Atto.endOfInput forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True)
          forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      if Bool
end then forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
str else (Text
str forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Text
quoted

    -- Parse a single character that might be escaped.
    bareChar :: Atto.Parser Char
    bareChar :: Parser Char
bareChar = do
      Char
char <-
        (Char -> Bool) -> Parser Char
Atto.satisfy
          ( \Char
c ->
              Bool -> Bool
not (Char -> Bool
isSpace Char
c)
                Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
'\''
                Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
'"'
                Bool -> Bool -> Bool
&& Char -> Bool
isPrint Char
c
          )
      if Char
char forall a. Eq a => a -> a -> Bool
== Char
'\\'
        then Parser Char
Atto.anyChar forall i a. Parser i a -> String -> Parser i a
Atto.<?> String
"escaped character"
        else forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
char

-- | State needed to scan input looking for a closing quote.
data ScanState = ScanState
  { ScanState -> String
scanResult :: [Char],
    ScanState -> Bool
scanEscape :: Bool
  }

-- | A scanning function that looks for a terminating quote.
quoteScanner ::
  -- | The quote character we are searching for.
  Char ->
  -- | The output of the last invocation.
  ScanState ->
  -- | The current input character.
  Char ->
  -- | 'Just' to continue, 'Nothing' to stop.
  Maybe ScanState
quoteScanner :: Char -> ScanState -> Char -> Maybe ScanState
quoteScanner Char
quote ScanState {Bool
String
scanEscape :: Bool
scanResult :: String
scanEscape :: ScanState -> Bool
scanResult :: ScanState -> String
..} Char
input
  | Bool
scanEscape = forall a. a -> Maybe a
Just (String -> Bool -> ScanState
ScanState (Char
input forall a. a -> [a] -> [a]
: String
scanResult) Bool
False)
  | Char
input forall a. Eq a => a -> a -> Bool
== Char
'\\' = forall a. a -> Maybe a
Just (String -> Bool -> ScanState
ScanState String
scanResult Bool
True)
  | Char
input forall a. Eq a => a -> a -> Bool
== Char
quote = forall a. Maybe a
Nothing
  | Bool
otherwise = forall a. a -> Maybe a
Just (String -> Bool -> ScanState
ScanState (Char
input forall a. a -> [a] -> [a]
: String
scanResult) Bool
False)