#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)
#if MIN_VERSION_base(4,8,0)
import Data.List (uncons)
#endif
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
#if !MIN_VERSION_base(4,8,0)
   where
     uncons :: [a] -> Maybe (a, [a])
     uncons []     = Nothing
     uncons (x:xs) = Just (x, xs)
#endif

  -- 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      [((Int
row, Int
col),String
_)] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Int
row, Int
col)
      (((Int, Int), String)
_:[((Int, Int), String)]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      [(RGB Word16
col, String
_)] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just RGB Word16
col
      ((RGB Word16, String)
_:[(RGB Word16, String)]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return 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