LibMain.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module System.Terminal.Emulator.SDL.LibMain where

import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception (bracket)
import Control.Lens
import Control.Monad (forM_, unless, when)
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.Conduit (runConduit, (.|))
import Data.Conduit.Attoparsec (conduitParser)
import Data.Conduit.Combinators (decodeUtf8Lenient)
import qualified Data.Conduit.Combinators as C
import Data.Conduit.TQueue (sinkTBQueue, sourceTBQueue)
import qualified Data.Vector.Unboxed as VU
import Data.Word (Word8)
import Foreign.C.Types (CInt)
import Linear (V2 (..), V3 (..), V4 (..))
import Linear.Affine (Point (..))
import qualified Linear.V4 as V4
import SDL (get, ($=))
import qualified SDL as SDL
import qualified System.Console.ANSI.Types as SGR
import System.Terminal.Emulator.Attrs (Cell, attrsBg, attrsFg, attrsIntensity, attrsUnderline)
import System.Terminal.Emulator.KeyboardInput.KeyPressToPty (keyPressToPty)
import System.Terminal.Emulator.Parsing (parseTermAtom)
import System.Terminal.Emulator.Parsing.Types (TermAtom)
import System.Terminal.Emulator.SDL.ImageFont (loadImageFont)
import System.Terminal.Emulator.SDL.KeyboardTranslate (translateSDLKey)
import System.Terminal.Emulator.SDL.Pty (launchPty)
import System.Terminal.Emulator.Term (activeScreen, altScreenActive, cursorPos, mkTerm, numRows, scrollBackLines, termGetKeyboardState, windowTitle)
import System.Terminal.Emulator.Term.Process (Term, TermLine, processTermAtoms)
import System.Terminal.Emulator.Term.Resize (resizeTerm)
import qualified System.Terminal.Emulator.TermLines as TL
import Prelude hiding (lines)

initialTerminalWidth, initialTerminalHeight :: CInt
initialTerminalWidth = 80
initialTerminalHeight = 30

initialWindowSize :: V2 CInt
initialWindowSize = V2 (initialTerminalWidth * cellWidth) (initialTerminalHeight * cellHeight)

main :: IO ()
main = do
  SDL.initializeAll
  bracket
    ( SDL.createWindow
        "My SDL Application"
        SDL.defaultWindow
          { SDL.windowBorder = True,
            SDL.windowInitialSize = initialWindowSize,
            SDL.windowResizable = True
          }
    )
    SDL.destroyWindow
    ( \window -> do
        renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer
        -- We need to resize the window again, because the window manager I
        -- use (xmonad) creates it initially a bit too small
        SDL.windowSize window $= initialWindowSize
        fontSurface <- loadImageFont
        fontTexture <- SDL.createTextureFromSurface renderer fontSurface
        SDL.freeSurface fontSurface

        terminalLoop window renderer fontTexture
    )

