{-# LANGUAGE CPP #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_HADDOCK hide #-}
-- | 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 qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString as BS
import Data.ByteString.Char8 (ByteString)
import Data.IORef
import Data.Word (Word8)

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

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 InternalEvent
_eventChannel  :: TChan InternalEvent
      -- | 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 -> ByteString
_unprocessedBytes :: ByteString
    , InputState -> ClassifierState
_classifierState :: ClassifierState
    , InputState -> Config
_appliedConfig :: Config
    , InputState -> InputBuffer
_inputBuffer :: InputBuffer
    , InputState -> ClassifierState -> ByteString -> KClass
_classifier :: ClassifierState -> ByteString -> 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 ByteString
readFromDevice InputM ByteString -> (ByteString -> InputM ()) -> InputM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> 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 :: ByteString -> InputM ()
addBytesToProcess :: ByteString -> InputM ()
addBytesToProcess ByteString
block = (ByteString -> Identity ByteString)
-> InputState -> Identity InputState
Lens' InputState ByteString
unprocessedBytes ((ByteString -> Identity ByteString)
 -> InputState -> Identity InputState)
-> ByteString -> InputM ()
forall s (m :: * -> *) a.
(MonadState s m, Monoid a) =>
ASetter' s a -> a -> m ()
<>= ByteString
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 InternalEvent) Input (TChan InternalEvent)
-> StateT InputState (ReaderT Input IO) (TChan InternalEvent)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (TChan InternalEvent) Input (TChan InternalEvent)
Lens' Input (TChan InternalEvent)
eventChannel StateT InputState (ReaderT Input IO) (TChan InternalEvent)
-> (TChan InternalEvent -> 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 InternalEvent -> IO ())
-> TChan InternalEvent
-> InputM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ())
-> (TChan InternalEvent -> STM ()) -> TChan InternalEvent -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TChan InternalEvent -> InternalEvent -> STM ())
-> InternalEvent -> TChan InternalEvent -> STM ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip TChan InternalEvent -> InternalEvent -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan (Event -> InternalEvent
InputEvent 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 ByteString
readFromDevice :: InputM ByteString
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
    ByteString
stringRep <- IO ByteString -> InputM ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> InputM ByteString)
-> IO ByteString -> InputM ByteString
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 CStringLen -> IO ByteString
BS.packCStringLen (Ptr Word8 -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
bufferPtr, ByteCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteCount
bytesRead)
        else ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
BS.empty
    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
$ ByteString -> Bool
BS.null ByteString
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 (ByteString -> String
BS8.unpack ByteString
stringRep)
    ByteString -> InputM ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
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
    ClassifierState -> ByteString -> KClass
c <- Getting
  (ClassifierState -> ByteString -> KClass)
  InputState
  (ClassifierState -> ByteString -> KClass)
-> StateT
     InputState
     (ReaderT Input IO)
     (ClassifierState -> ByteString -> KClass)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
  (ClassifierState -> ByteString -> KClass)
  InputState
  (ClassifierState -> ByteString -> KClass)
Lens' InputState (ClassifierState -> ByteString -> KClass)
classifier
    ClassifierState
s <- Getting ClassifierState InputState ClassifierState
-> StateT InputState (ReaderT Input IO) ClassifierState
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ClassifierState InputState ClassifierState
Lens' InputState ClassifierState
classifierState
    ByteString
b <- Getting ByteString InputState ByteString -> InputM ByteString
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ByteString InputState ByteString
Lens' InputState ByteString
unprocessedBytes
    case ClassifierState -> ByteString -> KClass
c ClassifierState
s ByteString
b of
        Valid Event
e ByteString
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]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
remaining
            (ClassifierState -> Identity ClassifierState)
-> InputState -> Identity InputState
Lens' InputState ClassifierState
classifierState ((ClassifierState -> Identity ClassifierState)
 -> InputState -> Identity InputState)
-> ClassifierState -> InputM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= ClassifierState
ClassifierStart
            (ByteString -> Identity ByteString)
-> InputState -> Identity InputState
Lens' InputState ByteString
unprocessedBytes ((ByteString -> Identity ByteString)
 -> InputState -> Identity InputState)
