From 20d0184854b20f87963d549602b45682d5f6d5bd Mon Sep 17 00:00:00 2001 From: Ben Franksen Date: Sat, 11 Mar 2023 19:59:41 +0100 Subject: [PATCH 1/2] Windows: depend on WIN32 package, implement and export hSize WIN32 supports getConsoleScreenBufferInfo since version 2.6.2.0 and withHandleToHANDLE that supports console handles since 2.13.2.0. The fallback for Cygwin or MSYS shells now passes the given handle to the std_in of the "stty size" command. Since size is now implemented as `hSize stdout`, it works correctly even if stdin is redirected. --- README.markdown | 41 +++++++++++ src/System/Console/Terminal/Size.hs | 13 ++-- src/System/Console/Terminal/Windows.hs | 95 +++++++++++--------------- terminal-size.cabal | 3 +- test.hs | 27 ++++++++ 5 files changed, 118 insertions(+), 61 deletions(-) create mode 100644 test.hs diff --git a/README.markdown b/README.markdown index c0f57ee..6be8f88 100644 --- a/README.markdown +++ b/README.markdown @@ -14,3 +14,44 @@ Usage >>> size Just (Window {height = 60, width = 112}) ``` + +Test +---- + +Compile test.hs and run it in a terminal. Here is what I get on Linux: + +``` +> ghc test.hs +> ./test +With redirected stdin + hSize stdin = Nothing + hSize stdout = Just (Window {height = 19, width = 87}) + hSize stderr = Just (Window {height = 19, width = 87}) +With redirected stdout + hSize stdin = Just (Window {height = 19, width = 87}) + hSize stdout = Nothing + hSize stderr = Just (Window {height = 19, width = 87}) +With redirected stderr + hSize stdin = Just (Window {height = 19, width = 87}) + hSize stdout = Just (Window {height = 19, width = 87}) + hSize stderr = Nothing +``` + +On MINGW/MSYS the output is the same. + +On Windows with cmd.exe I get + +``` +With redirected stdin + hSize stdin = Nothing + hSize stdout = Just (Window {height = 40, width = 164}) + hSize stderr = Just (Window {height = 40, width = 164}) +With redirected stdout + hSize stdin = Nothing + hSize stdout = Nothing + hSize stderr = Just (Window {height = 40, width = 164}) +With redirected stderr + hSize stdin = Nothing + hSize stdout = Just (Window {height = 40, width = 164}) + hSize stderr = Nothing +``` diff --git a/src/System/Console/Terminal/Size.hs b/src/System/Console/Terminal/Size.hs index ba6162d..a11fd3b 100644 --- a/src/System/Console/Terminal/Size.hs +++ b/src/System/Console/Terminal/Size.hs @@ -9,8 +9,8 @@ module System.Console.Terminal.Size , size #if !defined(mingw32_HOST_OS) , fdSize - , hSize #endif + , hSize ) where import System.Console.Terminal.Common @@ -19,8 +19,8 @@ import qualified System.Console.Terminal.Windows as Host #else import qualified System.Console.Terminal.Posix as Host import System.Posix.Types(Fd) -import System.IO(Handle) #endif +import System.IO(Handle) -- | Get terminal window width and height for @stdout@. @@ -45,9 +45,13 @@ size = Host.size -- Nothing fdSize :: Integral n => Fd -> IO (Maybe (Window n)) fdSize = Host.fdSize +#endif --- | /Not available on Windows:/ --- Same as 'fdSize', but takes 'Handle' instead of 'Fd' (file descriptor). +-- | Same as 'fdSize', but takes 'Handle' instead of 'Fd' (file descriptor). +-- +-- Note that on Windows with shells that use the native console API (cmd.exe, +-- PowerShell) this works only for output handles like 'stdout' and 'stderr'; +-- for input handles like 'stdin' it always returns 'Nothing'. -- -- >>> import System.Console.Terminal.Size -- >>> import System.IO @@ -55,4 +59,3 @@ fdSize = Host.fdSize -- Just (Window {height = 56, width = 85}) hSize :: Integral n => Handle -> IO (Maybe (Window n)) hSize = Host.hSize -#endif diff --git a/src/System/Console/Terminal/Windows.hs b/src/System/Console/Terminal/Windows.hs index 87aa1bf..ea6ed14 100644 --- a/src/System/Console/Terminal/Windows.hs +++ b/src/System/Console/Terminal/Windows.hs @@ -1,63 +1,48 @@ - -module System.Console.Terminal.Windows(size) where +module System.Console.Terminal.Windows(size, hSize) where import System.Console.Terminal.Common -import Control.Monad -import Data.Word -import Foreign.Ptr -import Foreign.Storable -import Foreign.Marshal.Alloc import System.Exit import System.IO +import System.IO.Error (catchIOError) import System.Process - -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 :: Word32 -c_STD_OUTPUT_HANDLE = -11 - -foreign import stdcall unsafe "windows.h GetConsoleScreenBufferInfo" - c_GetConsoleScreenBufferInfo :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO Bool - -foreign import stdcall unsafe "windows.h GetStdHandle" - c_GetStdHandle :: Word32 -> IO HANDLE - +import System.Win32.Console + ( CONSOLE_SCREEN_BUFFER_INFO(srWindow) + , SMALL_RECT(..) + , getConsoleScreenBufferInfo + ) +import System.Win32.Types (HANDLE, withHandleToHANDLE) size :: Integral n => IO (Maybe (Window n)) -size = 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 - exStty <- waitForProcess rStty - case exStty of - ExitFailure _ -> return Nothing - ExitSuccess -> - maybe (return Nothing) - (\hSize -> do - sizeStr <- hGetContents hSize - let [r, c] = map read $ words sizeStr :: [Int] - return $ Just $ Window (fromIntegral r) (fromIntegral c) - ) - mbStdout - else do - [left,top,right,bottom] <- forM [0..3] $ \i -> do - v <- peekByteOff p ((i*2) + posCONSOLE_SCREEN_BUFFER_INFO_srWindow) - return $ fromIntegral (v :: Word16) - return $ Just $ Window (1+bottom-top) (1+right-left) +size = hSize stdout + +hSize :: Integral n => Handle -> IO (Maybe (Window n)) +hSize hdl = + withHandleToHANDLE hdl nativeSize + `catchIOError` \_ -> do + -- This could happen on Cygwin or MSYS + let stty = (shell "stty size") { + std_in = UseHandle hdl + , std_out = CreatePipe + , std_err = CreatePipe + } + (_, mbStdout, _, rStty) <- createProcess stty + exStty <- waitForProcess rStty + case exStty of + ExitFailure _ -> return Nothing + ExitSuccess -> + maybe (return Nothing) + (\out -> do + sizeStr <- hGetContents out + let [r, c] = map read $ words sizeStr :: [Int] + return $ Just $ Window (fromIntegral r) (fromIntegral c) + ) + mbStdout + +nativeSize :: Integral n => HANDLE -> IO (Maybe (Window n)) +nativeSize hdl = do + rect <- srWindow <$> getConsoleScreenBufferInfo hdl + return $ Just $ Window + { height = fromIntegral (1 + bottomPos rect - topPos rect) + , width = fromIntegral (1 + rightPos rect - leftPos rect) + } diff --git a/terminal-size.cabal b/terminal-size.cabal index 7c66d22..7ea4bd1 100644 --- a/terminal-size.cabal +++ b/terminal-size.cabal @@ -34,7 +34,8 @@ library ghc-prim if os(windows) build-depends: - process + process, + Win32 >= 2.13.2.0 && < 2.14 build-tools: hsc2hs diff --git a/test.hs b/test.hs new file mode 100644 index 0000000..c103bc2 --- /dev/null +++ b/test.hs @@ -0,0 +1,27 @@ +import System.Console.Terminal.Size +import System.IO +import GHC.IO.Handle +import Control.Monad +import Data.Maybe + +stdHandles = + [ (stdin, "stdin") + , (stdout, "stdout") + , (stderr, "stderr") + ] + +main = do + fh <- openFile "test.hs" ReadMode + forM_ stdHandles $ \(h, n) -> do + putStrLn $ "With redirected " ++ n + -- save handle + h_saved <- hDuplicate h + -- redirect to a file handle + hDuplicateTo fh h + -- run hSize on all three std handles + hSizes <- forM stdHandles (hSize . fst) + -- restore redirected handle + hDuplicateTo h_saved h + -- report sizes + forM_ (zip hSizes stdHandles) $ \(s, (h', n')) -> do + putStrLn $ " hSize " ++ n' ++ " = " ++ show s From ce95a98d4240939a3b9f77586008dd5cf89d85ef Mon Sep 17 00:00:00 2001 From: Ben Franksen Date: Sat, 11 Mar 2023 20:12:57 +0100 Subject: [PATCH 2/2] Add github actions to test building --- .github/workflows/build.yml | 57 ++++++++++++++++++++++++++ src/System/Console/Terminal/Windows.hs | 2 +- 2 files changed, 58 insertions(+), 1 deletion(-) create mode 100644 .github/workflows/build.yml diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml new file mode 100644 index 0000000..3b4da86 --- /dev/null +++ b/.github/workflows/build.yml @@ -0,0 +1,57 @@ +name: Build + +on: push + +jobs: + build-with-cabal: + name: ${{ matrix.os }} / ghc-${{ matrix.ghc }} + + runs-on: ${{ matrix.os }} + strategy: + fail-fast: false + matrix: + os: + - ubuntu-latest + - macOS-latest + - windows-2022 + ghc: + - 8.2.2 + - 8.4.4 + - 8.6.5 + - 8.8.2 + - 8.10.7 + - 9.0.2 + - 9.2.4 + - 9.4.2 + cabal: + - latest + + steps: + - name: Checkout + uses: actions/checkout@v3 + + - name: Setup Haskell + id: setup-haskell-cabal + uses: haskell/actions/setup@v2 + with: + ghc-version: ${{ matrix.ghc }} + cabal-version: ${{ matrix.cabal }} + + - name: Cache cabal store + uses: actions/cache@v3 + with: + path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} + key: cabal-store-${{ matrix.os }}-ghc-${{ matrix.ghc }}-${{ hashFiles('terminal-size.cabal') }} + restore-keys: cabal-store-${{ matrix.os }}-ghc-${{ matrix.ghc }}- + + - name: Build dependencies + run: cabal build --only-dependencies + + - name: Build + run: cabal build --write-ghc-environment-files=always + + - name: Build Test Program + # It would be nice if we could also run it. But that doesn't work + # because the std handles are redirected in the gihub runner + # so hSize always returns Nothing. + run: ghc test.hs diff --git a/src/System/Console/Terminal/Windows.hs b/src/System/Console/Terminal/Windows.hs index ea6ed14..816bbe9 100644 --- a/src/System/Console/Terminal/Windows.hs +++ b/src/System/Console/Terminal/Windows.hs @@ -20,7 +20,7 @@ hSize :: Integral n => Handle -> IO (Maybe (Window n)) hSize hdl = withHandleToHANDLE hdl nativeSize `catchIOError` \_ -> do - -- This could happen on Cygwin or MSYS + -- Fallback to use for Cygwin or MSYS let stty = (shell "stty size") { std_in = UseHandle hdl , std_out = CreatePipe