{-# 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
Input
i <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' InputState Input
originalInput
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Input -> [Char] -> IO ()
inputLogMsg Input
i [Char]
msg
loopInputProcessor :: InputM ()
loopInputProcessor :: InputM ()
loopInputProcessor = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
InputM ByteString
readFromDevice forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> InputM ()
addBytesToProcess
[Event]
validEvents <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many InputM Event
parseEvent
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Event]
validEvents Event -> InputM ()
emit
InputM ()
dropInvalid
addBytesToProcess :: ByteString -> InputM ()
addBytesToProcess :: ByteString -> InputM ()
addBytesToProcess ByteString
block = Lens' InputState ByteString
unprocessedBytes 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 forall a b. (a -> b) -> a -> b
$ [Char]
"parsed event: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Event
event
(forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Input -> TChan InternalEvent
eventChannel) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. TChan a -> a -> STM ()
writeTChan (Event -> InternalEvent
InputEvent Event
event)
readFromDevice :: InputM ByteString
readFromDevice :: InputM ByteString
readFromDevice = do
Fd
fd <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' InputState Fd
deviceFd
Ptr Word8
bufferPtr <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' InputState InputBuffer
inputBufferforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' InputBuffer (Ptr Word8)
ptr
Int
maxBytes <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' InputState InputBuffer
inputBufferforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' InputBuffer Int
size
ByteString
stringRep <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Fd -> IO ()
threadWaitRead Fd
fd
ByteCount
bytesRead <- Fd -> Ptr Word8 -> ByteCount -> IO ByteCount
fdReadBuf Fd
fd Ptr Word8
bufferPtr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxBytes)
if ByteCount
bytesRead forall a. Ord a => a -> a -> Bool
> ByteCount
0
then CStringLen -> IO ByteString
BS.packCStringLen (forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
bufferPtr, forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteCount
bytesRead)
else forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
BS.empty
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ ByteString -> Bool
BS.null ByteString
stringRep) forall a b. (a -> b) -> a -> b
$
[Char] -> InputM ()
logMsg forall a b. (a -> b) -> a -> b
$ [Char]
"input bytes: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (ByteString -> [Char]
BS8.unpack ByteString
stringRep)
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
stringRep
parseEvent :: InputM Event
parseEvent :: InputM Event
parseEvent = do
ClassifierState -> ByteString -> KClass
c <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' InputState (ClassifierState -> ByteString -> KClass)
classifier
ClassifierState
s <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' InputState ClassifierState
classifierState
ByteString
b <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' InputState ByteString
unprocessedBytes
case ClassifierState -> ByteString -> KClass
c ClassifierState
s ByteString
b of
Valid Event
e ByteString
remaining -> do
[Char] -> InputM ()
logMsg forall a b. (a -> b) -> a -> b
$ [Char]
"valid parse: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Event
e
[Char] -> InputM ()
logMsg forall a b. (a -> b) -> a -> b
$ [Char]
"remaining: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ByteString
remaining
Lens' InputState ClassifierState
classifierState forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= ClassifierState
ClassifierStart
Lens' InputState ByteString
unprocessedBytes forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= ByteString
remaining
forall (m :: * -> *) a. Monad m => a -> m a
return Event
e
KClass
_ -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
dropInvalid :: InputM ()
dropInvalid :: InputM ()
dropInvalid = do
ClassifierState -> ByteString -> KClass
c <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' InputState (ClassifierState -> ByteString -> KClass)
classifier
ClassifierState
s <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' InputState ClassifierState
classifierState
ByteString
b <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' InputState ByteString
unprocessedBytes
case ClassifierState -> ByteString -> KClass
c ClassifierState
s ByteString
b of
KClass
Chunk -> do
Lens' InputState ClassifierState
classifierState 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
bforall a. a -> [a] -> [a]
:[ByteString]
bs)
Lens' InputState ByteString
unprocessedBytes 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"
Lens' InputState ClassifierState
classifierState forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= ClassifierState
ClassifierStart
Lens' InputState ByteString
unprocessedBytes forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= ByteString
BS8.empty
KClass
_ -> 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
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray forall {a}. Num a => a
bufferSize 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 forall {a}. Num a => a
bufferSize)
(ClassifyMap -> ClassifierState -> ByteString -> KClass
classify ClassifyMap
classifyTable)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (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 forall a. Integral a => a -> a -> a
`div` Int
100)
MVar ()
stopSync <- forall a. IO (MVar a)
newEmptyMVar
Input
input <- TChan InternalEvent -> IO () -> IO () -> ([Char] -> IO ()) -> Input
Input forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. STM a -> IO a
atomically forall a. STM (TChan a)
newTChan
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (m :: * -> *) a. Monad m => a -> m a
return ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (m :: * -> *) a. Monad m => a -> m a
return ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ())
ThreadId
inputThread <- forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkOSFinally (ClassifyMap -> Input -> Fd -> IO ()
runInputProcessorLoop ClassifyMap
classifyTable Input
input Fd
devFd)
(\Either SomeException ()
_ -> forall a. MVar a -> a -> IO ()
putMVar MVar ()
stopSync ())
let killAndWait :: IO ()
killAndWait = do
ThreadId -> IO ()
killThread ThreadId
inputThread
forall a. MVar a -> IO a
takeMVar MVar ()
stopSync
forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkOSFinally IO a
action Either SomeException a -> IO ()
and_then =
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> IO () -> IO ThreadId
forkOS forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try (forall a. IO a -> IO a
restore IO a
action) 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 = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (ASetter' s a
l 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 = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter s t a a
l (forall a. Monoid a => a -> a -> a
`mappend` a
n)