{-# LANGUAGE Safe #-}

module System.Console.ANSI.Internal
  ( getReportedCursorPosition
  , getReportedLayerColor
  , hSupportsANSI
  , hNowSupportsANSI
  ) where

import Data.List ( uncons )
import Data.Maybe ( fromMaybe, mapMaybe )
import System.Environment ( lookupEnv )
import System.IO ( Handle, hIsTerminalDevice, hIsWritable )
import System.Timeout ( timeout )

import System.Console.ANSI.Types ( ConsoleLayer (..) )

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

getReportedLayerColor :: ConsoleLayer -> IO String
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.


hSupportsANSI :: Handle -> IO Bool
-- 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
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
<*> IO Bool
hSupportsANSI'
 where
  hSupportsANSI' :: IO Bool
hSupportsANSI' = 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
  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) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"TERM"

hNowSupportsANSI :: Handle -> IO Bool
hNowSupportsANSI :: Handle -> IO Bool
hNowSupportsANSI = Handle -> IO Bool
hSupportsANSI