{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
-- | The input layer used to be a single function that correctly
-- accounted for the non-threaded runtime by emulating the terminal
-- VMIN adn VTIME handling. This has been removed and replace with a
-- more straightforward parser. The non-threaded runtime is no longer
-- supported.
--
-- This is an example of an algorithm where code coverage could be high,
-- even 100%, but the behavior is still under tested. I should collect
-- more of these examples...
--
-- reference: http://www.unixwiz.net/techtips/termios-vmin-vtime.html
module Graphics.Vty.Input.Loop where

import Graphics.Vty.Config
import Graphics.Vty.Input.Classify
import Graphics.Vty.Input.Events

import Control.Applicative
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception (mask, try, SomeException)
import Lens.Micro hiding ((<>~))
import Lens.Micro.Mtl
import Lens.Micro.TH
import Control.Monad (when, mzero, forM_)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.State (StateT(..), evalStateT)
import Control.Monad.State.Class (MonadState, modify)
import Control.Monad.Trans.Reader (ReaderT(..))

import Data.Char
import Data.IORef
import Data.Word (Word8)

import Foreign ( allocaArray, peekArray, Ptr )
import Foreign.C.Types (CInt(..))

import System.IO
import System.Posix.IO (fdReadBuf, setFdOption, FdOption(..))
import System.Posix.Terminal
import System.Posix.Types (Fd(..))

import Text.Printf (hPrintf)

data Input = Input
    { -- | Channel of events direct from input processing. Unlike
      -- 'nextEvent' this will not refresh the display if the next event
      -- is an 'EvResize'.
      Input -> TChan Event
_eventChannel  :: TChan Event
      -- | Shuts down the input processing. As part of shutting down the
      -- input, this should also restore the input state.
    , Input -> IO ()
shutdownInput :: IO ()
      -- | Restore the terminal's input state to what it was prior
      -- to configuring input for Vty. This should be done as part of
      -- 'shutdownInput' but is exposed in case you need to access it
      -- directly.
    , Input -> IO ()
restoreInputState :: IO ()
      -- | Changes to this value are reflected after the next event.
    , Input -> IORef Config
_configRef :: IORef Config
      -- | input debug log
    , Input -> Maybe Handle
_inputDebug :: Maybe Handle
    }

makeLenses ''Input

data InputBuffer = InputBuffer
    { InputBuffer -> Ptr Word8
_ptr :: Ptr Word8
    , InputBuffer -> Int
_size :: Int
    }

makeLenses ''InputBuffer

data InputState = InputState
    { InputState -> String
_unprocessedBytes :: String
    , InputState -> Config
_appliedConfig :: Config
    , InputState -> InputBuffer
_inputBuffer :: InputBuffer
    , InputState -> String -> KClass
_classifier :: String -> KClass
    }

makeLenses ''InputState

type InputM a = StateT InputState (ReaderT Input IO) a

logMsg :: String -> InputM ()
logMsg :: String -> InputM ()
logMsg String
msg = do
    Maybe Handle
d <- Getting (Maybe Handle) Input (Maybe Handle)
-> StateT InputState (ReaderT Input IO) (Maybe Handle)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe Handle) Input (Maybe Handle)
Lens' Input (Maybe Handle)
inputDebug
    case Maybe Handle
d of
        Maybe Handle
Nothing -> () -> InputM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just Handle
h -> IO () -> InputM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputM ()) -> IO () -> InputM ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
h String
msg IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
h

-- this must be run on an OS thread dedicated to this input handling.
-- otherwise the terminal timing read behavior will block the execution
-- of the lightweight threads.
loopInputProcessor :: InputM ()
loopInputProcessor :: InputM ()
loopInputProcessor = do
    InputM String
readFromDevice InputM String -> (String -> InputM ()) -> InputM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> InputM ()
addBytesToProcess
    [Event]
