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

import           Control.Concurrent
import qualified Control.Concurrent.Async      as A
import           Control.Concurrent.STM.TChan
import           Control.Concurrent.STM.TVar
import           Control.Concurrent.STM.TMVar
import qualified Control.Exception             as E
import           Control.Monad                 (forever, when, unless, void)
import           Control.Monad.Catch hiding    (handle)
import           Control.Monad.IO.Class
import           Control.Monad.STM
import           Data.Bits
import qualified Data.ByteString.Char8         as BS8
import           Data.Maybe
import qualified Data.Text                     as Text
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.Posix.Types            (Fd(..))

import           Control.Monad.Terminal.Terminal
import           Control.Monad.Terminal.Input




withTerminal :: (MonadIO m, MonadMask m) => (Terminal -> m a) -> m a
withTerminal action = do
  term        <- BS8.pack . fromMaybe "xterm" <$> liftIO (lookupEnv "TERM")
  mainThread  <- liftIO myThreadId
  interrupt   <- liftIO (newTVarIO False)
  output      <- liftIO newEmptyTMVarIO
  outputFlush <- liftIO newEmptyTMVarIO
  events      <- liftIO newTChanIO
  screenSize  <- liftIO (newTVarIO =<< getWindowSize)
  withTermiosSettings $ \termios->
    withResizeHandler (handleResize screenSize events) $
    withInputProcessing mainThread termios interrupt events $
    withOutputProcessing output outputFlush $ action $ Terminal {
        termType           = term
      , termInput          = readTChan events
      , termInterrupt      = swapTVar interrupt False >>= check
      , termOutput         = putTMVar output
      , termFlush          = putTMVar outputFlush ()
      , termScreenSize     = readTVar screenSize
      , termSpecialChars   = \case
          '\n'   -> Just $ KeyEvent EnterKey mempty
          '\t'   -> Just $ KeyEvent TabKey mempty
          '\SP'  -> Just $ KeyEvent SpaceKey mempty
          '\b'   -> Just $ KeyEvent (if termiosVERASE termios == '\b'   then BackspaceKey else DeleteKey) mempty
          '\DEL' -> Just $ KeyEvent (if termiosVERASE termios == '\DEL' then DeleteKey else BackspaceKey) mempty
          _      -> Nothing
      }
  where
    handleResize screenSize events = do
      ws <- getWindowSize
      atomically $ do
        writeTVar screenSize ws
        writeTChan events (WindowEvent $ WindowSizeChanged ws)

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

