content: {-# LANGUAGE Safe #-}
  
  module System.Console.ANSI.Internal
    ( getReportedCursorPosition
    , getReportedLayerColor
    , hNowSupportsANSI
    , hSupportsANSI
    , hSupportsANSIColor
    ) where
  
  import Control.Exception ( IOException, SomeException, catch, try )
  import Data.Bits ( (.&.), (.|.) )
  import Data.Maybe ( mapMaybe )
  import System.Environment ( getEnvironment, lookupEnv )
  import System.IO ( Handle, hIsTerminalDevice, hIsWritable, stdin )
  import System.Console.ANSI.Types ( ConsoleLayer )
  
  -- Provided by the ansi-terminal package
  import System.Console.ANSI.Windows.Foreign
           ( INPUT_RECORD (..), INPUT_RECORD_EVENT (..), KEY_EVENT_RECORD (..)
           , cWcharsToChars, eNABLE_VIRTUAL_TERMINAL_PROCESSING
           , getConsoleMode, getNumberOfConsoleInputEvents, iNVALID_HANDLE_VALUE
           , nullHANDLE, readConsoleInput, setConsoleMode, unicodeAsciiChar
           )
  import System.Console.ANSI.Windows.Win32.MinTTY ( isMinTTYHandle )
  import System.Console.ANSI.Windows.Win32.Types
           ( DWORD, HANDLE, withHandleToHANDLE )
  
  getReportedCursorPosition :: IO String
  getReportedCursorPosition = getReported
  
  getReportedLayerColor :: ConsoleLayer -> IO String
  getReportedLayerColor _ = getReported
  
  getReported :: IO String
  getReported = catch getReported' getReportedExceptionHandler
   where
    getReported' = withHandleToHANDLE stdin action
     where
      action hdl = do
        n <- getNumberOfConsoleInputEvents hdl
        if n == 0
          then pure ""
          else do
            es <- readConsoleInput hdl n
            pure $ stringFromInputEvents es
      stringFromInputEvents = cWcharsToChars . wCharsFromInputEvents
      wCharsFromInputEvents = mapMaybe wCharFromInputEvent
      wCharFromInputEvent e = if isKeyEvent && isKeyDown
        then Just (unicodeAsciiChar $ keyEventChar keyEventRecord)
        else Nothing
       where
        eventType = inputEventType e
        eventRecord = inputEvent e
        isKeyEvent = eventType == 1
        keyEventRecord = case eventRecord of
          InputKeyEvent keyEventRecord' -> keyEventRecord'
          _ -> error "Unexpected input event, given input event type."
        isKeyDown = keyEventKeyDown keyEventRecord
  
  getReportedExceptionHandler :: IOException -> IO a
  getReportedExceptionHandler e = error msg
   where
    msg = "Error: " ++ show e ++ "\nThis error may be avoided by using a " ++
          "console based on the Windows' Console API, such as Command Prompt " ++
          "or PowerShell."
  
  hSupportsANSI :: Handle -> IO Bool
  hSupportsANSI = hSupportsANSI' False
  
  hNowSupportsANSI :: Handle -> IO Bool
  hNowSupportsANSI = hSupportsANSI' True
  
  hSupportsANSI' :: Bool -> Handle -> IO Bool
  hSupportsANSI' tryToEnable handle = do
    isWritable <- hIsWritable handle
    if isWritable
      then withHandleToHANDLE handle $ withHANDLE
        (pure False) -- Invalid handle or no handle
        ( \h -> do
            tryMode <- try (getConsoleMode h) :: IO (Either SomeException DWORD)
            case tryMode of
              Left _ -> isMinTTYHandle h -- No ConHost mode
              Right mode -> do
                let isVTEnabled = mode .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING /= 0
                    isNotDumb = (/= Just "dumb") <$> lookupEnv "TERM"
                isTDNotDumb <- (&&) <$> hIsTerminalDevice handle <*> isNotDumb
                if isTDNotDumb && not isVTEnabled && tryToEnable
                  then do
                    let mode' = mode .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING
                    trySetMode <- try (setConsoleMode h mode')
                      :: IO (Either SomeException ())
                    case trySetMode of
                      Left _ -> pure False -- Can't enable VT processing
                      Right () -> pure True -- VT processing enabled
                  else pure $ isTDNotDumb && isVTEnabled
        )
      else pure False
  
  -- | This function applies another to the Windows handle, if the handle is
  -- valid. If it is invalid, the specified default action is returned.
  withHANDLE :: IO a -> (HANDLE -> IO a) -> HANDLE -> IO a
  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
  