validEvents <- StateT InputState (ReaderT Input IO) Event
-> StateT InputState (ReaderT Input IO) [Event]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many StateT InputState (ReaderT Input IO) Event
parseEvent
    [Event] -> (Event -> InputM ()) -> InputM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Event]
validEvents Event -> InputM ()
emit
    InputM ()
dropInvalid
    InputM ()
loopInputProcessor

addBytesToProcess :: String -> InputM ()
addBytesToProcess :: String -> InputM ()
addBytesToProcess String
block = (String -> Identity String) -> InputState -> Identity InputState
Lens' InputState String
unprocessedBytes ((String -> Identity String) -> InputState -> Identity InputState)
-> String -> InputM ()
forall s (m :: * -> *) a.
(MonadState s m, Monoid a) =>
ASetter' s a -> a -> m ()
<>= String
block

emit :: Event -> InputM ()
emit :: Event -> InputM ()
emit Event
event = do
    String -> InputM ()
logMsg (String -> InputM ()) -> String -> InputM ()
forall a b. (a -> b) -> a -> b
$ String
"parsed event: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Event -> String
forall a. Show a => a -> String
show Event
event
    Getting (TChan Event) Input (TChan Event)
-> StateT InputState (ReaderT Input IO) (TChan Event)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (TChan Event) Input (TChan Event)
Lens' Input (TChan Event)
eventChannel StateT InputState (ReaderT Input IO) (TChan Event)
-> (TChan Event -> InputM ()) -> InputM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> InputM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputM ())
-> (TChan Event -> IO ()) -> TChan Event -> InputM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ())
-> (TChan Event -> STM ()) -> TChan Event -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TChan Event -> Event -> STM ()) -> Event -> TChan Event -> STM ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip TChan Event -> Event -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan Event
event

-- The timing requirements are assured by the VMIN and VTIME set for the
-- device.
--
-- Precondition: Under the threaded runtime. Only current use is from a
-- forkOS thread. That case satisfies precondition.
readFromDevice :: InputM String
readFromDevice :: InputM String
readFromDevice = do
    Config
newConfig <- Getting (IORef Config) Input (IORef Config)
-> StateT InputState (ReaderT Input IO) (IORef Config)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (IORef Config) Input (IORef Config)
Lens' Input (IORef Config)
configRef StateT InputState (ReaderT Input IO) (IORef Config)
-> (IORef Config -> StateT InputState (ReaderT Input IO) Config)
-> StateT InputState (ReaderT Input IO) Config
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Config -> StateT InputState (ReaderT Input IO) Config
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Config -> StateT InputState (ReaderT Input IO) Config)
-> (IORef Config -> IO Config)
-> IORef Config
-> StateT InputState (ReaderT Input IO) Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef Config -> IO Config
forall a. IORef a -> IO a
readIORef
    Config
oldConfig <- Getting Config InputState Config
-> StateT InputState (ReaderT Input IO) Config
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Config InputState Config
Lens' InputState Config
appliedConfig
    let Just Fd
fd = Config -> Maybe Fd
inputFd Config
newConfig
    Bool -> InputM () -> InputM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config
newConfig Config -> Config -> Bool
forall a. Eq a => a -> a -> Bool
/= Config
oldConfig) (InputM () -> InputM ()) -> InputM () -> InputM ()
forall a b. (a -> b) -> a -> b
$ do
        String -> InputM ()
logMsg (String -> InputM ()) -> String -> InputM ()
forall a b. (a -> b) -> a -> b
$ String
"new config: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Config -> String
forall a. Show a => a -> String
show Config
newConfig
        IO () -> InputM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputM ()) -> IO () -> InputM ()
forall a b. (a -> b) -> a -> b
$ Fd -> Config -> IO ()
applyConfig Fd
fd Config
newConfig
        (Config -> Identity Config) -> InputState -> Identity InputState
Lens' InputState Config
appliedConfig ((Config -> Identity Config) -> InputState -> Identity InputState)
-> Config -> InputM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Config
newConfig
    Ptr Word8
