#include "Common-Safe-Haskell.hs"
{-# OPTIONS_HADDOCK hide #-}
module System.Console.ANSI.Unix
(
#include "Exports-Include.hs"
) where
import Data.Maybe (fromMaybe)
import Control.Exception.Base (bracket)
import System.IO (BufferMode (..), Handle, hGetBuffering, hGetEcho,
hIsTerminalDevice, hIsWritable, hPutStr, hSetBuffering, hSetEcho, stdin)
import System.Timeout (timeout)
import Text.ParserCombinators.ReadP (readP_to_S)
import System.Console.ANSI.Codes
import System.Console.ANSI.Types
#include "Common-Include.hs"
#include "Common-Include-Enabled.hs"
hCursorUp :: Handle -> Int -> IO ()
hCursorUp h :: Handle
h n :: 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 h :: Handle
h n :: 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 h :: Handle
h n :: 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 h :: Handle
h n :: 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 h :: Handle
h n :: 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 h :: Handle
h n :: 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 h :: Handle
h n :: 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 h :: Handle
h n :: Int
n m :: 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 h :: Handle
h = Handle -> String -> IO ()
hPutStr Handle
h String
saveCursorCode
hRestoreCursor :: Handle -> IO ()
hRestoreCursor h :: Handle
h = Handle -> String -> IO ()
hPutStr Handle
h String
restoreCursorCode
hReportCursorPosition :: Handle -> IO ()
hReportCursorPosition h :: Handle
h = Handle -> String -> IO ()
hPutStr Handle
h String
reportCursorPositionCode
hClearFromCursorToScreenEnd :: Handle -> IO ()
hClearFromCursorToScreenEnd h :: Handle
h = Handle -> String -> IO ()
hPutStr Handle
h String
clearFromCursorToScreenEndCode
hClearFromCursorToScreenBeginning :: Handle -> IO ()
hClearFromCursorToScreenBeginning h :: Handle
h
= Handle -> String -> IO ()
hPutStr Handle
h String
clearFromCursorToScreenBeginningCode
hClearScreen :: Handle -> IO ()
hClearScreen h :: Handle
h = Handle -> String -> IO ()
hPutStr Handle
h String
clearScreenCode
hClearFromCursorToLineEnd :: Handle -> IO ()
hClearFromCursorToLineEnd h :: Handle
h = Handle -> String -> IO ()
hPutStr Handle
h String
clearFromCursorToLineEndCode
hClearFromCursorToLineBeginning :: Handle -> IO ()
hClearFromCursorToLineBeginning h :: Handle
h = Handle -> String -> IO ()
hPutStr Handle
h String
clearFromCursorToLineBeginningCode
hClearLine :: Handle -> IO ()
hClearLine h :: Handle
h = Handle -> String -> IO ()
hPutStr Handle
h String
clearLineCode
hScrollPageUp :: Handle -> Int -> IO ()
hScrollPageUp h :: Handle
h n :: 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 h :: Handle
h n :: Int
n = Handle -> String -> IO ()
hPutStr Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
scrollPageDownCode Int
n
hSetSGR :: Handle -> [SGR] -> IO ()
hSetSGR h :: Handle
h sgrs :: [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 h :: Handle
h = Handle -> String -> IO ()
hPutStr Handle
h String
hideCursorCode
hShowCursor :: Handle -> IO ()
hShowCursor h :: Handle
h = Handle -> String -> IO ()
hPutStr Handle
h String
showCursorCode
hSetTitle :: Handle -> String -> IO ()
hSetTitle h :: Handle
h title :: 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 h :: 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 (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 "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 "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 h :: 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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Handle -> IO Bool
hSupportsANSI Handle
h)
getReportedCursorPosition :: IO String
getReportedCursorPosition = 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
$ \_ -> do
Handle -> Bool -> IO ()
hSetEcho Handle
stdin Bool
False
String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "" (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 500000 IO String
get
where
get :: IO String
get = do
Char
c <- IO Char
getChar
if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\ESC'
then String -> IO String
get' [Char
c]
else String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return [Char
c]
get' :: String -> IO String
get' s :: String
s = do
Char
c <- IO Char
getChar
if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= 'R'
then String -> IO String
get' (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
s)
else String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (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
s)
hGetCursorPosition :: Handle -> IO (Maybe (Int, Int))
hGetCursorPosition h :: Handle
h = ((Int, Int) -> (Int, Int)) -> Maybe (Int, Int) -> Maybe (Int, Int)
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 (row :: a
row, col :: b
col) = (a
row a -> a -> a
forall a. Num a => a -> a -> a
- 1, b
col b -> b -> b
forall a. Num a => a -> a -> a
- 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
$ \_ -> do
Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdin BufferMode
NoBuffering
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 (m :: * -> *) a. Monad m => a -> m a
return Maybe (Int, Int)
forall a. Maybe a
Nothing
[((row :: Int
row, col :: Int
col),_)] -> Maybe (Int, Int) -> IO (Maybe (Int, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return (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)
(_:_) -> Maybe (Int, Int) -> IO (Maybe (Int, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Int, Int)
forall a. Maybe a
Nothing