{-# 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
    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

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

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