main/SysTools/Terminal.hs

    {-# LANGUAGE CPP #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    module 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