    {-# LANGUAGE Trustworthy #-}

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

    import Data.List ( uncons )
    import Data.Maybe ( fromMaybe, isJust, mapMaybe )
    import System.Environment ( lookupEnv )
    import System.IO ( Handle, hIsTerminalDevice, hIsWritable )
    import System.IO.Unsafe ( unsafePerformIO )
    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
    Underlining =
      String -> IO String
    forall a. HasCallStack => String -> a
    error String
    "getReportedLayerColor does not support underlining."
    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
        c <- IO Char
    getChar
        if c == h
          then getStart hs (c:r) -- Try to get the rest of the start characters

          else pure $ reverse (c: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
        c <- IO Char
    getChar
        case lookup c 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
        c <- IO Char
    getChar
        if c /= e
          then getRest (c:r) -- Continue building the list, with the original end

                             -- characters.

          else getEnd es (c: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
    isNotDumb) (Bool -> Bool) -> IO Bool -> IO Bool
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Handle -> IO Bool
    hIsTerminalDevice Handle
    h

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

    hSupportsANSIColor :: Handle -> IO Bool
    hSupportsANSIColor :: Handle -> IO Bool
    hSupportsANSIColor Handle
    h = (Bool -> Bool -> Bool
    || Bool
    isEmacsTerm) (Bool -> Bool) -> IO Bool -> IO Bool
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Handle -> IO Bool
    hSupportsANSI Handle
    h
     where
      isEmacsTerm :: Bool
    isEmacsTerm = Bool
    insideEmacs Bool -> Bool -> Bool
    && Bool
    isDumb
      isDumb :: Bool
    isDumb = Bool -> Bool
    not Bool
    isNotDumb

    -- | This function assumes that once it is first established whether or not the

    -- TERM environment variable exists with contents dumb, that will not change.

    -- This approach is taken because the use of C function setenv() in one thread

    -- can cause other threads calling C function getenv() to crash. On Unix-like

    -- operating systems, System.Environment.lookupEnv is implemented using C

    -- function getenv().

    isNotDumb :: Bool
    isNotDumb :: Bool
    isNotDumb = IO (Maybe String) -> Maybe String
    forall a. IO a -> a
    unsafePerformIO (String -> IO (Maybe String)
    lookupEnv String
    "TERM") Maybe String -> Maybe String -> Bool
    forall a. Eq a => a -> a -> Bool
    /= String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "dumb"

    {-# NOINLINE isNotDumb #-}

    -- | This function assumes that once it is first established whether or not the

    -- INSIDE_EMACS environment variable exists, that will not change. This approach

    -- is taken because the use of C function setenv() in one thread can cause other

    -- threads calling C function getenv() to crash. On Unix-like operating systems,

    -- System.Environment.lookupEnv is implemented using C function getenv().

    insideEmacs :: Bool
    insideEmacs :: Bool
    insideEmacs = Maybe String -> Bool
    forall a. Maybe a -> Bool
    isJust (Maybe String -> Bool) -> Maybe String -> Bool
    forall a b. (a -> b) -> a -> b
    $ IO (Maybe String) -> Maybe String
    forall a. IO a -> a
    unsafePerformIO (String -> IO (Maybe String)
    lookupEnv String
    "INSIDE_EMACS")

    {-# NOINLINE insideEmacs #-}