From 660b10b2b60ecebfff75d9a75d2fd611cf2ede3a Mon Sep 17 00:00:00 2001
From: Mike Pilgrem <mpilgrem@users.noreply.github.com>
Date: Sun, 21 Apr 2024 22:48:57 +0100
Subject: [PATCH] Fix #166 On Unix-like OS, use `unsafePerformIO (lookupEnv
 <env_var>)`

---
 ansi-terminal/src/System/Console/ANSI.hs      |  7 +---
 .../unix/System/Console/ANSI/Internal.hs      | 36 ++++++++++++++++---
 .../win/System/Console/ANSI/Internal.hs       | 10 +++++-
 3 files changed, 42 insertions(+), 11 deletions(-)

diff --git a/ansi-terminal/src/System/Console/ANSI.hs b/ansi-terminal/src/System/Console/ANSI.hs
index 90bd12a..042d459 100644
--- a/ansi-terminal/src/System/Console/ANSI.hs
+++ b/ansi-terminal/src/System/Console/ANSI.hs
@@ -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
@@ -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
diff --git a/ansi-terminal/unix/System/Console/ANSI/Internal.hs b/ansi-terminal/unix/System/Console/ANSI/Internal.hs
index 4dee6ba..56b5088 100644
--- a/ansi-terminal/unix/System/Console/ANSI/Internal.hs
+++ b/ansi-terminal/unix/System/Console/ANSI/Internal.hs
@@ -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 (..) )
@@ -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 #-}
diff --git a/ansi-terminal/win/System/Console/ANSI/Internal.hs b/ansi-terminal/win/System/Console/ANSI/Internal.hs
index 76de6c2..dd80c2d 100644
--- a/ansi-terminal/win/System/Console/ANSI/Internal.hs
+++ b/ansi-terminal/win/System/Console/ANSI/Internal.hs
@@ -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 )
 
@@ -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