diff --git a/System/Console/ANSI/Common.hs b/System/Console/ANSI/Common.hs --- a/System/Console/ANSI/Common.hs +++ b/System/Console/ANSI/Common.hs @@ -1,33 +1,48 @@ module System.Console.ANSI.Common where --- | ANSI colors: come in various intensities, which are controlled by 'ANSISGR' -data ANSIColor = Black - | Red - | Green - | Yellow - | Blue - | Magenta - | Cyan - | White - deriving (Bounded, Enum, Show) +-- | ANSI colors: come in various intensities, which are controlled by 'ColorIntensity' +data Color = Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | White + deriving (Bounded, Enum, Show) + +-- | ANSI colors come in two intensities +data ColorIntensity = Dull + | Vivid + deriving (Enum, Show) + +-- | ANSI colors can be set on two different layers +data ConsoleLayer = Foreground + | Background + deriving (Enum, Show) + +-- | ANSI blink speeds: values other than 'NoBlink' are not widely supported +data BlinkSpeed = SlowBlink -- ^ Less than 150 blinks per minute + | RapidBlink -- ^ More than 150 blinks per minute + | NoBlink + +-- | ANSI text underlining +data Underlining = SingleUnderline + | DoubleUnderline -- ^ Not widely supported + | NoUnderline + +-- | ANSI general console intensity: usually treated as setting the font style (e.g. 'BoldIntensity' causes text to be bold) +data ConsoleIntensity = BoldIntensity + | FaintIntensity -- ^ Not widely supported: sometimes treated as concealing text + | NormalIntensity + -- | ANSI Select Graphic Rendition command -data ANSISGR = Reset - | BoldIntensity - | FaintIntensity -- ^ Not widely supported: sometimes treated as conceal - | NormalIntensity - | Italic -- ^ Not widely supported: sometimes treated as swapping foreground and background - | SingleUnderline - | DoubleUnderline -- ^ Not widely supported - | NoUnderline - | SlowBlink - | RapidBlink - | NoBlink - | Conceal -- ^ Not widely supported - | Reveal - | SwapForegroundBackground - | DontSwapForegroundBackground - | ForegroundNormalIntensity ANSIColor - | ForegroundHighIntensity ANSIColor - | BackgroundNormalIntensity ANSIColor - | BackgroundHighIntensity ANSIColor +data SGR = Reset + | SetConsoleIntensity ConsoleIntensity + | SetItalicized Bool -- ^ Not widely supported: sometimes treated as swapping foreground and background + | SetUnderlining Underlining + | SetBlinkSpeed BlinkSpeed + | SetVisible Bool -- ^ Not widely supported + | SetSwapForegroundBackground Bool + | SetColor ConsoleLayer ColorIntensity Color diff --git a/System/Console/ANSI/Example.hs b/System/Console/ANSI/Example.hs --- a/System/Console/ANSI/Example.hs +++ b/System/Console/ANSI/Example.hs @@ -13,7 +13,7 @@ examples :: [IO ()] examples = [ cursorMovementExample , lineChangeExample - , setPositionExample + , setCursorPositionExample , clearExample , scrollExample , sgrExample @@ -24,7 +24,7 @@ main = mapM_ (\example -> resetScreen >> example) examples resetScreen :: IO () -resetScreen = clearScreen >> setSGR Reset >> setPosition 0 0 +resetScreen = clearScreen >> setSGR [Reset] >> setCursorPosition 0 0 pause :: IO () pause = do @@ -72,39 +72,39 @@ -- Line One -- Line Two - previousLine 1 + cursorUpLine 1 putStr "New Line One" pause -- New Line One -- Line Two - nextLine 1 + cursorDownLine 1 putStr "New Line Two" pause -- New Line One -- New Line Two -setPositionExample :: IO () -setPositionExample = do +setCursorPositionExample :: IO () +setCursorPositionExample = do putStrLn "Line One" putStrLn "Line Two" pause -- Line One -- Line Two - setPosition 0 5 + setCursorPosition 0 5 putStr "Foo" pause -- Line Foo -- Line Two - setPosition 1 5 + setCursorPosition 1 5 putStr "Bar" pause -- Line Foo -- Line Bar - setColumn 1 + setCursorColumn 1 putStr "oaf" pause -- Line Foo @@ -118,7 +118,7 @@ -- Line One -- Line Two - setPosition 0 4 + setCursorPosition 0 4 clearFromCursorToScreenEnd pause -- Line @@ -131,7 +131,7 @@ -- Line One -- Line Two - setPosition 1 4 + setCursorPosition 1 4 clearFromCursorToScreenBeginning pause -- @@ -145,13 +145,13 @@ -- Line One -- Line Two - setPosition 0 4 + setCursorPosition 0 4 clearFromCursorToLineEnd pause -- Line -- Line Two - setPosition 1 4 + setCursorPosition 1 4 clearFromCursorToLineBeginning pause -- Line @@ -190,47 +190,49 @@ sgrExample :: IO () sgrExample = do - let colors = enumFromTo minBound maxBound :: [ANSIColor] - forM_ [ForegroundNormalIntensity, ForegroundHighIntensity, BackgroundNormalIntensity, BackgroundHighIntensity] $ \color_way -> do - resetScreen - forM_ colors $ \color -> do - setSGR Reset - setSGR (color_way color) - putStrLn (show color) - pause + let colors = enumFromTo minBound maxBound :: [Color] + forM_ [Foreground, Background] $ \layer -> do + forM_ [Dull, Vivid] $ \intensity -> do + resetScreen + forM_ colors $ \color -> do + setSGR [Reset] + setSGR [SetColor layer intensity color] + putStrLn (show color) + pause -- All the colors, 4 times in sequence - let named_styles = [ (BoldIntensity, "Bold") - , (FaintIntensity, "Faint") - , (NormalIntensity, "Normal") - , (Italic, "Italic") - , (SingleUnderline, "Single Underline") - , (DoubleUnderline, "Double Underline") - , (NoUnderline, "No Underline") - , (SlowBlink, "Slow Blink") - , (RapidBlink, "Rapid Blink") - , (NoBlink, "No Blink") - , (Conceal, "Conceal") - , (Reveal, "Reveal") + let named_styles = [ (SetConsoleIntensity BoldIntensity, "Bold") + , (SetConsoleIntensity FaintIntensity, "Faint") + , (SetConsoleIntensity NormalIntensity, "Normal") + , (SetItalicized True, "Italic") + , (SetItalicized False, "No Italics") + , (SetUnderlining SingleUnderline, "Single Underline") + , (SetUnderlining DoubleUnderline, "Double Underline") + , (SetUnderlining NoUnderline, "No Underline") + , (SetBlinkSpeed SlowBlink, "Slow Blink") + , (SetBlinkSpeed RapidBlink, "Rapid Blink") + , (SetBlinkSpeed NoBlink, "No Blink") + , (SetVisible False, "Conceal") + , (SetVisible True, "Reveal") ] forM_ named_styles $ \(style, name) -> do resetScreen - setSGR style + setSGR [style] putStrLn name pause -- Text describing a style displayed in that style in sequence - setSGR (ForegroundHighIntensity Red) - setSGR (BackgroundHighIntensity Blue) + setSGR [SetColor Foreground Vivid Red] + setSGR [SetColor Background Vivid Blue] - clearScreen >> setPosition 0 0 - setSGR DontSwapForegroundBackground + clearScreen >> setCursorPosition 0 0 + setSGR [SetSwapForegroundBackground False] putStr "Red-On-Blue" pause -- Red-On-Blue - clearScreen >> setPosition 0 0 - setSGR SwapForegroundBackground + clearScreen >> setCursorPosition 0 0 + setSGR [SetSwapForegroundBackground True] putStr "Blue-On-Red" pause -- Blue-On-Red diff --git a/System/Console/ANSI/Unix.hs b/System/Console/ANSI/Unix.hs --- a/System/Console/ANSI/Unix.hs +++ b/System/Console/ANSI/Unix.hs @@ -17,8 +17,8 @@ csi :: [Int] -> String -> String csi args code = "\ESC[" ++ concat (intersperse ";" (map show args)) ++ code -ansiColorToCode :: ANSIColor -> Int -ansiColorToCode color = case color of +colorToCode :: Color -> Int +colorToCode color = case color of Black -> 0 Red -> 1 Green -> 2 @@ -28,27 +28,31 @@ Cyan -> 6 White -> 7 -ansiSGRToCode :: ANSISGR -> Int -ansiSGRToCode sgr = case sgr of +sgrToCode :: SGR -> Int +sgrToCode sgr = case sgr of Reset -> 0 - BoldIntensity -> 1 - FaintIntensity -> 2 - NormalIntensity -> 22 - Italic -> 3 - SingleUnderline -> 4 - DoubleUnderline -> 21 - NoUnderline -> 24 - SlowBlink -> 5 - RapidBlink -> 6 - NoBlink -> 25 - Conceal -> 8 - Reveal -> 28 - SwapForegroundBackground -> 7 - DontSwapForegroundBackground -> 27 - ForegroundNormalIntensity color -> 30 + ansiColorToCode color - ForegroundHighIntensity color -> 90 + ansiColorToCode color - BackgroundNormalIntensity color -> 40 + ansiColorToCode color - BackgroundHighIntensity color -> 100 + ansiColorToCode color + SetConsoleIntensity intensity -> case intensity of + BoldIntensity -> 1 + FaintIntensity -> 2 + NormalIntensity -> 22 + SetItalicized True -> 3 + SetItalicized False -> 23 + SetUnderlining underlining -> case underlining of + 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 cursorUpCode n = csi [n] "A" @@ -62,18 +66,18 @@ hCursorBackward h n = hPutStr h $ cursorBackwardCode n -nextLineCode n = csi [n] "E" -previousLineCode n = csi [n] "F" +cursorDownLineCode n = csi [n] "E" +cursorUpLineCode n = csi [n] "F" -hNextLine h n = hPutStr h $ nextLineCode n -hPreviousLine h n = hPutStr h $ previousLineCode n +hCursorDownLine h n = hPutStr h $ cursorDownLineCode n +hCursorUpLine h n = hPutStr h $ cursorUpLineCode n -setColumnCode n = csi [n + 1] "G" -setPositionCode n m = csi [n + 1, m + 1] "H" +setCursorColumnCode n = csi [n + 1] "G" +setCursorPositionCode n m = csi [n + 1, m + 1] "H" -hSetColumn h n = hPutStr h $ setColumnCode n -hSetPosition h n m = hPutStr h $ setPositionCode n m +hSetCursorColumn h n = hPutStr h $ setCursorColumnCode n +hSetCursorPosition h n m = hPutStr h $ setCursorPositionCode n m clearFromCursorToScreenEndCode = csi [0] "J" @@ -101,9 +105,9 @@ hScrollPageDown h n = hPutStr h $ scrollPageDownCode n -setSGRCode sgr = csi [ansiSGRToCode sgr] "m" +setSGRCode sgrs = csi (map sgrToCode sgrs) "m" -hSetSGR h sgr = hPutStr h $ setSGRCode sgr +hSetSGR h sgrs = hPutStr h $ setSGRCode sgrs hideCursorCode = csi [] "?25l" 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 @@ -8,6 +8,7 @@ import System.IO import Data.Bits +import Data.List #include "Common-Include.hs" @@ -44,21 +45,21 @@ adjustLine :: HANDLE -> (SHORT -> SHORT -> SHORT) -> IO () adjustLine handle change_y = adjustCursorPosition handle (\window_left _ -> window_left) change_y -hNextLine h n = withHandle h $ \handle -> adjustLine handle (\_ y -> y + fromIntegral n) -hPreviousLine h n = withHandle h $ \handle -> adjustLine handle (\_ y -> y - fromIntegral n) +hCursorDownLine h n = withHandle h $ \handle -> adjustLine handle (\_ y -> y + fromIntegral n) +hCursorUpLine h n = withHandle h $ \handle -> adjustLine handle (\_ y -> y - fromIntegral n) -nextLineCode _ = "" -previousLineCode _ = "" +cursorDownLineCode _ = "" +cursorUpLineCode _ = "" -hSetColumn h x = withHandle h $ \handle -> adjustCursorPosition handle (\window_left _ -> window_left + fromIntegral x) (\_ y -> y) +hSetCursorColumn h x = withHandle h $ \handle -> adjustCursorPosition handle (\window_left _ -> window_left + fromIntegral x) (\_ y -> y) -setColumnCode _ = "" +setCursorColumnCode _ = "" -hSetPosition h y x = withHandle h $ \handle -> adjustCursorPosition handle (\window_left _ -> window_left + fromIntegral x) (\window_top _ -> window_top + fromIntegral y) +hSetCursorPosition h y x = withHandle h $ \handle -> adjustCursorPosition handle (\window_left _ -> window_left + fromIntegral x) (\window_top _ -> window_top + fromIntegral y) -setPositionCode _ _ = "" +setCursorPositionCode _ _ = "" clearChar :: WCHAR @@ -141,7 +142,7 @@ {-# INLINE applyANSIColorToAttribute #-} -applyANSIColorToAttribute :: WORD -> WORD -> WORD -> ANSIColor -> WORD -> WORD +applyANSIColorToAttribute :: WORD -> WORD -> WORD -> Color -> WORD -> WORD applyANSIColorToAttribute rED gREEN bLUE color attribute = case color of Black -> attribute' Red -> attribute' .|. rED @@ -155,7 +156,7 @@ wHITE = rED .|. gREEN .|. bLUE attribute' = attribute .&. (complement wHITE) -applyForegroundANSIColorToAttribute, applyBackgroundANSIColorToAttribute :: ANSIColor -> WORD -> WORD +applyForegroundANSIColorToAttribute, applyBackgroundANSIColorToAttribute :: Color -> WORD -> WORD applyForegroundANSIColorToAttribute = applyANSIColorToAttribute fOREGROUND_RED fOREGROUND_GREEN fOREGROUND_BLUE applyBackgroundANSIColorToAttribute = applyANSIColorToAttribute bACKGROUND_RED bACKGROUND_GREEN bACKGROUND_BLUE @@ -168,44 +169,42 @@ foreground_attribute' = background_attribute `shiftR` 4 background_attribute' = foreground_attribute `shiftL` 4 -applyANSISGRToAttribute :: ANSISGR -> WORD -> WORD +applyANSISGRToAttribute :: SGR -> WORD -> WORD applyANSISGRToAttribute sgr attribute = case sgr of Reset -> fOREGROUND_WHITE - BoldIntensity -> attribute .|. iNTENSITY - FaintIntensity -> attribute .&. (complement iNTENSITY) -- Not supported - NormalIntensity -> attribute .&. (complement iNTENSITY) - Italic -> attribute -- Not supported - SingleUnderline -> attribute .|. cOMMON_LVB_UNDERSCORE -- Not supported, since cOMMON_LVB_UNDERSCORE seems to have no effect - DoubleUnderline -> attribute .|. cOMMON_LVB_UNDERSCORE -- Not supported, since cOMMON_LVB_UNDERSCORE seems to have no effect - NoUnderline -> attribute .&. (complement cOMMON_LVB_UNDERSCORE) - SlowBlink -> attribute -- Not supported - RapidBlink -> attribute -- Not supported - NoBlink -> attribute - Conceal -> attribute -- Not supported - Reveal -> attribute + SetConsoleIntensity intensity -> case intensity of + BoldIntensity -> attribute .|. iNTENSITY + FaintIntensity -> attribute .&. (complement iNTENSITY) -- Not supported + NormalIntensity -> attribute .&. (complement iNTENSITY) + SetItalicized _ -> attribute -- Not supported + SetUnderlining underlining -> case underlining of + NoUnderline -> attribute .&. (complement cOMMON_LVB_UNDERSCORE) + _ -> attribute .|. cOMMON_LVB_UNDERSCORE -- Not supported, since cOMMON_LVB_UNDERSCORE seems to have no effect + SetBlinkSpeed _ -> attribute -- Not supported + SetVisible _ -> attribute -- Not supported -- The cOMMON_LVB_REVERSE_VIDEO doesn't actually appear to have any affect on the colors being displayed, so the emulator -- just uses it to carry information and implements the color-swapping behaviour itself. Bit of a hack, I guess :-) - SwapForegroundBackground -> + SetSwapForegroundBackground True -> -- Check if the color-swapping flag is already set if attribute .&. cOMMON_LVB_REVERSE_VIDEO /= 0 then attribute else swapForegroundBackgroundColors attribute .|. cOMMON_LVB_REVERSE_VIDEO - DontSwapForegroundBackground -> + SetSwapForegroundBackground False -> -- Check if the color-swapping flag is already not set if attribute .&. cOMMON_LVB_REVERSE_VIDEO == 0 then attribute else swapForegroundBackgroundColors attribute .&. (complement cOMMON_LVB_REVERSE_VIDEO) - ForegroundNormalIntensity color -> applyForegroundANSIColorToAttribute color (attribute .&. (complement fOREGROUND_INTENSITY)) - ForegroundHighIntensity color -> applyForegroundANSIColorToAttribute color (attribute .|. fOREGROUND_INTENSITY) - BackgroundNormalIntensity color -> applyBackgroundANSIColorToAttribute color (attribute .&. (complement bACKGROUND_INTENSITY)) - BackgroundHighIntensity color -> applyBackgroundANSIColorToAttribute color (attribute .|. bACKGROUND_INTENSITY) + SetColor Foreground Dull color -> applyForegroundANSIColorToAttribute color (attribute .&. (complement fOREGROUND_INTENSITY)) + 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) where iNTENSITY = fOREGROUND_INTENSITY .|. bACKGROUND_INTENSITY hSetSGR h sgr = withHandle h $ \handle -> do screen_buffer_info <- getConsoleScreenBufferInfo handle let attribute = csbi_attributes screen_buffer_info - attribute' = applyANSISGRToAttribute sgr attribute + attribute' = foldl' (flip applyANSISGRToAttribute) attribute sgr setConsoleTextAttribute handle attribute' setSGRCode _ = "" diff --git a/ansi-terminal.cabal b/ansi-terminal.cabal --- a/ansi-terminal.cabal +++ b/ansi-terminal.cabal @@ -1,5 +1,5 @@ Name: ansi-terminal -Version: 0.3.1 +Version: 0.4.0 Cabal-Version: >= 1.2 Category: User Interfaces Synopsis: Simple ANSI terminal support, with Windows compatibility diff --git a/includes/Common-Include.hs b/includes/Common-Include.hs --- a/includes/Common-Include.hs +++ b/includes/Common-Include.hs @@ -12,41 +12,41 @@ cursorBackward = hCursorBackward stdout -hNextLine, hPreviousLine :: Handle - -> Int -- ^ Number of lines to move - -> IO () -nextLine, previousLine :: Int -- ^ Number of lines to move - -> IO () -nextLineCode, previousLineCode :: Int -- ^ Number of lines to move - -> String +hCursorDownLine, hCursorUpLine :: Handle + -> Int -- ^ Number of lines to move + -> IO () +cursorDownLine, cursorUpLine :: Int -- ^ Number of lines to move + -> IO () +cursorDownLineCode, cursorUpLineCode :: Int -- ^ Number of lines to move + -> String -nextLine = hNextLine stdout -previousLine = hPreviousLine stdout +cursorDownLine = hCursorDownLine stdout +cursorUpLine = hCursorUpLine stdout -hSetColumn :: Handle - -> Int -- ^ 0-based column to move to - -> IO () -setColumn :: Int -- ^ 0-based column to move to - -> IO () -setColumnCode :: Int -- ^ 0-based column to move to - -> String +hSetCursorColumn :: Handle + -> Int -- ^ 0-based column to move to + -> IO () +setCursorColumn :: Int -- ^ 0-based column to move to + -> IO () +setCursorColumnCode :: Int -- ^ 0-based column to move to + -> String -setColumn = hSetColumn stdout +setCursorColumn = hSetCursorColumn stdout -hSetPosition :: Handle - -> Int -- ^ 0-based row to move to - -> Int -- ^ 0-based column to move to - -> IO () -setPosition :: Int -- ^ 0-based row to move to - -> Int -- ^ 0-based column to move to - -> IO () -setPositionCode :: Int -- ^ 0-based row to move to - -> Int -- ^ 0-based column to move to - -> String +hSetCursorPosition :: Handle + -> Int -- ^ 0-based row to move to + -> Int -- ^ 0-based column to move to + -> IO () +setCursorPosition :: Int -- ^ 0-based row to move to + -> Int -- ^ 0-based column to move to + -> IO () +setCursorPositionCode :: Int -- ^ 0-based row to move to + -> Int -- ^ 0-based column to move to + -> String -setPosition = hSetPosition stdout +setCursorPosition = hSetCursorPosition stdout hClearFromCursorToScreenEnd, hClearFromCursorToScreenBeginning, hClearScreen :: Handle @@ -86,13 +86,19 @@ -- | Set the Select Graphic Rendition mode hSetSGR :: Handle - -> ANSISGR -- ^ Mode: this is applied to the current console SGR mode + -> [SGR] -- ^ Commands: these will typically be applied on top of the current console SGR mode. + -- An empty list of commands is equivalent to the list @[Reset]@. Commands are applied + -- left to right. -> IO () -- | Set the Select Graphic Rendition mode -setSGR :: ANSISGR -- ^ Mode: this is applied to the current console SGR mode +setSGR :: [SGR] -- ^ Commands: these will typically be applied on top of the current console SGR mode. + -- An empty list of commands is equivalent to the list @[Reset]@. Commands are applied + -- left to right. -> IO () -- | Set the Select Graphic Rendition mode -setSGRCode :: ANSISGR -- ^ Mode: this is applied to the current console SGR mode +setSGRCode :: [SGR] -- ^ Commands: these will typically be applied on top of the current console SGR mode. + -- An empty list of commands is equivalent to the list @[Reset]@. Commands are applied + -- left to right. -> String setSGR = hSetSGR stdout diff --git a/includes/Exports-Include.hs b/includes/Exports-Include.hs --- a/includes/Exports-Include.hs +++ b/includes/Exports-Include.hs @@ -7,18 +7,18 @@ cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode, -- * Cursor movement by line -nextLine, previousLine, -hNextLine, hPreviousLine, -nextLineCode, previousLineCode, +cursorUpLine, cursorDownLine, +hCursorUpLine, hCursorDownLine, +cursorUpLineCode, cursorDownLineCode, -- * Directly changing cursor position -setColumn, -hSetColumn, -setColumnCode, +setCursorColumn, +hSetCursorColumn, +setCursorColumnCode, -setPosition, -hSetPosition, -setPositionCode, +setCursorPosition, +hSetCursorPosition, +setCursorPositionCode, -- * Clearing parts of the screen clearFromCursorToScreenEnd, clearFromCursorToScreenBeginning, clearScreen,