#include "Common-Safe-Haskell.hs"
{-# OPTIONS_HADDOCK hide #-}
module System.Console.ANSI.Unix
(
#include "Exports-Include.hs"
) where
import Control.Exception.Base (bracket)
import Control.Monad (when)
import Data.List (uncons)
import Data.Maybe (fromMaybe, mapMaybe)
import System.IO (BufferMode (..), Handle, hGetBuffering, hGetEcho,
hIsTerminalDevice, hIsWritable, hPutStr, hReady, hSetBuffering, hSetEcho,
stdin)
import System.Timeout (timeout)
import Text.ParserCombinators.ReadP (readP_to_S)
import System.Console.ANSI.Codes
#include "Common-Include.hs"
#include "Common-Include-Enabled.hs"
hCursorUp :: Handle -> Int -> IO ()
hCursorUp Handle
h Int
n = Handle -> String -> IO ()
hPutStr Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
cursorUpCode Int
n
hCursorDown :: Handle -> Int -> IO ()
hCursorDown Handle
h Int
n = Handle -> String -> IO ()
hPutStr Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
cursorDownCode Int
n
hCursorForward :: Handle -> Int -> IO ()
hCursorForward Handle
h Int
n = Handle -> String -> IO ()
hPutStr Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
cursorForwardCode Int
n
hCursorBackward :: Handle -> Int -> IO ()
hCursorBackward Handle
h Int
n = Handle -> String -> IO ()
hPutStr Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
cursorBackwardCode Int
n
hCursorDownLine :: Handle -> Int -> IO ()
hCursorDownLine Handle
h Int
n = Handle -> String -> IO ()
hPutStr Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
cursorDownLineCode Int
n
hCursorUpLine :: Handle -> Int -> IO ()
hCursorUpLine Handle
h Int
n = Handle -> String -> IO ()
hPutStr Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
cursorUpLineCode Int
n
hSetCursorColumn :: Handle -> Int -> IO ()
hSetCursorColumn Handle
h Int
n = Handle -> String -> IO ()
hPutStr Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
setCursorColumnCode Int
n
hSetCursorPosition :: Handle -> Int -> Int -> IO ()
hSetCursorPosition Handle
h Int
n Int
m = Handle -> String -> IO ()
hPutStr Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> String
setCursorPositionCode Int
n Int
m
hSaveCursor :: Handle -> IO ()
hSaveCursor Handle
h = Handle -> String -> IO ()
hPutStr Handle
h String
saveCursorCode
hRestoreCursor :: Handle -> IO ()
hRestoreCursor Handle
h = Handle -> String -> IO ()
hPutStr Handle
h String
restoreCursorCode
hReportCursorPosition :: Handle -> IO ()
hReportCursorPosition Handle
h = Handle -> String -> IO ()
hPutStr Handle
h String
reportCursorPositionCode
hClearFromCursorToScreenEnd :: Handle -> IO ()
hClearFromCursorToScreenEnd Handle
h = Handle -> String -> IO ()
hPutStr Handle
h String
clearFromCursorToScreenEndCode
hClearFromCursorToScreenBeginning :: Handle -> IO ()
hClearFromCursorToScreenBeginning Handle
h
= Handle -> String -> IO ()
hPutStr Handle
h String
clearFromCursorToScreenBeginningCode
hClearScreen :: Handle -> IO ()
hClearScreen Handle
h = Handle -> String -> IO ()
hPutStr Handle
h String
clearScreenCode
hClearFromCursorToLineEnd :: Handle -> IO ()
hClearFromCursorToLineEnd Handle
h = Handle -> String -> IO ()
hPutStr Handle
h String
clearFromCursorToLineEndCode
hClearFromCursorToLineBeginning :: Handle -> IO ()
hClearFromCursorToLineBeginning Handle
h = Handle -> String -> IO ()
hPutStr Handle
h String
clearFromCursorToLineBeginningCode
hClearLine :: Handle -> IO ()
hClearLine Handle
h = Handle -> String -> IO ()
hPutStr Handle
h String
clearLineCode
hScrollPageUp :: Handle -> Int -> IO ()
hScrollPageUp Handle
h Int
n = Handle -> String -> IO ()
hPutStr Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
scrollPageUpCode Int
n
hScrollPageDown :: Handle -> Int -> IO ()
hScrollPageDown Handle
h Int
n = Handle -> String -> IO ()
hPutStr Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
scrollPageDownCode Int
n
hUseAlternateScreenBuffer :: Handle -> IO ()
hUseAlternateScreenBuffer Handle
h = Handle -> String -> IO ()
hPutStr Handle
h String
useAlternateScreenBufferCode
hUseNormalScreenBuffer :: Handle -> IO ()
hUseNormalScreenBuffer Handle
h = Handle -> String -> IO ()
hPutStr Handle
h String
useNormalScreenBufferCode
hReportLayerColor :: Handle -> ConsoleLayer -> IO ()
hReportLayerColor Handle
h ConsoleLayer
layer = Handle -> String -> IO ()
hPutStr Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ConsoleLayer -> String
reportLayerColorCode ConsoleLayer
layer
hSetSGR :: Handle -> [SGR] -> IO ()
hSetSGR Handle
h [SGR]
sgrs = Handle -> String -> IO ()
hPutStr Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [SGR] -> String
setSGRCode [SGR]
sgrs
hHideCursor :: Handle -> IO ()
hHideCursor Handle
h = Handle -> String -> IO ()
hPutStr Handle
h String
hideCursorCode
hShowCursor :: Handle -> IO ()
hShowCursor Handle
h = Handle -> String -> IO ()
hPutStr Handle
h String
showCursorCode
hHyperlinkWithParams :: Handle -> [(String, String)] -> String -> String -> IO ()
hHyperlinkWithParams Handle
h [(String, String)]
params String
uri String
link =
Handle -> String -> IO ()
hPutStr Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> String -> String -> String
hyperlinkWithParamsCode [(String, String)]
params String
uri String
link
hSetTitle :: Handle -> String -> IO ()
hSetTitle Handle
h String
title = Handle -> String -> IO ()
hPutStr Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String
setTitleCode String
title
hSupportsANSI :: Handle -> IO Bool
hSupportsANSI Handle
h = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool) -> IO Bool -> IO (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO Bool
hIsTerminalDevice Handle
h IO (Bool -> Bool) -> IO Bool -> IO Bool
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO Bool
isNotDumb
where
isNotDumb :: IO Bool
isNotDumb = (Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> Maybe String
forall a. a -> Maybe a
Just String
"dumb") (Maybe String -> Bool)
-> ([(String, String)] -> Maybe String)
-> [(String, String)]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"TERM" ([(String, String)] -> Bool) -> IO [(String, String)] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(String, String)]
getEnvironment
hSupportsANSIWithoutEmulation :: Handle -> IO (Maybe Bool)
hSupportsANSIWithoutEmulation Handle
h =
Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> IO Bool -> IO (Maybe Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool) -> IO Bool -> IO (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO Bool
hIsWritable Handle
h IO (Bool -> Bool) -> IO Bool -> IO Bool
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Handle -> IO Bool
hSupportsANSI Handle
h)
getReportedCursorPosition :: IO String
getReportedCursorPosition = String -> [String] -> IO String
getReport String
"\ESC[" [String
"R"]
getReportedLayerColor :: ConsoleLayer -> IO String
getReportedLayerColor ConsoleLayer
layer =
String -> [String] -> IO String
getReport (String
"\ESC]" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pS String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";rgb:") [String
"\BEL", String
"\ESC\\"]
where
pS :: String
pS = case ConsoleLayer
layer of
ConsoleLayer
Foreground -> String
"10"
ConsoleLayer
Background -> String
"11"
getReport :: String -> [String] -> IO String
getReport :: String -> [String] -> IO String
getReport String
_ [] = String -> IO String
forall a. HasCallStack => String -> a
error String
"getReport requires a list of terminating sequences."
getReport String
startChars [String]
endChars = do
String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO String -> IO (Maybe String)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
500000 (String -> String -> IO String
getStart String
startChars String
"")
where
endChars' :: [(Char, String)]
endChars' = (String -> Maybe (Char, String)) -> [String] -> [(Char, String)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe (Char, String)
forall a. [a] -> Maybe (a, [a])
uncons [String]
endChars
getStart :: String -> String -> IO String
getStart :: String -> String -> IO String
getStart String
"" String
r = String -> IO String
getRest String
r
getStart (Char
h:String
hs) String
r = do
Char
c <- IO Char
getChar
if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
h
then String -> String -> IO String
getStart String
hs (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
r)
else String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
r)
getRest :: String -> IO String
getRest :: String -> IO String
getRest String
r = do
Char
c <- IO Char
getChar
case Char -> [(Char, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Char
c [(Char, String)]
endChars' of
Maybe String
Nothing -> String -> IO String
getRest (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
r)
Just String
es -> String -> String -> IO String
getEnd String
es (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
r)
getEnd :: String -> String -> IO String
getEnd :: String -> String -> IO String
getEnd String
"" String
r = String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse String
r
getEnd (Char
e:String
es) String
r = do
Char
c <- IO Char
getChar
if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
e
then String -> IO String
getRest (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
r)
else String -> String -> IO String
getEnd String
es (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
r)
hGetCursorPosition :: Handle -> IO (Maybe (Int, Int))
hGetCursorPosition Handle
h = ((Int, Int) -> (Int, Int)) -> Maybe (Int, Int) -> Maybe (Int, Int)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Int) -> (Int, Int)
forall {a} {b}. (Num a, Num b) => (a, b) -> (a, b)
to0base (Maybe (Int, Int) -> Maybe (Int, Int))
-> IO (Maybe (Int, Int)) -> IO (Maybe (Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe (Int, Int))
getCursorPosition'
where
to0base :: (a, b) -> (a, b)
to0base (a
row, b
col) = (a
row a -> a -> a
forall a. Num a => a -> a -> a
- a
1, b
col b -> b -> b
forall a. Num a => a -> a -> a
- b
1)
getCursorPosition' :: IO (Maybe (Int, Int))
getCursorPosition' = do
String
input <- IO BufferMode
-> (BufferMode -> IO ()) -> (BufferMode -> IO String) -> IO String
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Handle -> IO BufferMode
hGetBuffering Handle
stdin) (Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdin) ((BufferMode -> IO String) -> IO String)
-> (BufferMode -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \BufferMode
_ -> do
Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdin BufferMode
NoBuffering
IO Bool -> (Bool -> IO ()) -> (Bool -> IO String) -> IO String
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Handle -> IO Bool
hGetEcho Handle
stdin) (Handle -> Bool -> IO ()
hSetEcho Handle
stdin) ((Bool -> IO String) -> IO String)
-> (Bool -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \Bool
_ -> do
Handle -> Bool -> IO ()
hSetEcho Handle
stdin Bool
False
IO ()
clearStdin
Handle -> IO ()
hReportCursorPosition Handle
h
Handle -> IO ()
hFlush Handle
h
IO String
getReportedCursorPosition
case ReadP (Int, Int) -> ReadS (Int, Int)
forall a. ReadP a -> ReadS a
readP_to_S ReadP (Int, Int)
cursorPosition String
input of
[] -> Maybe (Int, Int) -> IO (Maybe (Int, Int))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Int, Int)
forall a. Maybe a
Nothing
[((Int
row, Int
col),String
_)] -> Maybe (Int, Int) -> IO (Maybe (Int, Int))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Int, Int) -> IO (Maybe (Int, Int)))
-> Maybe (Int, Int) -> IO (Maybe (Int, Int))
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Maybe (Int, Int)
forall a. a -> Maybe a
Just (Int
row, Int
col)
(((Int, Int), String)
_:[((Int, Int), String)]
_) -> Maybe (Int, Int) -> IO (Maybe (Int, Int))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Int, Int)
forall a. Maybe a
Nothing
clearStdin :: IO ()
clearStdin = do
Bool
isReady <- Handle -> IO Bool
hReady Handle
stdin
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isReady (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Char
_ <-IO Char
getChar
IO ()
clearStdin
hGetLayerColor :: Handle -> ConsoleLayer -> IO (Maybe (RGB Word16))
hGetLayerColor Handle
h ConsoleLayer
layer = do
String
input <- IO BufferMode
-> (BufferMode -> IO ()) -> (BufferMode -> IO String) -> IO String
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Handle -> IO BufferMode
hGetBuffering Handle
stdin) (Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdin) ((BufferMode -> IO String) -> IO String)
-> (BufferMode -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \BufferMode
_ -> do
Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdin BufferMode
NoBuffering
IO Bool -> (Bool -> IO ()) -> (Bool -> IO String) -> IO String
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Handle -> IO Bool
hGetEcho Handle
stdin) (Handle -> Bool -> IO ()
hSetEcho Handle
stdin) ((Bool -> IO String) -> IO String)
-> (Bool -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \Bool
_ -> do
Handle -> Bool -> IO ()
hSetEcho Handle
stdin Bool
False
IO ()
clearStdin
Handle -> ConsoleLayer -> IO ()
hReportLayerColor Handle
h ConsoleLayer
layer
Handle -> IO ()
hFlush Handle
h
ConsoleLayer -> IO String
getReportedLayerColor ConsoleLayer
layer
case ReadP (RGB Word16) -> ReadS (RGB Word16)
forall a. ReadP a -> ReadS a
readP_to_S (ConsoleLayer -> ReadP (RGB Word16)
layerColor ConsoleLayer
layer) String
input of
[] -> Maybe (RGB Word16) -> IO (Maybe (RGB Word16))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (RGB Word16)
forall a. Maybe a
Nothing
[(RGB Word16
col, String
_)] -> Maybe (RGB Word16) -> IO (Maybe (RGB Word16))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (RGB Word16) -> IO (Maybe (RGB Word16)))
-> Maybe (RGB Word16) -> IO (Maybe (RGB Word16))
forall a b. (a -> b) -> a -> b
$ RGB Word16 -> Maybe (RGB Word16)
forall a. a -> Maybe a
Just RGB Word16
col
((RGB Word16, String)
_:[(RGB Word16, String)]
_) -> Maybe (RGB Word16) -> IO (Maybe (RGB Word16))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (RGB Word16)
forall a. Maybe a
Nothing
where
clearStdin :: IO ()
clearStdin = do
Bool
isReady <- Handle -> IO Bool
hReady Handle
stdin
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isReady (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Char
_ <-IO Char
getChar
IO ()
clearStdin