Terminal.hs

{-# LANGUAGE NoImplicitPrelude        #-}
{-# LANGUAGE OverloadedStrings        #-}

{-|
Module      : System.Terminal
License     : BSD-3-Clause

The module of this name differs as between Windows and non-Windows builds. This
is the Windows version.
-}

module System.Terminal
  ( getTerminalWidth
  , hIsTerminalDeviceOrMinTTY
  ) where

import           Foreign.Marshal.Alloc ( allocaBytes )
import           Foreign.Ptr ( Ptr )
import           Foreign.Storable ( peekByteOff )
import           Stack.Prelude
import           System.IO ( hGetContents )
import           System.Process
                   ( StdStream (..), createProcess, shell, std_err, std_in
                   , std_out, waitForProcess
                   )
import           System.Win32 ( isMinTTYHandle, withHandleToHANDLE )

type HANDLE = Ptr ()

data CONSOLE_SCREEN_BUFFER_INFO

sizeCONSOLE_SCREEN_BUFFER_INFO :: Int
sizeCONSOLE_SCREEN_BUFFER_INFO = 22

posCONSOLE_SCREEN_BUFFER_INFO_srWindow :: Int
posCONSOLE_SCREEN_BUFFER_INFO_srWindow = 10 -- 4 x Word16 Left,Top,Right,Bottom

c_STD_OUTPUT_HANDLE :: Int
c_STD_OUTPUT_HANDLE = -11

foreign import ccall unsafe "windows.h GetConsoleScreenBufferInfo"
  c_GetConsoleScreenBufferInfo :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO Bool

foreign import ccall unsafe "windows.h GetStdHandle"
  c_GetStdHandle :: Int -> IO HANDLE

-- | If available, yields the width of the terminal.
getTerminalWidth :: IO (Maybe Int)
getTerminalWidth = do
  hdl <- c_GetStdHandle c_STD_OUTPUT_HANDLE
  allocaBytes sizeCONSOLE_SCREEN_BUFFER_INFO $ \p -> do
    b <- c_GetConsoleScreenBufferInfo hdl p
    if not b
      then do -- This could happen on Cygwin or MSYS
        let stty = (shell "stty size") {
              std_in  = UseHandle stdin
            , std_out = CreatePipe
            , std_err = CreatePipe
            }
        (_, mbStdout, _, rStty) <- createProcess stty
        waitForProcess rStty >>= \case
          ExitFailure _ -> pure Nothing
          ExitSuccess ->
            maybe (pure Nothing)
                  (\hSize -> do
                      sizeStr <- hGetContents hSize
                      case map readMaybe $ words sizeStr :: [Maybe Int] of
                        [Just _r, Just c] -> pure $ Just c
                        _ -> pure Nothing
                  )
                  mbStdout
      else do
        [left,_top,right,_bottom] <- forM [0..3] $ \i -> do
          v <- peekByteOff p (i * 2 + posCONSOLE_SCREEN_BUFFER_INFO_srWindow)
          pure $ fromIntegral (v :: Word16)
        pure $ Just (1 + right - left)

-- | hIsTerminaDevice does not recognise handles to mintty terminals as terminal
-- devices, but isMinTTYHandle does.
hIsTerminalDeviceOrMinTTY :: MonadIO m => Handle -> m Bool
hIsTerminalDeviceOrMinTTY h = do
  isTD <- hIsTerminalDevice h
  if isTD
    then pure True
    else liftIO $ withHandleToHANDLE h isMinTTYHandle