-> ByteString -> InputM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= ByteString
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
    ClassifierState -> ByteString -> KClass
c <- Getting
  (ClassifierState -> ByteString -> KClass)
  InputState
  (ClassifierState -> ByteString -> KClass)
-> StateT
     InputState
     (ReaderT Input IO)
     (ClassifierState -> ByteString -> KClass)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
  (ClassifierState -> ByteString -> KClass)
  InputState
  (ClassifierState -> ByteString -> KClass)
Lens' InputState (ClassifierState -> ByteString -> KClass)
classifier
    ClassifierState
s <- Getting ClassifierState InputState ClassifierState
-> StateT InputState (ReaderT Input IO) ClassifierState
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ClassifierState InputState ClassifierState
Lens' InputState ClassifierState
classifierState
    ByteString
b <- Getting ByteString InputState ByteString -> InputM ByteString
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ByteString InputState ByteString
Lens' InputState ByteString
unprocessedBytes
    case ClassifierState -> ByteString -> KClass
c ClassifierState
s ByteString
b of
        KClass
Chunk -> do
            (ClassifierState -> Identity ClassifierState)
-> InputState -> Identity InputState
Lens' InputState ClassifierState
classifierState ((ClassifierState -> Identity ClassifierState)
 -> InputState -> Identity InputState)
-> ClassifierState -> InputM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.=
                case ClassifierState
s of
                  ClassifierState
ClassifierStart -> ByteString -> [ByteString] -> ClassifierState
ClassifierInChunk ByteString
b []
                  ClassifierInChunk ByteString
p [ByteString]
bs -> ByteString -> [ByteString] -> ClassifierState
ClassifierInChunk ByteString
p (ByteString
bByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
bs)
            (ByteString -> Identity ByteString)
-> InputState -> Identity InputState
Lens' InputState ByteString
unprocessedBytes ((ByteString -> Identity ByteString)
 -> InputState -> Identity InputState)
-> ByteString -> InputM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= ByteString
BS8.empty
        KClass
Invalid -> do
            String -> InputM ()
logMsg String
"dropping input bytes"
            (ClassifierState -> Identity ClassifierState)
-> InputState -> Identity InputState
Lens' InputState ClassifierState
classifierState ((ClassifierState -> Identity ClassifierState)
 -> InputState -> Identity InputState)
-> ClassifierState -> InputM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= ClassifierState
ClassifierStart
            (ByteString -> Identity ByteString)
-> InputState -> Identity InputState
Lens' InputState ByteString
unprocessedBytes ((ByteString -> Identity ByteString)
 -> InputState -> Identity InputState)
-> ByteString -> InputM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= ByteString
BS8.empty
        KClass
_ -> () -> InputM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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 <- ByteString
-> ClassifierState
-> Config
-> InputBuffer
-> (ClassifierState -> ByteString -> KClass)
-> InputState
InputState ByteString
BS8.empty ClassifierState
ClassifierStart
                (Config
 -> InputBuffer
 -> (ClassifierState -> ByteString -> KClass)
 -> InputState)
-> IO Config
-> IO
     (InputBuffer
      -> (ClassifierState -> ByteString -> 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
   -> (ClassifierState -> ByteString -> KClass) -> InputState)
-> IO InputBuffer
-> IO ((ClassifierState -> ByteString -> 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 ((ClassifierState -> ByteString -> KClass) -> InputState)
-> IO (ClassifierState -> ByteString -> KClass) -> IO InputState
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ClassifierState -> ByteString -> KClass)
-> IO (ClassifierState -> ByteString -> KClass)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClassifyMap -> ClassifierState -> ByteString -> 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 InternalEvent
-> IO () -> IO () -> IORef Config -> Maybe Handle -> Input
Input (TChan InternalEvent
 -> IO () -> IO () -> IORef Config -> Maybe Handle -> Input)
-> IO (TChan InternalEvent)
-> IO (IO () -> IO () -> IORef Config -> Maybe Handle -> Input)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (TChan InternalEvent) -> IO (TChan InternalEvent)
forall a. STM a -> IO a
atomically STM (TChan InternalEvent)
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)