bufferPtr <- Getting (Ptr Word8) InputState (Ptr Word8)
-> StateT InputState (ReaderT Input IO) (Ptr Word8)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Getting (Ptr Word8) InputState (Ptr Word8)
 -> StateT InputState (ReaderT Input IO) (Ptr Word8))
-> Getting (Ptr Word8) InputState (Ptr Word8)
-> StateT InputState (ReaderT Input IO) (Ptr Word8)
forall a b. (a -> b) -> a -> b
$ (InputBuffer -> Const (Ptr Word8) InputBuffer)
-> InputState -> Const (Ptr Word8) InputState
Lens' InputState InputBuffer
inputBuffer((InputBuffer -> Const (Ptr Word8) InputBuffer)
 -> InputState -> Const (Ptr Word8) InputState)
-> ((Ptr Word8 -> Const (Ptr Word8) (Ptr Word8))
    -> InputBuffer -> Const (Ptr Word8) InputBuffer)
-> Getting (Ptr Word8) InputState (Ptr Word8)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Ptr Word8 -> Const (Ptr Word8) (Ptr Word8))
-> InputBuffer -> Const (Ptr Word8) InputBuffer
Lens' InputBuffer (Ptr Word8)
ptr
    Int
maxBytes  <- Getting Int InputState Int
-> StateT InputState (ReaderT Input IO) Int
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Getting Int InputState Int
 -> StateT InputState (ReaderT Input IO) Int)
-> Getting Int InputState Int
-> StateT InputState (ReaderT Input IO) Int
forall a b. (a -> b) -> a -> b
$ (InputBuffer -> Const Int InputBuffer)
-> InputState -> Const Int InputState
Lens' InputState InputBuffer
inputBuffer((InputBuffer -> Const Int InputBuffer)
 -> InputState -> Const Int InputState)
-> ((Int -> Const Int Int) -> InputBuffer -> Const Int InputBuffer)
-> Getting Int InputState Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> Const Int Int) -> InputBuffer -> Const Int InputBuffer
Lens' InputBuffer Int
size
    String
stringRep <- IO String -> InputM String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> InputM String) -> IO String -> InputM String
forall a b. (a -> b) -> a -> b
$ do
        -- The killThread used in shutdownInput will not interrupt the
        -- foreign call fdReadBuf uses this provides a location to be
        -- interrupted prior to the foreign call. If there is input on
        -- the FD then the fdReadBuf will return in a finite amount of
        -- time due to the vtime terminal setting.
        Fd -> IO ()
threadWaitRead Fd
fd
        ByteCount
bytesRead <- Fd -> Ptr Word8 -> ByteCount -> IO ByteCount
fdReadBuf Fd
fd Ptr Word8
bufferPtr (Int -> ByteCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxBytes)
        if ByteCount
bytesRead ByteCount -> ByteCount -> Bool
forall a. Ord a => a -> a -> Bool
> ByteCount
0
        then (Word8 -> Char) -> [Word8] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) ([Word8] -> String) -> IO [Word8] -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Ptr Word8 -> IO [Word8]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray (ByteCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteCount
bytesRead) Ptr Word8
bufferPtr
        else String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Bool -> InputM () -> InputM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
stringRep) (InputM () -> InputM ()) -> InputM () -> InputM ()
forall a b. (a -> b) -> a -> b
$ String -> InputM ()
logMsg (String -> InputM ()) -> String -> InputM ()
forall a b. (a -> b) -> a -> b
$ String
"input bytes: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
stringRep
    String -> InputM String
forall (m :: * -> *) a. Monad m => a -> m a
return String
stringRep

applyConfig :: Fd -> Config -> IO ()
applyConfig :: Fd -> Config -> IO ()
applyConfig Fd
fd (Config{ vmin :: Config -> Maybe Int
vmin = Just Int
theVmin, vtime :: Config -> Maybe Int
vtime = Just Int
theVtime })
    = Fd -> Int -> Int -> IO ()
