#include "Common-Safe-Haskell.hs"
{-# OPTIONS_HADDOCK hide #-}

module System.Console.ANSI.Unix
  (
-- This file contains code that is common to modules

-- System.Console.ANSI.Unix and System.Console.ANSI.Windows, namely the module

-- exports and the associated Haddock documentation.

#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

-- This file contains code that is common to modules System.Console.ANSI.Unix,

-- System.Console.ANSI.Windows and System.Console.ANSI.Windows.Emulator, such as

-- type signatures and the definition of functions specific to stdout in terms

-- of the corresponding more general functions, including the related Haddock

-- documentation.

#include "Common-Include.hs"
-- This file contains code that is common save that different code is required

-- in the case of the module System.Console.ANSI.Windows.Emulator (see the file

-- Common-Include-Emulator.hs in respect of the latter).

#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

-- (See Common-Include.hs for Haddock documentation)

--

-- Borrowed from an HSpec patch by Simon Hengel

-- (https://github.com/hspec/hspec/commit/d932f03317e0e2bd08c85b23903fb8616ae642bd)

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
  -- cannot use lookupEnv since it only appeared in GHC 7.6

  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)

-- (See Common-Include.hs for Haddock documentation)

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

-- (See Common-Include.hs for Haddock documentation)

getReportedCursorPosition :: IO String
getReportedCursorPosition = String -> [String] -> IO String
getReport String
"\ESC[" [String
"R"]

-- getReportedLayerColor :: ConsoleLayer -> IO String

-- (See Common-Include.hs for Haddock documentation)

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
  -- If, unexpectedly, no data is available on the console input stream then

  -- the timeout will prevent the getChar blocking. For consistency with the

  -- Windows equivalent, returns "" if the expected information is unavailable.

  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
"") -- 500 milliseconds

 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

  -- The list is built in reverse order, in order to avoid O(n^2) complexity.

  -- So, getReport yields the reversed built list.


  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) -- Try to get the rest of the start characters

      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) -- If the first character(s) are not the

                                  -- expected start then give up. This provides

                                  -- a modicom of protection against unexpected

                                  -- data in the input stream.

  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) -- Continue building the list, until the first of

                               -- the end characters is obtained.

      Just String
es -> String -> String -> IO String
getEnd String
es (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
r) -- Try to get the rest of the end characters.


  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) -- Continue building the list, with the original end

                         -- characters.

      else String -> String -> IO String
getEnd String
es (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
r) -- Continue building the list, checking against the

                           -- remaining end characters.


-- hGetCursorPosition :: Handle -> IO (Maybe (Int, Int))

-- (See Common-Include.hs for Haddock documentation)

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
      -- set no buffering (if 'no buffering' is not already set, the contents of

      -- the buffer will be discarded, so this needs to be done before the

      -- cursor positon is emitted)

      Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdin BufferMode
NoBuffering
      -- ensure that echoing is off

      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 -- ensure the report cursor position code is sent to the

                 -- operating system

        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 -> IO (Maybe (Colour Word16))

-- (See Common-Include.hs for Haddock documentation)

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
    -- set no buffering (if 'no buffering' is not already set, the contents of

    -- the buffer will be discarded, so this needs to be done before the

    -- cursor positon is emitted)

    Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdin BufferMode
NoBuffering
    -- ensure that echoing is off

    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 -- ensure the report cursor position code is sent to the

               -- operating system

      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