terminalLoop :: SDL.Window -> SDL.Renderer -> SDL.Texture -> IO ()
terminalLoop window renderer fontTexture = do
  V2 windowWidth windowHeight <- get $ SDL.windowSize window
  let terminalInitialWidth = fromIntegral (windowWidth `div` cellWidth)
      terminalInitialHeight = fromIntegral (windowHeight `div` cellHeight)

  termOutputQueue <- newTBQueueIO 500
  let initialTerm = mkTerm (terminalInitialWidth, terminalInitialHeight)

  windowDirtyVar <- newTVarIO True

  scrollBackVar <- newTVarIO 0

  termVar :: TVar Term <- newTVarIO initialTerm

  termInputBuffer :: TChan ByteString <- newTChanIO

  termResizeEvents :: TChan (Int, Int) <- newTChanIO

  termOutputStream :: TBQueue TermAtom <- newTBQueueIO 500

  let streamInput :: IO ()
      streamInput =
        runConduit $
          (sourceTBQueue termOutputQueue)
            .| decodeUtf8Lenient
            .| C.iterM (\t -> putStrLn $ "[RAW] " <> show t)
            .| conduitParser parseTermAtom -- termAtom
            -- .| C.iterM (\t -> putStrLn $ "[PARSED] " <> show t)
            .| C.map snd
            .| sinkTBQueue termOutputStream

  let doTerminalResize :: (Int, Int) -> IO ()
      doTerminalResize newSize = do
        atomically $ do
          modifyTVar' termVar (flip resizeTerm newSize')
          writeTVar windowDirtyVar True
        atomically $ writeTChan termResizeEvents newSize'
        where
          (width, height) = newSize
          newSize' = (max 1 width, max 1 height)

  let readInput :: IO ()
      readInput = do
        event <- interruptibleWaitEvent
        case SDL.eventPayload event of
          SDL.KeyboardEvent SDL.KeyboardEventData {SDL.keyboardEventKeyMotion = SDL.Pressed, SDL.keyboardEventKeysym = keysym} -> do
            -- putStrLn $ "{KEYSYM} " <> show keysym
            case translateSDLKey keysym of
              Nothing -> pure ()
              Just termInput -> atomically $ do
                term <- readTVar termVar
                writeTChan termInputBuffer (keyPressToPty (termGetKeyboardState term) termInput)
            pure ()
          SDL.WindowExposedEvent _ -> atomically $ writeTVar windowDirtyVar True
          SDL.MouseWheelEvent SDL.MouseWheelEventData {SDL.mouseWheelEventPos = V2 _ scrollY} -> do
            atomically $ do
              let scrollMultiplier = 6
              modifyTVar' scrollBackVar (\scrollBack -> max 0 (scrollBack + (scrollMultiplier * (fromIntegral scrollY))))
              writeTVar windowDirtyVar True
          SDL.MouseMotionEvent
            SDL.MouseMotionEventData
              { SDL.mouseMotionEventState = [SDL.ButtonRight],
                SDL.mouseMotionEventPos = P (V2 mouseX mouseY)
              } -> do
              let newTermWidth = fromIntegral mouseX `div` fromIntegral cellWidth
                  newTermHeight = fromIntegral mouseY `div` fromIntegral cellHeight
              doTerminalResize (newTermWidth, newTermHeight)
          SDL.MouseButtonEvent
            SDL.MouseButtonEventData
              { SDL.mouseButtonEventButton = SDL.ButtonRight,
                SDL.mouseButtonEventMotion = SDL.Pressed,
                SDL.mouseButtonEventPos = P (V2 mouseX mouseY),
                SDL.mouseButtonEventClicks = numClicks
              } -> do
              putStrLn $ "mouseClick: " <> show numClicks <> show (mouseX, mouseY)
              let newTermWidth = fromIntegral mouseX `div` fromIntegral cellWidth
                  newTermHeight = fromIntegral mouseY `div` fromIntegral cellHeight
              doTerminalResize (newTermWidth, newTermHeight)
          SDL.WindowSizeChangedEvent
            SDL.WindowSizeChangedEventData
              { SDL.windowSizeChangedEventSize = V2 newWindowWidth newWindowHeight
              } ->
              do
                putStrLn $ "RESIZE: " <> show (newWindowWidth, newWindowHeight)
                let newTermWidth = fromIntegral newWindowWidth `div` fromIntegral cellWidth
                    newTermHeight = fromIntegral newWindowHeight `div` fromIntegral cellHeight
                doTerminalResize (newTermWidth, newTermHeight)
          _ -> pure ()
        readInput

  let renderLoop :: IO ()
      renderLoop = do
        mbOutputBuf <-
          atomically $
            (readTBQueueAll termOutputStream >>= pure . Just)
              `orElse` ( do
                           windowDirty <- readTVar windowDirtyVar
                           if windowDirty
                             then do
                               writeTVar windowDirtyVar False
                               pure Nothing
                             else retry
                       )
        -- putStrLn $ "{OUTPUT} " <> show outputBuf
        !(termWrite, !term') <- atomically $ do
          term <- readTVar termVar
          case mbOutputBuf of
            Just outputBuf -> do
              let (termWrite, term') = processTermAtoms outputBuf term
              writeTVar termVar $! term'
              pure (termWrite, term')
            Nothing -> pure (B.empty, term)
        unless (B.null termWrite) $
          atomically $ writeTChan termInputBuffer termWrite
        scrollBack <- atomically $ readTVar scrollBackVar
        renderTerm window renderer fontTexture term' scrollBack
        renderLoop

  withAsync streamInput $ \streamInputAsync -> do
    link streamInputAsync
    withAsync readInput $ \readInputAsync -> do
      link readInputAsync
      withAsync
        ( renderLoop
        )
        $ \renderLoopAsync -> do
          link renderLoopAsync
          launchPty (terminalInitialWidth, terminalInitialHeight) (readTChan termInputBuffer) (readTChan termResizeEvents) $ \contents -> do
            -- putStrLn $ "[CONTENTS] " ++ show contents
            atomically $ writeTBQueue termOutputQueue contents

-- | Reads all the values in the 'TBQueue', or retry if it is empty
readTBQueueAll :: TBQueue a -> STM [a]
readTBQueueAll c = do
  first <- readTBQueue c
  rest <- tryReadTBQueueMultiple []
  pure (first : rest)
  where
    tryReadTBQueueMultiple accum = do
      mbItem <- tryReadTBQueue c
      case mbItem of
        Nothing -> pure (reverse accum)
        Just item -> tryReadTBQueueMultiple (item : accum)

renderTerm :: SDL.Window -> SDL.Renderer -> SDL.Texture -> Term -> Int -> IO ()
renderTerm window renderer fontTexture term scrollBack = do
  SDL.windowTitle window $= term ^. windowTitle
  let visibleRows
        | term ^. altScreenActive = term ^. activeScreen
        | otherwise = (TL.take (term ^. numRows) (TL.takeLast scrollBack (term ^. scrollBackLines))) <> (TL.dropLast scrollBack (term ^. activeScreen))

  SDL.rendererDrawColor renderer $= V4 255 32 255 255
  SDL.clear renderer
  _ <- (flip TL.traverseWithIndex) visibleRows $ \line termLine -> do
    renderLine renderer fontTexture termLine line

  renderGrid window renderer

  -- Render the cursor
  let (line, col) = term ^. cursorPos
  SDL.rendererDrawColor renderer $= V4 255 255 128 255
  SDL.drawRect renderer (Just (SDL.Rectangle (P (V2 (fromIntegral col * cellWidth) (fromIntegral (line + scrollBack) * cellHeight))) charSize))

  SDL.present renderer

renderGrid :: SDL.Window -> SDL.Renderer -> IO ()
renderGrid window renderer = do
  V2 windowWidth windowHeight <- get $ SDL.windowSize window
  SDL.rendererDrawColor renderer $= V4 8 8 8 255

  -- Horizontal lines
  forM_ [0, cellHeight .. windowHeight] $ \y -> do
    SDL.drawLine renderer (P (V2 0 y)) (P (V2 windowWidth y))

  -- Vertical lines
  forM_ [0, cellWidth .. windowWidth] $ \x -> do
    SDL.drawLine renderer (P (V2 x 0)) (P (V2 x windowHeight))

renderLine :: SDL.Renderer -> SDL.Texture -> TermLine -> Int -> IO ()
renderLine renderer fontTexture termLine line = do
  VU.iforM_ termLine $ \col cell -> do
    renderChar renderer fontTexture cell line col
  pure ()

renderChar :: SDL.Renderer -> SDL.Texture -> Cell -> Int -> Int -> IO ()
renderChar renderer fontTexture (char, attrs) line col = do
  let fgColor :: (V3 Word8)
      fgColor = case attrs ^. attrsFg of
        Nothing -> V3 172 216 172
        Just (SGR.Dull, SGR.Black) -> V3 0 0 0
        Just (SGR.Dull, SGR.Red) -> V3 208 0 0
        Just (SGR.Dull, SGR.Green) -> V3 0 208 0
        Just (SGR.Dull, SGR.Yellow) -> V3 208 208 0
        Just (SGR.Dull, SGR.Blue) -> V3 0 0 208
        Just (SGR.Dull, SGR.Magenta) -> V3 208 0 208
        Just (SGR.Dull, SGR.Cyan) -> V3 0 208 208
        Just (SGR.Dull, SGR.White) -> V3 208 208 208
        Just (SGR.Vivid, SGR.Black) -> V3 128 128 128
        Just (SGR.Vivid, SGR.Red) -> V3 128 128 128
        Just (SGR.Vivid, SGR.Green) -> V3 128 128 128
        Just (SGR.Vivid, SGR.Yellow) -> V3 128 128 128
        Just (SGR.Vivid, SGR.Blue) -> V3 128 128 128
        Just (SGR.Vivid, SGR.Magenta) -> V3 128 128 128
        Just (SGR.Vivid, SGR.Cyan) -> V3 128 128 128
        Just (SGR.Vivid, SGR.White) -> V3 128 128 128

      bgColor :: (V4 Word8)
      bgColor = case attrs ^. attrsBg of
        Nothing -> V4 0 0 0 255
        Just (SGR.Dull, SGR.Black) -> V4 0 0 0 255
        Just (SGR.Dull, SGR.Red) -> V4 208 0 0 255
        Just (SGR.Dull, SGR.Green) -> V4 0 208 0 255
        Just (SGR.Dull, SGR.Yellow) -> V4 208 208 0 255
        Just (SGR.Dull, SGR.Blue) -> V4 0 0 208 255
        Just (SGR.Dull, SGR.Magenta) -> V4 208 0 208 255
        Just (SGR.Dull, SGR.Cyan) -> V4 0 208 208 255
        Just (SGR.Dull, SGR.White) -> V4 208 208 208 255
        Just (SGR.Vivid, SGR.Black) -> V4 255 128 128 255
        Just (SGR.Vivid, SGR.Red) -> V4 255 128 128 255
        Just (SGR.Vivid, SGR.Green) -> V4 255 128 128 255
        Just (SGR.Vivid, SGR.Yellow) -> V4 255 128 128 255
        Just (SGR.Vivid, SGR.Blue) -> V4 255 128 128 255
        Just (SGR.Vivid, SGR.Magenta) -> V4 255 128 128 255
        Just (SGR.Vivid, SGR.Cyan) -> V4 255 128 128 255
        Just (SGR.Vivid, SGR.White) -> V4 255 128 128 255
  SDL.rendererDrawColor renderer $= bgColor
  SDL.fillRect renderer (Just (SDL.Rectangle (P (V2 (fromIntegral col * cellWidth) (fromIntegral line * cellHeight))) charSize))

  SDL.textureColorMod fontTexture $= fgColor
  SDL.copy
    renderer
    fontTexture
    (Just (SDL.Rectangle (charPosition char) charSize))
    (Just (SDL.Rectangle (P (V2 (fromIntegral col * cellWidth) (fromIntegral line * cellHeight))) charSize))

  when (attrs ^. attrsIntensity == SGR.BoldIntensity) $ do
    SDL.copy
      renderer
      fontTexture
      (Just (SDL.Rectangle (charPosition char) charSize))
      (Just (SDL.Rectangle (P (V2 (fromIntegral col * cellWidth - 1) (fromIntegral line * cellHeight))) charSize))

  when (attrs ^. attrsUnderline == SGR.SingleUnderline) $ do
    SDL.rendererDrawColor renderer $= (V4._w .~ 255) (V4.vector fgColor)
    SDL.drawLine
      renderer
      (P (V2 (fromIntegral col * cellWidth) (fromIntegral line * cellHeight + cellHeight - 2)))
      (P (V2 (fromIntegral col * cellWidth + cellWidth) (fromIntegral line * cellHeight + cellHeight - 2)))

fontCellWidth, fontCellHeight :: CInt
(fontCellWidth, fontCellHeight) = (16, 16)

cellWidth, cellHeight :: CInt
(cellWidth, cellHeight) = (14, 16)

charPosition :: Char -> Point V2 CInt
charPosition char = case fromEnum char of
  charCode
    | charCode < 256 -> P (V2 ((fromIntegral charCode `rem` 16) * fontCellWidth) ((fromIntegral charCode `div` 16) * fontCellHeight))
    | otherwise -> invalidCharP
  where
    invalidCharP = P (V2 (15 * fontCellWidth) (7 * fontCellHeight))

charSize :: V2 CInt
charSize = V2 fontCellWidth fontCellHeight

interruptibleWaitEvent :: IO SDL.Event
interruptibleWaitEvent = do
  result <- SDL.waitEventTimeout 50
  case result of
    Just e -> pure e
    Nothing -> interruptibleWaitEvent