{-# 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
    { localType              :: BS.ByteString
    , localEvent             :: STM Event
    , localInterrupt         :: STM Interrupt
    , localGetCursorPosition :: IO Position
    }

instance Terminal LocalTerminal where
    termType              = localType
    termEvent             = localEvent
    termInterrupt         = localInterrupt
    termCommand _ c       = Text.hPutStr IO.stdout (defaultEncode c)
    termFlush _           = IO.hFlush IO.stdout
    termGetWindowSize _   = getWindowSize
    termGetCursorPosition = localGetCursorPosition

withTerminal :: (MonadIO m, MonadMask m) => (LocalTerminal -> m a) -> m a
withTerminal action = do
    term           <- BS8.pack . fromMaybe "xterm" <$> liftIO (lookupEnv "TERM")
    mainThread     <- liftIO myThreadId
    interrupt      <- liftIO (newTVarIO False)
    windowChanged  <- liftIO (newTVarIO False)
    events         <- liftIO newEmptyTMVarIO
    cursorPosition <- liftIO newEmptyTMVarIO
    withTermiosSettings $ \termios->
        withInterruptHandler (handleInterrupt mainThread interrupt) $
        withResizeHandler (handleResize windowChanged) $
        withInputProcessing termios cursorPosition events $
        action LocalTerminal
            { localType = term
            , localEvent = do
                changed <- swapTVar windowChanged False
                if changed
                  then pure (WindowEvent WindowSizeChanged)
                  else takeTMVar events
            , localInterrupt = swapTVar interrupt False >>= check >> pure Interrupt
            , localGetCursorPosition = do
                -- Empty the result variable.
                atomically (void (takeTMVar cursorPosition) <|> pure ())
                -- Send cursor position report request.
                Text.hPutStr IO.stdout (defaultEncode GetCursorPosition)
                IO.hFlush IO.stdout
                -- Wait for the result variable to be filled by the input processor.
                atomically (takeTMVar cursorPosition)
            }
    where
        handleResize :: TVar Bool -> IO ()
        handleResize windowChanged =
            atomically (writeTVar windowChanged 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 mainThread interrupt = do
            unhandledInterrupt <- atomically (swapTVar interrupt True)
            when unhandledInterrupt (E.throwTo mainThread E.UserInterrupt)

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

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 { 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 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 (oldHandler,oldAction) = liftIO do
      void $ Conc.setHandler (28) 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 handler = bracket installHandler restoreHandler . const
  where
    installHandler = liftIO do
      Conc.ensureIOManagerIsRunning
      oldHandler <- Conc.setHandler (2) (Just (const handler, Dyn.toDyn 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 (oldHandler,oldAction) = liftIO do
      void $ Conc.setHandler (2) 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 termios cursorPosition events =
    bracket (liftIO $ A.async $ run decoder) (liftIO . A.cancel) . const
    where
        run :: Decoder -> IO ()
        run d = do
            c <- IO.hGetChar 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 d' -> IO.hWaitForInput IO.stdin timeoutMilliseconds >>= \case
                  True  -> run d'
                  False -> case feedDecoder d' mempty '\NUL' of
                      Left d'' -> run d''
                      Right evs -> do
                          forM_ evs writeEvent
                          run decoder
              -- The decoder reached a final state.
              -- All recognized events are appended to the event stream.
              Right evs -> do
                  forM_ evs writeEvent
                  run decoder

        decoder :: Decoder
        decoder = defaultDecoder (specialChar termios)

        -- Adds events to the event stream and catches certain events
        -- that require special treatment.
        writeEvent :: Event -> IO ()
        writeEvent = \case
            ev@(DeviceEvent (CursorPositionReport pos)) -> 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.
                putTMVar cursorPosition pos <|> void (swapTMVar cursorPosition pos)
                putTMVar events ev
            ev -> atomically (putTMVar events 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  = 50

getWindowSize :: IO Size
getWindowSize =
  alloca $ \ptr->
    unsafeIOCtl 0 (21523) ptr >>= \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 =
  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 229 "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 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    _ = ((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