module Byline.Shell
(
Shell (..),
runShell,
shellHelp,
shellCompletion,
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
data Shell a = Shell
{
forall a. Shell a -> ParserPrefs
shellPrefs :: O.ParserPrefs,
forall a. Shell a -> ParserInfo a
shellInfo :: O.ParserInfo a,
forall a. Shell a -> Stylized Text
shellPrompt :: Stylized Text
}
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 ()
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)
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
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
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
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)
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)
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
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
data ScanState = ScanState
{ ScanState -> String
scanResult :: [Char],
ScanState -> Bool
scanEscape :: Bool
}
quoteScanner ::
Char ->
ScanState ->
Char ->
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)