{-# LANGUAGE RecordWildCards, CPP #-}
module Graphics.Vty.Input
( Key(..)
, Modifier(..)
, Button(..)
, Event(..)
, Input(..)
, inputForConfig
, attributeControl
)
where
import Graphics.Vty.Config
import Graphics.Vty.Input.Events
import Graphics.Vty.Input.Loop
import Graphics.Vty.Input.Terminfo
import Control.Concurrent.STM
import Lens.Micro
import qualified System.Console.Terminfo as Terminfo
import System.Posix.Signals.Exts
import System.Posix.Terminal
import System.Posix.Types (Fd(..))
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
inputForConfig :: Config -> IO Input
inputForConfig :: Config -> IO Input
inputForConfig config :: Config
config@Config{ termName :: Config -> Maybe String
termName = Just String
termName
, inputFd :: Config -> Maybe Fd
inputFd = Just Fd
termFd
, vmin :: Config -> Maybe Int
vmin = Just Int
_
, vtime :: Config -> Maybe Int
vtime = Just Int
_
, [(String, String)]
InputMap
Maybe Bool
Maybe String
Maybe Fd
Maybe ColorMode
inputMap :: Config -> InputMap
mouseMode :: Maybe Bool
bracketedPasteMode :: Maybe Bool
debugLog :: Maybe String
inputMap :: InputMap
outputFd :: Maybe Fd
termWidthMaps :: [(String, String)]
allowCustomUnicodeWidthTables :: Maybe Bool
colorMode :: Maybe ColorMode
mouseMode :: Config -> Maybe Bool
bracketedPasteMode :: Config -> Maybe Bool
debugLog :: Config -> Maybe String
outputFd :: Config -> Maybe Fd
termWidthMaps :: Config -> [(String, String)]
allowCustomUnicodeWidthTables :: Config -> Maybe Bool
colorMode :: Config -> Maybe ColorMode
.. } = do
Terminal
terminal <- String -> IO Terminal
Terminfo.setupTerm String
termName
let inputOverrides :: [(String, Event)]
inputOverrides = [(String
s,Event
e) | (Maybe String
t,String
s,Event
e) <- InputMap
inputMap, Maybe String
t Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String
forall a. Maybe a
Nothing Bool -> Bool -> Bool
|| Maybe String
t Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just String
termName]
activeInputMap :: [(String, Event)]
activeInputMap = String -> Terminal -> [(String, Event)]
classifyMapForTerm String
termName Terminal
terminal [(String, Event)] -> [(String, Event)] -> [(String, Event)]
forall a. Monoid a => a -> a -> a
`mappend` [(String, Event)]
inputOverrides
(IO ()
setAttrs, IO ()
unsetAttrs) <- Fd -> IO (IO (), IO ())
attributeControl Fd
termFd
IO ()
setAttrs
Input
input <- Config -> [(String, Event)] -> IO Input
initInput Config
config [(String, Event)]
activeInputMap
let pokeIO :: Handler
pokeIO = IO () -> Handler
Catch (IO () -> Handler) -> IO () -> Handler
forall a b. (a -> b) -> a -> b
$ do
IO ()
setAttrs
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan InternalEvent -> InternalEvent -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan (Input
inputInput
-> Getting (TChan InternalEvent) Input (TChan InternalEvent)
-> TChan InternalEvent
forall s a. s -> Getting a s a -> a
^.Getting (TChan InternalEvent) Input (TChan InternalEvent)
Lens' Input (TChan InternalEvent)
eventChannel) InternalEvent
ResumeAfterSignal
Handler
_ <- Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
windowChange Handler
pokeIO Maybe SignalSet
forall a. Maybe a
Nothing
Handler
_ <- Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
continueProcess Handler
pokeIO Maybe SignalSet
forall a. Maybe a
Nothing
let restore :: IO ()
restore = IO ()
unsetAttrs
Input -> IO Input
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Input -> IO Input) -> Input -> IO Input
forall a b. (a -> b) -> a -> b
$ Input
input
{ shutdownInput :: IO ()
shutdownInput = do
Input -> IO ()
shutdownInput Input
input
Handler
_ <- Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
windowChange Handler
Ignore Maybe SignalSet
forall a. Maybe a
Nothing
Handler
_ <- Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
continueProcess Handler
Ignore Maybe SignalSet
forall a. Maybe a
Nothing
IO ()
restore
, restoreInputState :: IO ()
restoreInputState = Input -> IO ()
restoreInputState Input
input IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
restore
}
inputForConfig Config
config = (Config -> Config -> Config
forall a. Semigroup a => a -> a -> a
<> Config
config) (Config -> Config) -> IO Config -> IO Config
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Config
standardIOConfig IO Config -> (Config -> IO Input) -> IO Input
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Config -> IO Input
inputForConfig
attributeControl :: Fd -> IO (IO (), IO ())
attributeControl :: Fd -> IO (IO (), IO ())
attributeControl Fd
fd = do
TerminalAttributes
original <- Fd -> IO TerminalAttributes
getTerminalAttributes Fd
fd
let vtyMode :: TerminalAttributes
vtyMode = (TerminalAttributes -> TerminalMode -> TerminalAttributes)
-> TerminalAttributes -> [TerminalMode] -> TerminalAttributes
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TerminalAttributes -> TerminalMode -> TerminalAttributes
withMode TerminalAttributes
clearedFlags [TerminalMode]
flagsToSet
clearedFlags :: TerminalAttributes
clearedFlags = (TerminalAttributes -> TerminalMode -> TerminalAttributes)
-> TerminalAttributes -> [TerminalMode] -> TerminalAttributes
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TerminalAttributes -> TerminalMode -> TerminalAttributes
withoutMode TerminalAttributes
original [TerminalMode]
flagsToUnset
flagsToSet :: [TerminalMode]
flagsToSet = [ TerminalMode
MapCRtoLF
]
flagsToUnset :: [TerminalMode]
flagsToUnset = [ TerminalMode
StartStopOutput
, TerminalMode
KeyboardInterrupts
, TerminalMode
EnableEcho
, TerminalMode
ProcessInput
, TerminalMode
ExtendedFunctions
]
let setAttrs :: IO ()
setAttrs = Fd -> TerminalAttributes -> TerminalState -> IO ()
setTerminalAttributes Fd
fd TerminalAttributes
vtyMode TerminalState
Immediately
unsetAttrs :: IO ()
unsetAttrs = Fd -> TerminalAttributes -> TerminalState -> IO ()
setTerminalAttributes Fd
fd TerminalAttributes
original TerminalState
Immediately
(IO (), IO ()) -> IO (IO (), IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO ()
setAttrs, IO ()
unsetAttrs)