-- |
--
-- 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.
    Shell a -> ParserPrefs
shellPrefs :: O.ParserPrefs,
    -- | The shell parser wrapped in a 'O.ParserInfo'.  This is
    -- generally created with the 'O.info' function.
    Shell a -> ParserInfo a
shellInfo :: O.ParserInfo a,
    -- | The prompt to display.
    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 :: (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 <- Stylized Text -> Maybe Text -> m Text
forall (m :: * -> *) a.
(MonadByline m, ToStylizedText a) =>
a -> Maybe Text -> m Text
askLn Stylized Text
shellPrompt Maybe Text
forall a. Maybe a
Nothing
  [Text]
words <- Text -> m [Text]
forall (m :: * -> *). MonadByline m => Text -> m [Text]
shellSplit Text
input
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
words) ([String] -> m ()
go ((Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
forall a. ToString a => a -> String
toString [Text]
words))
  where
    go :: [String] -> m ()
go [String]
words = do
      case ParserPrefs -> ParserInfo a -> [String] -> ParserResult a
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 = (String, ExitCode) -> String
forall a b. (a, b) -> a
fst (ParserFailure ParserHelp -> String -> (String, ExitCode)
O.renderFailure ParserFailure ParserHelp
help String
"")
          Stylized Text -> m ()
forall (m :: * -> *) a.
(MonadByline m, ToStylizedText a) =>
a -> m ()
sayLn (Text -> Stylized Text
text (Text -> Stylized Text) -> Text -> Stylized Text
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. ToText a => a -> Text
toText String
str)
        O.CompletionInvoked CompletionResult
_ ->
          () -> m ()
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 :: 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 = ParserPrefs
-> ParserInfo a
-> ParseError
-> [Context]
-> ParserFailure ParserHelp
forall a.
ParserPrefs
-> ParserInfo a
-> ParseError
-> [Context]
-> ParserFailure ParserHelp
O.parserFailure ParserPrefs
shellPrefs ParserInfo a
shellInfo (Maybe String -> ParseError
O.ShowHelpText Maybe String
forall a. Maybe a
Nothing) [Context]
forall a. Monoid a => a
mempty
      s :: String
s = (String, ExitCode) -> String
forall a b. (a, b) -> a
fst (ParserFailure ParserHelp -> String -> (String, ExitCode)
O.renderFailure ParserFailure ParserHelp
h String
"")
  Stylized Text -> m ()
forall (m :: * -> *) a.
(MonadByline m, ToStylizedText a) =>
a -> m ()
sayLn (Text -> Stylized Text
text (Text -> Stylized Text) -> Text -> Stylized Text
forall a b. (a -> b) -> a -> b
$ String -> Text
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 :: 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 (Char -> Bool) -> (Bool -> Bool) -> Char -> Bool
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 CompLoc -> [Text] -> CompletionFunc m
forall (m :: * -> *).
Applicative m =>
CompLoc -> [Text] -> CompletionFunc m
completionFromList CompLoc
CompHead (HashMap Text [OptName] -> [Text]
forall t a b. (IsList t, Item t ~ (a, b)) => t -> [a]
keys HashMap Text [OptName]
commands) (Text, Text)
input
    else CompLoc -> [Text] -> CompletionFunc m
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 = [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Text] -> [Text]) -> Maybe [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ do
      Text
cmd <- Text -> [Text]
Text.words Text
left [Text] -> ([Text] -> Maybe Text) -> Maybe Text
forall a b. a -> (a -> b) -> b
& (NonEmpty Text -> Text) -> [Text] -> Maybe Text
forall a b. (NonEmpty a -> b) -> [a] -> Maybe b
viaNonEmpty NonEmpty Text -> Text
forall (f :: * -> *) a. IsNonEmpty f a a "head" => f a -> a
head
      [OptName]
names <- Key (HashMap Text [OptName])
-> HashMap Text [OptName] -> Maybe (Val (HashMap Text [OptName]))
forall t. StaticMap t => Key t -> t -> Maybe (Val t)
lookup Text
Key (HashMap Text [OptName])
cmd HashMap Text [OptName]
commands
      [Text] -> Maybe [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> Maybe [Text]) -> [Text] -> Maybe [Text]
forall a b. (a -> b) -> a -> b
$
        ((OptName -> Text) -> [OptName] -> [Text])
-> [OptName] -> (OptName -> Text) -> [Text]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (OptName -> Text) -> [OptName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [OptName]
names ((OptName -> Text) -> [Text]) -> (OptName -> Text) -> [Text]
forall a b. (a -> b) -> a -> b
$ \case
          O.OptShort Char
c -> String -> Text
forall a. ToText a => a -> Text
toText [Char
'-', Char
c]
          O.OptLong String
s -> Text
"--" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
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 =
      [Item (HashMap Text [OptName])] -> HashMap Text [OptName]
forall l. IsList l => [Item l] -> l
fromList ([Item (HashMap Text [OptName])] -> HashMap Text [OptName])
-> [Item (HashMap Text [OptName])] -> HashMap Text [OptName]
forall a b. (a -> b) -> a -> b
$
        [[(Text, [OptName])]] -> [(Text, [OptName])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Text, [OptName])]] -> [(Text, [OptName])])
