{-# LANGUAGE CPP #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_HADDOCK hide #-}
module Graphics.Vty.Platform.Windows.Input.Loop
( initInput
)
where
import Graphics.Vty.Input
import Graphics.Vty.Config (VtyUserConfig(..))
import Graphics.Vty.Platform.Windows.Input.Classify ( classify )
import Graphics.Vty.Platform.Windows.Input.Classify.Types
import Graphics.Vty.Platform.Windows.WindowsConsoleInput ( WinConsoleInputEvent )
import Graphics.Vty.Platform.Windows.WindowsInterfaces (readBuf)
import Control.Applicative ( Alternative(many) )
import Control.Concurrent
( ThreadId, forkOS, killThread, newEmptyMVar, putMVar, takeMVar )
import Control.Concurrent.STM ( atomically, writeTChan, newTChan )
import Control.Exception (mask, try, catch, SomeException)
import Lens.Micro ( over, ASetter, ASetter' )
import Lens.Micro.Mtl ( (.=), use )
import Control.Monad (unless, mzero, forM_)
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, ask)
import Lens.Micro.TH ( makeLenses )
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.Ptr (Ptr, castPtr)
import System.Environment (getEnv)
import System.IO ( Handle )
data InputBuffer = InputBuffer
{ InputBuffer -> Ptr Word8
_ptr :: Ptr Word8
, InputBuffer -> Ptr WinConsoleInputEvent
_inputRecordPtr :: Ptr WinConsoleInputEvent
, InputBuffer -> Int
_consoleEventBufferSize :: Int
}
makeLenses ''InputBuffer
data InputState = InputState
{ InputState -> ByteString
_unprocessedBytes :: ByteString
, InputState -> ClassifierState
_classifierState :: ClassifierState
, InputState -> Handle
_inputHandle :: Handle
, 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 <- 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
IO () -> InputM ()
forall a. IO a -> StateT InputState (ReaderT Input IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputM ()) -> IO () -> InputM ()
forall a b. (a -> b) -> a -> b
$ Input -> [Char] -> IO ()
inputLogMsg Input
i [Char]
msg
loopInputProcessor :: InputM ()
loopInputProcessor :: InputM ()
loopInputProcessor = 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
[Event]
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
[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
[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 ((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
Handle
handle <- Getting Handle InputState Handle
-> StateT InputState (ReaderT Input IO) Handle
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Handle InputState Handle
Lens' InputState Handle
inputHandle
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
Ptr WinConsoleInputEvent
winRecordPtr <- Getting
(Ptr WinConsoleInputEvent) InputState (Ptr WinConsoleInputEvent)
-> StateT InputState (ReaderT Input IO) (Ptr WinConsoleInputEvent)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Getting
(Ptr WinConsoleInputEvent) InputState (Ptr WinConsoleInputEvent)
-> StateT InputState (ReaderT Input IO) (Ptr WinConsoleInputEvent))
-> Getting
(Ptr WinConsoleInputEvent) InputState (Ptr WinConsoleInputEvent)
-> StateT InputState (ReaderT Input IO) (Ptr WinConsoleInputEvent)
forall a b. (a -> b) -> a -> b
$ (InputBuffer -> Const (Ptr WinConsoleInputEvent) InputBuffer)
-> InputState -> Const (Ptr WinConsoleInputEvent) InputState
Lens' InputState InputBuffer
inputBuffer((InputBuffer -> Const (Ptr WinConsoleInputEvent) InputBuffer)
-> InputState -> Const (Ptr WinConsoleInputEvent) InputState)
-> ((Ptr WinConsoleInputEvent
-> Const (Ptr WinConsoleInputEvent) (Ptr WinConsoleInputEvent))
-> InputBuffer -> Const (Ptr WinConsoleInputEvent) InputBuffer)
-> Getting
(Ptr WinConsoleInputEvent) InputState (Ptr WinConsoleInputEvent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Ptr WinConsoleInputEvent
-> Const (Ptr WinConsoleInputEvent) (Ptr WinConsoleInputEvent))
-> InputBuffer -> Const (Ptr WinConsoleInputEvent) InputBuffer
Lens' InputBuffer (Ptr WinConsoleInputEvent)
inputRecordPtr
Int
maxInputRecords <- 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
consoleEventBufferSize
Input
input <- ReaderT Input IO Input
-> StateT InputState (ReaderT Input IO) Input
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 Input
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
ByteString
stringRep <- IO ByteString -> InputM ByteString
forall a. IO a -> StateT InputState (ReaderT Input IO) a
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
Int
bytesRead <- TChan InternalEvent
-> Ptr WinConsoleInputEvent -> Handle -> Ptr Word8 -> Int -> IO Int
readBuf (Input -> TChan InternalEvent
eventChannel Input
input) Ptr WinConsoleInputEvent
winRecordPtr Handle
handle Ptr Word8
bufferPtr Int
maxInputRecords
if Int
bytesRead Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
then CStringLen -> IO ByteString
BS.packCStringLen (Ptr Word8 -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
bufferPtr, Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bytesRead)
else ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
BS.empty
Bool -> InputM () -> InputM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
BS.null ByteString
stringRep) (InputM () -> InputM ()) -> InputM () -> InputM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> InputM ()
logMsg ([Char] -> InputM ()) -> [Char] -> InputM ()
forall a b. (a -> b) -> a -> b
$ [Char]
"input bytes: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show (ByteString -> [Char]
BS8.unpack ByteString
stringRep)
ByteString -> InputM ByteString
forall a. a -> StateT InputState (ReaderT Input IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
stringRep
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
[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
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
[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 -> Handle -> IO ()
runInputProcessorLoop :: ClassifyMap -> Input -> Handle -> IO ()
runInputProcessorLoop ClassifyMap
classifyTable Input
input Handle
handle = do
let bufferSize :: a
bufferSize = a
1024
let maxKeyEvents :: a
maxKeyEvents = a
forall {a}. Num a => a
bufferSize a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
4
Int -> (Ptr WinConsoleInputEvent -> IO ()) -> IO ()
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
forall {a}. Integral a => a
maxKeyEvents ((Ptr WinConsoleInputEvent -> IO ()) -> IO ())
-> (Ptr WinConsoleInputEvent -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Ptr WinConsoleInputEvent
inputRecordBuf :: Ptr WinConsoleInputEvent) -> do
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
-> Handle
-> Input
-> InputBuffer
-> (ClassifierState -> ByteString -> KClass)
-> InputState
InputState ByteString
BS8.empty ClassifierState
ClassifierStart
Handle
handle
Input
input
(Ptr Word8 -> Ptr WinConsoleInputEvent -> Int -> InputBuffer
InputBuffer Ptr Word8
bufferPtr Ptr WinConsoleInputEvent
inputRecordBuf Int
forall {a}. Integral a => a
maxKeyEvents)
(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 :: VtyUserConfig -> Handle -> ClassifyMap -> IO Input
initInput :: VtyUserConfig -> Handle -> ClassifyMap -> IO Input
initInput VtyUserConfig
userConfig Handle
handle ClassifyMap
classifyTable = do
MVar ()
stopSync <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
Maybe [Char]
mDefaultLog <- IO (Maybe [Char])
-> (IOError -> IO (Maybe [Char])) -> IO (Maybe [Char])
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
(do [Char]
debugLog <- [Char] -> IO [Char]
getEnv [Char]
"VTY_DEBUG_LOG"
Maybe [Char] -> IO (Maybe [Char])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char] -> IO (Maybe [Char]))
-> Maybe [Char] -> IO (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
debugLog)
(\(IOError
_ :: IOError) -> Maybe [Char] -> IO (Maybe [Char])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Char]
forall a. Maybe a
Nothing)
Input
input <- TChan InternalEvent -> IO () -> IO () -> ([Char] -> IO ()) -> Input
Input (TChan InternalEvent
-> IO () -> IO () -> ([Char] -> IO ()) -> Input)
-> IO (TChan InternalEvent)
-> IO (IO () -> IO () -> ([Char] -> IO ()) -> 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 () -> ([Char] -> IO ()) -> Input)
-> IO (IO ()) -> IO (IO () -> ([Char] -> IO ()) -> Input)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO () -> IO (IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
IO (IO () -> ([Char] -> IO ()) -> Input)
-> IO (IO ()) -> IO (([Char] -> IO ()) -> Input)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO () -> IO (IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
IO (([Char] -> IO ()) -> Input) -> IO ([Char] -> IO ()) -> IO Input
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO ([Char] -> IO ())
-> ([Char] -> IO ([Char] -> IO ()))
-> Maybe [Char]
-> IO ([Char] -> IO ())
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (([Char] -> IO ()) -> IO ([Char] -> IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (([Char] -> IO ()) -> IO ([Char] -> IO ()))
-> ([Char] -> IO ()) -> IO ([Char] -> IO ())
forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> [Char] -> IO ()
append Maybe [Char]
mDefaultLog)
(([Char] -> IO ()) -> IO ([Char] -> IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (([Char] -> IO ()) -> IO ([Char] -> IO ()))
-> ([Char] -> [Char] -> IO ()) -> [Char] -> IO ([Char] -> IO ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> IO ()
appendFile)
(VtyUserConfig -> Maybe [Char]
configDebugLog VtyUserConfig
userConfig)
ThreadId
inputThread <- IO () -> (Either SomeException () -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkOSFinally (ClassifyMap -> Input -> Handle -> IO ()
runInputProcessorLoop ClassifyMap
classifyTable Input
input Handle
handle)
(\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 a. a -> IO a
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 }
where
append :: Maybe [Char] -> [Char] -> IO ()
append Maybe [Char]
mDebugLog [Char]
msg =
case Maybe [Char]
mDebugLog of
Just [Char]
debugLog -> [Char] -> [Char] -> IO ()
appendFile [Char]
debugLog ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
msg [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
Maybe [Char]
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
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)