content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  module Eta.SysTools.Terminal (stderrSupportsAnsiColors) where
  
  #if defined MIN_VERSION_terminfo
  import Control.Exception (catch)
  import Data.Maybe (fromMaybe)
  import System.Console.Terminfo (SetupTermError, Terminal, getCapability,
                                  setupTermFromEnv, termColors)
  import System.Posix (queryTerminal, stdError)
  #elif defined mingw32_HOST_OS
  import Control.Exception (catch, try)
  import Data.Bits ((.|.), (.&.))
  import Data.List (isInfixOf, isPrefixOf, isSuffixOf)
  import Foreign (FunPtr, Ptr, allocaBytes, castPtrToFunPtr,
                  peek, plusPtr, sizeOf, with)
  import Foreign.C (CInt(..), CWchar, peekCWStringLen)
  import qualified Graphics.Win32 as Win32
  import qualified System.Win32 as Win32
  #endif
  
  #if defined mingw32_HOST_OS && !defined WINAPI
  # if defined i386_HOST_ARCH
  #  define WINAPI stdcall
  # elif defined x86_64_HOST_ARCH
  #  define WINAPI ccall
  # else
  #  error unknown architecture
  # endif
  #endif
  
  -- | Check if ANSI escape sequences can be used to control color in stderr.
  stderrSupportsAnsiColors :: IO Bool
  stderrSupportsAnsiColors = do
  #if defined MIN_VERSION_terminfo
    queryTerminal stdError `andM` do
      (termSupportsColors <$> setupTermFromEnv)
        `catch` \ (_ :: SetupTermError) ->
          pure False
  
    where
  
      andM :: Monad m => m Bool -> m Bool -> m Bool
      andM mx my = do
        x <- mx
        if x
          then my
          else pure x
  
      termSupportsColors :: Terminal -> Bool
      termSupportsColors term = fromMaybe 0 (getCapability term termColors) > 0
  
  #elif defined mingw32_HOST_OS
    h <- Win32.getStdHandle Win32.sTD_ERROR_HANDLE
           `catch` \ (_ :: IOError) ->
             pure Win32.nullHANDLE
    if h == Win32.nullHANDLE
      then pure False
      else do
        eMode <- try (getConsoleMode h)
        case eMode of
          Left (_ :: IOError) -> queryCygwinTerminal h
          Right mode
            | modeHasVTP mode -> pure True
            | otherwise       -> enableVTP h mode
  
    where
  
      queryCygwinTerminal :: Win32.HANDLE -> IO Bool
      queryCygwinTerminal h = do
          fileType <- Win32.getFileType h
          if fileType /= Win32.fILE_TYPE_PIPE
            then pure False
            else do
              fn <- getFileNameByHandle h
              pure (("\\cygwin-" `isPrefixOf` fn || "\\msys-" `isPrefixOf` fn) &&
                    "-pty" `isInfixOf` fn &&
                    "-master" `isSuffixOf` fn)
        `catch` \ (_ :: IOError) ->
          pure False
  
      enableVTP :: Win32.HANDLE -> Win32.DWORD -> IO Bool
      enableVTP h mode = do
          setConsoleMode h (modeAddVTP mode)
          modeHasVTP <$> getConsoleMode h
        `catch` \ (_ :: IOError) ->
          pure False
  
      modeHasVTP :: Win32.DWORD -> Bool
      modeHasVTP mode = mode .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING /= 0
  
      modeAddVTP :: Win32.DWORD -> Win32.DWORD
      modeAddVTP mode = mode .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING
  
  eNABLE_VIRTUAL_TERMINAL_PROCESSING :: Win32.DWORD
  eNABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004
  
  getConsoleMode :: Win32.HANDLE -> IO Win32.DWORD
  getConsoleMode h = with 64 $ \ mode -> do
    Win32.failIfFalse_ "GetConsoleMode" (c_GetConsoleMode h mode)
    peek mode
  
  setConsoleMode :: Win32.HANDLE -> Win32.DWORD -> IO ()
  setConsoleMode h mode = do
    Win32.failIfFalse_ "SetConsoleMode" (c_SetConsoleMode h mode)
  
  foreign import WINAPI unsafe "windows.h GetConsoleMode" c_GetConsoleMode
    :: Win32.HANDLE -> Ptr Win32.DWORD -> IO Win32.BOOL
  
  foreign import WINAPI unsafe "windows.h SetConsoleMode" c_SetConsoleMode
    :: Win32.HANDLE -> Win32.DWORD -> IO Win32.BOOL
  
  fileNameInfo :: CInt
  fileNameInfo = 2
  
  mAX_PATH :: Num a => a
  mAX_PATH = 260
  
  getFileNameByHandle :: Win32.HANDLE -> IO String
  getFileNameByHandle h = do
    let sizeOfDWORD = sizeOf (undefined :: Win32.DWORD)
    let sizeOfWchar = sizeOf (undefined :: CWchar)
    -- note: implicitly assuming that DWORD has stronger alignment than wchar_t
    let bufSize = sizeOfDWORD + mAX_PATH * sizeOfWchar
    allocaBytes bufSize $ \ buf -> do
      getFileInformationByHandleEx h fileNameInfo buf (fromIntegral bufSize)
      len :: Win32.DWORD <- peek buf
      let len' = fromIntegral len `div` sizeOfWchar
      peekCWStringLen (buf `plusPtr` sizeOfDWORD, min len' mAX_PATH)
  
  getFileInformationByHandleEx
    :: Win32.HANDLE -> CInt -> Ptr a -> Win32.DWORD -> IO ()
  getFileInformationByHandleEx h cls buf bufSize = do
    lib <- Win32.getModuleHandle (Just "kernel32.dll")
    ptr <- Win32.getProcAddress lib "GetFileInformationByHandleEx"
    let c_GetFileInformationByHandleEx =
          mk_GetFileInformationByHandleEx (castPtrToFunPtr ptr)
    Win32.failIfFalse_ "getFileInformationByHandleEx"
      (c_GetFileInformationByHandleEx h cls buf bufSize)
  
  type F_GetFileInformationByHandleEx a =
    Win32.HANDLE -> CInt -> Ptr a -> Win32.DWORD -> IO Win32.BOOL
  
  foreign import WINAPI "dynamic"
    mk_GetFileInformationByHandleEx
    :: FunPtr (F_GetFileInformationByHandleEx a)
    -> F_GetFileInformationByHandleEx a
  
  #else
     pure False
  #endif
  