withResizeHandler :: (MonadIO m, MonadMask m) => IO () -> m a -> m a
withResizeHandler handler = bracket installHandler restoreHandler . const
  where
    installHandler = liftIO $ do
      Conc.ensureIOManagerIsRunning
      oldHandler <- Conc.setHandler (28) (Just (const handler, Dyn.toDyn handler))
{-# LINE 88 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      oldAction  <- stg_sig_install (28) (-4) nullPtr
{-# LINE 89 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      pure (oldHandler,oldAction)
    restoreHandler (oldHandler,oldAction) = liftIO $ do
      void $ Conc.setHandler (28) oldHandler
{-# LINE 92 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      void $ stg_sig_install (28) oldAction nullPtr
{-# LINE 93 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      pure ()

withOutputProcessing :: (MonadIO m, MonadMask m) => TMVar Text.Text -> TMVar () -> m a -> m a
withOutputProcessing output outputFlush = bracket
  ( liftIO $ A.async run )
  ( liftIO . A.cancel ) . const
  where
    run = forever $ atomically ((Just <$> takeTMVar output) `orElse` (takeTMVar outputFlush >> pure Nothing)) >>= \case
        Nothing -> IO.hFlush IO.stdout
        Just t  -> Text.hPutStr IO.stdout t

withInputProcessing :: (MonadIO m, MonadMask m) => ThreadId -> Termios -> TVar Bool -> TChan Event -> m a -> m a
withInputProcessing mainThread termios interrupt events = bracket
  ( liftIO $ A.async run )
  ( liftIO . A.cancel ) . const
  where
    run :: IO ()
    run = forever $ do
        IO.hGetChar handle >>= \case
          c | c == termiosVINTR  termios -> handleInterrupt c
            | c == termiosVERASE termios -> atomically $ writeChar c >> writeKey BackspaceKey
            | otherwise                  -> atomically $ writeChar c
        writeFillCharacterAfterTimeout

    handle     :: IO.Handle
    handle      = IO.stdin
    writeEvent :: Event -> STM ()
    writeEvent  = writeTChan events
    writeKey   :: Key -> STM ()
    writeKey k  = writeTChan events (KeyEvent k mempty)
    writeChar  :: Char -> STM ()
    writeChar c = writeTChan events (KeyEvent (CharKey c) mempty)
    -- This function is responsible for passing interrupt events 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 events. 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  :: Char -> IO ()
    handleInterrupt c =  do
      unhandledInterrupt <- liftIO (atomically $ writeChar c >> writeEvent InterruptEvent >> swapTVar interrupt True)
      when unhandledInterrupt (E.throwTo mainThread E.UserInterrupt)
    -- This function first evaluates whether more input is immediately available.
    -- If this is the case it just returns. Otherwise it registers interest in
    -- the file descriptor and waits for either input becoming available or a timeout
    -- to occur. When the timeout triggers, a NUL character is appended to the
    -- event stream to enable subsequent decoders to unambigously decode all
    -- cases without the need to take timing into consideration anymore.
    writeFillCharacterAfterTimeout :: IO ()
    writeFillCharacterAfterTimeout = do
      ready <- IO.hReady handle
      unless ready $ bracket (threadWaitReadSTM (Fd 0)) snd $ \(inputAvailable,_)-> do
        timeout <- registerDelay timeoutMicroseconds >>= \t-> pure (readTVar t >>= check)
        atomically $ inputAvailable `orElse` (timeout >> writeChar '\NUL')
    -- 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.
    timeoutMicroseconds :: Int
    timeoutMicroseconds  = 50000

getWindowSize :: IO (Int, Int)
getWindowSize =
  alloca $ \ptr->
    unsafeIOCtl 0 (21523) ptr >>= \case
{-# LINE 167 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      0 -> peek ptr >>= \ws-> pure (fromIntegral $ wsRow ws, fromIntegral $ wsCol ws)
      _ -> undefined

getTermios :: IO Termios
getTermios =
  alloca $ \ptr->
    unsafeGetTermios 0 ptr >>= \case
      0 -> peek ptr
      _ -> undefined

setTermios :: Termios -> IO ()
setTermios t =
  alloca $ \ptr->
    unsafeGetTermios 0 ptr >>= \case
      0 -> do
        poke ptr t
        unsafeSetTermios 0 (0) ptr >>= \case
{-# LINE 184 "platform/posix/src/System/Terminal/Platform.hsc" #-}
          0 -> pure ()
          _ -> undefined
      _ -> undefined

data Winsize
  = Winsize
  { wsRow :: !CUShort
  , wsCol :: !CUShort
  } deriving (Eq, Ord, Show)

data Termios
  = Termios
  { termiosVEOF   :: !Char
  , termiosVERASE :: !Char
  , termiosVINTR  :: !Char
  , termiosVKILL  :: !Char
  , termiosVQUIT  :: !Char
  , termiosISIG   :: !Bool
  , termiosICANON :: !Bool
  , termiosECHO   :: !Bool
  } deriving (Eq, Ord, Show)

instance Storable Winsize where
  sizeOf    _ = ((8))
{-# LINE 208 "platform/posix/src/System/Terminal/Platform.hsc" #-}
  alignment _ = (2)
{-# LINE 209 "platform/posix/src/System/Terminal/Platform.hsc" #-}
  peek ptr    = Winsize
    <$> ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr
{-# LINE 211 "platform/posix/src/System/Terminal/Platform.hsc" #-}
    <*> ((\hsc_ptr -> peekByteOff hsc_ptr 2)) ptr
{-# LINE 212 "platform/posix/src/System/Terminal/Platform.hsc" #-}
  poke ptr ws = do
    ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr (wsRow ws)
{-# LINE 214 "platform/posix/src/System/Terminal/Platform.hsc" #-}
    ((\hsc_ptr -> pokeByteOff hsc_ptr 2)) ptr (wsCol ws)
{-# LINE 215 "platform/posix/src/System/Terminal/Platform.hsc" #-}

instance Storable Termios where
  sizeOf    _ = ((60))
{-# LINE 218 "platform/posix/src/System/Terminal/Platform.hsc" #-}
  alignment _ = (4)
{-# LINE 219 "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 228 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      <*> pure (lflag .&. (2) /= 0)
{-# LINE 229 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      <*> pure (lflag .&. (8)   /= 0)
{-# LINE 230 "platform/posix/src/System/Terminal/Platform.hsc" #-}
    where
      peekVEOF       = ((\hsc_ptr -> peekByteOff hsc_ptr 21))   ptr :: IO CUChar
{-# LINE 232 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      peekVERASE     = ((\hsc_ptr -> peekByteOff hsc_ptr 19)) ptr :: IO CUChar
{-# LINE 233 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      peekVINTR      = ((\hsc_ptr -> peekByteOff hsc_ptr 17))  ptr :: IO CUChar
{-# LINE 234 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      peekVKILL      = ((\hsc_ptr -> peekByteOff hsc_ptr 20))  ptr :: IO CUChar
{-# LINE 235 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      peekVQUIT      = ((\hsc_ptr -> peekByteOff hsc_ptr 18))  ptr :: IO CUChar
{-# LINE 236 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      peekLFlag      = ((\hsc_ptr -> peekByteOff hsc_ptr 12))      ptr :: IO CUInt
{-# LINE 237 "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 244 "platform/posix/src/System/Terminal/Platform.hsc" #-}
    peekLFlag >>= \flag-> pokeLFlag (if termiosICANON termios then flag .|. (2) else flag .&. complement (2))
{-# LINE 245 "platform/posix/src/System/Terminal/Platform.hsc" #-}
    peekLFlag >>= \flag-> pokeLFlag (if termiosECHO   termios then flag .|. (8)   else flag .&. complement (8))
{-# LINE 246 "platform/posix/src/System/Terminal/Platform.hsc" #-}
    where
      pokeVEOF       = ((\hsc_ptr -> pokeByteOff hsc_ptr 21))   ptr :: CUChar -> IO ()
{-# LINE 248 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      pokeVERASE     = ((\hsc_ptr -> pokeByteOff hsc_ptr 19)) ptr :: CUChar -> IO ()
{-# LINE 249 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      pokeVINTR      = ((\hsc_ptr -> pokeByteOff hsc_ptr 17))  ptr :: CUChar -> IO ()
{-# LINE 250 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      pokeVKILL      = ((\hsc_ptr -> pokeByteOff hsc_ptr 20))  ptr :: CUChar -> IO ()
{-# LINE 251 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      pokeVQUIT      = ((\hsc_ptr -> pokeByteOff hsc_ptr 18))  ptr :: CUChar -> IO ()
{-# LINE 252 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      pokeLFlag      = ((\hsc_ptr -> pokeByteOff hsc_ptr 12))      ptr :: CUInt -> IO ()
{-# LINE 253 "platform/posix/src/System/Terminal/Platform.hsc" #-}
      peekLFlag      = ((\hsc_ptr -> peekByteOff hsc_ptr 12))      ptr :: IO CUInt
{-# LINE 254 "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