    {-# LANGUAGE CPP #-}
    {-# LANGUAGE NoMonomorphismRestriction #-}
    {-# LANGUAGE RecordWildCards #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE TemplateHaskell #-}
    {-# OPTIONS_HADDOCK hide #-}
    -- | The input layer used to be a single function that correctly
    -- accounted for the non-threaded runtime by emulating the terminal
    -- VMIN adn VTIME handling. This has been removed and replace with a
    -- more straightforward parser. The non-threaded runtime is no longer
    -- supported.
    --
    -- This is an example of an algorithm where code coverage could be high,
    -- even 100%, but the behavior is still under tested. I should collect
    -- more of these examples...
    --
    -- reference: http://www.unixwiz.net/techtips/termios-vmin-vtime.html
    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

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

    -- The timing requirements are assured by the VMIN and VTIME set for the
    -- device.
    --
    -- 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
        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
            -- The killThread used in shutdownInput will not interrupt the
            -- foreign call fdReadBuf uses this provides a location to be
            -- interrupted prior to the foreign call. If there is input on
            -- the FD then the fdReadBuf will return in a finite amount of
            -- time due to the vtime terminal setting.
            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)