#include "Common-Safe-Haskell.hs"

{-| This module exports functions that return 'String' values containing codes
in accordance with the \'ANSI\' standards for control character sequences
described in the documentation of module "System.Console.ANSI".

The module "System.Console.ANSI" exports functions with the same names as those
in this module. On some versions of Windows, the terminal in use may not be
ANSI-capable. When that is the case, the same-named functions exported by module
"System.Console.ANSI" return \"\", for the reasons set out in the documentation
of that module.

Consequently, if module "System.Console.ANSI" is also imported, this module is
intended to be imported qualified, to avoid name clashes with those functions.
For example:

> import qualified System.Console.ANSI.Codes as ANSI
-}
module System.Console.ANSI.Codes
  (
    -- * Basic data types

    module System.Console.ANSI.Types

    -- * Cursor movement by character

  , cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode

    -- * Cursor movement by line

  , cursorUpLineCode, cursorDownLineCode

    -- * Directly changing cursor position

  , setCursorColumnCode, setCursorPositionCode

    -- * Saving, restoring and reporting cursor position

  , saveCursorCode, restoreCursorCode, reportCursorPositionCode

    -- * Clearing parts of the screen

  , clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode
  , clearScreenCode, clearFromCursorToLineEndCode
  , clearFromCursorToLineBeginningCode, clearLineCode

    -- * Scrolling the screen

  , scrollPageUpCode, scrollPageDownCode

    -- * Select Graphic Rendition mode: colors and other whizzy stuff

  , setSGRCode

    -- * Cursor visibilty changes

  , hideCursorCode, showCursorCode

    -- * Hyperlinks

    -- | Some, but not all, terminals support hyperlinks - that is, clickable

    -- text that points to a URI.

  , hyperlinkCode, hyperlinkWithIdCode, hyperlinkWithParamsCode

    -- * Changing the title

  , setTitleCode

    -- * Utilities

  , colorToCode, csi, sgrToCode
  ) where

import Data.List (intercalate)

import Data.Colour.SRGB (toSRGB24, RGB (..))

import System.Console.ANSI.Types

-- | 'csi' @parameters controlFunction@, where @parameters@ is a list of 'Int',

-- returns the control sequence comprising the control function CONTROL