setTermTiming Fd
fd Int
theVmin (Int
theVtime Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100)
applyConfig Fd
_ Config
_ = String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"(vty) applyConfig was not provided a complete configuration"

parseEvent :: InputM Event
parseEvent :: StateT InputState (ReaderT Input IO) Event
parseEvent = do
    String -> KClass
c <- Getting (String -> KClass) InputState (String -> KClass)
-> StateT InputState (ReaderT Input IO) (String -> KClass)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (String -> KClass) InputState (String -> KClass)
Lens' InputState (String -> KClass)
classifier
    String
b <- Getting String InputState String -> InputM String
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting String InputState String
Lens' InputState String
unprocessedBytes
    case String -> KClass
c String
b of
        Valid Event
e String
remaining -> do
            String -> InputM ()
logMsg (String -> InputM ()) -> String -> InputM ()
forall a b. (a -> b) -> a -> b
$ String
"valid parse: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Event -> String
forall a. Show a => a -> String
show Event
e
            String -> InputM ()
logMsg (String -> InputM ()) -> String -> InputM ()
forall a b. (a -> b) -> a -> b
$ String
"remaining: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
remaining
            (String -> Identity String) -> InputState -> Identity InputState
Lens' InputState String
unprocessedBytes ((String -> Identity String) -> InputState -> Identity InputState)
-> String -> InputM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= String
remaining
            Event -> StateT InputState (ReaderT Input IO) Event
forall (m :: * -> *) a. Monad m => a -> m a
return Event
e
        KClass
_                   -> StateT InputState (ReaderT Input IO) Event
forall (m :: * -> *) a. MonadPlus m => m a
mzero

dropInvalid :: InputM ()
dropInvalid :: InputM ()
dropInvalid = do
    String -> KClass
c <- Getting (String -> KClass) InputState (String -> KClass)
-> StateT InputState (ReaderT Input IO) (String -> KClass)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (String -> KClass) InputState (String -> KClass)
Lens' InputState (String -> KClass)
classifier
    String
b <- Getting String InputState String -> InputM String
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting String InputState String
Lens' InputState String
unprocessedBytes
    Bool -> InputM () -> InputM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> KClass
c String
b KClass -> KClass -> Bool
forall a. Eq a => a -> a -> Bool
== KClass
Invalid) (InputM () -> InputM ()) -> InputM () -> InputM ()
forall a b. (a -> b) -> a -> b
$ do
        String -> InputM ()
logMsg String
"dropping input bytes"
        (String -> Identity String) -> InputState -> Identity InputState
Lens' InputState String
unprocessedBytes ((String -> Identity String) -> InputState -> Identity InputState)
-> String -> InputM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= []

runInputProcessorLoop :: ClassifyMap -> Input -> IO ()
runInputProcessorLoop :: ClassifyMap -> Input -> IO ()
runInputProcessorLoop ClassifyMap
classifyTable Input
input = do
    let bufferSize :: p
bufferSize = p
1024
    Int -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
forall p. Num p => p
bufferSize ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Ptr Word8
bufferPtr :: Ptr Word8) -> do
        InputState
s0 <- String -> Config -> InputBuffer -> (String -> KClass) -> InputState
InputState [] (Config -> InputBuffer -> (String -> KClass) -> InputState)
-> IO Config
-> IO (InputBuffer -> (String -> KClass) -> InputState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Config -> IO Config
forall a. IORef a -> IO a
readIORef (Input -> IORef Config
_configRef Input
input)
                            IO (InputBuffer -> (String -> KClass) -> InputState)
-> IO InputBuffer -> IO ((String -> KClass) -> InputState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> InputBuffer -> IO InputBuffer
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ptr Word8 -> Int -> InputBuffer
InputBuffer Ptr Word8
bufferPtr Int
forall p. Num p => p
bufferSize)
                            IO ((String -> KClass) -> InputState)
-> IO (String -> KClass) -> IO InputState
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> KClass) -> IO (String -> KClass)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClassifyMap -> String -> KClass
classify ClassifyMap
classifyTable)
        ReaderT Input IO () -> Input -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (InputM () -> InputState -> ReaderT Input IO ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT InputM ()
loopInputProcessor InputState
s0) Input
input

