diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,13 @@ # Version History +## 1.1.0.0 (October 27, 2020) + + * New `Shell` module for building shell-like interfaces. + + * New completion helper function `completionFromList`. + + * Update dependencies to their latest versions + ## 1.0.0.0 (July 27, 2020) This version is the result of a major refactoring of the code in order diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,14 +5,14 @@ [![Hackage](https://img.shields.io/hackage/v/byline)](https://hackage.haskell.org/package/byline) Byline simplifies writing interactive command-line applications by -building upon [ansi-terminal][] and [haskeline][]. This makes it +building upon [ansi-terminal][] and [haskeline][]. This makes it possible to print messages and prompts that include terminal escape sequences such as colors that are automatically disabled when standard -input is a file. It also means that Byline works on both +input is a file. It also means that Byline works on both POSIX-compatible systems and on Windows. The primary features of Byline include printing messages, prompting -for input, and generating custom menus. It was inspired by the +for input, and generating custom menus. It was inspired by the [highline] Ruby library and the [terminal library][] by Craig Roche. ## Example Using `MonadByline` @@ -33,14 +33,3 @@ ``` ![Demo](doc/demo.png) - -## Interfaces - - * The MTL interface lives in the [`byline`](byline) directory. - - * A `fused-effects` interface is forthcoming. - -[ansi-terminal]: http://hackage.haskell.org/package/ansi-terminal -[haskeline]: https://hackage.haskell.org/package/haskeline -[highline]: https://github.com/JEG2/highline -[terminal library]: https://github.com/cdxr/terminal diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -12,5 +12,9 @@ -- terms contained in the LICENSE file. -- -- License: BSD-2-Clause +module Main where + import Distribution.Simple + +main :: IO () main = defaultMain diff --git a/byline.cabal b/byline.cabal --- a/byline.cabal +++ b/byline.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: byline -version: 1.0.0.0 +version: 1.1.0.0 homepage: https://github.com/pjones/byline bug-reports: https://github.com/pjones/byline/issues license: BSD-2-Clause @@ -11,7 +11,7 @@ category: System, User Interfaces build-type: Simple stability: stable -tested-with: GHC ==8.6.5 || ==8.8.3 || ==8.10.1 +tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 synopsis: Library for creating command-line interfaces (colors, menus, etc.) @@ -42,7 +42,7 @@ > > askLn question (Just "Haskell") . - <> + <> -------------------------------------------------------------------------------- extra-source-files: @@ -70,8 +70,10 @@ DeriveFunctor DeriveTraversable DerivingStrategies + ExistentialQuantification FlexibleContexts FlexibleInstances + FunctionalDependencies GeneralizedNewtypeDeriving InstanceSigs KindSignatures @@ -82,6 +84,7 @@ RankNTypes RecordWildCards ScopedTypeVariables + TupleSections TypeFamilies ghc-options: @@ -92,16 +95,18 @@ -------------------------------------------------------------------------------- common dependencies build-depends: - , ansi-terminal >=0.6 && <0.11 - , base >=4.9 && <5.0 - , colour ^>=2.3 - , exceptions >=0.8 && <0.11 - , free ^>=5.1 - , haskeline ^>=0.8 - , mtl >=2.1 && <2.3 - , relude >=0.6 && <0.8 - , terminfo-hs >=0.1 && <0.3 - , text >=0.11 && <1.3 + , ansi-terminal >=0.6 && <0.12 + , attoparsec ^>=0.13 + , base >=4.9 && <5.0 + , colour ^>=2.3 + , exceptions >=0.8 && <0.11 + , free ^>=5.1 + , haskeline >=0.8 && <0.8.2 + , mtl >=2.1 && <2.3 + , optparse-applicative >=0.16 + , relude >=0.6 && <0.8 + , terminfo-hs >=0.1 && <0.3 + , text >=0.11 && <1.3 mixins: base hiding (Prelude), @@ -123,6 +128,7 @@ Byline.Internal.Stylized Byline.Internal.Types Byline.Menu + Byline.Shell Byline.Simulation ------------------------------------------------------------------------------ @@ -158,6 +164,15 @@ executable menu import: options, dependencies main-is: examples/menu.hs + build-depends: byline + + if !flag(build-examples) + buildable: False + +-------------------------------------------------------------------------------- +executable shell + import: options, dependencies + main-is: examples/shell.hs build-depends: byline if !flag(build-examples) diff --git a/examples/shell.hs b/examples/shell.hs new file mode 100644 --- /dev/null +++ b/examples/shell.hs @@ -0,0 +1,85 @@ +-- | +-- +-- 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 +module Main + ( main, + ) +where + +import Byline +import Byline.Shell +import qualified Data.Text as Text +import qualified Options.Applicative as O + +data Command + = Help + | Echo [Text] + | SetPrompt Text + +parser :: O.Parser Command +parser = + O.hsubparser $ + mconcat + [ O.command "help" (O.info (pure Help) $ O.progDesc "This message"), + O.command "echo" (O.info echoP $ O.progDesc "Print all arguments"), + O.command "set-prompt" (O.info promptP $ O.progDesc "Change the prompt") + ] + where + echoP = + Echo + <$> many + ( O.strArgument $ + mconcat + [ O.metavar "STR", + O.help "A string to print" + ] + ) + promptP = + SetPrompt + <$> O.strArgument + ( mconcat + [ O.metavar "STR", + O.help "Set the prompt to STR" + ] + ) + +dispatch :: + MonadByline m => + MonadState (Shell Command) m => + Command -> + m () +dispatch = \case + Help -> do + shell <- get + shellHelp shell + Echo ts -> + sayLn (text $ Text.intercalate " " ts) + SetPrompt prompt -> + modify' (\s -> s {shellPrompt = text prompt}) + +main :: IO () +main = do + let shell = + Shell + { shellPrefs = O.defaultPrefs, + shellInfo = O.info parser (O.progDesc "Simple shell"), + shellPrompt = "byline> " + } + void $ runBylineT (go shell) + where + go :: MonadByline m => Shell Command -> m () + go shell = do + sayLn (text "Starting shell, use ^D to exit") + pushCompletionFunction (shellCompletion shell) + (`evalStateT` shell) $ forever (get >>= runShell dispatch) diff --git a/examples/simple.hs b/examples/simple.hs --- a/examples/simple.hs +++ b/examples/simple.hs @@ -22,29 +22,34 @@ import qualified Data.Text as Text main :: IO () -main = void $ runBylineT $ do - -- Start with a simple message to standard output: - sayLn ("I can use " <> ("color" <> fg blue) <> "!") +main = void $ + runBylineT $ do + -- Start with a simple message to standard output: + sayLn ("I can use " <> ("color" <> fg blue) <> "!") - -- Get user input with a stylized prompt: - let question = - "What's your favorite " - <> ("language" <> bold <> fg green) - <> "? " - language <- askLn question Nothing + -- When not using any stylized modifiers you can use the `text' + -- helper function to avoid "Ambiguous type variable": + sayLn (text "This is some plain text") - if Text.null language - then Exit.die ("Cat got your tongue?" <> fg magenta) - else sayLn ("I see, you like " <> (text language <> fg red) <> ".") + -- Get user input with a stylized prompt: + let question = + "What's your favorite " + <> ("language" <> bold <> fg green) + <> "? " + language <- askLn question Nothing - -- Keep prompting until a confirmation function indicates that the - -- user's input is sufficient: - let question = - "What's your " - <> ("name" <> fg green <> underline) - <> "? " - name <- askUntil question Nothing (pure . atLeastThreeChars) - sayLn $ "Hey there " <> text name <> fg (rgb 108 113 196) + if Text.null language + then Exit.die ("Cat got your tongue?" <> fg magenta) + else sayLn ("I see, you like " <> (text language <> fg red) <> ".") + + -- Keep prompting until a confirmation function indicates that the + -- user's input is sufficient: + let question = + "What's your " + <> ("name" <> fg green <> underline) + <> "? " + name <- askUntil question Nothing (pure . atLeastThreeChars) + sayLn $ "Hey there " <> text name <> fg (rgb 108 113 196) -- | Example confirmation function that requires the input to be three -- or more characters long. diff --git a/src/Byline.hs b/src/Byline.hs --- a/src/Byline.hs +++ b/src/Byline.hs @@ -57,7 +57,6 @@ import Byline.Internal.Eval (BylineT, MonadByline (..), runBylineT) import qualified Byline.Internal.Prim as Prim import Byline.Internal.Stylized -import Prelude hiding (ask) -- | Output the given stylized text. -- diff --git a/src/Byline/Completion.hs b/src/Byline/Completion.hs --- a/src/Byline/Completion.hs +++ b/src/Byline/Completion.hs @@ -20,6 +20,10 @@ CompletionFunc, Completion (..), + -- * Completion Helpers + CompLoc (..), + completionFromList, + -- * Setting the Active Completion Function pushCompletionFunction, popCompletionFunction, @@ -29,6 +33,8 @@ import Byline.Internal.Completion import Byline.Internal.Eval (MonadByline (..)) import qualified Byline.Internal.Prim as Prim +import Data.Char (isSpace) +import qualified Data.Text as Text -- | Add a 'CompletionFunc' to the stack. -- @@ -41,6 +47,56 @@ -- @since 1.0.0.0 popCompletionFunction :: MonadByline m => m () popCompletionFunction = liftByline Prim.popCompFunc + +-- | Type to describe where completions are allowed. +-- +-- @since 1.1.0.0 +data CompLoc + = -- | Only complete the first word of input. + CompHead + | -- | Complete any word except the first. + CompTail + | -- | Perform completion anywhere in the input. + CompAny + +-- | Generate a completion function that uses the given list as the +-- completion candidates. +-- +-- @since 1.1.0.0 +completionFromList :: + forall m. + Applicative m => + -- | Where to allow completion. + CompLoc -> + -- | List of completion candidates. + [Text] -> + -- | The generated completion function. + CompletionFunc m +completionFromList loc ts (left, right) = + case loc of + CompHead -> + if Text.null left || Text.all (isSpace >>> not) left + then go (left, right) + else pure (mempty, mempty) + CompTail -> + if Text.any isSpace left + then completeLastWord (left, right) + else pure (mempty, mempty) + CompAny -> + completeLastWord (left, right) + where + go :: CompletionFunc m + go (left, _) = + if Text.null left + then pure ("", completions ts) + else pure ("", completions (filter (Text.isPrefixOf left) ts)) + completeLastWord :: CompletionFunc m + completeLastWord (left, right) = + let word = Text.takeWhileEnd (isSpace >>> not) left + prefix = Text.dropEnd (Text.length word) left + in go (word, right) <&> first (const prefix) + completions :: [Text] -> [Completion] + completions = map (\t -> Completion t t True) -- $use -- diff --git a/src/Byline/Exit.hs b/src/Byline/Exit.hs --- a/src/Byline/Exit.hs +++ b/src/Byline/Exit.hs @@ -56,9 +56,9 @@ let msg = mconcat [ text name, - ": ", + text ": ", toStylizedText a, - "\n" + text "\n" ] mode <- defaultRenderMode stderr diff --git a/src/Byline/Internal/Color.hs b/src/Byline/Internal/Color.hs --- a/src/Byline/Internal/Color.hs +++ b/src/Byline/Internal/Color.hs @@ -158,8 +158,8 @@ term256Locations = zipWith (\c i -> (i, C.cieXYZView c)) colors [16 ..] where colors :: [C.Colour Double] - colors = do - r <- [0.0, 0.2 .. 1.0] - g <- [0.0, 0.2 .. 1.0] - b <- [0.0, 0.2 .. 1.0] - return (C.sRGB r g b) + colors = + C.sRGB + <$> [0.0, 0.2 .. 1.0] + <*> [0.0, 0.2 .. 1.0] + <*> [0.0, 0.2 .. 1.0] diff --git a/src/Byline/Internal/Eval.hs b/src/Byline/Internal/Eval.hs --- a/src/Byline/Internal/Eval.hs +++ b/src/Byline/Internal/Eval.hs @@ -202,7 +202,7 @@ AskLn s d k -> do let prompt = renderText renderMode $ - maybe s (\d' -> s <> text "[" <> text d' <> "] ") d + maybe s (\d' -> s <> text "[" <> text d' <> text "] ") d liftHaskeline (Haskeline.getInputLine (toString prompt)) >>= \case Nothing -> EvalT empty Just answer diff --git a/src/Byline/Internal/Prim.hs b/src/Byline/Internal/Prim.hs --- a/src/Byline/Internal/Prim.hs +++ b/src/Byline/Internal/Prim.hs @@ -30,7 +30,6 @@ import Byline.Internal.Stylized (Stylized, text) import Control.Monad.Trans.Free.Church (MonadFree) import qualified Control.Monad.Trans.Free.Church as Free -import Prelude hiding (ask) -- | Primitive operations as a free monad. -- diff --git a/src/Byline/Internal/Stylized.hs b/src/Byline/Internal/Stylized.hs --- a/src/Byline/Internal/Stylized.hs +++ b/src/Byline/Internal/Stylized.hs @@ -82,7 +82,9 @@ -- | Helper function to create stylized text. If you enable the -- @OverloadedStrings@ extension then you can create stylized text --- directly without using this function. +-- directly without using this function. However, if you are not +-- using any of the other stylized modifiers then this function can be +-- helpful for avoiding "Ambiguous type variable" compile errors. -- -- This function is also helpful for producing stylized text from an -- existing @Text@ value. diff --git a/src/Byline/Menu.hs b/src/Byline/Menu.hs --- a/src/Byline/Menu.hs +++ b/src/Byline/Menu.hs @@ -223,9 +223,9 @@ firstItem = Text.strip (renderText Plain (_menuItemPrefix m 1)) -- Print the entire menu. displayMenu = do - maybe pass ((<> "\n") >>> sayLn) (_menuBanner m) + maybe pass ((<> text "\n") >>> sayLn) (_menuBanner m) cache <- foldlM listItem mempty (zip [1 ..] (toList $ _menuItems m)) - sayLn (maybe mempty ("\n" <>) (_menuBeforePrompt m)) + sayLn (maybe mempty (text "\n" <>) (_menuBeforePrompt m)) pure cache -- Print a menu item and cache its prefix in a Map. listItem cache (index, item) = do diff --git a/src/Byline/Shell.hs b/src/Byline/Shell.hs new file mode 100644 --- /dev/null +++ b/src/Byline/Shell.hs @@ -0,0 +1,221 @@ +-- | +-- +-- 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. + shellPrefs :: O.ParserPrefs, + -- | The shell parser wrapped in a 'O.ParserInfo'. This is + -- generally created with the 'O.info' function. + shellInfo :: O.ParserInfo a, + -- | The prompt to display. + shellPrompt :: Stylized Text + } + +-- | Run a single iteration of the shell. +-- +-- @since 1.1.0.0 +runShell :: + MonadByline m => + (a -> m ()) -> + Shell a -> + m () +runShell dispatch Shell {..} = do + input <- askLn shellPrompt Nothing + words <- shellSplit input + unless (null words) (go (map toString words)) + where + go words = do + case O.execParserPure shellPrefs shellInfo words of + O.Success a -> + dispatch a + O.Failure help -> do + let str = fst (O.renderFailure help "") + sayLn (text $ toText str) + O.CompletionInvoked _ -> + pure () + +-- | Print a list of shell commands. +-- +-- @since 1.1.0.0 +shellHelp :: + MonadByline m => + Shell a -> + m () +shellHelp Shell {..} = do + let h = O.parserFailure shellPrefs shellInfo (O.ShowHelpText Nothing) mempty + s = fst (O.renderFailure h "") + sayLn (text $ toText 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 input@(left, _) = do + if Text.null left || Text.all (isSpace >>> not) left + then completionFromList CompHead (keys commands) input + else completionFromList CompTail flags input + where + -- Get a list of flags for the current subcommand. + flags :: [Text] + flags = fromMaybe [] $ do + cmd <- Text.words left & viaNonEmpty head + names <- lookup cmd commands + pure $ + flip map names $ \case + O.OptShort c -> toText ['-', c] + O.OptLong s -> "--" <> toText s + + -- A map of command names and their flags. + commands :: HashMap Text [O.OptName] + commands = + fromList $ + concat $ + O.mapParser + (const nameAndFlags) + (O.infoParser $ shellInfo shell) + where + nameAndFlags opt = + case O.optMain opt of + O.CmdReader _ cmds p -> (`map` cmds) $ \cmd -> + ( toText cmd, + maybe + [] + ( O.infoParser + >>> O.mapParser (const optnames) + >>> concat + ) + (p cmd) + ) + _ -> mempty + optnames opt = + case O.optMain opt of + O.OptReader ns _ _ -> ns + O.FlagReader ns _ -> ns + _ -> mempty + +-- | Internal function to split user input into words similar to what +-- a POSIX shell does. +shellSplit :: MonadByline m => Text -> m [Text] +shellSplit t = + let input = Text.strip t + in if Text.null input + then pure [] + else case Atto.parseOnly go input of + Left e -> do + sayLn (("invalid input" <> fg red) <> ": " <> text (toText e)) + pure [] + Right ws -> + pure ws + where + go :: Atto.Parser [Text] + go = Atto.many1 (bare <|> quoted) <* expectEndOfInput + + expectEndOfInput :: Atto.Parser () + expectEndOfInput = (Atto.endOfInput <|>) $ do + leftover <- Atto.many1 Atto.anyChar + fail ("unexpected input: " <> leftover) + + -- A bare word (not wrapped in quotes). + bare :: Atto.Parser Text + bare = (Atto. "unquoted word") $ do + word <- Atto.many1 bareChar + void (Atto.many1 Atto.space) <|> Atto.endOfInput + pure (toText 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 = do + prefix <- many bareChar + quote <- Atto.satisfy (\c -> c == '\'' || c == '"') Atto. "quote" + (_, ScanState {..}) <- + Atto.runScanner (ScanState [] False) (quoteScanner quote) + when scanEscape (fail "expecting a character after a backslash") + _ <- Atto.char quote Atto. "closing quotation character" + let str = toText prefix <> toText (reverse scanResult) + end <- + (Atto.many1 Atto.space $> True) + <|> (Atto.endOfInput $> True) + <|> pure False + if end then pure str else (str <>) <$> quoted + + -- Parse a single character that might be escaped. + bareChar :: Atto.Parser Char + bareChar = do + char <- + Atto.satisfy + ( \c -> + not (isSpace c) + && c /= '\'' + && c /= '"' + && isPrint c + ) + if char == '\\' + then Atto.anyChar Atto. "escaped character" + else pure char + +-- | State needed to scan input looking for a closing quote. +data ScanState = ScanState + { scanResult :: [Char], + 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 quote ScanState {..} input + | scanEscape = Just (ScanState (input : scanResult) False) + | input == '\\' = Just (ScanState scanResult True) + | input == quote = Nothing + | otherwise = Just (ScanState (input : scanResult) False)