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.

Author: bfrk

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
+        -- 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)
+        }

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