{-# LANGUAGE CPP #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_HADDOCK hide #-}

-- | The input layer forks a thread to read input data via the

--   Windows console API. Key presses, mouse events, and window

--   resize events are all obtained by calling ReadConsoleInputW.

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

-- 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 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)

-- 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
    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
    -- A key event could require 4 bytes of UTF-8.

    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)