hs-term-emulator (empty) → 0.1.0.0
raw patch · 17 files changed
+2365/−0 lines, 17 filesdep +ansi-terminaldep +attoparsecdep +base
Dependencies added: ansi-terminal, attoparsec, base, bytestring, containers, criterion, hs-term-emulator, hspec, lens, text, vector
Files
- CHANGELOG.md +5/−0
- LICENSE +19/−0
- bench/Main.hs +31/−0
- hs-term-emulator.cabal +84/−0
- src/System/Terminal/Emulator/Attrs.hs +132/−0
- src/System/Terminal/Emulator/DECPrivateMode.hs +166/−0
- src/System/Terminal/Emulator/KeyboardInput.hs +73/−0
- src/System/Terminal/Emulator/KeyboardInput/KeyPressToPty.hs +131/−0
- src/System/Terminal/Emulator/Parsing.hs +6/−0
- src/System/Terminal/Emulator/Parsing/Internal.hs +400/−0
- src/System/Terminal/Emulator/Parsing/Types.hs +232/−0
- src/System/Terminal/Emulator/Term.hs +242/−0
- src/System/Terminal/Emulator/Term/Process.hs +462/−0
- src/System/Terminal/Emulator/Term/Resize.hs +146/−0
- src/System/Terminal/Emulator/TermLines.hs +106/−0
- test/Spec.hs +1/−0
- test/System/Terminal/Emulator/Parsing/InternalSpec.hs +129/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for hs-term-emulator++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (C) 2021 The hs-term-emulator Authors (see AUTHORS file)++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ bench/Main.hs view
@@ -0,0 +1,31 @@+module Main where++import Criterion.Main+import System.Terminal.Emulator.Parsing.Types+import System.Terminal.Emulator.Term (mkTerm)+import System.Terminal.Emulator.Term.Process (processTermAtoms)++lotsOfAAAAA :: Int -> [TermAtom]+lotsOfAAAAA numRows =+ concat+ ( replicate+ numRows+ ( ( replicate 30 (TermAtom_VisibleChar 'A')+ <> [ TermAtom_SingleCharacterFunction Control_CarriageReturn,+ TermAtom_SingleCharacterFunction Control_LineFeed+ ]+ )+ )+ )++main :: IO ()+main =+ defaultMain+ [ bgroup+ "term"+ [ bench "As 10" $ whnf (processTermAtoms (lotsOfAAAAA 10)) (mkTerm (40, 40)),+ bench "As 100" $ whnf (processTermAtoms (lotsOfAAAAA 100)) (mkTerm (40, 40)),+ bench "As 1000" $ whnf (processTermAtoms (lotsOfAAAAA 1000)) (mkTerm (40, 40)),+ bench "As 10000" $ whnf (processTermAtoms (lotsOfAAAAA 10000)) (mkTerm (40, 40))+ ]+ ]
+ hs-term-emulator.cabal view
@@ -0,0 +1,84 @@+cabal-version: 2.4+name: hs-term-emulator+version: 0.1.0.0+synopsis: Terminal Emulator written in 100% Haskell+description: See: https://github.com/bitc/hs-term-emulator/README.md+homepage: https://github.com/bitc/hs-term-emulator+bug-reports: https://github.com/bitc/hs-term-emulator/issues+license: MIT+license-file: LICENSE+author: Bit Connor+maintainer: https://github.com/bitc+category: Terminal+extra-source-files: CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/bitc/hs-term-emulator.git++library+ -- cabal-fmt: expand src+ exposed-modules:+ System.Terminal.Emulator.Attrs+ System.Terminal.Emulator.DECPrivateMode+ System.Terminal.Emulator.KeyboardInput+ System.Terminal.Emulator.KeyboardInput.KeyPressToPty+ System.Terminal.Emulator.Parsing+ System.Terminal.Emulator.Parsing.Internal+ System.Terminal.Emulator.Parsing.Types+ System.Terminal.Emulator.Term+ System.Terminal.Emulator.Term.Process+ System.Terminal.Emulator.Term.Resize+ System.Terminal.Emulator.TermLines++ build-depends:+ , ansi-terminal ^>=0.11+ , attoparsec ^>=0.14.1+ , base ^>=4.14.1.0+ , bytestring+ , containers ^>=0.6.5.1+ , lens ^>=5.0.1+ , text+ , vector ^>=0.12.3.0++ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall -Werror=incomplete-patterns -Werror=missing-fields++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs++ -- cabal-fmt: expand test -Spec+ other-modules: System.Terminal.Emulator.Parsing.InternalSpec+ hs-source-dirs: test+ build-depends:+ , ansi-terminal ^>=0.11+ , attoparsec ^>=0.14.1+ , base ^>=4.14+ , hs-term-emulator+ , hspec ^>=2.8.2+ , text+ , vector ^>=0.12.3.0++ default-language: Haskell2010+ build-tool-depends: hspec-discover:hspec-discover ==2.*+ other-extensions: TemplateHaskell+ ghc-options:+ -Wall -threaded -Werror=incomplete-patterns -Werror=missing-fields++benchmark bench+ type: exitcode-stdio-1.0+ main-is: Main.hs++ -- cabal-fmt: expand bench -Main+ other-modules:+ hs-source-dirs: bench+ build-depends:+ , base ^>=4.14+ , criterion ^>=1.5.9.0+ , hs-term-emulator++ default-language: Haskell2010+ ghc-options:+ -Wall -threaded -Werror=incomplete-patterns -Werror=missing-fields
+ src/System/Terminal/Emulator/Attrs.hs view
@@ -0,0 +1,132 @@+module System.Terminal.Emulator.Attrs where++import Control.Lens+import Data.Bits+import Data.Word (Word32)+import qualified System.Console.ANSI.Types as SGR++-- | Attrs:+--+-- 00000000 00000000 000000000000uuii+-- ^^ fg ^^ ^^ bg ^^ ^^^^^^^^^^^^^^^^+--+-- ii : ConsoleIntensity (00 = Normal, 01 = Bold, 10 = Faint)+-- uu : Underlining (00 = NoUnderline, 01 = SingleUnderline, 10 = DoubleUnderline)+type Attrs = Word32++blankAttrs :: Attrs+blankAttrs = 0+{-# INLINE blankAttrs #-}++type Cell = (Char, Attrs)++cellChar :: Lens' Cell Char+cellChar = lens fst (\(_, attrs) c -> (c, attrs))+{-# INLINE cellChar #-}++cellAttrs :: Lens' Cell Attrs+cellAttrs = lens snd (\(char, _) attrs -> (char, attrs))+{-# INLINE cellAttrs #-}++attrsFg :: Lens' Attrs (Maybe (SGR.ColorIntensity, SGR.Color))+attrsFg = lens getter setter+ where+ getter :: Attrs -> Maybe (SGR.ColorIntensity, SGR.Color)+ getter attrs = intToColor (shiftR attrs 24 .&. 0x000000FF)+ setter :: Attrs -> Maybe (SGR.ColorIntensity, SGR.Color) -> Attrs+ setter attrs color = (attrs .&. 0x00FFFFFF) .|. shiftL (colorToInt color) 24+ {-# INLINE getter #-}+ {-# INLINE setter #-}+{-# INLINE attrsFg #-}++attrsBg :: Lens' Attrs (Maybe (SGR.ColorIntensity, SGR.Color))+attrsBg = lens getter setter+ where+ getter :: Attrs -> Maybe (SGR.ColorIntensity, SGR.Color)+ getter attrs = intToColor (shiftR attrs 16 .&. 0x000000FF)+ setter :: Attrs -> Maybe (SGR.ColorIntensity, SGR.Color) -> Attrs+ setter attrs color = (attrs .&. 0xFF00FFFF) .|. shiftL (colorToInt color) 16+ {-# INLINE getter #-}+ {-# INLINE setter #-}+{-# INLINE attrsBg #-}++attrsIntensity :: Lens' Attrs SGR.ConsoleIntensity+attrsIntensity = lens getter setter+ where+ getter :: Attrs -> SGR.ConsoleIntensity+ getter attrs+ | attrs .&. 0x00000003 == 0 = SGR.NormalIntensity+ | attrs .&. 0x00000003 == 1 = SGR.BoldIntensity+ | otherwise = SGR.FaintIntensity+ setter :: Attrs -> SGR.ConsoleIntensity -> Attrs+ setter attrs intensity = ((attrs .&. 0xFFFFFFFC) .|. consoleIntensityToInt intensity)+ {-# INLINE getter #-}+ {-# INLINE setter #-}+{-# INLINE attrsIntensity #-}++attrsUnderline :: Lens' Attrs SGR.Underlining+attrsUnderline = lens getter setter+ where+ getter :: Attrs -> SGR.Underlining+ getter attrs+ | (shiftR attrs 2) .&. 0x00000003 == 0 = SGR.NoUnderline+ | (shiftR attrs 2) .&. 0x00000003 == 1 = SGR.SingleUnderline+ | otherwise = SGR.DoubleUnderline+ setter :: Attrs -> SGR.Underlining -> Attrs+ setter attrs underlining = ((attrs .&. 0xFFFFFFF3) .|. shiftL (underliningToInt underlining) 2)+ {-# INLINE getter #-}+ {-# INLINE setter #-}+{-# INLINE attrsUnderline #-}++intToColor :: Word32 -> Maybe (SGR.ColorIntensity, SGR.Color)+intToColor 0 = Nothing+intToColor 1 = Just (SGR.Dull, SGR.Black)+intToColor 2 = Just (SGR.Dull, SGR.Red)+intToColor 3 = Just (SGR.Dull, SGR.Green)+intToColor 4 = Just (SGR.Dull, SGR.Yellow)+intToColor 5 = Just (SGR.Dull, SGR.Blue)+intToColor 6 = Just (SGR.Dull, SGR.Magenta)+intToColor 7 = Just (SGR.Dull, SGR.Cyan)+intToColor 8 = Just (SGR.Dull, SGR.White)+intToColor 9 = Just (SGR.Vivid, SGR.Black)+intToColor 10 = Just (SGR.Vivid, SGR.Red)+intToColor 11 = Just (SGR.Vivid, SGR.Green)+intToColor 12 = Just (SGR.Vivid, SGR.Yellow)+intToColor 13 = Just (SGR.Vivid, SGR.Blue)+intToColor 14 = Just (SGR.Vivid, SGR.Magenta)+intToColor 15 = Just (SGR.Vivid, SGR.Cyan)+intToColor 16 = Just (SGR.Vivid, SGR.White)+intToColor i = error $ "intToColor: invalid int: " <> show i+{-# INLINE intToColor #-}++colorToInt :: Maybe (SGR.ColorIntensity, SGR.Color) -> Word32+colorToInt Nothing = 0+colorToInt (Just (SGR.Dull, SGR.Black)) = 1+colorToInt (Just (SGR.Dull, SGR.Red)) = 2+colorToInt (Just (SGR.Dull, SGR.Green)) = 3+colorToInt (Just (SGR.Dull, SGR.Yellow)) = 4+colorToInt (Just (SGR.Dull, SGR.Blue)) = 5+colorToInt (Just (SGR.Dull, SGR.Magenta)) = 6+colorToInt (Just (SGR.Dull, SGR.Cyan)) = 7+colorToInt (Just (SGR.Dull, SGR.White)) = 8+colorToInt (Just (SGR.Vivid, SGR.Black)) = 9+colorToInt (Just (SGR.Vivid, SGR.Red)) = 10+colorToInt (Just (SGR.Vivid, SGR.Green)) = 11+colorToInt (Just (SGR.Vivid, SGR.Yellow)) = 12+colorToInt (Just (SGR.Vivid, SGR.Blue)) = 13+colorToInt (Just (SGR.Vivid, SGR.Magenta)) = 14+colorToInt (Just (SGR.Vivid, SGR.Cyan)) = 15+colorToInt (Just (SGR.Vivid, SGR.White)) = 16+{-# INLINE colorToInt #-}++consoleIntensityToInt :: SGR.ConsoleIntensity -> Word32+consoleIntensityToInt SGR.NormalIntensity = 0+consoleIntensityToInt SGR.BoldIntensity = 1+consoleIntensityToInt SGR.FaintIntensity = 2+{-# INLINE consoleIntensityToInt #-}++underliningToInt :: SGR.Underlining -> Word32+underliningToInt SGR.NoUnderline = 0+underliningToInt SGR.SingleUnderline = 1+underliningToInt SGR.DoubleUnderline = 2+{-# INLINE underliningToInt #-}
+ src/System/Terminal/Emulator/DECPrivateMode.hs view
@@ -0,0 +1,166 @@+module System.Terminal.Emulator.DECPrivateMode+ ( DECPrivateMode (..),+ intToDECPrivateMode,+ )+where++data DECPrivateMode+ = -- | @1@+ --+ -- @DECSET@: Application Cursor Keys (DECCKM)+ --+ -- @DECRST@: Normal Cursor Keys (DECCKM)+ DECCKM+ | -- | @2@+ --+ -- @DECSET@: Designate USASCII for character sets G0-G3 (DECANM), and set VT100 mode.+ --+ -- @DECRST@: Designate VT52 mode (DECANM).+ DECANM+ | -- | @3@+ --+ -- @DECSET@: 132 Column Mode (DECCOLM)+ --+ -- @DECRST@: 0 Column Mode (DECCOLM)+ DECCOLM+ | -- | @4@+ --+ -- @DECSET@: Smooth (Slow) Scroll (DECSCLM)+ --+ -- @DECRST@: Jump (Fast) Scroll (DECSCLM)+ DECSCLM+ | -- | @5@+ --+ -- @DECSET@: Reverse Video (DECSCNM)+ --+ -- @DECRST@: Normal Video (DECSCNM)+ DECSCNM+ | -- | @6@+ --+ -- @DECSET@: Origin Mode (DECOM)+ --+ -- @DECRST@: Normal Cursor Mode (DECOM)+ DECOM+ | -- | @7@+ --+ -- @DECSET@: Wraparound Mode (DECAWM)+ --+ -- @DECRST@: No Wraparound Mode (DECAWM)+ DECAWM+ | -- | @8@+ --+ -- @DECSET@: Auto-repeat Keys (DECARM)+ --+ -- @DECRST@: No Auto-repeat Keys (DECARM)+ DECARM+ | -- | @9@+ --+ -- @DECSET@: Send Mouse X & Y on button press. See the section Mouse Tracking.+ --+ -- @DECRST@: Don’t Send Mouse X & Y on button press+ X10MouseCompatibilityMode+ | -- | @12@+ --+ -- @DECSET@: Start Blinking Cursor (att610)+ --+ -- @DECRST@: Stop Blinking Cursor (att610)+ Att610+ | -- | @18@+ --+ -- @DECSET@: Print form feed (DECPFF)+ --+ -- @DECRST@: Don’t print form feed (DECPFF)+ DECPFF+ | -- | @19@+ --+ -- @DECSET@: Set print extent to full screen (DECPEX)+ --+ -- @DECRST@: Limit print to scrolling region (DECPEX)+ DECPEX+ | -- | @25@+ --+ -- @DECSET@: Show Cursor (DECTCEM)+ --+ -- @DECRST@: Hide Cursor (DECTCEM)+ DECTCEM+ | -- | @42@+ --+ -- @DECSET@: Enable Nation Replacement Character sets (DECNRCM)+ --+ -- @DECRST@: Disable Nation Replacement Character sets (DECNRCM)+ DECNRCM+ | -- | @1000@+ --+ -- @DECSET@: Send Mouse X & Y on button press and release. See the section Mouse Tracking.+ --+ -- @DECRST@: Don’t Send Mouse X & Y on button press and release. See the section Mouse Tracking.+ ReportButtonPress+ | -- | @1001@+ --+ -- @DECSET@: Use Hilite Mouse Tracking+ --+ -- @DECRST@: Don’t Use Hilite Mouse Tracking+ MouseHighlightMode+ | -- | @1002@+ --+ -- @DECSET@: Use Cell Motion Mouse Tracking.+ --+ -- @DECRST@: Don’t Use Cell Motion Mouse Tracking+ ReportMotionOnButtonPress+ | -- | @1003@+ --+ -- @DECSET@: Use All Motion Mouse Tracking.+ --+ -- @DECRST@: Don’t Use All Motion Mouse Tracking+ EnableAllMouseMotions+ | -- | @47@ / @1047@+ --+ -- @DECSET@: Use Alternate Screen Buffer (unless disabled by the titeInhibit resource)+ --+ -- @DECRST@: Use Normal Screen Buffer, clearing screen first if in the Alternate Screen (unless disabled by the titeInhibit resource)+ UseAlternateScreenBuffer+ | -- | @1048@+ --+ -- @DECSET@: Save cursor as in DECSC (unless disabled by the titeInhibit resource)+ --+ -- @DECRST@: Restore cursor as in DECRC (unless disabled by the titeInhibit resource)+ SaveCursorAsInDECSC+ | -- | @1049@+ --+ -- @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.+ --+ -- @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.+ SaveCursorAsInDECSCAndUseAlternateScreenBuffer+ | -- | @2004@+ --+ -- @DECSET@: Set bracketed paste mode.+ --+ -- @DECRST@: Reset bracketed paste mode.+ BracketedPasteMode+ deriving (Eq, Show)++intToDECPrivateMode :: Int -> Maybe DECPrivateMode+intToDECPrivateMode 1 = Just DECCKM+intToDECPrivateMode 2 = Just DECANM+intToDECPrivateMode 3 = Just DECCOLM+intToDECPrivateMode 4 = Just DECSCLM+intToDECPrivateMode 5 = Just DECSCNM+intToDECPrivateMode 6 = Just DECOM+intToDECPrivateMode 7 = Just DECAWM+intToDECPrivateMode 8 = Just DECARM+intToDECPrivateMode 9 = Just X10MouseCompatibilityMode+intToDECPrivateMode 12 = Just Att610+intToDECPrivateMode 18 = Just DECPFF+intToDECPrivateMode 19 = Just DECPEX+intToDECPrivateMode 25 = Just DECTCEM+intToDECPrivateMode 42 = Just DECNRCM+intToDECPrivateMode 1000 = Just ReportButtonPress+intToDECPrivateMode 1001 = Just MouseHighlightMode+intToDECPrivateMode 1002 = Just ReportMotionOnButtonPress+intToDECPrivateMode 1003 = Just EnableAllMouseMotions+intToDECPrivateMode 47 = Just UseAlternateScreenBuffer+intToDECPrivateMode 1047 = Just UseAlternateScreenBuffer+intToDECPrivateMode 1048 = Just SaveCursorAsInDECSC+intToDECPrivateMode 1049 = Just SaveCursorAsInDECSCAndUseAlternateScreenBuffer+intToDECPrivateMode 2004 = Just BracketedPasteMode+intToDECPrivateMode _ = Nothing
+ src/System/Terminal/Emulator/KeyboardInput.hs view
@@ -0,0 +1,73 @@+module System.Terminal.Emulator.KeyboardInput+ ( KeyboardState (..),+ initialKeyboardState,+ KeyPress (..),+ KeyModifiers (..),+ SpecialKey (..),+ )+where++data KeyboardState = KeyboardState+ { keyboardState_DECCKM :: !Bool,+ -- | Set using Keyboard Action Mode (KAM)+ keyboardState_Locked :: !Bool,+ -- | Set using Automatic Newline / Normal Linefeed (LNM)+ keyboardState_CRLF :: !Bool+ }+ deriving (Show, Eq, Ord)++initialKeyboardState :: KeyboardState+initialKeyboardState =+ KeyboardState+ { keyboardState_DECCKM = False,+ keyboardState_Locked = False,+ keyboardState_CRLF = False+ }++data KeyPress+ = -- | The char must be a plain-old regular "visible" character (or ' ').+ -- Specifically, you should not put '\n' or '\b' (use 'SpecialKey' for+ -- that)+ KeyPress_Char !Char !KeyModifiers+ | -- | Used for a key press of a 'SpecialKey'. If a 'SpecialKey' doesn't+ -- exist (for example "Ctrl", or "CapsLock") then no 'KeyPress' event+ -- should be generated+ KeyPress_SpecialKey !SpecialKey !KeyModifiers+ deriving (Eq, Ord, Show)++data KeyModifiers = KeyModifiers+ { shift :: !Bool,+ ctrl :: !Bool,+ alt :: !Bool,+ capsLock :: !Bool+ }+ deriving (Eq, Ord, Show)++data SpecialKey+ = SpecialKey_Escape+ | SpecialKey_F1+ | SpecialKey_F2+ | SpecialKey_F3+ | SpecialKey_F4+ | SpecialKey_F5+ | SpecialKey_F6+ | SpecialKey_F7+ | SpecialKey_F8+ | SpecialKey_F9+ | SpecialKey_F10+ | SpecialKey_F11+ | SpecialKey_F12+ | SpecialKey_Insert+ | SpecialKey_Delete+ | SpecialKey_Home+ | SpecialKey_End+ | SpecialKey_PageUp+ | SpecialKey_PageDown+ | SpecialKey_Tab+ | SpecialKey_Enter+ | SpecialKey_Backspace+ | SpecialKey_ArrowLeft+ | SpecialKey_ArrowRight+ | SpecialKey_ArrowUp+ | SpecialKey_ArrowDown+ deriving (Eq, Ord, Show)
+ src/System/Terminal/Emulator/KeyboardInput/KeyPressToPty.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module System.Terminal.Emulator.KeyboardInput.KeyPressToPty+ ( keyPressToPty,+ )+where++import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.Char (isControl)+import System.Terminal.Emulator.KeyboardInput (KeyModifiers (..), KeyPress (..), KeyboardState (..), SpecialKey (..))++keyPressToPty :: KeyboardState -> KeyPress -> ByteString+keyPressToPty KeyboardState {keyboardState_Locked = True} _ = ""+keyPressToPty _ (KeyPress_Char c modifiers)+ | isControl c = error $ "Invalid Control Char for KeyPress: " ++ show c+ | otherwise = keyToPty c modifiers+keyPressToPty keyboardState (KeyPress_SpecialKey specialKey modifiers) = specialKeyToPty keyboardState specialKey modifiers++keyToPty :: Char -> KeyModifiers -> ByteString+keyToPty 'a' KeyModifiers {ctrl = True} = "\1"+keyToPty 'b' KeyModifiers {ctrl = True} = "\2"+keyToPty 'c' KeyModifiers {ctrl = True} = "\3"+keyToPty 'd' KeyModifiers {ctrl = True} = "\4"+keyToPty 'e' KeyModifiers {ctrl = True} = "\5"+keyToPty 'f' KeyModifiers {ctrl = True} = "\6"+keyToPty 'r' KeyModifiers {ctrl = True} = "\18"+keyToPty char _ = charToByteString char++specialKeyToPty :: KeyboardState -> SpecialKey -> KeyModifiers -> ByteString+specialKeyToPty keyboardState specialKey KeyModifiers {alt, ctrl, shift, capsLock} =+ case specialKey of+ SpecialKey_Escape+ | alt -> "\ESC\ESC"+ | otherwise -> "\ESC"+ SpecialKey_F1+ | alt -> "\ESC[1;3P"+ | ctrl -> "\ESC[1;5P"+ | shift -> "\ESC[1;2P"+ | otherwise -> "\ESCOP"+ SpecialKey_F2+ | alt -> "\ESC[1;3Q"+ | ctrl -> "\ESC[1;5Q"+ | shift -> "\ESC[1;2Q"+ | otherwise -> "\ESCOQ"+ SpecialKey_F3+ | alt -> "\ESC[1;3R"+ | ctrl -> "\ESC[1;5R"+ | shift -> "\ESC[1;2R"+ | otherwise -> "\ESCOR"+ SpecialKey_F4+ | alt -> "\ESC[1;3S"+ | ctrl -> "\ESC[1;5S"+ | shift -> "\ESC[1;2S"+ | otherwise -> "\ESCOS"+ SpecialKey_F5+ | alt -> "\ESC[15;3~"+ | ctrl -> "\ESC[15;5~"+ | shift -> "\ESC[15;2~"+ | otherwise -> "\ESC[15~"+ SpecialKey_F6+ | alt -> "\ESC[17;3~"+ | ctrl -> "\ESC[17;5~"+ | shift -> "\ESC[17;2~"+ | otherwise -> "\ESC[17~"+ SpecialKey_F7+ | alt -> "\ESC[18;3~"+ | ctrl -> "\ESC[18;5~"+ | shift -> "\ESC[18;2~"+ | otherwise -> "\ESC[18~"+ SpecialKey_F8+ | alt -> "\ESC[19;3~"+ | ctrl -> "\ESC[19;5~"+ | shift -> "\ESC[19;2~"+ | otherwise -> "\ESC[19~"+ SpecialKey_F9+ | alt -> "\ESC[20;3~"+ | ctrl -> "\ESC[20;5~"+ | shift -> "\ESC[20;2~"+ | otherwise -> "\ESC[20~"+ SpecialKey_F10+ | alt -> "\ESC[21;3~"+ | ctrl -> "\ESC[21;5~"+ | shift -> "\ESC[21;2~"+ | otherwise -> "\ESC[21~"+ SpecialKey_F11+ | alt -> "\ESC[23;3~"+ | ctrl -> "\ESC[23;5~"+ | shift -> "\ESC[23;2~"+ | otherwise -> "\ESC[23~"+ SpecialKey_F12+ | alt -> "\ESC[24;3~"+ | ctrl -> "\ESC[24;5~"+ | shift -> "\ESC[24;2~"+ | otherwise -> "\ESC[24~"+ SpecialKey_Insert -> error "TODO"+ SpecialKey_Delete -> "\ESC[3~"+ SpecialKey_Home -> error "TODO"+ SpecialKey_End -> error "TODO"+ SpecialKey_PageUp -> error "TODO"+ SpecialKey_PageDown -> error "TODO"+ SpecialKey_Tab -> "\t" -- TODO modifiers+ SpecialKey_Enter+ | alt && not shift && not ctrl && not capsLock -> "\ESC\r"+ | otherwise -> "\r"+ SpecialKey_Backspace+ | alt && shift -> "\ESC\b"+ | alt && ctrl -> "\ESC\b"+ | alt -> "\ESC\DEL"+ | shift -> "\b"+ | ctrl -> "\b"+ | capsLock -> "\b"+ | otherwise -> "\DEL"+ SpecialKey_ArrowLeft+ | keyboardState_DECCKM keyboardState -> "\ESCOD"+ | otherwise -> "\ESC[D"+ SpecialKey_ArrowRight+ | keyboardState_DECCKM keyboardState -> "\ESCOC"+ | otherwise -> "\ESC[C"+ SpecialKey_ArrowUp+ | keyboardState_DECCKM keyboardState -> "\ESCOA"+ | otherwise -> "\ESC[A"+ SpecialKey_ArrowDown+ | keyboardState_DECCKM keyboardState -> "\ESCOB"+ | otherwise -> "\ESC[B"++charToByteString :: Char -> ByteString+charToByteString =+ -- TODO Encode as UTF-8+ B.singleton . fromIntegral . fromEnum
+ src/System/Terminal/Emulator/Parsing.hs view
@@ -0,0 +1,6 @@+module System.Terminal.Emulator.Parsing+ ( parseTermAtom,+ )+where++import System.Terminal.Emulator.Parsing.Internal (parseTermAtom)
+ src/System/Terminal/Emulator/Parsing/Internal.hs view
@@ -0,0 +1,400 @@+{-# LANGUAGE OverloadedStrings #-}++module System.Terminal.Emulator.Parsing.Internal where++import Control.Applicative ((<|>))+import Data.Attoparsec.Text+import Data.Char (isDigit)+import Data.List.NonEmpty (NonEmpty ((:|)))+import qualified Data.List.NonEmpty as NE+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Read as T+import qualified Data.Vector as V+import System.Terminal.Emulator.DECPrivateMode (intToDECPrivateMode)+import System.Terminal.Emulator.Parsing.Types (ControlSequenceIntroducer (..), DeviceStatusReport (..), EraseInDisplayParam (..), EraseInLineParam (..), EscapeSequence (..), Mode (..), OperatingSystemCommand (..), SendDeviceAttributesSecondary (RequestTerminalIdentificationCode), SingleCharacterFunction (..), TermAtom (..), WindowManipulation (..), codeToSGR)+import Prelude hiding (takeWhile)++parseTermAtom :: Parser TermAtom+parseTermAtom =+ parseVisibleChar <|> parseControl++parseVisibleChar :: Parser TermAtom+parseVisibleChar = TermAtom_VisibleChar <$> satisfy (not . isControl)++-- | This parser always succeeds+parseControl :: Parser TermAtom+parseControl = do+ c <- anyChar+ if c == '\ESC'+ then parseEscape+ else pure $ case singleCharacterFunction c of+ Nothing -> TermAtom_SingleCharacterFunctionUnknown c+ Just f -> TermAtom_SingleCharacterFunction f++singleCharacterFunction :: Char -> Maybe SingleCharacterFunction+singleCharacterFunction '\a' = Just Control_Bell+singleCharacterFunction '\b' = Just Control_Backspace+singleCharacterFunction '\r' = Just Control_CarriageReturn+singleCharacterFunction '\ENQ' = Just Control_ReturnTerminalStatus+singleCharacterFunction '\f' = Just Control_FormFeed+singleCharacterFunction '\n' = Just Control_LineFeed+singleCharacterFunction '\SI' = Just Control_SwitchToStandardCharacterSet+singleCharacterFunction '\SO' = Just Control_SwitchToAlternateCharacterSet+singleCharacterFunction '\t' = Just Control_Tab+singleCharacterFunction '\v' = Just Control_VerticalTab+singleCharacterFunction _ = Nothing++-- | This parser always succeeds+parseEscape :: Parser TermAtom+parseEscape = do+ c <- anyChar+ case c of+ '[' -> handleCsi+ ']' -> handleOsc+ '(' -> handleSetG0CharacterSet+ _ -> handleSingle c+ where+ handleCsi :: Parser TermAtom+ handleCsi = do+ csiInput <- parseControlSequenceIntroducer+ pure $ case processControlSequenceIntroducer csiInput of+ Nothing -> case processOtherControlSequenceIntroducer csiInput of+ Nothing -> TermAtom_EscapeSequenceUnknown (renderCsi csiInput)+ Just csi -> TermAtom_EscapeSequence (Esc_CSI csi)+ Just csi -> TermAtom_EscapeSequence (Esc_CSI csi)++ handleOsc :: Parser TermAtom+ handleOsc = do+ oscInput <- parseOperatingSystemCommand+ pure $ case processOperatingSystemCommand oscInput of+ Nothing -> TermAtom_EscapeSequenceUnknown (renderOsc oscInput)+ Just osc -> TermAtom_EscapeSequence (Esc_OSC osc)++ handleSingle :: Char -> Parser TermAtom+ handleSingle c = pure $ case singleCharacterEscapeSequence c of+ Just e -> TermAtom_EscapeSequence e+ Nothing -> TermAtom_EscapeSequenceUnknown ("\ESC" <> T.singleton c)++ handleSetG0CharacterSet :: Parser TermAtom+ handleSetG0CharacterSet =+ ( choice+ [ string "A",+ string "B",+ string "C",+ string "5",+ string "H",+ string "7",+ string "K",+ string "Q",+ string "9",+ string "R",+ string "f",+ string "Y",+ string "Z",+ string "4",+ string "\">",+ string "%2",+ string "%6",+ string "%=",+ string "=",+ string "`",+ string "E",+ string "6",+ string "0",+ string "<",+ string ">",+ string "\"4",+ string "\"?",+ string "%0",+ string "%5",+ string "&4",+ string "%3",+ string "&5"+ ]+ >>= pure . TermAtom_EscapeSequence . ESC_SetG0CharacterSet+ )+ <|> ( anyChar >>= \c ->+ pure (TermAtom_EscapeSequenceUnknown ("\ESC(" <> T.singleton c))+ )++-----------------------------------------------------------------------+-- CSI (Control Sequence Introducer) sequences+-----------------------------------------------------------------------++data ControlSequenceIntroducerInput = ControlSequenceIntroducerInput !Text+ deriving (Show, Eq)++data ControlSequenceIntroducerComponents+ = ControlSequenceIntroducerComponents+ !Bool+ -- ^ Private?+ !(NonEmpty Int)+ -- ^ Args+ !Char+ -- ^ Mode+ deriving (Show, Eq)++-- | Should be run after reading the sequence @ESC [@+--+-- This parser always succeeds+parseControlSequenceIntroducer :: Parser ControlSequenceIntroducerInput+parseControlSequenceIntroducer = do+ str <- takeTill ((`between` (0x40, 0x7E)) . fromEnum)+ c <- anyChar+ pure (ControlSequenceIntroducerInput ((str) <> T.singleton c))++parseControlSequenceIntroducerComponents :: ControlSequenceIntroducerInput -> Maybe ControlSequenceIntroducerComponents+parseControlSequenceIntroducerComponents (ControlSequenceIntroducerInput str) =+ case parseOnly (parser <* endOfInput) str of+ Left _ -> Nothing+ Right val -> Just val+ where+ parser :: Parser ControlSequenceIntroducerComponents+ parser = do+ private <- option False (char '?' >> pure True)+ first <- peekChar'+ args <-+ if isDigit first || first == ';'+ then sepBy (option 0 decimal) (char ';')+ else pure []+ mode <- anyChar+ pure (ControlSequenceIntroducerComponents private (listToNonEmpty 0 args) mode)++listToNonEmpty :: a -> [a] -> NonEmpty a+listToNonEmpty def [] = def :| []+listToNonEmpty _ (x : xs) = x :| xs++processControlSequenceIntroducerComponents :: ControlSequenceIntroducerComponents -> Maybe ControlSequenceIntroducer+processControlSequenceIntroducerComponents (ControlSequenceIntroducerComponents False args mode) = parseCsi mode args+processControlSequenceIntroducerComponents (ControlSequenceIntroducerComponents True args mode) = parsePrivCsi mode args++changeZero :: Int -> Int -> Int+changeZero toVal 0 = toVal+changeZero _ val = val++headChangeZero :: Int -> NonEmpty Int -> Int+headChangeZero toVal args = changeZero toVal (NE.head args)++parseCsi :: Char -> NonEmpty Int -> Maybe ControlSequenceIntroducer+parseCsi mode args = case mode of+ 'A' -> Just (CSI_CursorUp (headChangeZero 1 args))+ 'B' -> Just (CSI_CursorDown (headChangeZero 1 args))+ 'C' -> Just (CSI_CursorForward (headChangeZero 1 args))+ 'D' -> Just (CSI_CursorBack (headChangeZero 1 args))+ 'K' ->+ CSI_EraseInLine <$> case NE.head args of+ 0 -> Just ClearFromCursorToEndOfLine+ 1 -> Just ClearFromCursorToBeginningOfLine+ 2 -> Just ClearEntireLine+ _ -> Nothing+ '@' -> Just (CSI_InsertBlankCharacters (headChangeZero 1 args))+ 'P' -> Just (CSI_DeleteChars (headChangeZero 1 args))+ 'G' -> Just (CSI_CursorCharacterAbsolute (headChangeZero 1 args))+ 'H' ->+ let (row, col) = case args of+ r :| [] -> (r, 0)+ r :| (c : _) -> (r, c)+ in Just (CSI_CursorPosition (changeZero 1 row) (changeZero 1 col))+ 'J' -> case NE.head args of+ 0 -> Just (CSI_EraseInDisplay EraseBelow)+ 1 -> Just (CSI_EraseInDisplay EraseAbove)+ 2 -> Just (CSI_EraseInDisplay EraseAll)+ 3 -> Just (CSI_EraseInDisplay EraseSavedLines)+ _ -> Nothing+ 'L' -> Just (CSI_InsertBlankLines (headChangeZero 1 args))+ 'M' -> Just (CSI_DeleteLines (headChangeZero 1 args))+ 'S' -> Just (CSI_ScrollUp (headChangeZero 1 args))+ 'T' -> Just (CSI_ScrollDown (headChangeZero 1 args))+ 'X' -> Just (CSI_EraseCharacters (headChangeZero 1 args))+ '`' -> Just (CSI_CharacterPositionAbsolute (headChangeZero 1 args))+ 'a' -> Just (CSI_CharacterPositionRelative (headChangeZero 1 args))+ 'c' -> case args of+ 0 :| [] -> Just CSI_SendDeviceAttributes+ _ -> Nothing+ 'd' -> Just (CSI_LinePositionAbsolute (headChangeZero 1 args))+ 'e' -> Just (CSI_LinePositionRelative (headChangeZero 1 args))+ 'f' ->+ let (row, col) = case args of+ r :| [] -> (r, 0)+ r :| (c : _) -> (r, c)+ in Just (CSI_HorizontalVerticalPosition (changeZero 1 row) (changeZero 1 col))+ 't' -> case args of+ 22 :| 0 : _ -> Just (CSI_WindowManipulation SaveIconAndWindowTitleOnStack)+ 23 :| 0 : _ -> Just (CSI_WindowManipulation RestoreIconAndWindowTitleOnStack)+ _ -> Nothing+ 'h' -> case args of+ 2 :| [] -> Just (CSI_SetMode KeyboardActionMode)+ 4 :| [] -> Just (CSI_SetMode InsertReplaceMode)+ 12 :| [] -> Just (CSI_SetMode SendReceive)+ 20 :| [] -> Just (CSI_SetMode AutomaticNewlineNormalLinefeed)+ _ -> Nothing+ 'l' -> case args of+ 2 :| [] -> Just (CSI_ResetMode KeyboardActionMode)+ 4 :| [] -> Just (CSI_ResetMode InsertReplaceMode)+ 12 :| [] -> Just (CSI_ResetMode SendReceive)+ 20 :| [] -> Just (CSI_ResetMode AutomaticNewlineNormalLinefeed)+ _ -> Nothing+ 'n' -> case NE.head args of+ 5 -> Just (CSI_DeviceStatusReport StatusReport)+ 6 -> Just (CSI_DeviceStatusReport ReportCursorPosition)+ _ -> Nothing+ 'r' ->+ let (top, bottom) = case args of+ t :| [] -> (t, 0)+ t :| (b : _) -> (t, b)+ in Just+ ( CSI_DECSTBM+ (if top == 0 then Nothing else Just top)+ (if bottom == 0 then Nothing else Just bottom)+ )+ 'm' -> Just $ CSI_SGR (V.fromList (mapMaybe codeToSGR (NE.toList args)))+ _ -> Nothing++parsePrivCsi :: Char -> NonEmpty Int -> Maybe ControlSequenceIntroducer+parsePrivCsi mode args = case mode of+ 'h' ->+ let n = (headChangeZero 1 args)+ in Just $ case intToDECPrivateMode n of+ Just decset -> CSI_DECSET decset+ Nothing -> CSI_DECSET_Unknown n+ 'l' ->+ let n = (headChangeZero 1 args)+ in Just $ case intToDECPrivateMode n of+ Just decset -> CSI_DECRST decset+ Nothing -> CSI_DECRST_Unknown n+ _ -> Nothing++processControlSequenceIntroducer :: ControlSequenceIntroducerInput -> Maybe ControlSequenceIntroducer+processControlSequenceIntroducer csiInput =+ parseControlSequenceIntroducerComponents csiInput+ >>= processControlSequenceIntroducerComponents++processOtherControlSequenceIntroducer :: ControlSequenceIntroducerInput -> Maybe ControlSequenceIntroducer+processOtherControlSequenceIntroducer (ControlSequenceIntroducerInput str) =+ case str of+ "!p" -> Just CSI_SoftTerminalReset+ ">c" -> Just (CSI_SendDeviceAttributesSecondary RequestTerminalIdentificationCode)+ ">0c" -> Just (CSI_SendDeviceAttributesSecondary RequestTerminalIdentificationCode)+ _+ | "?" `T.isPrefixOf` str && "$p" `T.isSuffixOf` str ->+ let modeStr = T.init (T.init (T.tail str))+ in case T.decimal modeStr of+ Left _ -> Nothing+ Right (mode, "") -> Just (CSI_RequestDECPrivateMode mode)+ Right (_, _) -> Nothing+ _ -> Nothing++-- | Used for error reporting+renderCsi :: ControlSequenceIntroducerInput -> Text+renderCsi (ControlSequenceIntroducerInput str) = "\ESC[" <> str++-----------------------------------------------------------------------+-- OSC (Operating System Command)+-----------------------------------------------------------------------++data OperatingSystemCommandInput = OperatingSystemCommandInput !Text++-- | Should be run after reading the sequence @ESC ]@+--+-- This parser always succeeds+parseOperatingSystemCommand :: Parser OperatingSystemCommandInput+parseOperatingSystemCommand = do+ str <-+ manyTill'+ anyChar+ ( (char '\a' >> pure ())+ <|> (string "\ESC\\" >> pure ())+ )+ pure (OperatingSystemCommandInput (T.pack str))++-- | Used for error reporting+renderOsc :: OperatingSystemCommandInput -> Text+renderOsc (OperatingSystemCommandInput str) = "\ESC]" <> str <> "\a"++processOperatingSystemCommand :: OperatingSystemCommandInput -> Maybe OperatingSystemCommand+processOperatingSystemCommand (OperatingSystemCommandInput str) =+ case parseOnly (parser <* endOfInput) str of+ Left _ -> Nothing+ Right val -> Just val+ where+ parser :: Parser OperatingSystemCommand+ parser =+ parseSetTitle+ <|> parseChangeTextForegroundColor+ <|> parseRequestTextForegroundColor+ <|> parseChangeTextBackgroundColor+ <|> parseRequestTextBackgroundColor+ <|> parseResetTextCursorColor++ parseSetTitle :: Parser OperatingSystemCommand+ parseSetTitle = do+ (icon, window) <- parseSetTitleMode+ _ <- char ';'+ title <- takeText+ pure (OSC_SetTitle icon window title)++ parseSetTitleMode :: Parser (Bool, Bool)+ parseSetTitleMode =+ (char '0' >> pure (True, True))+ <|> (char '1' >> pure (True, False))+ <|> (char '2' >> pure (False, True))++ parseChangeTextForegroundColor :: Parser OperatingSystemCommand+ parseChangeTextForegroundColor = do+ _ <- string "10;"+ c <- satisfy (/= '?')+ color <- takeText+ pure (OSC_ChangeTextForegroundColor (T.singleton c <> color))++ parseRequestTextForegroundColor :: Parser OperatingSystemCommand+ parseRequestTextForegroundColor = do+ _ <- string "10;?"+ pure OSC_RequestTextForegroundColor++ parseChangeTextBackgroundColor :: Parser OperatingSystemCommand+ parseChangeTextBackgroundColor = do+ _ <- string "11;"+ c <- satisfy (/= '?')+ color <- takeText+ pure (OSC_ChangeTextBackgroundColor (T.singleton c <> color))++ parseRequestTextBackgroundColor :: Parser OperatingSystemCommand+ parseRequestTextBackgroundColor = do+ _ <- string "11;?"+ pure OSC_RequestTextBackgroundColor++ parseResetTextCursorColor :: Parser OperatingSystemCommand+ parseResetTextCursorColor = do+ _ <- string "112"+ pure OSC_ResetTextCursorColor++-----------------------------------------------------------------------+-- Single Character Escape Sequence+-----------------------------------------------------------------------++singleCharacterEscapeSequence :: Char -> Maybe EscapeSequence+singleCharacterEscapeSequence c =+ case c of+ 'M' -> Just Esc_ReverseIndex+ 'c' -> Just Esc_RIS+ '=' -> Just Esc_DECPAM+ '>' -> Just Esc_DECPNM+ _ -> Nothing++-----------------------------------------------------------------------+-- Helper functions+-----------------------------------------------------------------------++between :: Ord a => a -> (a, a) -> Bool+between val (low, high) = val >= low && val <= high++isControlC0 :: Char -> Bool+isControlC0 c = fromEnum c `between` (0, 0x1F) || c == '\DEL'++isControlC1 :: Char -> Bool+isControlC1 c = fromEnum c `between` (0x80, 0x9f)++isControl :: Char -> Bool+isControl c = isControlC0 c || isControlC1 c
+ src/System/Terminal/Emulator/Parsing/Types.hs view
@@ -0,0 +1,232 @@+module System.Terminal.Emulator.Parsing.Types where++import Data.Text (Text)+import Data.Vector (Vector)+import System.Console.ANSI.Types (SGR)+import qualified System.Console.ANSI.Types as SGR+import System.Terminal.Emulator.DECPrivateMode (DECPrivateMode)++data TermAtom+ = TermAtom_VisibleChar !Char+ | TermAtom_SingleCharacterFunction !SingleCharacterFunction+ | TermAtom_SingleCharacterFunctionUnknown !Char+ | TermAtom_EscapeSequence !EscapeSequence+ | TermAtom_EscapeSequenceUnknown !Text+ deriving (Eq, Show)++data SingleCharacterFunction+ = -- | @BEL@ Bell (BEL is Ctrl-G).+ Control_Bell+ | -- | @BS@ Backspace (BS is Ctrl-H).+ Control_Backspace+ | -- | @CR@ Carriage Return (CR is Ctrl-M).+ Control_CarriageReturn+ | -- | @ENQ@ Return Terminal Status (ENQ is Ctrl-E). Default response is an empty string+ Control_ReturnTerminalStatus+ | -- | @FF@ Form Feed or New Page (NP ). (FF is Ctrl-L). FF is treated the same as LF .+ Control_FormFeed+ | -- | @LF@ Line Feed or New Line (NL). (LF is Ctrl-J).+ Control_LineFeed+ | -- | @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.+ Control_SwitchToStandardCharacterSet+ | -- | @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.+ Control_SwitchToAlternateCharacterSet+ | -- | @TAB@ Horizontal Tab (HTS is Ctrl-I).+ Control_Tab+ | -- | @VT@ Vertical Tab (VT is Ctrl-K). This is treated the same as LF.+ Control_VerticalTab+ deriving (Eq, Show)++data EscapeSequence+ = -- | @ESC M@ Reverse Index (RI is 0x8d).+ Esc_ReverseIndex+ | -- | @ESC c@ Reset terminal to initial state (RIS)+ Esc_RIS+ | -- | @ESC =@ Application Keypad (DECPAM)+ Esc_DECPAM+ | -- | @ESC >@ Set numeric keypad mode (DECPNM)+ Esc_DECPNM+ | -- | @ESC (@ Designate G0 Character Set, VT100, ISO 2022.+ ESC_SetG0CharacterSet !Text+ | Esc_CSI !ControlSequenceIntroducer+ | Esc_OSC !OperatingSystemCommand+ deriving (Eq, Show)++data ControlSequenceIntroducer+ = -- | @CSI Ps `@ Character Position Absolute [column] (default = [row,1]) (HPA).+ CSI_CharacterPositionAbsolute !Int+ | -- | @CSI Ps a@ Character Position Relative [columns] (default = [row,col+1]) (HPR).+ CSI_CharacterPositionRelative !Int+ | -- | @CSI Ps A@ Cursor Up Ps Times (default = 1) (CUU).+ CSI_CursorUp !Int+ | -- | @CSI Ps B@ Cursor Down Ps Times (default = 1) (CUD).+ CSI_CursorDown !Int+ | -- | @CSI Ps C@ Cursor Forward Ps Times (default = 1) (CUF).+ CSI_CursorForward !Int+ | -- | @CSI Ps D@ Cursor Backward Ps Times (default = 1) (CUB).+ CSI_CursorBack !Int+ | -- | @CSI Ps K@ Erase in Line (EL), VT100.+ CSI_EraseInLine !EraseInLineParam+ | -- | @CSI Ps \@@ Insert Ps (Blank) Character(s) (default = 1) (ICH)+ CSI_InsertBlankCharacters !Int+ | -- | @CSI Ps L@ Insert Ps Line(s) (default = 1) (IL)+ CSI_InsertBlankLines !Int+ | -- | @CSI Ps P@ Delete Ps Character(s) (default = 1) (DCH).+ CSI_DeleteChars !Int+ | -- | @CSI Ps M@ Delete Ps Line(s) (default = 1) (DL).+ CSI_DeleteLines !Int+ | -- | @CSI Ps G@ Cursor Character Absolute [column] (default = [row,1]) (CHA).+ CSI_CursorCharacterAbsolute !Int+ | -- | @CSI Ps ; Ps H@ Cursor Position [row;column] (default = [1,1]) (CUP).+ CSI_CursorPosition !Int !Int+ | -- | @CSI Ps ; Ps f@ Horizontal and Vertical Position [row;column] (default = [1,1]) (HVP).+ CSI_HorizontalVerticalPosition !Int !Int+ | -- | @CSI Ps d@ Line Position Absolute [row] (default = [1,column]) (VPA).+ CSI_LinePositionAbsolute !Int+ | -- | @CSI Ps e@ Line Position Relative [rows] (default = [row+1,column]) (VPR).+ CSI_LinePositionRelative !Int+ | -- | @CSI Ps S@ Scroll up Ps lines (default = 1) (SU), VT420, ECMA-48.+ CSI_ScrollUp !Int+ | -- | @CSI Ps T@ Scroll down Ps lines (default = 1) (SD), VT420.+ CSI_ScrollDown !Int+ | -- | @CSI Ps J@ Erase in Display (ED), VT100+ CSI_EraseInDisplay !EraseInDisplayParam+ | -- | @CSI Ps X@ Erase Ps Character(s) (default = 1) (ECH).+ CSI_EraseCharacters !Int+ | -- | @CSI Ps ; Ps ; Ps t@ Window manipulation (XTWINOPS), dtterm, extended by xterm. These controls may be disabled using the allowWindowOps resource.+ CSI_WindowManipulation !WindowManipulation+ | -- | @CSI Ps n@ Device Status Report (DSR).+ CSI_DeviceStatusReport !DeviceStatusReport+ | -- | @CSI ! p@ Soft terminal reset (DECSTR), VT220 and up.+ CSI_SoftTerminalReset+ | -- | @CSI Pm h@ Set Mode (SM).+ CSI_SetMode !Mode+ | -- | @CSI Pm l@ Reset Mode (RM).+ CSI_ResetMode !Mode+ | -- | @CSI Ps c@ Send Device Attributes (Primary DA).+ CSI_SendDeviceAttributes+ | -- | @CSI > Ps c@ Send Device Attributes (Secondary DA).+ CSI_SendDeviceAttributesSecondary !SendDeviceAttributesSecondary+ | -- | @CSI ? Ps $ p@ Request DEC private mode (DECRQM).+ CSI_RequestDECPrivateMode !Int+ | -- | Set Scrolling Region [top;bottom] (default = full size of window) (DECSTBM)+ CSI_DECSTBM !(Maybe Int) !(Maybe Int)+ | -- | DEC Private Mode Set+ CSI_DECSET !DECPrivateMode+ | -- | Unknown DECSET (DEC Private Mode Set) code+ CSI_DECSET_Unknown !Int+ | -- | DEC Private Mode Reset+ CSI_DECRST !DECPrivateMode+ | -- | Unknown DECRST (DEC Private Mode Reset) code+ CSI_DECRST_Unknown !Int+ | CSI_SGR !(Vector SGR)+ deriving (Eq, Show)++data EraseInLineParam+ = -- | @Ps = 0@ Erase to Right (default).+ ClearFromCursorToEndOfLine+ | -- | @Ps = 1@ Erase to Left.+ ClearFromCursorToBeginningOfLine+ | -- | @Ps = 2@ Erase All.+ ClearEntireLine+ deriving (Eq, Show)++data EraseInDisplayParam+ = -- | @Ps = 0@ Erase Below (default).+ EraseBelow+ | -- | @Ps = 1@ Erase Above.+ EraseAbove+ | -- | @Ps = 2@ Erase All.+ EraseAll+ | -- | @Ps = 3@ Erase Saved Lines, xterm.+ EraseSavedLines+ deriving (Eq, Show)++data WindowManipulation+ = -- | @22;0@ Save xterm icon and window title on stack.+ SaveIconAndWindowTitleOnStack+ | -- | @23;0@ Restore xterm icon and window title from stack.+ RestoreIconAndWindowTitleOnStack+ deriving (Eq, Show)++data DeviceStatusReport+ = -- | Status Report. Result ("OK") is @CSI 0 n@+ StatusReport+ | -- | Report Cursor Position (CPR) [row;column]. Result is @CSI r ; c R@+ ReportCursorPosition+ deriving (Eq, Show)++data Mode+ = -- | Keyboard Action Mode (KAM)+ KeyboardActionMode+ | -- | Insert/Replace Mode (IRM)+ InsertReplaceMode+ | -- | Send/receive (SRM)+ SendReceive+ | -- | Automatic Newline / Normal Linefeed (LNM).+ AutomaticNewlineNormalLinefeed+ deriving (Eq, Show)++data SendDeviceAttributesSecondary+ = RequestTerminalIdentificationCode+ deriving (Eq, Show)++data OperatingSystemCommand+ = -- | Change Icon Name and Window Title+ OSC_SetTitle+ !Bool+ -- ^ Set icon name to the string+ !Bool+ -- ^ Set window title to the string+ !Text+ -- ^ The string that should be used for the title+ | -- | Change VT100 text foreground color+ OSC_ChangeTextForegroundColor !Text+ | -- | Request VT100 text foreground color+ OSC_RequestTextForegroundColor+ | -- | Change VT100 text background color+ OSC_ChangeTextBackgroundColor !Text+ | -- | Request VT100 text background color+ OSC_RequestTextBackgroundColor+ | -- | @Ps = 112@ Reset text cursor color.+ OSC_ResetTextCursorColor+ deriving (Eq, Show)++codeToSGR :: Int -> Maybe SGR.SGR+codeToSGR 0 = Just SGR.Reset+codeToSGR 1 = Just $ SGR.SetConsoleIntensity SGR.BoldIntensity+codeToSGR 2 = Just $ SGR.SetConsoleIntensity SGR.FaintIntensity+codeToSGR 4 = Just $ SGR.SetUnderlining SGR.SingleUnderline+codeToSGR 21 = Just $ SGR.SetUnderlining SGR.DoubleUnderline+codeToSGR 22 = Just $ SGR.SetConsoleIntensity SGR.NormalIntensity+codeToSGR 24 = Just $ SGR.SetUnderlining SGR.NoUnderline+codeToSGR 39 = Just $ SGR.SetDefaultColor SGR.Foreground+codeToSGR 49 = Just $ SGR.SetDefaultColor SGR.Background+codeToSGR code+ | code `between` (30, 37) = do+ color <- codeToColor (code - 30)+ Just $ SGR.SetColor SGR.Foreground SGR.Dull color+ | code `between` (90, 97) = do+ color <- codeToColor (code - 90)+ Just $ SGR.SetColor SGR.Foreground SGR.Vivid color+ | code `between` (40, 47) = do+ color <- codeToColor (code - 40)+ Just $ SGR.SetColor SGR.Background SGR.Dull color+ | code `between` (100, 107) = do+ color <- codeToColor (code - 100)+ Just $ SGR.SetColor SGR.Background SGR.Vivid color+ | otherwise = Nothing++codeToColor :: Int -> Maybe SGR.Color+codeToColor 0 = Just SGR.Black+codeToColor 1 = Just SGR.Red+codeToColor 2 = Just SGR.Green+codeToColor 3 = Just SGR.Yellow+codeToColor 4 = Just SGR.Blue+codeToColor 5 = Just SGR.Magenta+codeToColor 6 = Just SGR.Cyan+codeToColor 7 = Just SGR.White+codeToColor _ = Nothing++between :: Ord a => a -> (a, a) -> Bool+between val (low, high) = val >= low && val <= high
+ src/System/Terminal/Emulator/Term.hs view
@@ -0,0 +1,242 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module System.Terminal.Emulator.Term+ ( -- * Types+ Term,+ mkTerm,++ -- * Direct 'Term' Lenses+ termAttrs,+ cursorPos,+ cursorState,+ modeWrap,+ insertMode,+ altScreenActive,+ numCols,+ numRows,+ keyboardState,+ scrollTop,+ scrollBottom,+ scrollBackLines,+ numScrollBackLines,+ termScreen,+ termAlt,+ windowTitle,++ -- * Direct 'CursorState' Lenses+ wrapNext,+ origin,++ -- * Helper 'Term' Lenses+ cursorLine,+ activeScreen,++ -- * Misc+ addScrollBackLines,+ vuIndex,+ termGetKeyboardState,+ )+where++import Control.Category ((>>>))+import Control.Exception (assert)+import Control.Lens+import Data.Text (Text)+import qualified Data.Vector.Unboxed as VU+import System.Terminal.Emulator.Attrs (Attrs, blankAttrs)+import System.Terminal.Emulator.KeyboardInput (KeyboardState, initialKeyboardState)+import System.Terminal.Emulator.TermLines (TermLine, TermLines)+import qualified System.Terminal.Emulator.TermLines as TL+import Prelude hiding (lines)++data CursorState = CursorState+ { cursorState_WrapNext :: !Bool,+ cursorState_Origin :: !Bool+ }+ deriving (Show, Eq, Ord)++data CursorPos = CursorPos !Int !Int+ deriving (Show, Eq, Ord)++data Term = Term+ { term_Attrs :: !Attrs,+ -- | (line, column)+ term_CursorPos :: !CursorPos,+ term_CursorState :: !CursorState,+ -- | Set using Wraparound Mode (DECAWM)+ term_ModeWrap :: !Bool,+ -- | Set using Insert/Replace Mode (IRM)+ term_InsertMode :: !Bool,+ term_AltScreenActive :: !Bool,+ term_NumCols :: !Int,+ term_NumRows :: !Int,+ term_KeyboardState :: !KeyboardState,+ -- | Row index of the top of the scroll region+ term_ScrollTop :: !Int,+ -- | Row index of the bottom of the scroll region+ term_ScrollBottom :: !Int,+ -- | Scroll back lines of the Main screen+ term_ScrollBackLines :: !TermLines,+ -- | Maximum scroll back lines to be saved+ term_NumScrollBackLines :: !Int,+ -- | Main screen. This is always the size of the terminal.+ term_Screen :: !TermLines,+ -- | Alternate screen. This is always the size of the terminal.+ --+ -- The Alternate screen does not have any scroll back lines+ --+ -- See also:+ -- <https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-The-Alternate-Screen-Buffer>+ term_Alt :: !TermLines,+ term_WindowTitle :: !Text+ }+ deriving (Show, Eq, Ord)++-- | Create a new blank Terminal with the given size @(width, height)@+mkTerm :: (Int, Int) -> Term+mkTerm (width, height) =+ Term+ { term_Attrs = blankAttrs,+ term_CursorPos = CursorPos 0 0,+ term_CursorState =+ CursorState+ { cursorState_WrapNext = False,+ cursorState_Origin = False+ },+ term_ModeWrap = True,+ term_InsertMode = False,+ term_AltScreenActive = False,+ term_NumCols = width,+ term_NumRows = height,+ term_KeyboardState = initialKeyboardState,+ term_ScrollTop = 0,+ term_ScrollBottom = height - 1,+ term_ScrollBackLines = TL.empty,+ term_NumScrollBackLines = 1000,+ term_Screen = TL.replicate height (VU.replicate width ((' ', 0))),+ term_Alt = TL.replicate height (VU.replicate width ((' ', 0))),+ term_WindowTitle = "hs-term"+ }++-----------------------------------------------------------------------+-- Direct 'Term' Lenses+-----------------------------------------------------------------------++termAttrs :: Lens' Term Attrs+termAttrs = lens term_Attrs (\term newVal -> term {term_Attrs = newVal})++-- | Cursor line is always in the range [0..numRows-1]+--+-- Cursor col is always in the range [0..numCols-1]+cursorPos :: Lens' Term (Int, Int)+cursorPos = lens getter setter+ where+ getter :: Term -> (Int, Int)+ getter term = let CursorPos row col = term_CursorPos term in (row, col)+ setter :: Term -> (Int, Int) -> Term+ setter term (newRow, newCol) =+ assert (newCol >= minX) $+ assert (newCol <= maxX) $+ assert (newRow >= minY) $+ assert (newRow <= maxY) $+ term {term_CursorPos = CursorPos newRow newCol}+ where+ minX = 0+ maxX = (term ^. numCols) - 1+ minY = 0+ maxY = (term ^. numRows) - 1++cursorState :: Lens' Term CursorState+cursorState = lens term_CursorState (\term newVal -> term {term_CursorState = newVal})++-- | Wraparound Mode (DECAWM)+modeWrap :: Lens' Term Bool+modeWrap = lens term_ModeWrap (\term newVal -> term {term_ModeWrap = newVal})++-- | Insert/Replace Mode (IRM)+insertMode :: Lens' Term Bool+insertMode = lens term_InsertMode (\term newVal -> term {term_InsertMode = newVal})++altScreenActive :: Lens' Term Bool+altScreenActive = lens term_AltScreenActive (\term newVal -> term {term_AltScreenActive = newVal})++numCols :: Lens' Term Int+numCols = lens term_NumCols (\term newVal -> term {term_NumCols = newVal})++numRows :: Lens' Term Int+numRows = lens term_NumRows (\term newVal -> term {term_NumRows = newVal})++keyboardState :: Lens' Term KeyboardState+keyboardState = lens term_KeyboardState (\term newVal -> term {term_KeyboardState = newVal})++scrollTop :: Lens' Term Int+scrollTop = lens term_ScrollTop (\term newVal -> term {term_ScrollTop = newVal})++scrollBottom :: Lens' Term Int+scrollBottom = lens term_ScrollBottom (\term newVal -> term {term_ScrollBottom = newVal})++scrollBackLines :: Lens' Term TermLines+scrollBackLines = lens term_ScrollBackLines (\term newVal -> term {term_ScrollBackLines = newVal})++numScrollBackLines :: Lens' Term Int+numScrollBackLines = lens term_NumScrollBackLines (\term newVal -> term {term_NumScrollBackLines = newVal})++termScreen :: Lens' Term TermLines+termScreen = lens term_Screen (\term newVal -> term {term_Screen = newVal})++termAlt :: Lens' Term TermLines+termAlt = lens term_Alt (\term newVal -> term {term_Alt = newVal})++windowTitle :: Lens' Term Text+windowTitle = lens term_WindowTitle (\term newWindowTitle -> term {term_WindowTitle = newWindowTitle})++-----------------------------------------------------------------------+-- Direct 'Term' Lenses+-----------------------------------------------------------------------++wrapNext :: Lens' CursorState Bool+wrapNext = lens cursorState_WrapNext (\cs newWrapNext -> cs {cursorState_WrapNext = newWrapNext})++origin :: Lens' CursorState Bool+origin = lens cursorState_Origin (\cs newOrigin -> cs {cursorState_Origin = newOrigin})++-----------------------------------------------------------------------+-- Helper 'Term' Lenses+-----------------------------------------------------------------------++-- | A lens to the line where the cursor currently is+cursorLine :: Lens' Term TermLine+cursorLine = lens getter setter+ where+ getter :: Term -> TermLine+ getter term = term ^. activeScreen . TL.vIndex (term ^. cursorPos . _1)+ setter :: Term -> TermLine -> Term+ setter term newTermLine = ((activeScreen . TL.vIndex (term ^. cursorPos . _1)) .~ newTermLine) term++-- | Either the main screen or the alternate screen (depending on which is+-- active)+activeScreen :: Lens' Term TermLines+activeScreen = lens getter setter+ where+ getter :: Term -> TermLines+ getter term = (if term_AltScreenActive term then term_Alt else term_Screen) term+ setter :: Term -> TermLines -> Term+ setter term newLines = (if term_AltScreenActive term then term {term_Alt = newLines} else term {term_Screen = newLines})++-----------------------------------------------------------------------++termGetKeyboardState :: Term -> KeyboardState+termGetKeyboardState = term_KeyboardState++vuIndex :: VU.Unbox a => Int -> Lens' (VU.Vector a) a+vuIndex i = lens getter setter+ where+ getter :: VU.Unbox a => VU.Vector a -> a+ getter v = assert (i >= 0 && i <= VU.length v - 1) $ v VU.! i+ setter :: VU.Unbox a => VU.Vector a -> a -> VU.Vector a+ setter v val = assert (i >= 0 && i <= VU.length v - 1) $ v VU.// [(i, val)]++addScrollBackLines :: TermLines -> Term -> Term+addScrollBackLines newLines term =+ (scrollBackLines %~ ((<> newLines) >>> TL.takeLast (term ^. numScrollBackLines))) term
+ src/System/Terminal/Emulator/Term/Process.hs view
@@ -0,0 +1,462 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++module System.Terminal.Emulator.Term.Process+ ( Term,+ TermLine,+ processTermAtoms,+ )+where++import Control.Category ((>>>))+import Control.Lens+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC8+import Data.Foldable (foldl')+import Data.List (iterate')+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as VU+import qualified System.Console.ANSI.Types as SGR+import System.Terminal.Emulator.Attrs (Attrs, attrsBg, attrsFg, attrsIntensity, attrsUnderline, blankAttrs)+import System.Terminal.Emulator.DECPrivateMode (DECPrivateMode)+import qualified System.Terminal.Emulator.DECPrivateMode as DECPrivateMode+import System.Terminal.Emulator.KeyboardInput (KeyboardState (keyboardState_CRLF, keyboardState_DECCKM, keyboardState_Locked))+import System.Terminal.Emulator.Parsing.Types (ControlSequenceIntroducer (..), DeviceStatusReport (..), EraseInDisplayParam (..), EraseInLineParam (..), EscapeSequence (..), Mode (..), OperatingSystemCommand (..), SendDeviceAttributesSecondary (RequestTerminalIdentificationCode), SingleCharacterFunction (..), TermAtom (..), WindowManipulation (..))+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)+import System.Terminal.Emulator.TermLines (TermLine)+import qualified System.Terminal.Emulator.TermLines as TL+import Prelude hiding (lines)++processTermAtoms :: [TermAtom] -> Term -> (ByteString, Term)+processTermAtoms termAtoms term =+ foldl'+ ( \(!w1, !t) termAtom ->+ let (!w2, !t') = processTermAtom termAtom t+ in (w1 <> w2, t')+ )+ (B.empty, term)+ termAtoms++processTermAtom :: TermAtom -> Term -> (ByteString, Term)+processTermAtom (TermAtom_VisibleChar char) = nw $ processVisibleChar char+processTermAtom (TermAtom_SingleCharacterFunction Control_Bell) = nw id -- TODO+processTermAtom (TermAtom_SingleCharacterFunction Control_Backspace) = nw $ \term -> cursorMoveTo (term ^. cursorPos . _1, (term ^. cursorPos . _2) - 1) term+processTermAtom (TermAtom_SingleCharacterFunction Control_Tab) = nw $ putTabs 1+processTermAtom (TermAtom_SingleCharacterFunction Control_LineFeed) = nw $ processLF+processTermAtom (TermAtom_SingleCharacterFunction Control_VerticalTab) = nw $ processLF+processTermAtom (TermAtom_SingleCharacterFunction Control_FormFeed) = nw $ processLF+processTermAtom (TermAtom_SingleCharacterFunction Control_CarriageReturn) = nw $ \term -> cursorMoveTo (term ^. cursorPos . _1, 0) term+processTermAtom (TermAtom_SingleCharacterFunction Control_ReturnTerminalStatus) = nw id+processTermAtom (TermAtom_SingleCharacterFunction Control_SwitchToStandardCharacterSet) = nw id+processTermAtom (TermAtom_SingleCharacterFunction Control_SwitchToAlternateCharacterSet) = nw id+processTermAtom (TermAtom_EscapeSequence escapeSequence) = processEscapeSequence escapeSequence+processTermAtom (TermAtom_SingleCharacterFunctionUnknown x) = error $ "Unknown Character Function: " <> show x+processTermAtom (TermAtom_EscapeSequenceUnknown x)+ | isExpectedInvalidEscSequence x = nw id+ | otherwise = error $ "Unknown ESC seq: " <> show x++-- | No-write operation+nw :: (Term -> Term) -> Term -> (ByteString, Term)+nw f term = (B.empty, f term)++-- | I have observed some invalid ESC sequences in the wild, that I am+-- deciding to ignore for now+isExpectedInvalidEscSequence :: Text -> Bool+isExpectedInvalidEscSequence str+ | ("\ESC[" `T.isPrefixOf` str) && T.any (== '\r') str = True+ | str == "\ESC\r" = True+ | otherwise = False++processEscapeSequence :: EscapeSequence -> Term -> (ByteString, Term)+processEscapeSequence Esc_ReverseIndex = nw reverseIndex+processEscapeSequence Esc_RIS = nw id -- TODO+processEscapeSequence Esc_DECPAM = nw id -- TODO+processEscapeSequence Esc_DECPNM = nw id -- TODO+processEscapeSequence (ESC_SetG0CharacterSet _) = nw id -- Ignore+processEscapeSequence (Esc_CSI (CSI_CursorUp n)) = nw $ \term -> cursorMoveTo ((term ^. cursorPos . _1) - n, term ^. cursorPos . _2) term+processEscapeSequence (Esc_CSI (CSI_CursorDown n)) = nw $ \term -> cursorMoveTo ((term ^. cursorPos . _1) + n, term ^. cursorPos . _2) term+processEscapeSequence (Esc_CSI (CSI_LinePositionRelative n)) = nw $ \term -> cursorMoveTo ((term ^. cursorPos . _1) + n, term ^. cursorPos . _2) term+processEscapeSequence (Esc_CSI (CSI_CharacterPositionRelative n)) = nw $ \term -> cursorMoveTo (term ^. cursorPos . _1, (term ^. cursorPos . _2) + n) term+processEscapeSequence (Esc_CSI (CSI_CursorForward n)) = nw $ \term -> cursorMoveTo (term ^. cursorPos . _1, (term ^. cursorPos . _2) + n) term+processEscapeSequence (Esc_CSI (CSI_CursorBack n)) = nw $ \term -> cursorMoveTo (term ^. cursorPos . _1, (term ^. cursorPos . _2) - n) term+processEscapeSequence (Esc_CSI (CSI_EraseInLine param)) = nw $ eraseInLine param+processEscapeSequence (Esc_CSI (CSI_EraseCharacters n)) = nw $ eraseCharacters n+processEscapeSequence (Esc_CSI (CSI_InsertBlankCharacters n)) = nw $ insertBlankChars n+processEscapeSequence (Esc_CSI (CSI_InsertBlankLines n)) = nw $ insertBlankLines n+processEscapeSequence (Esc_CSI (CSI_DeleteChars n)) = nw $ deleteChars n+processEscapeSequence (Esc_CSI (CSI_DeleteLines n)) = nw $ deleteLines n+processEscapeSequence (Esc_CSI (CSI_CursorCharacterAbsolute col)) = nw $ \term -> cursorMoveTo (term ^. cursorPos . _1, col - 1) term+processEscapeSequence (Esc_CSI (CSI_CharacterPositionAbsolute col)) = nw $ \term -> cursorMoveTo (term ^. cursorPos . _1, col - 1) term+processEscapeSequence (Esc_CSI (CSI_CursorPosition row col)) = nw $ cursorMoveAbsoluteTo (row - 1, col -1)+processEscapeSequence (Esc_CSI (CSI_HorizontalVerticalPosition row col)) = nw $ cursorMoveAbsoluteTo (row - 1, col - 1)+processEscapeSequence (Esc_CSI (CSI_LinePositionAbsolute row)) = nw $ \term -> cursorMoveAbsoluteTo (row - 1, term ^. cursorPos . _2) term+processEscapeSequence (Esc_CSI (CSI_ScrollUp n)) = nw $ \term -> scrollUp (term ^. scrollTop) n term+processEscapeSequence (Esc_CSI (CSI_ScrollDown n)) = nw $ \term -> scrollDown (term ^. scrollTop) n term+processEscapeSequence (Esc_CSI (CSI_EraseInDisplay param)) = nw $ eraseInDisplay param+processEscapeSequence (Esc_CSI (CSI_WindowManipulation param)) = nw $ windowManipulation param+processEscapeSequence (Esc_CSI (CSI_DeviceStatusReport param)) = deviceStatusReport param+processEscapeSequence (Esc_CSI (CSI_SoftTerminalReset)) = nw $ softTerminalReset+processEscapeSequence (Esc_CSI (CSI_SetMode param)) = nw $ setMode param+processEscapeSequence (Esc_CSI (CSI_ResetMode param)) = nw $ resetMode param+processEscapeSequence (Esc_CSI (CSI_SendDeviceAttributes)) = sendDeviceAttributes+processEscapeSequence (Esc_CSI (CSI_SendDeviceAttributesSecondary param)) = sendDeviceAttributesSecondary param+processEscapeSequence (Esc_CSI (CSI_RequestDECPrivateMode _i)) = nw id -- TODO (?)+processEscapeSequence (Esc_CSI (CSI_DECSTBM top bottom)) = nw $ (setScrollingRegion top bottom) >>> cursorMoveAbsoluteTo (0, 0)+processEscapeSequence (Esc_CSI (CSI_DECSET decset)) = nw $ termProcessDecset decset+processEscapeSequence (Esc_CSI (CSI_DECSET_Unknown _code)) = nw id -- TODO Log this+processEscapeSequence (Esc_CSI (CSI_DECRST decset)) = nw $ termProcessDecrst decset+processEscapeSequence (Esc_CSI (CSI_DECRST_Unknown _code)) = nw id -- TODO Log this+processEscapeSequence (Esc_CSI (CSI_SGR sgrs)) = nw $ \term -> V.foldl' (flip termProcessSGR) term sgrs+processEscapeSequence (Esc_OSC osc) = processOsc osc++putTabs :: Int -> Term -> Term+putTabs n+ | n >= 0 = \term -> (iterate' putTabForward term) !! n+ | otherwise = \term -> (iterate' putTabBackward term) !! (negate n)+ where+ tabspaces = 8+ putTabForward :: Term -> Term+ putTabForward term = ((cursorPos . _2) .~ (limit 0 (term ^. numCols - 1) col')) term+ where+ col = term ^. cursorPos . _2+ col' = ((col + tabspaces) `div` tabspaces) * tabspaces+ putTabBackward :: Term -> Term+ putTabBackward term+ | col == 0 = term+ | otherwise = ((cursorPos . _2) .~ (limit 0 (term ^. numCols - 1) col')) term+ where+ col = term ^. cursorPos . _2+ col' = ((col - 1) `div` tabspaces) * tabspaces++processLF :: Term -> Term+processLF term = addNewline (keyboardState_CRLF (term ^. keyboardState)) term++eraseInLine :: EraseInLineParam -> Term -> Term+eraseInLine ClearFromCursorToEndOfLine term = clearRegion (term ^. cursorPos) (term ^. cursorPos ^. _1, (term ^. numCols) - 1) term+eraseInLine ClearFromCursorToBeginningOfLine term = clearRegion (term ^. cursorPos ^. _1, 0) (term ^. cursorPos) term+eraseInLine ClearEntireLine term = clearRegion (term ^. cursorPos ^. _1, 0) (term ^. cursorPos ^. _1, (term ^. numCols) - 1) term++eraseCharacters :: Int -> Term -> Term+eraseCharacters n term = clearRegion (term ^. cursorPos) ((_2 %~ ((subtract 1) . (+ n))) (term ^. cursorPos)) term++reverseIndex :: Term -> Term+reverseIndex term+ | term ^. cursorPos . _1 == term ^. scrollTop = scrollDown (term ^. scrollTop) 1 term+ | otherwise = cursorMoveTo ((term ^. cursorPos . _1) - 1, term ^. cursorPos . _2) term++eraseInDisplay :: EraseInDisplayParam -> Term -> Term+eraseInDisplay EraseAbove _ = error "TODO EraseAbove"+eraseInDisplay EraseBelow term = (clearToEndOfLine >>> clearBelow) term+ where+ clearToEndOfLine = clearRegion (term ^. cursorPos) ((_2 .~ ((term ^. numCols) - 1)) (term ^. cursorPos))+ clearBelow+ | term ^. cursorPos . _1 < term ^. numRows - 1 =+ clearRegion+ (((_1 %~ (+ 1)) >>> (_2 .~ 0)) (term ^. cursorPos))+ (((_1 .~ ((term ^. numRows) - 1)) >>> (_2 .~ ((term ^. numCols) - 1))) (term ^. cursorPos))+ | otherwise = id+eraseInDisplay EraseAll term = clearRegion (0, 0) ((term ^. numRows) - 1, (term ^. numCols) - 1) term+eraseInDisplay EraseSavedLines term = (scrollBackLines .~ TL.empty) term++windowManipulation :: WindowManipulation -> Term -> Term+windowManipulation SaveIconAndWindowTitleOnStack = id -- TODO We could add a stack to our 'Term' data structure and save this+windowManipulation RestoreIconAndWindowTitleOnStack = id -- TODO We could add a stack to our 'Term' data structure and save this++deviceStatusReport :: DeviceStatusReport -> Term -> (ByteString, Term)+deviceStatusReport param term = case param of+ StatusReport ->+ let ok = "\ESC[0n"+ in (ok, term)+ ReportCursorPosition ->+ let (line, col) = term ^. cursorPos+ lineStr = BC8.pack (show (line + 1))+ colStr = BC8.pack (show (col + 1))+ cpr = "\ESC[" <> lineStr <> ";" <> colStr <> "R"+ in (cpr, term)++sendDeviceAttributes :: Term -> (ByteString, Term)+sendDeviceAttributes term =+ let identification = "\ESC[?1;2c" -- TODO or maybe "\ESC[?6c" ?+ in (identification, term)++sendDeviceAttributesSecondary :: SendDeviceAttributesSecondary -> Term -> (ByteString, Term)+sendDeviceAttributesSecondary RequestTerminalIdentificationCode term =+ let identification = "\ESC[>0;0;0c"+ in (identification, term)++softTerminalReset :: Term -> Term+softTerminalReset term = mkTerm (term ^. numCols, term ^. numRows)++setMode :: Mode -> Term -> Term+setMode KeyboardActionMode = keyboardState %~ (\state -> state {keyboardState_Locked = True})+setMode InsertReplaceMode = insertMode .~ True+setMode SendReceive = error "TODO Send/receive (SRM) Not Supported"+setMode AutomaticNewlineNormalLinefeed = keyboardState %~ (\state -> state {keyboardState_CRLF = True})++resetMode :: Mode -> Term -> Term+resetMode KeyboardActionMode = keyboardState %~ (\state -> state {keyboardState_Locked = False})+resetMode InsertReplaceMode = insertMode .~ False+resetMode SendReceive = id+resetMode AutomaticNewlineNormalLinefeed = keyboardState %~ (\state -> state {keyboardState_CRLF = False})++processOsc :: OperatingSystemCommand -> Term -> (ByteString, Term)+processOsc (OSC_SetTitle _ True str) = nw $ windowTitle .~ str+processOsc (OSC_SetTitle _ False _) = nw id -- set window icon not supported+processOsc (OSC_ChangeTextForegroundColor _) = nw id -- Ignore+processOsc (OSC_ChangeTextBackgroundColor _) = nw id -- Ignore+processOsc OSC_RequestTextForegroundColor = \term -> ("\ESC]10;0\a", term)+processOsc OSC_RequestTextBackgroundColor = \term -> ("\ESC]11;0\a", term)+processOsc OSC_ResetTextCursorColor = nw id++insertBlankChars :: Int -> Term -> Term+insertBlankChars n term = (cursorLine %~ updateLine) term+ where+ n' = limit 0 (term ^. numCols - term ^. cursorPos . _2) n+ col = term ^. cursorPos . _2+ updateLine :: TermLine -> TermLine+ updateLine termLine =+ start <> blanks <> rest+ where+ start = VU.take col termLine+ blanks = VU.replicate n' (' ', term ^. termAttrs)+ rest = VU.slice col (term ^. numCols - col) termLine++insertBlankLines :: Int -> Term -> Term+insertBlankLines n term+ | between (term ^. scrollTop, term ^. scrollBottom) (term ^. cursorPos . _1) = scrollDown (term ^. cursorPos . _1) n term+ | otherwise = term++deleteChars :: Int -> Term -> Term+deleteChars n term = (cursorLine %~ updateLine) term+ where+ n' = limit 0 ((term ^. numCols) - (term ^. cursorPos . _2)) n+ srcCol = col + n'+ size = term ^. numCols - srcCol+ col = term ^. cursorPos . _2+ updateLine :: TermLine -> TermLine+ updateLine termLine =+ start <> slice <> VU.replicate n' (' ', term ^. termAttrs)+ where+ start = VU.take col termLine+ slice = VU.slice srcCol size termLine++deleteLines :: Int -> Term -> Term+deleteLines n term+ | between (term ^. scrollTop, term ^. scrollBottom) (term ^. cursorPos . _1) = scrollUp (term ^. cursorPos . _1) n term+ | otherwise = term++setScrollingRegion :: Maybe Int -> Maybe Int -> Term -> Term+setScrollingRegion mbTop mbBottom term =+ ((scrollTop .~ top) >>> (scrollBottom .~ bottom)) term+ where+ top1 = case mbTop of+ Nothing -> 0+ Just t -> t - 1+ bottom1 = case mbBottom of+ Nothing -> term ^. numRows - 1+ Just b -> b - 1+ minY = 0+ maxY = term ^. numRows - 1+ top2 = limit minY maxY top1+ bottom2 = limit minY maxY bottom1+ (top, bottom) = if top2 > bottom2 then (bottom2, top2) else (top2, bottom2)++termProcessDecset :: DECPrivateMode -> Term -> Term+termProcessDecset DECPrivateMode.DECCKM = keyboardState %~ (\state -> state {keyboardState_DECCKM = True})+termProcessDecset DECPrivateMode.DECOM = (cursorState . origin .~ True) >>> (cursorMoveAbsoluteTo (0, 0))+termProcessDecset DECPrivateMode.ReportButtonPress = id+termProcessDecset DECPrivateMode.BracketedPasteMode = id -- TODO Set flag on 'Term'+termProcessDecset DECPrivateMode.SaveCursorAsInDECSCAndUseAlternateScreenBuffer = altScreenActive .~ True+termProcessDecset DECPrivateMode.Att610 = id -- TODO Set flag on 'Term'+termProcessDecset DECPrivateMode.DECTCEM = id -- TODO Set flag on 'Term'+termProcessDecset DECPrivateMode.DECAWM = modeWrap .~ True+termProcessDecset other = error $ "TODO: DECSET: " <> show other++termProcessDecrst :: DECPrivateMode -> Term -> Term+termProcessDecrst DECPrivateMode.DECCKM = keyboardState %~ (\state -> state {keyboardState_DECCKM = False})+termProcessDecrst DECPrivateMode.DECOM = (cursorState . origin .~ False) >>> (cursorMoveAbsoluteTo (0, 0))+termProcessDecrst DECPrivateMode.Att610 = id -- TODO Unset flag on 'Term'+termProcessDecrst DECPrivateMode.DECTCEM = id -- TODO Unset flag on 'Term'+termProcessDecrst DECPrivateMode.DECCOLM = id -- Ignored+termProcessDecrst DECPrivateMode.ReportButtonPress = id+termProcessDecrst DECPrivateMode.BracketedPasteMode = id -- TODO Unset flag on 'Term'+termProcessDecrst DECPrivateMode.SaveCursorAsInDECSCAndUseAlternateScreenBuffer = altScreenActive .~ False+termProcessDecrst DECPrivateMode.DECAWM = modeWrap .~ False+termProcessDecrst DECPrivateMode.EnableAllMouseMotions = id+termProcessDecrst DECPrivateMode.ReportMotionOnButtonPress = id+termProcessDecrst other = error $ "TODO: DECRST: " <> show other++termProcessSGR :: SGR.SGR -> Term -> Term+termProcessSGR = over termAttrs . applySGR++-- | For absolute user moves, when DECOM is set+cursorMoveAbsoluteTo :: (Int, Int) -> Term -> Term+cursorMoveAbsoluteTo (row, col) term =+ cursorMoveTo (row + rowOffset, col) term+ where+ rowOffset+ | term ^. cursorState . origin = term ^. scrollTop+ | otherwise = 0++cursorMoveTo :: (Int, Int) -> Term -> Term+cursorMoveTo (row, col) term =+ ( cursorPos . _1 .~ (limit minY maxY row)+ >>> cursorPos . _2 .~ (limit minX maxX col)+ >>> cursorState . wrapNext .~ False+ )+ term+ where+ minX = 0+ maxX = term ^. numCols - 1+ (minY, maxY)+ | term ^. cursorState . origin = (term ^. scrollTop, term ^. scrollBottom)+ | otherwise = (0, term ^. numRows - 1)++applySGR :: SGR.SGR -> Attrs -> Attrs+applySGR SGR.Reset = const blankAttrs+applySGR (SGR.SetConsoleIntensity intensity) = set attrsIntensity intensity+applySGR (SGR.SetItalicized _) = id -- TODO Not Supported+applySGR (SGR.SetUnderlining underlining) = set attrsUnderline underlining+applySGR (SGR.SetBlinkSpeed _) = id -- TODO Not Supported+applySGR (SGR.SetVisible _) = id -- TODO Not Supported+applySGR (SGR.SetSwapForegroundBackground _) = id -- TODO Not Supported+applySGR (SGR.SetColor SGR.Foreground intensity color) = set attrsFg (Just (intensity, color))+applySGR (SGR.SetColor SGR.Background intensity color) = set attrsBg (Just (intensity, color))+applySGR (SGR.SetRGBColor _ _) = id -- TODO Not Supported+applySGR (SGR.SetPaletteColor _ _) = id -- TODO Not Supported+applySGR (SGR.SetDefaultColor SGR.Foreground) = set attrsFg Nothing+applySGR (SGR.SetDefaultColor SGR.Background) = set attrsBg Nothing++processVisibleChar :: Char -> Term -> Term+processVisibleChar c =+ moveCursorBefore+ >>> moveChars+ >>> moveCursorDown+ >>> setChar+ >>> moveCursorAfter+ where+ moveCursorBefore :: Term -> Term+ moveCursorBefore term+ | (term ^. modeWrap) && (term ^. cursorState ^. wrapNext) = addNewline True term+ | otherwise = term+ moveChars :: Term -> Term+ moveChars term+ | (term ^. insertMode) && (col < (term ^. numCols) - 1) =+ ( cursorLine+ %~ ( \line ->+ VU.take+ (term ^. numCols)+ (VU.take col line <> VU.singleton (' ', 0) <> VU.drop col line)+ )+ )+ term+ | otherwise = term+ where+ col = term ^. cursorPos . _2+ moveCursorDown :: Term -> Term+ moveCursorDown term+ | term ^. cursorPos . _2 > (term ^. numCols) - 1 = addNewline True term+ | otherwise = term+ setChar :: Term -> Term+ setChar term = ((cursorLine . (vuIndex (term ^. cursorPos . _2))) .~ (c, term ^. termAttrs)) term+ moveCursorAfter :: Term -> Term+ moveCursorAfter term+ | term ^. cursorPos . _2 < (term ^. numCols) - 1 = cursorMoveTo (term ^. cursorPos . _1, (term ^. cursorPos . _2) + 1) term+ | otherwise = ((cursorState . wrapNext) .~ True) term++addNewline ::+ -- | first column+ Bool ->+ Term ->+ Term+addNewline firstCol = doScrollUp >>> moveCursor+ where+ doScrollUp :: Term -> Term+ doScrollUp term+ | term ^. cursorPos . _1 == term ^. scrollBottom = scrollUp (term ^. scrollTop) 1 term+ | otherwise = term+ moveCursor :: Term -> Term+ moveCursor term = cursorMoveTo (newRow, newCol) term+ where+ newRow+ | term ^. cursorPos . _1 == term ^. scrollBottom = term ^. cursorPos . _1+ | otherwise = (term ^. cursorPos . _1) + 1+ newCol+ | firstCol = 0+ | otherwise = term ^. cursorPos . _2++scrollDown :: Int -> Int -> Term -> Term+scrollDown orig n term = scrollLines term+ where+ n' = limit 0 (term ^. scrollBottom - orig + 1) n+ scrollLines =+ activeScreen+ %~ ( \lines ->+ TL.take orig lines+ <> TL.replicate n' newBlankLine+ <> TL.take ((term ^. scrollBottom) - orig - n' + 1) (TL.drop orig lines)+ <> TL.drop ((term ^. scrollBottom) + 1) lines+ )+ newBlankLine = VU.replicate (term ^. numCols) (' ', term ^. termAttrs)++scrollUp :: Int -> Int -> Term -> Term+scrollUp orig n term =+ (copyLinesToScrollBack >>> scrollLines) term+ where+ n' = limit 0 (term ^. scrollBottom - orig + 1) n+ copyLinesToScrollBack+ | not (term ^. altScreenActive) && orig == 0 = addScrollBackLines (TL.take n' (term ^. termScreen))+ | otherwise = id+ scrollLines =+ activeScreen+ %~ ( \lines ->+ TL.take orig lines+ <> TL.take ((term ^. scrollBottom) - orig - n' + 1) (TL.drop (orig + n') lines)+ <> TL.replicate n' newBlankLine+ <> TL.drop ((term ^. scrollBottom) + 1) lines+ )+ newBlankLine = VU.replicate (term ^. numCols) (' ', term ^. termAttrs)++clearRegion :: (Int, Int) -> (Int, Int) -> Term -> Term+clearRegion (line1, col1) (line2, col2) term =+ foldl'+ (\t line -> clearRow line (limit minX maxX col1') (limit minX maxX col2') t)+ term+ [(limit minY maxY line1') .. (limit minY maxY line2')]+ where+ line1' = min line1 line2+ line2' = max line1 line2+ col1' = min col1 col2+ col2' = max col1 col2+ minX = 0+ maxX = term ^. numCols - 1+ minY = 0+ maxY = term ^. numRows - 1++clearRow :: Int -> Int -> Int -> Term -> Term+clearRow line startCol endCol term =+ foldl'+ (\t col -> (activeScreen . TL.vIndex line . vuIndex col .~ (' ', attrs)) t)+ term+ [startCol .. endCol]+ where+ attrs = term ^. termAttrs++limit ::+ -- | minimum allowed value+ Int ->+ -- | maximum allowed value+ Int ->+ -- | value to limit+ Int ->+ Int+limit minVal maxVal val+ | val < minVal = minVal+ | val > maxVal = maxVal+ | otherwise = val++between :: Ord a => (a, a) -> a -> Bool+between (low, high) val = val >= low && val <= high
+ src/System/Terminal/Emulator/Term/Resize.hs view
@@ -0,0 +1,146 @@+module System.Terminal.Emulator.Term.Resize+ ( resizeTerm,+ )+where++import Control.Category ((>>>))+import Control.Exception (assert)+import Control.Lens+import qualified Data.Vector.Unboxed as VU+import System.Terminal.Emulator.Term (Term, addScrollBackLines, altScreenActive, cursorPos, numCols, numRows, scrollBackLines, scrollBottom, scrollTop, termAlt, termAttrs, termScreen)+import System.Terminal.Emulator.TermLines (TermLine, TermLines)+import qualified System.Terminal.Emulator.TermLines as TL+import Prelude hiding (lines)++-- | This should be called when the user resizes the terminal window.+--+-- You should also call 'System.Posix.Pty.resizePty', but only afterwards+--+-- The tuple is in the shape @(newWidth, newHeight)@, both must be positive+resizeTerm :: Term -> (Int, Int) -> Term+resizeTerm term (newWidth, newHeight) =+ assert (newWidth > 0) $+ assert (newHeight > 0) $+ ( resizeTermWidth newWidth+ >>> resizeTermHeight newHeight+ >>> scrollTop .~ 0+ >>> scrollBottom .~ (newHeight - 1)+ )+ term++-- Internal function. Resize the terminal, only changing the width.+resizeTermWidth :: Int -> Term -> Term+resizeTermWidth newWidth term =+ ( numCols .~ newWidth+ >>> termScreen %~ fmap adjustLine+ >>> termAlt %~ fmap adjustLine+ >>> scrollBackLines %~ fmap adjustLine+ >>> cursorPos . _2 %~ min (newWidth - 1)+ )+ term+ where+ oldWidth = term ^. numCols++ expandLine :: TermLine -> TermLine+ expandLine = (<> (VU.replicate (newWidth - oldWidth) ((' ', 0))))++ shrinkLine :: TermLine -> TermLine+ shrinkLine = VU.take newWidth++ adjustLine :: TermLine -> TermLine+ adjustLine+ | newWidth > oldWidth = expandLine+ | otherwise = shrinkLine++-- Internal function. Resize the terminal, only changing the height.+resizeTermHeight :: Int -> Term -> Term+resizeTermHeight newHeight term+ | newHeight >= oldHeight = resizeTermHeight' newHeight term+ | otherwise =+ let term' = truncateTermScreenBottom term (oldHeight - newHeight)+ in resizeTermHeight' newHeight term'+ where+ oldHeight = term ^. numRows++resizeTermHeight' :: Int -> Term -> Term+resizeTermHeight' newHeight term =+ ( numRows .~ newHeight+ >>> adjustScreen+ >>> termAlt %~ adjustAltScreen+ >>> cursorPos . _1 %~ min (newHeight - 1)+ )+ term+ where+ oldHeight = term ^. numRows++ newBlankLine = VU.replicate (term ^. numCols) (' ', term ^. termAttrs)++ expandAltScreen :: TermLines -> TermLines+ expandAltScreen = (<> (TL.replicate (newHeight - oldHeight) newBlankLine))++ shrinkAltScreen :: TermLines -> TermLines+ shrinkAltScreen = TL.take newHeight++ adjustAltScreen :: TermLines -> TermLines+ adjustAltScreen+ | newHeight > oldHeight = expandAltScreen+ | otherwise = shrinkAltScreen++ expandScreen :: Term -> Term+ expandScreen =+ ( termScreen+ %~ ( \lines ->+ TL.takeLast numHistoryLines (term ^. scrollBackLines)+ <> lines+ <> TL.replicate numNewBlankLines newBlankLine+ )+ )+ >>> scrollBackLines %~ TL.dropLast numHistoryLines+ >>> moveCursorDown+ where+ numHistoryLines = min (newHeight - oldHeight) (TL.length (term ^. scrollBackLines))+ numNewBlankLines = (newHeight - oldHeight) - numHistoryLines++ moveCursorDown :: Term -> Term+ moveCursorDown+ | term ^. altScreenActive = id+ | otherwise = cursorPos . _1 %~ (+ numHistoryLines)++ shrinkScreen :: Term -> Term+ shrinkScreen =+ (termScreen %~ TL.takeLast newHeight)+ >>> addScrollBackLines (TL.take numShrunkLines (term ^. termScreen))+ >>> moveCursorUp+ where+ numShrunkLines = oldHeight - newHeight+ moveCursorUp :: Term -> Term+ moveCursorUp+ | term ^. altScreenActive = id+ | otherwise = cursorPos . _1 %~ (\y -> max 0 (y - numShrunkLines))++ adjustScreen+ | newHeight > oldHeight = expandScreen+ | otherwise = shrinkScreen++-- | Chop off up to @n@ lines from the bottom of the main screen (only if they+-- are blank and not occupied by the cursor).+--+-- Also modifies the vertical size of the screen according to the number of+-- lines removed (numLines)+truncateTermScreenBottom :: Term -> Int -> Term+truncateTermScreenBottom term numLines+ | numLines == 0 = term+ | term ^. altScreenActive = term+ | term ^. cursorPos . _1 == term ^. numRows - 1 = term+ | not (lineIsBlank lastLine) = term+ | otherwise =+ let term' =+ ( (termScreen %~ (TL.dropLast 1))+ >>> (numRows %~ (subtract 1))+ )+ term+ in truncateTermScreenBottom term' (numLines - 1)+ where+ lastLine = TL.last (term ^. termScreen)+ lineIsBlank :: TermLine -> Bool+ lineIsBlank = VU.all (== (' ', 0))
+ src/System/Terminal/Emulator/TermLines.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}++module System.Terminal.Emulator.TermLines+ ( TermLine,+ TermLines,+ empty,+ length,+ replicate,+ vIndex,+ head,+ last,+ take,+ takeLast,+ drop,+ dropLast,+ traverseWithIndex,+ )+where++import Control.Exception (assert)+import Control.Lens+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import qualified Data.Vector.Unboxed as VU+import System.Terminal.Emulator.Attrs (Cell)+import Prelude hiding (drop, head, last, length, replicate, take)++type TermLine = VU.Vector Cell++type TermLines = StrictSeq TermLine++newtype StrictSeq a = StrictSeq (Seq a)+ deriving (Show, Eq, Ord, Functor, Semigroup)++-- | The empty sequence.+empty :: StrictSeq a+empty = StrictSeq Seq.empty+{-# INLINE empty #-}++-- | The number of elements in the sequence.+length :: StrictSeq a -> Int+length (StrictSeq v) = Seq.length v+{-# INLINE length #-}++-- | @replicate n x@ is a sequence consisting of n copies of x.+replicate :: Int -> a -> StrictSeq a+replicate n x = StrictSeq $ Seq.replicate n x+{-# INLINE replicate #-}++-- | A lens to the specified index of the sequence. Must be in range.+vIndex :: Int -> Lens' (StrictSeq a) a+vIndex i =+ lens getter setter+ where+ getter :: StrictSeq a -> a+ getter (StrictSeq v) = assert (i >= 0 && i < Seq.length v) $ (`Seq.index` i) v+ setter :: StrictSeq a -> a -> StrictSeq a+ setter (StrictSeq v) val = assert (i >= 0 && i < Seq.length v) $ val `seq` (StrictSeq (Seq.update i val v))+ {-# INLINE getter #-}+ {-# INLINE setter #-}+{-# INLINE vIndex #-}++-- | First element. Must be nonempty+head :: StrictSeq a -> a+head (StrictSeq v) = let x Seq.:< _ = Seq.viewl v in x+{-# INLINE head #-}++-- | Last element. Must be nonempty+last :: StrictSeq a -> a+last (StrictSeq v) = let _ Seq.:> x = Seq.viewr v in x+{-# INLINE last #-}++-- | The first @i@ elements of a sequence. If @i@ is negative, @take i s@+-- yields the empty sequence. If the sequence contains fewer than @i@+-- elements, the whole sequence is returned.+take :: Int -> StrictSeq a -> StrictSeq a+take i (StrictSeq v) = StrictSeq (Seq.take i v)+{-# INLINE take #-}++-- | The last @i@ elements of a sequence. If @i@ is negative, @takeLast i s@+-- yields the empty sequence. If the sequence contains fewer than @i@+-- elements, the whole sequence is returned.+takeLast :: Int -> StrictSeq a -> StrictSeq a+takeLast i (StrictSeq v) = StrictSeq (Seq.drop (Seq.length v - i) v)+{-# INLINE takeLast #-}++-- | Elements of a sequence after the first @i@. If @i@ is negative, @drop i+-- s@ yields the whole sequence. If the sequence contains fewer than @i@+-- elements, the empty sequence is returned.+drop :: Int -> StrictSeq a -> StrictSeq a+drop i (StrictSeq v) = StrictSeq (Seq.drop i v)+{-# INLINE drop #-}++-- | Elements of a sequence after the first @i@ last elements. If @i@ is+-- negative, @dropLast i s@ yields the whole sequence. If the sequence+-- contains fewer than @i@ elements, the empty sequence is returned.+dropLast :: Int -> StrictSeq a -> StrictSeq a+dropLast i (StrictSeq v) = StrictSeq (Seq.take (Seq.length v - i) v)+{-# INLINE dropLast #-}++-- | @traverseWithIndex@ is a version of @traverse@ that also offers access to+-- the index of each element.+traverseWithIndex :: Applicative f => (Int -> a -> f b) -> StrictSeq a -> f (StrictSeq b)+traverseWithIndex f (StrictSeq v) = StrictSeq <$> (Seq.traverseWithIndex f v)+{-# INLINE traverseWithIndex #-}
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/System/Terminal/Emulator/Parsing/InternalSpec.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}++module System.Terminal.Emulator.Parsing.InternalSpec where++import Control.Applicative (many)+import Data.Attoparsec.Text+import Data.Text (Text)+import qualified System.Console.ANSI.Types as SGR+import System.Terminal.Emulator.Parsing (parseTermAtom)+import System.Terminal.Emulator.Parsing.Internal (ControlSequenceIntroducerComponents (..), ControlSequenceIntroducerInput (..), parseControlSequenceIntroducer, parseControlSequenceIntroducerComponents)+import System.Terminal.Emulator.Parsing.Types (ControlSequenceIntroducer (..), EscapeSequence (..), Mode (..), OperatingSystemCommand (..), SingleCharacterFunction (..), TermAtom (..))+import Test.Hspec++spec :: Spec+spec = do+ describe "CSI" $ do+ it "Test 1" $+ (parseControlSequenceIntroducer, "0;1m")+ `shouldParseTo` [ControlSequenceIntroducerInput "0;1m"]+ it "Test 2" $+ parseControlSequenceIntroducerComponents (ControlSequenceIntroducerInput "1A") `shouldBe` Just (ControlSequenceIntroducerComponents False [1] 'A')+ it "Test 3" $+ parseControlSequenceIntroducerComponents (ControlSequenceIntroducerInput "2A") `shouldBe` Just (ControlSequenceIntroducerComponents False [2] 'A')+ it "Test 4" $+ parseControlSequenceIntroducerComponents (ControlSequenceIntroducerInput "A") `shouldBe` Just (ControlSequenceIntroducerComponents False [0] 'A')+ it "Test 6" $+ parseControlSequenceIntroducerComponents (ControlSequenceIntroducerInput "1;2A") `shouldBe` Just (ControlSequenceIntroducerComponents False [1, 2] 'A')+ it "Test 7" $+ parseControlSequenceIntroducerComponents (ControlSequenceIntroducerInput ";A") `shouldBe` Just (ControlSequenceIntroducerComponents False [0, 0] 'A')+ it "Test 8" $+ parseControlSequenceIntroducerComponents (ControlSequenceIntroducerInput ";2A") `shouldBe` Just (ControlSequenceIntroducerComponents False [0, 2] 'A')+ it "Test 9" $+ parseControlSequenceIntroducerComponents (ControlSequenceIntroducerInput ";;2A") `shouldBe` Just (ControlSequenceIntroducerComponents False [0, 0, 2] 'A')+ it "Test 10" $+ parseControlSequenceIntroducerComponents (ControlSequenceIntroducerInput ";2;A") `shouldBe` Just (ControlSequenceIntroducerComponents False [0, 2, 0] 'A')+ it "Test 11" $+ parseControlSequenceIntroducerComponents (ControlSequenceIntroducerInput ";;A") `shouldBe` Just (ControlSequenceIntroducerComponents False [0, 0, 0] 'A')+ describe+ "TermParse Parser"+ $ do+ it "TermAtom_VisibleChar A" $+ (parseTermAtom, "A")+ `shouldParseTo` [TermAtom_VisibleChar 'A']+ it "TermAtom_VisibleChar AB" $+ (parseTermAtom, "AB")+ `shouldParseTo` [TermAtom_VisibleChar 'A', TermAtom_VisibleChar 'B']+ it "TermAtom_VisibleChar ' '" $+ (parseTermAtom, " ")+ `shouldParseTo` [TermAtom_VisibleChar ' ']+ it "Control_Backspace" $+ (parseTermAtom, "\b")+ `shouldParseTo` [TermAtom_SingleCharacterFunction Control_Backspace]+ it "Multi chars" $+ (parseTermAtom, "A\b B")+ `shouldParseTo` [ TermAtom_VisibleChar 'A',+ TermAtom_SingleCharacterFunction Control_Backspace,+ TermAtom_VisibleChar ' ',+ TermAtom_VisibleChar 'B'+ ]+ it "ESC_RIS" $+ (parseTermAtom, "\ESCc")+ `shouldParseTo` [TermAtom_EscapeSequence Esc_RIS]+ it "Multi chars with simple escape" $+ (parseTermAtom, "A\ESCcB\bC")+ `shouldParseTo` [ TermAtom_VisibleChar 'A',+ TermAtom_EscapeSequence Esc_RIS,+ TermAtom_VisibleChar 'B',+ TermAtom_SingleCharacterFunction Control_Backspace,+ TermAtom_VisibleChar 'C'+ ]+ it "OSC set window title" $+ (parseTermAtom, "\ESC]0;Hello\a")+ `shouldParseTo` [TermAtom_EscapeSequence (Esc_OSC (OSC_SetTitle True True "Hello"))]+ it "OSC set window title ST" $+ (parseTermAtom, "\ESC]0;Hello\ESC\\")+ `shouldParseTo` [TermAtom_EscapeSequence (Esc_OSC (OSC_SetTitle True True "Hello"))]+ it "OSC mix" $+ (parseTermAtom, "A\ESC]0;Hello\a\aB")+ `shouldParseTo` [ TermAtom_VisibleChar 'A',+ TermAtom_EscapeSequence (Esc_OSC (OSC_SetTitle True True "Hello")),+ TermAtom_SingleCharacterFunction Control_Bell,+ TermAtom_VisibleChar 'B'+ ]+ it "CSI Cursor up default" $+ (parseTermAtom, "\ESC[A")+ `shouldParseTo` [TermAtom_EscapeSequence (Esc_CSI (CSI_CursorUp 1))]+ it "CSI Cursor up zero" $+ (parseTermAtom, "\ESC[0A")+ `shouldParseTo` [TermAtom_EscapeSequence (Esc_CSI (CSI_CursorUp 1))]+ it "CSI Cursor up default 1" $+ (parseTermAtom, "\ESC[1A")+ `shouldParseTo` [TermAtom_EscapeSequence (Esc_CSI (CSI_CursorUp 1))]+ it "CSI Cursor up default 2" $+ (parseTermAtom, "\ESC[2A")+ `shouldParseTo` [TermAtom_EscapeSequence (Esc_CSI (CSI_CursorUp 2))]+ it "SGR Set bold" $+ (parseTermAtom, "\ESC[1m")+ `shouldParseTo` [TermAtom_EscapeSequence (Esc_CSI (CSI_SGR [SGR.SetConsoleIntensity SGR.BoldIntensity]))]+ it "SGR Reset 1" $+ (parseTermAtom, "\ESC[0m")+ `shouldParseTo` [TermAtom_EscapeSequence (Esc_CSI (CSI_SGR [SGR.Reset]))]+ it "SGR Reset 1" $+ (parseTermAtom, "\ESC[m")+ `shouldParseTo` [TermAtom_EscapeSequence (Esc_CSI (CSI_SGR [SGR.Reset]))]+ it "DECSTR" $+ (parseTermAtom, "\ESC[!p")+ `shouldParseTo` [TermAtom_EscapeSequence (Esc_CSI CSI_SoftTerminalReset)]+ it "RM 0" $+ (parseTermAtom, "\ESC[l")+ `shouldParseTo` [TermAtom_EscapeSequenceUnknown "\ESC[l"]+ it "RM 2" $+ (parseTermAtom, "\ESC[2l")+ `shouldParseTo` [TermAtom_EscapeSequence (Esc_CSI (CSI_ResetMode KeyboardActionMode))]+ it "RM 4" $+ (parseTermAtom, "\ESC[4l")+ `shouldParseTo` [TermAtom_EscapeSequence (Esc_CSI (CSI_ResetMode InsertReplaceMode))]+ it "RM 12" $+ (parseTermAtom, "\ESC[12l")+ `shouldParseTo` [TermAtom_EscapeSequence (Esc_CSI (CSI_ResetMode SendReceive))]+ it "RM 20" $+ (parseTermAtom, "\ESC[20l")+ `shouldParseTo` [TermAtom_EscapeSequence (Esc_CSI (CSI_ResetMode AutomaticNewlineNormalLinefeed))]++shouldParseTo :: (Show a, Eq a) => (Parser a, Text) -> [a] -> IO ()+shouldParseTo (parser, str) expected =+ case parseOnly (many parser <* endOfInput) str of+ Left err -> fail err+ Right ts -> ts `shouldBe` expected