-- | Construct two IO actions: one to configure the terminal for Vty and
-- one to restore the terminal mode flags to the values they had at the
-- time this function was called.
--
-- This function constructs a configuration action to clear the
-- following terminal mode flags:
--
-- * IXON disabled: disables software flow control on outgoing data.
-- This stops the process from being suspended if the output terminal
-- cannot keep up.
--
-- * Raw mode is used for input.
--
-- * ISIG (enables keyboard combinations that result in
-- signals)
--
-- * ECHO (input is not echoed to the output)
--
-- * ICANON (canonical mode (line mode) input is not used)
--
-- * IEXTEN (extended functions are disabled)
--
-- The configuration action also explicitly sets these flags:
--
-- * ICRNL (input carriage returns are mapped to newlines)
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 (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 (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 -- ICRNL
                     ]
        flagsToUnset :: [TerminalMode]
flagsToUnset = [ TerminalMode
StartStopOutput -- IXON
                       , TerminalMode
KeyboardInterrupts -- ISIG
                       , TerminalMode
EnableEcho -- ECHO
                       , TerminalMode
ProcessInput -- ICANON
                       , TerminalMode
ExtendedFunctions -- IEXTEN
                       ]
    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 (m :: * -> *) a. Monad m => a -> m a
return (IO ()
setAttrs, IO ()
unsetAttrs)

logInitialInputState :: Input -> ClassifyMap -> IO()
logInitialInputState :: Input -> ClassifyMap -> IO ()
logInitialInputState Input
input ClassifyMap
classifyTable = case Input -> Maybe Handle
_inputDebug Input
input of
    Maybe Handle
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just Handle
h  -> do
        Config{ vmin :: Config -> Maybe Int
vmin = Just Int
theVmin
              , vtime :: Config -> Maybe Int
vtime = Just Int
theVtime
              , termName :: Config -> Maybe String
termName = Just String
theTerm } <- IORef Config -> IO Config
forall a. IORef a -> IO a
readIORef (IORef Config -> IO Config) -> IORef Config -> IO Config
forall a b. (a -> b) -> a -> b
$ Input -> IORef Config
_configRef Input
input
        ()
_ <- Handle -> String -> String -> IO ()
forall r. HPrintfType r => Handle -> String -> r
hPrintf Handle
h String
"initial (vmin,vtime): %s\n" ((Int, Int) -> String
forall a. Show a => a -> String
show (Int
theVmin, Int
theVtime))
        ClassifyMap -> ((String, Event) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ClassifyMap
classifyTable (((String, Event) -> IO ()) -> IO ())
-> ((String, Event) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(String, Event)
i -> case (String, Event)
i of
            (String
inBytes, EvKey Key
k [Modifier]
mods) -> Handle -> String -> String -> String -> String -> String -> IO ()
forall r. HPrintfType r => Handle -> String -> r
hPrintf Handle
h String
"map %s %s %s %s\n" (String -> String
forall a. Show a => a -> String
show String
theTerm)
                                                                     (String -> String
forall a. Show a => a -> String
show String
inBytes)
                                                                     (Key -> String
forall a. Show a => a -> String
show Key
k)
                                                                     ([Modifier] -> String
forall a. Show a => a -> String
show [Modifier]
mods)
            (String, Event)
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

initInput :: Config -> ClassifyMap -> IO Input
initInput :: Config -> ClassifyMap -> IO Input
initInput Config
config ClassifyMap
classifyTable = do
    let Just Fd
fd = Config -> Maybe Fd
inputFd Config
config
    Fd -> FdOption -> Bool -> IO ()
setFdOption Fd
fd FdOption
NonBlockingRead Bool
False
    Fd -> Config -> IO ()
applyConfig Fd
fd Config
config
    MVar ()
stopSync <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
    Input
input <- TChan Event
-> IO () -> IO () -> IORef Config -> Maybe Handle -> Input
Input (TChan Event
 -> IO () -> IO () -> IORef Config -> Maybe Handle -> Input)
-> IO (TChan Event)
-> IO (IO () -> IO () -> IORef Config -> Maybe Handle -> Input)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (TChan Event) -> IO (TChan Event)
forall a. STM a -> IO a
atomically STM (TChan Event)
forall a. STM (TChan a)
newTChan
                   IO (IO () -> IO () -> IORef Config -> Maybe Handle -> Input)
-> IO (IO ())
-> IO (IO () -> IORef Config -> Maybe Handle -> Input)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO () -> IO (IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                   IO (IO () -> IORef Config -> Maybe Handle -> Input)
-> IO (IO ()) -> IO (IORef Config -> Maybe Handle -> Input)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO () -> IO (IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                   IO (IORef Config -> Maybe Handle -> Input)
-> IO (IORef Config) -> IO (Maybe Handle -> Input)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Config -> IO (IORef Config)
forall a. a -> IO (IORef a)
newIORef Config
config
                   IO (Maybe Handle -> Input) -> IO (Maybe Handle) -> IO Input
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (Maybe Handle)
-> (String -> IO (Maybe Handle))
-> Maybe String
-> IO (Maybe Handle)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Handle -> IO (Maybe Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Handle
forall a. Maybe a
Nothing)
                             (\String
f -> Handle -> Maybe Handle
forall a. a -> Maybe a
Just (Handle -> Maybe Handle) -> IO Handle -> IO (Maybe Handle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IOMode -> IO Handle
openFile String
f IOMode
AppendMode)
                             (Config -> Maybe String
debugLog Config
config)
    Input -> ClassifyMap -> IO ()
logInitialInputState Input
input ClassifyMap
classifyTable
    ThreadId
inputThread <- IO () -> (Either SomeException () -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkOSFinally (ClassifyMap -> Input -> IO ()
runInputProcessorLoop ClassifyMap
classifyTable Input
input)
                                 (\Either SomeException ()
_ -> MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
stopSync ())
    let killAndWait :: IO ()
killAndWait = do
          ThreadId -> IO ()
killThread ThreadId
inputThread
          MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
stopSync
    Input -> IO Input
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 = IO ()
killAndWait }

foreign import ccall "vty_set_term_timing" setTermTiming :: Fd -> Int -> Int -> IO ()

forkOSFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkOSFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkOSFinally IO a
action Either SomeException a -> IO ()
and_then =
  ((forall a. IO a -> IO a) -> IO ThreadId) -> IO ThreadId
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO ThreadId) -> IO ThreadId)
-> ((forall a. IO a -> IO a) -> IO ThreadId) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> IO () -> IO ThreadId
forkOS (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO a -> IO a
forall a. IO a -> IO a
restore IO a
action) IO (Either SomeException a)
-> (Either SomeException a -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either SomeException a -> IO ()
and_then

(<>=) :: (MonadState s m, Monoid a) => ASetter' s a -> a -> m ()
ASetter' s a
l <>= :: ASetter' s a -> a -> m ()
<>= a
a = (s -> s) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (ASetter' s a
l ASetter' s a -> a -> s -> s
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ a
a)

(<>~) :: Monoid a => ASetter s t a a -> a -> s -> t
ASetter s t a a
l <>~ :: ASetter s t a a -> a -> s -> t
<>~ a
n = ASetter s t a a -> (a -> a) -> s -> t
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter s t a a
l (a -> a -> a
forall a. Monoid a => a -> a -> a
`mappend` a
n)