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