diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,42 @@ # Version History +## 1.0.0.0 (July 27, 2020) + +This version is the result of a major refactoring of the code in order +to produce an MTL-compatible library. + + - New MTL-style class: `MonadByline` + + - Proper monad transformer: `BylineT` + + - Most of the library is under a single import: `Byline` + + - Added a `ToStylizedText` class to enable using custom types with + functions like `menu`. + + - New `Byline.Exit.die` function to exit the current process with a + stylized error message. Thanks to the `ToStylizedText` class it's + easy to exit with custom error types. + + - The `Report` type and associated functions were superfluous and + therefore removed. (Consider using the new `die` and `warn` + functions in `Byline.Exit`.) + + - Menus now use `NonEmpty` to represent items and therefore the menu + `Choice` type has been simplified, removing the `NoItems` + constructor. + + - Fixed a bug where `Stylized Text` was not rendered when using one + of the `ask*` functions (#1). + + - Proper encoding of escape sequences so Haskeline doesn't + [print garbage](https://github.com/judah/haskeline/issues/130) on Windows. + + - Added support for RGB terminals + + - Added an implementation of 'MonadByline' that uses simulated user + input to test your Byline code. + ## 0.4.0.0 (March 17, 2020) - The `askUntil` function is now polymorphic in its return type. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,10 @@ # Byline -Byline simplifies writing interactive terminal applications by +[![CI](https://github.com/pjones/byline/workflows/CI/badge.svg)](https://github.com/pjones/byline/actions) +[![GitHub tag (latest by date)](https://img.shields.io/github/v/tag/pjones/byline?label=release)](https://github.com/pjones/byline/releases) +[![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 possible to print messages and prompts that include terminal escape sequences such as colors that are automatically disabled when standard @@ -11,9 +15,30 @@ for input, and generating custom menus. It was inspired by the [highline] Ruby library and the [terminal library][] by Craig Roche. -## Examples +## Example Using `MonadByline` -Please see the example programs in the `examples` directory. +```haskell +example :: MonadByline m => m Text +example = do + sayLn ("Hey, I like " <> ("Haskell" <> fg magenta) <> "!") + + let question = + "What's " + <> ("your" <> bold) + <> " favorite " + <> ("language" <> fg green <> underline) + <> "? " + + askLn question (Just "Haskell") +``` + +![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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,16 @@ +-- | +-- +-- 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 import Distribution.Simple main = defaultMain diff --git a/byline.cabal b/byline.cabal --- a/byline.cabal +++ b/byline.cabal @@ -1,30 +1,48 @@ -cabal-version: 2.2 +cabal-version: 2.2 +name: byline +version: 1.0.0.0 +homepage: https://github.com/pjones/byline +bug-reports: https://github.com/pjones/byline/issues +license: BSD-2-Clause +license-file: LICENSE +author: Peter Jones +maintainer: Peter Jones +copyright: Copyright: (c) 2015-2020 Peter J. Jones +category: System, User Interfaces +build-type: Simple +stability: stable +tested-with: GHC ==8.6.5 || ==8.8.3 || ==8.10.1 +synopsis: + Library for creating command-line interfaces (colors, menus, etc.) --------------------------------------------------------------------------------- -name: byline -version: 0.4.0.0 -synopsis: Library for creating command-line interfaces (colors, menus, etc.) -homepage: https://github.com/pjones/byline -bug-reports: https://github.com/pjones/byline/issues -license: BSD-2-Clause -license-file: LICENSE -author: Peter Jones -maintainer: Peter Jones -copyright: Copyright: (c) 2015-2020 Peter J. Jones -category: System, User Interfaces -build-type: Simple -stability: stable description: - Byline simplifies writing interactive terminal applications by + Byline simplifies writing interactive command-line applications by 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 - POSIX-compatible systems and on Windows. + sequences (such as setting text colors) that are automatically + disabled when standard 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 @highline@ Ruby library and the @terminal@ library by Craig Roche. + . + == Example + . + > example :: MonadByline m => m Text + > example = do + > sayLn ("Hey, I like " <> ("Haskell" <> fg magenta) <> "!") + > + > let question = + > "What's " + > <> ("your" <> bold) + > <> " favorite " + > <> ("language" <> fg green <> underline) + > <> "? " + > + > askLn question (Just "Haskell") + . + <> -------------------------------------------------------------------------------- extra-source-files: @@ -34,62 +52,103 @@ -------------------------------------------------------------------------------- source-repository head - type: git + type: git location: https://github.com/pjones/byline.git -------------------------------------------------------------------------------- flag build-examples description: Build examples when building the library. - manual: True - default: False + manual: True + default: False -------------------------------------------------------------------------------- common options - default-language: Haskell2010 - ghc-options: -Wall - -Werror=incomplete-record-updates - -Werror=incomplete-uni-patterns - -Werror=missing-home-modules - -Widentities - -Wmissing-export-lists - -Wredundant-constraints + default-language: Haskell2010 + default-extensions: + DefaultSignatures + DeriveFoldable + DeriveFunctor + DeriveTraversable + DerivingStrategies + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + OverloadedStrings + RankNTypes + RecordWildCards + ScopedTypeVariables + TypeFamilies + ghc-options: + -Wall -Wno-name-shadowing -Werror=incomplete-record-updates + -Werror=incomplete-uni-patterns -Werror=missing-home-modules + -Widentities -Wmissing-export-lists -Wredundant-constraints + -------------------------------------------------------------------------------- common dependencies - build-depends: base >= 4.9 && < 5.0 - , ansi-terminal >= 0.6 && < 0.12 - , colour >= 2.3 && < 2.4 - , containers >= 0.5 && < 0.7 - , exceptions >= 0.8 && < 0.11 - , haskeline >= 0.7 && < 0.8 - , mtl >= 2.1 && < 2.3 - , terminfo-hs >= 0.1 && < 0.3 - , text >= 0.11 && < 1.3 - , transformers >= 0.3 && < 0.6 + 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 + mixins: + base hiding (Prelude), + relude (Relude as Prelude, Relude.Extra.Map) + -------------------------------------------------------------------------------- library - import: options, dependencies - hs-source-dirs: src - + import: options, dependencies + hs-source-dirs: src exposed-modules: - System.Console.Byline - System.Console.Byline.Color - System.Console.Byline.Completion - System.Console.Byline.Internal.Byline - System.Console.Byline.Internal.Color - System.Console.Byline.Internal.Completion - System.Console.Byline.Internal.Render - System.Console.Byline.Internal.Types - System.Console.Byline.Menu - System.Console.Byline.Modifiers - System.Console.Byline.Primitive - System.Console.Byline.Stylized + Byline + Byline.Completion + Byline.Exit + Byline.Internal.Color + Byline.Internal.Completion + Byline.Internal.Eval + Byline.Internal.Prim + Byline.Internal.Simulation + Byline.Internal.Stylized + Byline.Internal.Types + Byline.Menu + Byline.Simulation +------------------------------------------------------------------------------ +test-suite test + import: options, dependencies + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + , byline + , tasty >=1.2 + , tasty-hunit ^>=0.10 + -------------------------------------------------------------------------------- +executable demo + import: options, dependencies + main-is: examples/demo.hs + build-depends: byline + + if !flag(build-examples) + buildable: False + +-------------------------------------------------------------------------------- executable simple - import: options, dependencies - main-is: examples/simple.hs + import: options, dependencies + main-is: examples/simple.hs build-depends: byline if !flag(build-examples) @@ -97,8 +156,8 @@ -------------------------------------------------------------------------------- executable menu - import: options, dependencies - main-is: examples/menu.hs + import: options, dependencies + main-is: examples/menu.hs build-depends: byline if !flag(build-examples) diff --git a/examples/demo.hs b/examples/demo.hs new file mode 100644 --- /dev/null +++ b/examples/demo.hs @@ -0,0 +1,38 @@ +-- | +-- +-- 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 + +-- | Simple example. +example :: MonadByline m => m Text +example = do + sayLn ("Hey, I like " <> ("Haskell" <> fg magenta) <> "!") + + let question = + "What's " + <> ("your" <> bold) + <> " favorite " + <> ("language" <> fg green <> underline) + <> "? " + + askLn question (Just "Haskell") + +-- | Main. +main :: IO () +main = runBylineT example >>= print diff --git a/examples/menu.hs b/examples/menu.hs --- a/examples/menu.hs +++ b/examples/menu.hs @@ -1,45 +1,61 @@ -{-# LANGUAGE OverloadedStrings #-} - -{- - -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 git://pmade.com/byline/LICENSE. No part of the -byline package, including this file, may be copied, modified, -propagated, or distributed except according to the terms contained in -the LICENSE file. - --} - --------------------------------------------------------------------------------- -module Main (main) where +-- | +-- +-- 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 Data.Text (Text) -import System.Console.Byline +import Byline.Menu +import qualified Data.List.NonEmpty as NonEmpty --------------------------------------------------------------------------------- -data Item = Fruit Text | Vegetable Text deriving Show +-- | Menu items that we'll ask the user to choose from. +data Item + = Fruit Text + | Vegetable Text + deriving (Show) --------------------------------------------------------------------------------- -displayItem :: Item -> Stylized -displayItem (Fruit name) = text name <> (" (fruit)" <> fg red) -displayItem (Vegetable name) = text name <> (" (vegetable)" <> fg green) +-- | How to display a menu item. +instance ToStylizedText Item where + toStylizedText item = case item of + Fruit name -> text name <> (" (fruit)" <> fg red) + Vegetable name -> text name <> (" (vegetable)" <> fg green) --------------------------------------------------------------------------------- -items :: [Item] -items = [ Fruit "Watermelon" - , Vegetable "Cucumber" - , Fruit "Kiwi" - , Vegetable "Asparagus" - ] +-- | The list of menu items. +items :: NonEmpty Item +items = + NonEmpty.fromList + [ Fruit "Watermelon", + Vegetable "Cucumber", + Fruit "Kiwi", + Vegetable "Asparagus" + ] --------------------------------------------------------------------------------- +-- | It's main! main :: IO () main = do - let menuConfig = banner "Pick a snack: " $ menu items displayItem - prompt = "Which snack? " - onError = "please pick a valid item!" <> fg red + let menuConfig = + menuBanner ("Pick a snack: " <> bold) $ + menu items + prompt = "Which snack? " <> bold <> fg yellow + onError = "Please pick a valid item!" <> fg red - answer <- runByline $ askWithMenuRepeatedly menuConfig prompt onError - putStrLn ("you picked: " ++ show answer) + -- Display the menu and get back the item the user selected. The + -- user will be able to select an item using it's index, name, or + -- using tab completion. + answer <- + runBylineT $ + askWithMenuRepeatedly menuConfig prompt onError + + putStrLn ("You picked: " ++ show answer) diff --git a/examples/simple.hs b/examples/simple.hs --- a/examples/simple.hs +++ b/examples/simple.hs @@ -1,53 +1,54 @@ -{-# LANGUAGE OverloadedStrings #-} - -{- - -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 git://pmade.com/byline/LICENSE. No part of the -byline package, including this file, may be copied, modified, -propagated, or distributed except according to the terms contained in -the LICENSE file. - --} - --------------------------------------------------------------------------------- -module Main (main) where +-- | +-- +-- 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 Control.Monad (void) -import Data.Text (Text) +import Byline +import qualified Byline.Exit as Exit import qualified Data.Text as Text -import System.Console.Byline --------------------------------------------------------------------------------- main :: IO () -main = void $ runByline $ do - - -- Simple message to stdout: - sayLn "Okay, let's kick this off" - - -- Now with some color: - sayLn ("I can use " <> ("color" <> fg blue) <> " too!") +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) <> "? " - language <- ask question Nothing + let question = + "What's your favorite " + <> ("language" <> bold <> fg green) + <> "? " + language <- askLn question Nothing if Text.null language - then sayLn "Cat got your tongue?" + 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: - name <- askUntil "What's your name? " Nothing atLeastThreeChars + 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. -atLeastThreeChars :: Text -> IO (Either Stylized Text) -atLeastThreeChars input = return $ - if Text.length input < 3 - then Left "You can do better." - else Right input +atLeastThreeChars :: Text -> Either (Stylized Text) Text +atLeastThreeChars input + | Text.length input < 3 = Left ("You can do better." <> bg red) + | otherwise = Right input diff --git a/src/Byline.hs b/src/Byline.hs new file mode 100644 --- /dev/null +++ b/src/Byline.hs @@ -0,0 +1,201 @@ +-- | +-- +-- Copyright: +-- This file is part of the package addy. 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 Byline + ( -- * How to Use this Library + -- $use + + -- * Byline Class and Transformer + MonadByline, + BylineT, + runBylineT, + + -- * Basic User Interaction + say, + sayLn, + askLn, + askChar, + askPassword, + askUntil, + + -- * Stylizing Modifiers + Stylized, + ToStylizedText (..), + text, + fg, + bg, + bold, + underline, + swapFgBg, + + -- * Colors + Color, + black, + red, + green, + yellow, + blue, + magenta, + cyan, + white, + rgb, + ) +where + +import Byline.Internal.Color +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. +-- +-- See also: 'sayLn'. +-- +-- @since 1.0.0.0 +say :: + (MonadByline m, ToStylizedText a) => + -- | The stylized text to output. + a -> + m () +say = + toStylizedText + >>> Prim.say + >>> liftByline + +-- | Like 'say', but append a newline character. +-- +-- @since 1.0.0.0 +sayLn :: + (MonadByline m, ToStylizedText a) => + -- | The stylized text to output. An appropirate line ending + -- character will be added to the end of this text. + a -> + m () +sayLn = + toStylizedText + >>> Prim.sayLn + >>> liftByline + +-- | Read a line of input after printing the given stylized text as a +-- prompt. +-- +-- @since 1.0.0.0 +askLn :: + (MonadByline m, ToStylizedText a) => + -- | The prompt. + a -> + -- | The text to return if the user does not enter a response. + Maybe Text -> + -- | User input (or default answer). + m Text +askLn prompt def = liftByline (Prim.askLn (toStylizedText prompt) def) + +-- | Read a single character of input. +-- +-- @since 1.0.0.0 +askChar :: + (MonadByline m, ToStylizedText a) => + -- | The prompt to display. + a -> + m Char +askChar = + toStylizedText + >>> Prim.askChar + >>> liftByline + +-- | Read a password without echoing it to the terminal. If a masking +-- character is given it will replace each typed character. +-- +-- @since 1.0.0.0 +askPassword :: + (MonadByline m, ToStylizedText a) => + -- | The prompt to display. + a -> + -- | Optional masking character that will be printed each time the + -- user presses a key. When 'Nothing' is given the default behavior + -- will be used which is system dependent but usually results in no + -- characters being echoed to the terminal. + Maybe Char -> + m Text +askPassword prompt = + Prim.askPassword (toStylizedText prompt) + >>> liftByline + +-- | Continue to prompt for a response until a confirmation function +-- returns a valid result. +-- +-- @since 1.0.0.0 +askUntil :: + (MonadByline m, ToStylizedText a, ToStylizedText e) => + -- | The prompt to display. + a -> + -- | The default answer if the user presses enter without typing + -- anything. + Maybe Text -> + -- | A function to validate the user input. If the user input is + -- acceptable the function should return 'Right'. If the input is + -- invalid then it should return 'Left' with an error message to + -- display. The error message will be printed with 'sayLn'. + (Text -> m (Either e b)) -> + m b +askUntil prompt def confirm = go + where + go = do + answer <- askLn prompt def + confirm answer >>= \case + Left msg -> sayLn msg >> go + Right res -> pure res + +-- $use +-- +-- Byline provides a monad transformer that allows you to compose +-- interactive terminal actions. When producing output, +-- these actions accept stylized text that can include +-- foreground and background colors, underlined text, and +-- bold text. +-- +-- Stylized text can be constructed with string literals +-- (using the @OverloadedStrings@ extension) or using the +-- 'text' function. Attributes such as color can be changed +-- using modifier functions and the 'Semigroup' @(<>)@ operator. +-- +-- Actions that read user input can work with completion +-- functions which are activated when the user presses the +-- tab key. Most input actions also support default values +-- that will be returned when the user presses the enter key +-- without providing any input. +-- +-- Example: +-- +-- @ +-- {-\# LANGUAGE OverloadedStrings \#-} +-- +-- example :: MonadByline m => m Text +-- example = do +-- sayLn ("Hey, I like " <> ("Haskell" <> fg magenta) <> "!") +-- +-- let question = +-- "What's " +-- <> ("your" <> bold) +-- <> " favorite " +-- <> ("language" <> fg green <> underline) +-- <> "? " +-- +-- askLn question (Just "Haskell") +-- @ +-- +-- More complete examples can be found in the @examples@ +-- directory of the distribution tarball or in the +-- repository. diff --git a/src/Byline/Completion.hs b/src/Byline/Completion.hs new file mode 100644 --- /dev/null +++ b/src/Byline/Completion.hs @@ -0,0 +1,49 @@ +-- | +-- +-- 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 Byline.Completion + ( -- * A Note About Completion + -- $use + + -- * Completion Function + CompletionFunc, + Completion (..), + + -- * Setting the Active Completion Function + pushCompletionFunction, + popCompletionFunction, + ) +where + +import Byline.Internal.Completion +import Byline.Internal.Eval (MonadByline (..)) +import qualified Byline.Internal.Prim as Prim + +-- | Add a 'CompletionFunc' to the stack. +-- +-- @since 1.0.0.0 +pushCompletionFunction :: MonadByline m => CompletionFunc IO -> m () +pushCompletionFunction = Prim.pushCompFunc >>> liftByline + +-- | Remove the top completion function from the stack. +-- +-- @since 1.0.0.0 +popCompletionFunction :: MonadByline m => m () +popCompletionFunction = liftByline Prim.popCompFunc + +-- $use +-- +-- Haskeline makes it very difficult (if not impossible) to implement +-- a completion function that runs in an arbitrary monad. More +-- information can be found in the documentation for 'CompletionFunc'. diff --git a/src/Byline/Exit.hs b/src/Byline/Exit.hs new file mode 100644 --- /dev/null +++ b/src/Byline/Exit.hs @@ -0,0 +1,65 @@ +-- | +-- +-- 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 Byline.Exit + ( -- * Exiting with style + die, + + -- * Warnings + warn, + + -- * Re-exports + module Byline, + ) +where + +import Byline +import Byline.Internal.Eval (defaultRenderMode) +import Byline.Internal.Stylized (render) +import qualified System.Environment as Environment +import qualified System.Exit as Exit +import qualified System.IO as IO +import Prelude hiding (die) + +-- | Exit the current process after printing a pretty error message. +-- +-- This function is similar to 'Exit.die' except that the name of the +-- current process along with a 'Stylized' error message is printed to +-- the standard error handle before exiting with a failure code. +-- +-- @since 1.0.0.0 +die :: (MonadIO m, ToStylizedText a) => a -> m b +die a = do + warn a + liftIO (IO.hFlush stderr >> Exit.exitFailure) + +-- | Print a message to standard error. +-- +-- Unlike 'die', this function will __not__ exit the current process. +-- +-- @since 1.0.0.0 +warn :: (MonadIO m, ToStylizedText a) => a -> m () +warn a = liftIO $ do + name <- Environment.getProgName <&> toText + + let msg = + mconcat + [ text name, + ": ", + toStylizedText a, + "\n" + ] + + mode <- defaultRenderMode stderr + render mode stderr msg diff --git a/src/Byline/Internal/Color.hs b/src/Byline/Internal/Color.hs new file mode 100644 --- /dev/null +++ b/src/Byline/Internal/Color.hs @@ -0,0 +1,165 @@ +{-# OPTIONS_HADDOCK hide #-} + +-- | +-- +-- 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 Byline.Internal.Color + ( Color (..), + black, + red, + green, + yellow, + blue, + magenta, + cyan, + white, + rgb, + colorAsANSI, + colorAsIndex256, + colorAsRGB, + nearestColor, + term256Locations, + ) +where + +import Byline.Internal.Types +import qualified Data.Colour.CIE as C +import qualified Data.Colour.SRGB as C +import qualified System.Console.ANSI as ANSI + +-- | Standard ANSI color by name. +-- +-- @since 1.0.0.0 +black, red, green, yellow, blue, magenta, cyan, white :: Color +black = ColorCode ANSI.Black +red = ColorCode ANSI.Red +green = ColorCode ANSI.Green +yellow = ColorCode ANSI.Yellow +blue = ColorCode ANSI.Blue +magenta = ColorCode ANSI.Magenta +cyan = ColorCode ANSI.Cyan +white = ColorCode ANSI.White + +-- | Specify a color using a RGB triplet where each component is in +-- the range @[0 .. 255]@. The actual rendered color will depend on +-- the terminal. +-- +-- If the terminal advertises that it supports 256 colors, the color +-- given to this function will be converted to the nearest color in +-- the 216-color pallet supported by the terminal. (216 colors +-- because the first 16 are the standard colors and the last 24 are +-- grayscale entries.) +-- +-- However, if the terminal doesn't support extra colors, or doesn't +-- have a @TERMINFO@ entry (e.g., Windows) then the nearest standard +-- color will be chosen. +-- +-- Nearest colors are calculated using their CIE distance from one +-- another. +-- +-- See also: +-- +-- * +-- * +-- +-- @since 1.0.0.0 +rgb :: Word8 -> Word8 -> Word8 -> Color +rgb r g b = ColorRGB (r, g, b) + +-- | Convert a Byline color to an ANSI color. +-- +-- @since 1.0.0.0 +colorAsANSI :: Color -> ANSI.Color +colorAsANSI (ColorCode c) = c +colorAsANSI (ColorRGB c) = nearestColor c ansiColorLocations + +-- | Convert a Byline color to an index into a terminal 256-color palette. +-- +-- @since 1.0.0.0 +colorAsIndex256 :: Color -> Word8 +colorAsIndex256 = \case + ColorCode c -> ANSI.xtermSystem ANSI.Dull c + ColorRGB c -> nearestColor c term256Locations + +-- | Convert a Byline color to a 'C.Colour'. If the color is +-- specified using an ANSI color name then return that color code +-- instead. This allows the terminal to pick the color on its own. +-- +-- @since 1.0.0.0 +colorAsRGB :: Color -> Either ANSI.Color (C.Colour Float) +colorAsRGB = \case + ColorCode c -> Left c + ColorRGB (r, g, b) -> Right (C.sRGB24 r g b) + +-- | Find the nearest color given a full RGB color. +-- +-- @since 1.0.0.0 +nearestColor :: + Bounded a => + -- | Original color. + (Word8, Word8, Word8) -> + -- | List of colors and locations. + [(a, (Double, Double, Double))] -> + -- | Destination color. + a +nearestColor (r, g, b) table = + case listToMaybe (sortColors $ distances table) of + Nothing -> minBound -- Should never happen. + Just (c, _) -> c + where + location :: (Double, Double, Double) + location = C.cieXYZView (C.sRGB24 r g b) + distance :: (Double, Double, Double) -> (Double, Double, Double) -> Double + distance (x1, y1, z1) (x2, y2, z2) = sqrt ((x ** 2) + (y ** 2) + (z ** 2)) + where + x = x1 - x2 + y = y1 - y2 + z = z1 - z2 + distances :: [(a, (Double, Double, Double))] -> [(a, Double)] + distances = map (second (distance location)) + sortColors :: [(a, Double)] -> [(a, Double)] + sortColors = sortBy (comparing snd) + +-- | Get the CIE locations for the standard ANSI colors. +-- +-- Locations are based on the default xterm colors. See also: +-- +-- * +-- * +-- +-- @since 1.0.0.0 +ansiColorLocations :: [(ANSI.Color, (Double, Double, Double))] +ansiColorLocations = + [ (ANSI.Black, (0.0, 0.0, 0.0)), + (ANSI.Red, (0.2518, 0.1298, 0.0118)), + (ANSI.Green, (0.2183, 0.4366, 0.0728)), + (ANSI.Yellow, (0.4701, 0.5664, 0.0846)), + (ANSI.Blue, (0.1543, 0.0617, 0.8126)), + (ANSI.Magenta, (0.3619, 0.1739, 0.592)), + (ANSI.Cyan, (0.3285, 0.4807, 0.653)), + (ANSI.White, (0.7447, 0.7835, 0.8532)) + ] + +-- | All of the allowed colors for 256 color terminals. +-- +-- @since 1.0.0.0 +term256Locations :: [(Word8, (Double, Double, Double))] +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) diff --git a/src/Byline/Internal/Completion.hs b/src/Byline/Internal/Completion.hs new file mode 100644 --- /dev/null +++ b/src/Byline/Internal/Completion.hs @@ -0,0 +1,118 @@ +{-# OPTIONS_HADDOCK hide #-} + +-- | +-- +-- 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 Byline.Internal.Completion + ( CompletionFunc, + Completion (..), + runCompletionFunction, + runCompletionFunctions, + ) +where + +import qualified Data.Text as Text +import qualified System.Console.Haskeline.Completion as Haskeline + +-- | A completion function modeled after the one used in Haskeline. +-- +-- /Warning:/ If you're familiar with the Haskeline version of the +-- @CompletionFunc@ type please be sure to read this description +-- carefully since the two behave differently. +-- +-- The completion function is called when the user presses the tab +-- key. The current input line is split into two parts based on where +-- the cursor is positioned. Text to the left of the cursor will be +-- the first value in the tuple and text to the right of the cursor +-- will be the second value. +-- +-- The text returned from the completion function is the text from the +-- left of the cursor which wasn't used in the completion. It should +-- also produce a list of possible 'Completion' values. +-- +-- In Haskeline, some of these text values are reversed. This is +-- /not/ the case in Byline. +-- +-- /A note about @IO@:/ +-- +-- Due to Haskeline, the completion function is forced to return an +-- @IO@ value. It would be better if it could return a value in the +-- base monad instead but it doesn't look like that's possible. +-- Patches welcome. +-- +-- @since 1.0.0.0 +type CompletionFunc m = (Text, Text) -> m (Text, [Completion]) + +-- | A type representing a completion match to the user's input. +-- +-- @since 1.0.0.0 +data Completion = Completion + { -- | Text to insert to the right of the cursor. + replacement :: Text, + -- | Text to display when listing all completions. + display :: Text, + -- | Whether to follow the completed word with a + -- terminating space or close existing quotes. + isFinished :: Bool + } + deriving (Eq, Ord, Show) + +-- | Convert a Byline completion result into a Haskeline completion result. +-- +-- @since 1.0.0.0 +convertCompletion :: Completion -> Haskeline.Completion +convertCompletion (Completion r d i) = + Haskeline.Completion + { Haskeline.replacement = toString r, + Haskeline.display = toString d, + Haskeline.isFinished = i + } + +-- | Adapt a completion function so it works with Haskeline. +-- +-- @since 1.0.0.0 +runCompletionFunction :: + Monad m => + CompletionFunc m -> + Haskeline.CompletionFunc m +runCompletionFunction comp (left, right) = do + (output, completions) <- + comp + ( Text.reverse $ toText left, + toText right + ) + pure + ( toString $ Text.reverse output, + map convertCompletion completions + ) + +-- | Run a list of completion functions, returning the results of the +-- first function that produced any. +-- +-- @since 1.0.0.0 +runCompletionFunctions :: + forall m. + Monad m => + [CompletionFunc m] -> + Haskeline.CompletionFunc m +runCompletionFunctions fs input = + foldlM go (mempty, mempty) fs + where + go :: + (String, [Haskeline.Completion]) -> + CompletionFunc m -> + m (String, [Haskeline.Completion]) + go prev f = case prev of + (_, []) -> runCompletionFunction f input + _ -> pure prev diff --git a/src/Byline/Internal/Eval.hs b/src/Byline/Internal/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Byline/Internal/Eval.hs @@ -0,0 +1,254 @@ +{-# OPTIONS_HADDOCK hide #-} + +-- | +-- +-- 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 Byline.Internal.Eval + ( MonadByline (..), + BylineT, + runBylineT, + Settings (..), + defaultBylineSettings, + runBylineT', + defaultRenderMode, + ) +where + +import Byline.Internal.Completion +import Byline.Internal.Prim (PrimF (..)) +import Byline.Internal.Stylized +import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) +import Control.Monad.Cont (ContT, MonadCont) +import Control.Monad.Except (MonadError) +import qualified Control.Monad.State.Lazy as LState +import qualified Control.Monad.Trans.Free.Church as Free +import qualified System.Console.ANSI as ANSI +import qualified System.Console.Haskeline as Haskeline +import qualified System.Environment as System +import qualified System.Terminfo as Terminfo +import qualified System.Terminfo.Caps as Terminfo + +-- | A class of types that can lift Byline operations into a base +-- monad. +-- +-- @since 1.0.0.0 +class Monad m => MonadByline (m :: * -> *) where + liftByline :: Free.F PrimF a -> m a + default liftByline :: (MonadTrans t, MonadByline m1, m ~ t m1) => Free.F PrimF a -> m a + liftByline = lift . liftByline + +instance MonadByline m => MonadByline (ExceptT e m) + +instance MonadByline m => MonadByline (StateT s m) + +instance MonadByline m => MonadByline (LState.StateT s m) + +instance MonadByline m => MonadByline (ReaderT r m) + +instance MonadByline m => MonadByline (IdentityT m) + +instance MonadByline m => MonadByline (ContT r m) + +-- | A monad transformer that implements 'MonadByline'. +-- +-- @since 1.0.0.0 +newtype BylineT m a = BylineT + {unBylineT :: Free.FT PrimF m a} + deriving newtype + ( Functor, + Applicative, + Monad, + MonadIO, + MonadState s, + MonadReader r, + MonadError e, + MonadCont, + MonadThrow, + MonadCatch + ) + +instance MonadTrans BylineT where + lift = BylineT . lift + +instance MonadByline (BylineT m) where + liftByline = BylineT . Free.fromF + +-- | Mutable list of completion functions. +-- +-- @since 1.0.0.0 +type CompRef m = IORef [CompletionFunc m] + +-- | Discharge the 'MonadByline' effect by running all operations and +-- returning the result in the base monad. +-- +-- The result is wrapped in a 'Maybe' where a 'Nothing' value +-- indicates that an end-of-file (EOF) signal was received while +-- reading user input. +-- +-- @since 1.0.0.0 +runBylineT :: + (MonadIO m, MonadMask m) => + BylineT m a -> + m (Maybe a) +runBylineT = runBylineT' defaultBylineSettings + +-- | Settings that control Byline at run time. +-- +-- @since 1.0.0.0 +data Settings = Settings + { -- | The output handle to write to. If 'Nothing' use standard + -- output. + -- + -- NOTE: This only affects Byline (i.e. functions that use + -- @say@). Functions like @ask@ that invoke Haskeline will always + -- use standard output since that's the hard-coded default. + bylineOutput :: Maybe Handle, + -- | The input handle to read from. If 'Nothing' use standard + -- input. + bylineInput :: Maybe Handle, + -- | Override the detected render mode. + -- + -- If 'Nothing' use the render mode that is calculated based on + -- the type of handle Byline writes to. + bylineMode :: Maybe RenderMode + } + +-- | The default Byline settings. +-- +-- @since 1.0.0.0 +defaultBylineSettings :: Settings +defaultBylineSettings = Settings Nothing Nothing Nothing + +-- | Like 'runBylineT' except you can override the settings. +-- +-- @since 1.0.0.0 +runBylineT' :: + forall m a. + (MonadIO m, MonadMask m) => + Settings -> + BylineT m a -> + m (Maybe a) +runBylineT' Settings {..} m = do + compRef <- newIORef [] + let settings = + Haskeline.setComplete + (compFunc compRef) + Haskeline.defaultSettings + let behavior = + maybe + Haskeline.defaultBehavior + Haskeline.useFileHandle + bylineInput + let hOut = fromMaybe stdout bylineOutput + Haskeline.runInputTBehavior behavior settings (go compRef hOut) + where + compFunc :: CompRef IO -> Haskeline.CompletionFunc m + compFunc compRef input = liftIO $ + readIORef compRef >>= \case + [] -> Haskeline.completeFilename input + fs -> runCompletionFunctions fs input + go :: + CompRef IO -> + Handle -> + Haskeline.InputT m (Maybe a) + go compRef hOut = do + mode <- maybe (liftIO (defaultRenderMode hOut)) pure bylineMode + unBylineT m + & evalPrimF mode hOut compRef + & unEvalT + & runMaybeT + +-- | Internal transformer for evaluating primitive operations in the +-- 'Haskeline.InputT' transformer with EOF handling. +-- +-- @since 1.0.0.0 +newtype EvalT m a = EvalT + {unEvalT :: MaybeT (Haskeline.InputT m) a} + deriving newtype (Functor, Applicative, Monad, MonadIO) + +instance MonadTrans EvalT where + lift = EvalT . lift . lift + +-- | Evaluate 'PrimF' values. +-- +-- @since 1.0.0.0 +evalPrimF :: + forall m a. + (MonadIO m, MonadMask m) => + RenderMode -> + Handle -> + CompRef IO -> + Free.FT PrimF m a -> + EvalT m a +evalPrimF renderMode outputHandle compRef = Free.iterTM go + where + go :: + PrimF (EvalT m a) -> + EvalT m a + go = \case + Say s k -> + liftIO (render renderMode outputHandle s) >> k + AskLn s d k -> do + let prompt = + renderText renderMode $ + maybe s (\d' -> s <> text "[" <> text d' <> "] ") d + liftHaskeline (Haskeline.getInputLine (toString prompt)) >>= \case + Nothing -> EvalT empty + Just answer + | null answer -> k (fromMaybe mempty d) + | otherwise -> k (toText answer) + AskChar s k -> do + let prompt = toString (renderText renderMode s) + liftHaskeline (Haskeline.getInputChar prompt) >>= \case + Nothing -> EvalT empty + Just c -> k c + AskPassword s m k -> do + let prompt = toString (renderText renderMode s) + liftHaskeline (Haskeline.getPassword m prompt) >>= \case + Nothing -> EvalT empty + Just str -> k (toText str) + PushCompFunc f k -> + modifyIORef' compRef (f :) >> k + PopCompFunc k -> + modifyIORef' + compRef + ( \case + [] -> [] + (_ : fs) -> fs + ) + >> k + liftHaskeline :: Haskeline.InputT m b -> EvalT m b + liftHaskeline = Haskeline.withInterrupt >>> lift >>> EvalT + +-- | Calculate the default rendering mode based on the terminal type. +defaultRenderMode :: Handle -> IO RenderMode +defaultRenderMode hOut = do + isTerm <- ANSI.hSupportsANSI hOut + if isTerm + then runMaybeT getMaxColors >>= \case + Nothing -> pure Simple + Just n + | n < 256 -> pure Simple + | n > 256 -> pure TermRGB + | otherwise -> pure Term256 + else pure Plain + where + getMaxColors :: MaybeT IO Int + getMaxColors = do + term <- MaybeT (System.lookupEnv "TERM") + lift (Terminfo.acquireDatabase term) >>= \case + Left _ -> empty + Right db -> + hoistMaybe $ + Terminfo.queryNumTermCap db Terminfo.MaxColors diff --git a/src/Byline/Internal/Prim.hs b/src/Byline/Internal/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Byline/Internal/Prim.hs @@ -0,0 +1,87 @@ +{-# OPTIONS_HADDOCK hide #-} + +-- | +-- +-- 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 Byline.Internal.Prim + ( PrimF (..), + say, + sayLn, + askLn, + askChar, + askPassword, + pushCompFunc, + popCompFunc, + ) +where + +import Byline.Internal.Completion (CompletionFunc) +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. +-- +-- @since 1.0.0.0 +data PrimF f + = Say (Stylized Text) f + | AskLn (Stylized Text) (Maybe Text) (Text -> f) + | AskChar (Stylized Text) (Char -> f) + | AskPassword (Stylized Text) (Maybe Char) (Text -> f) + | PushCompFunc (CompletionFunc IO) f + | PopCompFunc f + deriving (Functor) + +-- | Smart constructor. +-- +-- @since 1.0.0.0 +say :: MonadFree PrimF m => Stylized Text -> m () +say = Free.liftF . (`Say` ()) + +-- | Smart constructor. +-- +-- @since 1.0.0.0 +sayLn :: MonadFree PrimF m => Stylized Text -> m () +sayLn message = say (message <> text "\n") + +-- | Smart constructor. +-- +-- @since 1.0.0.0 +askLn :: MonadFree PrimF m => Stylized Text -> Maybe Text -> m Text +askLn prompt def = Free.liftF (AskLn prompt def id) + +-- | Smart constructor. +-- +-- @since 1.0.0.0 +askChar :: MonadFree PrimF m => Stylized Text -> m Char +askChar = Free.liftF . (`AskChar` id) + +-- | Smart constructor. +-- +-- @since 1.0.0.0 +askPassword :: MonadFree PrimF m => Stylized Text -> Maybe Char -> m Text +askPassword prompt mask = Free.liftF (AskPassword prompt mask id) + +-- | Smart constructor. +-- +-- @since 1.0.0.0 +pushCompFunc :: MonadFree PrimF m => CompletionFunc IO -> m () +pushCompFunc = Free.liftF . (`PushCompFunc` ()) + +-- | Smart constructor. +-- +-- @since 1.0.0.0 +popCompFunc :: MonadFree PrimF m => m () +popCompFunc = Free.liftF (PopCompFunc ()) diff --git a/src/Byline/Internal/Simulation.hs b/src/Byline/Internal/Simulation.hs new file mode 100644 --- /dev/null +++ b/src/Byline/Internal/Simulation.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_HADDOCK hide #-} + +-- | +-- +-- 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 Byline.Internal.Simulation + ( Simulated (..), + SimulationFunction, + SimulationState (..), + BylineT (..), + runBylineT, + ) +where + +import Byline.Internal.Completion +import Byline.Internal.Eval (MonadByline (..)) +import Byline.Internal.Prim +import Byline.Internal.Stylized +import Control.Monad.Catch (MonadCatch, MonadThrow) +import Control.Monad.Cont (MonadCont) +import Control.Monad.Except (MonadError) +import qualified Control.Monad.Trans.Free.Church as Free +import qualified Data.Text as Text + +-- | Simulated user input. +-- +-- @since 1.0.0.0 +data Simulated + = -- | Simulate user input by providing the 'Text' value + -- they typed as a response to a prompt. + -- + -- If the asking function wants a single character of input then + -- only the first character of the provided 'Text' is used. In + -- this case, if an empty 'Text' value is given, it will be treated + -- as an end-of-file (EOF) character. + SimulatedInput Text + | -- | Simulate an end-of-file (EOF) character. Usually this occurs + -- when the user enters @Control-D@ or when standard input is + -- exhausted. + SimulatedEOF + +-- | A function that simulates user input by returning a 'Simulated' +-- value. +-- +-- The function has full access to the 'SimulationState' including the +-- ability to change the simulation function itself. For example, +-- below is a function that will return the text \"Current" the first +-- time it is called and \"Next" every time after that. +-- +-- @ +-- +-- textThenDefault :: Monad m => SimulationFunction m +-- textThenDefault = do +-- -- The next input request will come from this function: +-- modify (\s -> s {simulationFunction = pure (SimulatedInput \"Next")}) +-- +-- -- But this time we'll return different text: +-- pure (SimulatedInput \"Current") +-- @ +-- +-- @since 1.0.0.0 +type SimulationFunction m = StateT (SimulationState m) m Simulated + +-- | Stateful information available to the simulation function. +-- +-- @since 1.0.0.0 +data SimulationState m = SimulationState + { -- | The prompt associated with current request for input. This + -- 'Text' value will /not/ contain any formatting escape codes such + -- as colors. + precedingPrompt :: Text, + -- | The function that will be called to simulate user input. + simulationFunction :: SimulationFunction m, + -- | The stack of completion functions. + completionFunctions :: [CompletionFunc IO] + } + +-- | A monad transformer that implements the 'MonadByline' class +-- without actually doing anything. +-- +-- @since 1.0.0.0 +newtype BylineT m a = BylineT + {unBylineT :: MaybeT (StateT (SimulationState m) m) a} + deriving newtype + ( Functor, + Applicative, + Monad, + MonadIO, + MonadReader r, + MonadError e, + MonadCont, + MonadThrow, + MonadCatch + ) + +instance MonadState s m => MonadState s (BylineT m) where + state = lift . state + +instance MonadTrans BylineT where + lift = BylineT . lift . lift + +instance Monad m => MonadByline (BylineT m) where + liftByline = evalPrimF + +-- | Evaluate a 'PrimF' instruction. +-- +-- @since 1.0.0.0 +evalPrimF :: forall m a. Monad m => Free.F PrimF a -> BylineT m a +evalPrimF = Free.iterM go + where + go :: PrimF (BylineT m a) -> BylineT m a + go = \case + Say _ k -> k + AskLn s d k -> simulate s $ \t -> + if Text.null t + then k (fromMaybe t d) + else k t + AskChar s k -> simulate s $ \t -> + if Text.null t + then BylineT empty + else k (Text.head t) + AskPassword s _ k -> simulate s k + PushCompFunc f k -> + BylineT + ( lift . modify $ \st -> + st {completionFunctions = f : completionFunctions st} + ) + >> k + PopCompFunc k -> + BylineT + ( lift . modify $ \st -> + case completionFunctions st of + [] -> st {completionFunctions = []} + _ : xs -> st {completionFunctions = xs} + ) + >> k + simulate :: Stylized Text -> (Text -> BylineT m b) -> BylineT m b + simulate s f = do + BylineT (modify $ \st -> st {precedingPrompt = renderText Plain s}) + simfun <- BylineT (gets simulationFunction) + BylineT (lift simfun) >>= \case + SimulatedInput t -> f t + SimulatedEOF -> BylineT empty + +-- | Discharge the 'MonadByline' effect using the given 'SimulationFunction'. +-- +-- @since 1.0.0.0 +runBylineT :: Monad m => SimulationFunction m -> BylineT m a -> m (Maybe a) +runBylineT f = + unBylineT + >>> runMaybeT + >>> (`evalStateT` SimulationState "" f []) diff --git a/src/Byline/Internal/Stylized.hs b/src/Byline/Internal/Stylized.hs new file mode 100644 --- /dev/null +++ b/src/Byline/Internal/Stylized.hs @@ -0,0 +1,248 @@ +{-# OPTIONS_HADDOCK hide #-} + +-- | +-- +-- 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 Byline.Internal.Stylized + ( Stylized (..), + ToStylizedText (..), + text, + fg, + bg, + bold, + underline, + swapFgBg, + RenderMode (..), + render, + renderText, + ) +where + +import Byline.Internal.Color (Color) +import qualified Byline.Internal.Color as Color +import Byline.Internal.Types (Modifier (..), OnlyOne (..), Status (..)) +import qualified Data.Text.IO as Text +import qualified System.Console.ANSI as ANSI + +-- | A stylized value. Construct text with modifiers using string +-- literals and the @OverloadedStrings@ extension and/or the 'text' +-- function. +-- +-- @since 1.0.0.0 +data Stylized a + = -- | Something to stylize. + Stylized Modifier a + | -- | Modify the next stylized value. + StylizedMod Modifier + | -- | Multiple stylized values. + StylizedList [Stylized a] + deriving (Show, Eq, Functor, Foldable, Traversable) + +-- | @since 1.0.0.0 +instance Semigroup (Stylized a) where + -- StylizedText on LHS. + (<>) a@(Stylized _ _) b@(Stylized _ _) = StylizedList [a, b] + (<>) (Stylized m t) (StylizedMod m') = Stylized (m <> m') t + (<>) a@(Stylized _ _) (StylizedList b) = StylizedList (a : b) + -- StylizedMod on LHS. + (<>) (StylizedMod m) (Stylized m' t) = Stylized (m <> m') t + (<>) (StylizedMod m) (StylizedMod m') = StylizedMod (m <> m') + (<>) m@(StylizedMod _) (StylizedList l) = StylizedList (map (m <>) l) + -- StylizedList on LHS. + (<>) (StylizedList l) t@(Stylized _ _) = StylizedList (l <> [t]) + (<>) (StylizedList l) m@(StylizedMod _) = StylizedList (map (<> m) l) + (<>) (StylizedList l) (StylizedList l') = StylizedList (l <> l') + +-- | @since 1.0.0.0 +instance Monoid (Stylized a) where + mempty = StylizedList [] + +-- | @since 1.0.0.0 +instance IsString (Stylized Text) where + fromString = text . toText + +-- | A class for types that can be converted to 'Stylized' text. +class ToStylizedText a where + toStylizedText :: a -> Stylized Text + +-- | @since 1.0.0.0 +instance ToStylizedText (Stylized Text) where + toStylizedText = id + +-- | Helper function to create stylized text. If you enable the +-- @OverloadedStrings@ extension then you can create stylized text +-- directly without using this function. +-- +-- This function is also helpful for producing stylized text from an +-- existing @Text@ value. +-- +-- @since 1.0.0.0 +text :: Text -> Stylized Text +text = Stylized mempty + +-- | Set the foreground color. For example: +-- +-- @ +-- "Hello World!" <> fg magenta +-- @ +-- +-- @since 1.0.0.0 +fg :: Color -> Stylized Text +fg c = StylizedMod (mempty {modColorFG = OnlyOne (Just c)}) + +-- | Set the background color. +-- +-- @since 1.0.0.0 +bg :: Color -> Stylized Text +bg c = StylizedMod (mempty {modColorBG = OnlyOne (Just c)}) + +-- | Produce bold text. +-- +-- @since 1.0.0.0 +bold :: Stylized Text +bold = StylizedMod (mempty {modBold = On}) + +-- | Produce underlined text. +-- +-- @since 1.0.0.0 +underline :: Stylized Text +underline = StylizedMod (mempty {modUnderline = On}) + +-- | Produce swapped foreground/background text. +-- +-- @since 1.0.0.0 +swapFgBg :: Stylized Text +swapFgBg = StylizedMod (mempty {modSwapFgBg = On}) + +-- | How to render stylized text. +-- +-- @since 1.0.0.0 +data RenderMode + = -- | Text only, no modifiers. + Plain + | -- | Allow up to 8 colors. + Simple + | -- | Allow up to 216 colors. + Term256 + | -- | A terminal that supports full RGB colors. + TermRGB + +-- | Instructions for formatting stylized text after the 'RenderMode' +-- has already been considered. +-- +-- @since 1.0.0.0 +data RenderInstruction + = RenderText Text + | RenderSGR [ANSI.SGR] + +-- | Send stylized text to the given handle. +-- +-- @since 1.0.0.0 +render :: RenderMode -> Handle -> Stylized Text -> IO () +render mode h stylized = mapM_ go (renderInstructions mode stylized) + where + go :: RenderInstruction -> IO () + go (RenderText t) = Text.hPutStr h t + go (RenderSGR s) = ANSI.hSetSGR h s + +-- | Render all modifiers as escape characters and return the +-- resulting text. The text produced from this function is formatted +-- for output by Haskeline. +-- +-- @since 1.0.0.0 +renderText :: RenderMode -> Stylized Text -> Text +renderText mode stylized = foldMap go (renderInstructions mode stylized) + where + go :: RenderInstruction -> Text + go = \case + RenderText t -> t + RenderSGR s -> + -- NOTE: The \STX character below is not a real terminal + -- escape character. Instead it is intercepted by Haskeline. + -- See: https://github.com/judah/haskeline/wiki/ControlSequencesInPrompt + toText (ANSI.setSGRCode s) <> "\STX" + +-- | Internal function to turn stylized text into render instructions. +-- +-- @since 1.0.0.0 +renderInstructions :: RenderMode -> Stylized Text -> [RenderInstruction] +renderInstructions mode = \case + Stylized m t -> renderMod mode (t, m) + StylizedMod _ -> [] + StylizedList xs -> concatMap (renderInstructions mode) xs + where + renderMod :: RenderMode -> (Text, Modifier) -> [RenderInstruction] + renderMod mode (t, m) = + case mode of + Plain -> + -- Only render text, no modifiers. + [RenderText t] + Simple -> + -- Terminal supports basic 16 colors. + let color l = ANSI.SetColor l ANSI.Dull . Color.colorAsANSI + in renderToSGR t m color + Term256 -> + -- Terminal supports the 256-color palette. + let color l = ANSI.SetPaletteColor l . Color.colorAsIndex256 + in renderToSGR t m color + TermRGB -> + -- Super terminal! + let color l c = case Color.colorAsRGB c of + Left ac -> ANSI.SetColor l ANSI.Dull ac + Right rgb -> ANSI.SetRGBColor l rgb + in renderToSGR t m color + renderToSGR :: + Text -> + Modifier -> + (ANSI.ConsoleLayer -> Color -> ANSI.SGR) -> + [RenderInstruction] + renderToSGR t m f = + [ RenderSGR (modToSGR m f), + RenderText t, + RenderSGR [ANSI.Reset] + ] + +-- | Convert a modifier into a series of ANSI.SGR codes. +-- +-- @since 1.0.0.0 +modToSGR :: + -- | The modifier to render as an SGR code. + Modifier -> + -- | A function that knows how to render colors. + (ANSI.ConsoleLayer -> Color -> ANSI.SGR) -> + -- | The resulting SGR codes. + [ANSI.SGR] +modToSGR mod colorF = + catMaybes + [ colorF ANSI.Foreground <$> getColor modColorFG, + colorF ANSI.Background <$> getColor modColorBG, + ANSI.SetConsoleIntensity <$> getIntensity, + ANSI.SetUnderlining <$> getUnderlining, + ANSI.SetSwapForegroundBackground <$> getSwapForegroundBackground + ] + where + getColor :: (Modifier -> OnlyOne Color) -> Maybe Color + getColor f = unOne (f mod) + getIntensity :: Maybe ANSI.ConsoleIntensity + getIntensity = case modBold mod of + Off -> Nothing + On -> Just ANSI.BoldIntensity + getUnderlining :: Maybe ANSI.Underlining + getUnderlining = case modUnderline mod of + Off -> Nothing + On -> Just ANSI.SingleUnderline + getSwapForegroundBackground :: Maybe Bool + getSwapForegroundBackground = case modSwapFgBg mod of + Off -> Nothing + On -> Just True diff --git a/src/Byline/Internal/Types.hs b/src/Byline/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Byline/Internal/Types.hs @@ -0,0 +1,91 @@ +{-# OPTIONS_HADDOCK hide #-} + +-- | +-- +-- 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 Byline.Internal.Types + ( Color (..), + Status (..), + OnlyOne (..), + Modifier (..), + ) +where + +import qualified System.Console.ANSI as ANSI + +-- | Opaque type for representing a color. +-- +-- A color can be one of the eight standard terminal colors +-- constructed with one of the named color functions (e.g., +-- 'Byline.black', 'Byline.red', etc.) or using the 'Byline.rgb' +-- function. +-- +-- @since 1.0.0.0 +data Color + = ColorCode ANSI.Color + | ColorRGB (Word8, Word8, Word8) + deriving (Show, Eq) + +-- | Like @Bool@, but with a different @Monoid@ instance. +-- +-- @since 1.0.0.0 +data Status = On | Off + deriving (Show, Eq) + +-- | @since 1.0.0.0 +instance Semigroup Status where + (<>) Off Off = Off + (<>) Off On = On + (<>) On On = On + (<>) On Off = On + +-- | @since 1.0.0.0 +instance Monoid Status where + mempty = Off + +-- | Like @Maybe@, but with a different @Monoid@ instance. +-- +-- @since 1.0.0.0 +newtype OnlyOne a = OnlyOne {unOne :: Maybe a} + deriving (Show, Eq) + +-- | @since 1.0.0.0 +instance Semigroup (OnlyOne a) where + (<>) _ b@(OnlyOne (Just _)) = b + (<>) a _ = a + +-- | @since 1.0.0.0 +instance Monoid (OnlyOne a) where + mempty = OnlyOne Nothing + +-- | Information about modifications made to stylized text. +-- +-- @since 1.0.0.0 +data Modifier = Modifier + { modColorFG :: OnlyOne Color, + modColorBG :: OnlyOne Color, + modBold :: Status, + modUnderline :: Status, + modSwapFgBg :: Status + } + deriving (Show, Eq) + +-- | @since 1.0.0.0 +instance Semigroup Modifier where + (<>) (Modifier a b c d e) (Modifier a' b' c' d' e') = + Modifier (a <> a') (b <> b') (c <> c') (d <> d') (e <> e') + +-- | @since 1.0.0.0 +instance Monoid Modifier where + mempty = Modifier mempty mempty mempty mempty mempty diff --git a/src/Byline/Menu.hs b/src/Byline/Menu.hs new file mode 100644 --- /dev/null +++ b/src/Byline/Menu.hs @@ -0,0 +1,273 @@ +-- | +-- +-- 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 Byline.Menu + ( -- * Menus with Tab Completion + -- $usage + + -- * Building a Menu + Menu, + menu, + menuBanner, + menuPrefix, + menuSuffix, + FromChoice, + menuFromChoiceFunc, + + -- * Prompting with a Menu + askWithMenu, + askWithMenuRepeatedly, + Choice (..), + + -- * Re-exports + module Byline, + ) +where + +import Byline +import Byline.Completion +import Byline.Internal.Stylized (RenderMode (..), renderText) +import qualified Data.Text as Text +import Relude.Extra.Map +import Text.Printf (printf) + +-- | Opaque type representing a menu containing items of type @a@. +-- +-- @since 1.0.0.0 +data Menu a = Menu + { -- | Menu items. + _menuItems :: NonEmpty a, + -- | Banner printed before menu. + _menuBanner :: Maybe (Stylized Text), + -- | Stylize an item's index. + _menuItemPrefix :: Int -> Stylized Text, + -- | Printed after an item's index. + _menuItemSuffix :: Stylized Text, + -- | Printed before the prompt. + _menuBeforePrompt :: Maybe (Stylized Text), + -- | 'FromChoice' function. + _menuItemFromChoiceFunc :: FromChoice a + } + +instance Foldable Menu where + foldMap f Menu {..} = foldMap f _menuItems + toList Menu {..} = toList _menuItems + null _ = False + length Menu {..} = length _menuItems + +-- | A type representing the choice made by a user while working with +-- a menu. +-- +-- @since 1.0.0.0 +data Choice a + = -- | User picked a menu item. + Match a + | -- | User entered text that doesn't match an item. + Other Text + deriving (Show, Eq, Functor, Foldable, Traversable) + +-- | A function that is given the input from a user while working in a +-- menu and should translate that into a 'Choice'. +-- +-- The @Map@ contains the menu item indexes/prefixes (numbers or +-- letters) and the items themselves. +-- +-- The default 'FromChoice' function allows the user to select a menu +-- item by typing its index or part of its textual representation. As +-- long as input from the user is a unique prefix of one of the menu +-- items then that item will be returned. +-- +-- @since 1.0.0.0 +type FromChoice a = Menu a -> Map Text a -> Text -> Choice a + +-- | Default prefix generator. Creates numbers aligned for two-digit +-- prefixes. +-- +-- @since 1.0.0.0 +numbered :: Int -> Stylized Text +numbered = text . Text.pack . printf "%2d" + +-- | Helper function to produce a list of menu items matching the +-- given user input. +-- +-- @since 1.0.0.0 +matchOnPrefix :: ToStylizedText a => Menu a -> Text -> [a] +matchOnPrefix config input = + filter prefixCheck (toList $ _menuItems config) + where + asText i = renderText Plain (toStylizedText i) + prefixCheck i = input `Text.isPrefixOf` asText i + +-- | Default 'FromChoice' function. Checks to see if the user has input +-- a unique prefix for a menu item (matches the item text) or selected +-- one of the generated item prefixes (such as those generated by the +-- internal @numbered@ function). +-- +-- @since 1.0.0.0 +defaultFromChoice :: forall a. ToStylizedText a => FromChoice a +defaultFromChoice config prefixes input = + case uniquePrefix <|> lookup cleanInput prefixes of + Nothing -> Other input + Just match -> Match match + where + cleanInput :: Text + cleanInput = Text.strip input + uniquePrefix :: Maybe a + uniquePrefix = + let matches = matchOnPrefix config cleanInput + in if length matches == 1 + then listToMaybe matches + else Nothing + +-- | Default completion function. Matches all of the menu items. +-- +-- @since 1.0.0.0 +defaultCompFunc :: (Applicative m, ToStylizedText a) => Menu a -> CompletionFunc m +defaultCompFunc config (left, _) = + pure ("", completions matches) + where + -- All matching menu items. + matches = + if Text.null left + then toList (_menuItems config) + else matchOnPrefix config left + -- Convert a menu item to a String. + asText i = renderText Plain (toStylizedText i) + -- Convert menu items into Completion values. + completions = map (\i -> Completion (asText i) (asText i) True) + +-- | Create a 'Menu' by giving a list of menu items and a function +-- that can convert those items into stylized text. +-- +-- @since 1.0.0.0 +menu :: ToStylizedText a => NonEmpty a -> Menu a +menu items = + Menu + { _menuItems = items, + _menuBanner = Nothing, + _menuItemPrefix = numbered, + _menuItemSuffix = text ") ", + _menuBeforePrompt = Nothing, + _menuItemFromChoiceFunc = defaultFromChoice + } + +-- | Change the banner of a menu. The banner is printed just before +-- the menu items are displayed. +-- +-- @since 1.0.0.0 +menuBanner :: ToStylizedText b => b -> Menu a -> Menu a +menuBanner b m = m {_menuBanner = Just (toStylizedText b)} + +-- | Change the prefix function. The prefix function should generate +-- unique, stylized text that the user can use to select a menu item. +-- The default prefix function numbers the menu items starting with 1. +-- +-- @since 1.0.0.0 +menuPrefix :: (Int -> Stylized Text) -> Menu a -> Menu a +menuPrefix f m = m {_menuItemPrefix = f} + +-- | Change the menu item suffix. It is displayed directly after the +-- menu item prefix and just before the menu item itself. +-- +-- Default: @") "@ +-- +-- @since 1.0.0.0 +menuSuffix :: Stylized Text -> Menu a -> Menu a +menuSuffix s m = m {_menuItemSuffix = s} + +-- | Change the 'FromChoice' function. The function should +-- compare the user's input to the menu items and their assigned +-- prefix values and return a 'Choice'. +-- +-- @since 1.0.0.0 +menuFromChoiceFunc :: FromChoice a -> Menu a -> Menu a +menuFromChoiceFunc f m = m {_menuItemFromChoiceFunc = f} + +-- | Ask the user to choose an item from a menu. The menu will only +-- be shown once and the user's choice will be returned in a 'Choice' +-- value. +-- +-- If you want to force the user to only choose from the displayed +-- menu items you should use 'askWithMenuRepeatedly' instead. +-- +-- @since 1.0.0.0 +askWithMenu :: + (MonadByline m, ToStylizedText a, ToStylizedText b) => + -- | The 'Menu' to display. + Menu a -> + -- | The prompt. + b -> + -- | The 'Choice' the user selected. + m (Choice a) +askWithMenu m prompt = + pushCompletionFunction (defaultCompFunc m) + *> go + <* popCompletionFunction + where + go = do + prefixes <- displayMenu + answer <- askLn prompt (Just firstItem) + pure (_menuItemFromChoiceFunc m m prefixes answer) + -- The default menu item. + firstItem = Text.strip (renderText Plain (_menuItemPrefix m 1)) + -- Print the entire menu. + displayMenu = do + maybe pass ((<> "\n") >>> sayLn) (_menuBanner m) + cache <- foldlM listItem mempty (zip [1 ..] (toList $ _menuItems m)) + sayLn (maybe mempty ("\n" <>) (_menuBeforePrompt m)) + pure cache + -- Print a menu item and cache its prefix in a Map. + listItem cache (index, item) = do + let bullet = _menuItemPrefix m index + rendered = renderText Plain bullet + sayLn $ + mconcat + [ text " ", -- Indent. + bullet, -- Unique identifier. + _menuItemSuffix m, -- Spacer or marker. + toStylizedText item -- The item. + ] + pure (one (Text.strip rendered, item) <> cache) + +-- | Like 'askWithMenu' except that arbitrary input is not allowed. +-- If the user doesn't correctly select a menu item then the menu will +-- be repeated and an error message will be displayed. +-- +-- @since 1.0.0.0 +askWithMenuRepeatedly :: + (MonadByline m, ToStylizedText a, ToStylizedText b, ToStylizedText e) => + -- | The 'Menu' to display. + Menu a -> + -- | The prompt. + b -> + -- | Error message when the user tried to select a non-menu item. + e -> + -- | The 'Choice' the user selected. + m a +askWithMenuRepeatedly m prompt errprompt = go m + where + go config = do + answer <- askWithMenu config prompt + case answer of + Other _ -> go (config {_menuBeforePrompt = Just (toStylizedText errprompt)}) + Match x -> pure x + +-- $usage +-- +-- Menus are used to provide the user with a choice of acceptable +-- values. Each choice is labeled to make it easier for a user to +-- select it, or the user may enter text that does not correspond to +-- any of the menus items. +-- +-- For an example see the @menu.hs@ file in the @examples@ directory. diff --git a/src/Byline/Simulation.hs b/src/Byline/Simulation.hs new file mode 100644 --- /dev/null +++ b/src/Byline/Simulation.hs @@ -0,0 +1,41 @@ +-- | +-- +-- 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 Byline.Simulation + ( -- * Simulating User Interaction + -- $use + + -- * Simulated Values + Simulated (..), + SimulationFunction, + + -- * Access to Simulation State + SimulationState (..), + + -- * Simulation as a Monad Transformer + BylineT, + runBylineT, + + -- * Re-exports + module Byline, + ) +where + +import Byline hiding (BylineT, runBylineT) +import Byline.Internal.Simulation + +-- $use +-- +-- This module provides a monad transformer that can simulate an +-- interactive user session for testing 'MonadByline' code. diff --git a/src/System/Console/Byline.hs b/src/System/Console/Byline.hs deleted file mode 100644 --- a/src/System/Console/Byline.hs +++ /dev/null @@ -1,119 +0,0 @@ -{- - -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 git://pmade.com/byline/LICENSE. No part of the -byline package, including this file, may be copied, modified, -propagated, or distributed except according to the terms contained in -the LICENSE file. - --} - --------------------------------------------------------------------------------- -module System.Console.Byline - ( -- * Introduction - -- - -- | Byline provides a monad transformer that allows you to compose - -- interactive terminal actions. When producing output, - -- these actions accept stylized text that can include - -- foreground and background colors, underlined text, and - -- bold text. - -- - -- Stylized text can be constructed with string literals - -- (using the @OverloadedStrings@ extension) or using the - -- 'text' function. Attributes such as color can be changed - -- using modifier functions and the @mappend@ operator, - -- @(<>)@. - -- - -- Actions that read user input can work with completion - -- functions which are activated when the user presses the - -- tab key. Most input actions also support default values - -- that will be returned when the user presses the enter key - -- without providing any input. - -- - -- Example: - -- - -- @ - -- {-\# LANGUAGE OverloadedStrings \#-} - -- - -- ... - -- - -- language <- runByline $ do - -- sayLn ("Look mom, " <> ("colors" <> fg blue) <> "!") - -- - -- let question = "What's your favorite " <> - -- ("language" <> bold) <> "? " - -- - -- ask question Nothing - -- @ - -- - -- More complete examples can be found in the @examples@ - -- directory of the distribution tarball or in the - -- repository. - - -- * Executing Interactive Sessions - Byline - , runByline - - -- * Primitive Operations - , say - , sayLn - , ask - , askChar - , askPassword - , askUntil - , report - , reportLn - - -- * Constructing Stylized Text - , Stylized - , text - - -- * Modifying Output Text - - -- | The 'Stylized' type is an instance of the monoid class. - -- This means you can change attributes of the text by using - -- the following functions along with @mappend@ or the @(<>)@ - -- operator. - , fg, bg, bold, underline, swapFgBg - - -- * Specifying Colors - , Color - , black, red, green, yellow, blue, magenta, cyan, white, rgb - - -- * Menus - - -- | Menus provide a way to display a small number of list items - -- to the user. The desired list item is selected by typing - -- its index or by typing a unique prefix string. A default - -- completion function is provided to allow the user to - -- select a list item using tab completion. - , Menu - , Choice (..) - , menu - , askWithMenu - , askWithMenuRepeatedly - , banner - , prefix - , suffix - , Matcher - , matcher - - -- * Completion - , CompletionFunc - , Completion (..) - , withCompletionFunc - - -- * Utility Functions, Operators, and Types - , ReportType (..) - , (<>) - ) where - --------------------------------------------------------------------------------- -import System.Console.Byline.Color -import System.Console.Byline.Completion -import System.Console.Byline.Internal.Byline -import System.Console.Byline.Menu -import System.Console.Byline.Modifiers -import System.Console.Byline.Primitive -import System.Console.Byline.Stylized diff --git a/src/System/Console/Byline/Color.hs b/src/System/Console/Byline/Color.hs deleted file mode 100644 --- a/src/System/Console/Byline/Color.hs +++ /dev/null @@ -1,69 +0,0 @@ -{- - -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 git://pmade.com/byline/LICENSE. No part of the -byline package, including this file, may be copied, modified, -propagated, or distributed except according to the terms contained in -the LICENSE file. - --} - - --------------------------------------------------------------------------------- --- | Color type and functions for specifying colors. -module System.Console.Byline.Color - ( Color (..) - , black, red, green, yellow, blue, magenta, cyan, white - , rgb - ) where - --------------------------------------------------------------------------------- --- Library imports: -import Data.Word -import qualified System.Console.ANSI as ANSI - --------------------------------------------------------------------------------- --- | Opaque type for representing a color. --- --- A color can be one of the eight standard terminal colors --- constructed with one of the named color functions (e.g., 'black', --- 'red', etc.) or using the 'rgb' function. -data Color = ColorCode ANSI.Color | ColorRGB (Word8, Word8, Word8) - --------------------------------------------------------------------------------- --- | Standard ANSI color by name. -black, red, green, yellow, blue, magenta, cyan, white :: Color -black = ColorCode ANSI.Black -red = ColorCode ANSI.Red -green = ColorCode ANSI.Green -yellow = ColorCode ANSI.Yellow -blue = ColorCode ANSI.Blue -magenta = ColorCode ANSI.Magenta -cyan = ColorCode ANSI.Cyan -white = ColorCode ANSI.White - --------------------------------------------------------------------------------- --- | Specify a color using a RGB triplet where each component is in --- the range @[0 .. 255]@. The actual rendered color will depend on --- the terminal. --- --- If the terminal advertises that it supports 256 colors, the color --- given to this function will be converted to the nearest color in --- the 216-color pallet supported by the terminal. (216 colors --- because the first 16 are the standard colors and the last 24 are --- grayscale entries.) --- --- However, if the terminal doesn't support extra colors, or doesn't --- have a @TERMINFO@ entry (e.g., Windows) then the nearest standard --- color will be chosen. --- --- Nearest colors are calculated using their CIE distance from one --- another. --- --- See also: --- --- * --- * -rgb :: Word8 -> Word8 -> Word8 -> Color -rgb r g b = ColorRGB (r, g, b) diff --git a/src/System/Console/Byline/Completion.hs b/src/System/Console/Byline/Completion.hs deleted file mode 100644 --- a/src/System/Console/Byline/Completion.hs +++ /dev/null @@ -1,57 +0,0 @@ -{- - -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 git://pmade.com/byline/LICENSE. No part of the -byline package, including this file, may be copied, modified, -propagated, or distributed except according to the terms contained in -the LICENSE file. - --} - --------------------------------------------------------------------------------- --- | The completion types. -module System.Console.Byline.Completion - ( CompletionFunc - , Completion (..) - ) where - --------------------------------------------------------------------------------- --- Library imports: -import Data.Text (Text) - --------------------------------------------------------------------------------- --- | A completion function modeled after the one used in Haskeline. --- --- /Warning:/ If you're familiar with the Haskeline version of the --- @CompletionFunc@ type please be sure to read this description --- carefully since the two behave differently. --- --- The completion function is called when the user presses the tab --- key. The current input line is split into two parts based on where --- the cursor is positioned. Text to the left of the cursor will be --- the first value in the tuple and text to the right of the cursor --- will be the second value. --- --- The text returned from the completion function is the text from the --- left of the cursor which wasn't used in the completion. It should --- also produce a list of possible 'Completion' values. --- --- In Haskeline, some of these text values are reversed. This is --- /not/ the case in Byline. --- --- /A note about @IO@:/ --- --- Due to the way that Byline uses Haskeline, the completion function --- is forced to return an @IO@ value. It would be better if it could --- return a value in the base monad instead. Patches welcome. -type CompletionFunc = (Text, Text) -> IO (Text, [Completion]) - --------------------------------------------------------------------------------- --- | A type representing a completion match to the user's input. -data Completion = Completion - { replacement :: Text -- ^ Text to insert to the right of the cursor. - , display :: Text -- ^ Text to display when listing all completions. - , isFinished :: Bool -- ^ Whether to follow the completed word with a - -- terminating space or close existing quotes. - } deriving (Eq, Ord, Show) diff --git a/src/System/Console/Byline/Internal/Byline.hs b/src/System/Console/Byline/Internal/Byline.hs deleted file mode 100644 --- a/src/System/Console/Byline/Internal/Byline.hs +++ /dev/null @@ -1,153 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# OPTIONS_HADDOCK hide #-} - -{- - -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 git://pmade.com/byline/LICENSE. No part of the -byline package, including this file, may be copied, modified, -propagated, or distributed except according to the terms contained in -the LICENSE file. - --} - --------------------------------------------------------------------------------- --- | Internal module containing the @Byline@ monad transformer. -module System.Console.Byline.Internal.Byline - ( Byline (..) - , Env (..) - , eof - , liftBase - , liftInputT - , runByline - ) where - --------------------------------------------------------------------------------- --- Library imports: -import Control.Applicative -import Control.Monad.Catch -import Control.Monad.Reader -import Control.Monad.Trans.Maybe -import Data.IORef -import System.Environment (lookupEnv) -import System.IO (Handle, stdout) -import qualified System.Terminfo as Term -import qualified System.Terminfo.Caps as Term - --------------------------------------------------------------------------------- --- Import Haskeline, which is used to do the heavy lifting. -import qualified System.Console.Haskeline as H -import qualified System.Console.Haskeline.IO as H - --------------------------------------------------------------------------------- --- Byline imports: -import System.Console.Byline.Internal.Completion -import System.Console.Byline.Internal.Render - --------------------------------------------------------------------------------- --- The following is a kludge to avoid the "redundant import" warning --- when using GHC >= 7.10.x. This should be removed after we decide --- to stop supporting GHC < 7.10.x. -import Prelude - --------------------------------------------------------------------------------- --- | Reader environment for Byline. -data Env = Env - { sayMode :: RenderMode - , askMode :: RenderMode - , outHandle :: Handle - , inputState :: H.InputState - , compFunc :: IORef (Maybe CompletionFunc) - } - --------------------------------------------------------------------------------- --- | A monad transformer that encapsulates interactive actions. -newtype Byline m a = Byline {unByline :: ReaderT Env (MaybeT m) a} - deriving (Functor, Applicative, Monad, MonadReader Env, MonadIO) - -instance MonadTrans Byline where - lift = liftBase - --------------------------------------------------------------------------------- --- | Calculate the default rendering modes based on the terminal type. -defRenderMode :: H.InputT IO (RenderMode, RenderMode) -defRenderMode = do - termHint <- H.haveTerminalUI - maxColors <- liftIO (runMaybeT getMaxColors) - - return $ case (termHint, maxColors) of - (True, Just n) | n < 256 -> (Simple, Simple) - | otherwise -> (Term256, Term256) - (True, Nothing) -> (Simple, Plain) - (False, _) -> (Plain, Plain) - where - getMaxColors :: MaybeT IO Int - getMaxColors = do - term <- MaybeT (lookupEnv "TERM") - db <- liftIO (Term.acquireDatabase term) - - case db of - Left _ -> MaybeT (return Nothing) - Right d -> MaybeT (return $ Term.queryNumTermCap d Term.MaxColors) - --------------------------------------------------------------------------------- --- | Create the default reader environment. -defEnv :: H.InputState - -> (RenderMode, RenderMode) - -> IORef (Maybe CompletionFunc) - -> Env -defEnv state (smode, amode) comp = - Env { sayMode = smode - , askMode = amode - , outHandle = stdout - , inputState = state - , compFunc = comp - } - --------------------------------------------------------------------------------- --- | Signal an EOF and terminate all Byline actions. -eof :: (Monad m) => Byline m a -eof = Byline $ lift (MaybeT $ return Nothing) - --------------------------------------------------------------------------------- --- | Lift an operation in the base monad into Byline. -liftBase :: (Monad m) => m a -> Byline m a -liftBase = Byline . lift . lift - --------------------------------------------------------------------------------- --- | Lift an 'InputT' action into 'Byline'. -liftInputT :: (MonadIO m) => H.InputT IO a -> Byline m a -liftInputT input = do - state <- asks inputState - liftIO (H.queryInput state $ H.withInterrupt input) - --------------------------------------------------------------------------------- --- | Execute 'Byline' actions and produce a result within the base monad. --- --- /A note about EOF:/ --- --- If an End of File (EOF) is encountered during an input action then --- this function will return @Nothing@. This can occur when the user --- manually enters an EOF character by pressing @Control-d@ or if --- standard input is a file. --- --- This decision was made to simplify the @Byline@ interface for --- actions that read user input and is a typical strategy for terminal --- applications. If this isn't desirable, you may want to break your --- actions up into groups and call 'runByline' multiple times. -runByline :: (MonadIO m, MonadMask m) => Byline m a -> m (Maybe a) -runByline (Byline byline) = do - comp <- liftIO (newIORef Nothing) - let settings = H.setComplete (runCompletionFunction comp) H.defaultSettings - - bracketOnError (liftIO $ H.initializeInput settings) -- Acquire. - (liftIO . H.cancelInput) -- Release. - (go comp) -- Use. - where - go comp state = do - modes <- liftIO (H.queryInput state defRenderMode) - output <- runMaybeT $ runReaderT byline (defEnv state modes comp) - - liftIO (H.closeInput state) - return output diff --git a/src/System/Console/Byline/Internal/Color.hs b/src/System/Console/Byline/Internal/Color.hs deleted file mode 100644 --- a/src/System/Console/Byline/Internal/Color.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_HADDOCK hide #-} - -{- - -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 git://pmade.com/byline/LICENSE. No part of the -byline package, including this file, may be copied, modified, -propagated, or distributed except according to the terms contained in -the LICENSE file. - --} - - --------------------------------------------------------------------------------- --- | Internal color operations. -module System.Console.Byline.Internal.Color - ( Color (..) - , colorAsANSI - , nearestColor - , term256Locations - ) where - --------------------------------------------------------------------------------- --- Library imports: -import Control.Arrow (second) -import qualified Data.Colour.CIE as C -import qualified Data.Colour.SRGB as C -import Data.List (sortBy) -import Data.Maybe -import Data.Ord (comparing) -import Data.Word -import qualified System.Console.ANSI as ANSI - --------------------------------------------------------------------------------- --- Byline imports: -import System.Console.Byline.Color - --------------------------------------------------------------------------------- --- | Convert a Byline color to an ANSI color. -colorAsANSI :: Color -> ANSI.Color -colorAsANSI (ColorCode c) = c -colorAsANSI (ColorRGB c) = nearestColor c ansiColorLocations - --------------------------------------------------------------------------------- --- | Find the nearest color given a full RGB color. -nearestColor :: (Bounded a) - => (Word8, Word8, Word8) -- ^ Original color. - -> [(a, (Double, Double, Double))] -- ^ List of colors and locations. - -> a -- ^ Destination color. -nearestColor (r, g, b) table = - case listToMaybe (sortColors $ distances table) of - Nothing -> minBound -- Should never happen. - Just (c, _) -> c - - where - location :: (Double, Double, Double) - location = C.cieXYZView (C.sRGB24 r g b) - - distance :: (Double, Double, Double) -> (Double, Double, Double) -> Double - distance (x1, y1, z1) (x2, y2, z2) = sqrt ((x ** 2) + (y ** 2) + (z ** 2)) - where x = x1 - x2 - y = y1 - y2 - z = z1 - z2 - - distances :: [(a, (Double, Double, Double))] -> [(a, Double)] - distances = map (second (distance location)) - - sortColors :: [(a, Double)] -> [(a, Double)] - sortColors = sortBy (comparing snd) - --------------------------------------------------------------------------------- --- | Get the CIE locations for the standard ANSI colors. --- --- Locations are based on the default xterm colors. See also: --- --- * --- * -ansiColorLocations :: [(ANSI.Color, (Double, Double, Double))] -ansiColorLocations = [ (ANSI.Black, (0.0, 0.0, 0.0)) - , (ANSI.Red, (0.2518, 0.1298, 0.0118)) - , (ANSI.Green, (0.2183, 0.4366, 0.0728)) - , (ANSI.Yellow, (0.4701, 0.5664, 0.0846)) - , (ANSI.Blue, (0.1543, 0.0617, 0.8126)) - , (ANSI.Magenta, (0.3619, 0.1739, 0.592)) - , (ANSI.Cyan, (0.3285, 0.4807, 0.653)) - , (ANSI.White, (0.7447, 0.7835, 0.8532)) - ] - --------------------------------------------------------------------------------- --- | All of the allowed colors for 256 color terminals. -term256Locations :: [(Word8, (Double, Double, Double))] -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) diff --git a/src/System/Console/Byline/Internal/Completion.hs b/src/System/Console/Byline/Internal/Completion.hs deleted file mode 100644 --- a/src/System/Console/Byline/Internal/Completion.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} - -{- - -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 git://pmade.com/byline/LICENSE. No part of the -byline package, including this file, may be copied, modified, -propagated, or distributed except according to the terms contained in -the LICENSE file. - --} - --------------------------------------------------------------------------------- --- | Internal completion operations. -module System.Console.Byline.Internal.Completion - ( CompletionFunc - , Completion (..) - , runCompletionFunction - ) where - --------------------------------------------------------------------------------- --- Library imports: -import Data.IORef -import qualified Data.Text as Text -import qualified System.Console.Haskeline.Completion as H - --------------------------------------------------------------------------------- --- Byline imports: -import System.Console.Byline.Completion - --------------------------------------------------------------------------------- --- | Convert a Byline completion result into a Haskeline completion result. -convertCompletion :: Completion -> H.Completion -convertCompletion (Completion r d i) = - H.Completion { H.replacement = Text.unpack r - , H.display = Text.unpack d - , H.isFinished = i - } - --------------------------------------------------------------------------------- --- | Helper function that allows Byline to swap out the completion function. -runCompletionFunction :: IORef (Maybe CompletionFunc) -> H.CompletionFunc IO -runCompletionFunction compref (left, right) = do - comp <- readIORef compref - - case comp of - Nothing -> H.completeFilename (left, right) - - Just f -> do - (output, completions) <- - f (Text.reverse $ Text.pack left, Text.pack right) - - return (Text.unpack $ Text.reverse output, - map convertCompletion completions) diff --git a/src/System/Console/Byline/Internal/Render.hs b/src/System/Console/Byline/Internal/Render.hs deleted file mode 100644 --- a/src/System/Console/Byline/Internal/Render.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_HADDOCK hide #-} - -{- - -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 git://pmade.com/byline/LICENSE. No part of the -byline package, including this file, may be copied, modified, -propagated, or distributed except according to the terms contained in -the LICENSE file. - --} - --------------------------------------------------------------------------------- --- | Functions for turning stylized text into text or terminal commands. -module System.Console.Byline.Internal.Render - ( RenderMode (..) - , render - , renderText - ) where - --------------------------------------------------------------------------------- --- Library imports: -import Control.Applicative -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Word -import System.Console.ANSI as ANSI -import System.IO (Handle, hPutStr) - --------------------------------------------------------------------------------- --- Byline imports: -import System.Console.Byline.Internal.Color as C -import System.Console.Byline.Internal.Types -import System.Console.Byline.Stylized - --------------------------------------------------------------------------------- --- The following is a kludge to avoid the "redundant import" warning --- when using GHC >= 7.10.x. This should be removed after we decide --- to stop supporting GHC < 7.10.x. -import Prelude - --------------------------------------------------------------------------------- --- | How to render stylized text. -data RenderMode = Plain -- ^ Text only, no modifiers. - | Simple -- ^ Allow up to 8 colors. - | Term256 -- ^ Allow up to 216 colors. - --------------------------------------------------------------------------------- --- | Instructions for formatting stylized text after the 'RenderMode' --- has already been considered. -data RenderInstruction = RenderText Text - | RenderSGR [SGR] - --------------------------------------------------------------------------------- --- | Send stylized text to the given handle. This works on Windows --- thanks to the @ansi-terminal@ package. -render :: RenderMode -> Handle -> Stylized -> IO () -render mode h stylized = mapM_ go (renderInstructions mode stylized) - where - go :: RenderInstruction -> IO () - go (RenderText t) = hPutStr h (Text.unpack t) - go (RenderSGR s) = hSetSGR h s - --------------------------------------------------------------------------------- --- | Render all modifiers as escape characters and return the --- resulting text. On most terminals, sending this text to stdout --- will correctly render the modifiers. However, this won't work on --- Windows consoles so you'll want to send 'Plain' as the 'RenderMode'. -renderText :: RenderMode -> Stylized -> Text -renderText mode stylized = Text.concat $ map go (renderInstructions mode stylized) - where - go :: RenderInstruction -> Text - go (RenderText t) = t - go (RenderSGR _) = Text.empty - --------------------------------------------------------------------------------- --- | Internal function to turn stylized text into render instructions. -renderInstructions :: RenderMode -> Stylized -> [RenderInstruction] -renderInstructions mode = concat . mapStylized renderMod - where - renderMod :: (Text, Modifier) -> [RenderInstruction] - renderMod (t, m) = - case mode of - -- Only rendering text. - Plain -> [ RenderText t ] - - -- Render text with modifiers. The only difference between - -- 'Simple' and 'Term256' is handled by 'modToText'. - _ -> [ RenderSGR (modToSGR m) - , RenderText (modToText mode m) - , RenderText t - , RenderSGR [Reset] - ] - --------------------------------------------------------------------------------- --- | Convert a modifier into a series of SGR codes. -modToSGR :: Modifier -> [SGR] -modToSGR m = - catMaybes [ SetColor Foreground Dull <$> modColor modColorFG - , SetColor Background Dull <$> modColor modColorBG - , SetConsoleIntensity <$> modIntensity - , SetUnderlining <$> modUnderlining - , SetSwapForegroundBackground <$> modSwapForegroundBackground - ] - - where - modColor :: (Modifier -> OnlyOne C.Color) -> Maybe ANSI.Color - modColor f = C.colorAsANSI <$> unOne (f m) - - modIntensity :: Maybe ConsoleIntensity - modIntensity = case modBold m of - Off -> Nothing - On -> Just BoldIntensity - - modUnderlining :: Maybe Underlining - modUnderlining = case modUnderline m of - Off -> Nothing - On -> Just SingleUnderline - - modSwapForegroundBackground :: Maybe Bool - modSwapForegroundBackground = case modSwapFgBg m of - Off -> Nothing - On -> Just True - - --------------------------------------------------------------------------------- --- | Convert modifiers into direct escape sequences for modifiers --- that can't be converted into SGR codes (e.g., RGB colors). --- --- See: -modToText :: RenderMode -> Modifier -> Text -modToText Plain _ = Text.empty -modToText Simple _ = Text.empty -modToText Term256 m = - Text.concat $ catMaybes [ escape Foreground <$> modColor modColorFG - , escape Background <$> modColor modColorBG - ] - - where - modColor :: (Modifier -> OnlyOne C.Color) -> Maybe (Word8, Word8, Word8) - modColor f = case unOne (f m) of - Just (ColorRGB c) -> Just c - _ -> Nothing - - -- Produce the correct CSI escape. - escape :: ConsoleLayer -> (Word8, Word8, Word8) -> Text - escape Foreground c = Text.concat ["\ESC[38;5;", colorIndex c, "m"] - escape Background c = Text.concat ["\ESC[48;5;", colorIndex c, "m"] - - -- Return the 216-color index for (r, g, b). - colorIndex :: (Word8, Word8, Word8) -> Text - colorIndex c = Text.pack $ show (nearestColor c term256Locations) diff --git a/src/System/Console/Byline/Internal/Types.hs b/src/System/Console/Byline/Internal/Types.hs deleted file mode 100644 --- a/src/System/Console/Byline/Internal/Types.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} - -{- - -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 git://pmade.com/byline/LICENSE. No part of the -byline package, including this file, may be copied, modified, -propagated, or distributed except according to the terms contained in -the LICENSE file. - --} - --------------------------------------------------------------------------------- --- | Internal types. -module System.Console.Byline.Internal.Types - ( Status (..) - , OnlyOne (..) - , Modifier (..) - ) where - --------------------------------------------------------------------------------- --- Library imports: -import qualified Data.Semigroup as Semi - --------------------------------------------------------------------------------- --- Byline imports: -import System.Console.Byline.Color (Color) - --------------------------------------------------------------------------------- --- | Like @Bool@, but with a different @Monoid@ instance. -data Status = On | Off - --------------------------------------------------------------------------------- -instance Semi.Semigroup Status where - (<>) Off Off = Off - (<>) Off On = On - (<>) On On = On - (<>) On Off = On - --------------------------------------------------------------------------------- -instance Monoid Status where - mempty = Off - mappend = (Semi.<>) - --------------------------------------------------------------------------------- --- | Like @Maybe@, but with a different @Monoid@ instance. -newtype OnlyOne a = OnlyOne {unOne :: Maybe a} - --------------------------------------------------------------------------------- -instance Semi.Semigroup (OnlyOne a) where - (<>) _ b@(OnlyOne (Just _)) = b - (<>) a _ = a - --------------------------------------------------------------------------------- -instance Monoid (OnlyOne a) where - mempty = OnlyOne Nothing - mappend = (Semi.<>) - --------------------------------------------------------------------------------- --- | Information about modifications made to stylized text. -data Modifier = Modifier - { modColorFG :: OnlyOne Color - , modColorBG :: OnlyOne Color - , modBold :: Status - , modUnderline :: Status - , modSwapFgBg :: Status - } - --------------------------------------------------------------------------------- -instance Semi.Semigroup Modifier where - (<>) (Modifier a b c d e) (Modifier a' b' c' d' e') = - Modifier (a <> a') (b <> b') (c <> c') (d <> d') (e <> e') - --------------------------------------------------------------------------------- -instance Monoid Modifier where - mempty = Modifier mempty mempty mempty mempty mempty - mappend = (Semi.<>) diff --git a/src/System/Console/Byline/Menu.hs b/src/System/Console/Byline/Menu.hs deleted file mode 100644 --- a/src/System/Console/Byline/Menu.hs +++ /dev/null @@ -1,249 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{- - -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 git://pmade.com/byline/LICENSE. No part of the -byline package, including this file, may be copied, modified, -propagated, or distributed except according to the terms contained in -the LICENSE file. - --} - --------------------------------------------------------------------------------- --- | Functions and types for working with menus. -module System.Console.Byline.Menu - ( Menu - , Choice (..) - , Matcher - , menu - , banner - , prefix - , suffix - , matcher - , askWithMenu - , askWithMenuRepeatedly - ) where - --------------------------------------------------------------------------------- --- Library imports: -import Control.Applicative -import Control.Monad -import Control.Monad.IO.Class -import qualified Control.Monad.Reader as Reader -import Data.IORef -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as Text -import Text.Printf (printf) - --------------------------------------------------------------------------------- --- Byline imports: -import System.Console.Byline.Internal.Byline -import System.Console.Byline.Internal.Completion -import System.Console.Byline.Internal.Render -import System.Console.Byline.Primitive -import System.Console.Byline.Stylized - --------------------------------------------------------------------------------- --- | Opaque type representing a menu containing items of type @a@. -data Menu a = Menu - { menuItems :: [a] -- ^ Menu items. - , menuBanner :: Maybe Stylized -- ^ Banner printed before menu. - , menuDisplay :: a -> Stylized -- ^ Stylize a menu item. - , menuItemPrefix :: Int -> Stylized -- ^ Stylize an item's index. - , menuItemSuffix :: Stylized -- ^ Printed after an item's index. - , menuBeforePrompt :: Maybe Stylized -- ^ Printed before the prompt. - , menuMatcher :: Matcher a -- ^ Matcher function. - } - --------------------------------------------------------------------------------- --- | A type representing the choice made by a user while working with --- a menu. -data Choice a = NoItems -- ^ Menu has no items to choose from. - | Match a -- ^ User picked a menu item. - | Other Text -- ^ User entered text that doesn't match an item. - deriving Show - --------------------------------------------------------------------------------- --- | A function that is given the input from a user while working in a --- menu and should translate that into a 'Choice'. --- --- The @Map@ contains the menu item indexes/prefixes (numbers or --- letters) and the items themselves. --- --- The default matcher function allows the user to select a menu item --- by typing its index or part of its textual representation. As long --- as input from the user is a unique prefix of one of the menu items --- then that item will be returned. -type Matcher a = Menu a -> Map Text a -> Text -> Choice a - --------------------------------------------------------------------------------- --- | Default prefix generator. Creates numbers aligned for two-digit --- prefixes. -numbered :: Int -> Stylized -numbered = text . Text.pack . printf "%2d" - --------------------------------------------------------------------------------- --- | Helper function to produce a list of menu items matching the --- given user input. -matchOnPrefix :: Menu a -> Text -> [a] -matchOnPrefix config input = filter prefixCheck (menuItems config) - where - asText i = renderText Plain (menuDisplay config i) - prefixCheck i = input `Text.isPrefixOf` asText i - --------------------------------------------------------------------------------- --- | Default 'Matcher' function. Checks to see if the user has input --- a unique prefix for a menu item (matches the item text) or selected --- one of the generated item prefixes (such as those generated by the --- internal @numbered@ function). -defaultMatcher :: Matcher a -defaultMatcher config prefixes input = - case uniquePrefix <|> Map.lookup cleanInput prefixes of - Nothing -> Other input - Just match -> Match match - - where - cleanInput = Text.strip input - - -- uniquePrefix :: Maybe a - uniquePrefix = let matches = matchOnPrefix config cleanInput - in if length matches == 1 - then listToMaybe matches - else Nothing - --------------------------------------------------------------------------------- --- | Default completion function. Matches all of the menu items. -defaultCompFunc :: Menu a -> CompletionFunc -defaultCompFunc config (left, _) = return ("", completions matches) - where - -- All matching menu items. - matches = if Text.null left - then menuItems config - else matchOnPrefix config left - - -- Convert a menu item to a String. - asText i = renderText Plain (menuDisplay config i) - - -- Convert menu items into Completion values. - completions = map (\i -> Completion (asText i) (asText i) True) - --------------------------------------------------------------------------------- --- | Create a 'Menu' by giving a list of menu items and a function --- that can convert those items into stylized text. -menu :: [a] -> (a -> Stylized) -> Menu a -menu items displayF = - Menu { menuItems = items - , menuBanner = Nothing - , menuDisplay = displayF - , menuItemPrefix = numbered - , menuItemSuffix = text ") " - , menuBeforePrompt = Nothing - , menuMatcher = defaultMatcher - } - --------------------------------------------------------------------------------- --- | Change the banner of a menu. The banner is printed just before --- the menu items are displayed. -banner :: Stylized -> Menu a -> Menu a -banner b m = m {menuBanner = Just b} - --------------------------------------------------------------------------------- --- | Change the prefix function. The prefix function should generate --- unique, stylized text that the user can use to select a menu item. --- The default prefix function numbers the menu items starting with 1. -prefix :: (Int -> Stylized) -> Menu a -> Menu a -prefix f m = m {menuItemPrefix = f} - --------------------------------------------------------------------------------- --- | Change the menu item suffix. It is displayed directly after the --- menu item prefix and just before the menu item itself. --- --- Default: @") "@ -suffix :: Stylized -> Menu a -> Menu a -suffix s m = m {menuItemSuffix = s} - --------------------------------------------------------------------------------- --- | Change the 'Matcher' function. The matcher function should --- compare the user's input to the menu items and their assigned --- prefix values and return a 'Choice'. -matcher :: Matcher a -> Menu a -> Menu a -matcher f m = m {menuMatcher = f} - --------------------------------------------------------------------------------- --- | Ask the user to choose an item from a menu. The menu will only --- be shown once and the user's choice will be returned in a 'Choice' --- value. --- --- If you want to force the user to only choose from the displayed --- menu items you should use 'askWithMenuRepeatedly' instead. -askWithMenu :: (MonadIO m) - => Menu a -- ^ The 'Menu' to display. - -> Stylized -- ^ The prompt. - -> Byline m (Choice a) -askWithMenu m prompt = do - currCompFunc <- Reader.asks compFunc >>= liftIO . readIORef - - if null (menuItems m) - then return NoItems - else go currCompFunc - - where - -- Use the default completion function for menus, but not if another - -- completion function is already active. - go comp = withCompletionFunc (fromMaybe (defaultCompFunc m) comp) $ do - prefixes <- displayMenu - answer <- ask prompt (Just firstItem) - return (menuMatcher m m prefixes answer) - - -- The default menu item. - firstItem = Text.strip $ renderText Plain (menuItemPrefix m 1) - - -- Print the entire menu. - displayMenu = do - case menuBanner m of - Nothing -> return () - Just br -> sayLn (br <> "\n") - - cache <- foldM listItem Map.empty $ zip [1..] (menuItems m) - - case menuBeforePrompt m of - Nothing -> sayLn mempty -- Just for the newline. - Just bp -> sayLn ("\n" <> bp) - - return cache - - -- Print a menu item and cache its prefix in a Map. - listItem cache (index, item) = do - let bullet = menuItemPrefix m index - rendered = renderText Plain bullet - - sayLn $ mconcat [ text " " -- Indent. - , bullet -- Unique identifier. - , menuItemSuffix m -- Spacer or marker. - , menuDisplay m item -- The item. - ] - - return (Map.insert (Text.strip rendered) item cache) - --------------------------------------------------------------------------------- --- | Like 'askWithMenu' except that arbitrary input is not allowed. --- If the user doesn't correctly select a menu item then the menu will --- be repeated and an error message will be displayed. -askWithMenuRepeatedly :: (MonadIO m) - => Menu a -- ^ The 'Menu' to display. - -> Stylized -- ^ The prompt. - -> Stylized -- ^ Error message. - -> Byline m (Choice a) -askWithMenuRepeatedly m prompt errprompt = go m - where - go config = do - answer <- askWithMenu config prompt - - case answer of - Other _ -> go (config {menuBeforePrompt = Just errprompt}) - _ -> return answer diff --git a/src/System/Console/Byline/Modifiers.hs b/src/System/Console/Byline/Modifiers.hs deleted file mode 100644 --- a/src/System/Console/Byline/Modifiers.hs +++ /dev/null @@ -1,66 +0,0 @@ -{- - -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 git://pmade.com/byline/LICENSE. No part of the -byline package, including this file, may be copied, modified, -propagated, or distributed except according to the terms contained in -the LICENSE file. - --} - - --------------------------------------------------------------------------------- --- | Modifiers for the @Stylized@ type. -module System.Console.Byline.Modifiers - ( fg - , bg - , bold - , underline - , swapFgBg - ) where - --------------------------------------------------------------------------------- --- Library imports: -import Data.Monoid - --------------------------------------------------------------------------------- --- Byline imports: -import System.Console.Byline.Internal.Color -import System.Console.Byline.Internal.Types -import System.Console.Byline.Stylized - --------------------------------------------------------------------------------- --- The following is a kludge to avoid the "redundant import" warning --- when using GHC >= 7.10.x. This should be removed after we decide --- to stop supporting GHC < 7.10.x. -import Prelude - --------------------------------------------------------------------------------- --- | Set the foreground color. For example: --- --- @ --- "Hello World!" <> fg magenta --- @ -fg :: Color -> Stylized -fg c = modStylized (mempty {modColorFG = OnlyOne (Just c)}) - --------------------------------------------------------------------------------- --- | Set the background color. -bg :: Color -> Stylized -bg c = modStylized (mempty {modColorBG = OnlyOne (Just c)}) - --------------------------------------------------------------------------------- --- | Produce bold text. -bold :: Stylized -bold = modStylized (mempty {modBold = On}) - --------------------------------------------------------------------------------- --- | Produce underlined text. -underline :: Stylized -underline = modStylized (mempty {modUnderline = On}) - --------------------------------------------------------------------------------- --- | Produce swapped foreground/background text. -swapFgBg :: Stylized -swapFgBg = modStylized (mempty {modSwapFgBg = On}) diff --git a/src/System/Console/Byline/Primitive.hs b/src/System/Console/Byline/Primitive.hs deleted file mode 100644 --- a/src/System/Console/Byline/Primitive.hs +++ /dev/null @@ -1,172 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{- - -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 git://pmade.com/byline/LICENSE. No part of the -byline package, including this file, may be copied, modified, -propagated, or distributed except according to the terms contained in -the LICENSE file. - --} - --------------------------------------------------------------------------------- --- | Primitive operations such as printing messages and reading input. -module System.Console.Byline.Primitive - ( ReportType (..) - , say - , sayLn - , ask - , askChar - , askPassword - , askUntil - , report - , reportLn - , withCompletionFunc - ) where - --------------------------------------------------------------------------------- --- Library imports: -import Control.Monad.IO.Class -import qualified Control.Monad.Reader as Reader -import Data.IORef -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as T -import qualified System.Console.Haskeline as H - --------------------------------------------------------------------------------- ---- Byline imports: -import System.Console.Byline.Color -import System.Console.Byline.Internal.Byline -import System.Console.Byline.Internal.Completion -import System.Console.Byline.Internal.Render -import System.Console.Byline.Modifiers -import System.Console.Byline.Stylized - --------------------------------------------------------------------------------- --- | Report types for the 'report' function. -data ReportType = Error -- ^ Report errors with: @"error: "@ - | Warning -- ^ Report warnings with: @"warning: "@ - --------------------------------------------------------------------------------- --- | Output the stylized text to the output handle (default: stdout). -say :: (MonadIO m) => Stylized -> Byline m () -say message = do - env <- Reader.ask - liftIO $ render (sayMode env) (outHandle env) message - --------------------------------------------------------------------------------- --- | Like 'say', but append a newline character. -sayLn :: (MonadIO m) => Stylized -> Byline m () -sayLn message = say (message <> text "\n") - --------------------------------------------------------------------------------- --- | Read input after printing the given stylized text as a prompt. -ask :: (MonadIO m) - => Stylized - -- ^ The prompt. - - -> Maybe Text - -- ^ Optional default answer that will be returned if the user - -- presses return without providing any input (a zero-length - -- string). - - -> Byline m Text -ask prompt defans = do - let prompt' = case defans of - Nothing -> prompt - Just s -> prompt <> text "[" <> text s <> "] " - - answer <- liftInputT . H.getInputLine =<< renderPrompt prompt' - - case answer of - Nothing -> eof - Just s | null s -> return (fromMaybe (T.pack s) defans) - | otherwise -> return (T.pack s) - --------------------------------------------------------------------------------- --- | Read a single character of input. -askChar :: (MonadIO m) - => Stylized - -> Byline m Char -askChar prompt = do - answer <- liftInputT . H.getInputChar =<< renderPrompt prompt - case answer of - Nothing -> eof - Just c -> return c - --------------------------------------------------------------------------------- --- | Read a password without echoing it to the terminal. If a masking --- character is given it will replace each typed character. -askPassword :: (MonadIO m) - => Stylized - -- ^ The prompt. - - -> Maybe Char - -- ^ Optional masking character that will be printed each - -- time the user presses a key. - - -> Byline m Text -askPassword prompt maskchr = do - pass <- liftInputT . H.getPassword maskchr =<< renderPrompt prompt - case pass of - Nothing -> eof - Just s -> return (T.pack s) - --------------------------------------------------------------------------------- --- | Continue to prompt for a response until a confirmation function --- returns a valid result. --- --- The confirmation function receives the output from 'ask' and should --- return a @Left Stylized@ to produce an error message (printed with --- 'sayLn'). When an acceptable answer from 'ask' is received, the --- confirmation function should return it with @Right@. -askUntil :: (MonadIO m) - => Stylized -- ^ The prompt. - -> Maybe Text -- ^ Optional default answer. - -> (Text -> m (Either Stylized a)) -- ^ Confirmation function. - -> Byline m a -askUntil prompt defans confirm = go where - go = do - answer <- ask prompt defans - check <- liftBase (confirm answer) - - case check of - Left msg -> sayLn msg >> go - Right result -> return result - --------------------------------------------------------------------------------- --- | Output stylized text with a prefix determined by 'ReportType'. -report :: (MonadIO m) => ReportType -> Stylized -> Byline m () -report Error message = say $ (text "error: " <> fg red) <> message -report Warning message = say $ (text "warning: " <> fg yellow) <> message - --------------------------------------------------------------------------------- --- | Like 'report', but append a newline character. -reportLn :: (MonadIO m) => ReportType -> Stylized -> Byline m () -reportLn rt message = report rt (message <> text "\n") - --------------------------------------------------------------------------------- --- | Run the given 'Byline' action with a different completion --- function. -withCompletionFunc :: (MonadIO m) => CompletionFunc -> Byline m a -> Byline m a -withCompletionFunc comp byline = do - compref <- Reader.asks compFunc - current <- liftIO (readIORef compref) - - -- Temporally change the completion function. - -- Exceptions will be dealt with in 'runByline'. - liftIO (writeIORef compref (Just comp)) - output <- byline - - -- Reset the completion function and return the result. - liftIO (writeIORef compref current) - return output - --------------------------------------------------------------------------------- -renderPrompt :: (Monad m) => Stylized -> Byline m String -renderPrompt prompt = do - mode <- Reader.asks askMode - return $ T.unpack (renderText mode prompt) diff --git a/src/System/Console/Byline/Stylized.hs b/src/System/Console/Byline/Stylized.hs deleted file mode 100644 --- a/src/System/Console/Byline/Stylized.hs +++ /dev/null @@ -1,91 +0,0 @@ -{- - -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 git://pmade.com/byline/LICENSE. No part of the -byline package, including this file, may be copied, modified, -propagated, or distributed except according to the terms contained in -the LICENSE file. - --} - --------------------------------------------------------------------------------- --- | The stylized type and constructors. -module System.Console.Byline.Stylized - ( Stylized - , Modifier - , text - , mapStylized - , modStylized - ) where - --------------------------------------------------------------------------------- --- Library imports: -import qualified Data.Semigroup as Semi -import Data.String -import Data.Text (Text) -import qualified Data.Text as T - --------------------------------------------------------------------------------- --- Byline imports: -import System.Console.Byline.Internal.Types - --------------------------------------------------------------------------------- --- | Stylized text. Construct text with modifiers using string --- literals and the @OverloadedStrings@ extension and/or the 'text' --- function. -data Stylized = StylizedText Text Modifier - | StylizedMod Modifier - | StylizedList [Stylized] - --------------------------------------------------------------------------------- --- | Helper function to create stylized text. If you enable the --- @OverloadedStrings@ extension then you can create stylized text --- directly without using this function. --- --- This function is also helpful for producing stylized text from an --- existing @Text@ value. -text :: Text -> Stylized -text t = StylizedText t mempty - --------------------------------------------------------------------------------- --- | Map a function over stylized text. The 'Modifier' type is --- opaque so this function might not be very useful outside of the --- Byline internals. -mapStylized :: ((Text, Modifier) -> a) -> Stylized -> [a] -mapStylized f (StylizedText t m) = [ f (t, m) ] -mapStylized _ (StylizedMod _) = [ ] -- No op. -mapStylized f (StylizedList l) = concatMap (mapStylized f) l - --------------------------------------------------------------------------------- --- | Constructor to modify stylized text. This function is only --- useful to internal Byline functions. -modStylized :: Modifier -> Stylized -modStylized = StylizedMod - --------------------------------------------------------------------------------- -instance Semi.Semigroup Stylized where - -- StylizedText on LHS. - (<>) a@(StylizedText _ _) b@(StylizedText _ _) = StylizedList [a, b] - (<>) (StylizedText t m) (StylizedMod m') = StylizedText t (m <> m') - (<>) a@(StylizedText _ _) (StylizedList b) = StylizedList (a:b) - - -- StylizedMod on LHS. - (<>) (StylizedMod m) (StylizedText t m') = StylizedText t (m <> m') - (<>) (StylizedMod m) (StylizedMod m') = StylizedMod (m <> m') - (<>) m@(StylizedMod _) (StylizedList l) = StylizedList (map (m <>) l) - - -- StylizedList on LHS. - (<>) (StylizedList l) t@(StylizedText _ _) = StylizedList (l <> [t]) - (<>) (StylizedList l) m@(StylizedMod _) = StylizedList (map (<> m) l) - (<>) (StylizedList l) (StylizedList l') = StylizedList (l <> l') - - --------------------------------------------------------------------------------- -instance Monoid Stylized where - mempty = StylizedText mempty mempty - mappend = (Semi.<>) - --------------------------------------------------------------------------------- -instance IsString Stylized where - fromString = text . T.pack diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,60 @@ +-- | +-- +-- 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.Simulation +import Test.Tasty +import Test.Tasty.HUnit + +example :: MonadByline m => m Text +example = do + sayLn ("Hey, I like " <> ("Haskell" <> fg magenta) <> "!") + + let question = + "What's " + <> ("your" <> bold) + <> " favorite " + <> ("language" <> fg green <> underline) + <> "? " + + askLn question (Just "Haskell") + +main :: IO () +main = defaultMain $ do + testGroup + "Byline" + [ testCase "default input" $ + run "" example @?= Just "Haskell", + testCase "user input" $ + run "Python" example @?= Just "Python", + testCase "changing state" $ do + runIdentity (runBylineT textThenDefault example) @?= Just "Current" + runIdentity (runBylineT textThenDefault (example >> example)) @?= Just "Next" + ] + where + run :: Text -> BylineT Identity Text -> Maybe Text + run input action = + let sim = pure (SimulatedInput input) + in runBylineT sim action & runIdentity + textThenDefault :: Monad m => SimulationFunction m + textThenDefault = do + -- The next input request will come from this function: + modify (\s -> s {simulationFunction = pure (SimulatedInput "Next")}) + + -- But this time we'll return different text: + pure (SimulatedInput "Current")