Loop.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS_HADDOCK hide #-}

-- | The input layer forks a thread to read input data via the
--   Windows console API. Key presses, mouse events, and window
--   resize events are all obtained by calling ReadConsoleInputW.
module Graphics.Vty.Platform.Windows.Input.Loop
  ( initInput,
  )
where

import Control.Applicative (Alternative (many))
import Control.Concurrent
  ( ThreadId,
    forkOS,
    killThread,
    newEmptyMVar,
    putMVar,
    takeMVar,
  )
import Control.Concurrent.STM (atomically, newTChan, writeTChan)
import Control.Exception (SomeException, catch, mask, try)
import Control.Monad (forM_, mzero, unless)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.State.Class (MonadState, modify)
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Reader (ReaderT (..), ask, asks)
import Control.Monad.Trans.State (StateT (..), evalStateT)
import qualified Data.ByteString as BS
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BS8
import Data.Word (Word8)
import Foreign (allocaArray)
import Foreign.Ptr (Ptr, castPtr)
import Graphics.Vty.Config (VtyUserConfig (..))
import Graphics.Vty.Input
import Graphics.Vty.Platform.Windows.Input.Classify (classify)
import Graphics.Vty.Platform.Windows.Input.Classify.Types
import Graphics.Vty.Platform.Windows.WindowsInterfaces (readBuf)
import Lens.Micro (ASetter, ASetter', over)
import Lens.Micro.Mtl (use, (.=))
import Lens.Micro.TH (makeLenses)
import System.Environment (getEnv)
import System.IO (Handle)
import System.Win32.Console (INPUT_RECORD)

data InputBuffer = InputBuffer
  { _ptr :: Ptr Word8,
    _inputRecordPtr :: Ptr INPUT_RECORD,
    _consoleEventBufferSize :: Int
  }

makeLenses ''InputBuffer

data InputState = InputState
  { _unprocessedBytes :: ByteString,
    _classifierState :: ClassifierState,
    _inputHandle :: Handle,
    _originalInput :: Input,
    _inputBuffer :: InputBuffer,
    _classifier :: ClassifierState -> ByteString -> KClass
  }

makeLenses ''InputState

type InputM a = StateT InputState (ReaderT Input IO) a

logMsg :: String -> InputM ()
logMsg msg = do
  i <- use originalInput
  liftIO $ inputLogMsg i 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 = do
  readFromDevice >>= addBytesToProcess
  validEvents <- many parseEvent
  forM_ validEvents emit
  dropInvalid
  loopInputProcessor

addBytesToProcess :: ByteString -> InputM ()
addBytesToProcess block = unprocessedBytes <>= block

emit :: Event -> InputM ()
emit event = do
  logMsg $ "parsed event: " ++ show event
  lift (asks eventChannel) >>= liftIO . atomically . flip writeTChan (InputEvent event)

-- Precondition: Under the threaded runtime. Only current use is from a
-- forkOS thread. That case satisfies precondition.
readFromDevice :: InputM ByteString
readFromDevice = do
  handle <- use inputHandle

  bufferPtr <- use $ inputBuffer . ptr
  winRecordPtr <- use $ inputBuffer . inputRecordPtr
  maxInputRecords <- use $ inputBuffer . consoleEventBufferSize

  input <- lift ask
  stringRep <- liftIO $ do
    bytesRead <- readBuf (eventChannel input) winRecordPtr handle bufferPtr maxInputRecords
    if bytesRead > 0
      then BS.packCStringLen (castPtr bufferPtr, fromIntegral bytesRead)
      else return BS.empty
  unless (BS.null stringRep) $ logMsg $ "input bytes: " ++ show (BS8.unpack stringRep)
  return stringRep

parseEvent :: InputM Event
parseEvent = do
  c <- use classifier
  s <- use classifierState
  b <- use unprocessedBytes
  case c s b of
    Valid e remaining -> do
      logMsg $ "valid parse: " ++ show e
      logMsg $ "remaining: " ++ show remaining
      classifierState .= ClassifierStart
      unprocessedBytes .= remaining
      return e
    _ -> mzero

dropInvalid :: InputM ()
dropInvalid = do
  c <- use classifier
  s <- use classifierState
  b <- use unprocessedBytes
  case c s b of
    Chunk -> do
      classifierState
        .= case s of
          ClassifierStart -> ClassifierInChunk b []
          ClassifierInChunk p bs -> ClassifierInChunk p (b : bs)
      unprocessedBytes .= BS8.empty
    Invalid -> do
      logMsg "dropping input bytes"
      classifierState .= ClassifierStart
      unprocessedBytes .= BS8.empty
    _ -> return ()

runInputProcessorLoop :: ClassifyMap -> Input -> Handle -> IO ()
runInputProcessorLoop classifyTable input handle = do
    let bufferSize = 1024
    -- A key event could require 4 bytes of UTF-8.
    let maxKeyEvents = bufferSize `div` 4
    allocaArray maxKeyEvents $ \(inputRecordBuf :: Ptr INPUT_RECORD) -> do
      allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do
        let s0 =
              InputState
                BS8.empty
                ClassifierStart
                handle
                input
                (InputBuffer bufferPtr inputRecordBuf maxKeyEvents)
                (classify classifyTable)
        runReaderT (evalStateT loopInputProcessor s0) input

initInput :: VtyUserConfig -> Handle -> ClassifyMap -> IO Input
initInput userConfig handle classifyTable = do
  stopSync <- newEmptyMVar
  mDefaultLog <-
    catch
      ( do
          debugLog <- getEnv "VTY_DEBUG_LOG"
          return $ Just debugLog
      )
      (\(_ :: IOError) -> return Nothing)
  input <-
    Input
      <$> atomically newTChan
      <*> pure (return ())
      <*> pure (return ())
      <*> maybe
        (return $ append mDefaultLog)
        (return . appendFile)
        (configDebugLog userConfig)
  inputThread <-
    forkOSFinally
      (runInputProcessorLoop classifyTable input handle)
      (\_ -> putMVar stopSync ())
  let killAndWait = do
        killThread inputThread
        takeMVar stopSync
  return $ input {shutdownInput = killAndWait}
  where
    append mDebugLog msg =
      case mDebugLog of
        Just debugLog -> appendFile debugLog $ msg ++ "\n"
        Nothing -> return ()

forkOSFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkOSFinally action and_then =
  mask $ \restore -> forkOS $ try (restore action) >>= and_then

(<>=) :: (MonadState s m, Monoid a) => ASetter' s a -> a -> m ()
l <>= a = modify (l <>~ a)

(<>~) :: (Monoid a) => ASetter s t a a -> a -> s -> t
l <>~ n = over l (`mappend` n)