diff --git a/package.yaml b/package.yaml index dce1a06..06ff72a 100644 --- a/package.yaml +++ b/package.yaml @@ -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: diff --git a/src/Control/Monad/Repl.hs b/src/Control/Monad/Repl.hs index 8bf8c2b..a02a544 100644 --- a/src/Control/Monad/Repl.hs +++ b/src/Control/Monad/Repl.hs @@ -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 diff --git a/src/Control/Monad/Terminal.hs b/src/Control/Monad/Terminal.hs index ebd80dc..90a2f48 100644 --- a/src/Control/Monad/Terminal.hs +++ b/src/Control/Monad/Terminal.hs @@ -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 () diff --git a/src/Control/Monad/Terminal/Pretty.hs b/src/Control/Monad/Terminal/Pretty.hs index b412af8..cd885b7 100644 --- a/src/Control/Monad/Terminal/Pretty.hs +++ b/src/Control/Monad/Terminal/Pretty.hs @@ -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 diff --git a/src/System/Terminal/Ansi/AnsiTerminalT.hs b/src/System/Terminal/Ansi/AnsiTerminalT.hs index 910dc3d..c556a8d 100644 --- a/src/System/Terminal/Ansi/AnsiTerminalT.hs +++ b/src/System/Terminal/Ansi/AnsiTerminalT.hs @@ -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 diff --git a/src/System/Terminal/Ansi/Internal.hs b/src/System/Terminal/Ansi/Internal.hs index a547f55..b207168 100644 --- a/src/System/Terminal/Ansi/Internal.hs +++ b/src/System/Terminal/Ansi/Internal.hs @@ -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 diff --git a/src/System/Terminal/Ansi/RemoteTerminalT.hs b/src/System/Terminal/Ansi/RemoteTerminalT.hs new file mode 100644 index 0000000..176bc4d --- /dev/null +++ b/src/System/Terminal/Ansi/RemoteTerminalT.hs @@ -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 diff --git a/terminal.cabal b/terminal.cabal index 3c95190..30a24f9 100644 --- a/terminal.cabal +++ b/terminal.cabal @@ -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