{-# LINE 1 "platform/posix/src/System/Terminal/Platform.hsc" #-}
module System.Terminal.Platform
    ( withTerminal
    , LocalTerminal ()
    ) where

import           Control.Applicative
import           Control.Concurrent
import qualified Control.Concurrent.Async      as A
import           Control.Concurrent.STM.TVar
import           Control.Concurrent.STM.TMVar
import qualified Control.Exception             as E
import           Control.Monad                 (forM_, void, when)
import           Control.Monad.Catch hiding    (handle)
import           Control.Monad.IO.Class
import           Control.Monad.STM
import           Data.Bits
import qualified Data.ByteString               as BS
import qualified Data.ByteString.Char8         as BS8
import           Data.Maybe
import qualified Data.Text.IO                  as Text
import           Foreign.C.Types
import           Foreign.Marshal.Alloc
import           Foreign.Ptr
import           Foreign.Storable
import           System.Environment
import qualified System.IO                     as IO
import qualified GHC.Conc                      as Conc
import qualified Data.Dynamic                  as Dyn

import           System.Terminal.Terminal
import           System.Terminal.MonadInput
import           System.Terminal.MonadScreen hiding (getWindowSize)
import           System.Terminal.Decoder
import           System.Terminal.Encoder




data LocalTerminal
    = LocalTerminal
    { LocalTerminal -> ByteString
localType              :: BS.ByteString
    , LocalTerminal -> STM Event
localEvent             :: STM Event
    , LocalTerminal -> STM Interrupt
localInterrupt         :: STM Interrupt
    , LocalTerminal -> IO Position
localGetCursorPosition :: IO Position
    }

instance Terminal LocalTerminal where
    termType :: LocalTerminal -> ByteString
termType              = LocalTerminal -> ByteString
localType
    termEvent :: LocalTerminal -> STM Event
termEvent             = LocalTerminal -> STM Event
localEvent
    termInterrupt :: LocalTerminal -> STM Interrupt
termInterrupt         = LocalTerminal -> STM Interrupt
localInterrupt
    termCommand :: LocalTerminal -> Command -> IO ()
termCommand LocalTerminal
_ Command
c       = Handle -> Text -> IO ()
Text.hPutStr Handle
IO.stdout (Command -> Text
defaultEncode Command
c)
    termFlush :: LocalTerminal -> IO ()
termFlush LocalTerminal
_           = Handle -> IO ()
IO.hFlush Handle
IO.stdout
    termGetWindowSize :: LocalTerminal -> IO Size
termGetWindowSize LocalTerminal
_   = IO Size
getWindowSize
    termGetCursorPosition :: LocalTerminal -> IO Position
termGetCursorPosition = LocalTerminal -> IO Position
localGetCursorPosition

withTerminal :: (MonadIO m, MonadMask m) => (LocalTerminal -> m a) -> m a
withTerminal :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
(LocalTerminal -> m a) -> m a
withTerminal LocalTerminal -> m a
action = do
    term           <- String -> ByteString
BS8.pack (String -> ByteString)
-> (Maybe String -> String) -> Maybe String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"xterm" (Maybe String -> ByteString) -> m (Maybe String) -> m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe String) -> m (Maybe String)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO (Maybe String)
lookupEnv String
"TERM")
    mainThread     <- liftIO myThreadId
    interrupt      <- liftIO (newTVarIO False)
    windowChanged  <- liftIO (newTVarIO False)
    events         <- liftIO newEmptyTMVarIO
    cursorPosition <- liftIO newEmptyTMVarIO
    withTermiosSettings $ \Termios
termios->
        IO () -> m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
