Initial commit

bundled/Basement/Terminal/Size.hsc

@@ -0,0 +1,190 @@
+{-# LANGUAGE CApiFFI #-}
+module Basement.Terminal.Size 
+    ( getDimensions
+    ) where
+        
+import           Foreign
+import           Foreign.C
+import           Basement.Compat.Base
+import           Basement.Types.OffsetSize
+import           Basement.Numerical.Subtractive
+import           Basement.Numerical.Additive
+import           Prelude (fromIntegral)
+
+#include "foundation_system.h"
+#ifdef FOUNDATION_SYSTEM_WINDOWS
+
+import           System.Win32.Types (HANDLE, BOOL)
+import           Graphics.Win32.Misc (getStdHandle, sTD_OUTPUT_HANDLE, StdHandleId)
+
+#include <windows.h>
+#elif defined FOUNDATION_SYSTEM_UNIX
+#include <sys/ioctl.h>
+#ifdef __sun
+#include <sys/termios.h>
+#endif
+#endif 
+
+#include <stdio.h>
+
+#if __GLASGOW_HASKELL__ < 800
+#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)
+#endif
+
+#ifdef FOUNDATION_SYSTEM_UNIX
+data Winsize = Winsize
+    { ws_row    :: !Word16
+    , ws_col    :: !Word16
+    , ws_xpixel :: !Word16
+    , ws_ypixel :: !Word16
+    }
+
+instance Storable Winsize where
+    sizeOf _ = #{size struct winsize}
+    alignment _ = #{alignment struct winsize}
+    peek ptr = do
+        r <- #{peek struct winsize, ws_row} ptr
+        c <- #{peek struct winsize, ws_col} ptr
+        x <- #{peek struct winsize, ws_xpixel} ptr
+        y <- #{peek struct winsize, ws_ypixel} ptr
+        return (Winsize r c x y)
+    poke ptr (Winsize r c x y) = do
+        #{poke struct winsize, ws_row} ptr r
+        #{poke struct winsize, ws_col} ptr c
+        #{poke struct winsize, ws_xpixel} ptr x
+        #{poke struct winsize, ws_ypixel} ptr y
+        
+#elif defined FOUNDATION_SYSTEM_WINDOWS
+type Handle = Ptr CChar  -- void *
+
+data SmallRect = SmallRect 
+    { left   :: !Int16
+    , top    :: !Int16
+    , right  :: !Int16
+    , bottom :: !Int16
+    } deriving (Show)
+
+instance Storable SmallRect where
+    sizeOf _ = #{size SMALL_RECT}
+    alignment _ = #{alignment SMALL_RECT}
+    peek ptr = do
+        l <- #{peek SMALL_RECT, Left} ptr
+        r <- #{peek SMALL_RECT, Right} ptr
+        t <- #{peek SMALL_RECT, Top} ptr
+        b <- #{peek SMALL_RECT, Bottom} ptr
+        return (SmallRect l t r b)
+    poke ptr (SmallRect l t r b) = do
+        #{poke SMALL_RECT, Left} ptr l
+        #{poke SMALL_RECT, Top} ptr t
+        #{poke SMALL_RECT, Right} ptr r
+        #{poke SMALL_RECT, Bottom} ptr b
+        
+data Coord = Coord 
+    { x :: !Int16
+    , y :: !Int16
+    } deriving (Show)
+
+instance Storable Coord where
+    sizeOf _ = #{size COORD}
+    alignment _ = #{alignment COORD}
+    peek ptr = do
+        x <- #{peek COORD, X} ptr
+        y <- #{peek COORD, Y} ptr
+        return (Coord x y)
+    poke ptr (Coord x y) = do
+        #{poke COORD, X} ptr x
+        #{poke COORD, Y} ptr y
+
+data ConsoleScreenBufferInfo = ConsoleScreenBufferInfo 
+    { dwSize              :: !Coord
+    , dwCursorPosition    :: !Coord
+    , wAttributes         :: !Word16
+    , srWindow            :: !SmallRect
+    , dwMaximumWindowSize :: !Coord
+    } deriving (Show)
+
+instance Storable ConsoleScreenBufferInfo where
+    sizeOf _ = #{size CONSOLE_SCREEN_BUFFER_INFO}
+    alignment _ = #{alignment CONSOLE_SCREEN_BUFFER_INFO}
+    peek ptr = do
+        s <- #{peek CONSOLE_SCREEN_BUFFER_INFO, dwSize} ptr
+        c <- #{peek CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition} ptr
+        a <- #{peek CONSOLE_SCREEN_BUFFER_INFO, wAttributes} ptr
+        w <- #{peek CONSOLE_SCREEN_BUFFER_INFO, srWindow} ptr
+        m <- #{peek CONSOLE_SCREEN_BUFFER_INFO, dwMaximumWindowSize} ptr
+        return (ConsoleScreenBufferInfo s c a w m)
+    poke ptr (ConsoleScreenBufferInfo s c a w m) = do
+        #{poke CONSOLE_SCREEN_BUFFER_INFO, dwSize} ptr s
+        #{poke CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition} ptr c
+        #{poke CONSOLE_SCREEN_BUFFER_INFO, wAttributes} ptr a
+        #{poke CONSOLE_SCREEN_BUFFER_INFO, srWindow} ptr w
+        #{poke CONSOLE_SCREEN_BUFFER_INFO, dwMaximumWindowSize} ptr m
+    
+invalidHandleValue :: IntPtr
+invalidHandleValue = #{const INVALID_HANDLE_VALUE}
+
+stdOutputHandle :: CULong
+stdOutputHandle = #{const STD_OUTPUT_HANDLE}
+#endif
+-- defined FOUNDATION_SYSTEM_WINDOWS
+
+#ifdef FOUNDATION_SYSTEM_UNIX
+
+foreign import capi "sys/ioctl.h ioctl" c_ioctl :: CInt -> CULong -> Ptr a -> IO CInt
+
+-- | Get the terminal windows size
+tiocgwinsz :: CULong
+tiocgwinsz = Prelude.fromIntegral (#{const TIOCGWINSZ} :: Word)
+
+#elif defined FOUNDATION_SYSTEM_WINDOWS
+foreign import ccall "GetConsoleScreenBufferInfo" c_get_console_screen_buffer_info 
+  :: HANDLE -> Ptr ConsoleScreenBufferInfo -> IO BOOL
+#endif
+
+#ifdef FOUNDATION_SYSTEM_UNIX
+ioctlWinsize :: CInt -> IO (Maybe (CountOf Char, CountOf Char))
+ioctlWinsize fd = alloca $ \winsizePtr -> do
+    status <- c_ioctl fd tiocgwinsz winsizePtr
+    if status == (-1 :: CInt)
+        then pure Nothing
+        else Just . toDimensions <$> peek winsizePtr
+  where
+    toDimensions winsize =
+        ( CountOf . Prelude.fromIntegral . ws_col $ winsize
+        , CountOf . Prelude.fromIntegral . ws_row $ winsize)
+       
+#elif defined FOUNDATION_SYSTEM_WINDOWS
+getConsoleScreenBufferInfo :: HANDLE -> IO (Maybe ConsoleScreenBufferInfo)
+getConsoleScreenBufferInfo handle = alloca $ \infoPtr -> do
+    status <- c_get_console_screen_buffer_info handle infoPtr
+    if status
+        then Just <$> peek infoPtr
+        else pure Nothing
+       
+winWinsize :: StdHandleId -> IO (Maybe (CountOf Char, CountOf Char))
+winWinsize handleRef = (infoToDimensions <$>) <$>
+    (getStdHandle handleRef >>= getConsoleScreenBufferInfo)
+  where
+    infoToDimensions info =
+        let window = srWindow info
+            width = Prelude.fromIntegral (right window - left window + 1)
+            height = Prelude.fromIntegral (bottom window - top window + 1)
+         in (CountOf width, CountOf height)
+#endif
+-- defined FOUNDATION_SYSTEM_WINDOWS
+
+-- | Return the size of the current terminal
+--
+-- If the system is not supported or that querying the system result in an error
+-- then a default size of (80, 24) will be given back.
+getDimensions :: IO (CountOf Char, CountOf Char)
+getDimensions =
+#if defined FOUNDATION_SYSTEM_WINDOWS
+    maybe defaultSize id <$> winWinsize sTD_OUTPUT_HANDLE
+#elif defined FOUNDATION_SYSTEM_UNIX
+    maybe defaultSize id <$> ioctlWinsize 0
+#else
+    pure defaultSize
+#endif
+  where
+    defaultSize = (80, 24)