simplex-chat/haskell-terminal
1
0
Fork 0
mirror of https://github.com/simplex-chat/haskell-terminal.git synced 2026-06-03 09:17:32 +00:00
Code Issues Packages Projects Releases Wiki Activity

Major refactoring towards more purity and separation of concern.

Browse Source
This commit is contained in:
Lars Petersen
2018-02-23 21:12:37 +01:00
parent 61dc401501
commit 9a3cfdbe75
8 changed files with 173 additions and 20 deletions
Download Patch File Download Diff File Expand all files Collapse all files
package.yaml
+1
View File
@@ -37,6 +37,7 @@ library:
- System.Terminal.Ansi.Internal
other-modules:
- System.Terminal.Ansi.AnsiTerminalT
- System.Terminal.Ansi.RemoteTerminalT
- System.Terminal.Ansi.Platform
source-dirs: src
when:
src/Control/Monad/Repl.hs
+3 -5
View File
@@ -83,8 +83,8 @@ instance (T.MonadIsolate m) => T.MonadIsolate (ReplT s m) where
instance (T.MonadColorPrinter m) => T.MonadColorPrinter (ReplT s m) where
setDefault = lift T.setDefault
setForegroundColor = lift . T.setForegroundColor
setBackgroundColor = lift . T.setBackgroundColor
setForeground = lift . T.setForeground
setBackground = lift . T.setBackground
setUnderline = lift . T.setUnderline
setNegative = lift . T.setNegative
setBold = lift . T.setBold
@@ -99,7 +99,6 @@ instance (T.MonadScreen m) => T.MonadScreen (ReplT s m) where
cursorVisible = lift . T.cursorVisible
getScreenSize = lift T.getScreenSize
getCursorPosition = lift T.getCursorPosition
setLineWrap = lift . T.setLineWrap
instance (T.MonadEvent m) => T.MonadEvent (ReplT s m) where
withEventSTM = lift . T.withEventSTM
@@ -114,7 +113,7 @@ execReplT (ReplT ma) s = replUserState <$> execStateT loop (replTStateDefault s)
True -> pure ()
protected = catch ma $ \e-> do
if e == E.UserInterrupt then
lift (T.isolate $ T.setBold True >> T.setForegroundColor T.red >> T.putStringLn "Interrupted.")
lift (T.isolate $ T.setBold True >> T.setForeground T.red >> T.putStringLn "Interrupted.")
else
throwM e
@@ -130,7 +129,6 @@ instance T.MonadTerminal m => MonadRepl (ReplT s m) where
prompt <- ReplT $ replPrompt <$> get
prompt
lift $ T.setDefault
lift $ T.setLineWrap False
lift $ T.flush
withStacks [] []
where
src/Control/Monad/Terminal.hs
+2 -3
View File
@@ -53,8 +53,8 @@ class MonadPrinter m => MonadColorPrinter m where
-- * underline
-- * italic
setDefault :: m ()
setForegroundColor :: T.Color -> m ()
setBackgroundColor :: T.Color -> m ()
setForeground :: T.Color -> m ()
setBackground :: T.Color -> m ()
setUnderline :: Bool -> m ()
setNegative :: Bool -> m ()
setBold :: Bool -> m ()
@@ -69,4 +69,3 @@ class MonadPrinter m => MonadScreen m where
cursorVisible :: Bool -> m ()
getScreenSize :: m (Int,Int)
getCursorPosition :: m (Int,Int)
setLineWrap :: Bool -> m ()
src/Control/Monad/Terminal/Pretty.hs
+4 -4
View File
@@ -65,15 +65,15 @@ putDoc doc = T.isolate $ do
PP.SText _ t ss -> T.putText t >> render anns ss
PP.SLine n ss -> T.putLn >> T.putText (Text.replicate n " ") >> render anns ss
PP.SAnnPush ann ss -> case ann of
TermForeground c -> T.setForegroundColor c >> render (ann:anns) ss
TermBackground c -> T.setBackgroundColor c >> render (ann:anns) ss
TermForeground c -> T.setForeground c >> render (ann:anns) ss
TermBackground c -> T.setBackground c >> render (ann:anns) ss
TermInverted -> T.setNegative True >> render (ann:anns) ss
TermUnderlined -> T.setUnderline True >> render (ann:anns) ss
TermBold -> T.setBold True >> render (ann:anns) ss
PP.SAnnPop ss -> case anns of
[] -> render [] ss
(TermForeground c:anns') -> T.setForegroundColor ColorDefault >> render anns' ss
(TermBackground c:anns') -> T.setBackgroundColor ColorDefault >> render anns' ss
(TermForeground c:anns') -> T.setForeground ColorDefault >> render anns' ss
(TermBackground c:anns') -> T.setBackground ColorDefault >> render anns' ss
(TermInverted :anns') -> T.setNegative False >> render anns' ss
(TermUnderlined :anns') -> T.setUnderline False >> render anns' ss
(TermBold :anns') -> T.setBold False >> render anns' ss
src/System/Terminal/Ansi/AnsiTerminalT.hs
+2 -7
View File
@@ -94,7 +94,6 @@ runAnsiTerminalT (AnsiTerminalT ma) = T.withTerminal $ \env-> do
OutCursorPosition x y -> isolate2 i (cursorPosition x y)
OutCursorVisible b -> isolate3 i (cursorVisible b) (\a-> a { tsCursorVisible = b})
OutAskCursorPosition -> isolate2 i askCursorPosition
OutSetLineWrap b -> isolate2 i (setLineWrap b)
where
isolate1 i = isolate True i st >>= run
isolate2 i m = isolate False i st >>= \st-> m >> run st
@@ -194,8 +193,6 @@ runAnsiTerminalT (AnsiTerminalT ma) = T.withTerminal $ \env-> do
cursorVisible False = IO.putStr "\ESC[?25l"
cursorVisible True = IO.putStr "\ESC[?25h"
askCursorPosition = IO.putStr "\ESC[6n"
setLineWrap False = IO.putStr "\ESC[7l"
setLineWrap True = IO.putStr "\ESC[7h"
safeN :: Int -> Int
safeN n
@@ -262,8 +259,8 @@ instance (MonadIO m, MonadThrow m) => T.MonadPrinter (AnsiTerminalT m) where
instance (MonadIO m, MonadThrow m) => T.MonadColorPrinter (AnsiTerminalT m) where
setDefault = write OutSetDefault
setForegroundColor = write . OutSetForeground
setBackgroundColor = write . OutSetBackground
setForeground = write . OutSetForeground
setBackground = write . OutSetBackground
setUnderline = write . OutSetUnderline
setBold = write . OutSetBold
setNegative = write . OutSetNegative
@@ -284,7 +281,6 @@ instance (MonadIO m, MonadThrow m) => T.MonadScreen (AnsiTerminalT m) where
write OutAskCursorPosition
T.flush
liftIO $ atomically $ T.envCursorPosition env
setLineWrap = write . OutSetLineWrap
data Output
= OutIsolate
@@ -309,7 +305,6 @@ data Output
| OutCursorBackward Int
| OutCursorPosition Int Int
| OutCursorVisible Bool
| OutSetLineWrap Bool
write :: (MonadIO m, MonadThrow m) => Output -> AnsiTerminalT m ()
write output = AnsiTerminalT $ do
src/System/Terminal/Ansi/Internal.hs
+5
View File
@@ -43,6 +43,11 @@ class Monad m => MonadInput m where
getNextNonBlock :: m (Maybe Char)
wait :: m ()
instance MonadInput (ReaderT (STM Char) STM) where
getNext = ask >>= lift
getNextNonBlock = ask >>= \mc-> lift ((Just <$> mc) `orElse` pure Nothing)
wait = ask >>= \mc-> lift (fmap (=='\NUL') mc >>= check)
decodeAnsi :: MonadInput m => m T.Event
decodeAnsi = decode1 =<< getNext
where
src/System/Terminal/Ansi/RemoteTerminalT.hs
+154
View File
@@ -0,0 +1,154 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module System.Terminal.Ansi.RemoteTerminalT
( RemoteTerminalT ()
, runRemoteTerminalT
)
where
import Control.Concurrent
import qualified Control.Concurrent.Async as A
import Control.Concurrent.STM.TChan
import Control.Concurrent.STM.TMVar
import Control.Concurrent.STM.TVar
import qualified Control.Exception as E
import Control.Monad (forever, void, when)
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.STM
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State
import Data.Bits
import qualified Data.ByteString as BS
import Data.Char
import Data.Function (fix)
import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.List.NonEmpty as N
import Data.Maybe
import Data.Monoid
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Data.Word
import System.Environment
import qualified System.IO as IO
import qualified Control.Monad.Repl as T
import qualified Control.Monad.Terminal as T
import qualified Control.Monad.Terminal.Color as T
import qualified Control.Monad.Terminal.Events as T
import qualified Control.Monad.Terminal.Modes as T
import qualified Control.Monad.Terminal.Pretty as T
import qualified System.Terminal.Ansi.Internal as T
import qualified System.Terminal.Ansi.Platform as T
data RemoteEnv
= RemoteEnv
{ envTerm :: BS.ByteString
, envInputChars :: STM Char
, envInputEvents :: STM T.Event
, envOutput :: Text.Text -> STM ()
, envOutputFlush :: STM ()
, envSpecialChars :: Char -> Maybe T.Event
}
newtype RemoteTerminalT m a
= RemoteTerminalT (ReaderT RemoteEnv m a)
deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask)
runRemoteTerminalT :: (MonadIO m, MonadMask m) => RemoteTerminalT m a -> RemoteEnv -> m a
runRemoteTerminalT (RemoteTerminalT action) env =
runReaderT action env { envInputEvents = events }
where
events = (mapEvent <$> runReaderT T.decodeAnsi (envInputChars env)) `orElse` envInputEvents env
mapEvent ev@(T.EvKey (T.KChar c) [])
| c == '\NUL' = T.EvKey T.KNull []
| c < ' ' = fromMaybe (T.EvKey (T.KChar $ toEnum $ 64 + fromEnum c) [T.MCtrl]) (envSpecialChars env c)
| otherwise = ev
mapEvent ev = ev
instance MonadTrans RemoteTerminalT where
lift = RemoteTerminalT . lift
instance (MonadIO m) => T.MonadEvent (RemoteTerminalT m) where
withEventSTM f = RemoteTerminalT (liftIO . atomically . f . envInputEvents =<< ask)
instance (MonadIO m) => T.MonadPrinter (RemoteTerminalT m) where
putChar c = RemoteTerminalT $ do
env <- ask
liftIO $ atomically $ envOutput env $ Text.singleton c
putString = \case
[] -> pure ()
(x:xs) -> T.putChar x >> T.putString xs
putText t = RemoteTerminalT $ do
env <- ask
liftIO $ atomically $ envOutput env t
flush = RemoteTerminalT $ do
env <- ask
liftIO $ atomically $ envOutputFlush env
instance (MonadIO m) => T.MonadColorPrinter (RemoteTerminalT m) where
setUnderline True = write "\ESC[4m"
setUnderline False = write "\ESC[24m"
setBold True = write "\ESC[1m"
setBold False = write "\ESC[22m"
setNegative True = write "\ESC[7m"
setNegative False = write "\ESC[27m"
setDefault = write "\ESC[m"
setForeground c@T.ColorDefault = write "\ESC[39m"
setForeground c@(T.Color4Bit T.Black False) = write "\ESC[30m"
setForeground c@(T.Color4Bit T.Red False) = write "\ESC[31m"
setForeground c@(T.Color4Bit T.Green False) = write "\ESC[32m"
setForeground c@(T.Color4Bit T.Yellow False) = write "\ESC[33m"
setForeground c@(T.Color4Bit T.Blue False) = write "\ESC[34m"
setForeground c@(T.Color4Bit T.Magenta False) = write "\ESC[35m"
setForeground c@(T.Color4Bit T.Cyan False) = write "\ESC[36m"
setForeground c@(T.Color4Bit T.White False) = write "\ESC[37m"
setForeground c@(T.Color4Bit T.Black True) = write "\ESC[90m"
setForeground c@(T.Color4Bit T.Red True) = write "\ESC[91m"
setForeground c@(T.Color4Bit T.Green True) = write "\ESC[92m"
setForeground c@(T.Color4Bit T.Yellow True) = write "\ESC[93m"
setForeground c@(T.Color4Bit T.Blue True) = write "\ESC[94m"
setForeground c@(T.Color4Bit T.Magenta True) = write "\ESC[95m"
setForeground c@(T.Color4Bit T.Cyan True) = write "\ESC[96m"
setForeground c@(T.Color4Bit T.White True) = write "\ESC[97m"
setForeground _ = error "FIXME"
setBackground c@T.ColorDefault = write "\ESC[49m"
setBackground c@(T.Color4Bit T.Black False) = write "\ESC[40m"
setBackground c@(T.Color4Bit T.Red False) = write "\ESC[41m"
setBackground c@(T.Color4Bit T.Green False) = write "\ESC[42m"
setBackground c@(T.Color4Bit T.Yellow False) = write "\ESC[43m"
setBackground c@(T.Color4Bit T.Blue False) = write "\ESC[44m"
setBackground c@(T.Color4Bit T.Magenta False) = write "\ESC[45m"
setBackground c@(T.Color4Bit T.Cyan False) = write "\ESC[46m"
setBackground c@(T.Color4Bit T.White False) = write "\ESC[47m"
setBackground c@(T.Color4Bit T.Black True) = write "\ESC[100m"
setBackground c@(T.Color4Bit T.Red True) = write "\ESC[101m"
setBackground c@(T.Color4Bit T.Green True) = write "\ESC[102m"
setBackground c@(T.Color4Bit T.Yellow True) = write "\ESC[103m"
setBackground c@(T.Color4Bit T.Blue True) = write "\ESC[104m"
setBackground c@(T.Color4Bit T.Magenta True) = write "\ESC[105m"
setBackground c@(T.Color4Bit T.Cyan True) = write "\ESC[106m"
setBackground c@(T.Color4Bit T.White True) = write "\ESC[107m"
setBackground _ = error "FIXME"
instance (MonadIO m) => T.MonadScreen (RemoteTerminalT m) where
clear = write "\ESC[H"
cursorUp i = write $ "\ESC[" <> Text.pack (show i) <> "A"
cursorDown i = write $ "\ESC[" <> Text.pack (show i) <> "B"
cursorForward i = write $ "\ESC[" <> Text.pack (show i) <> "C"
cursorBackward i = write $ "\ESC[" <> Text.pack (show i) <> "D"
cursorPosition x y = write $ "\ESC[" <> Text.pack (show x) <> ";" <> Text.pack (show y) <> "H"
cursorVisible False = write "\ESC[?25l"
cursorVisible True = write "\ESC[?25h"
--askCursorPosition = write "\ESC[6n"
getCursorPosition = pure (0,0)
getScreenSize = pure (0,0)
write :: (MonadIO m) => Text.Text -> RemoteTerminalT m ()
write t = RemoteTerminalT $ do
env <- ask
liftIO $ atomically $ envOutput env t
terminal.cabal
+2 -1
View File
@@ -2,7 +2,7 @@
--
-- see: https://github.com/sol/hpack
--
-- hash: 9cd7c0c7e9ee58361168650a7554d7bb01bda633455f7e56d02bf541ef366e8c
-- hash: 2f021e46e24c0f7267b6ab53579f0ce6f9b1c8d01788a630460cfae40d891920
name: terminal
version: 0.1.0.0
@@ -64,6 +64,7 @@ library
System.Terminal.Ansi.Internal
other-modules:
System.Terminal.Ansi.AnsiTerminalT
System.Terminal.Ansi.RemoteTerminalT
System.Terminal.Ansi.Platform
default-language: Haskell2010