Windows: depend on WIN32 package, implement and export hSize

.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

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
+```

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,14 +45,17 @@ 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
 -- >>> hSize stdout
 -- Just (Window {height = 56, width = 85})
 hSize :: Integral n => Handle -> IO (Maybe (Window n))
 hSize = Host.hSize
-#endif

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
+        -- Fallback to use for 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)
+        }

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

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