Skip to content

Commit

Permalink
Fix #166 On Unix-like OS, use unsafePerformIO (lookupEnv <env_var>)
Browse files Browse the repository at this point in the history
  • Loading branch information
mpilgrem committed Apr 23, 2024
1 parent 6bcbe9f commit 660b10b
Show file tree
Hide file tree
Showing 3 changed files with 42 additions and 11 deletions.
7 changes: 1 addition & 6 deletions ansi-terminal/src/System/Console/ANSI.hs
Original file line number Diff line number Diff line change
Expand Up @@ -368,7 +368,6 @@ import Control.Monad ( when, void )
import Data.Char ( digitToInt, isDigit, isHexDigit )
import Data.Colour.SRGB ( RGB (..) )
import Data.Word ( Word16 )
import System.Environment ( getEnvironment )
import System.IO
( BufferMode (..), Handle, hFlush, hGetBuffering, hGetEcho, hPutStr
, hReady, hSetBuffering, hSetEcho, stdin, stdout
Expand Down Expand Up @@ -638,11 +637,7 @@ hNowSupportsANSI = Internal.hNowSupportsANSI
--
-- @since 0.9
hSupportsANSIColor :: Handle -> IO Bool
hSupportsANSIColor h = (||) <$> hSupportsANSI h <*> isEmacsTerm
where
isEmacsTerm = (\env -> insideEmacs env && isDumb env) <$> getEnvironment
insideEmacs = any (\(k, _) -> k == "INSIDE_EMACS")
isDumb env = Just "dumb" == lookup "TERM" env
hSupportsANSIColor = Internal.hSupportsANSIColor

-- | Use heuristics to determine whether a given handle will support \'ANSI\'
-- control characters in output. The function is consistent with
Expand Down
36 changes: 32 additions & 4 deletions ansi-terminal/unix/System/Console/ANSI/Internal.hs
Original file line number Diff line number Diff line change
@@ -1,16 +1,18 @@
{-# LANGUAGE Safe #-}
{-# LANGUAGE Trustworthy #-}

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

import Data.List ( uncons )
import Data.Maybe ( fromMaybe, mapMaybe )
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 (..) )
Expand Down Expand Up @@ -72,8 +74,34 @@ hSupportsANSI :: Handle -> IO Bool
-- (https://github.com/hspec/hspec/commit/d932f03317e0e2bd08c85b23903fb8616ae642bd)
hSupportsANSI h = (&&) <$> hIsWritable h <*> hSupportsANSI'
where
hSupportsANSI' = (&&) <$> hIsTerminalDevice h <*> isNotDumb
isNotDumb = (/= Just "dumb") <$> lookupEnv "TERM"
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 #-}
10 changes: 9 additions & 1 deletion ansi-terminal/win/System/Console/ANSI/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -5,12 +5,13 @@ module System.Console.ANSI.Internal
, getReportedLayerColor
, hNowSupportsANSI
, hSupportsANSI
, hSupportsANSIColor
) where

import Control.Exception ( IOException, SomeException, catch, try )
import Data.Bits ( (.&.), (.|.) )
import Data.Maybe ( mapMaybe )
import System.Environment ( lookupEnv )
import System.Environment ( getEnvironment, lookupEnv )
import System.IO ( Handle, hIsTerminalDevice, hIsWritable, stdin )
import System.Console.ANSI.Types ( ConsoleLayer )

Expand Down Expand Up @@ -103,3 +104,10 @@ withHANDLE invalid action h =
if h == iNVALID_HANDLE_VALUE || h == nullHANDLE
then invalid -- Invalid handle or no handle
else action h

hSupportsANSIColor :: Handle -> IO Bool
hSupportsANSIColor h = (||) <$> hSupportsANSI h <*> isEmacsTerm
where
isEmacsTerm = (\env -> insideEmacs env && isDumb env) <$> getEnvironment
insideEmacs = any (\(k, _) -> k == "INSIDE_EMACS")
isDumb env = Just "dumb" == lookup "TERM" env

0 comments on commit 660b10b

Please sign in to comment.