{-# LANGUAGE CPP #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_HADDOCK hide #-}
module Graphics.Vty.Platform.Unix.Input.Loop
( initInput
)
where
import Graphics.Vty.Input
import Graphics.Vty.Platform.Unix.Settings
import Graphics.Vty.Platform.Unix.Input.Classify
import Graphics.Vty.Platform.Unix.Input.Classify.Types
import Control.Applicative
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception (mask, try, SomeException)
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString as BS
import Data.ByteString.Char8 (ByteString)
import Data.Word (Word8)
import Foreign (allocaArray)
import Foreign.C.Types (CInt(..))
import Foreign.Ptr (Ptr, castPtr)
import Lens.Micro hiding ((<>~))
import Lens.Micro.TH
import Lens.Micro.Mtl
import Control.Monad (when, mzero, forM_, forever)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans (lift)
import Control.Monad.Trans.State (StateT(..), evalStateT)
import Control.Monad.State.Class (MonadState, modify)
import Control.Monad.Trans.Reader (ReaderT(..), asks)
import System.Posix.IO (fdReadBuf, setFdOption, FdOption(..))
import System.Posix.Types (Fd(..))
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 -> Fd
_deviceFd :: Fd
, InputState -> Input
_originalInput :: Input
, 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 :: [Char] -> InputM ()
logMsg [Char]
msg = do
i <- Getting Input InputState Input
-> StateT InputState (ReaderT Input IO) Input
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Input InputState Input
Lens' InputState Input
originalInput
liftIO $ inputLogMsg i msg
loopInputProcessor :: InputM ()
loopInputProcessor :: InputM ()
loopInputProcessor = InputM () -> InputM ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (InputM () -> InputM ()) -> InputM () -> InputM ()
forall a b. (a -> b) -> a -> b
$ do
InputM ByteString
readFromDevice InputM ByteString -> (ByteString -> InputM ()) -> InputM ()
forall a b.
StateT InputState (ReaderT Input IO) a
-> (a -> StateT InputState (ReaderT Input IO) b)
-> StateT InputState (ReaderT Input IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> InputM ()
addBytesToProcess
validEvents <- StateT InputState (ReaderT Input IO) Event
-> StateT InputState (ReaderT Input IO) [Event]
forall a.
StateT InputState (ReaderT Input IO) a
-> StateT InputState (ReaderT Input IO) [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many StateT InputState (ReaderT Input IO) Event
parseEvent
forM_ validEvents emit
dropInvalid
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
[Char] -> InputM ()
logMsg ([Char] -> InputM ()) -> [Char] -> InputM ()
forall a b. (a -> b) -> a -> b
$ [Char]
"parsed event: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Event -> [Char]
forall a. Show a => a -> [Char]
show Event
event
(ReaderT Input IO (TChan InternalEvent)
-> StateT InputState (ReaderT Input IO) (TChan InternalEvent)
forall (m :: * -> *) a. Monad m => m a -> StateT InputState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT Input IO (TChan InternalEvent)
-> StateT InputState (ReaderT Input IO) (TChan InternalEvent))
-> ReaderT Input IO (TChan InternalEvent)
-> StateT InputState (ReaderT Input IO) (TChan InternalEvent)
forall a b. (a -> b) -> a -> b
$ (Input -> TChan InternalEvent)
-> ReaderT Input IO (TChan InternalEvent)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Input -> TChan InternalEvent
eventChannel) StateT InputState (ReaderT Input IO) (TChan InternalEvent)
-> (TChan InternalEvent -> InputM ()) -> InputM ()
forall a b.
StateT InputState (ReaderT Input IO) a
-> (a -> StateT InputState (ReaderT Input IO) b)
-> StateT InputState (ReaderT Input IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> InputM ()
forall a. IO a -> StateT InputState (ReaderT Input IO) a
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)
readFromDevice :: InputM ByteString
readFromDevice :: InputM ByteString
readFromDevice = do
fd <- Getting Fd InputState Fd -> StateT InputState (ReaderT Input IO) Fd
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Fd InputState Fd
Lens' InputState Fd
deviceFd
bufferPtr <- use $ inputBuffer.ptr
maxBytes <- use $ inputBuffer.size
stringRep <- liftIO $ do
threadWaitRead fd
bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)
if bytesRead > 0
then BS.packCStringLen (castPtr bufferPtr, fromIntegral bytesRead)
else return BS.empty
when (not $ BS.null stringRep) $
logMsg $ "input bytes: " ++ show (BS8.unpack stringRep)
return stringRep
parseEvent :: InputM Event
parseEvent :: StateT InputState (ReaderT Input IO) Event
parseEvent = do
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
s <- use classifierState
b <- use unprocessedBytes
case c s b of
Valid Event
e ByteString
remaining -> do
[Char] -> InputM ()
logMsg ([Char] -> InputM ()) -> [Char] -> InputM ()
forall a b. (a -> b) -> a -> b
$ [Char]
"valid parse: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Event -> [Char]
forall a. Show a => a -> [Char]
show Event
e
[Char] -> InputM ()
logMsg ([Char] -> InputM ()) -> [Char] -> InputM ()
forall a b. (a -> b) -> a -> b
$ [Char]
"remaining: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
forall a. Show a => a -> [Char]
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 a. a -> StateT InputState (ReaderT Input IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return Event
e
KClass
_ -> StateT InputState (ReaderT Input IO) Event
forall a. StateT InputState (ReaderT Input IO) a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
dropInvalid :: InputM ()
dropInvalid :: InputM ()
dropInvalid = do
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
s <- use classifierState
b <- use unprocessedBytes
case c s 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
[Char] -> InputM ()
logMsg [Char]
"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 a. a -> StateT InputState (ReaderT Input IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
runInputProcessorLoop :: ClassifyMap -> Input -> Fd -> IO ()
runInputProcessorLoop :: ClassifyMap -> Input -> Fd -> IO ()
runInputProcessorLoop ClassifyMap
classifyTable Input
input Fd
devFd = do
let bufferSize :: a
bufferSize = a
1024
Int -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
forall {a}. Num a => a
bufferSize ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Ptr Word8
bufferPtr :: Ptr Word8) -> do
let s0 :: InputState
s0 = ByteString
-> ClassifierState
-> Fd
-> Input
-> InputBuffer
-> (ClassifierState -> ByteString -> KClass)
-> InputState
InputState ByteString
BS8.empty ClassifierState
ClassifierStart
Fd
devFd Input
input
(Ptr Word8 -> Int -> InputBuffer
InputBuffer Ptr Word8
bufferPtr Int
forall {a}. Num a => a
bufferSize)
(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
initInput :: UnixSettings -> ClassifyMap -> IO Input
initInput :: UnixSettings -> ClassifyMap -> IO Input
initInput UnixSettings
settings ClassifyMap
classifyTable = do
let devFd :: Fd
devFd = UnixSettings -> Fd
settingInputFd UnixSettings
settings
theVmin :: Int
theVmin = UnixSettings -> Int
settingVmin UnixSettings
settings
theVtime :: Int
theVtime = UnixSettings -> Int
settingVtime UnixSettings
settings
Fd -> FdOption -> Bool -> IO ()
setFdOption Fd
devFd FdOption
NonBlockingRead Bool
False
Fd -> Int -> Int -> IO ()
setTermTiming Fd
devFd Int
theVmin (Int
theVtime Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100)
stopSync <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
input <- Input <$> atomically newTChan
<*> pure (return ())
<*> pure (return ())
<*> pure (const $ return ())
inputThread <- forkOSFinally (runInputProcessorLoop classifyTable input devFd)
(\Either SomeException ()
_ -> MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
stopSync ())
let killAndWait = do
ThreadId -> IO ()
killThread ThreadId
inputThread
MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
stopSync
return $ input { shutdownInput = killAndWait }
foreign import ccall "vty_set_term_timing" setTermTiming :: Fd -> Int -> Int -> IO ()
forkOSFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkOSFinally :: forall a. 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 a b. IO a -> (a -> IO b) -> IO b
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 <>= :: forall s (m :: * -> *) a.
(MonadState s m, Monoid a) =>
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 <>~ :: forall a s t. Monoid a => 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)