diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,10 +1,15 @@ Changes ======= +Version 0.7 +----------- + +Add 24-bit RGB color support + Version 0.6.3.1 --------------- -Fix Windows + ghc 7.8 compatibility, +Fix Windows + ghc 7.8 compatibility Version 0.6.3 ------------- diff --git a/System/Console/ANSI/Codes.hs b/System/Console/ANSI/Codes.hs --- a/System/Console/ANSI/Codes.hs +++ b/System/Console/ANSI/Codes.hs @@ -52,6 +52,7 @@ , colorToCode, csi, sgrToCode ) where +import Data.Colour.SRGB (toSRGB24, RGB (..)) import Data.List (intersperse) import System.Console.ANSI.Types @@ -81,31 +82,36 @@ -- | 'sgrToCode' @sgr@ returns the parameter of the SELECT GRAPHIC RENDITION -- (SGR) aspect identified by @sgr@. sgrToCode :: SGR -- ^ The SGR aspect - -> Int + -> [Int] sgrToCode sgr = case sgr of - Reset -> 0 + Reset -> [0] SetConsoleIntensity intensity -> case intensity of - BoldIntensity -> 1 - FaintIntensity -> 2 - NormalIntensity -> 22 - SetItalicized True -> 3 - SetItalicized False -> 23 + BoldIntensity -> [1] + FaintIntensity -> [2] + NormalIntensity -> [22] + SetItalicized True -> [3] + SetItalicized False -> [23] SetUnderlining underlining -> case underlining of - SingleUnderline -> 4 - DoubleUnderline -> 21 - NoUnderline -> 24 + SingleUnderline -> [4] + DoubleUnderline -> [21] + NoUnderline -> [24] SetBlinkSpeed blink_speed -> case blink_speed of - SlowBlink -> 5 - RapidBlink -> 6 - NoBlink -> 25 - SetVisible False -> 8 - SetVisible True -> 28 - SetSwapForegroundBackground True -> 7 - SetSwapForegroundBackground False -> 27 - SetColor Foreground Dull color -> 30 + colorToCode color - SetColor Foreground Vivid color -> 90 + colorToCode color - SetColor Background Dull color -> 40 + colorToCode color - SetColor Background Vivid color -> 100 + colorToCode color + SlowBlink -> [5] + RapidBlink -> [6] + NoBlink -> [25] + SetVisible False -> [8] + SetVisible True -> [28] + SetSwapForegroundBackground True -> [7] + SetSwapForegroundBackground False -> [27] + SetColor Foreground Dull color -> [30 + colorToCode color] + SetColor Foreground Vivid color -> [90 + colorToCode color] + SetColor Background Dull color -> [40 + colorToCode color] + SetColor Background Vivid color -> [100 + colorToCode color] + SetRGBColor Foreground color -> [38, 2] ++ toRGB color + SetRGBColor Background color -> [48, 2] ++ toRGB color + where + toRGB color = let RGB r g b = toSRGB24 color + in map fromIntegral [r, g, b] cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode :: Int -- ^ Number of lines or characters to move -> String @@ -148,7 +154,7 @@ -- equivalent to the list @[Reset]@. Commands are applied -- left to right. -> String -setSGRCode sgrs = csi (map sgrToCode sgrs) "m" +setSGRCode sgrs = csi (concatMap sgrToCode sgrs) "m" hideCursorCode, showCursorCode :: String hideCursorCode = csi [] "?25l" diff --git a/System/Console/ANSI/Types.hs b/System/Console/ANSI/Types.hs --- a/System/Console/ANSI/Types.hs +++ b/System/Console/ANSI/Types.hs @@ -10,6 +10,7 @@ , BlinkSpeed (..) ) where +import Data.Colour (Colour) import Data.Ix -- | ANSI colors: come in various intensities, which are controlled by 'ColorIntensity' @@ -60,4 +61,5 @@ | SetVisible Bool -- ^ Not widely supported | SetSwapForegroundBackground Bool | SetColor ConsoleLayer ColorIntensity Color - deriving (Eq, Ord, Show, Read) + | SetRGBColor ConsoleLayer (Colour Float) -- ^ Supported from Windows 10 Creators Update + deriving (Eq, Show, Read) diff --git a/System/Console/ANSI/Windows/Emulator.hs b/System/Console/ANSI/Windows/Emulator.hs --- a/System/Console/ANSI/Windows/Emulator.hs +++ b/System/Console/ANSI/Windows/Emulator.hs @@ -10,6 +10,10 @@ import System.IO import Control.Exception (catchJust) +import Data.Colour (Colour) +import Data.Colour.Names (black, blue, cyan, green, grey, lime, magenta, maroon, + navy, olive, purple, red, silver, teal, white, yellow) +import Data.Colour.SRGB (RGB (..), toSRGB) import Data.Bits import Data.List @@ -189,6 +193,16 @@ SetColor Foreground Vivid color -> applyForegroundANSIColorToAttribute color (attribute .|. fOREGROUND_INTENSITY) SetColor Background Dull color -> applyBackgroundANSIColorToAttribute color (attribute .&. (complement bACKGROUND_INTENSITY)) SetColor Background Vivid color -> applyBackgroundANSIColorToAttribute color (attribute .|. bACKGROUND_INTENSITY) + SetRGBColor Foreground color -> let (colorIntensity, aNSIColor) = toANSIColor color + attribute' = case colorIntensity of + Dull -> attribute .&. complement fOREGROUND_INTENSITY + Vivid -> attribute .|. fOREGROUND_INTENSITY + in applyForegroundANSIColorToAttribute aNSIColor attribute' + SetRGBColor Background color -> let (colorIntensity, aNSIColor) = toANSIColor color + attribute' = case colorIntensity of + Dull -> attribute .&. complement bACKGROUND_INTENSITY + Vivid -> attribute .|. bACKGROUND_INTENSITY + in applyBackgroundANSIColorToAttribute aNSIColor attribute' where iNTENSITY = fOREGROUND_INTENSITY @@ -212,3 +226,32 @@ -- assume that that is what the user intended. This will fail if they are sending the command -- over e.g. a network link... but that's not really what I'm designing for. hSetTitle h title = emulatorFallback (Unix.hSetTitle h title) $ withTString title $ setConsoleTitle + +aNSIColors :: [((ColorIntensity, Color), Colour Float)] +aNSIColors = [ ((Dull, Black), black) + , ((Dull, Blue), navy) + , ((Dull, Green), green) + , ((Dull, Cyan), teal) + , ((Dull, Red), maroon) + , ((Dull, Magenta), purple) + , ((Dull, Yellow), olive) + , ((Dull, White), silver) + , ((Vivid, Black), grey) + , ((Vivid, Blue), blue) + , ((Vivid, Green), lime) + , ((Vivid, Cyan), cyan) + , ((Vivid, Red), red) + , ((Vivid, Magenta), magenta) + , ((Vivid, Yellow), yellow) + , ((Vivid, White), white) ] + +toANSIColor :: Colour Float -> (ColorIntensity, Color) +toANSIColor color = fst $ minimumBy order aNSIColors + where + RGB r g b = toSRGB color + order (_, c1) (_, c2) = compare (dist c1) (dist c2) + dist c = let RGB r' g' b' = toSRGB c + dr = r' - r + dg = g' - g + db = b' - b + in dr * dr + dg * dg + db * db diff --git a/ansi-terminal.cabal b/ansi-terminal.cabal --- a/ansi-terminal.cabal +++ b/ansi-terminal.cabal @@ -1,10 +1,10 @@ Name: ansi-terminal -Version: 0.6.3.1 +Version: 0.7 Cabal-Version: >= 1.6 Category: User Interfaces Synopsis: Simple ANSI terminal support, with Windows compatibility -Description: ANSI terminal support for Haskell: allows cursor movement, screen clearing, color output showing or hiding the cursor, and - changing the title. Compatible with Windows and those Unixes with ANSI terminals, but only GHC is supported as a compiler. +Description: ANSI terminal support for Haskell: allows cursor movement, screen clearing, color output, showing or hiding the cursor, and + changing the title. Works on UNIX and Windows. License: BSD3 License-File: LICENSE Author: Max Bolingbroke @@ -29,10 +29,11 @@ Exposed-Modules: System.Console.ANSI System.Console.ANSI.Types System.Console.ANSI.Codes - + Include-Dirs: includes - + Build-Depends: base >= 4 && < 5 + , colour if os(windows) Build-Depends: base-compat >= 0.9.1 , Win32 >= 2.0 @@ -49,15 +50,15 @@ -- We assume any non-Windows platform is Unix Cpp-Options: -DUNIX Other-Modules: System.Console.ANSI.Unix - + Extensions: CPP ForeignFunctionInterface - + Ghc-Options: -Wall Executable ansi-terminal-example Main-Is: System/Console/ANSI/Example.hs - + Include-Dirs: includes Other-Modules: System.Console.ANSI