├── .gitignore ├── font.bmp ├── hs-term-emulator ├── test │ ├── Spec.hs │ └── System │ │ └── Terminal │ │ └── Emulator │ │ ├── Term │ │ ├── SimpleTerm.hs │ │ ├── ArbitraryTermAtom.hs │ │ └── ProcessSpec.hs │ │ └── Parsing │ │ └── InternalSpec.hs ├── CHANGELOG.md ├── src │ └── System │ │ └── Terminal │ │ └── Emulator │ │ ├── Parsing.hs │ │ ├── KeyboardInput.hs │ │ ├── TermLines.hs │ │ ├── Attrs.hs │ │ ├── Term │ │ ├── Resize.hs │ │ └── Process.hs │ │ ├── DECPrivateMode.hs │ │ ├── KeyboardInput │ │ └── KeyPressToPty.hs │ │ ├── Term.hs │ │ └── Parsing │ │ ├── Types.hs │ │ └── Internal.hs ├── bench │ └── Main.hs ├── LICENSE └── hs-term-emulator.cabal ├── cabal.project ├── screenshots ├── screenshot_vim_01.png ├── screenshot_htop_01.png └── screenshot_shell_01.png ├── hs-sdl-term-emulator ├── CHANGELOG.md ├── Main.hs ├── LICENSE ├── src │ └── System │ │ └── Terminal │ │ └── Emulator │ │ └── SDL │ │ ├── ImageFont.hs │ │ ├── Pty.hs │ │ ├── KeyboardTranslate.hs │ │ └── LibMain.hs └── hs-sdl-term-emulator.cabal ├── pkgconfig └── sdl2.pc ├── devpacks.toml └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | /dist-newstyle/ 2 | cabal.project.local 3 | -------------------------------------------------------------------------------- /font.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bitc/hs-term-emulator/HEAD/font.bmp -------------------------------------------------------------------------------- /hs-term-emulator/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: hs-sdl-term-emulator/ 2 | hs-term-emulator/ 3 | 4 | optimization: 2 5 | -------------------------------------------------------------------------------- /screenshots/screenshot_vim_01.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bitc/hs-term-emulator/HEAD/screenshots/screenshot_vim_01.png -------------------------------------------------------------------------------- /screenshots/screenshot_htop_01.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bitc/hs-term-emulator/HEAD/screenshots/screenshot_htop_01.png -------------------------------------------------------------------------------- /screenshots/screenshot_shell_01.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bitc/hs-term-emulator/HEAD/screenshots/screenshot_shell_01.png -------------------------------------------------------------------------------- /hs-term-emulator/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for hs-term-emulator 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /hs-sdl-term-emulator/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for hs-sdl-term-emulator 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /hs-sdl-term-emulator/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified System.Terminal.Emulator.SDL.LibMain 4 | 5 | main :: IO () 6 | main = System.Terminal.Emulator.SDL.LibMain.main 7 | -------------------------------------------------------------------------------- /hs-term-emulator/src/System/Terminal/Emulator/Parsing.hs: -------------------------------------------------------------------------------- 1 | module System.Terminal.Emulator.Parsing 2 | ( parseTermAtom, 3 | ) 4 | where 5 | 6 | import System.Terminal.Emulator.Parsing.Internal (parseTermAtom) 7 | -------------------------------------------------------------------------------- /pkgconfig/sdl2.pc: -------------------------------------------------------------------------------- 1 | # sdl pkg-config source file 2 | 3 | Name: sdl2 4 | Description: Simple DirectMedia Layer is a cross-platform multimedia library designed to provide low level access to audio, keyboard, mouse, joystick, 3D hardware via OpenGL, and 2D video framebuffer. 5 | Version: 2.0.7 6 | Requires: 7 | Conflicts: 8 | Libs: -Wl,--enable-new-dtags -lSDL2 9 | Libs.private: -lSDL2 -Wl,--no-undefined -lm -ldl -lpthread -lrt 10 | Cflags: -D_REENTRANT 11 | -------------------------------------------------------------------------------- /devpacks.toml: -------------------------------------------------------------------------------- 1 | version = 0 2 | 3 | [packages] 4 | [packages.base] 5 | 6 | ghc = "8.10.3" 7 | haskell_cabal_install = "3.4.0.0" 8 | ncurses = { linux = "6.2" } 9 | zlib = { version = "1.2.11", windows = false } 10 | libsdl2 = "2.0.7" 11 | 12 | [shell] 13 | [shell.env] 14 | 15 | C_INCLUDE_PATH = [ 16 | "${libsdl2}/include/SDL2", 17 | "${zlib}/include" 18 | ] 19 | 20 | LIBRARY_PATH = [ 21 | "${libsdl2}/lib", 22 | "${ncurses}/lib", 23 | "${zlib}/lib" 24 | ] 25 | 26 | # TODO This is broken. Seems like it must be an absolute path. For now run 27 | # manually: 28 | # 29 | # export PKG_CONFIG_PATH=`pwd`/pkgconfig 30 | # 31 | PKG_CONFIG_PATH = "./pkgconfig" 32 | -------------------------------------------------------------------------------- /hs-term-emulator/test/System/Terminal/Emulator/Term/SimpleTerm.hs: -------------------------------------------------------------------------------- 1 | module System.Terminal.Emulator.Term.SimpleTerm 2 | ( SimpleTerm (..), 3 | termToSimpleTerm, 4 | ) 5 | where 6 | 7 | import Control.Lens 8 | import Data.Foldable (toList) 9 | import qualified Data.Vector.Unboxed as VU 10 | import System.Terminal.Emulator.Term (Term, cursorPos, scrollBackLines, termScreen) 11 | import System.Terminal.Emulator.TermLines (TermLine) 12 | 13 | -- | A simplified terminal that doesn't have an alt screen or colors 14 | data SimpleTerm = SimpleTerm 15 | { st_ScrollBackLines :: [[Char]], 16 | st_Screen :: [[Char]], 17 | st_CursorPos :: (Int, Int) 18 | } 19 | deriving (Show, Eq, Ord) 20 | 21 | termToSimpleTerm :: Term -> SimpleTerm 22 | termToSimpleTerm term = 23 | SimpleTerm 24 | { st_ScrollBackLines = map termLineToStLine $ toList $ term ^. scrollBackLines, 25 | st_Screen = map termLineToStLine $ toList $ term ^. termScreen, 26 | st_CursorPos = term ^. cursorPos 27 | } 28 | 29 | termLineToStLine :: TermLine -> [Char] 30 | termLineToStLine = map fst . VU.toList 31 | -------------------------------------------------------------------------------- /hs-term-emulator/bench/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Criterion.Main 4 | import System.Terminal.Emulator.Parsing.Types 5 | import System.Terminal.Emulator.Term (mkTerm) 6 | import System.Terminal.Emulator.Term.Process (processTermAtoms) 7 | 8 | lotsOfAAAAA :: Int -> [TermAtom] 9 | lotsOfAAAAA numRows = 10 | concat 11 | ( replicate 12 | numRows 13 | ( ( replicate 30 (TermAtom_VisibleChar 'A') 14 | <> [ TermAtom_SingleCharacterFunction Control_CarriageReturn, 15 | TermAtom_SingleCharacterFunction Control_LineFeed 16 | ] 17 | ) 18 | ) 19 | ) 20 | 21 | main :: IO () 22 | main = 23 | defaultMain 24 | [ bgroup 25 | "term" 26 | [ bench "As 10" $ whnf (processTermAtoms (lotsOfAAAAA 10)) (mkTerm (40, 40)), 27 | bench "As 100" $ whnf (processTermAtoms (lotsOfAAAAA 100)) (mkTerm (40, 40)), 28 | bench "As 1000" $ whnf (processTermAtoms (lotsOfAAAAA 1000)) (mkTerm (40, 40)), 29 | bench "As 10000" $ whnf (processTermAtoms (lotsOfAAAAA 10000)) (mkTerm (40, 40)) 30 | ] 31 | ] 32 | -------------------------------------------------------------------------------- /hs-term-emulator/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (C) 2021 The hs-term-emulator Authors (see AUTHORS file) 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /hs-sdl-term-emulator/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (C) 2021 The hs-term-emulator Authors (see AUTHORS file) 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /hs-sdl-term-emulator/src/System/Terminal/Emulator/SDL/ImageFont.hs: -------------------------------------------------------------------------------- 1 | module System.Terminal.Emulator.SDL.ImageFont where 2 | 3 | import Control.Monad (forM_) 4 | import Data.Bits (shiftR, (.&.), (.|.)) 5 | import Data.Word (Word32) 6 | import Foreign.Ptr (Ptr, castPtr) 7 | import Foreign.Storable (peekElemOff, pokeElemOff) 8 | import Linear (V2 (..)) 9 | import qualified SDL as SDL 10 | 11 | loadImageFont :: IO SDL.Surface 12 | loadImageFont = do 13 | bmp <- SDL.loadBMP "font.bmp" 14 | rgba <- convertGrayscaleToAlpha bmp 15 | SDL.freeSurface bmp 16 | pure rgba 17 | 18 | -- | Creates a new surface in RGBA format where the color of all pixels is 19 | -- white, and the alpha channel is taken from the grayscale values of the 20 | -- source surface 21 | convertGrayscaleToAlpha :: 22 | -- | 'Surface' to copy from 23 | SDL.Surface -> 24 | -- | New 'Surface' is created 25 | IO SDL.Surface 26 | convertGrayscaleToAlpha grayscaleRGB = do 27 | size@(V2 width height) <- SDL.surfaceDimensions grayscaleRGB 28 | rgba <- SDL.createRGBSurface size SDL.RGBA8888 29 | _ <- SDL.surfaceBlit grayscaleRGB Nothing rgba Nothing 30 | 31 | SDL.lockSurface rgba 32 | pixelsPtr <- SDL.surfacePixels rgba 33 | let pixels :: Ptr Word32 34 | pixels = castPtr pixelsPtr 35 | forM_ [0 .. fromIntegral (width * height) - 1] $ \i -> do 36 | pixel <- peekElemOff pixels i 37 | let intensity = (pixel .&. 0xFF000000) `shiftR` 24 38 | pokeElemOff pixels i (intensity .|. 0xFFFFFF00) 39 | SDL.unlockSurface rgba 40 | 41 | pure rgba 42 | -------------------------------------------------------------------------------- /hs-sdl-term-emulator/src/System/Terminal/Emulator/SDL/Pty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module System.Terminal.Emulator.SDL.Pty where 4 | 5 | import Control.Concurrent.Async 6 | import Control.Concurrent.STM 7 | import Control.Exception (bracket, try) 8 | import Data.ByteString (ByteString) 9 | import System.Environment (getEnvironment) 10 | import System.Posix.Pty 11 | import System.Process 12 | 13 | termEnvVarName :: String 14 | termEnvVarName = "xterm" 15 | 16 | launchPty :: (Int, Int) -> (STM ByteString) -> (STM (Int, Int)) -> (ByteString -> IO ()) -> IO () 17 | launchPty initialSize getInput getResize onOutput = do 18 | currentEnv <- getEnvironment 19 | 20 | let environ :: [(String, String)] 21 | environ = 22 | filter ((/= "TERM") . fst) currentEnv 23 | <> [("TERM", termEnvVarName)] 24 | 25 | bracket 26 | (spawnWithPty (Just environ) False "/bin/bash" [] initialSize) 27 | ( \(pty, processHandle) -> do 28 | closePty pty 29 | _ <- waitForProcess processHandle 30 | pure () 31 | ) 32 | ( \(pty, _) -> do 33 | let inputLoop :: IO () 34 | inputLoop = do 35 | event <- atomically $ (getInput >>= pure . Left) `orElse` (getResize >>= pure . Right) 36 | case event of 37 | Left inputBuf -> writePty pty inputBuf 38 | Right newSize -> resizePty pty newSize 39 | inputLoop 40 | 41 | let readNext :: IO () 42 | readNext = do 43 | result <- try $ do 44 | threadWaitReadPty pty 45 | readPty pty 46 | case result of 47 | Right output -> do 48 | onOutput output 49 | readNext 50 | Left (_ :: IOError) -> do 51 | pure () 52 | 53 | withAsync inputLoop $ \inputLoopAsync -> do 54 | link inputLoopAsync 55 | readNext 56 | ) 57 | -------------------------------------------------------------------------------- /hs-sdl-term-emulator/hs-sdl-term-emulator.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: hs-sdl-term-emulator 3 | version: 0.1.0.4 4 | synopsis: Terminal Emulator written in Haskell, SDL2 Backend 5 | description: See: https://github.com/bitc/hs-term-emulator#readme 6 | homepage: https://github.com/bitc/hs-term-emulator 7 | bug-reports: https://github.com/bitc/hs-term-emulator/issues 8 | license: MIT 9 | license-file: LICENSE 10 | author: Bit Connor 11 | maintainer: https://github.com/bitc 12 | category: Terminal 13 | extra-source-files: CHANGELOG.md 14 | 15 | source-repository head 16 | type: git 17 | location: https://github.com/bitc/hs-term-emulator.git 18 | 19 | library 20 | -- cabal-fmt: expand src 21 | exposed-modules: 22 | System.Terminal.Emulator.SDL.ImageFont 23 | System.Terminal.Emulator.SDL.KeyboardTranslate 24 | System.Terminal.Emulator.SDL.LibMain 25 | System.Terminal.Emulator.SDL.Pty 26 | 27 | build-depends: 28 | , ansi-terminal >=0.10 && <0.12 29 | , async ^>=2.2.2 30 | , base >=4.10 && <5 31 | , bytestring 32 | , conduit ^>=1.3.0 33 | , conduit-extra ^>=1.3.0 34 | , hs-term-emulator ==0.1.0.4 35 | , lens >=4.19 && <6 36 | , linear ^>=1.21 37 | , posix-pty ^>=0.2.2 38 | , process 39 | , sdl2 ^>=2.5.3.0 40 | , stm 41 | , stm-conduit ^>=4.0.1 42 | , vector ^>=0.12.2.0 43 | 44 | hs-source-dirs: src 45 | default-language: Haskell2010 46 | ghc-options: -Wall -Werror=incomplete-patterns -Werror=missing-fields 47 | 48 | executable hs-sdl-term-emulator 49 | main-is: Main.hs 50 | build-depends: 51 | , base >=4.8 && <5 52 | , hs-sdl-term-emulator 53 | 54 | default-language: Haskell2010 55 | ghc-options: -Wall -threaded 56 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # hs-term-emulator 2 | 3 | ![https://twitter.com/bitconnordev](https://img.shields.io/twitter/follow/bitconnordev?style=social) 4 | 5 | This is a Terminal Emulator (like xterm) implemented entirely in Haskell. 6 | 7 | There are two packages: 8 | 9 | 1. [hs-term-emulator](https://hackage.haskell.org/package/hs-term-emulator): 10 | This is a "pure" package that does no Input/Output and has no actual GUI. 11 | 12 | It provides a data structure representing the state of a terminal (See 13 | [System.Terminal.Emulator.Term](https://hackage.haskell.org/package/hs-term-emulator-0.1.0.4/docs/System-Terminal-Emulator-Term.html)), 14 | and functions for parsing the terminal output bytestream and updating the 15 | 'Term' datastructure. 16 | 17 | It also has functions for translating user KeyPress actions from a typical 18 | physical keyboard into the correct escape sequences that should be fed 19 | back into the terminal pty. 20 | 21 | 2. [hs-sdl-term-emulator](https://hackage.haskell.org/package/hs-sdl-term-emulator): 22 | A proof-of-concept implementation of a real usable terminal. 23 | 24 | This builds upon the previous package, and uses the 25 | [sdl2](https://hackage.haskell.org/package/sdl2) package to create a 26 | desktop window that renders the contents of the terminal. It also listens 27 | to keyboard presses and sends them back into the terminal. 28 | 29 | 30 | ## Screenshots 31 | 32 | ![screenshot_shell_01](screenshots/screenshot_shell_01.png) 33 | 34 | ![screenshot_htop_01](screenshots/screenshot_htop_01.png) 35 | 36 | ![screenshot_vim_01](screenshots/screenshot_vim_01.png) 37 | 38 | ## Misc Development Tricks 39 | 40 | Here is a good ghci trick: 41 | 42 | :def! R \_ -> Prelude.return (":!clear\n:r\n:main") 43 | :R 44 | 45 | Running `cabal-fmt`: 46 | 47 | $ mkdir -p ./.cabal/bin 48 | $ cabal v2-install cabal-fmt --installdir=./.cabal/bin --overwrite-policy=always 49 | $ ./.cabal/bin/cabal-fmt --version 50 | -------------------------------------------------------------------------------- /hs-term-emulator/src/System/Terminal/Emulator/KeyboardInput.hs: -------------------------------------------------------------------------------- 1 | module System.Terminal.Emulator.KeyboardInput 2 | ( KeyboardState (..), 3 | initialKeyboardState, 4 | KeyPress (..), 5 | KeyModifiers (..), 6 | SpecialKey (..), 7 | ) 8 | where 9 | 10 | data KeyboardState = KeyboardState 11 | { keyboardState_DECPAM :: !Bool, 12 | keyboardState_DECCKM :: !Bool, 13 | -- | Set using Keyboard Action Mode (KAM) 14 | keyboardState_Locked :: !Bool, 15 | -- | Set using Automatic Newline / Normal Linefeed (LNM) 16 | keyboardState_CRLF :: !Bool 17 | } 18 | deriving (Show, Eq, Ord) 19 | 20 | initialKeyboardState :: KeyboardState 21 | initialKeyboardState = 22 | KeyboardState 23 | { keyboardState_DECPAM = False, 24 | keyboardState_DECCKM = False, 25 | keyboardState_Locked = False, 26 | keyboardState_CRLF = False 27 | } 28 | 29 | data KeyPress 30 | = -- | The char must be a plain-old regular "visible" character (or ' '). 31 | -- Specifically, you should not put '\n' or '\b' (use 'SpecialKey' for 32 | -- that) 33 | KeyPress_Char !Char !KeyModifiers 34 | | -- | Used for a key press of a 'SpecialKey'. If a 'SpecialKey' doesn't 35 | -- exist (for example "Ctrl", or "CapsLock") then no 'KeyPress' event 36 | -- should be generated 37 | KeyPress_SpecialKey !SpecialKey !KeyModifiers 38 | deriving (Eq, Ord, Show) 39 | 40 | data KeyModifiers = KeyModifiers 41 | { shift :: !Bool, 42 | ctrl :: !Bool, 43 | alt :: !Bool, 44 | capsLock :: !Bool 45 | } 46 | deriving (Eq, Ord, Show) 47 | 48 | data SpecialKey 49 | = SpecialKey_Escape 50 | | SpecialKey_F1 51 | | SpecialKey_F2 52 | | SpecialKey_F3 53 | | SpecialKey_F4 54 | | SpecialKey_F5 55 | | SpecialKey_F6 56 | | SpecialKey_F7 57 | | SpecialKey_F8 58 | | SpecialKey_F9 59 | | SpecialKey_F10 60 | | SpecialKey_F11 61 | | SpecialKey_F12 62 | | SpecialKey_Insert 63 | | SpecialKey_Delete 64 | | SpecialKey_Home 65 | | SpecialKey_End 66 | | SpecialKey_PageUp 67 | | SpecialKey_PageDown 68 | | SpecialKey_Tab 69 | | SpecialKey_Enter 70 | | SpecialKey_Backspace 71 | | SpecialKey_ArrowLeft 72 | | SpecialKey_ArrowRight 73 | | SpecialKey_ArrowUp 74 | | SpecialKey_ArrowDown 75 | deriving (Eq, Ord, Show) 76 | -------------------------------------------------------------------------------- /hs-term-emulator/hs-term-emulator.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: hs-term-emulator 3 | version: 0.1.0.4 4 | synopsis: Terminal Emulator written in 100% Haskell 5 | description: See: https://github.com/bitc/hs-term-emulator#readme 6 | homepage: https://github.com/bitc/hs-term-emulator 7 | bug-reports: https://github.com/bitc/hs-term-emulator/issues 8 | license: MIT 9 | license-file: LICENSE 10 | author: Bit Connor 11 | maintainer: https://github.com/bitc 12 | category: Terminal 13 | extra-source-files: CHANGELOG.md 14 | 15 | source-repository head 16 | type: git 17 | location: https://github.com/bitc/hs-term-emulator.git 18 | 19 | library 20 | -- cabal-fmt: expand src 21 | exposed-modules: 22 | System.Terminal.Emulator.Attrs 23 | System.Terminal.Emulator.DECPrivateMode 24 | System.Terminal.Emulator.KeyboardInput 25 | System.Terminal.Emulator.KeyboardInput.KeyPressToPty 26 | System.Terminal.Emulator.Parsing 27 | System.Terminal.Emulator.Parsing.Internal 28 | System.Terminal.Emulator.Parsing.Types 29 | System.Terminal.Emulator.Term 30 | System.Terminal.Emulator.Term.Process 31 | System.Terminal.Emulator.Term.Resize 32 | System.Terminal.Emulator.TermLines 33 | 34 | build-depends: 35 | , ansi-terminal >=0.10 && <0.12 36 | , attoparsec >=0.13.2.1 && <0.15 37 | , base >=4.8 && <5 38 | , bytestring 39 | , containers >=0.6.0.1 && <7 40 | , lens >=4.19 && <6 41 | , text 42 | , vector ^>=0.12.2.0 43 | 44 | hs-source-dirs: src 45 | default-language: Haskell2010 46 | ghc-options: -Wall -Werror=incomplete-patterns -Werror=missing-fields 47 | 48 | test-suite spec 49 | type: exitcode-stdio-1.0 50 | main-is: Spec.hs 51 | 52 | -- cabal-fmt: expand test -Spec 53 | other-modules: 54 | System.Terminal.Emulator.Parsing.InternalSpec 55 | System.Terminal.Emulator.Term.ArbitraryTermAtom 56 | System.Terminal.Emulator.Term.ProcessSpec 57 | System.Terminal.Emulator.Term.SimpleTerm 58 | 59 | hs-source-dirs: test 60 | build-depends: 61 | , ansi-terminal >=0.10 && <0.12 62 | , attoparsec >=0.13.2.1 && <0.15 63 | , base >=4.8 && <5 64 | , hs-term-emulator 65 | , hspec ^>=2.8.2 66 | , lens >=4.19 && <6 67 | , QuickCheck ^>=2.14.0 68 | , text 69 | , vector ^>=0.12.2.0 70 | 71 | default-language: Haskell2010 72 | build-tool-depends: hspec-discover:hspec-discover ==2.* 73 | other-extensions: TemplateHaskell 74 | ghc-options: 75 | -Wall -threaded -Werror=incomplete-patterns -Werror=missing-fields 76 | 77 | benchmark bench 78 | type: exitcode-stdio-1.0 79 | main-is: Main.hs 80 | 81 | -- cabal-fmt: expand bench -Main 82 | other-modules: 83 | hs-source-dirs: bench 84 | build-depends: 85 | , base >=4.8 && <5 86 | , criterion ^>=1.5.9.0 87 | , hs-term-emulator 88 | 89 | default-language: Haskell2010 90 | ghc-options: 91 | -Wall -threaded -Werror=incomplete-patterns -Werror=missing-fields 92 | -------------------------------------------------------------------------------- /hs-term-emulator/test/System/Terminal/Emulator/Term/ArbitraryTermAtom.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module System.Terminal.Emulator.Term.ArbitraryTermAtom where 4 | 5 | import Data.Text (Text) 6 | import qualified Data.Text as T 7 | import qualified Data.Vector as V 8 | import System.Console.ANSI.Types (SGR) 9 | import qualified System.Console.ANSI.Types as SGR 10 | import System.Terminal.Emulator.Parsing.Types (ControlSequenceIntroducer (..), EscapeSequence (..), OperatingSystemCommand (..), TermAtom (..)) 11 | import Test.QuickCheck 12 | 13 | arbitraryVisibleChar, arbitrarySingleCharacterFunction, arbitraryEscapeSequence :: Gen TermAtom 14 | arbitraryVisibleChar = TermAtom_VisibleChar <$> arbitraryPrintableChar 15 | arbitrarySingleCharacterFunction = TermAtom_SingleCharacterFunction <$> arbitraryBoundedEnum 16 | arbitraryEscapeSequence = 17 | TermAtom_EscapeSequence 18 | <$> oneof 19 | [ pure Esc_ReverseIndex, 20 | pure Esc_RIS, 21 | pure Esc_DECPAM, 22 | pure (ESC_SetG0CharacterSet "%6"), 23 | (Esc_CSI <$> arbitraryCSI), 24 | (Esc_OSC <$> arbitraryOSI) 25 | ] 26 | 27 | chooseNat :: Gen Int 28 | chooseNat = chooseInt (1, 30) 29 | 30 | arbitraryCSI :: Gen ControlSequenceIntroducer 31 | arbitraryCSI = 32 | oneof 33 | [ CSI_CharacterPositionAbsolute <$> chooseNat, 34 | CSI_CharacterPositionRelative <$> chooseNat, 35 | CSI_CursorUp <$> chooseNat, 36 | CSI_CursorDown <$> chooseNat, 37 | CSI_CursorForward <$> chooseNat, 38 | CSI_CursorBack <$> chooseNat, 39 | CSI_EraseInLine <$> arbitraryBoundedEnum, 40 | CSI_InsertBlankCharacters <$> chooseNat, 41 | CSI_InsertBlankLines <$> chooseNat, 42 | CSI_DeleteChars <$> chooseNat, 43 | CSI_DeleteLines <$> chooseNat, 44 | CSI_CursorCharacterAbsolute <$> chooseNat, 45 | CSI_CursorPosition <$> chooseNat <*> chooseNat, 46 | CSI_HorizontalVerticalPosition <$> chooseNat <*> chooseNat, 47 | CSI_LinePositionAbsolute <$> chooseNat, 48 | CSI_LinePositionRelative <$> chooseNat, 49 | CSI_ScrollUp <$> chooseNat, 50 | CSI_ScrollDown <$> chooseNat, 51 | CSI_EraseInDisplay <$> arbitraryBoundedEnum, 52 | CSI_EraseCharacters <$> chooseNat, 53 | CSI_WindowManipulation <$> arbitraryBoundedEnum, 54 | CSI_DeviceStatusReport <$> arbitraryBoundedEnum, 55 | pure CSI_SoftTerminalReset, 56 | CSI_SetMode <$> arbitraryBoundedEnum, 57 | CSI_ResetMode <$> arbitraryBoundedEnum, 58 | pure $ CSI_SendDeviceAttributes, 59 | CSI_SendDeviceAttributesSecondary <$> arbitraryBoundedEnum, 60 | CSI_RequestDECPrivateMode <$> arbitrary {- TODO ??? -}, 61 | CSI_DECSTBM <$> liftArbitrary chooseNat <*> liftArbitrary chooseNat, 62 | CSI_DECSET <$> arbitraryBoundedEnum, 63 | CSI_DECRST <$> arbitraryBoundedEnum, 64 | CSI_SGR <$> (V.fromList <$> (listOf arbitrarySGR)) 65 | ] 66 | 67 | arbitrarySGR :: Gen SGR 68 | arbitrarySGR = 69 | oneof 70 | [ pure SGR.Reset, 71 | SGR.SetConsoleIntensity <$> elements [SGR.BoldIntensity, SGR.FaintIntensity, SGR.NormalIntensity], 72 | SGR.SetUnderlining <$> elements [SGR.SingleUnderline, SGR.DoubleUnderline, SGR.NoUnderline], 73 | SGR.SetDefaultColor <$> arbConsoleLayer, 74 | SGR.SetColor <$> arbConsoleLayer <*> elements [SGR.Dull, SGR.Vivid] <*> arbitraryBoundedEnum 75 | ] 76 | where 77 | arbConsoleLayer = elements [SGR.Foreground, SGR.Background] 78 | 79 | arbitraryOSI :: Gen OperatingSystemCommand 80 | arbitraryOSI = 81 | oneof 82 | [ OSC_SetTitle <$> arbitrary <*> arbitrary <*> arbitraryPrintableText, 83 | OSC_ChangeTextForegroundColor <$> arbitraryPrintableText, 84 | pure $ OSC_RequestTextForegroundColor, 85 | OSC_ChangeTextBackgroundColor <$> arbitraryPrintableText, 86 | pure $ OSC_RequestTextBackgroundColor, 87 | pure $ OSC_ResetTextCursorColor 88 | ] 89 | 90 | arbitraryPrintableText :: Gen Text 91 | arbitraryPrintableText = T.pack <$> (listOf arbitraryPrintableChar) 92 | 93 | arbitraryTermAtom :: Gen TermAtom 94 | arbitraryTermAtom = 95 | oneof 96 | [ arbitraryVisibleChar, 97 | arbitrarySingleCharacterFunction, 98 | arbitraryEscapeSequence 99 | ] 100 | -------------------------------------------------------------------------------- /hs-term-emulator/src/System/Terminal/Emulator/TermLines.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | 4 | module System.Terminal.Emulator.TermLines 5 | ( TermLine, 6 | TermLines, 7 | empty, 8 | length, 9 | singleton, 10 | replicate, 11 | vIndex, 12 | head, 13 | last, 14 | take, 15 | takeLast, 16 | drop, 17 | dropLast, 18 | traverseWithIndex, 19 | toSeq, 20 | ) 21 | where 22 | 23 | import Control.Exception (assert) 24 | import Control.Lens 25 | import Data.Sequence (Seq) 26 | import qualified Data.Sequence as Seq 27 | import qualified Data.Vector.Unboxed as VU 28 | import System.Terminal.Emulator.Attrs (Cell) 29 | import Prelude hiding (drop, head, last, length, replicate, take) 30 | 31 | type TermLine = VU.Vector Cell 32 | 33 | type TermLines = StrictSeq TermLine 34 | 35 | newtype StrictSeq a = StrictSeq (Seq a) 36 | deriving (Show, Eq, Ord, Functor, Semigroup, Monoid, Foldable) 37 | 38 | -- | The empty sequence. 39 | empty :: StrictSeq a 40 | empty = StrictSeq Seq.empty 41 | {-# INLINE empty #-} 42 | 43 | -- | The number of elements in the sequence. 44 | length :: StrictSeq a -> Int 45 | length (StrictSeq v) = Seq.length v 46 | {-# INLINE length #-} 47 | 48 | singleton :: a -> StrictSeq a 49 | singleton x = x `seq` (StrictSeq (Seq.singleton x)) 50 | {-# INLINE singleton #-} 51 | 52 | -- | @replicate n x@ is a sequence consisting of n copies of x. 53 | replicate :: Int -> a -> StrictSeq a 54 | replicate n x = x `seq` (StrictSeq (Seq.replicate n x)) 55 | {-# INLINE replicate #-} 56 | 57 | -- | A lens to the specified index of the sequence. Must be in range. 58 | vIndex :: Int -> Lens' (StrictSeq a) a 59 | vIndex i = 60 | lens getter setter 61 | where 62 | getter :: StrictSeq a -> a 63 | getter (StrictSeq v) = assert (i >= 0 && i < Seq.length v) $ (`Seq.index` i) v 64 | setter :: StrictSeq a -> a -> StrictSeq a 65 | setter (StrictSeq v) val = assert (i >= 0 && i < Seq.length v) $ val `seq` (StrictSeq (Seq.update i val v)) 66 | {-# INLINE getter #-} 67 | {-# INLINE setter #-} 68 | {-# INLINE vIndex #-} 69 | 70 | -- | First element. Must be nonempty 71 | head :: StrictSeq a -> a 72 | head (StrictSeq v) = let x Seq.:< _ = Seq.viewl v in x 73 | {-# INLINE head #-} 74 | 75 | -- | Last element. Must be nonempty 76 | last :: StrictSeq a -> a 77 | last (StrictSeq v) = let _ Seq.:> x = Seq.viewr v in x 78 | {-# INLINE last #-} 79 | 80 | -- | The first @i@ elements of a sequence. If @i@ is negative, @take i s@ 81 | -- yields the empty sequence. If the sequence contains fewer than @i@ 82 | -- elements, the whole sequence is returned. 83 | take :: Int -> StrictSeq a -> StrictSeq a 84 | take i (StrictSeq v) = StrictSeq (Seq.take i v) 85 | {-# INLINE take #-} 86 | 87 | -- | The last @i@ elements of a sequence. If @i@ is negative, @takeLast i s@ 88 | -- yields the empty sequence. If the sequence contains fewer than @i@ 89 | -- elements, the whole sequence is returned. 90 | takeLast :: Int -> StrictSeq a -> StrictSeq a 91 | takeLast i (StrictSeq v) = StrictSeq (Seq.drop (Seq.length v - i) v) 92 | {-# INLINE takeLast #-} 93 | 94 | -- | Elements of a sequence after the first @i@. If @i@ is negative, @drop i 95 | -- s@ yields the whole sequence. If the sequence contains fewer than @i@ 96 | -- elements, the empty sequence is returned. 97 | drop :: Int -> StrictSeq a -> StrictSeq a 98 | drop i (StrictSeq v) = StrictSeq (Seq.drop i v) 99 | {-# INLINE drop #-} 100 | 101 | -- | Elements of a sequence after the first @i@ last elements. If @i@ is 102 | -- negative, @dropLast i s@ yields the whole sequence. If the sequence 103 | -- contains fewer than @i@ elements, the empty sequence is returned. 104 | dropLast :: Int -> StrictSeq a -> StrictSeq a 105 | dropLast i (StrictSeq v) = StrictSeq (Seq.take (Seq.length v - i) v) 106 | {-# INLINE dropLast #-} 107 | 108 | -- | @traverseWithIndex@ is a version of @traverse@ that also offers access to 109 | -- the index of each element. 110 | traverseWithIndex :: Applicative f => (Int -> a -> f b) -> StrictSeq a -> f (StrictSeq b) 111 | traverseWithIndex f (StrictSeq v) = StrictSeq <$> (Seq.traverseWithIndex f v) 112 | {-# INLINE traverseWithIndex #-} 113 | 114 | toSeq :: StrictSeq a -> Seq a 115 | toSeq (StrictSeq v) = v 116 | {-# INLINE toSeq #-} 117 | -------------------------------------------------------------------------------- /hs-sdl-term-emulator/src/System/Terminal/Emulator/SDL/KeyboardTranslate.hs: -------------------------------------------------------------------------------- 1 | module System.Terminal.Emulator.SDL.KeyboardTranslate where 2 | 3 | import Data.Char (isAlpha, toUpper) 4 | import qualified SDL as SDL 5 | import System.Terminal.Emulator.KeyboardInput (KeyModifiers (..), KeyPress (..), SpecialKey (..)) 6 | 7 | translateSDLKey :: SDL.Keysym -> Maybe KeyPress 8 | translateSDLKey keysym 9 | | keycode `elem` [SDL.KeycodeReturn, SDL.KeycodeReturn2, SDL.KeycodeKPEnter] = Just $ KeyPress_SpecialKey SpecialKey_Enter modifiers 10 | | keycode `elem` [SDL.KeycodeBackspace] = Just $ KeyPress_SpecialKey SpecialKey_Backspace modifiers 11 | | keycode `elem` [SDL.KeycodeTab, SDL.KeycodeKPTab] = Just $ KeyPress_SpecialKey SpecialKey_Tab modifiers 12 | | keycode `elem` [SDL.KeycodeEscape] = Just $ KeyPress_SpecialKey SpecialKey_Escape modifiers 13 | | keycode `elem` [SDL.KeycodeUp, SDL.KeycodeKP8] = Just $ KeyPress_SpecialKey SpecialKey_ArrowUp modifiers 14 | | keycode `elem` [SDL.KeycodeDown, SDL.KeycodeKP2] = Just $ KeyPress_SpecialKey SpecialKey_ArrowDown modifiers 15 | | keycode `elem` [SDL.KeycodeLeft, SDL.KeycodeKP4] = Just $ KeyPress_SpecialKey SpecialKey_ArrowLeft modifiers 16 | | keycode `elem` [SDL.KeycodeRight, SDL.KeycodeKP6] = Just $ KeyPress_SpecialKey SpecialKey_ArrowRight modifiers 17 | | keycode `elem` [SDL.KeycodeInsert, SDL.KeycodeKP0] = Just $ KeyPress_SpecialKey SpecialKey_Insert modifiers 18 | | keycode `elem` [SDL.KeycodeDelete, SDL.KeycodeKPBackspace] = Just $ KeyPress_SpecialKey SpecialKey_Delete modifiers 19 | | keycode `elem` [SDL.KeycodeHome, SDL.KeycodeKP7] = Just $ KeyPress_SpecialKey SpecialKey_Home modifiers 20 | | keycode `elem` [SDL.KeycodeEnd, SDL.KeycodeKP1] = Just $ KeyPress_SpecialKey SpecialKey_End modifiers 21 | | keycode `elem` [SDL.KeycodePageUp, SDL.KeycodeKP9] = Just $ KeyPress_SpecialKey SpecialKey_PageUp modifiers 22 | | keycode `elem` [SDL.KeycodePageDown, SDL.KeycodeKP3] = Just $ KeyPress_SpecialKey SpecialKey_PageDown modifiers 23 | | keycode == SDL.KeycodeF1 = Just $ KeyPress_SpecialKey SpecialKey_F1 modifiers 24 | | keycode == SDL.KeycodeF2 = Just $ KeyPress_SpecialKey SpecialKey_F2 modifiers 25 | | keycode == SDL.KeycodeF3 = Just $ KeyPress_SpecialKey SpecialKey_F3 modifiers 26 | | keycode == SDL.KeycodeF4 = Just $ KeyPress_SpecialKey SpecialKey_F4 modifiers 27 | | keycode == SDL.KeycodeF5 = Just $ KeyPress_SpecialKey SpecialKey_F5 modifiers 28 | | keycode == SDL.KeycodeF6 = Just $ KeyPress_SpecialKey SpecialKey_F6 modifiers 29 | | keycode == SDL.KeycodeF7 = Just $ KeyPress_SpecialKey SpecialKey_F7 modifiers 30 | | keycode == SDL.KeycodeF8 = Just $ KeyPress_SpecialKey SpecialKey_F8 modifiers 31 | | keycode == SDL.KeycodeF9 = Just $ KeyPress_SpecialKey SpecialKey_F9 modifiers 32 | | keycode == SDL.KeycodeF10 = Just $ KeyPress_SpecialKey SpecialKey_F10 modifiers 33 | | keycode == SDL.KeycodeF11 = Just $ KeyPress_SpecialKey SpecialKey_F11 modifiers 34 | | keycode == SDL.KeycodeF12 = Just $ KeyPress_SpecialKey SpecialKey_F12 modifiers 35 | | keycodeNum >= 32 && keycodeNum <= 126 = Just $ KeyPress_Char (keySymToChar keysym) modifiers 36 | | otherwise = Nothing 37 | where 38 | keycode = SDL.keysymKeycode keysym 39 | SDL.Keycode keycodeNum = keycode 40 | modifiers = sdlKeyModifiers (SDL.keysymModifier keysym) 41 | 42 | sdlKeyModifiers :: SDL.KeyModifier -> KeyModifiers 43 | sdlKeyModifiers keyModifier = 44 | KeyModifiers 45 | { shift = SDL.keyModifierLeftShift keyModifier || SDL.keyModifierRightShift keyModifier, 46 | ctrl = SDL.keyModifierLeftCtrl keyModifier || SDL.keyModifierRightCtrl keyModifier, 47 | alt = SDL.keyModifierLeftAlt keyModifier || SDL.keyModifierRightAlt keyModifier, 48 | capsLock = SDL.keyModifierCapsLock keyModifier 49 | } 50 | 51 | keySymToChar :: SDL.Keysym -> Char 52 | keySymToChar keysym 53 | | isAlpha char = 54 | if shiftPressed /= SDL.keyModifierCapsLock keyModifier 55 | then toUpper char 56 | else char 57 | | otherwise = if shiftPressed then uppercaseNonAlpha char else char 58 | where 59 | keyModifier = SDL.keysymModifier keysym 60 | char = toEnum (fromIntegral keycode) 61 | SDL.Keycode keycode = SDL.keysymKeycode keysym 62 | shiftPressed = SDL.keyModifierLeftShift keyModifier || SDL.keyModifierRightShift keyModifier 63 | 64 | uppercaseNonAlpha :: Char -> Char 65 | uppercaseNonAlpha char | isAlpha char = toUpper char 66 | uppercaseNonAlpha '`' = '~' 67 | uppercaseNonAlpha '1' = '!' 68 | uppercaseNonAlpha '2' = '@' 69 | uppercaseNonAlpha '3' = '#' 70 | uppercaseNonAlpha '4' = '$' 71 | uppercaseNonAlpha '5' = '%' 72 | uppercaseNonAlpha '6' = '^' 73 | uppercaseNonAlpha '7' = '&' 74 | uppercaseNonAlpha '8' = '*' 75 | uppercaseNonAlpha '9' = '(' 76 | uppercaseNonAlpha '0' = ')' 77 | uppercaseNonAlpha '-' = '_' 78 | uppercaseNonAlpha '=' = '+' 79 | uppercaseNonAlpha '[' = '{' 80 | uppercaseNonAlpha ']' = '}' 81 | uppercaseNonAlpha ';' = ':' 82 | uppercaseNonAlpha '\'' = '"' 83 | uppercaseNonAlpha '\\' = '|' 84 | uppercaseNonAlpha ',' = '<' 85 | uppercaseNonAlpha '.' = '>' 86 | uppercaseNonAlpha '/' = '?' 87 | uppercaseNonAlpha char = char 88 | -------------------------------------------------------------------------------- /hs-term-emulator/src/System/Terminal/Emulator/Attrs.hs: -------------------------------------------------------------------------------- 1 | module System.Terminal.Emulator.Attrs where 2 | 3 | import Control.Lens 4 | import Data.Bits 5 | import Data.Word (Word32) 6 | import qualified System.Console.ANSI.Types as SGR 7 | 8 | -- | Attrs: 9 | -- 10 | -- @ 11 | -- 00000000 00000000 000000000000uuii 12 | -- ^^ fg ^^ ^^ bg ^^ ^^^^^^^^^^^^^^^^ 13 | -- 14 | -- ii : ConsoleIntensity (00 = Normal, 01 = Bold, 10 = Faint) 15 | -- uu : Underlining (00 = NoUnderline, 01 = SingleUnderline, 10 = DoubleUnderline) 16 | -- @ 17 | type Attrs = Word32 18 | 19 | blankAttrs :: Attrs 20 | blankAttrs = 0 21 | {-# INLINE blankAttrs #-} 22 | 23 | type Cell = (Char, Attrs) 24 | 25 | cellChar :: Lens' Cell Char 26 | cellChar = lens fst (\(_, attrs) c -> (c, attrs)) 27 | {-# INLINE cellChar #-} 28 | 29 | cellAttrs :: Lens' Cell Attrs 30 | cellAttrs = lens snd (\(char, _) attrs -> (char, attrs)) 31 | {-# INLINE cellAttrs #-} 32 | 33 | attrsFg :: Lens' Attrs (Maybe (SGR.ColorIntensity, SGR.Color)) 34 | attrsFg = lens getter setter 35 | where 36 | getter :: Attrs -> Maybe (SGR.ColorIntensity, SGR.Color) 37 | getter attrs = intToColor (shiftR attrs 24 .&. 0x000000FF) 38 | setter :: Attrs -> Maybe (SGR.ColorIntensity, SGR.Color) -> Attrs 39 | setter attrs color = (attrs .&. 0x00FFFFFF) .|. shiftL (colorToInt color) 24 40 | {-# INLINE getter #-} 41 | {-# INLINE setter #-} 42 | {-# INLINE attrsFg #-} 43 | 44 | attrsBg :: Lens' Attrs (Maybe (SGR.ColorIntensity, SGR.Color)) 45 | attrsBg = lens getter setter 46 | where 47 | getter :: Attrs -> Maybe (SGR.ColorIntensity, SGR.Color) 48 | getter attrs = intToColor (shiftR attrs 16 .&. 0x000000FF) 49 | setter :: Attrs -> Maybe (SGR.ColorIntensity, SGR.Color) -> Attrs 50 | setter attrs color = (attrs .&. 0xFF00FFFF) .|. shiftL (colorToInt color) 16 51 | {-# INLINE getter #-} 52 | {-# INLINE setter #-} 53 | {-# INLINE attrsBg #-} 54 | 55 | attrsIntensity :: Lens' Attrs SGR.ConsoleIntensity 56 | attrsIntensity = lens getter setter 57 | where 58 | getter :: Attrs -> SGR.ConsoleIntensity 59 | getter attrs 60 | | attrs .&. 0x00000003 == 0 = SGR.NormalIntensity 61 | | attrs .&. 0x00000003 == 1 = SGR.BoldIntensity 62 | | otherwise = SGR.FaintIntensity 63 | setter :: Attrs -> SGR.ConsoleIntensity -> Attrs 64 | setter attrs intensity = ((attrs .&. 0xFFFFFFFC) .|. consoleIntensityToInt intensity) 65 | {-# INLINE getter #-} 66 | {-# INLINE setter #-} 67 | {-# INLINE attrsIntensity #-} 68 | 69 | attrsUnderline :: Lens' Attrs SGR.Underlining 70 | attrsUnderline = lens getter setter 71 | where 72 | getter :: Attrs -> SGR.Underlining 73 | getter attrs 74 | | (shiftR attrs 2) .&. 0x00000003 == 0 = SGR.NoUnderline 75 | | (shiftR attrs 2) .&. 0x00000003 == 1 = SGR.SingleUnderline 76 | | otherwise = SGR.DoubleUnderline 77 | setter :: Attrs -> SGR.Underlining -> Attrs 78 | setter attrs underlining = ((attrs .&. 0xFFFFFFF3) .|. shiftL (underliningToInt underlining) 2) 79 | {-# INLINE getter #-} 80 | {-# INLINE setter #-} 81 | {-# INLINE attrsUnderline #-} 82 | 83 | intToColor :: Word32 -> Maybe (SGR.ColorIntensity, SGR.Color) 84 | intToColor 0 = Nothing 85 | intToColor 1 = Just (SGR.Dull, SGR.Black) 86 | intToColor 2 = Just (SGR.Dull, SGR.Red) 87 | intToColor 3 = Just (SGR.Dull, SGR.Green) 88 | intToColor 4 = Just (SGR.Dull, SGR.Yellow) 89 | intToColor 5 = Just (SGR.Dull, SGR.Blue) 90 | intToColor 6 = Just (SGR.Dull, SGR.Magenta) 91 | intToColor 7 = Just (SGR.Dull, SGR.Cyan) 92 | intToColor 8 = Just (SGR.Dull, SGR.White) 93 | intToColor 9 = Just (SGR.Vivid, SGR.Black) 94 | intToColor 10 = Just (SGR.Vivid, SGR.Red) 95 | intToColor 11 = Just (SGR.Vivid, SGR.Green) 96 | intToColor 12 = Just (SGR.Vivid, SGR.Yellow) 97 | intToColor 13 = Just (SGR.Vivid, SGR.Blue) 98 | intToColor 14 = Just (SGR.Vivid, SGR.Magenta) 99 | intToColor 15 = Just (SGR.Vivid, SGR.Cyan) 100 | intToColor 16 = Just (SGR.Vivid, SGR.White) 101 | intToColor i = error $ "intToColor: invalid int: " <> show i 102 | {-# INLINE intToColor #-} 103 | 104 | colorToInt :: Maybe (SGR.ColorIntensity, SGR.Color) -> Word32 105 | colorToInt Nothing = 0 106 | colorToInt (Just (SGR.Dull, SGR.Black)) = 1 107 | colorToInt (Just (SGR.Dull, SGR.Red)) = 2 108 | colorToInt (Just (SGR.Dull, SGR.Green)) = 3 109 | colorToInt (Just (SGR.Dull, SGR.Yellow)) = 4 110 | colorToInt (Just (SGR.Dull, SGR.Blue)) = 5 111 | colorToInt (Just (SGR.Dull, SGR.Magenta)) = 6 112 | colorToInt (Just (SGR.Dull, SGR.Cyan)) = 7 113 | colorToInt (Just (SGR.Dull, SGR.White)) = 8 114 | colorToInt (Just (SGR.Vivid, SGR.Black)) = 9 115 | colorToInt (Just (SGR.Vivid, SGR.Red)) = 10 116 | colorToInt (Just (SGR.Vivid, SGR.Green)) = 11 117 | colorToInt (Just (SGR.Vivid, SGR.Yellow)) = 12 118 | colorToInt (Just (SGR.Vivid, SGR.Blue)) = 13 119 | colorToInt (Just (SGR.Vivid, SGR.Magenta)) = 14 120 | colorToInt (Just (SGR.Vivid, SGR.Cyan)) = 15 121 | colorToInt (Just (SGR.Vivid, SGR.White)) = 16 122 | {-# INLINE colorToInt #-} 123 | 124 | consoleIntensityToInt :: SGR.ConsoleIntensity -> Word32 125 | consoleIntensityToInt SGR.NormalIntensity = 0 126 | consoleIntensityToInt SGR.BoldIntensity = 1 127 | consoleIntensityToInt SGR.FaintIntensity = 2 128 | {-# INLINE consoleIntensityToInt #-} 129 | 130 | underliningToInt :: SGR.Underlining -> Word32 131 | underliningToInt SGR.NoUnderline = 0 132 | underliningToInt SGR.SingleUnderline = 1 133 | underliningToInt SGR.DoubleUnderline = 2 134 | {-# INLINE underliningToInt #-} 135 | -------------------------------------------------------------------------------- /hs-term-emulator/src/System/Terminal/Emulator/Term/Resize.hs: -------------------------------------------------------------------------------- 1 | module System.Terminal.Emulator.Term.Resize 2 | ( resizeTerm, 3 | ) 4 | where 5 | 6 | import Control.Category ((>>>)) 7 | import Control.Exception (assert) 8 | import Control.Lens 9 | import qualified Data.Vector.Unboxed as VU 10 | import System.Terminal.Emulator.Term (Term, addScrollBackLines, altScreenActive, cursorPos, numCols, numRows, scrollBackLines, scrollBottom, scrollTop, termAlt, termAttrs, termScreen) 11 | import System.Terminal.Emulator.TermLines (TermLine, TermLines) 12 | import qualified System.Terminal.Emulator.TermLines as TL 13 | import Prelude hiding (lines) 14 | 15 | -- | This should be called when the user resizes the terminal window. 16 | -- 17 | -- You should also call 'System.Posix.Pty.resizePty', but only afterwards 18 | -- 19 | -- The tuple is in the shape @(newWidth, newHeight)@, both must be positive 20 | resizeTerm :: Term -> (Int, Int) -> Term 21 | resizeTerm term (newWidth, newHeight) = 22 | assert (newWidth > 0) $ 23 | assert (newHeight > 0) $ 24 | ( resizeTermWidth newWidth 25 | >>> resizeTermHeight newHeight 26 | >>> scrollTop .~ 0 27 | >>> scrollBottom .~ (newHeight - 1) 28 | ) 29 | term 30 | 31 | -- Internal function. Resize the terminal, only changing the width. 32 | resizeTermWidth :: Int -> Term -> Term 33 | resizeTermWidth newWidth term = 34 | ( numCols .~ newWidth 35 | >>> termScreen %~ fmap adjustLine 36 | >>> termAlt %~ fmap adjustLine 37 | >>> scrollBackLines %~ fmap adjustLine 38 | >>> cursorPos . _2 %~ min (newWidth - 1) 39 | ) 40 | term 41 | where 42 | oldWidth = term ^. numCols 43 | 44 | expandLine :: TermLine -> TermLine 45 | expandLine = (<> (VU.replicate (newWidth - oldWidth) ((' ', 0)))) 46 | 47 | shrinkLine :: TermLine -> TermLine 48 | shrinkLine = VU.take newWidth 49 | 50 | adjustLine :: TermLine -> TermLine 51 | adjustLine 52 | | newWidth > oldWidth = expandLine 53 | | otherwise = shrinkLine 54 | 55 | -- Internal function. Resize the terminal, only changing the height. 56 | resizeTermHeight :: Int -> Term -> Term 57 | resizeTermHeight newHeight term 58 | | newHeight >= oldHeight = resizeTermHeight' newHeight term 59 | | otherwise = 60 | let term' = truncateTermScreenBottom term (oldHeight - newHeight) 61 | in resizeTermHeight' newHeight term' 62 | where 63 | oldHeight = term ^. numRows 64 | 65 | resizeTermHeight' :: Int -> Term -> Term 66 | resizeTermHeight' newHeight term = 67 | ( numRows .~ newHeight 68 | >>> adjustScreen 69 | >>> termAlt %~ adjustAltScreen 70 | >>> cursorPos . _1 %~ min (newHeight - 1) 71 | ) 72 | term 73 | where 74 | oldHeight = term ^. numRows 75 | 76 | newBlankLine = VU.replicate (term ^. numCols) (' ', term ^. termAttrs) 77 | 78 | expandAltScreen :: TermLines -> TermLines 79 | expandAltScreen = (<> (TL.replicate (newHeight - oldHeight) newBlankLine)) 80 | 81 | shrinkAltScreen :: TermLines -> TermLines 82 | shrinkAltScreen = TL.take newHeight 83 | 84 | adjustAltScreen :: TermLines -> TermLines 85 | adjustAltScreen 86 | | newHeight > oldHeight = expandAltScreen 87 | | otherwise = shrinkAltScreen 88 | 89 | expandScreen :: Term -> Term 90 | expandScreen = 91 | ( termScreen 92 | %~ ( \lines -> 93 | TL.takeLast numHistoryLines (term ^. scrollBackLines) 94 | <> lines 95 | <> TL.replicate numNewBlankLines newBlankLine 96 | ) 97 | ) 98 | >>> scrollBackLines %~ TL.dropLast numHistoryLines 99 | >>> moveCursorDown 100 | where 101 | numHistoryLines = min (newHeight - oldHeight) (TL.length (term ^. scrollBackLines)) 102 | numNewBlankLines = (newHeight - oldHeight) - numHistoryLines 103 | 104 | moveCursorDown :: Term -> Term 105 | moveCursorDown 106 | | term ^. altScreenActive = id 107 | | otherwise = cursorPos . _1 %~ (+ numHistoryLines) 108 | 109 | shrinkScreen :: Term -> Term 110 | shrinkScreen = 111 | (termScreen %~ TL.takeLast newHeight) 112 | >>> addScrollBackLines (TL.take numShrunkLines (term ^. termScreen)) 113 | >>> moveCursorUp 114 | where 115 | numShrunkLines = oldHeight - newHeight 116 | moveCursorUp :: Term -> Term 117 | moveCursorUp 118 | | term ^. altScreenActive = id 119 | | otherwise = cursorPos . _1 %~ (\y -> max 0 (y - numShrunkLines)) 120 | 121 | adjustScreen 122 | | newHeight > oldHeight = expandScreen 123 | | otherwise = shrinkScreen 124 | 125 | -- | Chop off up to @n@ lines from the bottom of the main screen (only if they 126 | -- are blank and not occupied by the cursor). 127 | -- 128 | -- Also modifies the vertical size of the screen according to the number of 129 | -- lines removed (numLines) 130 | truncateTermScreenBottom :: Term -> Int -> Term 131 | truncateTermScreenBottom term numLines 132 | | numLines == 0 = term 133 | | term ^. altScreenActive = term 134 | | term ^. cursorPos . _1 == term ^. numRows - 1 = term 135 | | not (lineIsBlank lastLine) = term 136 | | otherwise = 137 | let term' = 138 | ( (termScreen %~ (TL.dropLast 1)) 139 | >>> (numRows %~ (subtract 1)) 140 | ) 141 | term 142 | in truncateTermScreenBottom term' (numLines - 1) 143 | where 144 | lastLine = TL.last (term ^. termScreen) 145 | lineIsBlank :: TermLine -> Bool 146 | lineIsBlank = VU.all (== (' ', 0)) 147 | -------------------------------------------------------------------------------- /hs-term-emulator/src/System/Terminal/Emulator/DECPrivateMode.hs: -------------------------------------------------------------------------------- 1 | module System.Terminal.Emulator.DECPrivateMode 2 | ( DECPrivateMode (..), 3 | intToDECPrivateMode, 4 | ) 5 | where 6 | 7 | data DECPrivateMode 8 | = -- | @1@ 9 | -- 10 | -- @DECSET@: Application Cursor Keys (DECCKM) 11 | -- 12 | -- @DECRST@: Normal Cursor Keys (DECCKM) 13 | DECCKM 14 | | -- | @2@ 15 | -- 16 | -- @DECSET@: Designate USASCII for character sets G0-G3 (DECANM), and set VT100 mode. 17 | -- 18 | -- @DECRST@: Designate VT52 mode (DECANM). 19 | DECANM 20 | | -- | @3@ 21 | -- 22 | -- @DECSET@: 132 Column Mode (DECCOLM) 23 | -- 24 | -- @DECRST@: 0 Column Mode (DECCOLM) 25 | DECCOLM 26 | | -- | @4@ 27 | -- 28 | -- @DECSET@: Smooth (Slow) Scroll (DECSCLM) 29 | -- 30 | -- @DECRST@: Jump (Fast) Scroll (DECSCLM) 31 | DECSCLM 32 | | -- | @5@ 33 | -- 34 | -- @DECSET@: Reverse Video (DECSCNM) 35 | -- 36 | -- @DECRST@: Normal Video (DECSCNM) 37 | DECSCNM 38 | | -- | @6@ 39 | -- 40 | -- @DECSET@: Origin Mode (DECOM) 41 | -- 42 | -- @DECRST@: Normal Cursor Mode (DECOM) 43 | DECOM 44 | | -- | @7@ 45 | -- 46 | -- @DECSET@: Wraparound Mode (DECAWM) 47 | -- 48 | -- @DECRST@: No Wraparound Mode (DECAWM) 49 | DECAWM 50 | | -- | @8@ 51 | -- 52 | -- @DECSET@: Auto-repeat Keys (DECARM) 53 | -- 54 | -- @DECRST@: No Auto-repeat Keys (DECARM) 55 | DECARM 56 | | -- | @9@ 57 | -- 58 | -- @DECSET@: Send Mouse X & Y on button press. See the section Mouse Tracking. 59 | -- 60 | -- @DECRST@: Don’t Send Mouse X & Y on button press 61 | X10MouseCompatibilityMode 62 | | -- | @12@ 63 | -- 64 | -- @DECSET@: Start Blinking Cursor (att610) 65 | -- 66 | -- @DECRST@: Stop Blinking Cursor (att610) 67 | Att610 68 | | -- | @18@ 69 | -- 70 | -- @DECSET@: Print form feed (DECPFF) 71 | -- 72 | -- @DECRST@: Don’t print form feed (DECPFF) 73 | DECPFF 74 | | -- | @19@ 75 | -- 76 | -- @DECSET@: Set print extent to full screen (DECPEX) 77 | -- 78 | -- @DECRST@: Limit print to scrolling region (DECPEX) 79 | DECPEX 80 | | -- | @25@ 81 | -- 82 | -- @DECSET@: Show Cursor (DECTCEM) 83 | -- 84 | -- @DECRST@: Hide Cursor (DECTCEM) 85 | DECTCEM 86 | | -- | @42@ 87 | -- 88 | -- @DECSET@: Enable Nation Replacement Character sets (DECNRCM) 89 | -- 90 | -- @DECRST@: Disable Nation Replacement Character sets (DECNRCM) 91 | DECNRCM 92 | | -- | @1000@ 93 | -- 94 | -- @DECSET@: Send Mouse X & Y on button press and release. See the section Mouse Tracking. 95 | -- 96 | -- @DECRST@: Don’t Send Mouse X & Y on button press and release. See the section Mouse Tracking. 97 | ReportButtonPress 98 | | -- | @1001@ 99 | -- 100 | -- @DECSET@: Use Hilite Mouse Tracking 101 | -- 102 | -- @DECRST@: Don’t Use Hilite Mouse Tracking 103 | MouseHighlightMode 104 | | -- | @1002@ 105 | -- 106 | -- @DECSET@: Use Cell Motion Mouse Tracking. 107 | -- 108 | -- @DECRST@: Don’t Use Cell Motion Mouse Tracking 109 | ReportMotionOnButtonPress 110 | | -- | @1003@ 111 | -- 112 | -- @DECSET@: Use All Motion Mouse Tracking. 113 | -- 114 | -- @DECRST@: Don’t Use All Motion Mouse Tracking 115 | EnableAllMouseMotions 116 | | -- | @47@ / @1047@ 117 | -- 118 | -- @DECSET@: Use Alternate Screen Buffer (unless disabled by the titeInhibit resource) 119 | -- 120 | -- @DECRST@: Use Normal Screen Buffer, clearing screen first if in the Alternate Screen (unless disabled by the titeInhibit resource) 121 | UseAlternateScreenBuffer 122 | | -- | @1048@ 123 | -- 124 | -- @DECSET@: Save cursor as in DECSC (unless disabled by the titeInhibit resource) 125 | -- 126 | -- @DECRST@: Restore cursor as in DECRC (unless disabled by the titeInhibit resource) 127 | SaveCursorAsInDECSC 128 | | -- | @1049@ 129 | -- 130 | -- @DECSET@: Save cursor as in DECSC and use Alternate Screen Buffer, clearing it first (unless disabled by the titeInhibit resource). This combines the effects of the 1047 and 1048 modes. Use this with terminfo-based applications rather than the 47 mode. 131 | -- 132 | -- @DECRST@: Use Normal Screen Buffer and restore cursor as in DECRC (unless disabled by the titeInhibit resource). This combines the effects of the 1047 and 1048 modes. Use this with terminfo-based applications rather than the 47 mode. 133 | SaveCursorAsInDECSCAndUseAlternateScreenBuffer 134 | | -- | @2004@ 135 | -- 136 | -- @DECSET@: Set bracketed paste mode. 137 | -- 138 | -- @DECRST@: Reset bracketed paste mode. 139 | BracketedPasteMode 140 | deriving (Show, Eq, Ord, Enum, Bounded) 141 | 142 | intToDECPrivateMode :: Int -> Maybe DECPrivateMode 143 | intToDECPrivateMode 1 = Just DECCKM 144 | intToDECPrivateMode 2 = Just DECANM 145 | intToDECPrivateMode 3 = Just DECCOLM 146 | intToDECPrivateMode 4 = Just DECSCLM 147 | intToDECPrivateMode 5 = Just DECSCNM 148 | intToDECPrivateMode 6 = Just DECOM 149 | intToDECPrivateMode 7 = Just DECAWM 150 | intToDECPrivateMode 8 = Just DECARM 151 | intToDECPrivateMode 9 = Just X10MouseCompatibilityMode 152 | intToDECPrivateMode 12 = Just Att610 153 | intToDECPrivateMode 18 = Just DECPFF 154 | intToDECPrivateMode 19 = Just DECPEX 155 | intToDECPrivateMode 25 = Just DECTCEM 156 | intToDECPrivateMode 42 = Just DECNRCM 157 | intToDECPrivateMode 1000 = Just ReportButtonPress 158 | intToDECPrivateMode 1001 = Just MouseHighlightMode 159 | intToDECPrivateMode 1002 = Just ReportMotionOnButtonPress 160 | intToDECPrivateMode 1003 = Just EnableAllMouseMotions 161 | intToDECPrivateMode 47 = Just UseAlternateScreenBuffer 162 | intToDECPrivateMode 1047 = Just UseAlternateScreenBuffer 163 | intToDECPrivateMode 1048 = Just SaveCursorAsInDECSC 164 | intToDECPrivateMode 1049 = Just SaveCursorAsInDECSCAndUseAlternateScreenBuffer 165 | intToDECPrivateMode 2004 = Just BracketedPasteMode 166 | intToDECPrivateMode _ = Nothing 167 | -------------------------------------------------------------------------------- /hs-term-emulator/test/System/Terminal/Emulator/Term/ProcessSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module System.Terminal.Emulator.Term.ProcessSpec where 5 | 6 | import Control.Applicative (many) 7 | import Control.Lens 8 | import Data.Attoparsec.Text 9 | import Data.Text (Text) 10 | import qualified Data.Vector.Unboxed as VU 11 | import System.Terminal.Emulator.Parsing (parseTermAtom) 12 | import System.Terminal.Emulator.Parsing.Types (TermAtom) 13 | import System.Terminal.Emulator.Term (Term, activeScreen, mkTerm, numCols, scrollBackLines) 14 | import System.Terminal.Emulator.Term.ArbitraryTermAtom (arbitraryTermAtom) 15 | import System.Terminal.Emulator.Term.Process (processTermAtoms) 16 | import System.Terminal.Emulator.Term.SimpleTerm (SimpleTerm (..), termToSimpleTerm) 17 | import Test.Hspec 18 | import Test.Hspec.QuickCheck (modifyMaxSize, modifyMaxSuccess) 19 | import Test.QuickCheck (Arbitrary (..), property) 20 | import Test.QuickCheck.Property (failed, reason, succeeded) 21 | 22 | newtype TestTermAtom = TestTermAtom {unTestTermAtom :: TermAtom} 23 | deriving (Show) 24 | 25 | instance Arbitrary TestTermAtom where 26 | arbitrary = TestTermAtom <$> arbitraryTermAtom 27 | 28 | blankTerm :: Term 29 | blankTerm = mkTerm (10, 4) 30 | 31 | runTerminal :: Term -> Text -> Term 32 | runTerminal term input = 33 | case parseOnly (many parseTermAtom <* endOfInput) input of 34 | Left err -> error $ "Error parsing terminal input: " <> err 35 | Right ts -> 36 | let (_, term') = processTermAtoms ts term 37 | in term' 38 | 39 | testCase :: (Term, Text) -> SimpleTerm -> Expectation 40 | testCase (initialTerm, input) expected = 41 | let term' = runTerminal initialTerm input 42 | actual = termToSimpleTerm term' 43 | in actual `shouldBe` expected 44 | 45 | spec :: Spec 46 | spec = do 47 | describe "ProcessSpec" $ do 48 | modifyMaxSuccess (const 10000) $ 49 | modifyMaxSize (const 4000) $ 50 | xit "Term Property Test: All lines proper width" $ 51 | property $ 52 | \(atoms :: [TestTermAtom]) -> 53 | let initialTerm = blankTerm 54 | (_, term') = processTermAtoms (map unTestTermAtom atoms) initialTerm 55 | in if all (\l -> VU.length l == term' ^. numCols) (term' ^. activeScreen) 56 | && all (\l -> VU.length l == term' ^. numCols) (term' ^. scrollBackLines) 57 | then succeeded 58 | else failed {reason = show term' <> "\n"} 59 | 60 | it "No Input" $ 61 | testCase 62 | (blankTerm, "") 63 | SimpleTerm 64 | { st_ScrollBackLines = [], 65 | st_Screen = 66 | [ " ", 67 | " ", 68 | " ", 69 | " " 70 | ], 71 | st_CursorPos = (0, 0) 72 | } 73 | 74 | it "Single char" $ 75 | testCase 76 | (blankTerm, "A") 77 | SimpleTerm 78 | { st_ScrollBackLines = [], 79 | st_Screen = 80 | [ "A ", 81 | " ", 82 | " ", 83 | " " 84 | ], 85 | st_CursorPos = (0, 1) 86 | } 87 | 88 | it "Multiple chars" $ 89 | testCase 90 | (blankTerm, "AB") 91 | SimpleTerm 92 | { st_ScrollBackLines = [], 93 | st_Screen = 94 | [ "AB ", 95 | " ", 96 | " ", 97 | " " 98 | ], 99 | st_CursorPos = (0, 2) 100 | } 101 | 102 | it "Newlines" $ 103 | testCase 104 | (blankTerm, "A\n\n\n") 105 | SimpleTerm 106 | { st_ScrollBackLines = [], 107 | st_Screen = 108 | [ "A ", 109 | " ", 110 | " ", 111 | " " 112 | ], 113 | st_CursorPos = (3, 1) 114 | } 115 | 116 | it "Scroll up" $ 117 | testCase 118 | (blankTerm, "A\n\n\n\n") 119 | SimpleTerm 120 | { st_ScrollBackLines = 121 | [ "A " 122 | ], 123 | st_Screen = 124 | [ " ", 125 | " ", 126 | " ", 127 | " " 128 | ], 129 | st_CursorPos = (3, 1) 130 | } 131 | 132 | it "Scroll up 2" $ 133 | testCase 134 | (blankTerm, "A\nB\n\n\n\n") 135 | SimpleTerm 136 | { st_ScrollBackLines = 137 | [ "A ", 138 | " B " 139 | ], 140 | st_Screen = 141 | [ " ", 142 | " ", 143 | " ", 144 | " " 145 | ], 146 | st_CursorPos = (3, 2) 147 | } 148 | 149 | it "Cursor Down 1" $ 150 | testCase 151 | (blankTerm, "A\ESC[B") 152 | SimpleTerm 153 | { st_ScrollBackLines = [], 154 | st_Screen = 155 | [ "A ", 156 | " ", 157 | " ", 158 | " " 159 | ], 160 | st_CursorPos = (1, 1) 161 | } 162 | 163 | it "Cursor Down past bottom" $ 164 | testCase 165 | (blankTerm, "A\ESC[B\ESC[B\ESC[B\ESC[B") 166 | SimpleTerm 167 | { st_ScrollBackLines = [], 168 | st_Screen = 169 | [ "A ", 170 | " ", 171 | " ", 172 | " " 173 | ], 174 | st_CursorPos = (3, 1) 175 | } 176 | 177 | -- TODO modern terminals don't add to the scrollback 178 | it "Scroll up 2" $ 179 | testCase 180 | (blankTerm, "A\ESC[2S") 181 | SimpleTerm 182 | { st_ScrollBackLines = 183 | [ "A ", 184 | " " 185 | ], 186 | st_Screen = 187 | [ " ", 188 | " ", 189 | " ", 190 | " " 191 | ], 192 | st_CursorPos = (0, 1) 193 | } 194 | 195 | -- TODO modern terminals don't add to the scrollback 196 | it "Delete lines 2" $ 197 | testCase 198 | (blankTerm, "A\ESC[2M") 199 | SimpleTerm 200 | { st_ScrollBackLines = 201 | [ "A ", 202 | " " 203 | ], 204 | st_Screen = 205 | [ " ", 206 | " ", 207 | " ", 208 | " " 209 | ], 210 | st_CursorPos = (0, 1) 211 | } 212 | -------------------------------------------------------------------------------- /hs-term-emulator/test/System/Terminal/Emulator/Parsing/InternalSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module System.Terminal.Emulator.Parsing.InternalSpec where 5 | 6 | import Control.Applicative (many) 7 | import Data.Attoparsec.Text 8 | import Data.Text (Text) 9 | import qualified System.Console.ANSI.Types as SGR 10 | import System.Terminal.Emulator.Parsing (parseTermAtom) 11 | import System.Terminal.Emulator.Parsing.Internal (ControlSequenceIntroducerComponents (..), ControlSequenceIntroducerInput (..), parseControlSequenceIntroducer, parseControlSequenceIntroducerComponents) 12 | import System.Terminal.Emulator.Parsing.Types (ControlSequenceIntroducer (..), EscapeSequence (..), Mode (..), OperatingSystemCommand (..), SingleCharacterFunction (..), TermAtom (..)) 13 | import Test.Hspec 14 | 15 | spec :: Spec 16 | spec = do 17 | describe "CSI" $ do 18 | it "Test 1" $ 19 | (parseControlSequenceIntroducer, "0;1m") 20 | `shouldParseTo` [ControlSequenceIntroducerInput "0;1m"] 21 | it "Test 2" $ 22 | parseControlSequenceIntroducerComponents (ControlSequenceIntroducerInput "1A") `shouldBe` Just (ControlSequenceIntroducerComponents False [1] 'A') 23 | it "Test 3" $ 24 | parseControlSequenceIntroducerComponents (ControlSequenceIntroducerInput "2A") `shouldBe` Just (ControlSequenceIntroducerComponents False [2] 'A') 25 | it "Test 4" $ 26 | parseControlSequenceIntroducerComponents (ControlSequenceIntroducerInput "A") `shouldBe` Just (ControlSequenceIntroducerComponents False [0] 'A') 27 | it "Test 6" $ 28 | parseControlSequenceIntroducerComponents (ControlSequenceIntroducerInput "1;2A") `shouldBe` Just (ControlSequenceIntroducerComponents False [1, 2] 'A') 29 | it "Test 7" $ 30 | parseControlSequenceIntroducerComponents (ControlSequenceIntroducerInput ";A") `shouldBe` Just (ControlSequenceIntroducerComponents False [0, 0] 'A') 31 | it "Test 8" $ 32 | parseControlSequenceIntroducerComponents (ControlSequenceIntroducerInput ";2A") `shouldBe` Just (ControlSequenceIntroducerComponents False [0, 2] 'A') 33 | it "Test 9" $ 34 | parseControlSequenceIntroducerComponents (ControlSequenceIntroducerInput ";;2A") `shouldBe` Just (ControlSequenceIntroducerComponents False [0, 0, 2] 'A') 35 | it "Test 10" $ 36 | parseControlSequenceIntroducerComponents (ControlSequenceIntroducerInput ";2;A") `shouldBe` Just (ControlSequenceIntroducerComponents False [0, 2, 0] 'A') 37 | it "Test 11" $ 38 | parseControlSequenceIntroducerComponents (ControlSequenceIntroducerInput ";;A") `shouldBe` Just (ControlSequenceIntroducerComponents False [0, 0, 0] 'A') 39 | describe 40 | "TermParse Parser" 41 | $ do 42 | it "TermAtom_VisibleChar A" $ 43 | (parseTermAtom, "A") 44 | `shouldParseTo` [TermAtom_VisibleChar 'A'] 45 | it "TermAtom_VisibleChar AB" $ 46 | (parseTermAtom, "AB") 47 | `shouldParseTo` [TermAtom_VisibleChar 'A', TermAtom_VisibleChar 'B'] 48 | it "TermAtom_VisibleChar ' '" $ 49 | (parseTermAtom, " ") 50 | `shouldParseTo` [TermAtom_VisibleChar ' '] 51 | it "Control_Backspace" $ 52 | (parseTermAtom, "\b") 53 | `shouldParseTo` [TermAtom_SingleCharacterFunction Control_Backspace] 54 | it "Multi chars" $ 55 | (parseTermAtom, "A\b B") 56 | `shouldParseTo` [ TermAtom_VisibleChar 'A', 57 | TermAtom_SingleCharacterFunction Control_Backspace, 58 | TermAtom_VisibleChar ' ', 59 | TermAtom_VisibleChar 'B' 60 | ] 61 | it "ESC_RIS" $ 62 | (parseTermAtom, "\ESCc") 63 | `shouldParseTo` [TermAtom_EscapeSequence Esc_RIS] 64 | it "Multi chars with simple escape" $ 65 | (parseTermAtom, "A\ESCcB\bC") 66 | `shouldParseTo` [ TermAtom_VisibleChar 'A', 67 | TermAtom_EscapeSequence Esc_RIS, 68 | TermAtom_VisibleChar 'B', 69 | TermAtom_SingleCharacterFunction Control_Backspace, 70 | TermAtom_VisibleChar 'C' 71 | ] 72 | it "OSC set window title" $ 73 | (parseTermAtom, "\ESC]0;Hello\a") 74 | `shouldParseTo` [TermAtom_EscapeSequence (Esc_OSC (OSC_SetTitle True True "Hello"))] 75 | it "OSC set window title ST" $ 76 | (parseTermAtom, "\ESC]0;Hello\ESC\\") 77 | `shouldParseTo` [TermAtom_EscapeSequence (Esc_OSC (OSC_SetTitle True True "Hello"))] 78 | it "OSC mix" $ 79 | (parseTermAtom, "A\ESC]0;Hello\a\aB") 80 | `shouldParseTo` [ TermAtom_VisibleChar 'A', 81 | TermAtom_EscapeSequence (Esc_OSC (OSC_SetTitle True True "Hello")), 82 | TermAtom_SingleCharacterFunction Control_Bell, 83 | TermAtom_VisibleChar 'B' 84 | ] 85 | it "CSI Cursor up default" $ 86 | (parseTermAtom, "\ESC[A") 87 | `shouldParseTo` [TermAtom_EscapeSequence (Esc_CSI (CSI_CursorUp 1))] 88 | it "CSI Cursor up zero" $ 89 | (parseTermAtom, "\ESC[0A") 90 | `shouldParseTo` [TermAtom_EscapeSequence (Esc_CSI (CSI_CursorUp 1))] 91 | it "CSI Cursor up default 1" $ 92 | (parseTermAtom, "\ESC[1A") 93 | `shouldParseTo` [TermAtom_EscapeSequence (Esc_CSI (CSI_CursorUp 1))] 94 | it "CSI Cursor up default 2" $ 95 | (parseTermAtom, "\ESC[2A") 96 | `shouldParseTo` [TermAtom_EscapeSequence (Esc_CSI (CSI_CursorUp 2))] 97 | it "SGR Set bold" $ 98 | (parseTermAtom, "\ESC[1m") 99 | `shouldParseTo` [TermAtom_EscapeSequence (Esc_CSI (CSI_SGR [SGR.SetConsoleIntensity SGR.BoldIntensity]))] 100 | it "SGR Reset 1" $ 101 | (parseTermAtom, "\ESC[0m") 102 | `shouldParseTo` [TermAtom_EscapeSequence (Esc_CSI (CSI_SGR [SGR.Reset]))] 103 | it "SGR Reset 1" $ 104 | (parseTermAtom, "\ESC[m") 105 | `shouldParseTo` [TermAtom_EscapeSequence (Esc_CSI (CSI_SGR [SGR.Reset]))] 106 | it "DECSTR" $ 107 | (parseTermAtom, "\ESC[!p") 108 | `shouldParseTo` [TermAtom_EscapeSequence (Esc_CSI CSI_SoftTerminalReset)] 109 | it "RM 0" $ 110 | (parseTermAtom, "\ESC[l") 111 | `shouldParseTo` [TermAtom_EscapeSequenceUnknown "\ESC[l"] 112 | it "RM 2" $ 113 | (parseTermAtom, "\ESC[2l") 114 | `shouldParseTo` [TermAtom_EscapeSequence (Esc_CSI (CSI_ResetMode KeyboardActionMode))] 115 | it "RM 4" $ 116 | (parseTermAtom, "\ESC[4l") 117 | `shouldParseTo` [TermAtom_EscapeSequence (Esc_CSI (CSI_ResetMode InsertReplaceMode))] 118 | it "RM 12" $ 119 | (parseTermAtom, "\ESC[12l") 120 | `shouldParseTo` [TermAtom_EscapeSequence (Esc_CSI (CSI_ResetMode SendReceive))] 121 | it "RM 20" $ 122 | (parseTermAtom, "\ESC[20l") 123 | `shouldParseTo` [TermAtom_EscapeSequence (Esc_CSI (CSI_ResetMode AutomaticNewlineNormalLinefeed))] 124 | 125 | shouldParseTo :: (Show a, Eq a) => (Parser a, Text) -> [a] -> IO () 126 | shouldParseTo (parser, str) expected = 127 | case parseOnly (many parser <* endOfInput) str of 128 | Left err -> fail err 129 | Right ts -> ts `shouldBe` expected 130 | -------------------------------------------------------------------------------- /hs-term-emulator/src/System/Terminal/Emulator/KeyboardInput/KeyPressToPty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module System.Terminal.Emulator.KeyboardInput.KeyPressToPty 5 | ( keyPressToPty, 6 | ) 7 | where 8 | 9 | import Data.ByteString (ByteString) 10 | import qualified Data.ByteString as B 11 | import qualified Data.ByteString.Char8 as BC8 12 | import Data.Char (isControl) 13 | import System.Terminal.Emulator.KeyboardInput (KeyModifiers (..), KeyPress (..), KeyboardState (..), SpecialKey (..)) 14 | 15 | keyPressToPty :: KeyboardState -> KeyPress -> ByteString 16 | keyPressToPty KeyboardState {keyboardState_Locked = True} _ = "" 17 | keyPressToPty _ (KeyPress_Char c modifiers) 18 | | isControl c = error $ "Invalid Control Char for KeyPress: " ++ show c 19 | | otherwise = keyToPty c modifiers 20 | keyPressToPty keyboardState (KeyPress_SpecialKey specialKey modifiers) = specialKeyToPty keyboardState specialKey (pressedModifiers modifiers) 21 | 22 | keyToPty :: Char -> KeyModifiers -> ByteString 23 | keyToPty c KeyModifiers {ctrl, alt} 24 | | ctrl && c >= 'a' && c <= 'z' = escapePrefix <> BC8.singleton (toEnum (fromEnum c - 96)) 25 | | ctrl && c >= 'A' && c <= 'Z' = escapePrefix <> BC8.singleton (toEnum (fromEnum c - 64)) 26 | | otherwise = escapePrefix <> charToByteString c 27 | where 28 | escapePrefix 29 | | alt = "\ESC" 30 | | otherwise = "" 31 | 32 | data ModKey = Alt | Ctrl | Shift 33 | deriving (Eq, Show) 34 | 35 | pressedModifiers :: KeyModifiers -> [ModKey] 36 | pressedModifiers KeyModifiers {alt, ctrl, shift} = 37 | (if alt then [Alt] else []) 38 | <> (if ctrl then [Ctrl] else []) 39 | <> (if shift then [Shift] else []) 40 | 41 | specialKeyToPty :: KeyboardState -> SpecialKey -> [ModKey] -> ByteString 42 | specialKeyToPty KeyboardState {keyboardState_DECCKM, keyboardState_DECPAM} specialKey modKeys = 43 | case specialKey of 44 | SpecialKey_Escape 45 | | Alt `elem` modKeys -> "\ESC\ESC" 46 | | otherwise -> "\ESC" 47 | SpecialKey_F1 48 | | modKeys == [Alt] -> "\ESC[1;3P" 49 | | modKeys == [Ctrl] -> "\ESC[1;5P" 50 | | modKeys == [Shift] -> "\ESC[1;2P" 51 | | modKeys == [] -> "\ESCOP" 52 | | otherwise -> "" 53 | SpecialKey_F2 54 | | modKeys == [Alt] -> "\ESC[1;3Q" 55 | | modKeys == [Ctrl] -> "\ESC[1;5Q" 56 | | modKeys == [Shift] -> "\ESC[1;2Q" 57 | | modKeys == [] -> "\ESCOQ" 58 | | otherwise -> "" 59 | SpecialKey_F3 60 | | modKeys == [Alt] -> "\ESC[1;3R" 61 | | modKeys == [Ctrl] -> "\ESC[1;5R" 62 | | modKeys == [Shift] -> "\ESC[1;2R" 63 | | modKeys == [] -> "\ESCOR" 64 | | otherwise -> "" 65 | SpecialKey_F4 66 | | modKeys == [Alt] -> "\ESC[1;3S" 67 | | modKeys == [Ctrl] -> "\ESC[1;5S" 68 | | modKeys == [Shift] -> "\ESC[1;2S" 69 | | modKeys == [] -> "\ESCOS" 70 | | otherwise -> "" 71 | SpecialKey_F5 72 | | modKeys == [Alt] -> "\ESC[15;3~" 73 | | modKeys == [Ctrl] -> "\ESC[15;5~" 74 | | modKeys == [Shift] -> "\ESC[15;2~" 75 | | modKeys == [] -> "\ESC[15~" 76 | | otherwise -> "" 77 | SpecialKey_F6 78 | | modKeys == [Alt] -> "\ESC[17;3~" 79 | | modKeys == [Ctrl] -> "\ESC[17;5~" 80 | | modKeys == [Shift] -> "\ESC[17;2~" 81 | | modKeys == [] -> "\ESC[17~" 82 | | otherwise -> "" 83 | SpecialKey_F7 84 | | modKeys == [Alt] -> "\ESC[18;3~" 85 | | modKeys == [Ctrl] -> "\ESC[18;5~" 86 | | modKeys == [Shift] -> "\ESC[18;2~" 87 | | modKeys == [] -> "\ESC[18~" 88 | | otherwise -> "" 89 | SpecialKey_F8 90 | | modKeys == [Alt] -> "\ESC[19;3~" 91 | | modKeys == [Ctrl] -> "\ESC[19;5~" 92 | | modKeys == [Shift] -> "\ESC[19;2~" 93 | | modKeys == [] -> "\ESC[19~" 94 | | otherwise -> "" 95 | SpecialKey_F9 96 | | modKeys == [Alt] -> "\ESC[20;3~" 97 | | modKeys == [Ctrl] -> "\ESC[20;5~" 98 | | modKeys == [Shift] -> "\ESC[20;2~" 99 | | modKeys == [] -> "\ESC[20~" 100 | | otherwise -> "" 101 | SpecialKey_F10 102 | | modKeys == [Alt] -> "\ESC[21;3~" 103 | | modKeys == [Ctrl] -> "\ESC[21;5~" 104 | | modKeys == [Shift] -> "\ESC[21;2~" 105 | | modKeys == [] -> "\ESC[21~" 106 | | otherwise -> "" 107 | SpecialKey_F11 108 | | modKeys == [Alt] -> "\ESC[23;3~" 109 | | modKeys == [Ctrl] -> "\ESC[23;5~" 110 | | modKeys == [Shift] -> "\ESC[23;2~" 111 | | modKeys == [] -> "\ESC[23~" 112 | | otherwise -> "" 113 | SpecialKey_F12 114 | | modKeys == [Alt] -> "\ESC[24;3~" 115 | | modKeys == [Ctrl] -> "\ESC[24;5~" 116 | | modKeys == [Shift] -> "\ESC[24;2~" 117 | | modKeys == [] -> "\ESC[24~" 118 | | otherwise -> "" 119 | SpecialKey_Insert 120 | | modKeys == [Shift] && keyboardState_DECPAM -> "\ESC[2;2~" 121 | | modKeys == [Shift] -> "\ESC[4l" 122 | | modKeys == [Ctrl] && keyboardState_DECPAM -> "\ESC[2;5~" 123 | | modKeys == [Ctrl] -> "\ESC[L" 124 | | keyboardState_DECPAM -> "\ESC[2~" 125 | | otherwise -> "\ESC[4h" 126 | SpecialKey_Delete 127 | | modKeys == [Shift] -> "\ESC[3;2~" 128 | | modKeys == [Ctrl] -> "\ESC[3;5~" 129 | | otherwise -> "\ESC[3~" 130 | SpecialKey_Home 131 | | modKeys == [Shift] && keyboardState_DECCKM -> "\ESC[1;2H" 132 | | modKeys == [Shift] -> "\ESC[2J" 133 | | keyboardState_DECCKM -> "\ESC[1~" 134 | | otherwise -> "\ESC[H" 135 | SpecialKey_End 136 | | modKeys == [Shift] && keyboardState_DECPAM -> "\ESC[1;2F" 137 | | modKeys == [Shift] -> "\ESC[K" 138 | | modKeys == [Ctrl] && keyboardState_DECPAM -> "\ESC[1;5F" 139 | | modKeys == [Ctrl] -> "\ESC[J" 140 | | otherwise -> "\ESC[4~" 141 | SpecialKey_PageUp 142 | | modKeys == [Shift] -> "\ESC[5;2~" 143 | | modKeys == [Ctrl] -> "\ESC[5;5~" 144 | | otherwise -> "\ESC[5~" 145 | SpecialKey_PageDown 146 | | modKeys == [Shift] -> "\ESC[6;2~" 147 | | modKeys == [Ctrl] -> "\ESC[6;5~" 148 | | otherwise -> "\ESC[6~" 149 | SpecialKey_Tab 150 | | modKeys == [Shift] -> "\ESC[Z" 151 | | modKeys == [Alt] -> "\ESC\t" 152 | | otherwise -> "\t" 153 | SpecialKey_Enter 154 | | modKeys == [Alt] -> "\ESC\r" 155 | | otherwise -> "\r" 156 | SpecialKey_Backspace 157 | | Alt `elem` modKeys && Shift `elem` modKeys -> "\ESC\b" 158 | | Alt `elem` modKeys && Ctrl `elem` modKeys -> "\ESC\b" 159 | | Alt `elem` modKeys -> "\ESC\DEL" 160 | | Shift `elem` modKeys -> "\b" 161 | | Ctrl `elem` modKeys -> "\b" 162 | | otherwise -> "\DEL" 163 | SpecialKey_ArrowLeft 164 | | modKeys == [Shift] -> "\ESC[1;2D" 165 | | modKeys == [Alt] -> "\ESC[1;3D" 166 | | modKeys == [Alt, Shift] -> "\ESC[1;4D" 167 | | modKeys == [Ctrl] -> "\ESC[1;5D" 168 | | modKeys == [Ctrl, Shift] -> "\ESC[1;6D" 169 | | modKeys == [Alt, Ctrl] -> "\ESC[1;7D" 170 | | modKeys == [Alt, Ctrl, Shift] -> "\ESC[1;8D" 171 | | keyboardState_DECCKM -> "\ESCOD" 172 | | otherwise -> "\ESC[D" 173 | SpecialKey_ArrowRight 174 | | modKeys == [Shift] -> "\ESC[1;2C" 175 | | modKeys == [Alt] -> "\ESC[1;3C" 176 | | modKeys == [Alt, Shift] -> "\ESC[1;4C" 177 | | modKeys == [Ctrl] -> "\ESC[1;5C" 178 | | modKeys == [Ctrl, Shift] -> "\ESC[1;6C" 179 | | modKeys == [Alt, Ctrl] -> "\ESC[1;7C" 180 | | modKeys == [Alt, Ctrl, Shift] -> "\ESC[1;8C" 181 | | keyboardState_DECCKM -> "\ESCOC" 182 | | otherwise -> "\ESC[C" 183 | SpecialKey_ArrowUp 184 | | modKeys == [Shift] -> "\ESC[1;2A" 185 | | modKeys == [Alt] -> "\ESC[1;3A" 186 | | modKeys == [Alt, Shift] -> "\ESC[1;4A" 187 | | modKeys == [Ctrl] -> "\ESC[1;5A" 188 | | modKeys == [Ctrl, Shift] -> "\ESC[1;6A" 189 | | modKeys == [Alt, Ctrl] -> "\ESC[1;7A" 190 | | modKeys == [Alt, Ctrl, Shift] -> "\ESC[1;8A" 191 | | keyboardState_DECCKM -> "\ESCOA" 192 | | otherwise -> "\ESC[A" 193 | SpecialKey_ArrowDown 194 | | modKeys == [Shift] -> "\ESC[1;2B" 195 | | modKeys == [Alt] -> "\ESC[1;3B" 196 | | modKeys == [Alt, Shift] -> "\ESC[1;4B" 197 | | modKeys == [Ctrl] -> "\ESC[1;5B" 198 | | modKeys == [Ctrl, Shift] -> "\ESC[1;6B" 199 | | modKeys == [Alt, Ctrl] -> "\ESC[1;7B" 200 | | modKeys == [Alt, Ctrl, Shift] -> "\ESC[1;8B" 201 | | keyboardState_DECCKM -> "\ESCOB" 202 | | otherwise -> "\ESC[B" 203 | 204 | charToByteString :: Char -> ByteString 205 | charToByteString = 206 | -- TODO Encode as UTF-8 207 | B.singleton . fromIntegral . fromEnum 208 | -------------------------------------------------------------------------------- /hs-term-emulator/src/System/Terminal/Emulator/Term.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | 4 | module System.Terminal.Emulator.Term 5 | ( -- * Types 6 | Term, 7 | mkTerm, 8 | 9 | -- * Direct 'Term' Lenses 10 | termAttrs, 11 | cursorPos, 12 | cursorState, 13 | modeWrap, 14 | insertMode, 15 | altScreenActive, 16 | numCols, 17 | numRows, 18 | keyboardState, 19 | scrollTop, 20 | scrollBottom, 21 | scrollBackLines, 22 | numScrollBackLines, 23 | termScreen, 24 | termAlt, 25 | windowTitle, 26 | 27 | -- * Direct 'CursorState' Lenses 28 | wrapNext, 29 | origin, 30 | 31 | -- * Helper 'Term' Lenses 32 | cursorLine, 33 | activeScreen, 34 | 35 | -- * Misc 36 | addScrollBackLines, 37 | vuIndex, 38 | termGetKeyboardState, 39 | ) 40 | where 41 | 42 | import Control.Category ((>>>)) 43 | import Control.Exception (assert) 44 | import Control.Lens 45 | import Data.Text (Text) 46 | import qualified Data.Vector.Unboxed as VU 47 | import System.Terminal.Emulator.Attrs (Attrs, blankAttrs) 48 | import System.Terminal.Emulator.KeyboardInput (KeyboardState, initialKeyboardState) 49 | import System.Terminal.Emulator.TermLines (TermLine, TermLines) 50 | import qualified System.Terminal.Emulator.TermLines as TL 51 | import Prelude hiding (lines) 52 | 53 | data CursorState = CursorState 54 | { cursorState_WrapNext :: !Bool, 55 | cursorState_Origin :: !Bool 56 | } 57 | deriving (Show, Eq, Ord) 58 | 59 | data CursorPos = CursorPos !Int !Int 60 | deriving (Show, Eq, Ord) 61 | 62 | data Term = Term 63 | { term_Attrs :: !Attrs, 64 | -- | (line, column) 65 | term_CursorPos :: !CursorPos, 66 | term_CursorState :: !CursorState, 67 | -- | Set using Wraparound Mode (DECAWM) 68 | term_ModeWrap :: !Bool, 69 | -- | Set using Insert/Replace Mode (IRM) 70 | term_InsertMode :: !Bool, 71 | term_AltScreenActive :: !Bool, 72 | term_NumCols :: !Int, 73 | term_NumRows :: !Int, 74 | term_KeyboardState :: !KeyboardState, 75 | -- | Row index of the top of the scroll region 76 | term_ScrollTop :: !Int, 77 | -- | Row index of the bottom of the scroll region 78 | term_ScrollBottom :: !Int, 79 | -- | Scroll back lines of the Main screen 80 | term_ScrollBackLines :: !TermLines, 81 | -- | Maximum scroll back lines to be saved 82 | term_NumScrollBackLines :: !Int, 83 | -- | Main screen. This is always the size of the terminal. 84 | term_Screen :: !TermLines, 85 | -- | Alternate screen. This is always the size of the terminal. 86 | -- 87 | -- The Alternate screen does not have any scroll back lines 88 | -- 89 | -- See also: 90 | -- 91 | term_Alt :: !TermLines, 92 | term_WindowTitle :: !Text 93 | } 94 | deriving (Show, Eq, Ord) 95 | 96 | -- | Create a new blank Terminal with the given size @(width, height)@ 97 | mkTerm :: (Int, Int) -> Term 98 | mkTerm (width, height) = 99 | Term 100 | { term_Attrs = blankAttrs, 101 | term_CursorPos = CursorPos 0 0, 102 | term_CursorState = 103 | CursorState 104 | { cursorState_WrapNext = False, 105 | cursorState_Origin = False 106 | }, 107 | term_ModeWrap = True, 108 | term_InsertMode = False, 109 | term_AltScreenActive = False, 110 | term_NumCols = width, 111 | term_NumRows = height, 112 | term_KeyboardState = initialKeyboardState, 113 | term_ScrollTop = 0, 114 | term_ScrollBottom = height - 1, 115 | term_ScrollBackLines = TL.empty, 116 | term_NumScrollBackLines = 1000, 117 | term_Screen = TL.replicate height (VU.replicate width ((' ', 0))), 118 | term_Alt = TL.replicate height (VU.replicate width ((' ', 0))), 119 | term_WindowTitle = "hs-term" 120 | } 121 | 122 | ----------------------------------------------------------------------- 123 | -- Direct 'Term' Lenses 124 | ----------------------------------------------------------------------- 125 | 126 | termAttrs :: Lens' Term Attrs 127 | termAttrs = lens term_Attrs (\term newVal -> term {term_Attrs = newVal}) 128 | 129 | -- | Cursor line is always in the range [0..numRows-1] 130 | -- 131 | -- Cursor col is always in the range [0..numCols-1] 132 | cursorPos :: Lens' Term (Int, Int) 133 | cursorPos = lens getter setter 134 | where 135 | getter :: Term -> (Int, Int) 136 | getter term = let CursorPos row col = term_CursorPos term in (row, col) 137 | setter :: Term -> (Int, Int) -> Term 138 | setter term (newRow, newCol) = 139 | assert (newCol >= minX) $ 140 | assert (newCol <= maxX) $ 141 | assert (newRow >= minY) $ 142 | assert (newRow <= maxY) $ 143 | term {term_CursorPos = CursorPos newRow newCol} 144 | where 145 | minX = 0 146 | maxX = (term ^. numCols) - 1 147 | minY = 0 148 | maxY = (term ^. numRows) - 1 149 | 150 | cursorState :: Lens' Term CursorState 151 | cursorState = lens term_CursorState (\term newVal -> term {term_CursorState = newVal}) 152 | 153 | -- | Wraparound Mode (DECAWM) 154 | modeWrap :: Lens' Term Bool 155 | modeWrap = lens term_ModeWrap (\term newVal -> term {term_ModeWrap = newVal}) 156 | 157 | -- | Insert/Replace Mode (IRM) 158 | insertMode :: Lens' Term Bool 159 | insertMode = lens term_InsertMode (\term newVal -> term {term_InsertMode = newVal}) 160 | 161 | altScreenActive :: Lens' Term Bool 162 | altScreenActive = lens term_AltScreenActive (\term newVal -> term {term_AltScreenActive = newVal}) 163 | 164 | numCols :: Lens' Term Int 165 | numCols = lens term_NumCols (\term newVal -> term {term_NumCols = newVal}) 166 | 167 | numRows :: Lens' Term Int 168 | numRows = lens term_NumRows (\term newVal -> term {term_NumRows = newVal}) 169 | 170 | keyboardState :: Lens' Term KeyboardState 171 | keyboardState = lens term_KeyboardState (\term newVal -> term {term_KeyboardState = newVal}) 172 | 173 | scrollTop :: Lens' Term Int 174 | scrollTop = lens term_ScrollTop (\term newVal -> term {term_ScrollTop = newVal}) 175 | 176 | scrollBottom :: Lens' Term Int 177 | scrollBottom = lens term_ScrollBottom (\term newVal -> term {term_ScrollBottom = newVal}) 178 | 179 | scrollBackLines :: Lens' Term TermLines 180 | scrollBackLines = lens term_ScrollBackLines (\term newVal -> term {term_ScrollBackLines = newVal}) 181 | 182 | numScrollBackLines :: Lens' Term Int 183 | numScrollBackLines = lens term_NumScrollBackLines (\term newVal -> term {term_NumScrollBackLines = newVal}) 184 | 185 | termScreen :: Lens' Term TermLines 186 | termScreen = lens term_Screen (\term newVal -> term {term_Screen = newVal}) 187 | 188 | termAlt :: Lens' Term TermLines 189 | termAlt = lens term_Alt (\term newVal -> term {term_Alt = newVal}) 190 | 191 | windowTitle :: Lens' Term Text 192 | windowTitle = lens term_WindowTitle (\term newWindowTitle -> term {term_WindowTitle = newWindowTitle}) 193 | 194 | ----------------------------------------------------------------------- 195 | -- Direct 'Term' Lenses 196 | ----------------------------------------------------------------------- 197 | 198 | wrapNext :: Lens' CursorState Bool 199 | wrapNext = lens cursorState_WrapNext (\cs newWrapNext -> cs {cursorState_WrapNext = newWrapNext}) 200 | 201 | origin :: Lens' CursorState Bool 202 | origin = lens cursorState_Origin (\cs newOrigin -> cs {cursorState_Origin = newOrigin}) 203 | 204 | ----------------------------------------------------------------------- 205 | -- Helper 'Term' Lenses 206 | ----------------------------------------------------------------------- 207 | 208 | -- | A lens to the line where the cursor currently is 209 | cursorLine :: Lens' Term TermLine 210 | cursorLine = lens getter setter 211 | where 212 | getter :: Term -> TermLine 213 | getter term = term ^. activeScreen . TL.vIndex (term ^. cursorPos . _1) 214 | setter :: Term -> TermLine -> Term 215 | setter term newTermLine = ((activeScreen . TL.vIndex (term ^. cursorPos . _1)) .~ newTermLine) term 216 | 217 | -- | Either the main screen or the alternate screen (depending on which is 218 | -- active) 219 | activeScreen :: Lens' Term TermLines 220 | activeScreen = lens getter setter 221 | where 222 | getter :: Term -> TermLines 223 | getter term = (if term_AltScreenActive term then term_Alt else term_Screen) term 224 | setter :: Term -> TermLines -> Term 225 | setter term newLines = (if term_AltScreenActive term then term {term_Alt = newLines} else term {term_Screen = newLines}) 226 | 227 | ----------------------------------------------------------------------- 228 | 229 | termGetKeyboardState :: Term -> KeyboardState 230 | termGetKeyboardState = term_KeyboardState 231 | 232 | vuIndex :: VU.Unbox a => Int -> Lens' (VU.Vector a) a 233 | vuIndex i = lens getter setter 234 | where 235 | getter :: VU.Unbox a => VU.Vector a -> a 236 | getter v = assert (i >= 0 && i <= VU.length v - 1) $ v VU.! i 237 | setter :: VU.Unbox a => VU.Vector a -> a -> VU.Vector a 238 | setter v val = assert (i >= 0 && i <= VU.length v - 1) $ v VU.// [(i, val)] 239 | 240 | addScrollBackLines :: TermLines -> Term -> Term 241 | addScrollBackLines newLines term = 242 | (scrollBackLines %~ ((<> newLines) >>> TL.takeLast (term ^. numScrollBackLines))) term 243 | -------------------------------------------------------------------------------- /hs-term-emulator/src/System/Terminal/Emulator/Parsing/Types.hs: -------------------------------------------------------------------------------- 1 | module System.Terminal.Emulator.Parsing.Types where 2 | 3 | import Data.Text (Text) 4 | import Data.Vector (Vector) 5 | import System.Console.ANSI.Types (SGR) 6 | import qualified System.Console.ANSI.Types as SGR 7 | import System.Terminal.Emulator.DECPrivateMode (DECPrivateMode) 8 | 9 | data TermAtom 10 | = TermAtom_VisibleChar !Char 11 | | TermAtom_SingleCharacterFunction !SingleCharacterFunction 12 | | TermAtom_SingleCharacterFunctionUnknown !Char 13 | | TermAtom_EscapeSequence !EscapeSequence 14 | | TermAtom_EscapeSequenceUnknown !Text 15 | deriving (Show, Eq) 16 | 17 | data SingleCharacterFunction 18 | = -- | @BEL@ Bell (BEL is Ctrl-G). 19 | Control_Bell 20 | | -- | @BS@ Backspace (BS is Ctrl-H). 21 | Control_Backspace 22 | | -- | @CR@ Carriage Return (CR is Ctrl-M). 23 | Control_CarriageReturn 24 | | -- | @ENQ@ Return Terminal Status (ENQ is Ctrl-E). Default response is an empty string 25 | Control_ReturnTerminalStatus 26 | | -- | @FF@ Form Feed or New Page (NP ). (FF is Ctrl-L). FF is treated the same as LF . 27 | Control_FormFeed 28 | | -- | @LF@ Line Feed or New Line (NL). (LF is Ctrl-J). 29 | Control_LineFeed 30 | | -- | @SI@ Switch to Standard Character Set (Ctrl-O is Shift In or LS0). This invokes the G0 character set (the default) as GL. VT200 and up implement LS0. 31 | Control_SwitchToStandardCharacterSet 32 | | -- | @SO@ Switch to Alternate Character Set (Ctrl-N is Shift Out or LS1). This invokes the G1 character set as GL. VT200 and up implement LS1. 33 | Control_SwitchToAlternateCharacterSet 34 | | -- | @TAB@ Horizontal Tab (HTS is Ctrl-I). 35 | Control_Tab 36 | | -- | @VT@ Vertical Tab (VT is Ctrl-K). This is treated the same as LF. 37 | Control_VerticalTab 38 | deriving (Show, Eq, Ord, Enum, Bounded) 39 | 40 | data EscapeSequence 41 | = -- | @ESC M@ Reverse Index (RI is 0x8d). 42 | Esc_ReverseIndex 43 | | -- | @ESC c@ Reset terminal to initial state (RIS) 44 | Esc_RIS 45 | | -- | @ESC =@ Application Keypad (DECPAM) 46 | Esc_DECPAM 47 | | -- | @ESC >@ Set numeric keypad mode (DECPNM) 48 | Esc_DECPNM 49 | | -- | @ESC (@ Designate G0 Character Set, VT100, ISO 2022. 50 | ESC_SetG0CharacterSet !Text 51 | | Esc_CSI !ControlSequenceIntroducer 52 | | Esc_OSC !OperatingSystemCommand 53 | deriving (Show, Eq) 54 | 55 | data ControlSequenceIntroducer 56 | = -- | @CSI Ps `@ Character Position Absolute [column] (default = [row,1]) (HPA). 57 | CSI_CharacterPositionAbsolute !Int 58 | | -- | @CSI Ps a@ Character Position Relative [columns] (default = [row,col+1]) (HPR). 59 | CSI_CharacterPositionRelative !Int 60 | | -- | @CSI Ps A@ Cursor Up Ps Times (default = 1) (CUU). 61 | CSI_CursorUp !Int 62 | | -- | @CSI Ps B@ Cursor Down Ps Times (default = 1) (CUD). 63 | CSI_CursorDown !Int 64 | | -- | @CSI Ps C@ Cursor Forward Ps Times (default = 1) (CUF). 65 | CSI_CursorForward !Int 66 | | -- | @CSI Ps D@ Cursor Backward Ps Times (default = 1) (CUB). 67 | CSI_CursorBack !Int 68 | | -- | @CSI Ps K@ Erase in Line (EL), VT100. 69 | CSI_EraseInLine !EraseInLineParam 70 | | -- | @CSI Ps \@@ Insert Ps (Blank) Character(s) (default = 1) (ICH) 71 | CSI_InsertBlankCharacters !Int 72 | | -- | @CSI Ps L@ Insert Ps Line(s) (default = 1) (IL) 73 | CSI_InsertBlankLines !Int 74 | | -- | @CSI Ps P@ Delete Ps Character(s) (default = 1) (DCH). 75 | CSI_DeleteChars !Int 76 | | -- | @CSI Ps M@ Delete Ps Line(s) (default = 1) (DL). 77 | CSI_DeleteLines !Int 78 | | -- | @CSI Ps G@ Cursor Character Absolute [column] (default = [row,1]) (CHA). 79 | CSI_CursorCharacterAbsolute !Int 80 | | -- | @CSI Ps ; Ps H@ Cursor Position [row;column] (default = [1,1]) (CUP). 81 | CSI_CursorPosition !Int !Int 82 | | -- | @CSI Ps ; Ps f@ Horizontal and Vertical Position [row;column] (default = [1,1]) (HVP). 83 | CSI_HorizontalVerticalPosition !Int !Int 84 | | -- | @CSI Ps d@ Line Position Absolute [row] (default = [1,column]) (VPA). 85 | CSI_LinePositionAbsolute !Int 86 | | -- | @CSI Ps e@ Line Position Relative [rows] (default = [row+1,column]) (VPR). 87 | CSI_LinePositionRelative !Int 88 | | -- | @CSI Ps S@ Scroll up Ps lines (default = 1) (SU), VT420, ECMA-48. 89 | CSI_ScrollUp !Int 90 | | -- | @CSI Ps T@ Scroll down Ps lines (default = 1) (SD), VT420. 91 | CSI_ScrollDown !Int 92 | | -- | @CSI Ps J@ Erase in Display (ED), VT100 93 | CSI_EraseInDisplay !EraseInDisplayParam 94 | | -- | @CSI Ps X@ Erase Ps Character(s) (default = 1) (ECH). 95 | CSI_EraseCharacters !Int 96 | | -- | @CSI Ps ; Ps ; Ps t@ Window manipulation (XTWINOPS), dtterm, extended by xterm. These controls may be disabled using the allowWindowOps resource. 97 | CSI_WindowManipulation !WindowManipulation 98 | | -- | @CSI Ps n@ Device Status Report (DSR). 99 | CSI_DeviceStatusReport !DeviceStatusReport 100 | | -- | @CSI ! p@ Soft terminal reset (DECSTR), VT220 and up. 101 | CSI_SoftTerminalReset 102 | | -- | @CSI Pm h@ Set Mode (SM). 103 | CSI_SetMode !Mode 104 | | -- | @CSI Pm l@ Reset Mode (RM). 105 | CSI_ResetMode !Mode 106 | | -- | @CSI Ps c@ Send Device Attributes (Primary DA). 107 | CSI_SendDeviceAttributes 108 | | -- | @CSI > Ps c@ Send Device Attributes (Secondary DA). 109 | CSI_SendDeviceAttributesSecondary !SendDeviceAttributesSecondary 110 | | -- | @CSI ? Ps $ p@ Request DEC private mode (DECRQM). 111 | CSI_RequestDECPrivateMode !Int 112 | | -- | Set Scrolling Region [top;bottom] (default = full size of window) (DECSTBM) 113 | CSI_DECSTBM !(Maybe Int) !(Maybe Int) 114 | | -- | DEC Private Mode Set 115 | CSI_DECSET !DECPrivateMode 116 | | -- | Unknown DECSET (DEC Private Mode Set) code 117 | CSI_DECSET_Unknown !Int 118 | | -- | DEC Private Mode Reset 119 | CSI_DECRST !DECPrivateMode 120 | | -- | Unknown DECRST (DEC Private Mode Reset) code 121 | CSI_DECRST_Unknown !Int 122 | | CSI_SGR !(Vector SGR) 123 | deriving (Show, Eq) 124 | 125 | data EraseInLineParam 126 | = -- | @Ps = 0@ Erase to Right (default). 127 | ClearFromCursorToEndOfLine 128 | | -- | @Ps = 1@ Erase to Left. 129 | ClearFromCursorToBeginningOfLine 130 | | -- | @Ps = 2@ Erase All. 131 | ClearEntireLine 132 | deriving (Show, Eq, Ord, Enum, Bounded) 133 | 134 | data EraseInDisplayParam 135 | = -- | @Ps = 0@ Erase Below (default). 136 | EraseBelow 137 | | -- | @Ps = 1@ Erase Above. 138 | EraseAbove 139 | | -- | @Ps = 2@ Erase All. 140 | EraseAll 141 | | -- | @Ps = 3@ Erase Saved Lines, xterm. 142 | EraseSavedLines 143 | deriving (Show, Eq, Ord, Enum, Bounded) 144 | 145 | data WindowManipulation 146 | = -- | @22;0@ Save xterm icon and window title on stack. 147 | SaveIconAndWindowTitleOnStack 148 | | -- | @23;0@ Restore xterm icon and window title from stack. 149 | RestoreIconAndWindowTitleOnStack 150 | deriving (Show, Eq, Ord, Enum, Bounded) 151 | 152 | data DeviceStatusReport 153 | = -- | Status Report. Result ("OK") is @CSI 0 n@ 154 | StatusReport 155 | | -- | Report Cursor Position (CPR) [row;column]. Result is @CSI r ; c R@ 156 | ReportCursorPosition 157 | deriving (Show, Eq, Ord, Enum, Bounded) 158 | 159 | data Mode 160 | = -- | Keyboard Action Mode (KAM) 161 | KeyboardActionMode 162 | | -- | Insert/Replace Mode (IRM) 163 | InsertReplaceMode 164 | | -- | Send/receive (SRM) 165 | SendReceive 166 | | -- | Automatic Newline / Normal Linefeed (LNM). 167 | AutomaticNewlineNormalLinefeed 168 | deriving (Show, Eq, Ord, Enum, Bounded) 169 | 170 | data SendDeviceAttributesSecondary 171 | = RequestTerminalIdentificationCode 172 | deriving (Show, Eq, Ord, Enum, Bounded) 173 | 174 | data OperatingSystemCommand 175 | = -- | Change Icon Name and Window Title 176 | OSC_SetTitle 177 | !Bool 178 | -- ^ Set icon name to the string 179 | !Bool 180 | -- ^ Set window title to the string 181 | !Text 182 | -- ^ The string that should be used for the title 183 | | -- | Change VT100 text foreground color 184 | OSC_ChangeTextForegroundColor !Text 185 | | -- | Request VT100 text foreground color 186 | OSC_RequestTextForegroundColor 187 | | -- | Change VT100 text background color 188 | OSC_ChangeTextBackgroundColor !Text 189 | | -- | Request VT100 text background color 190 | OSC_RequestTextBackgroundColor 191 | | -- | @Ps = 112@ Reset text cursor color. 192 | OSC_ResetTextCursorColor 193 | deriving (Show, Eq, Ord) 194 | 195 | codeToSGR :: Int -> Maybe SGR.SGR 196 | codeToSGR 0 = Just SGR.Reset 197 | codeToSGR 1 = Just $ SGR.SetConsoleIntensity SGR.BoldIntensity 198 | codeToSGR 2 = Just $ SGR.SetConsoleIntensity SGR.FaintIntensity 199 | codeToSGR 4 = Just $ SGR.SetUnderlining SGR.SingleUnderline 200 | codeToSGR 21 = Just $ SGR.SetUnderlining SGR.DoubleUnderline 201 | codeToSGR 22 = Just $ SGR.SetConsoleIntensity SGR.NormalIntensity 202 | codeToSGR 24 = Just $ SGR.SetUnderlining SGR.NoUnderline 203 | codeToSGR 39 = Just $ SGR.SetDefaultColor SGR.Foreground 204 | codeToSGR 49 = Just $ SGR.SetDefaultColor SGR.Background 205 | codeToSGR code 206 | | code `between` (30, 37) = do 207 | color <- codeToColor (code - 30) 208 | Just $ SGR.SetColor SGR.Foreground SGR.Dull color 209 | | code `between` (90, 97) = do 210 | color <- codeToColor (code - 90) 211 | Just $ SGR.SetColor SGR.Foreground SGR.Vivid color 212 | | code `between` (40, 47) = do 213 | color <- codeToColor (code - 40) 214 | Just $ SGR.SetColor SGR.Background SGR.Dull color 215 | | code `between` (100, 107) = do 216 | color <- codeToColor (code - 100) 217 | Just $ SGR.SetColor SGR.Background SGR.Vivid color 218 | | otherwise = Nothing 219 | 220 | codeToColor :: Int -> Maybe SGR.Color 221 | codeToColor 0 = Just SGR.Black 222 | codeToColor 1 = Just SGR.Red 223 | codeToColor 2 = Just SGR.Green 224 | codeToColor 3 = Just SGR.Yellow 225 | codeToColor 4 = Just SGR.Blue 226 | codeToColor 5 = Just SGR.Magenta 227 | codeToColor 6 = Just SGR.Cyan 228 | codeToColor 7 = Just SGR.White 229 | codeToColor _ = Nothing 230 | 231 | between :: Ord a => a -> (a, a) -> Bool 232 | between val (low, high) = val >= low && val <= high 233 | -------------------------------------------------------------------------------- /hs-sdl-term-emulator/src/System/Terminal/Emulator/SDL/LibMain.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module System.Terminal.Emulator.SDL.LibMain where 6 | 7 | import Control.Concurrent.Async 8 | import Control.Concurrent.STM 9 | import Control.Exception (bracket) 10 | import Control.Lens 11 | import Control.Monad (forM_, unless, when) 12 | import Data.ByteString (ByteString) 13 | import qualified Data.ByteString as B 14 | import Data.Conduit (runConduit, (.|)) 15 | import Data.Conduit.Attoparsec (conduitParser) 16 | import Data.Conduit.Combinators (decodeUtf8Lenient) 17 | import qualified Data.Conduit.Combinators as C 18 | import Data.Conduit.TQueue (sinkTBQueue, sourceTBQueue) 19 | import qualified Data.Vector.Unboxed as VU 20 | import Data.Word (Word8) 21 | import Foreign.C.Types (CInt) 22 | import Linear (V2 (..), V3 (..), V4 (..)) 23 | import Linear.Affine (Point (..)) 24 | import qualified Linear.V4 as V4 25 | import SDL (get, ($=)) 26 | import qualified SDL as SDL 27 | import qualified System.Console.ANSI.Types as SGR 28 | import System.Terminal.Emulator.Attrs (Cell, attrsBg, attrsFg, attrsIntensity, attrsUnderline) 29 | import System.Terminal.Emulator.KeyboardInput.KeyPressToPty (keyPressToPty) 30 | import System.Terminal.Emulator.Parsing (parseTermAtom) 31 | import System.Terminal.Emulator.Parsing.Types (TermAtom) 32 | import System.Terminal.Emulator.SDL.ImageFont (loadImageFont) 33 | import System.Terminal.Emulator.SDL.KeyboardTranslate (translateSDLKey) 34 | import System.Terminal.Emulator.SDL.Pty (launchPty) 35 | import System.Terminal.Emulator.Term (activeScreen, altScreenActive, cursorPos, mkTerm, numRows, scrollBackLines, termGetKeyboardState, windowTitle) 36 | import System.Terminal.Emulator.Term.Process (Term, TermLine, processTermAtoms) 37 | import System.Terminal.Emulator.Term.Resize (resizeTerm) 38 | import qualified System.Terminal.Emulator.TermLines as TL 39 | import Prelude hiding (lines) 40 | 41 | initialTerminalWidth, initialTerminalHeight :: CInt 42 | initialTerminalWidth = 80 43 | initialTerminalHeight = 30 44 | 45 | initialWindowSize :: V2 CInt 46 | initialWindowSize = V2 (initialTerminalWidth * cellWidth) (initialTerminalHeight * cellHeight) 47 | 48 | main :: IO () 49 | main = do 50 | SDL.initializeAll 51 | bracket 52 | ( SDL.createWindow 53 | "My SDL Application" 54 | SDL.defaultWindow 55 | { SDL.windowBorder = True, 56 | SDL.windowInitialSize = initialWindowSize, 57 | SDL.windowResizable = True 58 | } 59 | ) 60 | SDL.destroyWindow 61 | ( \window -> do 62 | renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer 63 | -- We need to resize the window again, because the window manager I 64 | -- use (xmonad) creates it initially a bit too small 65 | SDL.windowSize window $= initialWindowSize 66 | fontSurface <- loadImageFont 67 | fontTexture <- SDL.createTextureFromSurface renderer fontSurface 68 | SDL.freeSurface fontSurface 69 | 70 | terminalLoop window renderer fontTexture 71 | ) 72 | 73 | terminalLoop :: SDL.Window -> SDL.Renderer -> SDL.Texture -> IO () 74 | terminalLoop window renderer fontTexture = do 75 | V2 windowWidth windowHeight <- get $ SDL.windowSize window 76 | let terminalInitialWidth = fromIntegral (windowWidth `div` cellWidth) 77 | terminalInitialHeight = fromIntegral (windowHeight `div` cellHeight) 78 | 79 | termOutputQueue <- newTBQueueIO 500 80 | let initialTerm = mkTerm (terminalInitialWidth, terminalInitialHeight) 81 | 82 | windowDirtyVar <- newTVarIO True 83 | 84 | scrollBackVar <- newTVarIO 0 85 | 86 | termVar :: TVar Term <- newTVarIO initialTerm 87 | 88 | termInputBuffer :: TChan ByteString <- newTChanIO 89 | 90 | termResizeEvents :: TChan (Int, Int) <- newTChanIO 91 | 92 | termOutputStream :: TBQueue TermAtom <- newTBQueueIO 500 93 | 94 | let streamInput :: IO () 95 | streamInput = 96 | runConduit $ 97 | (sourceTBQueue termOutputQueue) 98 | .| decodeUtf8Lenient 99 | .| C.iterM (\t -> putStrLn $ "[RAW] " <> show t) 100 | .| conduitParser parseTermAtom -- termAtom 101 | -- .| C.iterM (\t -> putStrLn $ "[PARSED] " <> show t) 102 | .| C.map snd 103 | .| sinkTBQueue termOutputStream 104 | 105 | let doTerminalResize :: (Int, Int) -> IO () 106 | doTerminalResize newSize = do 107 | atomically $ do 108 | modifyTVar' termVar (flip resizeTerm newSize') 109 | writeTVar windowDirtyVar True 110 | atomically $ writeTChan termResizeEvents newSize' 111 | where 112 | (width, height) = newSize 113 | newSize' = (max 1 width, max 1 height) 114 | 115 | let readInput :: IO () 116 | readInput = do 117 | event <- interruptibleWaitEvent 118 | case SDL.eventPayload event of 119 | SDL.KeyboardEvent SDL.KeyboardEventData {SDL.keyboardEventKeyMotion = SDL.Pressed, SDL.keyboardEventKeysym = keysym} -> do 120 | -- putStrLn $ "{KEYSYM} " <> show keysym 121 | case translateSDLKey keysym of 122 | Nothing -> pure () 123 | Just termInput -> atomically $ do 124 | term <- readTVar termVar 125 | writeTChan termInputBuffer (keyPressToPty (termGetKeyboardState term) termInput) 126 | pure () 127 | SDL.WindowExposedEvent _ -> atomically $ writeTVar windowDirtyVar True 128 | SDL.MouseWheelEvent SDL.MouseWheelEventData {SDL.mouseWheelEventPos = V2 _ scrollY} -> do 129 | atomically $ do 130 | let scrollMultiplier = 6 131 | modifyTVar' scrollBackVar (\scrollBack -> max 0 (scrollBack + (scrollMultiplier * (fromIntegral scrollY)))) 132 | writeTVar windowDirtyVar True 133 | SDL.MouseMotionEvent 134 | SDL.MouseMotionEventData 135 | { SDL.mouseMotionEventState = [SDL.ButtonRight], 136 | SDL.mouseMotionEventPos = P (V2 mouseX mouseY) 137 | } -> do 138 | let newTermWidth = fromIntegral mouseX `div` fromIntegral cellWidth 139 | newTermHeight = fromIntegral mouseY `div` fromIntegral cellHeight 140 | doTerminalResize (newTermWidth, newTermHeight) 141 | SDL.MouseButtonEvent 142 | SDL.MouseButtonEventData 143 | { SDL.mouseButtonEventButton = SDL.ButtonRight, 144 | SDL.mouseButtonEventMotion = SDL.Pressed, 145 | SDL.mouseButtonEventPos = P (V2 mouseX mouseY), 146 | SDL.mouseButtonEventClicks = numClicks 147 | } -> do 148 | putStrLn $ "mouseClick: " <> show numClicks <> show (mouseX, mouseY) 149 | let newTermWidth = fromIntegral mouseX `div` fromIntegral cellWidth 150 | newTermHeight = fromIntegral mouseY `div` fromIntegral cellHeight 151 | doTerminalResize (newTermWidth, newTermHeight) 152 | SDL.WindowSizeChangedEvent 153 | SDL.WindowSizeChangedEventData 154 | { SDL.windowSizeChangedEventSize = V2 newWindowWidth newWindowHeight 155 | } -> 156 | do 157 | putStrLn $ "RESIZE: " <> show (newWindowWidth, newWindowHeight) 158 | let newTermWidth = fromIntegral newWindowWidth `div` fromIntegral cellWidth 159 | newTermHeight = fromIntegral newWindowHeight `div` fromIntegral cellHeight 160 | doTerminalResize (newTermWidth, newTermHeight) 161 | _ -> pure () 162 | readInput 163 | 164 | let renderLoop :: IO () 165 | renderLoop = do 166 | mbOutputBuf <- 167 | atomically $ 168 | (readTBQueueAll termOutputStream >>= pure . Just) 169 | `orElse` ( do 170 | windowDirty <- readTVar windowDirtyVar 171 | if windowDirty 172 | then do 173 | writeTVar windowDirtyVar False 174 | pure Nothing 175 | else retry 176 | ) 177 | -- putStrLn $ "{OUTPUT} " <> show outputBuf 178 | !(termWrite, !term') <- atomically $ do 179 | term <- readTVar termVar 180 | case mbOutputBuf of 181 | Just outputBuf -> do 182 | let (termWrite, term') = processTermAtoms outputBuf term 183 | writeTVar termVar $! term' 184 | pure (termWrite, term') 185 | Nothing -> pure (B.empty, term) 186 | unless (B.null termWrite) $ 187 | atomically $ writeTChan termInputBuffer termWrite 188 | scrollBack <- atomically $ readTVar scrollBackVar 189 | renderTerm window renderer fontTexture term' scrollBack 190 | renderLoop 191 | 192 | withAsync streamInput $ \streamInputAsync -> do 193 | link streamInputAsync 194 | withAsync readInput $ \readInputAsync -> do 195 | link readInputAsync 196 | withAsync 197 | ( renderLoop 198 | ) 199 | $ \renderLoopAsync -> do 200 | link renderLoopAsync 201 | launchPty (terminalInitialWidth, terminalInitialHeight) (readTChan termInputBuffer) (readTChan termResizeEvents) $ \contents -> do 202 | -- putStrLn $ "[CONTENTS] " ++ show contents 203 | atomically $ writeTBQueue termOutputQueue contents 204 | 205 | -- | Reads all the values in the 'TBQueue', or retry if it is empty 206 | readTBQueueAll :: TBQueue a -> STM [a] 207 | readTBQueueAll c = do 208 | first <- readTBQueue c 209 | rest <- tryReadTBQueueMultiple [] 210 | pure (first : rest) 211 | where 212 | tryReadTBQueueMultiple accum = do 213 | mbItem <- tryReadTBQueue c 214 | case mbItem of 215 | Nothing -> pure (reverse accum) 216 | Just item -> tryReadTBQueueMultiple (item : accum) 217 | 218 | renderTerm :: SDL.Window -> SDL.Renderer -> SDL.Texture -> Term -> Int -> IO () 219 | renderTerm window renderer fontTexture term scrollBack = do 220 | SDL.windowTitle window $= term ^. windowTitle 221 | let visibleRows 222 | | term ^. altScreenActive = term ^. activeScreen 223 | | otherwise = (TL.take (term ^. numRows) (TL.takeLast scrollBack (term ^. scrollBackLines))) <> (TL.dropLast scrollBack (term ^. activeScreen)) 224 | 225 | SDL.rendererDrawColor renderer $= V4 255 32 255 255 226 | SDL.clear renderer 227 | _ <- (flip TL.traverseWithIndex) visibleRows $ \line termLine -> do 228 | renderLine renderer fontTexture termLine line 229 | 230 | renderGrid window renderer 231 | 232 | -- Render the cursor 233 | let (line, col) = term ^. cursorPos 234 | SDL.rendererDrawColor renderer $= V4 255 255 128 255 235 | SDL.drawRect renderer (Just (SDL.Rectangle (P (V2 (fromIntegral col * cellWidth) (fromIntegral (line + scrollBack) * cellHeight))) charSize)) 236 | 237 | SDL.present renderer 238 | 239 | renderGrid :: SDL.Window -> SDL.Renderer -> IO () 240 | renderGrid window renderer = do 241 | V2 windowWidth windowHeight <- get $ SDL.windowSize window 242 | SDL.rendererDrawColor renderer $= V4 8 8 8 255 243 | 244 | -- Horizontal lines 245 | forM_ [0, cellHeight .. windowHeight] $ \y -> do 246 | SDL.drawLine renderer (P (V2 0 y)) (P (V2 windowWidth y)) 247 | 248 | -- Vertical lines 249 | forM_ [0, cellWidth .. windowWidth] $ \x -> do 250 | SDL.drawLine renderer (P (V2 x 0)) (P (V2 x windowHeight)) 251 | 252 | renderLine :: SDL.Renderer -> SDL.Texture -> TermLine -> Int -> IO () 253 | renderLine renderer fontTexture termLine line = do 254 | VU.iforM_ termLine $ \col cell -> do 255 | renderChar renderer fontTexture cell line col 256 | pure () 257 | 258 | renderChar :: SDL.Renderer -> SDL.Texture -> Cell -> Int -> Int -> IO () 259 | renderChar renderer fontTexture (char, attrs) line col = do 260 | let fgColor :: (V3 Word8) 261 | fgColor = case attrs ^. attrsFg of 262 | Nothing -> V3 172 216 172 263 | Just (SGR.Dull, SGR.Black) -> V3 0 0 0 264 | Just (SGR.Dull, SGR.Red) -> V3 208 0 0 265 | Just (SGR.Dull, SGR.Green) -> V3 0 208 0 266 | Just (SGR.Dull, SGR.Yellow) -> V3 208 208 0 267 | Just (SGR.Dull, SGR.Blue) -> V3 0 0 208 268 | Just (SGR.Dull, SGR.Magenta) -> V3 208 0 208 269 | Just (SGR.Dull, SGR.Cyan) -> V3 0 208 208 270 | Just (SGR.Dull, SGR.White) -> V3 208 208 208 271 | Just (SGR.Vivid, SGR.Black) -> V3 128 128 128 272 | Just (SGR.Vivid, SGR.Red) -> V3 128 128 128 273 | Just (SGR.Vivid, SGR.Green) -> V3 128 128 128 274 | Just (SGR.Vivid, SGR.Yellow) -> V3 128 128 128 275 | Just (SGR.Vivid, SGR.Blue) -> V3 128 128 128 276 | Just (SGR.Vivid, SGR.Magenta) -> V3 128 128 128 277 | Just (SGR.Vivid, SGR.Cyan) -> V3 128 128 128 278 | Just (SGR.Vivid, SGR.White) -> V3 128 128 128 279 | 280 | bgColor :: (V4 Word8) 281 | bgColor = case attrs ^. attrsBg of 282 | Nothing -> V4 0 0 0 255 283 | Just (SGR.Dull, SGR.Black) -> V4 0 0 0 255 284 | Just (SGR.Dull, SGR.Red) -> V4 208 0 0 255 285 | Just (SGR.Dull, SGR.Green) -> V4 0 208 0 255 286 | Just (SGR.Dull, SGR.Yellow) -> V4 208 208 0 255 287 | Just (SGR.Dull, SGR.Blue) -> V4 0 0 208 255 288 | Just (SGR.Dull, SGR.Magenta) -> V4 208 0 208 255 289 | Just (SGR.Dull, SGR.Cyan) -> V4 0 208 208 255 290 | Just (SGR.Dull, SGR.White) -> V4 208 208 208 255 291 | Just (SGR.Vivid, SGR.Black) -> V4 255 128 128 255 292 | Just (SGR.Vivid, SGR.Red) -> V4 255 128 128 255 293 | Just (SGR.Vivid, SGR.Green) -> V4 255 128 128 255 294 | Just (SGR.Vivid, SGR.Yellow) -> V4 255 128 128 255 295 | Just (SGR.Vivid, SGR.Blue) -> V4 255 128 128 255 296 | Just (SGR.Vivid, SGR.Magenta) -> V4 255 128 128 255 297 | Just (SGR.Vivid, SGR.Cyan) -> V4 255 128 128 255 298 | Just (SGR.Vivid, SGR.White) -> V4 255 128 128 255 299 | SDL.rendererDrawColor renderer $= bgColor 300 | SDL.fillRect renderer (Just (SDL.Rectangle (P (V2 (fromIntegral col * cellWidth) (fromIntegral line * cellHeight))) charSize)) 301 | 302 | SDL.textureColorMod fontTexture $= fgColor 303 | SDL.copy 304 | renderer 305 | fontTexture 306 | (Just (SDL.Rectangle (charPosition char) charSize)) 307 | (Just (SDL.Rectangle (P (V2 (fromIntegral col * cellWidth) (fromIntegral line * cellHeight))) charSize)) 308 | 309 | when (attrs ^. attrsIntensity == SGR.BoldIntensity) $ do 310 | SDL.copy 311 | renderer 312 | fontTexture 313 | (Just (SDL.Rectangle (charPosition char) charSize)) 314 | (Just (SDL.Rectangle (P (V2 (fromIntegral col * cellWidth - 1) (fromIntegral line * cellHeight))) charSize)) 315 | 316 | when (attrs ^. attrsUnderline == SGR.SingleUnderline) $ do 317 | SDL.rendererDrawColor renderer $= (V4._w .~ 255) (V4.vector fgColor) 318 | SDL.drawLine 319 | renderer 320 | (P (V2 (fromIntegral col * cellWidth) (fromIntegral line * cellHeight + cellHeight - 2))) 321 | (P (V2 (fromIntegral col * cellWidth + cellWidth) (fromIntegral line * cellHeight + cellHeight - 2))) 322 | 323 | fontCellWidth, fontCellHeight :: CInt 324 | (fontCellWidth, fontCellHeight) = (16, 16) 325 | 326 | cellWidth, cellHeight :: CInt 327 | (cellWidth, cellHeight) = (14, 16) 328 | 329 | charPosition :: Char -> Point V2 CInt 330 | charPosition char = case fromEnum char of 331 | charCode 332 | | charCode < 256 -> P (V2 ((fromIntegral charCode `rem` 16) * fontCellWidth) ((fromIntegral charCode `div` 16) * fontCellHeight)) 333 | | otherwise -> invalidCharP 334 | where 335 | invalidCharP = P (V2 (15 * fontCellWidth) (7 * fontCellHeight)) 336 | 337 | charSize :: V2 CInt 338 | charSize = V2 fontCellWidth fontCellHeight 339 | 340 | interruptibleWaitEvent :: IO SDL.Event 341 | interruptibleWaitEvent = do 342 | result <- SDL.waitEventTimeout 50 343 | case result of 344 | Just e -> pure e 345 | Nothing -> interruptibleWaitEvent 346 | -------------------------------------------------------------------------------- /hs-term-emulator/src/System/Terminal/Emulator/Parsing/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module System.Terminal.Emulator.Parsing.Internal where 4 | 5 | import Control.Applicative ((<|>)) 6 | import Data.Attoparsec.Text 7 | import Data.Char (isDigit) 8 | import Data.List.NonEmpty (NonEmpty ((:|))) 9 | import qualified Data.List.NonEmpty as NE 10 | import Data.Maybe (mapMaybe) 11 | import Data.Text (Text) 12 | import qualified Data.Text as T 13 | import qualified Data.Text.Read as T 14 | import qualified Data.Vector as V 15 | import System.Terminal.Emulator.DECPrivateMode (intToDECPrivateMode) 16 | import System.Terminal.Emulator.Parsing.Types (ControlSequenceIntroducer (..), DeviceStatusReport (..), EraseInDisplayParam (..), EraseInLineParam (..), EscapeSequence (..), Mode (..), OperatingSystemCommand (..), SendDeviceAttributesSecondary (RequestTerminalIdentificationCode), SingleCharacterFunction (..), TermAtom (..), WindowManipulation (..), codeToSGR) 17 | import Prelude hiding (takeWhile) 18 | 19 | parseTermAtom :: Parser TermAtom 20 | parseTermAtom = 21 | parseVisibleChar <|> parseControl 22 | 23 | parseVisibleChar :: Parser TermAtom 24 | parseVisibleChar = TermAtom_VisibleChar <$> satisfy (not . isControl) 25 | 26 | -- | This parser always succeeds 27 | parseControl :: Parser TermAtom 28 | parseControl = do 29 | c <- anyChar 30 | if c == '\ESC' 31 | then parseEscape 32 | else pure $ case singleCharacterFunction c of 33 | Nothing -> TermAtom_SingleCharacterFunctionUnknown c 34 | Just f -> TermAtom_SingleCharacterFunction f 35 | 36 | singleCharacterFunction :: Char -> Maybe SingleCharacterFunction 37 | singleCharacterFunction '\a' = Just Control_Bell 38 | singleCharacterFunction '\b' = Just Control_Backspace 39 | singleCharacterFunction '\r' = Just Control_CarriageReturn 40 | singleCharacterFunction '\ENQ' = Just Control_ReturnTerminalStatus 41 | singleCharacterFunction '\f' = Just Control_FormFeed 42 | singleCharacterFunction '\n' = Just Control_LineFeed 43 | singleCharacterFunction '\SI' = Just Control_SwitchToStandardCharacterSet 44 | singleCharacterFunction '\SO' = Just Control_SwitchToAlternateCharacterSet 45 | singleCharacterFunction '\t' = Just Control_Tab 46 | singleCharacterFunction '\v' = Just Control_VerticalTab 47 | singleCharacterFunction _ = Nothing 48 | 49 | -- | This parser always succeeds 50 | parseEscape :: Parser TermAtom 51 | parseEscape = do 52 | c <- anyChar 53 | case c of 54 | '[' -> handleCsi 55 | ']' -> handleOsc 56 | '(' -> handleSetG0CharacterSet 57 | _ -> handleSingle c 58 | where 59 | handleCsi :: Parser TermAtom 60 | handleCsi = do 61 | csiInput <- parseControlSequenceIntroducer 62 | pure $ case processControlSequenceIntroducer csiInput of 63 | Nothing -> case processOtherControlSequenceIntroducer csiInput of 64 | Nothing -> TermAtom_EscapeSequenceUnknown (renderCsi csiInput) 65 | Just csi -> TermAtom_EscapeSequence (Esc_CSI csi) 66 | Just csi -> TermAtom_EscapeSequence (Esc_CSI csi) 67 | 68 | handleOsc :: Parser TermAtom 69 | handleOsc = do 70 | oscInput <- parseOperatingSystemCommand 71 | pure $ case processOperatingSystemCommand oscInput of 72 | Nothing -> TermAtom_EscapeSequenceUnknown (renderOsc oscInput) 73 | Just osc -> TermAtom_EscapeSequence (Esc_OSC osc) 74 | 75 | handleSingle :: Char -> Parser TermAtom 76 | handleSingle c = pure $ case singleCharacterEscapeSequence c of 77 | Just e -> TermAtom_EscapeSequence e 78 | Nothing -> TermAtom_EscapeSequenceUnknown ("\ESC" <> T.singleton c) 79 | 80 | handleSetG0CharacterSet :: Parser TermAtom 81 | handleSetG0CharacterSet = 82 | ( choice 83 | [ string "A", 84 | string "B", 85 | string "C", 86 | string "5", 87 | string "H", 88 | string "7", 89 | string "K", 90 | string "Q", 91 | string "9", 92 | string "R", 93 | string "f", 94 | string "Y", 95 | string "Z", 96 | string "4", 97 | string "\">", 98 | string "%2", 99 | string "%6", 100 | string "%=", 101 | string "=", 102 | string "`", 103 | string "E", 104 | string "6", 105 | string "0", 106 | string "<", 107 | string ">", 108 | string "\"4", 109 | string "\"?", 110 | string "%0", 111 | string "%5", 112 | string "&4", 113 | string "%3", 114 | string "&5" 115 | ] 116 | >>= pure . TermAtom_EscapeSequence . ESC_SetG0CharacterSet 117 | ) 118 | <|> ( anyChar >>= \c -> 119 | pure (TermAtom_EscapeSequenceUnknown ("\ESC(" <> T.singleton c)) 120 | ) 121 | 122 | ----------------------------------------------------------------------- 123 | -- CSI (Control Sequence Introducer) sequences 124 | ----------------------------------------------------------------------- 125 | 126 | data ControlSequenceIntroducerInput = ControlSequenceIntroducerInput !Text 127 | deriving (Show, Eq) 128 | 129 | data ControlSequenceIntroducerComponents 130 | = ControlSequenceIntroducerComponents 131 | !Bool 132 | -- ^ Private? 133 | !(NonEmpty Int) 134 | -- ^ Args 135 | !Char 136 | -- ^ Mode 137 | deriving (Show, Eq) 138 | 139 | -- | Should be run after reading the sequence @ESC [@ 140 | -- 141 | -- This parser always succeeds 142 | parseControlSequenceIntroducer :: Parser ControlSequenceIntroducerInput 143 | parseControlSequenceIntroducer = do 144 | str <- takeTill ((`between` (0x40, 0x7E)) . fromEnum) 145 | c <- anyChar 146 | pure (ControlSequenceIntroducerInput ((str) <> T.singleton c)) 147 | 148 | parseControlSequenceIntroducerComponents :: ControlSequenceIntroducerInput -> Maybe ControlSequenceIntroducerComponents 149 | parseControlSequenceIntroducerComponents (ControlSequenceIntroducerInput str) = 150 | case parseOnly (parser <* endOfInput) str of 151 | Left _ -> Nothing 152 | Right val -> Just val 153 | where 154 | parser :: Parser ControlSequenceIntroducerComponents 155 | parser = do 156 | private <- option False (char '?' >> pure True) 157 | first <- peekChar' 158 | args <- 159 | if isDigit first || first == ';' 160 | then sepBy (option 0 decimal) (char ';') 161 | else pure [] 162 | mode <- anyChar 163 | pure (ControlSequenceIntroducerComponents private (listToNonEmpty 0 args) mode) 164 | 165 | listToNonEmpty :: a -> [a] -> NonEmpty a 166 | listToNonEmpty def [] = def :| [] 167 | listToNonEmpty _ (x : xs) = x :| xs 168 | 169 | processControlSequenceIntroducerComponents :: ControlSequenceIntroducerComponents -> Maybe ControlSequenceIntroducer 170 | processControlSequenceIntroducerComponents (ControlSequenceIntroducerComponents False args mode) = parseCsi mode args 171 | processControlSequenceIntroducerComponents (ControlSequenceIntroducerComponents True args mode) = parsePrivCsi mode args 172 | 173 | changeZero :: Int -> Int -> Int 174 | changeZero toVal 0 = toVal 175 | changeZero _ val = val 176 | 177 | headChangeZero :: Int -> NonEmpty Int -> Int 178 | headChangeZero toVal args = changeZero toVal (NE.head args) 179 | 180 | parseCsi :: Char -> NonEmpty Int -> Maybe ControlSequenceIntroducer 181 | parseCsi mode args = case mode of 182 | 'A' -> Just (CSI_CursorUp (headChangeZero 1 args)) 183 | 'B' -> Just (CSI_CursorDown (headChangeZero 1 args)) 184 | 'C' -> Just (CSI_CursorForward (headChangeZero 1 args)) 185 | 'D' -> Just (CSI_CursorBack (headChangeZero 1 args)) 186 | 'K' -> 187 | CSI_EraseInLine <$> case NE.head args of 188 | 0 -> Just ClearFromCursorToEndOfLine 189 | 1 -> Just ClearFromCursorToBeginningOfLine 190 | 2 -> Just ClearEntireLine 191 | _ -> Nothing 192 | '@' -> Just (CSI_InsertBlankCharacters (headChangeZero 1 args)) 193 | 'P' -> Just (CSI_DeleteChars (headChangeZero 1 args)) 194 | 'G' -> Just (CSI_CursorCharacterAbsolute (headChangeZero 1 args)) 195 | 'H' -> 196 | let (row, col) = case args of 197 | r :| [] -> (r, 0) 198 | r :| (c : _) -> (r, c) 199 | in Just (CSI_CursorPosition (changeZero 1 row) (changeZero 1 col)) 200 | 'J' -> case NE.head args of 201 | 0 -> Just (CSI_EraseInDisplay EraseBelow) 202 | 1 -> Just (CSI_EraseInDisplay EraseAbove) 203 | 2 -> Just (CSI_EraseInDisplay EraseAll) 204 | 3 -> Just (CSI_EraseInDisplay EraseSavedLines) 205 | _ -> Nothing 206 | 'L' -> Just (CSI_InsertBlankLines (headChangeZero 1 args)) 207 | 'M' -> Just (CSI_DeleteLines (headChangeZero 1 args)) 208 | 'S' -> Just (CSI_ScrollUp (headChangeZero 1 args)) 209 | 'T' -> Just (CSI_ScrollDown (headChangeZero 1 args)) 210 | 'X' -> Just (CSI_EraseCharacters (headChangeZero 1 args)) 211 | '`' -> Just (CSI_CharacterPositionAbsolute (headChangeZero 1 args)) 212 | 'a' -> Just (CSI_CharacterPositionRelative (headChangeZero 1 args)) 213 | 'c' -> case args of 214 | 0 :| [] -> Just CSI_SendDeviceAttributes 215 | _ -> Nothing 216 | 'd' -> Just (CSI_LinePositionAbsolute (headChangeZero 1 args)) 217 | 'e' -> Just (CSI_LinePositionRelative (headChangeZero 1 args)) 218 | 'f' -> 219 | let (row, col) = case args of 220 | r :| [] -> (r, 0) 221 | r :| (c : _) -> (r, c) 222 | in Just (CSI_HorizontalVerticalPosition (changeZero 1 row) (changeZero 1 col)) 223 | 't' -> case args of 224 | 22 :| 0 : _ -> Just (CSI_WindowManipulation SaveIconAndWindowTitleOnStack) 225 | 23 :| 0 : _ -> Just (CSI_WindowManipulation RestoreIconAndWindowTitleOnStack) 226 | _ -> Nothing 227 | 'h' -> case args of 228 | 2 :| [] -> Just (CSI_SetMode KeyboardActionMode) 229 | 4 :| [] -> Just (CSI_SetMode InsertReplaceMode) 230 | 12 :| [] -> Just (CSI_SetMode SendReceive) 231 | 20 :| [] -> Just (CSI_SetMode AutomaticNewlineNormalLinefeed) 232 | _ -> Nothing 233 | 'l' -> case args of 234 | 2 :| [] -> Just (CSI_ResetMode KeyboardActionMode) 235 | 4 :| [] -> Just (CSI_ResetMode InsertReplaceMode) 236 | 12 :| [] -> Just (CSI_ResetMode SendReceive) 237 | 20 :| [] -> Just (CSI_ResetMode AutomaticNewlineNormalLinefeed) 238 | _ -> Nothing 239 | 'n' -> case NE.head args of 240 | 5 -> Just (CSI_DeviceStatusReport StatusReport) 241 | 6 -> Just (CSI_DeviceStatusReport ReportCursorPosition) 242 | _ -> Nothing 243 | 'r' -> 244 | let (top, bottom) = case args of 245 | t :| [] -> (t, 0) 246 | t :| (b : _) -> (t, b) 247 | in Just 248 | ( CSI_DECSTBM 249 | (if top == 0 then Nothing else Just top) 250 | (if bottom == 0 then Nothing else Just bottom) 251 | ) 252 | 'm' -> Just $ CSI_SGR (V.fromList (mapMaybe codeToSGR (NE.toList args))) 253 | _ -> Nothing 254 | 255 | parsePrivCsi :: Char -> NonEmpty Int -> Maybe ControlSequenceIntroducer 256 | parsePrivCsi mode args = case mode of 257 | 'h' -> 258 | let n = (headChangeZero 1 args) 259 | in Just $ case intToDECPrivateMode n of 260 | Just decset -> CSI_DECSET decset 261 | Nothing -> CSI_DECSET_Unknown n 262 | 'l' -> 263 | let n = (headChangeZero 1 args) 264 | in Just $ case intToDECPrivateMode n of 265 | Just decset -> CSI_DECRST decset 266 | Nothing -> CSI_DECRST_Unknown n 267 | _ -> Nothing 268 | 269 | processControlSequenceIntroducer :: ControlSequenceIntroducerInput -> Maybe ControlSequenceIntroducer 270 | processControlSequenceIntroducer csiInput = 271 | parseControlSequenceIntroducerComponents csiInput 272 | >>= processControlSequenceIntroducerComponents 273 | 274 | processOtherControlSequenceIntroducer :: ControlSequenceIntroducerInput -> Maybe ControlSequenceIntroducer 275 | processOtherControlSequenceIntroducer (ControlSequenceIntroducerInput str) = 276 | case str of 277 | "!p" -> Just CSI_SoftTerminalReset 278 | ">c" -> Just (CSI_SendDeviceAttributesSecondary RequestTerminalIdentificationCode) 279 | ">0c" -> Just (CSI_SendDeviceAttributesSecondary RequestTerminalIdentificationCode) 280 | _ 281 | | "?" `T.isPrefixOf` str && "$p" `T.isSuffixOf` str -> 282 | let modeStr = T.init (T.init (T.tail str)) 283 | in case T.decimal modeStr of 284 | Left _ -> Nothing 285 | Right (mode, "") -> Just (CSI_RequestDECPrivateMode mode) 286 | Right (_, _) -> Nothing 287 | _ -> Nothing 288 | 289 | -- | Used for error reporting 290 | renderCsi :: ControlSequenceIntroducerInput -> Text 291 | renderCsi (ControlSequenceIntroducerInput str) = "\ESC[" <> str 292 | 293 | ----------------------------------------------------------------------- 294 | -- OSC (Operating System Command) 295 | ----------------------------------------------------------------------- 296 | 297 | data OperatingSystemCommandInput = OperatingSystemCommandInput !Text 298 | 299 | -- | Should be run after reading the sequence @ESC ]@ 300 | -- 301 | -- This parser always succeeds 302 | parseOperatingSystemCommand :: Parser OperatingSystemCommandInput 303 | parseOperatingSystemCommand = do 304 | str <- 305 | manyTill' 306 | anyChar 307 | ( (char '\a' >> pure ()) 308 | <|> (string "\ESC\\" >> pure ()) 309 | ) 310 | pure (OperatingSystemCommandInput (T.pack str)) 311 | 312 | -- | Used for error reporting 313 | renderOsc :: OperatingSystemCommandInput -> Text 314 | renderOsc (OperatingSystemCommandInput str) = "\ESC]" <> str <> "\a" 315 | 316 | processOperatingSystemCommand :: OperatingSystemCommandInput -> Maybe OperatingSystemCommand 317 | processOperatingSystemCommand (OperatingSystemCommandInput str) = 318 | case parseOnly (parser <* endOfInput) str of 319 | Left _ -> Nothing 320 | Right val -> Just val 321 | where 322 | parser :: Parser OperatingSystemCommand 323 | parser = 324 | parseSetTitle 325 | <|> parseChangeTextForegroundColor 326 | <|> parseRequestTextForegroundColor 327 | <|> parseChangeTextBackgroundColor 328 | <|> parseRequestTextBackgroundColor 329 | <|> parseResetTextCursorColor 330 | 331 | parseSetTitle :: Parser OperatingSystemCommand 332 | parseSetTitle = do 333 | (icon, window) <- parseSetTitleMode 334 | _ <- char ';' 335 | title <- takeText 336 | pure (OSC_SetTitle icon window title) 337 | 338 | parseSetTitleMode :: Parser (Bool, Bool) 339 | parseSetTitleMode = 340 | (char '0' >> pure (True, True)) 341 | <|> (char '1' >> pure (True, False)) 342 | <|> (char '2' >> pure (False, True)) 343 | 344 | parseChangeTextForegroundColor :: Parser OperatingSystemCommand 345 | parseChangeTextForegroundColor = do 346 | _ <- string "10;" 347 | c <- satisfy (/= '?') 348 | color <- takeText 349 | pure (OSC_ChangeTextForegroundColor (T.singleton c <> color)) 350 | 351 | parseRequestTextForegroundColor :: Parser OperatingSystemCommand 352 | parseRequestTextForegroundColor = do 353 | _ <- string "10;?" 354 | pure OSC_RequestTextForegroundColor 355 | 356 | parseChangeTextBackgroundColor :: Parser OperatingSystemCommand 357 | parseChangeTextBackgroundColor = do 358 | _ <- string "11;" 359 | c <- satisfy (/= '?') 360 | color <- takeText 361 | pure (OSC_ChangeTextBackgroundColor (T.singleton c <> color)) 362 | 363 | parseRequestTextBackgroundColor :: Parser OperatingSystemCommand 364 | parseRequestTextBackgroundColor = do 365 | _ <- string "11;?" 366 | pure OSC_RequestTextBackgroundColor 367 | 368 | parseResetTextCursorColor :: Parser OperatingSystemCommand 369 | parseResetTextCursorColor = do 370 | _ <- string "112" 371 | pure OSC_ResetTextCursorColor 372 | 373 | ----------------------------------------------------------------------- 374 | -- Single Character Escape Sequence 375 | ----------------------------------------------------------------------- 376 | 377 | singleCharacterEscapeSequence :: Char -> Maybe EscapeSequence 378 | singleCharacterEscapeSequence c = 379 | case c of 380 | 'M' -> Just Esc_ReverseIndex 381 | 'c' -> Just Esc_RIS 382 | '=' -> Just Esc_DECPAM 383 | '>' -> Just Esc_DECPNM 384 | _ -> Nothing 385 | 386 | ----------------------------------------------------------------------- 387 | -- Helper functions 388 | ----------------------------------------------------------------------- 389 | 390 | between :: Ord a => a -> (a, a) -> Bool 391 | between val (low, high) = val >= low && val <= high 392 | 393 | isControlC0 :: Char -> Bool 394 | isControlC0 c = fromEnum c `between` (0, 0x1F) || c == '\DEL' 395 | 396 | isControlC1 :: Char -> Bool 397 | isControlC1 c = fromEnum c `between` (0x80, 0x9f) 398 | 399 | isControl :: Char -> Bool 400 | isControl c = isControlC0 c || isControlC1 c 401 | -------------------------------------------------------------------------------- /hs-term-emulator/src/System/Terminal/Emulator/Term/Process.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module System.Terminal.Emulator.Term.Process 5 | ( Term, 6 | TermLine, 7 | processTermAtoms, 8 | ) 9 | where 10 | 11 | import Control.Category ((>>>)) 12 | import Control.Lens 13 | import Data.ByteString (ByteString) 14 | import qualified Data.ByteString as B 15 | import qualified Data.ByteString.Char8 as BC8 16 | import Data.Foldable (foldl') 17 | import Data.List (iterate') 18 | import Data.Text (Text) 19 | import qualified Data.Text as T 20 | import qualified Data.Vector as V 21 | import qualified Data.Vector.Unboxed as VU 22 | import qualified System.Console.ANSI.Types as SGR 23 | import System.Terminal.Emulator.Attrs (Attrs, attrsBg, attrsFg, attrsIntensity, attrsUnderline, blankAttrs) 24 | import System.Terminal.Emulator.DECPrivateMode (DECPrivateMode) 25 | import qualified System.Terminal.Emulator.DECPrivateMode as DECPrivateMode 26 | import System.Terminal.Emulator.KeyboardInput (KeyboardState (keyboardState_CRLF, keyboardState_DECCKM, keyboardState_DECPAM, keyboardState_Locked)) 27 | import System.Terminal.Emulator.Parsing.Types (ControlSequenceIntroducer (..), DeviceStatusReport (..), EraseInDisplayParam (..), EraseInLineParam (..), EscapeSequence (..), Mode (..), OperatingSystemCommand (..), SendDeviceAttributesSecondary (RequestTerminalIdentificationCode), SingleCharacterFunction (..), TermAtom (..), WindowManipulation (..)) 28 | import System.Terminal.Emulator.Term (Term, activeScreen, addScrollBackLines, altScreenActive, cursorLine, cursorPos, cursorState, insertMode, keyboardState, mkTerm, modeWrap, numCols, numRows, origin, scrollBackLines, scrollBottom, scrollTop, termAttrs, termScreen, vuIndex, windowTitle, wrapNext) 29 | import System.Terminal.Emulator.TermLines (TermLine) 30 | import qualified System.Terminal.Emulator.TermLines as TL 31 | import Prelude hiding (lines) 32 | 33 | processTermAtoms :: [TermAtom] -> Term -> (ByteString, Term) 34 | processTermAtoms termAtoms term = 35 | foldl' 36 | ( \(!w1, !t) termAtom -> 37 | let (!w2, !t') = processTermAtom termAtom t 38 | in (w1 <> w2, t') 39 | ) 40 | (B.empty, term) 41 | termAtoms 42 | 43 | processTermAtom :: TermAtom -> Term -> (ByteString, Term) 44 | processTermAtom (TermAtom_VisibleChar char) = nw $ processVisibleChar char 45 | processTermAtom (TermAtom_SingleCharacterFunction Control_Bell) = nw id -- TODO 46 | processTermAtom (TermAtom_SingleCharacterFunction Control_Backspace) = nw $ \term -> cursorMoveTo (term ^. cursorPos . _1, (term ^. cursorPos . _2) - 1) term 47 | processTermAtom (TermAtom_SingleCharacterFunction Control_Tab) = nw $ putTabs 1 48 | processTermAtom (TermAtom_SingleCharacterFunction Control_LineFeed) = nw $ processLF 49 | processTermAtom (TermAtom_SingleCharacterFunction Control_VerticalTab) = nw $ processLF 50 | processTermAtom (TermAtom_SingleCharacterFunction Control_FormFeed) = nw $ processLF 51 | processTermAtom (TermAtom_SingleCharacterFunction Control_CarriageReturn) = nw $ \term -> cursorMoveTo (term ^. cursorPos . _1, 0) term 52 | processTermAtom (TermAtom_SingleCharacterFunction Control_ReturnTerminalStatus) = nw id 53 | processTermAtom (TermAtom_SingleCharacterFunction Control_SwitchToStandardCharacterSet) = nw id 54 | processTermAtom (TermAtom_SingleCharacterFunction Control_SwitchToAlternateCharacterSet) = nw id 55 | processTermAtom (TermAtom_EscapeSequence escapeSequence) = processEscapeSequence escapeSequence 56 | processTermAtom (TermAtom_SingleCharacterFunctionUnknown x) = error $ "Unknown Character Function: " <> show x 57 | processTermAtom (TermAtom_EscapeSequenceUnknown x) 58 | | isExpectedInvalidEscSequence x = nw id 59 | | otherwise = error $ "Unknown ESC seq: " <> show x 60 | 61 | -- | No-write operation 62 | nw :: (Term -> Term) -> Term -> (ByteString, Term) 63 | nw f term = (B.empty, f term) 64 | 65 | -- | I have observed some invalid ESC sequences in the wild, that I am 66 | -- deciding to ignore for now 67 | isExpectedInvalidEscSequence :: Text -> Bool 68 | isExpectedInvalidEscSequence str 69 | | ("\ESC[" `T.isPrefixOf` str) && T.any (== '\r') str = True 70 | | str == "\ESC\r" = True 71 | | otherwise = False 72 | 73 | processEscapeSequence :: EscapeSequence -> Term -> (ByteString, Term) 74 | processEscapeSequence Esc_ReverseIndex = nw reverseIndex 75 | processEscapeSequence Esc_RIS = nw id -- TODO 76 | processEscapeSequence Esc_DECPAM = nw $ keyboardState %~ (\state -> state {keyboardState_DECPAM = True}) 77 | processEscapeSequence Esc_DECPNM = nw $ keyboardState %~ (\state -> state {keyboardState_DECPAM = False}) 78 | processEscapeSequence (ESC_SetG0CharacterSet _) = nw id -- Ignore 79 | processEscapeSequence (Esc_CSI (CSI_CursorUp n)) = nw $ \term -> cursorMoveTo ((term ^. cursorPos . _1) - n, term ^. cursorPos . _2) term 80 | processEscapeSequence (Esc_CSI (CSI_CursorDown n)) = nw $ \term -> cursorMoveTo ((term ^. cursorPos . _1) + n, term ^. cursorPos . _2) term 81 | processEscapeSequence (Esc_CSI (CSI_LinePositionRelative n)) = nw $ \term -> cursorMoveTo ((term ^. cursorPos . _1) + n, term ^. cursorPos . _2) term 82 | processEscapeSequence (Esc_CSI (CSI_CharacterPositionRelative n)) = nw $ \term -> cursorMoveTo (term ^. cursorPos . _1, (term ^. cursorPos . _2) + n) term 83 | processEscapeSequence (Esc_CSI (CSI_CursorForward n)) = nw $ \term -> cursorMoveTo (term ^. cursorPos . _1, (term ^. cursorPos . _2) + n) term 84 | processEscapeSequence (Esc_CSI (CSI_CursorBack n)) = nw $ \term -> cursorMoveTo (term ^. cursorPos . _1, (term ^. cursorPos . _2) - n) term 85 | processEscapeSequence (Esc_CSI (CSI_EraseInLine param)) = nw $ eraseInLine param 86 | processEscapeSequence (Esc_CSI (CSI_EraseCharacters n)) = nw $ eraseCharacters n 87 | processEscapeSequence (Esc_CSI (CSI_InsertBlankCharacters n)) = nw $ insertBlankChars n 88 | processEscapeSequence (Esc_CSI (CSI_InsertBlankLines n)) = nw $ insertBlankLines n 89 | processEscapeSequence (Esc_CSI (CSI_DeleteChars n)) = nw $ deleteChars n 90 | processEscapeSequence (Esc_CSI (CSI_DeleteLines n)) = nw $ deleteLines n 91 | processEscapeSequence (Esc_CSI (CSI_CursorCharacterAbsolute col)) = nw $ \term -> cursorMoveTo (term ^. cursorPos . _1, col - 1) term 92 | processEscapeSequence (Esc_CSI (CSI_CharacterPositionAbsolute col)) = nw $ \term -> cursorMoveTo (term ^. cursorPos . _1, col - 1) term 93 | processEscapeSequence (Esc_CSI (CSI_CursorPosition row col)) = nw $ cursorMoveAbsoluteTo (row - 1, col - 1) 94 | processEscapeSequence (Esc_CSI (CSI_HorizontalVerticalPosition row col)) = nw $ cursorMoveAbsoluteTo (row - 1, col - 1) 95 | processEscapeSequence (Esc_CSI (CSI_LinePositionAbsolute row)) = nw $ \term -> cursorMoveAbsoluteTo (row - 1, term ^. cursorPos . _2) term 96 | processEscapeSequence (Esc_CSI (CSI_ScrollUp n)) = nw $ \term -> scrollUp (term ^. scrollTop) n term 97 | processEscapeSequence (Esc_CSI (CSI_ScrollDown n)) = nw $ \term -> scrollDown (term ^. scrollTop) n term 98 | processEscapeSequence (Esc_CSI (CSI_EraseInDisplay param)) = nw $ eraseInDisplay param 99 | processEscapeSequence (Esc_CSI (CSI_WindowManipulation param)) = nw $ windowManipulation param 100 | processEscapeSequence (Esc_CSI (CSI_DeviceStatusReport param)) = deviceStatusReport param 101 | processEscapeSequence (Esc_CSI (CSI_SoftTerminalReset)) = nw $ softTerminalReset 102 | processEscapeSequence (Esc_CSI (CSI_SetMode param)) = nw $ setMode param 103 | processEscapeSequence (Esc_CSI (CSI_ResetMode param)) = nw $ resetMode param 104 | processEscapeSequence (Esc_CSI (CSI_SendDeviceAttributes)) = sendDeviceAttributes 105 | processEscapeSequence (Esc_CSI (CSI_SendDeviceAttributesSecondary param)) = sendDeviceAttributesSecondary param 106 | processEscapeSequence (Esc_CSI (CSI_RequestDECPrivateMode _i)) = nw id -- TODO (?) 107 | processEscapeSequence (Esc_CSI (CSI_DECSTBM top bottom)) = nw $ (setScrollingRegion top bottom) >>> cursorMoveAbsoluteTo (0, 0) 108 | processEscapeSequence (Esc_CSI (CSI_DECSET decset)) = nw $ termProcessDecset decset 109 | processEscapeSequence (Esc_CSI (CSI_DECSET_Unknown _code)) = nw id -- TODO Log this 110 | processEscapeSequence (Esc_CSI (CSI_DECRST decset)) = nw $ termProcessDecrst decset 111 | processEscapeSequence (Esc_CSI (CSI_DECRST_Unknown _code)) = nw id -- TODO Log this 112 | processEscapeSequence (Esc_CSI (CSI_SGR sgrs)) = nw $ \term -> V.foldl' (flip termProcessSGR) term sgrs 113 | processEscapeSequence (Esc_OSC osc) = processOsc osc 114 | 115 | putTabs :: Int -> Term -> Term 116 | putTabs n 117 | | n >= 0 = \term -> (iterate' putTabForward term) !! n 118 | | otherwise = \term -> (iterate' putTabBackward term) !! (negate n) 119 | where 120 | tabspaces = 8 121 | putTabForward :: Term -> Term 122 | putTabForward term = ((cursorPos . _2) .~ (limit 0 (term ^. numCols - 1) col')) term 123 | where 124 | col = term ^. cursorPos . _2 125 | col' = ((col + tabspaces) `div` tabspaces) * tabspaces 126 | putTabBackward :: Term -> Term 127 | putTabBackward term 128 | | col == 0 = term 129 | | otherwise = ((cursorPos . _2) .~ (limit 0 (term ^. numCols - 1) col')) term 130 | where 131 | col = term ^. cursorPos . _2 132 | col' = ((col - 1) `div` tabspaces) * tabspaces 133 | 134 | processLF :: Term -> Term 135 | processLF term = addNewline (keyboardState_CRLF (term ^. keyboardState)) term 136 | 137 | eraseInLine :: EraseInLineParam -> Term -> Term 138 | eraseInLine ClearFromCursorToEndOfLine term = clearRegion (term ^. cursorPos) (term ^. cursorPos ^. _1, (term ^. numCols) - 1) term 139 | eraseInLine ClearFromCursorToBeginningOfLine term = clearRegion (term ^. cursorPos ^. _1, 0) (term ^. cursorPos) term 140 | eraseInLine ClearEntireLine term = clearRegion (term ^. cursorPos ^. _1, 0) (term ^. cursorPos ^. _1, (term ^. numCols) - 1) term 141 | 142 | eraseCharacters :: Int -> Term -> Term 143 | eraseCharacters n term = clearRegion (term ^. cursorPos) ((_2 %~ ((subtract 1) . (+ n))) (term ^. cursorPos)) term 144 | 145 | reverseIndex :: Term -> Term 146 | reverseIndex term 147 | | term ^. cursorPos . _1 == term ^. scrollTop = scrollDown (term ^. scrollTop) 1 term 148 | | otherwise = cursorMoveTo ((term ^. cursorPos . _1) - 1, term ^. cursorPos . _2) term 149 | 150 | eraseInDisplay :: EraseInDisplayParam -> Term -> Term 151 | eraseInDisplay EraseAbove _ = error "TODO EraseAbove" 152 | eraseInDisplay EraseBelow term = (clearToEndOfLine >>> clearBelow) term 153 | where 154 | clearToEndOfLine = clearRegion (term ^. cursorPos) ((_2 .~ ((term ^. numCols) - 1)) (term ^. cursorPos)) 155 | clearBelow 156 | | term ^. cursorPos . _1 < term ^. numRows - 1 = 157 | clearRegion 158 | (((_1 %~ (+ 1)) >>> (_2 .~ 0)) (term ^. cursorPos)) 159 | (((_1 .~ ((term ^. numRows) - 1)) >>> (_2 .~ ((term ^. numCols) - 1))) (term ^. cursorPos)) 160 | | otherwise = id 161 | eraseInDisplay EraseAll term = clearRegion (0, 0) ((term ^. numRows) - 1, (term ^. numCols) - 1) term 162 | eraseInDisplay EraseSavedLines term = (scrollBackLines .~ TL.empty) term 163 | 164 | windowManipulation :: WindowManipulation -> Term -> Term 165 | windowManipulation SaveIconAndWindowTitleOnStack = id -- TODO We could add a stack to our 'Term' data structure and save this 166 | windowManipulation RestoreIconAndWindowTitleOnStack = id -- TODO We could add a stack to our 'Term' data structure and save this 167 | 168 | deviceStatusReport :: DeviceStatusReport -> Term -> (ByteString, Term) 169 | deviceStatusReport param term = case param of 170 | StatusReport -> 171 | let ok = "\ESC[0n" 172 | in (ok, term) 173 | ReportCursorPosition -> 174 | let (line, col) = term ^. cursorPos 175 | lineStr = BC8.pack (show (line + 1)) 176 | colStr = BC8.pack (show (col + 1)) 177 | cpr = "\ESC[" <> lineStr <> ";" <> colStr <> "R" 178 | in (cpr, term) 179 | 180 | sendDeviceAttributes :: Term -> (ByteString, Term) 181 | sendDeviceAttributes term = 182 | let identification = "\ESC[?1;2c" -- TODO or maybe "\ESC[?6c" ? 183 | in (identification, term) 184 | 185 | sendDeviceAttributesSecondary :: SendDeviceAttributesSecondary -> Term -> (ByteString, Term) 186 | sendDeviceAttributesSecondary RequestTerminalIdentificationCode term = 187 | let identification = "\ESC[>0;0;0c" 188 | in (identification, term) 189 | 190 | softTerminalReset :: Term -> Term 191 | softTerminalReset term = mkTerm (term ^. numCols, term ^. numRows) 192 | 193 | setMode :: Mode -> Term -> Term 194 | setMode KeyboardActionMode = keyboardState %~ (\state -> state {keyboardState_Locked = True}) 195 | setMode InsertReplaceMode = insertMode .~ True 196 | setMode SendReceive = error "TODO Send/receive (SRM) Not Supported" 197 | setMode AutomaticNewlineNormalLinefeed = keyboardState %~ (\state -> state {keyboardState_CRLF = True}) 198 | 199 | resetMode :: Mode -> Term -> Term 200 | resetMode KeyboardActionMode = keyboardState %~ (\state -> state {keyboardState_Locked = False}) 201 | resetMode InsertReplaceMode = insertMode .~ False 202 | resetMode SendReceive = id 203 | resetMode AutomaticNewlineNormalLinefeed = keyboardState %~ (\state -> state {keyboardState_CRLF = False}) 204 | 205 | processOsc :: OperatingSystemCommand -> Term -> (ByteString, Term) 206 | processOsc (OSC_SetTitle _ True str) = nw $ windowTitle .~ str 207 | processOsc (OSC_SetTitle _ False _) = nw id -- set window icon not supported 208 | processOsc (OSC_ChangeTextForegroundColor _) = nw id -- Ignore 209 | processOsc (OSC_ChangeTextBackgroundColor _) = nw id -- Ignore 210 | processOsc OSC_RequestTextForegroundColor = \term -> ("\ESC]10;0\a", term) 211 | processOsc OSC_RequestTextBackgroundColor = \term -> ("\ESC]11;0\a", term) 212 | processOsc OSC_ResetTextCursorColor = nw id 213 | 214 | insertBlankChars :: Int -> Term -> Term 215 | insertBlankChars n term = (cursorLine %~ updateLine) term 216 | where 217 | n' = limit 0 (term ^. numCols - term ^. cursorPos . _2) n 218 | col = term ^. cursorPos . _2 219 | updateLine :: TermLine -> TermLine 220 | updateLine termLine = 221 | start <> blanks <> rest 222 | where 223 | start = VU.take col termLine 224 | blanks = VU.replicate n' (' ', term ^. termAttrs) 225 | rest = VU.slice col (term ^. numCols - col - n') termLine 226 | 227 | insertBlankLines :: Int -> Term -> Term 228 | insertBlankLines n term 229 | | between (term ^. scrollTop, term ^. scrollBottom) (term ^. cursorPos . _1) = scrollDown (term ^. cursorPos . _1) n term 230 | | otherwise = term 231 | 232 | deleteChars :: Int -> Term -> Term 233 | deleteChars n term = (cursorLine %~ updateLine) term 234 | where 235 | n' = limit 0 ((term ^. numCols) - (term ^. cursorPos . _2)) n 236 | srcCol = col + n' 237 | size = term ^. numCols - srcCol 238 | col = term ^. cursorPos . _2 239 | updateLine :: TermLine -> TermLine 240 | updateLine termLine = 241 | start <> slice <> VU.replicate n' (' ', term ^. termAttrs) 242 | where 243 | start = VU.take col termLine 244 | slice = VU.slice srcCol size termLine 245 | 246 | deleteLines :: Int -> Term -> Term 247 | deleteLines n term 248 | | between (term ^. scrollTop, term ^. scrollBottom) (term ^. cursorPos . _1) = scrollUp (term ^. cursorPos . _1) n term 249 | | otherwise = term 250 | 251 | setScrollingRegion :: Maybe Int -> Maybe Int -> Term -> Term 252 | setScrollingRegion mbTop mbBottom term = 253 | ((scrollTop .~ top) >>> (scrollBottom .~ bottom)) term 254 | where 255 | top1 = case mbTop of 256 | Nothing -> 0 257 | Just t -> t - 1 258 | bottom1 = case mbBottom of 259 | Nothing -> term ^. numRows - 1 260 | Just b -> b - 1 261 | minY = 0 262 | maxY = term ^. numRows - 1 263 | top2 = limit minY maxY top1 264 | bottom2 = limit minY maxY bottom1 265 | (top, bottom) = if top2 > bottom2 then (bottom2, top2) else (top2, bottom2) 266 | 267 | termProcessDecset :: DECPrivateMode -> Term -> Term 268 | termProcessDecset DECPrivateMode.DECCKM = keyboardState %~ (\state -> state {keyboardState_DECCKM = True}) 269 | termProcessDecset DECPrivateMode.DECOM = (cursorState . origin .~ True) >>> (cursorMoveAbsoluteTo (0, 0)) 270 | termProcessDecset DECPrivateMode.ReportButtonPress = id 271 | termProcessDecset DECPrivateMode.BracketedPasteMode = id -- TODO Set flag on 'Term' 272 | termProcessDecset DECPrivateMode.SaveCursorAsInDECSCAndUseAlternateScreenBuffer = altScreenActive .~ True 273 | termProcessDecset DECPrivateMode.Att610 = id -- TODO Set flag on 'Term' 274 | termProcessDecset DECPrivateMode.DECTCEM = id -- TODO Set flag on 'Term' 275 | termProcessDecset DECPrivateMode.DECAWM = modeWrap .~ True 276 | termProcessDecset other = error $ "TODO: DECSET: " <> show other 277 | 278 | termProcessDecrst :: DECPrivateMode -> Term -> Term 279 | termProcessDecrst DECPrivateMode.DECCKM = keyboardState %~ (\state -> state {keyboardState_DECCKM = False}) 280 | termProcessDecrst DECPrivateMode.DECOM = (cursorState . origin .~ False) >>> (cursorMoveAbsoluteTo (0, 0)) 281 | termProcessDecrst DECPrivateMode.Att610 = id -- TODO Unset flag on 'Term' 282 | termProcessDecrst DECPrivateMode.DECTCEM = id -- TODO Unset flag on 'Term' 283 | termProcessDecrst DECPrivateMode.DECCOLM = id -- Ignored 284 | termProcessDecrst DECPrivateMode.ReportButtonPress = id 285 | termProcessDecrst DECPrivateMode.BracketedPasteMode = id -- TODO Unset flag on 'Term' 286 | termProcessDecrst DECPrivateMode.SaveCursorAsInDECSCAndUseAlternateScreenBuffer = altScreenActive .~ False 287 | termProcessDecrst DECPrivateMode.DECAWM = modeWrap .~ False 288 | termProcessDecrst DECPrivateMode.EnableAllMouseMotions = id 289 | termProcessDecrst DECPrivateMode.ReportMotionOnButtonPress = id 290 | termProcessDecrst other = error $ "TODO: DECRST: " <> show other 291 | 292 | termProcessSGR :: SGR.SGR -> Term -> Term 293 | termProcessSGR = over termAttrs . applySGR 294 | 295 | -- | For absolute user moves, when DECOM is set 296 | cursorMoveAbsoluteTo :: (Int, Int) -> Term -> Term 297 | cursorMoveAbsoluteTo (row, col) term = 298 | cursorMoveTo (row + rowOffset, col) term 299 | where 300 | rowOffset 301 | | term ^. cursorState . origin = term ^. scrollTop 302 | | otherwise = 0 303 | 304 | cursorMoveTo :: (Int, Int) -> Term -> Term 305 | cursorMoveTo (row, col) term = 306 | ( cursorPos . _1 .~ (limit minY maxY row) 307 | >>> cursorPos . _2 .~ (limit minX maxX col) 308 | >>> cursorState . wrapNext .~ False 309 | ) 310 | term 311 | where 312 | minX = 0 313 | maxX = term ^. numCols - 1 314 | (minY, maxY) 315 | | term ^. cursorState . origin = (term ^. scrollTop, term ^. scrollBottom) 316 | | otherwise = (0, term ^. numRows - 1) 317 | 318 | applySGR :: SGR.SGR -> Attrs -> Attrs 319 | applySGR SGR.Reset = const blankAttrs 320 | applySGR (SGR.SetConsoleIntensity intensity) = set attrsIntensity intensity 321 | applySGR (SGR.SetItalicized _) = id -- TODO Not Supported 322 | applySGR (SGR.SetUnderlining underlining) = set attrsUnderline underlining 323 | applySGR (SGR.SetBlinkSpeed _) = id -- TODO Not Supported 324 | applySGR (SGR.SetVisible _) = id -- TODO Not Supported 325 | applySGR (SGR.SetSwapForegroundBackground _) = id -- TODO Not Supported 326 | applySGR (SGR.SetColor SGR.Foreground intensity color) = set attrsFg (Just (intensity, color)) 327 | applySGR (SGR.SetColor SGR.Background intensity color) = set attrsBg (Just (intensity, color)) 328 | applySGR (SGR.SetRGBColor _ _) = id -- TODO Not Supported 329 | applySGR (SGR.SetPaletteColor _ _) = id -- TODO Not Supported 330 | applySGR (SGR.SetDefaultColor SGR.Foreground) = set attrsFg Nothing 331 | applySGR (SGR.SetDefaultColor SGR.Background) = set attrsBg Nothing 332 | 333 | processVisibleChar :: Char -> Term -> Term 334 | processVisibleChar c = 335 | moveCursorBefore 336 | >>> moveChars 337 | >>> moveCursorDown 338 | >>> setChar 339 | >>> moveCursorAfter 340 | where 341 | moveCursorBefore :: Term -> Term 342 | moveCursorBefore term 343 | | (term ^. modeWrap) && (term ^. cursorState ^. wrapNext) = addNewline True term 344 | | otherwise = term 345 | moveChars :: Term -> Term 346 | moveChars term 347 | | (term ^. insertMode) && (col < (term ^. numCols) - 1) = 348 | ( cursorLine 349 | %~ ( \line -> 350 | VU.take 351 | (term ^. numCols) 352 | (VU.take col line <> VU.singleton (' ', 0) <> VU.drop col line) 353 | ) 354 | ) 355 | term 356 | | otherwise = term 357 | where 358 | col = term ^. cursorPos . _2 359 | moveCursorDown :: Term -> Term 360 | moveCursorDown term 361 | | term ^. cursorPos . _2 > (term ^. numCols) - 1 = addNewline True term 362 | | otherwise = term 363 | setChar :: Term -> Term 364 | setChar term = ((cursorLine . (vuIndex (term ^. cursorPos . _2))) .~ (c, term ^. termAttrs)) term 365 | moveCursorAfter :: Term -> Term 366 | moveCursorAfter term 367 | | term ^. cursorPos . _2 < (term ^. numCols) - 1 = cursorMoveTo (term ^. cursorPos . _1, (term ^. cursorPos . _2) + 1) term 368 | | otherwise = ((cursorState . wrapNext) .~ True) term 369 | 370 | addNewline :: 371 | -- | first column 372 | Bool -> 373 | Term -> 374 | Term 375 | addNewline firstCol = doScrollUp >>> moveCursor 376 | where 377 | doScrollUp :: Term -> Term 378 | doScrollUp term 379 | | term ^. cursorPos . _1 == term ^. scrollBottom = scrollUp (term ^. scrollTop) 1 term 380 | | otherwise = term 381 | moveCursor :: Term -> Term 382 | moveCursor term = cursorMoveTo (newRow, newCol) term 383 | where 384 | newRow 385 | | term ^. cursorPos . _1 == term ^. scrollBottom = term ^. cursorPos . _1 386 | | otherwise = (term ^. cursorPos . _1) + 1 387 | newCol 388 | | firstCol = 0 389 | | otherwise = term ^. cursorPos . _2 390 | 391 | scrollDown :: Int -> Int -> Term -> Term 392 | scrollDown orig n term = scrollLines term 393 | where 394 | n' = limit 0 (term ^. scrollBottom - orig + 1) n 395 | scrollLines = 396 | activeScreen 397 | %~ ( \lines -> 398 | TL.take orig lines 399 | <> TL.replicate n' newBlankLine 400 | <> TL.take ((term ^. scrollBottom) - orig - n' + 1) (TL.drop orig lines) 401 | <> TL.drop ((term ^. scrollBottom) + 1) lines 402 | ) 403 | newBlankLine = VU.replicate (term ^. numCols) (' ', term ^. termAttrs) 404 | 405 | scrollUp :: Int -> Int -> Term -> Term 406 | scrollUp orig n term = 407 | (copyLinesToScrollBack >>> scrollLines) term 408 | where 409 | n' = limit 0 (term ^. scrollBottom - orig + 1) n 410 | copyLinesToScrollBack 411 | | not (term ^. altScreenActive) && orig == 0 = addScrollBackLines (TL.take n' (term ^. termScreen)) 412 | | otherwise = id 413 | scrollLines = 414 | activeScreen 415 | %~ ( \lines -> 416 | TL.take orig lines 417 | <> TL.take ((term ^. scrollBottom) - orig - n' + 1) (TL.drop (orig + n') lines) 418 | <> TL.replicate n' newBlankLine 419 | <> TL.drop ((term ^. scrollBottom) + 1) lines 420 | ) 421 | newBlankLine = VU.replicate (term ^. numCols) (' ', term ^. termAttrs) 422 | 423 | clearRegion :: (Int, Int) -> (Int, Int) -> Term -> Term 424 | clearRegion (line1, col1) (line2, col2) term = 425 | foldl' 426 | (\t line -> clearRow line (limit minX maxX col1') (limit minX maxX col2') t) 427 | term 428 | [(limit minY maxY line1') .. (limit minY maxY line2')] 429 | where 430 | line1' = min line1 line2 431 | line2' = max line1 line2 432 | col1' = min col1 col2 433 | col2' = max col1 col2 434 | minX = 0 435 | maxX = term ^. numCols - 1 436 | minY = 0 437 | maxY = term ^. numRows - 1 438 | 439 | clearRow :: Int -> Int -> Int -> Term -> Term 440 | clearRow line startCol endCol term = 441 | foldl' 442 | (\t col -> (activeScreen . TL.vIndex line . vuIndex col .~ (' ', attrs)) t) 443 | term 444 | [startCol .. endCol] 445 | where 446 | attrs = term ^. termAttrs 447 | 448 | limit :: 449 | -- | minimum allowed value 450 | Int -> 451 | -- | maximum allowed value 452 | Int -> 453 | -- | value to limit 454 | Int -> 455 | Int 456 | limit minVal maxVal val 457 | | val < minVal = minVal 458 | | val > maxVal = maxVal 459 | | otherwise = val 460 | 461 | between :: Ord a => (a, a) -> a -> Bool 462 | between (low, high) val = val >= low && val <= high 463 | --------------------------------------------------------------------------------