-> [[(Text, [OptName])]] -> [(Text, [OptName])]
forall a b. (a -> b) -> a -> b
$
          (forall x. ArgumentReachability -> Option x -> [(Text, [OptName])])
-> Parser a -> [[(Text, [OptName])]]
forall b a.
(forall x. ArgumentReachability -> Option x -> b)
-> Parser a -> [b]
O.mapParser
            ((Option x -> [(Text, [OptName])])
-> ArgumentReachability -> Option x -> [(Text, [OptName])]
forall a b. a -> b -> a
const Option x -> [(Text, [OptName])]
forall a. Option a -> [(Text, [OptName])]
nameAndFlags)
            (ParserInfo a -> Parser a
forall a. ParserInfo a -> Parser a
O.infoParser (ParserInfo a -> Parser a) -> ParserInfo a -> Parser a
forall a b. (a -> b) -> a -> b
$ Shell a -> ParserInfo a
forall a. Shell a -> ParserInfo a
shellInfo Shell a
shell)
      where
        nameAndFlags :: Option a -> [(Text, [OptName])]
nameAndFlags Option a
opt =
          case Option a -> OptReader a
forall a. Option a -> OptReader a
O.optMain Option a
opt of
            O.CmdReader Maybe String
_ [String]
cmds String -> Maybe (ParserInfo a)
p -> ((String -> (Text, [OptName])) -> [String] -> [(Text, [OptName])]
forall a b. (a -> b) -> [a] -> [b]
`map` [String]
cmds) ((String -> (Text, [OptName])) -> [(Text, [OptName])])
-> (String -> (Text, [OptName])) -> [(Text, [OptName])]
forall a b. (a -> b) -> a -> b
$ \String
cmd ->
              ( String -> Text
forall a. ToText a => a -> Text
toText String
cmd,
                [OptName]
-> (ParserInfo a -> [OptName]) -> Maybe (ParserInfo a) -> [OptName]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                  []
                  ( ParserInfo a -> Parser a
forall a. ParserInfo a -> Parser a
O.infoParser
                      (ParserInfo a -> Parser a)
-> (Parser a -> [OptName]) -> ParserInfo a -> [OptName]
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (forall x. ArgumentReachability -> Option x -> [OptName])
-> Parser a -> [[OptName]]
forall b a.
(forall x. ArgumentReachability -> Option x -> b)
-> Parser a -> [b]
O.mapParser ((Option x -> [OptName])
-> ArgumentReachability -> Option x -> [OptName]
forall a b. a -> b -> a
const Option x -> [OptName]
forall a. Option a -> [OptName]
optnames)
                      (Parser a -> [[OptName]])
-> ([[OptName]] -> [OptName]) -> Parser a -> [OptName]
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> [[OptName]] -> [OptName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                  )
                  (String -> Maybe (ParserInfo a)
p String
cmd)
              )
            OptReader a
_ -> [(Text, [OptName])]
forall a. Monoid a => a
mempty
        optnames :: Option a -> [OptName]
optnames Option a
opt =
          case Option a -> OptReader a
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
_ -> [OptName]
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 :: 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 [Text] -> m [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        else case Parser [Text] -> Text -> Either String [Text]
forall a. Parser a -> Text -> Either String a
Atto.parseOnly Parser [Text]
go Text
input of
          Left String
e -> do
            Stylized Text -> m ()
forall (m :: * -> *) a.
(MonadByline m, ToStylizedText a) =>
a -> m ()
sayLn ((Stylized Text
"invalid input" Stylized Text -> Stylized Text -> Stylized Text
forall a. Semigroup a => a -> a -> a
<> Color -> Stylized Text
fg Color
red) Stylized Text -> Stylized Text -> Stylized Text
forall a. Semigroup a => a -> a -> a
<> Stylized Text
": " Stylized Text -> Stylized Text -> Stylized Text
forall a. Semigroup a => a -> a -> a
<> Text -> Stylized Text
text (String -> Text
forall a. ToText a => a -> Text
toText String
e))
            [Text] -> m [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
          Right [Text]
ws ->
            [Text] -> m [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text]
ws
  where
    go :: Atto.Parser [Text]
    go :: Parser [Text]
go = Parser Text Text -> Parser [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Atto.many1 (Parser Text Text
bare Parser Text Text -> Parser Text Text -> Parser Text Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Text
quoted) Parser [Text] -> Parser Text () -> Parser [Text]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
expectEndOfInput

    expectEndOfInput :: Atto.Parser ()
    expectEndOfInput :: Parser Text ()
expectEndOfInput = (Parser Text ()
forall t. Chunk t => Parser t ()
Atto.endOfInput Parser Text () -> Parser Text () -> Parser Text ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>) (Parser Text () -> Parser Text ())
-> Parser Text () -> Parser Text ()
forall a b. (a -> b) -> a -> b
$ do
      String
leftover <- Parser Text Char -> Parser Text String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Atto.many1 Parser Text Char
Atto.anyChar
      String -> Parser Text ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"unexpected input: " String -> String -> String
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 = (Parser Text Text -> String -> Parser Text Text
forall i a. Parser i a -> String -> Parser i a
Atto.<?> String
"unquoted word") (Parser Text Text -> Parser Text Text)
-> Parser Text Text -> Parser Text Text
forall a b. (a -> b) -> a -> b
$ do
      String
word <- Parser Text Char -> Parser Text String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Atto.many1 Parser Text Char
bareChar
      Parser Text String -> Parser Text ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text Char -> Parser Text String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Atto.many1 Parser Text Char
Atto.space) Parser Text () -> Parser Text () -> Parser Text ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text ()
forall t. Chunk t => Parser t ()
Atto.endOfInput
      Text -> Parser Text Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Text
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 <- Parser Text Char -> Parser Text String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser Text Char
bareChar
      Char
quote <- (Char -> Bool) -> Parser Text Char
Atto.satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"') Parser Text Char -> String -> Parser Text 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
..}) <-
        ScanState
-> (ScanState -> Char -> Maybe ScanState)
-> Parser (Text, ScanState)
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)
      Bool -> Parser Text () -> Parser Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
