#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

    -- * Changing the title

    -- | 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: i.e. the

    -- text for the window in the Start bar (or similar) as well as that in

    -- the actual window title. This is chosen for consistent behaviour

    -- between Unixes and Windows.

  , setTitleCode

    -- * Utilities

  , colorToCode, csi, sgrToCode
  ) where

import Data.List (intersperse)

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 args :: [Int]
args code :: String
code = "\ESC[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse ";" ((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
color = case Color
color of
  Black   -> 0
  Red     -> 1
  Green   -> 2
  Yellow  -> 3
  Blue    -> 4
  Magenta -> 5
  Cyan    -> 6
  White   -> 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
sgr = case SGR
sgr of
  Reset -> [0]
  SetConsoleIntensity intensity :: ConsoleIntensity
intensity -> case ConsoleIntensity
intensity of
    BoldIntensity   -> [1]
    FaintIntensity  -> [2]
    NormalIntensity -> [22]
  SetItalicized True  -> [3]
  SetItalicized False -> [23]
  SetUnderlining underlining :: Underlining
underlining -> case Underlining
underlining of
    SingleUnderline -> [4]
    DoubleUnderline -> [21]
    NoUnderline     -> [24]
  SetBlinkSpeed blink_speed :: BlinkSpeed
blink_speed -> case BlinkSpeed
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 :: Color
color  -> [30 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Color -> Int
colorToCode Color
color]
  SetColor Foreground Vivid color :: Color
color -> [90 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Color -> Int
colorToCode Color
color]
  SetColor Background Dull color :: Color
color  -> [40 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Color -> Int
colorToCode Color
color]
  SetColor Background Vivid color :: Color
color -> [100 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Color -> Int
colorToCode Color
color]
  SetPaletteColor Foreground index :: Word8
index -> [38, 5, Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
index]
  SetPaletteColor Background index :: Word8
index -> [48, 5, Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
index]
  SetRGBColor Foreground color :: Colour Float
color -> [38, 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 Background color :: Colour Float
color -> [48, 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 Foreground -> [39]
  SetDefaultColor Background -> [49]
 where
  toRGB :: Colour b -> [b]
toRGB color :: Colour b
color = let RGB r :: Word8
r g :: Word8
g b :: 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 n :: Int
n = [Int] -> String -> String
csi [Int
n] "A"
cursorDownCode :: Int -> String
cursorDownCode n :: Int
n = [Int] -> String -> String
csi [Int
n] "B"
cursorForwardCode :: Int -> String
cursorForwardCode n :: Int
n = [Int] -> String -> String
csi [Int
n] "C"
cursorBackwardCode :: Int -> String
cursorBackwardCode n :: Int
n = [Int] -> String -> String
csi [Int
n] "D"

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

                                     -> String
cursorDownLineCode :: Int -> String
cursorDownLineCode n :: Int
n = [Int] -> String -> String
csi [Int
n] "E"
cursorUpLineCode :: Int -> String
cursorUpLineCode n :: Int
n = [Int] -> String -> String
csi [Int
n] "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 n :: Int
n = [Int] -> String -> String
csi [Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1] "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 n :: Int
n m :: Int
m = [Int] -> String -> String
csi [Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1] "H"

-- | @since 0.7.1

saveCursorCode, restoreCursorCode :: String
saveCursorCode :: String
saveCursorCode = "\ESC7"
restoreCursorCode :: String
restoreCursorCode = "\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 [] "6n"

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

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

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

                                     -> String
scrollPageUpCode :: Int -> String
scrollPageUpCode n :: Int
n = [Int] -> String -> String
csi [Int
n] "S"
scrollPageDownCode :: Int -> String
scrollPageDownCode n :: Int
n = [Int] -> String -> String
csi [Int
n] "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 sgrs :: [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) "m"

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


-- | XTerm control sequence to set the Icon Name and Window Title.

setTitleCode :: String -- ^ New Icon Name and Window Title

             -> String
setTitleCode :: String -> String
setTitleCode title :: String
title = "\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
/= '\007') String
title String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\007"