Major API overhaul

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

System/Console/ANSI/Example.hs

@@ -13,7 +13,7 @@ import Control.Monad
 examples :: [IO ()]
 examples = [ cursorMovementExample
            , lineChangeExample
-           , setPositionExample
+           , setCursorPositionExample
            , clearExample
            , scrollExample
            , sgrExample
@@ -24,7 +24,7 @@ main :: IO ()
 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 @@ lineChangeExample = do
     -- 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 @@ clearExample = do
     -- Line One
     -- Line Two
 
-    setPosition 0 4
+    setCursorPosition 0 4
     clearFromCursorToScreenEnd
     pause
     -- Line
@@ -131,7 +131,7 @@ clearExample = do
     -- Line One
     -- Line Two
 
-    setPosition 1 4
+    setCursorPosition 1 4
     clearFromCursorToScreenBeginning
     pause
     --
@@ -145,13 +145,13 @@ clearExample = do
     -- 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 @@ scrollExample = do
 
 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

System/Console/ANSI/Unix.hs

@@ -17,8 +17,8 @@ import Data.List
 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 @@ ansiColorToCode color = case color of
     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 @@ hCursorForward h n = hPutStr h $ cursorForwardCode n
 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 @@ hScrollPageUp h n = hPutStr h $ scrollPageUpCode n
 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"