scanEscape (String -> Parser Text ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expecting a character after a backslash")
      Char
_ <- Char -> Parser Text Char
Atto.char Char
quote Parser Text Char -> String -> Parser Text Char
forall i a. Parser i a -> String -> Parser i a
Atto.<?> String
"closing quotation character"
      let str :: Text
str = String -> Text
forall a. ToText a => a -> Text
toText String
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. ToText a => a -> Text
toText (String -> String
forall a. [a] -> [a]
reverse String
scanResult)
      Bool
end <-
        (Parser Text Char -> Parser Text String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Atto.many1 Parser Text Char
Atto.space Parser Text String -> Bool -> Parser Text Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True)
          Parser Text Bool -> Parser Text Bool -> Parser Text Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser Text ()
forall t. Chunk t => Parser t ()
Atto.endOfInput Parser Text () -> Bool -> Parser Text Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True)
          Parser Text Bool -> Parser Text Bool -> Parser Text Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parser Text Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      if Bool
end then Text -> Parser Text Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
str else (Text
str Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> Parser Text Text -> Parser Text Text
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 Text Char
bareChar = do
      Char
char <-
        (Char -> Bool) -> Parser Text Char
Atto.satisfy
          ( \Char
c ->
              Bool -> Bool
not (Char -> Bool
isSpace Char
c)
                Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\''
                Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"'
                Bool -> Bool -> Bool
&& Char -> Bool
isPrint Char
c
          )
      if Char
char Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\'
        then Parser Text Char
Atto.anyChar Parser Text Char -> String -> Parser Text Char
forall i a. Parser i a -> String -> Parser i a
Atto.<?> String
"escaped character"
        else Char -> Parser Text Char
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 = ScanState -> Maybe ScanState
forall a. a -> Maybe a
Just (String -> Bool -> ScanState
ScanState (Char
input Char -> String -> String
forall a. a -> [a] -> [a]
: String
scanResult) Bool
False)
  | Char
input Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' = ScanState -> Maybe ScanState
forall a. a -> Maybe a
Just (String -> Bool -> ScanState
ScanState String
scanResult Bool
True)
  | Char
input Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
quote = Maybe ScanState
forall a. Maybe a
Nothing
  | Bool
otherwise = ScanState -> Maybe ScanState
forall a. a -> Maybe a
Just (String -> Bool -> ScanState
ScanState (Char
input Char -> String -> String
forall a. a -> [a] -> [a]
: String
scanResult) Bool
False)