-- SEQUENCE INTRODUCER (CSI) followed by the parameter(s) (separated by \';\')

-- and ending with the @controlFunction@ character(s) that identifies the

-- control function.

csi :: [Int]  -- ^ List of parameters for the control sequence

    -> String -- ^ Character(s) that identify the control function

    -> String
csi :: [Int] -> String -> String
csi [Int]
args String
code = String
"\ESC[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
";" ((Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
forall a. Show a => a -> String
show [Int]
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
code

-- | 'colorToCode' @color@ returns the 0-based index of the color (one of the

-- eight colors in the ANSI standard).

colorToCode :: Color -> Int
colorToCode :: Color -> Int
colorToCode Color
color = case Color
color of
  Color
Black   -> Int
0
  Color
Red     -> Int
1
  Color
Green   -> Int
2
  Color
Yellow  -> Int
3
  Color
Blue    -> Int
4
  Color
Magenta -> Int
5
  Color
Cyan    -> Int
6
  Color
White   -> Int
7

-- | 'sgrToCode' @sgr@ returns the parameter of the SELECT GRAPHIC RENDITION

-- (SGR) aspect identified by @sgr@.

sgrToCode :: SGR -- ^ The SGR aspect

          -> [Int]
sgrToCode :: SGR -> [Int]
sgrToCode SGR
sgr = case SGR
sgr of
  SGR
Reset -> [Int
0]
  SetConsoleIntensity ConsoleIntensity
intensity -> case ConsoleIntensity
intensity of
    ConsoleIntensity
BoldIntensity   -> [Int
1]
    ConsoleIntensity
FaintIntensity  -> [Int
2]
    ConsoleIntensity
NormalIntensity -> [Int
22]
  SetItalicized Bool
True  -> [Int
3]
  SetItalicized Bool
False -> [Int
23]
  SetUnderlining Underlining
underlining -> case Underlining
underlining of
    Underlining
SingleUnderline -> [Int
4]
    Underlining
DoubleUnderline -> [Int
21]
    Underlining
NoUnderline     -> [Int
24]
  SetBlinkSpeed BlinkSpeed
blink_speed -> case BlinkSpeed
blink_speed of
    BlinkSpeed
SlowBlink   -> [Int
5]
    BlinkSpeed
RapidBlink  -> [Int
6]
    BlinkSpeed
NoBlink     -> [Int
25]
  SetVisible Bool
False -> [Int
8]
  SetVisible Bool
True  -> [Int
28]
  SetSwapForegroundBackground Bool
True  -> [Int
7]
  SetSwapForegroundBackground Bool
False -> [Int
27]
  SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
color  -> [Int
30 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Color -> Int
colorToCode Color
color]
  SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
color -> [Int
90 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Color -> Int
colorToCode Color
color]
  SetColor ConsoleLayer
Background ColorIntensity
Dull Color
color  -> [Int
40 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Color -> Int
colorToCode Color
color]
  SetColor ConsoleLayer
Background ColorIntensity
Vivid Color
color -> [Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Color -> Int
colorToCode Color
color]
  SetPaletteColor ConsoleLayer
Foreground Word8
index -> [Int
38, Int
5, Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
index]
  SetPaletteColor ConsoleLayer
Background Word8
index -> [Int
48, Int
5, Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
index]
  SetRGBColor ConsoleLayer
Foreground Colour Float
color -> [Int
38, Int
2] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ Colour Float -> [Int]
forall b b. (Num b, RealFrac b, Floating b) => Colour b -> [b]
toRGB Colour Float
color
  SetRGBColor ConsoleLayer
Background Colour Float
color -> [Int
48, Int
2] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ Colour Float -> [Int]
forall b b. (Num b, RealFrac b, Floating b) => Colour b -> [b]
toRGB Colour Float
color
  SetDefaultColor ConsoleLayer
Foreground -> [Int
39]
  SetDefaultColor ConsoleLayer
Background -> [Int
49]
 where
  toRGB :: Colour b -> [b]
toRGB Colour b
color = let RGB Word8
r Word8
g Word8
b = Colour b -> RGB Word8
forall b. (RealFrac b, Floating b) => Colour b -> RGB Word8
toSRGB24 Colour b
color
                in  (Word8 -> b) -> [Word8] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Word8
r, Word8
g, Word8
b]

cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode
  :: Int -- ^ Number of lines or characters to move

  -> String
cursorUpCode :: Int -> String
cursorUpCode Int
n = [Int] -> String -> String
csi [Int
n] String
"A"
cursorDownCode :: Int -> String
cursorDownCode Int
n = [Int] -> String -> String
csi [Int
n] String
"B"
cursorForwardCode :: Int -> String
cursorForwardCode Int
n = [Int] -> String -> String
csi [Int
n] String
"C"
cursorBackwardCode :: Int -> String
cursorBackwardCode Int
n = [Int] -> String -> String
csi [Int
n] String
"D"

cursorDownLineCode, cursorUpLineCode :: Int -- ^ Number of lines to move

                                     -> String
cursorDownLineCode :: Int -> String
cursorDownLineCode Int
n = [Int] -> String -> String
csi [Int
n] String
"E"
cursorUpLineCode :: Int -> String
cursorUpLineCode Int
n = [Int] -> String -> String
csi [Int
n] String
"F"

-- | Code to move the cursor to the specified column. The column numbering is

-- 0-based (that is, the left-most column is numbered 0).

setCursorColumnCode :: Int -- ^ 0-based column to move to

                    -> String
setCursorColumnCode :: Int -> String
setCursorColumnCode Int
n = [Int] -> String -> String
csi [Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1] String
"G"

-- | Code to move the cursor to the specified position (row and column). The

-- position is 0-based (that is, the top-left corner is at row 0 column 0).

setCursorPositionCode :: Int -- ^ 0-based row to move to

                      -> Int -- ^ 0-based column to move to

                      -> String
setCursorPositionCode :: Int -> Int -> String
setCursorPositionCode Int
n Int
m = [Int] -> String -> String
csi [Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1] String
"H"

-- | @since 0.7.1

saveCursorCode, restoreCursorCode :: String
saveCursorCode :: String
saveCursorCode = String
"\ESC7"
restoreCursorCode :: String
restoreCursorCode = String
"\ESC8"

-- | Code to emit the cursor position into the console input stream, immediately

-- after being recognised on the output stream, as:

-- @ESC [ \<cursor row> ; \<cursor column> R@

--

-- Note that the information that is emitted is 1-based (the top-left corner is

-- at row 1 column 1) but 'setCursorPositionCode' is 0-based.

--

-- In isolation of 'getReportedCursorPosition' or 'getCursorPosition', this

-- function may be of limited use on Windows operating systems because of

-- difficulties in obtaining the data emitted into the console input stream.

-- The function 'hGetBufNonBlocking' in module "System.IO" does not work on

-- Windows. This has been attributed to the lack of non-blocking primatives in

-- the operating system (see the GHC bug report #806 at

-- <https://ghc.haskell.org/trac/ghc/ticket/806>).

--

-- @since 0.7.1

reportCursorPositionCode :: String

reportCursorPositionCode :: String
reportCursorPositionCode = [Int] -> String -> String
csi [] String
"6n"

clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode,
  clearScreenCode :: String
clearFromCursorToLineEndCode, clearFromCursorToLineBeginningCode,
  clearLineCode :: String

clearFromCursorToScreenEndCode :: String
clearFromCursorToScreenEndCode = [Int] -> String -> String
csi [Int
0] String
"J"
clearFromCursorToScreenBeginningCode :: String
clearFromCursorToScreenBeginningCode = [Int] -> String -> String
csi [Int
1] String
"J"
clearScreenCode :: String
clearScreenCode = [Int] -> String -> String
csi [Int
2] String
"J"
clearFromCursorToLineEndCode :: String
clearFromCursorToLineEndCode = [Int] -> String -> String
csi [Int
0] String
"K"
clearFromCursorToLineBeginningCode :: String
clearFromCursorToLineBeginningCode = [Int] -> String -> String
csi [Int
1] String
"K"
clearLineCode :: String
clearLineCode = [Int] -> String -> String
csi [Int
2] String
"K"

scrollPageUpCode, scrollPageDownCode :: Int -- ^ Number of lines to scroll by

                                     -> String
scrollPageUpCode :: Int -> String
scrollPageUpCode Int
n = [Int] -> String -> String
csi [Int
n] String
"S"
scrollPageDownCode :: Int -> String
scrollPageDownCode Int
n = [Int] -> String -> String
csi [Int
n] String
"T"

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
setSGRCode :: [SGR] -> String
setSGRCode [SGR]
sgrs = [Int] -> String -> String
csi ((SGR -> [Int]) -> [SGR] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SGR -> [Int]
sgrToCode [SGR]
sgrs) String
"m"

hideCursorCode, showCursorCode :: String
hideCursorCode :: String
hideCursorCode = [Int] -> String -> String
csi [] String
"?25l"
showCursorCode :: String
showCursorCode = [Int] -> String -> String
csi [] String
"?25h"

-- | Code to introduce a hyperlink with (key, value) parameters. Some terminals

-- support an @id@ parameter key, so that hyperlinks with the same @id@ value

-- are treated as connected.

--

-- @since 0.11.3

hyperlinkWithParamsCode
  :: [(String, String)]
  -- ^ Parameters

  -> String
  -- ^ URI

  -> String
  -- ^ Link text

  -> String
hyperlinkWithParamsCode :: [(String, String)] -> String -> String -> String
hyperlinkWithParamsCode [(String, String)]
ps String
uri String
link =
  String
"\ESC]8;" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ps' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
uri String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\ESC\\" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
link String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\ESC]8;;\ESC\\"
 where
  ps' :: String
ps' = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
":" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
k, String
v) -> String
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v) [(String, String)]
ps

-- | Code to introduce a hyperlink.

--

-- @since 0.11.3

hyperlinkCode
  :: String
  -- ^ URI

  -> String
  -- ^ Link text

  -> String
hyperlinkCode :: String -> String -> String
hyperlinkCode = [(String, String)] -> String -> String -> String
hyperlinkWithParamsCode []

-- | Code to introduce a hyperlink with an identifier for the link. Some

-- terminals support an identifier, so that hyperlinks with the same identifier

-- are treated as connected.

--

-- @since 0.11.3

hyperlinkWithIdCode
  :: String
  -- ^ Identifier for the link

  -> String
  -- ^ URI

  -> String
  -- ^ Link text

  -> String
hyperlinkWithIdCode :: String -> String -> String -> String
hyperlinkWithIdCode String
linkId = [(String, String)] -> String -> String -> String
hyperlinkWithParamsCode [(String
"id", String
linkId)]

-- | Code to set the terminal window title and the icon name (that is, the text

-- for the window in the Start bar, or similar).


-- Thanks to Brandon S. Allbery and Curt Sampson for pointing me in the right

-- direction on xterm title setting on haskell-cafe. The "0" signifies that both

-- the title and "icon" text should be set. This is chosen for consistent

-- behaviour between Unixes and Windows.

setTitleCode :: String -- ^ New window title and icon name

             -> String
setTitleCode :: String -> String
setTitleCode String
title = String
"\ESC]0;" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\007') String
title String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\007"