#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 Data.Maybe (fromMaybe)
import Control.Exception.Base (bracket)
import Control.Monad (when)
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
import System.Console.ANSI.Types

-- 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

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 = 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 IO String
get -- 500 milliseconds

 where
  get :: IO String
get = do
    Char
c <- IO Char
getChar
    if Char
c forall a. Eq a => a -> a -> Bool
== Char
'\ESC'
      then String -> IO String
get' [Char
c]
      else forall (m :: * -> *) a. Monad m => a -> m a
return [Char
c] -- If the first character is not the expected \ESC then

                      -- give up. This provides a modicom of protection against

                      -- unexpected data in the input stream.

  get' :: String -> IO String
get' String
s = do
    Char
c <- IO Char
getChar
    if Char
c forall a. Eq a => a -> a -> Bool
/= Char
'R'
      then String -> IO String
get' (Char
cforall a. a -> [a] -> [a]
:String
s) -- Continue building the list, until the expected 'R'

                      -- character is obtained. Build the list in reverse order,

                      -- in order to avoid O(n^2) complexity.

      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
s) -- Reverse the order of the built list.


-- 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