#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 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 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 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 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 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 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 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 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 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 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 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 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 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 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
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO Bool
hIsTerminalDevice Handle
h 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 = (forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just String
"dumb") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"TERM" 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 =
  forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO Bool
hIsWritable Handle
h 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]" forall a. [a] -> [a] -> [a]
++ String
pS 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
_ [] = 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.

  forall a. a -> Maybe a -> a
fromMaybe String
"" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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' = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe 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 forall a. Eq a => a -> a -> Bool
== Char
h
      then String -> String -> IO String
getStart String
hs (Char
cforall a. a -> [a] -> [a]
:String
r) -- Try to get the rest of the start characters

      else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse (Char
cforall 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 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
cforall 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
cforall 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse String
r
  getEnd (Char
e:String
es) String
r = do
    Char
c <- IO Char
getChar
    if Char
c forall a. Eq a => a -> a -> Bool
/= Char
e
      then String -> IO String
getRest (Char
cforall a. a -> [a] -> [a]
:String
r) -- Continue building the list, with the original end

                         -- characters.

      else String -> String -> IO String
getEnd String
es (Char
cforall 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a} {b}. (Num a, Num b) => (a, b) -> (a, b)
to0base 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 forall a. Num a => a -> a -> a
- a
1, b
col forall a. Num a => a -> a -> a
- b
1)
  getCursorPosition' :: IO (Maybe (Int, Int))
getCursorPosition' = do
    String
input <- 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) 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

      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) 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 forall a. ReadP a -> ReadS a
readP_to_S ReadP (Int, Int)
cursorPosition String
input of
      [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      [((Int
row, Int
col),String
_)] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Int
row, Int
col)
      (((Int, Int), String)
_:[((Int, Int), String)]
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  clearStdin :: IO ()
clearStdin = do
    Bool
isReady <- Handle -> IO Bool
hReady Handle
stdin
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isReady 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 <- 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) 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

    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) 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 forall a. ReadP a -> ReadS a
readP_to_S (ConsoleLayer -> ReadP (RGB Word16)
layerColor ConsoleLayer
layer) String
input of
      [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      [(RGB Word16
col, String
_)] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just RGB Word16
col
      ((RGB Word16, String)
_:[(RGB Word16, String)]
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
 where
  clearStdin :: IO ()
clearStdin = do
    Bool
isReady <- Handle -> IO Bool
hReady Handle
stdin
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isReady forall a b. (a -> b) -> a -> b
$ do
      Char
_ <-IO Char
getChar
      IO ()
clearStdin