diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -13,4 +13,8 @@ http://hackage.haskell.org/package/rainbow +and Stackage: + +https://www.stackage.org/package/rainbow + rainbow is licensed under the BSD license; see the LICENSE file. diff --git a/lib/Rainbow.hs b/lib/Rainbow.hs --- a/lib/Rainbow.hs +++ b/lib/Rainbow.hs @@ -10,7 +10,10 @@ -- | Rainbow handles colors and special effects for text. The basic -- building block of Rainbow is the 'Y.Chunk'. The 'Y.Chunk' contains -- both text and formatting information such as colors, bold, --- underlining, etc. +-- underlining, etc. 'Y.Chunk' is an instance of +-- 'Data.String.IsString' so you can create a 'Y.Chunk' using the +-- @OverloadedStrings@ extension. Such a chunk has the given text +-- and has no formatting. -- -- When printed, each 'Y.Chunk' starts off with a clean slate, so if -- you want special formatting such as any color, bold, etc, then you @@ -27,10 +30,13 @@ -- Here are some basic examples: -- -- @ --- 'T.putChunkLn' $ 'Y.chunk' \"Some blue text\" '&' 'fore' 'blue' --- 'T.putChunkLn' $ 'Y.chunk' \"Blue on red background\" +-- ghci> import Rainbow +-- ghci> import Data.Function ((&)) +-- ghci> :set -XOverloadedStrings +-- ghci> 'T.putChunkLn' $ \"Some blue text\" '&' 'fore' 'blue' +-- ghci> 'T.putChunkLn' $ \"Blue on red background\" -- '&' 'fore' 'blue' '&' 'back' 'red' --- 'T.putChunkLn' $ 'Y.chunk' \"Blue on red, foreground bold\" +-- ghci> 'T.putChunkLn' $ \"Blue on red, foreground bold\" -- '&' 'fore' 'blue' '&' 'back' 'red' '&' 'bold' -- @ -- @@ -40,10 +46,10 @@ -- you start GHCi. -- -- @ --- 'T.putChunkLn' $ 'Y.chunk' \"Blue on 8, bright green on 256\" '&' +-- ghci> 'T.putChunkLn' $ \"Blue on 8, bright green on 256\" '&' -- 'fore' ('blue' '<>' 'brightGreen') -- --- 'T.putChunkLn' $ 'Y.chunk' \"Blue on 8, red on 256" '&' +-- ghci> 'T.putChunkLn' $ \"Blue on 8, red on 256" '&' -- 'fore' ('blue' '<>' 'only256' 'red') -- @ -- @@ -51,14 +57,16 @@ -- to print things in different colors, make more than one 'Y.Chunk': -- -- @ --- 'mapM_' 'T.putChunkLn' --- [ 'Y.chunk' \"Roses\" '&' 'fore' 'red' --- , 'Y.chunk' \"Violets\" '&' 'fore' 'blue' ] +-- ghci> 'T.putChunksLn' +-- [ \"Roses\" '&' 'fore' 'red' +-- , \"Violets\" '&' 'fore' 'blue' ] -- @ -- --- The above examples use 'T.putChunkLn', but that function will --- be inefficient if you are printing many 'Y.Chunk's. For --- greater efficiency see 'T.chunksToByteStrings'. +-- Most of the above examples use 'T.putChunkLn', but that function +-- may be inefficient if you are printing many 'Y.Chunk's. For +-- greater efficiency use functions under the heading \"Converting +-- multiple Chunk to ByteString\", including 'T.putChunksLn' and +-- 'T.putChunks'. -- -- The functions in this module, "Rainbow", will likely be enough for -- most uses, but for more flexibility you can use "Rainbow.Types". @@ -117,7 +125,7 @@ , color256 , only256 - -- * Converting 'Y.Chunk' to 'Data.ByteString.ByteString' + -- * Converting multiple 'Y.Chunk' to 'Data.ByteString.ByteString' -- | To print a 'Y.Chunk', you need to convert it to some -- 'Data.ByteString.ByteString's. @@ -146,14 +154,16 @@ , T.byteStringMakerFromHandle , T.chunksToByteStrings - -- * Writing 'Y.Chunk' to a handle or to standard output + -- * Writing multiple 'Y.Chunk' to a handle or to standard output , T.putChunks , T.hPutChunks + , T.putChunksLn + , T.hPutChunksLn -- * Quick and dirty functions for IO -- | For efficiency reasons you probably don't want to use these - -- when printing large numbers of 'Chunk', but they are handy for + -- when printing large numbers of 'Y.Chunk', but they are handy for -- throwaway uses like experimenting in GHCi. , T.putChunk , T.putChunkLn @@ -208,12 +218,14 @@ strikeout :: Y.Chunk -> Y.Chunk strikeout = formatBoth Y.strikeout --- | Change the foreground color for both 8- and 256-color terminals. +-- | Change the foreground color. Whether this affects 8-color +-- terminals, 256-color terminals, or both depends on the 'Y.Radiant'. fore :: Y.Radiant -> Y.Chunk -> Y.Chunk fore (Y.Radiant c8 c256) c = c & Y.scheme . Y.style8 . Y.fore .~ c8 & Y.scheme . Y.style256 . Y.fore .~ c256 --- | Change the background color for both 8- and 256-color terminals. +-- | Change the background color. Whether this affects 8-color +-- terminals, 256-color terminals, or both depends on the 'Y.Radiant'. back :: Y.Radiant -> Y.Chunk -> Y.Chunk back (Y.Radiant c8 c256) c = c & Y.scheme . Y.style8 . Y.back .~ c8 & Y.scheme . Y.style256 . Y.back .~ c256 @@ -223,7 +235,7 @@ -- red on a 256-color terminal: -- -- @ --- 'T.putChunkLn' $ 'chunk' \"Blue on 8, red on 256" & +-- 'T.putChunkLn' $ \"Blue on 8, red on 256\" & -- 'fore' ('blue' <> 'only256' 'red') -- @ only256 :: Y.Radiant -> Y.Radiant @@ -277,6 +289,11 @@ brightWhite :: Y.Radiant brightWhite = color256 15 +-- | A 'Y.Radiant' for any of the 256 colors available. Supply the +-- color number. Exactly which color you'll get for a given number +-- is dependent on the terminal; though there seem to be common +-- defaults, often the user can configure this however she likes. +-- The resulting 'Y.Radiant' will affect 256-color terminals only. color256 :: Word8 -> Y.Radiant color256 x = Y.Radiant (Y.Color Nothing) (Y.Color (Just x)) @@ -326,14 +343,10 @@ Probably the most common so-called terminals in use today that do NOT support the ISO 6429 codes are those that are not really terminals. For instance, you might use an Emacs shell buffer. For those -situations just use 'toByteStringsColors0'. - -I also decided to standardize on UTF-8 for the 'Text' output. These -days that seems reasonable. +situations just use 'T.toByteStringsColors0'. -Now, to figure out how many colors the terminal supports, Rainbow -simply uses the @tput@ program. This removes the dependency on -Terminfo altogether. +I also decided to standardize on UTF-8 for the 'Data.Text.Text' +output. These days that seems reasonable. Apparently it's difficult to get ISO 6429 support on Microsoft Windows. Oh well. diff --git a/lib/Rainbow/Translate.hs b/lib/Rainbow/Translate.hs --- a/lib/Rainbow/Translate.hs +++ b/lib/Rainbow/Translate.hs @@ -5,19 +5,16 @@ -- exported from "Rainbow". module Rainbow.Translate where -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString as BS -import Data.Text (Text) -import qualified Data.Text.Encoding as X +import Control.Exception (try, IOException) import Data.ByteString (ByteString) -import Data.Word (Word8) import Data.List (intersperse) +import Data.Text (Text) +import Data.Word (Word8) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.Text.Encoding as X import qualified Rainbow.Types as T -import System.Process (readProcessWithExitCode) -import Text.Read (readMaybe) -import System.Exit (ExitCode(ExitFailure)) -import Control.Monad (mzero) -import Control.Exception (try, IOException) +import qualified System.Console.Terminfo as Terminfo import qualified System.IO as IO @@ -219,35 +216,29 @@ . normalDefault --- | Spawns a subprocess to read the output of @tput colors@. If this --- says there are at least 256 colors are available, returns --- 'toByteStringsColors256'. Otherwise, if there are at least 8 --- colors available, returns 'toByteStringsColors8'. Otherwise, --- returns 'toByteStringsColors0'. +-- | Uses 'Terminfo.setupTermFromEnv' to obtain the terminal's color +-- capability. If this says there are at least 256 colors are +-- available, returns 'toByteStringsColors256'. Otherwise, if there +-- are at least 8 colors available, returns 'toByteStringsColors8'. +-- Otherwise, returns 'toByteStringsColors0'. -- -- If any IO exceptions arise during this process, they are discarded -- and 'toByteStringsColors0' is returned. +-- byteStringMakerFromEnvironment :: IO (T.Chunk -> [ByteString] -> [ByteString]) -byteStringMakerFromEnvironment - = catcher (fmap f $ readProcessWithExitCode "tput" ["colors"] "") +byteStringMakerFromEnvironment = fmap g (try Terminfo.setupTermFromEnv) where - f (code, stdOut, _) = maybe toByteStringsColors0 id $ do - case code of - ExitFailure _ -> mzero - _ -> return () - numColors <- readMaybe stdOut - return $ numColorsToFunc numColors - numColorsToFunc i - | i >= (256 :: Int) = toByteStringsColors256 - | i >= 8 = toByteStringsColors8 - | otherwise = toByteStringsColors0 - - catcher act = fmap g (try act) + g (Left e) = toByteStringsColors0 where - g (Left e) = toByteStringsColors0 - where _types = e :: IOException - g (Right good) = good + _types = e :: IOException + g (Right terminal) = + case Terminfo.getCapability terminal (Terminfo.tiGetNum "colors") of + Nothing -> toByteStringsColors0 + Just c + | c >= 256 -> toByteStringsColors256 + | c >= 8 -> toByteStringsColors8 + | otherwise -> toByteStringsColors0 -- | Like 'byteStringMakerFromEnvironment' but also consults a -- provided 'IO.Handle'. If the 'IO.Handle' is not a terminal, @@ -311,6 +302,17 @@ let bsList = chunksToByteStrings maker cks mapM_ (BS.hPut h) bsList +-- | Writes a list of chunks to the given 'IO.Handle', followed by a +-- newline character. +-- +-- First uses 'byteStringMakerFromEnvironment' to determine how many +-- colors to use. Then creates a list of 'ByteString' using +-- 'chunksToByteStrings' and then writes them to the given 'IO.Handle'. +hPutChunksLn :: IO.Handle -> [T.Chunk] -> IO () +hPutChunksLn h cks = do + hPutChunks h cks + IO.hPutStr h "\n" + -- | Writes a list of chunks to standard output. -- -- First uses 'byteStringMakerFromEnvironment' to determine how many @@ -319,25 +321,31 @@ putChunks :: [T.Chunk] -> IO () putChunks = hPutChunks IO.stdout --- Quick and dirty I/O functions +-- | Writes a list of chunks to standard output, followed by a +-- newline. +-- +-- First uses 'byteStringMakerFromEnvironment' to determine how many +-- colors to use. Then creates a list of 'ByteString' using +-- 'chunksToByteStrings' and then writes them to standard output. +putChunksLn :: [T.Chunk] -> IO () +putChunksLn cks = do + putChunks cks + IO.putStr "\n" --- | Writes a 'T.Chunk' to standard output. Spawns a child process to --- read the output of @tput colors@ to determine how many colors to --- use, for every single chunk. Therefore, this is not going to win --- any speed awards. You are better off using 'chunksToByteStrings' --- and the functions in "Data.ByteString" to print your 'T.Chunk's if --- you are printing a lot of them. +-- | Writes a 'T.Chunk' to standard output. Uses +-- 'byteStringMakerFromEnvironment' each time you apply it, so this +-- might be inefficient. You are better off using +-- 'chunksToByteStrings' and the functions in "Data.ByteString" to +-- print your 'T.Chunk's if you are printing a lot of them. putChunk :: T.Chunk -> IO () putChunk ck = do mkr <- byteStringMakerFromEnvironment mapM_ BS.putStr . chunksToByteStrings mkr $ [ck] -- | Writes a 'T.Chunk' to standard output, and appends a newline. --- Spawns a child process to read the output of @tput colors@ to --- determine how many colors to use, for every single chunk. --- Therefore, this is not going to win any speed awards. You are --- better off using 'chunksToByteStrings' and the functions in --- "Data.ByteString" to print your 'T.Chunk's if you are printing a lot --- of them. +-- Uses 'byteStringMakerFromEnvironment' each time you apply it, so +-- this might be inefficient. You are better off using +-- 'chunksToByteStrings' and the functions in "Data.ByteString" to +-- print your 'T.Chunk's if you are printing a lot of them. putChunkLn :: T.Chunk -> IO () putChunkLn ck = putChunk ck >> putStrLn "" diff --git a/lib/Rainbow/Types.hs b/lib/Rainbow/Types.hs --- a/lib/Rainbow/Types.hs +++ b/lib/Rainbow/Types.hs @@ -1,7 +1,5 @@ {-# LANGUAGE DeriveGeneric, DeriveDataTypeable, DeriveFunctor, DeriveTraversable, DeriveFoldable, TemplateHaskell #-} --- Lens.Simple makeLenses will not create signatures -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} -- | All the main types in Rainbow. Using this module you can specify -- that you want different formatting for 8- and 256-color terminals. @@ -13,7 +11,7 @@ -- # Imports import Control.Lens (makeLenses) -import Data.String +import Data.String (IsString(..)) import Data.Text (Text) import qualified Data.Text as X import Data.Traversable () @@ -194,6 +192,8 @@ , _yarn :: Text } deriving (Eq, Show, Ord, Generic, Typeable) +-- | Uses the underlying 'Semigroup' instances for both the +-- underlying 'Scheme' and the underlying 'Text'. instance Semigroup Chunk where (Chunk x0 x1) <> (Chunk y0 y1) = Chunk (x0 <> y0) (x1 <> y1) @@ -203,14 +203,15 @@ fromString = chunk . X.pack -- | Uses the underlying 'Monoid' instances for the 'Scheme' and for --- the particular '_yarn'. Therefore 'mempty' will have no formatting --- and no colors and will generally have no text, though whether or --- not there is any text depends on the 'mempty' for the type of the --- '_yarn'. +-- the underlying 'Text'. Therefore 'mempty' will have no +-- formatting, no colors, and no text. instance Monoid Chunk where mempty = Chunk mempty mempty -- | Creates a 'Chunk' with no formatting and with the given text. +-- A 'Chunk' is also an instance of 'Data.String.IsString' so you +-- can create them with the @OverloadedStrings@ extension. Such a +-- 'Chunk' has the text of the string and no formatting. chunk :: Text -> Chunk chunk = Chunk mempty diff --git a/rainbow.cabal b/rainbow.cabal --- a/rainbow.cabal +++ b/rainbow.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2. +-- This file has been generated from package.yaml by hpack version 0.31.1. -- -- see: https://github.com/sol/hpack -- --- hash: 3d6f930a7b2c045e5eb1bb6169a5b9ad82753e1bfdc533cc56466aeccefb65de +-- hash: a0dd786d4193174131933aaa84515c8a81ceaece927b730a4629b9049c32190f name: rainbow -version: 0.34.0.0 +version: 0.34.2.0 synopsis: Print text to terminal with colors and effects description: Please see README.md category: System @@ -16,25 +16,20 @@ bug-reports: https://www.github.com/massysett/rainbow/issues author: Omari Norman maintainer: omari@smileystation.com -copyright: Copyright 2013-2018 Omari Norman +copyright: Copyright 2013-2019 Omari Norman license: BSD3 license-file: LICENSE build-type: Simple extra-source-files: README.md stack.yaml +x-curation: uncurated source-repository head type: git location: https://github.com/massysett/rainbow library - exposed-modules: - Rainbow - Rainbow.Translate - Rainbow.Types - other-modules: - Paths_rainbow hs-source-dirs: lib other-extensions: TemplateHaskell @@ -43,42 +38,19 @@ base >=4.11 && <5 , bytestring , lens - , process + , terminfo , text - default-language: Haskell2010 - -test-suite colorTest - type: exitcode-stdio-1.0 - main-is: colorTest.hs - other-modules: + exposed-modules: Rainbow Rainbow.Translate Rainbow.Types - Rainbow.QuickCheck + other-modules: Paths_rainbow - hs-source-dirs: - lib - tests - other-extensions: TemplateHaskell - ghc-options: -Wall - build-depends: - QuickCheck - , base >=4.11 && <5 - , bytestring - , lens - , process - , text default-language: Haskell2010 test-suite rainbow-instances type: exitcode-stdio-1.0 main-is: rainbow-instances.hs - other-modules: - Rainbow - Rainbow.Translate - Rainbow.Types - Rainbow.QuickCheck - Paths_rainbow hs-source-dirs: lib tests @@ -89,36 +61,19 @@ , base >=4.11 && <5 , bytestring , lens - , process + , terminfo , text - default-language: Haskell2010 - -test-suite test256color - type: exitcode-stdio-1.0 - main-is: test256color.hs other-modules: Rainbow Rainbow.Translate Rainbow.Types Rainbow.QuickCheck Paths_rainbow - hs-source-dirs: - lib - tests - other-extensions: TemplateHaskell - ghc-options: -Wall - build-depends: - QuickCheck - , base >=4.11 && <5 - , bytestring - , lens - , process - , text default-language: Haskell2010 -test-suite test8color +test-suite rainbow-visual type: exitcode-stdio-1.0 - main-is: test8color.hs + main-is: rainbow-visual.hs other-modules: Rainbow Rainbow.Translate @@ -135,6 +90,6 @@ , base >=4.11 && <5 , bytestring , lens - , process + , terminfo , text default-language: Haskell2010 diff --git a/tests/colorTest.hs b/tests/colorTest.hs deleted file mode 100644 --- a/tests/colorTest.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main where - -import Rainbow -import qualified Data.ByteString as BS -import Data.Function ((&)) -import qualified Data.Text as X - -colors8 :: [(String, Radiant)] -colors8 = - [ ("(no color)", mempty) - , ("black", black) - , ("red", red) - , ("green", green) - , ("yellow", yellow) - , ("blue", blue) - , ("magenta", magenta) - , ("cyan", cyan) - , ("white", white) - ] - -colors256 :: [(String, Radiant)] -colors256 - = ("(no color)", mempty) : map mkColor [minBound..maxBound] - where - mkColor w = (show w, color256 w) - -colorChunks8ByForeground :: [[Chunk]] -colorChunks8ByForeground = do - (fgColorName, fgColor) <- colors8 - (bgColorName, bgColor) <- colors8 - let lbl = "foreground " <> fgColorName <> " background " <> bgColorName - return [ chunk (X.pack lbl) & fore fgColor & back bgColor - , chunk "\n" - ] - -colorChunks8ByBackground :: [[Chunk]] -colorChunks8ByBackground = do - (bgColorName, bgColor) <- colors8 - (fgColorName, fgColor) <- colors8 - let lbl = "background " <> bgColorName <> " foreground " <> fgColorName - return [ chunk (X.pack lbl) & fore fgColor & back bgColor - , chunk "\n" - ] - -colorChunks256ByForeground :: [[Chunk]] -colorChunks256ByForeground = do - (fgColorName, fgColor) <- colors256 - (bgColorName, bgColor) <- colors256 - let lbl = "foreground " <> fgColorName <> " background " <> bgColorName - return [ chunk (X.pack lbl) & fore fgColor & back bgColor - , chunk "\n" - ] - -colorChunks256ByBackground :: [[Chunk]] -colorChunks256ByBackground = do - (bgColorName, bgColor) <- colors256 - (fgColorName, fgColor) <- colors256 - let lbl = "background " <> bgColorName <> " foreground " <> fgColorName - return [ chunk (X.pack lbl) & fore fgColor & back bgColor - , chunk "\n" - ] - -sep :: String -> IO () -sep s = do - putStrLn "" - putStrLn "" - putStrLn $ replicate 40 '=' - putStrLn s - -main :: IO () -main = do - sep "8 Colors - sorted by foreground color" - mapM_ BS.putStr . chunksToByteStrings toByteStringsColors8 - . concat $ colorChunks8ByForeground - sep "8 Colors - sorted by background color" - mapM_ BS.putStr . chunksToByteStrings toByteStringsColors8 - . concat $ colorChunks8ByBackground - sep "256 Colors - sorted by foreground color" - mapM_ BS.putStr . chunksToByteStrings toByteStringsColors256 - . concat $ colorChunks256ByForeground - sep "256 Colors - sorted by background color" - mapM_ BS.putStr . chunksToByteStrings toByteStringsColors256 - . concat $ colorChunks256ByBackground diff --git a/tests/rainbow-visual.hs b/tests/rainbow-visual.hs new file mode 100644 --- /dev/null +++ b/tests/rainbow-visual.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Rainbow +import Data.Function ((&)) + +main :: IO () +main = do + putChunksLn + [ "Red fore, green back " & fore red & back green + , "Blue fore, magenta back" & fore blue & back magenta ] + putChunksLn + [ "Red, bold fore " & fore red & bold + , "Red, underlined fore " & fore red & underline + , "Cyan, italic fore" & fore cyan & italic + ] + putChunksLn + [ "Light grey background on 256-color" & back (color256 254) ] diff --git a/tests/test256color.hs b/tests/test256color.hs deleted file mode 100644 --- a/tests/test256color.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main where - -import Control.Arrow (second) -import Data.Function ((&)) -import Rainbow -import qualified Data.ByteString as BS -import qualified Data.Text as X - -effects :: [(String, Chunk -> Chunk)] -effects = - [ ("bold", bold) - , ("faint", faint) - , ("italic", italic) - , ("underline", underline) - , ("blink", blink) - , ("inverse", inverse) - , ("invisible", invisible) - , ("strikeout", strikeout) - ] - -colors :: [(String, Radiant)] -colors = ("(no color)", mempty) : map mkColor [minBound..maxBound] - where - mkColor w = (show w, color256 w) - -maybeEffects :: [(String, Maybe (Chunk -> Chunk))] -maybeEffects = ("(no effect)", Nothing) - : map (second Just) effects - -{- --- From --- http://stackoverflow.com/a/22577148/1017252 -combinations :: Int -> [a] -> [[a]] -combinations k xs = combinations' (length xs) k xs - where combinations' n k' l@(y:ys) - | k' == 0 = [[]] - | k' >= n = [l] - | null l = [] - | otherwise = map (y :) (combinations' (n - 1) (k' - 1) ys) - ++ combinations' (n - 1) k' ys --} - -colorsAndEffects :: [[Chunk]] -colorsAndEffects = do - (fgColorName, fgColor) <- colors - (bgColorName, bgColor) <- colors - (effectName, mayEffect) <- maybeEffects - let lbl = "foreground " ++ fgColorName ++ " background " ++ bgColorName - ++ " effect " ++ effectName - return $ [ chunk (X.pack lbl) & fore fgColor - & back bgColor - & maybe id id mayEffect - , chunk "\n" - ] - -main :: IO () -main - = mapM_ BS.putStr - . chunksToByteStrings toByteStringsColors256 - . concat - $ colorsAndEffects diff --git a/tests/test8color.hs b/tests/test8color.hs deleted file mode 100644 --- a/tests/test8color.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main where - -import Control.Arrow (second) -import Data.Function ((&)) -import Rainbow -import qualified Data.ByteString as BS -import qualified Data.Text as X - -effects :: [(String, Chunk -> Chunk)] -effects = - [ ("bold", bold) - , ("faint", faint) - , ("italic", italic) - , ("underline", underline) - , ("blink", blink) - , ("inverse", inverse) - , ("invisible", invisible) - , ("strikeout", strikeout) - ] - -colors :: [(String, Radiant)] -colors = - [ ("(no color)", mempty) - , ("black", black) - , ("red", red) - , ("green", green) - , ("yellow", yellow) - , ("blue", blue) - , ("magenta", magenta) - , ("cyan", cyan) - , ("white", white) - ] - -maybeEffects :: [(String, Maybe (Chunk -> Chunk))] -maybeEffects = ("(no effect)", Nothing) - : map (second Just) effects - -{- --- From --- http://stackoverflow.com/a/22577148/1017252 -combinations :: Int -> [a] -> [[a]] -combinations k xs = combinations' (length xs) k xs - where combinations' n k' l@(y:ys) - | k' == 0 = [[]] - | k' >= n = [l] - | null l = [] - | otherwise = map (y :) (combinations' (n - 1) (k' - 1) ys) - ++ combinations' (n - 1) k' ys --} - -colorsAndEffects :: [[Chunk]] -colorsAndEffects = do - (fgColorName, fgColor) <- colors - (bgColorName, bgColor) <- colors - (effectName, mayEffect) <- maybeEffects - let lbl = "foreground " ++ fgColorName ++ " background " ++ bgColorName - ++ " effect " ++ effectName - return $ [ chunk (X.pack lbl) & fore fgColor - & back bgColor - & maybe id id mayEffect - , chunk "\n" - ] - -main :: IO () -main - = mapM_ BS.putStr - . chunksToByteStrings toByteStringsColors8 - . concat - $ colorsAndEffects