Internal.hs

{-# 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 = getReport "\ESC[" ["R"]

getReportedLayerColor :: ConsoleLayer -> IO String
getReportedLayerColor Underlining =
  error "getReportedLayerColor does not support underlining."
getReportedLayerColor layer =
  getReport ("\ESC]" ++ pS ++ ";rgb:") ["\BEL", "\ESC\\"]
 where
   pS = case layer of
          Foreground -> "10"
          Background -> "11"

getReport :: String -> [String] -> IO String
getReport _ [] = error "getReport requires a list of terminating sequences."
getReport startChars 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.
  fromMaybe "" <$> timeout 500000 (getStart startChars "") -- 500 milliseconds
 where
  endChars' = mapMaybe uncons 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 "" r = getRest r
  getStart (h:hs) r = do
    c <- 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 r = do
    c <- getChar
    case lookup c endChars' of
      Nothing -> getRest (c:r) -- Continue building the list, until the first of
                               -- the end characters is obtained.
      Just es -> getEnd es (c:r) -- Try to get the rest of the end characters.

  getEnd :: String -> String -> IO String
  getEnd "" r = pure $ reverse r
  getEnd (e:es) r = do
    c <- 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 h = (&&) <$> hIsWritable h <*> hSupportsANSI'
 where
  hSupportsANSI' = (&& isNotDumb) <$> hIsTerminalDevice h

hNowSupportsANSI :: Handle -> IO Bool
hNowSupportsANSI = hSupportsANSI

hSupportsANSIColor :: Handle -> IO Bool
hSupportsANSIColor h = (|| isEmacsTerm) <$> hSupportsANSI h
 where
  isEmacsTerm = insideEmacs && isDumb
  isDumb = not 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 = unsafePerformIO (lookupEnv "TERM") /= Just "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 = isJust $ unsafePerformIO (lookupEnv "INSIDE_EMACS")

{-# NOINLINE insideEmacs #-}