hs-sdl-term-emulator (empty) → 0.1.0.4
raw patch · 8 files changed
+609/−0 lines, 8 filesdep +ansi-terminaldep +asyncdep +base
Dependencies added: ansi-terminal, async, base, bytestring, conduit, conduit-extra, hs-sdl-term-emulator, hs-term-emulator, lens, linear, posix-pty, process, sdl2, stm, stm-conduit, vector
Files
- CHANGELOG.md +5/−0
- LICENSE +19/−0
- Main.hs +6/−0
- hs-sdl-term-emulator.cabal +55/−0
- src/System/Terminal/Emulator/SDL/ImageFont.hs +41/−0
- src/System/Terminal/Emulator/SDL/KeyboardTranslate.hs +82/−0
- src/System/Terminal/Emulator/SDL/LibMain.hs +345/−0
- src/System/Terminal/Emulator/SDL/Pty.hs +56/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for hs-sdl-term-emulator++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (C) 2021 The hs-term-emulator Authors (see AUTHORS file)++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Main.hs view
@@ -0,0 +1,6 @@+module Main where++import qualified System.Terminal.Emulator.SDL.LibMain++main :: IO ()+main = System.Terminal.Emulator.SDL.LibMain.main
+ hs-sdl-term-emulator.cabal view
@@ -0,0 +1,55 @@+cabal-version: 2.4+name: hs-sdl-term-emulator+version: 0.1.0.4+synopsis: Terminal Emulator written in Haskell, SDL2 Backend+description: See: https://github.com/bitc/hs-term-emulator#readme+homepage: https://github.com/bitc/hs-term-emulator+bug-reports: https://github.com/bitc/hs-term-emulator/issues+license: MIT+license-file: LICENSE+author: Bit Connor+maintainer: https://github.com/bitc+category: Terminal+extra-source-files: CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/bitc/hs-term-emulator.git++library+ -- cabal-fmt: expand src+ exposed-modules:+ System.Terminal.Emulator.SDL.ImageFont+ System.Terminal.Emulator.SDL.KeyboardTranslate+ System.Terminal.Emulator.SDL.LibMain+ System.Terminal.Emulator.SDL.Pty++ build-depends:+ , ansi-terminal ^>=0.11+ , async ^>=2.2.3+ , base >=4.10 && <5+ , bytestring+ , conduit ^>=1.3.4.1+ , conduit-extra ^>=1.3.5+ , hs-term-emulator ^>=0.1.0.0+ , lens ^>=5.0.1+ , linear ^>=1.21.6+ , posix-pty ^>=0.2.2+ , process+ , sdl2 ^>=2.5.3.0+ , stm+ , stm-conduit ^>=4.0.1+ , vector ^>=0.12.3.0++ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall -Werror=incomplete-patterns -Werror=missing-fields++executable hs-sdl-term-emulator+ main-is: Main.hs+ build-depends:+ , base >=4.10 && <5+ , hs-sdl-term-emulator++ default-language: Haskell2010+ ghc-options: -Wall -threaded
+ src/System/Terminal/Emulator/SDL/ImageFont.hs view
@@ -0,0 +1,41 @@+module System.Terminal.Emulator.SDL.ImageFont where++import Control.Monad (forM_)+import Data.Bits (shiftR, (.&.), (.|.))+import Data.Word (Word32)+import Foreign.Ptr (Ptr, castPtr)+import Foreign.Storable (peekElemOff, pokeElemOff)+import Linear (V2 (..))+import qualified SDL as SDL++loadImageFont :: IO SDL.Surface+loadImageFont = do+ bmp <- SDL.loadBMP "font.bmp"+ rgba <- convertGrayscaleToAlpha bmp+ SDL.freeSurface bmp+ pure rgba++-- | Creates a new surface in RGBA format where the color of all pixels is+-- white, and the alpha channel is taken from the grayscale values of the+-- source surface+convertGrayscaleToAlpha ::+ -- | 'Surface' to copy from+ SDL.Surface ->+ -- | New 'Surface' is created+ IO SDL.Surface+convertGrayscaleToAlpha grayscaleRGB = do+ size@(V2 width height) <- SDL.surfaceDimensions grayscaleRGB+ rgba <- SDL.createRGBSurface size SDL.RGBA8888+ _ <- SDL.surfaceBlit grayscaleRGB Nothing rgba Nothing++ SDL.lockSurface rgba+ pixelsPtr <- SDL.surfacePixels rgba+ let pixels :: Ptr Word32+ pixels = castPtr pixelsPtr+ forM_ [0 .. fromIntegral (width * height) - 1] $ \i -> do+ pixel <- peekElemOff pixels i+ let intensity = (pixel .&. 0xFF000000) `shiftR` 24+ pokeElemOff pixels i (intensity .|. 0xFFFFFF00)+ SDL.unlockSurface rgba++ pure rgba
+ src/System/Terminal/Emulator/SDL/KeyboardTranslate.hs view
@@ -0,0 +1,82 @@+module System.Terminal.Emulator.SDL.KeyboardTranslate where++import Data.Char (isAlpha, toUpper)+import System.Terminal.Emulator.KeyboardInput (KeyModifiers (..), KeyPress (..), SpecialKey (..))+import qualified SDL as SDL++translateSDLKey :: SDL.Keysym -> Maybe KeyPress+translateSDLKey keysym+ | keycode `elem` [SDL.KeycodeReturn, SDL.KeycodeReturn2, SDL.KeycodeKPEnter] = Just $ KeyPress_SpecialKey SpecialKey_Enter modifiers+ | keycode `elem` [SDL.KeycodeBackspace] = Just $ KeyPress_SpecialKey SpecialKey_Backspace modifiers+ | keycode `elem` [SDL.KeycodeDelete, SDL.KeycodeKPBackspace] = Just $ KeyPress_SpecialKey SpecialKey_Delete modifiers+ | keycode `elem` [SDL.KeycodeTab, SDL.KeycodeKPTab] = Just $ KeyPress_SpecialKey SpecialKey_Tab modifiers+ | keycode `elem` [SDL.KeycodeEscape] = Just $ KeyPress_SpecialKey SpecialKey_Escape modifiers+ | keycode `elem` [SDL.KeycodeUp, SDL.KeycodeKP8] = Just $ KeyPress_SpecialKey SpecialKey_ArrowUp modifiers+ | keycode `elem` [SDL.KeycodeDown, SDL.KeycodeKP2] = Just $ KeyPress_SpecialKey SpecialKey_ArrowDown modifiers+ | keycode `elem` [SDL.KeycodeLeft, SDL.KeycodeKP4] = Just $ KeyPress_SpecialKey SpecialKey_ArrowLeft modifiers+ | keycode `elem` [SDL.KeycodeRight, SDL.KeycodeKP6] = Just $ KeyPress_SpecialKey SpecialKey_ArrowRight modifiers+ | keycode == SDL.KeycodeF1 = Just $ KeyPress_SpecialKey SpecialKey_F1 modifiers+ | keycode == SDL.KeycodeF2 = Just $ KeyPress_SpecialKey SpecialKey_F2 modifiers+ | keycode == SDL.KeycodeF3 = Just $ KeyPress_SpecialKey SpecialKey_F3 modifiers+ | keycode == SDL.KeycodeF4 = Just $ KeyPress_SpecialKey SpecialKey_F4 modifiers+ | keycode == SDL.KeycodeF5 = Just $ KeyPress_SpecialKey SpecialKey_F5 modifiers+ | keycode == SDL.KeycodeF6 = Just $ KeyPress_SpecialKey SpecialKey_F6 modifiers+ | keycode == SDL.KeycodeF7 = Just $ KeyPress_SpecialKey SpecialKey_F7 modifiers+ | keycode == SDL.KeycodeF8 = Just $ KeyPress_SpecialKey SpecialKey_F8 modifiers+ | keycode == SDL.KeycodeF9 = Just $ KeyPress_SpecialKey SpecialKey_F9 modifiers+ | keycode == SDL.KeycodeF10 = Just $ KeyPress_SpecialKey SpecialKey_F10 modifiers+ | keycode == SDL.KeycodeF11 = Just $ KeyPress_SpecialKey SpecialKey_F11 modifiers+ | keycode == SDL.KeycodeF12 = Just $ KeyPress_SpecialKey SpecialKey_F12 modifiers+ | keycodeNum >= 32 && keycodeNum <= 126 = Just $ KeyPress_Char (keySymToChar keysym) modifiers+ | otherwise = Nothing+ where+ keycode = SDL.keysymKeycode keysym+ SDL.Keycode keycodeNum = keycode+ modifiers = sdlKeyModifiers (SDL.keysymModifier keysym)++sdlKeyModifiers :: SDL.KeyModifier -> KeyModifiers+sdlKeyModifiers keyModifier =+ KeyModifiers+ { shift = SDL.keyModifierLeftShift keyModifier || SDL.keyModifierRightShift keyModifier,+ ctrl = SDL.keyModifierLeftCtrl keyModifier || SDL.keyModifierRightCtrl keyModifier,+ alt = SDL.keyModifierLeftAlt keyModifier || SDL.keyModifierRightAlt keyModifier,+ capsLock = SDL.keyModifierCapsLock keyModifier+ }++keySymToChar :: SDL.Keysym -> Char+keySymToChar keysym+ | isAlpha char =+ if shiftPressed /= SDL.keyModifierCapsLock keyModifier+ then toUpper char+ else char+ | otherwise = if shiftPressed then uppercaseNonAlpha char else char+ where+ keyModifier = SDL.keysymModifier keysym+ char = toEnum (fromIntegral keycode)+ SDL.Keycode keycode = SDL.keysymKeycode keysym+ shiftPressed = SDL.keyModifierLeftShift keyModifier || SDL.keyModifierRightShift keyModifier++uppercaseNonAlpha :: Char -> Char+uppercaseNonAlpha char | isAlpha char = toUpper char+uppercaseNonAlpha '`' = '~'+uppercaseNonAlpha '1' = '!'+uppercaseNonAlpha '2' = '@'+uppercaseNonAlpha '3' = '#'+uppercaseNonAlpha '4' = '$'+uppercaseNonAlpha '5' = '%'+uppercaseNonAlpha '6' = '^'+uppercaseNonAlpha '7' = '&'+uppercaseNonAlpha '8' = '*'+uppercaseNonAlpha '9' = '('+uppercaseNonAlpha '0' = ')'+uppercaseNonAlpha '-' = '_'+uppercaseNonAlpha '=' = '+'+uppercaseNonAlpha '[' = '{'+uppercaseNonAlpha ']' = '}'+uppercaseNonAlpha ';' = ':'+uppercaseNonAlpha '\'' = '"'+uppercaseNonAlpha '\\' = '|'+uppercaseNonAlpha ',' = '<'+uppercaseNonAlpha '.' = '>'+uppercaseNonAlpha '/' = '?'+uppercaseNonAlpha char = char
+ src/System/Terminal/Emulator/SDL/LibMain.hs view
@@ -0,0 +1,345 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module System.Terminal.Emulator.SDL.LibMain where++import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.Exception (bracket)+import Control.Lens+import Control.Monad (forM_, unless, when)+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.Conduit (runConduit, (.|))+import Data.Conduit.Attoparsec (conduitParser)+import Data.Conduit.Combinators (decodeUtf8Lenient)+import qualified Data.Conduit.Combinators as C+import Data.Conduit.TQueue (sinkTBQueue, sourceTBQueue)+import qualified Data.Vector.Unboxed as VU+import Data.Word (Word8)+import Foreign.C.Types (CInt)+import Linear (V2 (..), V3 (..), V4 (..))+import Linear.Affine (Point (..))+import qualified Linear.V4 as V4+import SDL (get, ($=))+import qualified SDL as SDL+import qualified System.Console.ANSI.Types as SGR+import System.Terminal.Emulator.Attrs (Cell, attrsBg, attrsFg, attrsIntensity, attrsUnderline)+import System.Terminal.Emulator.KeyboardInput.KeyPressToPty (keyPressToPty)+import System.Terminal.Emulator.Parsing (parseTermAtom)+import System.Terminal.Emulator.Parsing.Types (TermAtom)+import System.Terminal.Emulator.SDL.ImageFont (loadImageFont)+import System.Terminal.Emulator.SDL.KeyboardTranslate (translateSDLKey)+import System.Terminal.Emulator.SDL.Pty (launchPty)+import System.Terminal.Emulator.Term (activeScreen, altScreenActive, cursorPos, mkTerm, numRows, scrollBackLines, termGetKeyboardState, windowTitle)+import System.Terminal.Emulator.Term.Process (Term, TermLine, processTermAtoms)+import System.Terminal.Emulator.Term.Resize (resizeTerm)+import qualified System.Terminal.Emulator.TermLines as TL+import Prelude hiding (lines)++initialTerminalWidth, initialTerminalHeight :: CInt+initialTerminalWidth = 80+initialTerminalHeight = 30++initialWindowSize :: V2 CInt+initialWindowSize = V2 (initialTerminalWidth * cellWidth) (initialTerminalHeight * cellHeight)++main :: IO ()+main = do+ SDL.initializeAll+ bracket+ ( SDL.createWindow+ "My SDL Application"+ SDL.defaultWindow+ { SDL.windowBorder = True,+ SDL.windowInitialSize = initialWindowSize,+ SDL.windowResizable = True+ }+ )+ SDL.destroyWindow+ ( \window -> do+ renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer+ -- We need to resize the window again, because the window manager I+ -- use (xmonad) creates it initially a bit too small+ SDL.windowSize window $= initialWindowSize+ fontSurface <- loadImageFont+ fontTexture <- SDL.createTextureFromSurface renderer fontSurface+ SDL.freeSurface fontSurface++ terminalLoop window renderer fontTexture+ )++terminalLoop :: SDL.Window -> SDL.Renderer -> SDL.Texture -> IO ()+terminalLoop window renderer fontTexture = do+ V2 windowWidth windowHeight <- get $ SDL.windowSize window+ let terminalInitialWidth = fromIntegral (windowWidth `div` cellWidth)+ terminalInitialHeight = fromIntegral (windowHeight `div` cellHeight)++ termOutputQueue <- newTBQueueIO 500+ let initialTerm = mkTerm (terminalInitialWidth, terminalInitialHeight)++ windowDirtyVar <- newTVarIO True++ scrollBackVar <- newTVarIO 0++ termVar :: TVar Term <- newTVarIO initialTerm++ termInputBuffer :: TChan ByteString <- newTChanIO++ termResizeEvents :: TChan (Int, Int) <- newTChanIO++ termOutputStream :: TBQueue TermAtom <- newTBQueueIO 500++ let streamInput :: IO ()+ streamInput =+ runConduit $+ (sourceTBQueue termOutputQueue)+ .| decodeUtf8Lenient+ .| C.iterM (\t -> putStrLn $ "[RAW] " <> show t)+ .| conduitParser parseTermAtom -- termAtom+ -- .| C.iterM (\t -> putStrLn $ "[PARSED] " <> show t)+ .| C.map snd+ .| sinkTBQueue termOutputStream++ let doTerminalResize :: (Int, Int) -> IO ()+ doTerminalResize newSize = do+ atomically $ do+ modifyTVar' termVar (flip resizeTerm newSize')+ writeTVar windowDirtyVar True+ atomically $ writeTChan termResizeEvents newSize'+ where+ (width, height) = newSize+ newSize' = (max 1 width, max 1 height)++ let readInput :: IO ()+ readInput = do+ event <- interruptibleWaitEvent+ case SDL.eventPayload event of+ SDL.KeyboardEvent SDL.KeyboardEventData {SDL.keyboardEventKeyMotion = SDL.Pressed, SDL.keyboardEventKeysym = keysym} -> do+ -- putStrLn $ "{KEYSYM} " <> show keysym+ case translateSDLKey keysym of+ Nothing -> pure ()+ Just termInput -> atomically $ do+ term <- readTVar termVar+ writeTChan termInputBuffer (keyPressToPty (termGetKeyboardState term) termInput)+ pure ()+ SDL.WindowExposedEvent _ -> atomically $ writeTVar windowDirtyVar True+ SDL.MouseWheelEvent SDL.MouseWheelEventData {SDL.mouseWheelEventPos = V2 _ scrollY} -> do+ atomically $ do+ let scrollMultiplier = 6+ modifyTVar' scrollBackVar (\scrollBack -> max 0 (scrollBack + (scrollMultiplier * (fromIntegral scrollY))))+ writeTVar windowDirtyVar True+ SDL.MouseMotionEvent+ SDL.MouseMotionEventData+ { SDL.mouseMotionEventState = [SDL.ButtonRight],+ SDL.mouseMotionEventPos = P (V2 mouseX mouseY)+ } -> do+ let newTermWidth = fromIntegral mouseX `div` fromIntegral cellWidth+ newTermHeight = fromIntegral mouseY `div` fromIntegral cellHeight+ doTerminalResize (newTermWidth, newTermHeight)+ SDL.MouseButtonEvent+ SDL.MouseButtonEventData+ { SDL.mouseButtonEventButton = SDL.ButtonRight,+ SDL.mouseButtonEventMotion = SDL.Pressed,+ SDL.mouseButtonEventPos = P (V2 mouseX mouseY),+ SDL.mouseButtonEventClicks = numClicks+ } -> do+ putStrLn $ "mouseClick: " <> show numClicks <> show (mouseX, mouseY)+ let newTermWidth = fromIntegral mouseX `div` fromIntegral cellWidth+ newTermHeight = fromIntegral mouseY `div` fromIntegral cellHeight+ doTerminalResize (newTermWidth, newTermHeight)+ SDL.WindowSizeChangedEvent+ SDL.WindowSizeChangedEventData+ { SDL.windowSizeChangedEventSize = V2 newWindowWidth newWindowHeight+ } ->+ do+ putStrLn $ "RESIZE: " <> show (newWindowWidth, newWindowHeight)+ let newTermWidth = fromIntegral newWindowWidth `div` fromIntegral cellWidth+ newTermHeight = fromIntegral newWindowHeight `div` fromIntegral cellHeight+ doTerminalResize (newTermWidth, newTermHeight)+ _ -> pure ()+ readInput++ let renderLoop :: IO ()+ renderLoop = do+ mbOutputBuf <-+ atomically $+ (readTBQueueAll termOutputStream >>= pure . Just)+ `orElse` ( do+ windowDirty <- readTVar windowDirtyVar+ if windowDirty+ then do+ writeTVar windowDirtyVar False+ pure Nothing+ else retry+ )+ -- putStrLn $ "{OUTPUT} " <> show outputBuf+ !(termWrite, !term') <- atomically $ do+ term <- readTVar termVar+ case mbOutputBuf of+ Just outputBuf -> do+ let (termWrite, term') = processTermAtoms outputBuf term+ writeTVar termVar $! term'+ pure (termWrite, term')+ Nothing -> pure (B.empty, term)+ unless (B.null termWrite) $+ atomically $ writeTChan termInputBuffer termWrite+ scrollBack <- atomically $ readTVar scrollBackVar+ renderTerm window renderer fontTexture term' scrollBack+ renderLoop++ withAsync streamInput $ \streamInputAsync -> do+ link streamInputAsync+ withAsync readInput $ \readInputAsync -> do+ link readInputAsync+ withAsync+ ( renderLoop+ )+ $ \renderLoopAsync -> do+ link renderLoopAsync+ launchPty (terminalInitialWidth, terminalInitialHeight) (readTChan termInputBuffer) (readTChan termResizeEvents) $ \contents -> do+ -- putStrLn $ "[CONTENTS] " ++ show contents+ atomically $ writeTBQueue termOutputQueue contents++-- | Reads all the values in the 'TBQueue', or retry if it is empty+readTBQueueAll :: TBQueue a -> STM [a]+readTBQueueAll c = do+ first <- readTBQueue c+ rest <- tryReadTBQueueMultiple []+ pure (first : rest)+ where+ tryReadTBQueueMultiple accum = do+ mbItem <- tryReadTBQueue c+ case mbItem of+ Nothing -> pure (reverse accum)+ Just item -> tryReadTBQueueMultiple (item : accum)++renderTerm :: SDL.Window -> SDL.Renderer -> SDL.Texture -> Term -> Int -> IO ()+renderTerm window renderer fontTexture term scrollBack = do+ SDL.windowTitle window $= term ^. windowTitle+ let visibleRows+ | term ^. altScreenActive = term ^. activeScreen+ | otherwise = (TL.take (term ^. numRows) (TL.takeLast scrollBack (term ^. scrollBackLines))) <> (TL.dropLast scrollBack (term ^. activeScreen))++ SDL.rendererDrawColor renderer $= V4 255 32 255 255+ SDL.clear renderer+ _ <- (flip TL.traverseWithIndex) visibleRows $ \line termLine -> do+ renderLine renderer fontTexture termLine line++ renderGrid window renderer++ -- Render the cursor+ let (line, col) = term ^. cursorPos+ SDL.rendererDrawColor renderer $= V4 255 255 128 255+ SDL.drawRect renderer (Just (SDL.Rectangle (P (V2 (fromIntegral col * cellWidth) (fromIntegral (line + scrollBack) * cellHeight))) charSize))++ SDL.present renderer++renderGrid :: SDL.Window -> SDL.Renderer -> IO ()+renderGrid window renderer = do+ V2 windowWidth windowHeight <- get $ SDL.windowSize window+ SDL.rendererDrawColor renderer $= V4 8 8 8 255++ -- Horizontal lines+ forM_ [0, cellHeight .. windowHeight] $ \y -> do+ SDL.drawLine renderer (P (V2 0 y)) (P (V2 windowWidth y))++ -- Vertical lines+ forM_ [0, cellWidth .. windowWidth] $ \x -> do+ SDL.drawLine renderer (P (V2 x 0)) (P (V2 x windowHeight))++renderLine :: SDL.Renderer -> SDL.Texture -> TermLine -> Int -> IO ()+renderLine renderer fontTexture termLine line = do+ VU.iforM_ termLine $ \col cell -> do+ renderChar renderer fontTexture cell line col+ pure ()++renderChar :: SDL.Renderer -> SDL.Texture -> Cell -> Int -> Int -> IO ()+renderChar renderer fontTexture (char, attrs) line col = do+ let fgColor :: (V3 Word8)+ fgColor = case attrs ^. attrsFg of+ Nothing -> V3 172 216 172+ Just (SGR.Dull, SGR.Black) -> V3 0 0 0+ Just (SGR.Dull, SGR.Red) -> V3 208 0 0+ Just (SGR.Dull, SGR.Green) -> V3 0 208 0+ Just (SGR.Dull, SGR.Yellow) -> V3 208 208 0+ Just (SGR.Dull, SGR.Blue) -> V3 0 0 208+ Just (SGR.Dull, SGR.Magenta) -> V3 208 0 208+ Just (SGR.Dull, SGR.Cyan) -> V3 0 208 208+ Just (SGR.Dull, SGR.White) -> V3 208 208 208+ Just (SGR.Vivid, SGR.Black) -> V3 128 128 128+ Just (SGR.Vivid, SGR.Red) -> V3 128 128 128+ Just (SGR.Vivid, SGR.Green) -> V3 128 128 128+ Just (SGR.Vivid, SGR.Yellow) -> V3 128 128 128+ Just (SGR.Vivid, SGR.Blue) -> V3 128 128 128+ Just (SGR.Vivid, SGR.Magenta) -> V3 128 128 128+ Just (SGR.Vivid, SGR.Cyan) -> V3 128 128 128+ Just (SGR.Vivid, SGR.White) -> V3 128 128 128++ bgColor :: (V4 Word8)+ bgColor = case attrs ^. attrsBg of+ Nothing -> V4 0 0 0 255+ Just (SGR.Dull, SGR.Black) -> V4 0 0 0 255+ Just (SGR.Dull, SGR.Red) -> V4 208 0 0 255+ Just (SGR.Dull, SGR.Green) -> V4 0 208 0 255+ Just (SGR.Dull, SGR.Yellow) -> V4 208 208 0 255+ Just (SGR.Dull, SGR.Blue) -> V4 0 0 208 255+ Just (SGR.Dull, SGR.Magenta) -> V4 208 0 208 255+ Just (SGR.Dull, SGR.Cyan) -> V4 0 208 208 255+ Just (SGR.Dull, SGR.White) -> V4 208 208 208 255+ Just (SGR.Vivid, SGR.Black) -> V4 255 128 128 255+ Just (SGR.Vivid, SGR.Red) -> V4 255 128 128 255+ Just (SGR.Vivid, SGR.Green) -> V4 255 128 128 255+ Just (SGR.Vivid, SGR.Yellow) -> V4 255 128 128 255+ Just (SGR.Vivid, SGR.Blue) -> V4 255 128 128 255+ Just (SGR.Vivid, SGR.Magenta) -> V4 255 128 128 255+ Just (SGR.Vivid, SGR.Cyan) -> V4 255 128 128 255+ Just (SGR.Vivid, SGR.White) -> V4 255 128 128 255+ SDL.rendererDrawColor renderer $= bgColor+ SDL.fillRect renderer (Just (SDL.Rectangle (P (V2 (fromIntegral col * cellWidth) (fromIntegral line * cellHeight))) charSize))++ SDL.textureColorMod fontTexture $= fgColor+ SDL.copy+ renderer+ fontTexture+ (Just (SDL.Rectangle (charPosition char) charSize))+ (Just (SDL.Rectangle (P (V2 (fromIntegral col * cellWidth) (fromIntegral line * cellHeight))) charSize))++ when (attrs ^. attrsIntensity == SGR.BoldIntensity) $ do+ SDL.copy+ renderer+ fontTexture+ (Just (SDL.Rectangle (charPosition char) charSize))+ (Just (SDL.Rectangle (P (V2 (fromIntegral col * cellWidth - 1) (fromIntegral line * cellHeight))) charSize))++ when (attrs ^. attrsUnderline == SGR.SingleUnderline) $ do+ SDL.rendererDrawColor renderer $= (V4._w .~ 255) (V4.vector fgColor)+ SDL.drawLine+ renderer+ (P (V2 (fromIntegral col * cellWidth) (fromIntegral line * cellHeight + cellHeight - 2)))+ (P (V2 (fromIntegral col * cellWidth + cellWidth) (fromIntegral line * cellHeight + cellHeight - 2)))++fontCellWidth, fontCellHeight :: CInt+(fontCellWidth, fontCellHeight) = (16, 16)++cellWidth, cellHeight :: CInt+(cellWidth, cellHeight) = (14, 16)++charPosition :: Char -> Point V2 CInt+charPosition char = case fromEnum char of+ charCode+ | charCode < 256 -> P (V2 ((fromIntegral charCode `rem` 16) * fontCellWidth) ((fromIntegral charCode `div` 16) * fontCellHeight))+ | otherwise -> invalidCharP+ where+ invalidCharP = P (V2 (15 * fontCellWidth) (7 * fontCellHeight))++charSize :: V2 CInt+charSize = V2 fontCellWidth fontCellHeight++interruptibleWaitEvent :: IO SDL.Event+interruptibleWaitEvent = do+ result <- SDL.waitEventTimeout 50+ case result of+ Just e -> pure e+ Nothing -> interruptibleWaitEvent
+ src/System/Terminal/Emulator/SDL/Pty.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE ScopedTypeVariables #-}++module System.Terminal.Emulator.SDL.Pty where++import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.Exception (bracket, try)+import Data.ByteString (ByteString)+import System.Environment (getEnvironment)+import System.Posix.Pty+import System.Process++termEnvVarName :: String+termEnvVarName = "xterm"++launchPty :: (Int, Int) -> (STM ByteString) -> (STM (Int, Int)) -> (ByteString -> IO ()) -> IO ()+launchPty initialSize getInput getResize onOutput = do+ currentEnv <- getEnvironment++ let environ :: [(String, String)]+ environ =+ filter ((/= "TERM") . fst) currentEnv+ <> [("TERM", termEnvVarName)]++ bracket+ (spawnWithPty (Just environ) False "/bin/bash" [] initialSize)+ ( \(pty, processHandle) -> do+ closePty pty+ _ <- waitForProcess processHandle+ pure ()+ )+ ( \(pty, _) -> do+ let inputLoop :: IO ()+ inputLoop = do+ event <- atomically $ (getInput >>= pure . Left) `orElse` (getResize >>= pure . Right)+ case event of+ Left inputBuf -> writePty pty inputBuf+ Right newSize -> resizePty pty newSize+ inputLoop++ let readNext :: IO ()+ readNext = do+ result <- try $ do+ threadWaitReadPty pty+ readPty pty+ case result of+ Right output -> do+ onOutput output+ readNext+ Left (_ :: IOError) -> do+ pure ()++ withAsync inputLoop $ \inputLoopAsync -> do+ link inputLoopAsync+ readNext+ )