diff --git a/CHANGES b/CHANGES new file mode 100644 --- /dev/null +++ b/CHANGES @@ -0,0 +1,8 @@ +-*- org -*- + +#+title: Version History +#+startup: showall + +* 0.1.0.0 (May 19, 2015) + + - Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2015, Peter J. Jones +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the + distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,21 @@ +# Byline + +Byline simplifies writing interactive terminal 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. + +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. + +## Examples + +Please see the example programs in the `examples` directory. + +[ansi-terminal]: http://hackage.haskell.org/package/ansi-terminal +[haskeline]: https://hackage.haskell.org/package/haskeline +[highline]: https://github.com/JEG2/highline +[terminal library]: https://github.com/cdxr/terminal diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/byline.cabal b/byline.cabal new file mode 100644 --- /dev/null +++ b/byline.cabal @@ -0,0 +1,111 @@ +-------------------------------------------------------------------------------- +name: byline +version: 0.1.0.0 +synopsis: Library for creating command-line interfaces (colors, menus, etc.) +homepage: http://github.com/pjones/byline +bug-reports: http://github.com/pjones/byline/issues +license: BSD2 +license-file: LICENSE +author: Peter Jones +maintainer: Peter Jones +copyright: Copyright: (c) 2015 Peter J. Jones +category: System +build-type: Simple +stability: experimental +tested-with: GHC == 7.8.4 +cabal-version: >=1.10 +description: + Byline simplifies writing interactive terminal 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. + . + 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. + +-------------------------------------------------------------------------------- +extra-source-files: + CHANGES + README.md + examples/*.hs + +-------------------------------------------------------------------------------- +source-repository head + type: git + location: git://github.com/pjones/byline.git + +-------------------------------------------------------------------------------- +flag maintainer + description: Enable settings for the package maintainer. + manual: True + default: False + +-------------------------------------------------------------------------------- +flag build-examples + description: Build examples when building the library. + manual: True + default: False + +-------------------------------------------------------------------------------- +library + 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 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fwarn-incomplete-uni-patterns + ghc-prof-options: -prof -auto-all + + if flag(maintainer) + ghc-options: -Werror + + build-depends: base >= 4.7 && < 5.0 + , ansi-terminal >= 0.6 && < 0.7 + , colour >= 2.3 && < 2.4 + , containers >= 0.5 && < 0.6 + , exceptions >= 0.8 && < 0.9 + , haskeline >= 0.7 && < 0.8 + , mtl >= 2.1 && < 2.2 + , terminfo-hs >= 0.1 && < 0.2 + , text >= 0.11 && < 1.3 + , transformers >= 0.3 && < 0.4 + +-------------------------------------------------------------------------------- +executable simple + main-is: examples/simple.hs + default-language: Haskell2010 + ghc-options: -Wall -fwarn-incomplete-uni-patterns + build-depends: base, byline, text + + if flag(maintainer) + ghc-options: -Werror + + if !flag(build-examples) + buildable: False + +-------------------------------------------------------------------------------- +executable menu + main-is: examples/menu.hs + default-language: Haskell2010 + ghc-options: -Wall -fwarn-incomplete-uni-patterns + build-depends: base, byline, text + + if flag(maintainer) + ghc-options: -Werror + + if !flag(build-examples) + buildable: False diff --git a/examples/menu.hs b/examples/menu.hs new file mode 100644 --- /dev/null +++ b/examples/menu.hs @@ -0,0 +1,45 @@ +{-# 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 + +-------------------------------------------------------------------------------- +import Data.Text (Text) +import System.Console.Byline + +-------------------------------------------------------------------------------- +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) + +-------------------------------------------------------------------------------- +items :: [Item] +items = [ Fruit "Watermelon" + , Vegetable "Cucumber" + , Fruit "Kiwi" + , Vegetable "Asparagus" + ] + +-------------------------------------------------------------------------------- +main :: IO () +main = do + let menuConfig = banner "Pick a snack: " $ menu items displayItem + prompt = "Which snack? " + onError = "please pick a valid item!" <> fg red + + answer <- runByline $ askWithMenuRepeatedly menuConfig prompt onError + putStrLn ("you picked: " ++ show answer) diff --git a/examples/simple.hs b/examples/simple.hs new file mode 100644 --- /dev/null +++ b/examples/simple.hs @@ -0,0 +1,53 @@ +{-# 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 + +-------------------------------------------------------------------------------- +import Control.Monad (void) +import Data.Text (Text) +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!") + + -- Get user input with a stylized prompt: + let question = "What's your favorite " <> ("language" <> bold) <> "? " + language <- ask question Nothing + + if Text.null language + then sayLn "Cat got your tongue?" + 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 + 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 diff --git a/src/System/Console/Byline.hs b/src/System/Console/Byline.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Byline.hs @@ -0,0 +1,122 @@ +{- + +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 + + -- * 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 Data.Monoid ((<>)) + +-------------------------------------------------------------------------------- +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 new file mode 100644 --- /dev/null +++ b/src/System/Console/Byline/Color.hs @@ -0,0 +1,69 @@ +{- + +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 new file mode 100644 --- /dev/null +++ b/src/System/Console/Byline/Completion.hs @@ -0,0 +1,57 @@ +{- + +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 new file mode 100644 --- /dev/null +++ b/src/System/Console/Byline/Internal/Byline.hs @@ -0,0 +1,144 @@ +{-# 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 + +-------------------------------------------------------------------------------- +-- | 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) + +-------------------------------------------------------------------------------- +-- | 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 new file mode 100644 --- /dev/null +++ b/src/System/Console/Byline/Internal/Color.hs @@ -0,0 +1,101 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/System/Console/Byline/Internal/Completion.hs @@ -0,0 +1,55 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/System/Console/Byline/Internal/Render.hs @@ -0,0 +1,142 @@ +{-# 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 + +-------------------------------------------------------------------------------- +-- | 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 + ] + + 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 + +-------------------------------------------------------------------------------- +-- | 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 new file mode 100644 --- /dev/null +++ b/src/System/Console/Byline/Internal/Types.hs @@ -0,0 +1,65 @@ +{-# 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 Data.Monoid + +-------------------------------------------------------------------------------- +-- Byline imports: +import System.Console.Byline.Color (Color) + +-------------------------------------------------------------------------------- +-- | Like @Bool@, but with a different @Monoid@ instance. +data Status = On | Off + +-------------------------------------------------------------------------------- +instance Monoid Status where + mempty = Off + mappend Off Off = Off + mappend Off On = On + mappend On On = On + mappend On Off = On + +-------------------------------------------------------------------------------- +-- | Like @Maybe@, but with a different @Monoid@ instance. +newtype OnlyOne a = OnlyOne {unOne :: Maybe a} + +-------------------------------------------------------------------------------- +instance Monoid (OnlyOne a) where + mempty = OnlyOne Nothing + mappend _ b@(OnlyOne (Just _)) = b + mappend a _ = a + +-------------------------------------------------------------------------------- +-- | Information about modifications made to stylized text. +data Modifier = Modifier + { modColorFG :: OnlyOne Color + , modColorBG :: OnlyOne Color + , modBold :: Status + , modUnderline :: Status + } + +-------------------------------------------------------------------------------- +instance Monoid Modifier where + mempty = Modifier mempty mempty mempty mempty + mappend (Modifier a b c d) (Modifier a' b' c' d') = + Modifier (a <> a') (b <> b') (c <> c') (d <> d') diff --git a/src/System/Console/Byline/Menu.hs b/src/System/Console/Byline/Menu.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Byline/Menu.hs @@ -0,0 +1,243 @@ +{-# 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.Monoid +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 = 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 + let firstItem = Text.strip $ renderText Plain (menuItemPrefix m 1) + + -- Use the default completion function for menus, but not if another + -- completion function is already active. + withCompletionFunc (fromMaybe (defaultCompFunc m) currCompFunc) $ do + prefixes <- displayMenu + answer <- ask prompt (Just firstItem) + return (menuMatcher m m prefixes answer) + + where + -- 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 + Match _ -> return answer + _ -> go (config {menuBeforePrompt = Just errprompt}) diff --git a/src/System/Console/Byline/Modifiers.hs b/src/System/Console/Byline/Modifiers.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Byline/Modifiers.hs @@ -0,0 +1,54 @@ +{- + +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 + ) 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 + +-------------------------------------------------------------------------------- +-- | 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}) diff --git a/src/System/Console/Byline/Primitive.hs b/src/System/Console/Byline/Primitive.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Byline/Primitive.hs @@ -0,0 +1,173 @@ +{-# 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.Monoid +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 Text)) -- ^ Confirmation function. + -> Byline m Text +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 new file mode 100644 --- /dev/null +++ b/src/System/Console/Byline/Stylized.hs @@ -0,0 +1,87 @@ +{- + +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 Data.Monoid +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 Monoid Stylized where + mempty = StylizedText mempty mempty + + -- StylizedText on LHS. + mappend a@(StylizedText _ _) b@(StylizedText _ _) = StylizedList [a, b] + mappend (StylizedText t m) (StylizedMod m') = StylizedText t (m <> m') + mappend a@(StylizedText _ _) (StylizedList b) = StylizedList (a:b) + + -- StylizedMod on LHS. + mappend (StylizedMod m) (StylizedText t m') = StylizedText t (m <> m') + mappend (StylizedMod m) (StylizedMod m') = StylizedMod (m <> m') + mappend m@(StylizedMod _) (StylizedList l) = StylizedList (map (m <>) l) + + -- StylizedList on LHS. + mappend (StylizedList l) t@(StylizedText _ _) = StylizedList (l <> [t]) + mappend (StylizedList l) m@(StylizedMod _) = StylizedList (map (<> m) l) + mappend (StylizedList l) (StylizedList l') = StylizedList (l <> l') + +-------------------------------------------------------------------------------- +instance IsString Stylized where + fromString = text . T.pack