{-# LANGUAGE CPP #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_HADDOCK hide #-}
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
{
Input -> TChan InternalEvent
_eventChannel :: TChan InternalEvent
, Input -> IO ()
shutdownInput :: IO ()
, Input -> IO ()
restoreInputState :: IO ()
, Input -> IORef Config
_configRef :: IORef Config
, 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 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Input (Maybe Handle)
inputDebug
case Maybe Handle
d of
Maybe Handle
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Handle
h -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
h String
msg forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
h
loopInputProcessor :: InputM ()
loopInputProcessor :: InputM ()
loopInputProcessor = 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
InputM ()
loopInputProcessor
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
String -> InputM ()
logMsg forall a b. (a -> b) -> a -> b
$ String
"parsed event: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Event
event
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' 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
Config
newConfig <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Input (IORef Config)
configRef 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. IORef a -> IO a
readIORef
Config
oldConfig <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' InputState Config
appliedConfig
let Just Fd
fd = Config -> Maybe Fd
inputFd Config
newConfig
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config
newConfig forall a. Eq a => a -> a -> Bool
/= Config
oldConfig) forall a b. (a -> b) -> a -> b
$ do
String -> InputM ()
logMsg forall a b. (a -> b) -> a -> b
$ String
"new config: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Config
newConfig
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Fd -> Config -> IO ()
applyConfig Fd
fd Config
newConfig
Lens' InputState Config
appliedConfig forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Config
newConfig
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
$
String -> InputM ()
logMsg forall a b. (a -> b) -> a -> b
$ String
"input bytes: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (ByteString -> String
BS8.unpack ByteString
stringRep)
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 forall a. Integral a => a -> a -> a
`div` Int
100)
applyConfig Fd
_ Config
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"(vty) applyConfig was not provided a complete configuration"
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
String -> InputM ()
logMsg forall a b. (a -> b) -> a -> b
$ String
"valid parse: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Event
e
String -> InputM ()
logMsg forall a b. (a -> b) -> a -> b
$ String
"remaining: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
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
String -> InputM ()
logMsg String
"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 -> IO ()
runInputProcessorLoop :: ClassifyMap -> Input -> IO ()
runInputProcessorLoop ClassifyMap
classifyTable Input
input = 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
InputState
s0 <- ByteString
-> ClassifierState
-> Config
-> InputBuffer
-> (ClassifierState -> ByteString -> KClass)
-> InputState
InputState ByteString
BS8.empty ClassifierState
ClassifierStart
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef (Input -> IORef Config
_configRef Input
input)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ptr Word8 -> Int -> InputBuffer
InputBuffer Ptr Word8
bufferPtr forall {a}. Num a => a
bufferSize)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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
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 = 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 = 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
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 -> 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 } <- forall a. IORef a -> IO a
readIORef forall a b. (a -> b) -> a -> b
$ Input -> IORef Config
_configRef Input
input
()
_ <- forall r. HPrintfType r => Handle -> String -> r
hPrintf Handle
h String
"initial (vmin,vtime): %s\n" (forall a. Show a => a -> String
show (Int
theVmin, Int
theVtime))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ClassifyMap
classifyTable forall a b. (a -> b) -> a -> b
$ \(String, Event)
i -> case (String, Event)
i of
(String
inBytes, EvKey Key
k [Modifier]
mods) -> forall r. HPrintfType r => Handle -> String -> r
hPrintf Handle
h String
"map %s %s %s %s\n" (forall a. Show a => a -> String
show String
theTerm)
(forall a. Show a => a -> String
show String
inBytes)
(forall a. Show a => a -> String
show Key
k)
(forall a. Show a => a -> String
show [Modifier]
mods)
(String, Event)
_ -> 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 <- forall a. IO (MVar a)
newEmptyMVar
Input
input <- TChan InternalEvent
-> IO () -> IO () -> IORef Config -> Maybe Handle -> 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 a. a -> IO (IORef a)
newIORef Config
config
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
(\String
f -> forall a. a -> Maybe a
Just 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 <- forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkOSFinally (ClassifyMap -> Input -> IO ()
runInputProcessorLoop ClassifyMap
classifyTable Input
input)
(\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)