{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, FlexibleInstances #-}
{-|
Module      : System.IO.Terminal.Input
Copyright   : (c) UU, 2019
License     : MIT
Maintainer  : Tom Smeding
Stability   : experimental
Portability : POSIX, macOS, Windows

Keyboard input for console applications.

A monad transformer is defined that allows reading keys from the
keyboard in symbolic form, i.e. escape sequences have already been
parsed.
-}
module System.IO.Terminal.Input
    (InputT, Input, withInput, liftIO, MonadInput(..)
    ,Key(..)
    ,InfInt(..), readKey)
    where

import Control.Monad.Trans
import Control.Monad.State.Strict
import Data.Maybe
import Numeric.InfInt
import System.IO.Terminal.Render
import System.IO.Terminal.Input.Key
import System.IO.Terminal.Input.SeqParser
-- import qualified Utils.Debug as Debug
import Utils.Time

#if defined(OS_LINUX) || defined(OS_MACOS)
import System.IO.Terminal.Input.Posix
#else
import System.IO.Terminal.Input.Windows
#endif


-- | Escape sequence timeout in milliseconds.
gEscTimeoutMS :: Int
gEscTimeoutMS = 100


-- | The keyboard input monad transformer. The contained monad must be
-- a monad over 'IO'.
newtype InputT m a = InputT (StateT InputState m a)
  deriving (Functor, Applicative, Monad, MonadState InputState, MonadTrans)

deriving instance MonadIO m => MonadIO (InputT m)

-- | The non-transformer variant of 'InputT'.
type Input = InputT IO

data InputState = InputState { sKeys :: [Key]
                             , sParser :: SeqParser (Maybe Char) Key
                               -- If the timeout event was already returned, Infinity
                             , sLastKey :: InfInt }

-- | Run an 'Input' computation within an IO-based monad.
withInput :: MonadIO m => InputT m a -> m a
withInput (InputT st) =
    withRawMode $ evalStateT st (InputState [] seqParser Infinity)


-- | The behavior class for the 'InputT' monad transformer.
class Monad m => MonadInput m where
    -- | Timeout in milliseconds; Infinity is no timeout. Returns Nothing
    -- in case the timeout was reached.
    readKeyTimeout :: InfInt -> m (Maybe Key)

instance MonadIO m => MonadInput (InputT m) where
    readKeyTimeout userTimeout =
        get >>= \s -> case sKeys s of
            [] -> do
                let SeqParser parserFunc = sParser s

                beforeKey <- timestampMS <$> liftIO getSystemTime

                -- These timeouts are either 'Finite timeout' in milliseconds, or 'Infinity' in case
                -- no timeout is needed.
                let -- Possibly the amount of time left for the next escape sequence item
                    escTimeout = let delta = Finite beforeKey - sLastKey s
                                     left = Finite gEscTimeoutMS - delta
                                 in if left < 0 then 0 else left
                    -- We wait until either the user timeout or the escape timeout passes, whichever
                    -- is earlier
                    timeoutVal = min userTimeout escTimeout

                -- Debug.logIO ("readKeyTimeout", beforeKey, userTimeout, sLastKey s, escTimeout, timeoutVal)

                ch <- liftIO $ getCharTimeout (toFinite timeoutVal)

                let userTimeoutTriggered = isNothing ch && userTimeout < escTimeout
                -- If we hit the user timeout, return appropriately
                if userTimeoutTriggered
                    then {-Debug.logIO "returning Nothing" >>-} return Nothing
                    else do
                        -- We either got an actual key, or we hit the escape timeout. In either
                        -- case, we advance the escape sequence parser.
                        let (ks, p') = parserFunc ch
                        -- Debug.logIO ("keys", ks)

                        -- If we got an escape timeout, we'll be reporting it so we mark the last
                        -- key as "long ago" to not report an escape timeout twice to the parser.
                        -- Otherwise, we "start the escape timer" by storing the time of receipt of
                        -- this key.
                        afterKey <- timestampMS <$> liftIO getSystemTime
                        let newLastKey = maybe Infinity (const $ Finite afterKey) ch
                        modify $ \s' -> s' { sKeys = ks, sParser = p', sLastKey = newLastKey }

                        -- Either way, we stored some stuff in sKeys, so either that contains keys
                        -- to return, or we got nothing yet and need to retry; recursing handles
                        -- both cases nicely.
                        let userLeft = userTimeout - Finite (afterKey - beforeKey)
                        readKeyTimeout userLeft

            (k:ks) -> do
                put (s { sKeys = ks })
                -- Debug.logIO (Just k)
                return (Just k)

instance MonadInput (RenderT Input) where
    readKeyTimeout = lift . readKeyTimeout

-- | Read a key from standard input without timeout. Shortcut for
-- @readKeyTimeout Infinity@.
readKey :: MonadInput m => m Key
readKey = fromJust <$> readKeyTimeout Infinity