IO () -> m a -> m a
withInterruptHandler (ThreadId -> TVar Bool -> IO ()
handleInterrupt ThreadId
mainThread TVar Bool
interrupt) (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$
        IO () -> m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
IO () -> m a -> m a
withResizeHandler (TVar Bool -> IO ()
handleResize TVar Bool
windowChanged) (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$
        Termios -> TMVar Position -> TMVar Event -> m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Termios -> TMVar Position -> TMVar Event -> m a -> m a
withInputProcessing Termios
termios TMVar Position
cursorPosition TMVar Event
events (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ 
        LocalTerminal -> m a
action LocalTerminal
            { localType :: ByteString
localType = ByteString
term
            , localEvent :: STM Event
localEvent = do
                changed <- TVar Bool -> Bool -> STM Bool
forall a. TVar a -> a -> STM a
swapTVar TVar Bool
windowChanged Bool
False
                if changed
                  then pure (WindowEvent WindowSizeChanged)
                  else takeTMVar events
            , localInterrupt :: STM Interrupt
localInterrupt = TVar Bool -> Bool -> STM Bool
forall a. TVar a -> a -> STM a
swapTVar TVar Bool
interrupt Bool
False STM Bool -> (Bool -> STM ()) -> STM ()
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> STM ()
check STM () -> STM Interrupt -> STM Interrupt
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Interrupt -> STM Interrupt
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Interrupt
Interrupt
            , localGetCursorPosition :: IO Position
localGetCursorPosition = do
                -- Empty the result variable.
                STM () -> IO ()
forall a. STM a -> IO a
atomically (STM Position -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (TMVar Position -> STM Position
forall a. TMVar a -> STM a
takeTMVar TMVar Position
cursorPosition) STM () -> STM () -> STM ()
forall a. STM a -> STM a -> STM a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> () -> STM ()
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
                -- Send cursor position report request.
                Handle -> Text -> IO ()
Text.hPutStr Handle
IO.stdout (Command -> Text
defaultEncode Command
GetCursorPosition)
                Handle -> IO ()
IO.hFlush Handle
IO.stdout
                -- Wait for the result variable to be filled by the input processor.
                STM Position -> IO Position
forall a. STM a -> IO a
atomically (TMVar Position -> STM Position
forall a. TMVar a -> STM a
takeTMVar TMVar Position
cursorPosition)
            }
    where
        handleResize :: TVar Bool -> IO ()
        handleResize :: TVar Bool -> IO ()
handleResize TVar Bool
windowChanged =
            STM () -> IO ()
forall a. STM a -> IO a
atomically (TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
windowChanged Bool
True)
        -- This function is responsible for passing interrupt signals and
        -- eventually throwing an exception to the main thread in case it
        -- detects that the main thread is not serving its duty to process
        -- interrupt signals. It does this by setting a flag each time an interrupt
        -- occurs - if the flag is still set when a new interrupt occurs, it assumes
        -- the main thread is not responsive.
        handleInterrupt  :: ThreadId -> TVar Bool -> IO ()
        handleInterrupt :: ThreadId -> TVar Bool -> IO ()
handleInterrupt ThreadId
mainThread TVar Bool
interrupt = do
            unhandledInterrupt <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (TVar Bool -> Bool -> STM Bool
forall a. TVar a -> a -> STM a
swapTVar TVar Bool
interrupt Bool
True)
            when unhandledInterrupt (E.throwTo mainThread E.UserInterrupt)

specialChar :: Termios -> Modifiers -> Char -> Maybe Event
specialChar :: Termios -> Modifiers -> Char -> Maybe Event
specialChar Termios
t Modifiers
mods = \case
    Char
c | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Termios -> Char
termiosVERASE Termios
t -> Event -> Maybe Event
forall a. a -> Maybe a
Just (Event -> Maybe Event) -> Event -> Maybe Event
forall a b. (a -> b) -> a -> b
$ Key -> Modifiers -> Event
KeyEvent Key
BackspaceKey Modifiers
mods
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n'            -> Event -> Maybe Event
forall a. a -> Maybe a
Just (Event -> Maybe Event) -> Event -> Maybe Event
forall a b. (a -> b) -> a -> b
$ Key -> Modifiers -> Event
KeyEvent Key
EnterKey     Modifiers
mods
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t'            -> Event -> Maybe Event
forall a. a -> Maybe a
Just (Event -> Maybe Event) -> Event -> Maybe Event
forall a b. (a -> b) -> a -> b
$ Key -> Modifiers -> Event
KeyEvent Key
TabKey       Modifiers
mods
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\b'            -> Event -> Maybe Event
forall a. a -> Maybe a
Just (Event -> Maybe Event) -> Event -> Maybe Event
forall a b. (a -> b) -> a -> b
$ Key -> Modifiers -> Event
KeyEvent Key
DeleteKey    Modifiers
mods
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\SP'           -> Event -> Maybe Event
forall a. a -> Maybe a
Just (Event -> Maybe Event) -> Event -> Maybe Event
forall a b. (a -> b) -> a -> b
$ Key -> Modifiers -> Event
KeyEvent Key
SpaceKey     Modifiers
mods
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\DEL'          -> Event -> Maybe Event
forall a. a -> Maybe a
Just (Event -> Maybe Event) -> Event -> Maybe Event
forall a b. (a -> b) -> a -> b
$ Key -> Modifiers -> Event
KeyEvent Key
DeleteKey    Modifiers
mods
      | Bool
otherwise            -> Maybe Event
forall a. Maybe a
Nothing

withTermiosSettings :: (MonadIO m, MonadMask m) => (Termios -> m a) -> m a
withTermiosSettings :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
(Termios -> m a) -> m a
withTermiosSettings Termios -> m a
fma = m Termios -> (Termios -> m ()) -> (Termios -> m a) -> m a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket m Termios
before Termios -> m ()
after Termios -> m a
between
  where
    before :: m Termios
before  = IO Termios -> m Termios
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
      termios <- IO Termios
getTermios
      let termios' = Termios
termios { termiosICANON = False, termiosECHO = False }
      setTermios termios'
      pure termios
    after :: Termios -> m ()
after   = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Termios -> IO ()) -> Termios -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Termios -> IO ()
setTermios
    between :: Termios -> m a
between = Termios -> m a
fma

withResizeHandler :: (MonadIO m, MonadMask m) => IO () -> m a -> m a
withResizeHandler :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
IO () -> m a -> m a
withResizeHandler IO ()
handler = m (Maybe (HandlerFun, Dynamic), CInt)
-> ((Maybe (HandlerFun, Dynamic), CInt) -> m ())
-> ((Maybe (HandlerFun, Dynamic), CInt) -> m a)
-> m a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket m (Maybe (HandlerFun, Dynamic), CInt)
installHandler (Maybe (HandlerFun, Dynamic), CInt) -> m ()
forall {m :: * -> *}.
MonadIO m =>
(Maybe (HandlerFun, Dynamic), CInt) -> m ()
restoreHandler (((Maybe (HandlerFun, Dynamic), CInt) -> m a) -> m a)
-> (m a -> (Maybe (HandlerFun, Dynamic), CInt) -> m a)
-> m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> (Maybe (HandlerFun, Dynamic), CInt) -> m a
forall a b. a -> b -> a
const
  where
    installHandler :: m (Maybe (HandlerFun, Dynamic), CInt)
installHandler = IO (Maybe (HandlerFun, Dynamic), CInt)
-> m (Maybe (HandlerFun, Dynamic), CInt)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
      IO ()
Conc.ensureIOManagerIsRunning
      oldHandler <- CInt
-> Maybe (HandlerFun, Dynamic) -> IO (Maybe (HandlerFun, Dynamic))
Conc.setHandler (CInt
28) ((HandlerFun, Dynamic) -> Maybe (HandlerFun, Dynamic)
forall a. a -> Maybe a
Just (IO () -> HandlerFun
forall a b. a -> b -> a
const IO ()
handler, IO () -> Dynamic
forall a. Typeable a => a -> Dynamic
Dyn.toDyn IO ()
handler))
{-# LINE 127 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      oldAction  <- stg_sig_install (28) (-4) nullPtr
{-# LINE 128 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      pure (oldHandler,oldAction)
    restoreHandler :: (Maybe (HandlerFun, Dynamic), CInt) -> m ()
restoreHandler (Maybe (HandlerFun, Dynamic)
oldHandler,CInt
oldAction) = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
      IO (Maybe (HandlerFun, Dynamic)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (HandlerFun, Dynamic)) -> IO ())
-> IO (Maybe (HandlerFun, Dynamic)) -> IO ()
forall a b. (a -> b) -> a -> b
$ CInt
-> Maybe (HandlerFun, Dynamic) -> IO (Maybe (HandlerFun, Dynamic))
Conc.setHandler (CInt
28) Maybe (HandlerFun, Dynamic)
oldHandler
{-# LINE 131 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      void $ stg_sig_install (28) oldAction nullPtr
{-# LINE 132 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      pure ()

withInterruptHandler :: (MonadIO m, MonadMask m) => IO () -> m a -> m a
withInterruptHandler :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
IO () -> m a -> m a
withInterruptHandler IO ()
handler = m (Maybe (HandlerFun, Dynamic), CInt)
-> ((Maybe (HandlerFun, Dynamic), CInt) -> m ())
-> ((Maybe (HandlerFun, Dynamic), CInt) -> m a)
-> m a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket m (Maybe (HandlerFun, Dynamic), CInt)
installHandler (Maybe (HandlerFun, Dynamic), CInt) -> m ()
forall {m :: * -> *}.
MonadIO m =>
(Maybe (HandlerFun, Dynamic), CInt) -> m ()
restoreHandler (((Maybe (HandlerFun, Dynamic), CInt) -> m a) -> m a)
-> (m a -> (Maybe (HandlerFun, Dynamic), CInt) -> m a)
-> m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> (Maybe (HandlerFun, Dynamic), CInt) -> m a
forall a b. a -> b -> a
const
  where
    installHandler :: m (Maybe (HandlerFun, Dynamic), CInt)
installHandler = IO (Maybe (HandlerFun, Dynamic), CInt)
-> m (Maybe (HandlerFun, Dynamic), CInt)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
      IO ()
Conc.ensureIOManagerIsRunning
      oldHandler <- CInt
-> Maybe (HandlerFun, Dynamic) -> IO (Maybe (HandlerFun, Dynamic))
Conc.setHandler (CInt
2) ((HandlerFun, Dynamic) -> Maybe (HandlerFun, Dynamic)
forall a. a -> Maybe a
Just (IO () -> HandlerFun
forall a b. a -> b -> a
const IO ()
handler, IO () -> Dynamic
forall a. Typeable a => a -> Dynamic
Dyn.toDyn IO ()
handler))
{-# LINE 140 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      oldAction  <- stg_sig_install (2) (-4) nullPtr
{-# LINE 141 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      pure (oldHandler,oldAction)
    restoreHandler :: (Maybe (HandlerFun, Dynamic), CInt) -> m ()
restoreHandler (Maybe (HandlerFun, Dynamic)
oldHandler,CInt
oldAction) = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
      IO (Maybe (HandlerFun, Dynamic)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (HandlerFun, Dynamic)) -> IO ())
-> IO (Maybe (HandlerFun, Dynamic)) -> IO ()
forall a b. (a -> b) -> a -> b
$ CInt
-> Maybe (HandlerFun, Dynamic) -> IO (Maybe (HandlerFun, Dynamic))
Conc.setHandler (CInt
2) Maybe (HandlerFun, Dynamic)
oldHandler
{-# LINE 144 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      void $ stg_sig_install (2) oldAction nullPtr
{-# LINE 145 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      pure ()

withInputProcessing :: (MonadIO m, MonadMask m) =>
    Termios -> TMVar Position -> TMVar Event -> m a -> m a
withInputProcessing :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Termios -> TMVar Position -> TMVar Event -> m a -> m a
withInputProcessing Termios
termios TMVar Position
cursorPosition TMVar Event
events =
    m (Async ()) -> (Async () -> m ()) -> (Async () -> m a) -> m a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (IO (Async ()) -> m (Async ())
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async ()) -> m (Async ())) -> IO (Async ()) -> m (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
A.async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ Decoder -> IO ()
run Decoder
decoder) (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Async () -> IO ()) -> Async () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Async () -> IO ()
forall a. Async a -> IO ()
A.cancel) ((Async () -> m a) -> m a)
-> (m a -> Async () -> m a) -> m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> Async () -> m a
forall a b. a -> b -> a
const
    where
        run :: Decoder -> IO ()
        run :: Decoder -> IO ()
run Decoder
d = do
            c <- Handle -> IO Char
IO.hGetChar Handle
IO.stdin
            case feedDecoder d mempty c of
              -- The decoder is not in final state.
              -- There are sequences depending on timing (escape either is literal
              -- escape or the beginning of a sequence).
              -- This block evaluates whether more input is available within
              -- a limited timespan. If this is the case it just recurses 
              -- with the decoder continuation.
              -- Otherwise, a NUL character is fed in order to tell the decoder
              -- that there is no more input belonging to the sequence.
              Left Decoder
d' -> Handle -> Int -> IO Bool
IO.hWaitForInput Handle
IO.stdin Int
timeoutMilliseconds IO Bool -> (Bool -> 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
>>= \case
                  Bool
True  -> Decoder -> IO ()
run Decoder
d'
                  Bool
False -> case Decoder -> Modifiers -> Char -> Either Decoder [Event]
feedDecoder Decoder
d' Modifiers
forall a. Monoid a => a
mempty Char
'\NUL' of
                      Left Decoder
d'' -> Decoder -> IO ()
run Decoder
d''
                      Right [Event]
evs -> do
                          [Event] -> (Event -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Event]
evs Event -> IO ()
writeEvent
                          Decoder -> IO ()
run Decoder
decoder
              -- The decoder reached a final state.
              -- All recognized events are appended to the event stream.
              Right [Event]
evs -> do
                  [Event] -> (Event -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Event]
evs Event -> IO ()
writeEvent
                  Decoder -> IO ()
run Decoder
decoder

        decoder :: Decoder
        decoder :: Decoder
decoder = (Modifiers -> Char -> Maybe Event) -> Decoder
defaultDecoder (Termios -> Modifiers -> Char -> Maybe Event
specialChar Termios
termios)

        -- Adds events to the event stream and catches certain events
        -- that require special treatment.
        writeEvent :: Event -> IO ()
        writeEvent :: Event -> IO ()
writeEvent = \case
            ev :: Event
ev@(DeviceEvent (CursorPositionReport Position
pos)) -> STM () -> IO ()
forall a. STM a -> IO a
atomically do
                -- One of the alternatives will succeed.
                -- The second one is not strictly required but a fail safe in order
                -- to never block in case the terminal sends a report without request.
                TMVar Position -> Position -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar Position
cursorPosition Position
pos STM () -> STM () -> STM ()
forall a. STM a -> STM a -> STM a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> STM Position -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (TMVar Position -> Position -> STM Position
forall a. TMVar a -> a -> STM a
swapTMVar TMVar Position
cursorPosition Position
pos)
                TMVar Event -> Event -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar Event
events Event
ev
            Event
ev -> STM () -> IO ()
forall a. STM a -> IO a
atomically (TMVar Event -> Event -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar Event
events Event
ev)

        -- The timeout duration has been choosen as a tradeoff between correctness
        -- (actual transmission or scheduling delays shall not be misinterpreted) and
        -- responsiveness for a human user (50 ms are barely noticable, but 1000 ms are).
        -- I.e. when the user presses the ESC key (as vim users sometimes do ;-)
        -- it shall be reflected in the application behavior quite instantly and
        -- certainly _before_ the user presses the next key (thereby assuming that the
        -- user is not able to type more than 20 characters per second).
        -- For escape sequences it shall also be taken into consideration that they are
        -- usually transmitted and received as chunks. Only on very rare occasions (buffer
        -- boundaries) it might happen that they are split right after the sequence
        -- introducer. In a modern environment with virtual terminals there is good
        -- reason to consider this more unlikely than a user that types so fast
        -- that his input might be misinterpreted as an escape sequence.
        timeoutMilliseconds :: Int
        timeoutMilliseconds :: Int
timeoutMilliseconds  = Int
50

getWindowSize :: IO Size
getWindowSize :: IO Size
getWindowSize =
  (Ptr Winsize -> IO Size) -> IO Size
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr Winsize -> IO Size) -> IO Size)
-> (Ptr Winsize -> IO Size) -> IO Size
forall a b. (a -> b) -> a -> b
$ \Ptr Winsize
ptr->
    CInt -> CInt -> Ptr Winsize -> IO CInt
forall a. CInt -> CInt -> Ptr a -> IO CInt
unsafeIOCtl CInt
0 (CInt
21523) Ptr Winsize
ptr IO CInt -> (CInt -> IO Size) -> IO Size
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
{-# LINE 212 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      0 -> peek ptr >>= \ws-> pure $ Size (fromIntegral $ wsRow ws) (fromIntegral $ wsCol ws)
      _ -> undefined

getTermios :: IO Termios
getTermios :: IO Termios
getTermios = 
  (Ptr Termios -> IO Termios) -> IO Termios
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr Termios -> IO Termios) -> IO Termios)
-> (Ptr Termios -> IO Termios) -> IO Termios
forall a b. (a -> b) -> a -> b
$ \Ptr Termios
ptr->
    CInt -> Ptr Termios -> IO CInt
unsafeGetTermios CInt
0 Ptr Termios
ptr IO CInt -> (CInt -> IO Termios) -> IO Termios
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      CInt
0 -> Ptr Termios -> IO Termios
forall a. Storable a => Ptr a -> IO a
peek Ptr Termios
ptr
      CInt
_ -> IO Termios
forall a. HasCallStack => a
undefined

setTermios :: Termios -> IO ()
setTermios :: Termios -> IO ()
setTermios Termios
t =
  (Ptr Termios -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr Termios -> IO ()) -> IO ())
-> (Ptr Termios -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Termios
ptr->
    CInt -> Ptr Termios -> IO CInt
unsafeGetTermios CInt
0 Ptr Termios
ptr IO CInt -> (CInt -> 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
>>= \case
      CInt
0 -> do 
        Ptr Termios -> Termios -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Termios
ptr Termios
t
        CInt -> CInt -> Ptr Termios -> IO CInt
unsafeSetTermios CInt
0 (CInt
0) Ptr Termios
ptr IO CInt -> (CInt -> 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
>>= \case
{-# LINE 229 "platform/posix/src/System/Terminal/Platform.hsc" #-}
          CInt
0 -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          CInt
_ -> IO ()
forall a. HasCallStack => a
undefined
      CInt
_ -> IO ()
forall a. HasCallStack => a
undefined

data Winsize
  = Winsize
  { Winsize -> CUShort
wsRow :: !CUShort
  , Winsize -> CUShort
wsCol :: !CUShort
  } deriving (Winsize -> Winsize -> Bool
(Winsize -> Winsize -> Bool)
-> (Winsize -> Winsize -> Bool) -> Eq Winsize
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Winsize -> Winsize -> Bool
== :: Winsize -> Winsize -> Bool
$c/= :: Winsize -> Winsize -> Bool
/= :: Winsize -> Winsize -> Bool
Eq, Eq Winsize
Eq Winsize =>
(Winsize -> Winsize -> Ordering)
-> (Winsize -> Winsize -> Bool)
-> (Winsize -> Winsize -> Bool)
-> (Winsize -> Winsize -> Bool)
-> (Winsize -> Winsize -> Bool)
-> (Winsize -> Winsize -> Winsize)
-> (Winsize -> Winsize -> Winsize)
-> Ord Winsize
Winsize -> Winsize -> Bool
Winsize -> Winsize -> Ordering
Winsize -> Winsize -> Winsize
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Winsize -> Winsize -> Ordering
compare :: Winsize -> Winsize -> Ordering
$c< :: Winsize -> Winsize -> Bool
< :: Winsize -> Winsize -> Bool
$c<= :: Winsize -> Winsize -> Bool
<= :: Winsize -> Winsize -> Bool
$c> :: Winsize -> Winsize -> Bool
> :: Winsize -> Winsize -> Bool
$c>= :: Winsize -> Winsize -> Bool
>= :: Winsize -> Winsize -> Bool
$cmax :: Winsize -> Winsize -> Winsize
max :: Winsize -> Winsize -> Winsize
$cmin :: Winsize -> Winsize -> Winsize
min :: Winsize -> Winsize -> Winsize
Ord, Int -> Winsize -> String -> String
[Winsize] -> String -> String
Winsize -> String
(Int -> Winsize -> String -> String)
-> (Winsize -> String)
-> ([Winsize] -> String -> String)
-> Show Winsize
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Winsize -> String -> String
showsPrec :: Int -> Winsize -> String -> String
$cshow :: Winsize -> String
show :: Winsize -> String
$cshowList :: [Winsize] -> String -> String
showList :: [Winsize] -> String -> String
Show)

data Termios
  = Termios
  { Termios -> Char
termiosVEOF   :: !Char
  , Termios -> Char
termiosVERASE :: !Char
  , Termios -> Char
termiosVINTR  :: !Char
  , Termios -> Char
termiosVKILL  :: !Char
  , Termios -> Char
termiosVQUIT  :: !Char
  , Termios -> Bool
termiosISIG   :: !Bool
  , Termios -> Bool
termiosICANON :: !Bool
  , Termios -> Bool
termiosECHO   :: !Bool
  } deriving (Termios -> Termios -> Bool
(Termios -> Termios -> Bool)
-> (Termios -> Termios -> Bool) -> Eq Termios
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Termios -> Termios -> Bool
== :: Termios -> Termios -> Bool
$c/= :: Termios -> Termios -> Bool
/= :: Termios -> Termios -> Bool
Eq, Eq Termios
Eq Termios =>
(Termios -> Termios -> Ordering)
-> (Termios -> Termios -> Bool)
-> (Termios -> Termios -> Bool)
-> (Termios -> Termios -> Bool)
-> (Termios -> Termios -> Bool)
-> (Termios -> Termios -> Termios)
-> (Termios -> Termios -> Termios)
-> Ord Termios
Termios -> Termios -> Bool
Termios -> Termios -> Ordering
Termios -> Termios -> Termios
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Termios -> Termios -> Ordering
compare :: Termios -> Termios -> Ordering
$c< :: Termios -> Termios -> Bool
< :: Termios -> Termios -> Bool
$c<= :: Termios -> Termios -> Bool
<= :: Termios -> Termios -> Bool
$c> :: Termios -> Termios -> Bool
> :: Termios -> Termios -> Bool
$c>= :: Termios -> Termios -> Bool
>= :: Termios -> Termios -> Bool
$cmax :: Termios -> Termios -> Termios
max :: Termios -> Termios -> Termios
$cmin :: Termios -> Termios -> Termios
min :: Termios -> Termios -> Termios
Ord, Int -> Termios -> String -> String
[Termios] -> String -> String
Termios -> String
(Int -> Termios -> String -> String)
-> (Termios -> String)
-> ([Termios] -> String -> String)
-> Show Termios
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Termios -> String -> String
showsPrec :: Int -> Termios -> String -> String
$cshow :: Termios -> String
show :: Termios -> String
$cshowList :: [Termios] -> String -> String
showList :: [Termios] -> String -> String
Show)

instance Storable Winsize where
  sizeOf :: Winsize -> Int
sizeOf    Winsize
_ = ((Int
8))
{-# LINE 253 "platform/posix/src/System/Terminal/Platform.hsc" #-}
  alignment _ = (2)
{-# LINE 254 "platform/posix/src/System/Terminal/Platform.hsc" #-}
  peek ptr    = Winsize
    <$> ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr
{-# LINE 256 "platform/posix/src/System/Terminal/Platform.hsc" #-}
    <*> ((\hsc_ptr -> peekByteOff hsc_ptr 2)) ptr
{-# LINE 257 "platform/posix/src/System/Terminal/Platform.hsc" #-}
  poke ptr ws = do
    ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr (wsRow ws)
{-# LINE 259 "platform/posix/src/System/Terminal/Platform.hsc" #-}
    ((\hsc_ptr -> pokeByteOff hsc_ptr 2)) ptr (wsCol ws)
{-# LINE 260 "platform/posix/src/System/Terminal/Platform.hsc" #-}

instance Storable Termios where
  sizeOf :: Termios -> Int
sizeOf    Termios
_ = ((Int
60))
{-# LINE 263 "platform/posix/src/System/Terminal/Platform.hsc" #-}
  alignment _ = (4)
{-# LINE 264 "platform/posix/src/System/Terminal/Platform.hsc" #-}
  peek ptr    = do
    lflag <- peekLFlag
    Termios
      <$> (toEnum . fromIntegral <$> peekVEOF)
      <*> (toEnum . fromIntegral <$> peekVERASE)
      <*> (toEnum . fromIntegral <$> peekVINTR)
      <*> (toEnum . fromIntegral <$> peekVKILL)
      <*> (toEnum . fromIntegral <$> peekVQUIT)
      <*> pure (lflag .&. (1)   /= 0)
{-# LINE 273 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      <*> pure (lflag .&. (2) /= 0)
{-# LINE 274 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      <*> pure (lflag .&. (8)   /= 0)
{-# LINE 275 "platform/posix/src/System/Terminal/Platform.hsc" #-}
    where
      peekVEOF       = ((\hsc_ptr -> peekByteOff hsc_ptr 21))   ptr :: IO CUChar
{-# LINE 277 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      peekVERASE     = ((\hsc_ptr -> peekByteOff hsc_ptr 19)) ptr :: IO CUChar
{-# LINE 278 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      peekVINTR      = ((\hsc_ptr -> peekByteOff hsc_ptr 17))  ptr :: IO CUChar
{-# LINE 279 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      peekVKILL      = ((\hsc_ptr -> peekByteOff hsc_ptr 20))  ptr :: IO CUChar
{-# LINE 280 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      peekVQUIT      = ((\hsc_ptr -> peekByteOff hsc_ptr 18))  ptr :: IO CUChar
{-# LINE 281 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      peekLFlag      = ((\hsc_ptr -> peekByteOff hsc_ptr 12))      ptr :: IO CUInt 
{-# LINE 282 "platform/posix/src/System/Terminal/Platform.hsc" #-}
  poke ptr termios = do
    pokeVEOF   $ fromIntegral $ fromEnum $ termiosVEOF   termios
    pokeVERASE $ fromIntegral $ fromEnum $ termiosVERASE termios
    pokeVINTR  $ fromIntegral $ fromEnum $ termiosVINTR  termios
    pokeVKILL  $ fromIntegral $ fromEnum $ termiosVKILL  termios
    pokeVQUIT  $ fromIntegral $ fromEnum $ termiosVQUIT  termios
    peekLFlag >>= \flag-> pokeLFlag (if termiosISIG   termios then flag .|. (1)   else flag .&. complement (1))
{-# LINE 289 "platform/posix/src/System/Terminal/Platform.hsc" #-}
    peekLFlag >>= \flag-> pokeLFlag (if termiosICANON termios then flag .|. (2) else flag .&. complement (2))
{-# LINE 290 "platform/posix/src/System/Terminal/Platform.hsc" #-}
    peekLFlag >>= \flag-> pokeLFlag (if termiosECHO   termios then flag .|. (8)   else flag .&. complement (8))
{-# LINE 291 "platform/posix/src/System/Terminal/Platform.hsc" #-}
    where
      pokeVEOF       = ((\hsc_ptr -> pokeByteOff hsc_ptr 21))   ptr :: CUChar -> IO ()
{-# LINE 293 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      pokeVERASE     = ((\hsc_ptr -> pokeByteOff hsc_ptr 19)) ptr :: CUChar -> IO ()
{-# LINE 294 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      pokeVINTR      = ((\hsc_ptr -> pokeByteOff hsc_ptr 17))  ptr :: CUChar -> IO ()
{-# LINE 295 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      pokeVKILL      = ((\hsc_ptr -> pokeByteOff hsc_ptr 20))  ptr :: CUChar -> IO ()
{-# LINE 296 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      pokeVQUIT      = ((\hsc_ptr -> pokeByteOff hsc_ptr 18))  ptr :: CUChar -> IO ()
{-# LINE 297 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      pokeLFlag      = ((\hsc_ptr -> pokeByteOff hsc_ptr 12))      ptr :: CUInt -> IO ()
{-# LINE 298 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      peekLFlag      = ((\hsc_ptr -> peekByteOff hsc_ptr 12))      ptr :: IO CUInt
{-# LINE 299 "platform/posix/src/System/Terminal/Platform.hsc" #-}

foreign import ccall unsafe "tcgetattr"
  unsafeGetTermios :: CInt -> Ptr Termios -> IO CInt

foreign import ccall unsafe "tcsetattr"
  unsafeSetTermios :: CInt -> CInt -> Ptr Termios -> IO CInt

foreign import ccall unsafe "ioctl"
  unsafeIOCtl :: CInt -> CInt -> Ptr a -> IO CInt

foreign import ccall unsafe
  stg_sig_install :: CInt -> CInt -> Ptr a -> IO CInt