purge a bit extra bundled files
cannot yet enumerate every module in .cabal and purge the remaining ones due to their platform-specificity that precludes automation like cabal-fmt module expansion
This commit is contained in:
La Ancapo
parent
97cdc074f9
commit
5097d517f4
3 changed files with 0 additions and 396 deletions
|
|
@ -1,31 +0,0 @@
|
|||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE RebindableSyntax #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Basement.Terminal
|
||||
( initialize
|
||||
, getDimensions
|
||||
) where
|
||||
|
||||
import Basement.Compat.Base
|
||||
import Basement.Terminal.Size (getDimensions)
|
||||
#ifdef mingw32_HOST_OS
|
||||
import System.IO (hSetEncoding, utf8, hPutStrLn, stderr, stdin, stdout)
|
||||
import System.Win32.Console (setConsoleCP, setConsoleOutputCP, getConsoleCP, getConsoleOutputCP)
|
||||
#endif
|
||||
|
||||
initialize :: IO ()
|
||||
initialize = do
|
||||
#ifdef mingw32_HOST_OS
|
||||
query getConsoleOutputCP (\e -> setConsoleOutputCP e >> hSetEncoding stdout utf8 >> hSetEncoding stderr utf8) utf8Code
|
||||
query getConsoleCP (\e -> setConsoleCP e >> hSetEncoding stdin utf8) utf8Code
|
||||
where
|
||||
utf8Code = 65001
|
||||
query get set expected = do
|
||||
v <- get
|
||||
if v == expected then pure () else set expected
|
||||
#else
|
||||
pure ()
|
||||
#endif
|
||||
|
|
@ -1,175 +0,0 @@
|
|||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE RebindableSyntax #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
-- |
|
||||
-- Module : Basement.Terminal.ANSI
|
||||
-- License : BSD-style
|
||||
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
|
||||
--
|
||||
-- ANSI Terminal escape for cursor and attributes manipulations
|
||||
--
|
||||
-- On Unix system, it should be supported by most terminal emulators.
|
||||
--
|
||||
-- On Windows system, all escape sequences are empty for maximum
|
||||
-- compatibility purpose, and easy implementation. newer version
|
||||
-- of Windows 10 supports ANSI escape now, but we'll need
|
||||
-- some kind of detection.
|
||||
--
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Basement.Terminal.ANSI
|
||||
(
|
||||
-- * Types
|
||||
Escape
|
||||
, Displacement
|
||||
, ColorComponent
|
||||
, GrayComponent
|
||||
, RGBComponent
|
||||
-- * Simple ANSI escape factory functions
|
||||
, cursorUp
|
||||
, cursorDown
|
||||
, cursorForward
|
||||
, cursorBack
|
||||
, cursorNextLine
|
||||
, cursorPrevLine
|
||||
, cursorHorizontalAbsolute
|
||||
, cursorPosition
|
||||
, eraseScreenFromCursor
|
||||
, eraseScreenToCursor
|
||||
, eraseScreenAll
|
||||
, eraseLineFromCursor
|
||||
, eraseLineToCursor
|
||||
, eraseLineAll
|
||||
, scrollUp
|
||||
, scrollDown
|
||||
, sgrReset
|
||||
, sgrForeground
|
||||
, sgrBackground
|
||||
, sgrForegroundGray24
|
||||
, sgrBackgroundGray24
|
||||
, sgrForegroundColor216
|
||||
, sgrBackgroundColor216
|
||||
) where
|
||||
|
||||
import Basement.String
|
||||
import Basement.Bounded
|
||||
import Basement.Imports
|
||||
import Basement.Numerical.Multiplicative
|
||||
import Basement.Numerical.Additive
|
||||
|
||||
#ifndef mingw32_HOST_OS
|
||||
#define SUPPORT_ANSI_ESCAPE
|
||||
#endif
|
||||
|
||||
type Escape = String
|
||||
|
||||
type Displacement = Word64
|
||||
|
||||
-- | Simple color component on 8 color terminal (maximum compatibility)
|
||||
type ColorComponent = Zn64 8
|
||||
|
||||
-- | Gray color compent on 256colors terminals
|
||||
type GrayComponent = Zn64 24
|
||||
|
||||
-- | Color compent on 256colors terminals
|
||||
type RGBComponent = Zn64 6
|
||||
|
||||
cursorUp, cursorDown, cursorForward, cursorBack
|
||||
, cursorNextLine, cursorPrevLine
|
||||
, cursorHorizontalAbsolute :: Displacement -> Escape
|
||||
cursorUp n = csi1 n "A"
|
||||
cursorDown n = csi1 n "B"
|
||||
cursorForward n = csi1 n "C"
|
||||
cursorBack n = csi1 n "D"
|
||||
cursorNextLine n = csi1 n "E"
|
||||
cursorPrevLine n = csi1 n "F"
|
||||
cursorHorizontalAbsolute n = csi1 n "G"
|
||||
|
||||
cursorPosition :: Displacement -> Displacement -> Escape
|
||||
cursorPosition row col = csi2 row col "H"
|
||||
|
||||
eraseScreenFromCursor
|
||||
, eraseScreenToCursor
|
||||
, eraseScreenAll
|
||||
, eraseLineFromCursor
|
||||
, eraseLineToCursor
|
||||
, eraseLineAll :: Escape
|
||||
eraseScreenFromCursor = csi1 0 "J"
|
||||
eraseScreenToCursor = csi1 1 "J"
|
||||
eraseScreenAll = csi1 2 "J"
|
||||
eraseLineFromCursor = csi1 0 "K"
|
||||
eraseLineToCursor = csi1 1 "K"
|
||||
eraseLineAll = csi1 2 "K"
|
||||
|
||||
scrollUp, scrollDown :: Displacement -> Escape
|
||||
scrollUp n = csi1 n "S"
|
||||
scrollDown n = csi1 n "T"
|
||||
|
||||
-- | All attribute off
|
||||
sgrReset :: Escape
|
||||
sgrReset = csi1 0 "m"
|
||||
|
||||
-- | 8 Colors + Bold attribute for foreground
|
||||
sgrForeground :: ColorComponent -> Bool -> Escape
|
||||
sgrForeground n bold
|
||||
| bold = csi2 (30+unZn64 n) 1 "m"
|
||||
| otherwise = csi1 (30+unZn64 n) "m"
|
||||
|
||||
-- | 8 Colors + Bold attribute for background
|
||||
sgrBackground :: ColorComponent -> Bool -> Escape
|
||||
sgrBackground n bold
|
||||
| bold = csi2 (40+unZn64 n) 1 "m"
|
||||
| otherwise = csi1 (40+unZn64 n) "m"
|
||||
|
||||
-- 256 colors mode
|
||||
|
||||
sgrForegroundGray24, sgrBackgroundGray24 :: GrayComponent -> Escape
|
||||
sgrForegroundGray24 v = csi3 38 5 (0xE8 + unZn64 v) "m"
|
||||
sgrBackgroundGray24 v = csi3 48 5 (0xE8 + unZn64 v) "m"
|
||||
|
||||
sgrForegroundColor216 :: RGBComponent -- ^ Red component
|
||||
-> RGBComponent -- ^ Green component
|
||||
-> RGBComponent -- ^ Blue component
|
||||
-> Escape
|
||||
sgrForegroundColor216 r g b = csi3 38 5 (0x10 + 36 * unZn64 r + 6 * unZn64 g + unZn64 b) "m"
|
||||
|
||||
sgrBackgroundColor216 :: RGBComponent -- ^ Red component
|
||||
-> RGBComponent -- ^ Green component
|
||||
-> RGBComponent -- ^ Blue component
|
||||
-> Escape
|
||||
sgrBackgroundColor216 r g b = csi3 48 5 (0x10 + 36 * unZn64 r + 6 * unZn64 g + unZn64 b) "m"
|
||||
|
||||
#ifdef SUPPORT_ANSI_ESCAPE
|
||||
|
||||
csi0 :: String -> String
|
||||
csi0 suffix = mconcat ["\ESC[", suffix]
|
||||
|
||||
csi1 :: Displacement -> String -> String
|
||||
csi1 p1 suffix = mconcat ["\ESC[", pshow p1, suffix]
|
||||
|
||||
csi2 :: Displacement -> Displacement -> String -> String
|
||||
csi2 p1 p2 suffix = mconcat ["\ESC[", pshow p1, ";", pshow p2, suffix]
|
||||
|
||||
csi3 :: Displacement -> Displacement -> Displacement -> String -> String
|
||||
csi3 p1 p2 p3 suffix = mconcat ["\ESC[", pshow p1, ";", pshow p2, ";", pshow p3, suffix]
|
||||
|
||||
pshow = show
|
||||
|
||||
#else
|
||||
|
||||
csi0 :: String -> String
|
||||
csi0 _ = ""
|
||||
|
||||
csi1 :: Displacement -> String -> String
|
||||
csi1 _ _ = ""
|
||||
|
||||
csi2 :: Displacement -> Displacement -> String -> String
|
||||
csi2 _ _ _ = ""
|
||||
|
||||
csi3 :: Displacement -> Displacement -> Displacement -> String -> String
|
||||
csi3 _ _ _ _ = ""
|
||||
|
||||
#endif
|
||||
|
|
@ -1,190 +0,0 @@
|
|||
{-# 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)
|
||||
Loading…
Add table
Add a link
Reference in a new issue