{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} module Control.Monad.Terminal.Input where import Control.Monad.IO.Class import Control.Monad.STM import Data.Bits import Data.List -- | This monad describes an environment that maintains a stream of `Event`s -- and offers out-of-band signaling for interrupts. -- -- * An interrupt shall occur if the user either presses CTRL+C -- or any other mechanism the environment designates for that purpose. -- * Implementations shall maintain an interrupt flag that is set -- when an interrupt occurs. Computations in this monad shall check and -- reset this flag regularly. If the execution environment finds this -- flag still set when trying to signal another interrupt, it shall -- throw `Control.Exception.AsyncException.UserInterrupt` to the -- seemingly unresponsive computation. -- * When an interrupt is signaled through the flag, an `Event.InterruptEvent` -- must be added to the event stream in the same transaction. -- This allows to flush all unprocessed events from the stream that -- occured before the interrupt. class (MonadIO m) => MonadInput m where -- | Wait for the next interrupt or the next event transformed by a given mapper. -- -- * The first mapper parameter is a transaction that succeeds as -- soon as the interrupt flag gets set. Executing this transaction -- resets the interrupt flag. If the interrupt flag is not reset -- before a second interrupt occurs, the current thread shall -- receive an `Control.Exception.AsyncException.UserInterrupt`. -- * The second mapper parameter is a transaction that succeeds as -- as soon as the next event arrives and removes that event from the -- stream of events. It may be executed several times within the same -- transaction, but might not succeed every time. waitMapInterruptAndEvents :: (STM () -> STM Event -> STM a) -> m a -- | Wait for the next event. -- -- * Returns as soon as an event occurs. -- * This operation resets the interrupt flag it returns, -- signaling responsiveness to the execution environment. -- * `Event.InterruptEvent`s occur in the event stream at their correct -- position wrt to ordering of events. They are returned as regular -- events. This is eventually not desired when trying to handle interrupts -- with highest priority and `waitInterruptOrElse` should be considered then. waitEvent :: MonadInput m => m Event waitEvent = waitMapInterruptAndEvents $ \intr evs-> (intr `orElse` pure ()) >> evs -- | Wait simultaneously for the next event or a given transaction. -- -- * Returns as soon as either an event occurs or the given transaction -- succeeds. -- * This operation resets the interrupt flag whenever it returns, -- signaling responsiveness to the execution environment. -- * `Event.InterruptEvent`s occur in the event stream at their correct -- position wrt to ordering of events. They are returned as regular -- events. This is eventually not desired when trying to handle interrupts -- with highest priority and `waitInterruptOrElse` should be considered then. waitEventOrElse :: MonadInput m => STM a -> m (Either Event a) waitEventOrElse stma = waitMapInterruptAndEvents $ \intr evs-> (intr `orElse` pure ()) >> ((Prelude.Left <$> evs) `orElse` (Prelude.Right <$> stma)) -- | Wait simultaneously for the next interrupt or a given transaction. -- -- * Returns `Nothing` on interrupt and `Just` when the supplied transaction -- succeeds first. -- * This operation resets the interrupt flag, signaling responsiveness -- to the execution environment. -- * All pending events up to and including the `InterruptEvent` are flushed -- from the event stream in case of an interrupt. waitInterruptOrElse :: MonadInput m => STM a -> m (Maybe a) waitInterruptOrElse stma = waitMapInterruptAndEvents $ \intr evs-> (intr >> dropTillInterruptEvent evs >> pure Nothing) `orElse` (Just <$> stma) where dropTillInterruptEvent :: STM Event -> STM () dropTillInterruptEvent evs = ((Just <$> evs) `orElse` pure Nothing) >>= \case Nothing -> pure () Just InterruptEvent -> pure () _ -> dropTillInterruptEvent evs data Key = CharKey Char | TabKey | SpaceKey | BackspaceKey | EnterKey | InsertKey | DeleteKey | HomeKey -- ^ Pos 1 | BeginKey | EndKey | PageUpKey | PageDownKey | EscapeKey | PrintKey | PauseKey | ArrowKey Direction | FunctionKey Int deriving (Eq,Ord,Show) newtype Modifiers = Modifiers Int deriving (Eq, Ord, Bits) instance Semigroup Modifiers where Modifiers a <> Modifiers b = Modifiers (a .|. b) instance Monoid Modifiers where mempty = Modifiers 0 instance Show Modifiers where show (Modifiers 0) = "mempty" show (Modifiers 1) = "shiftKey" show (Modifiers 2) = "ctrlKey" show (Modifiers 4) = "altKey" show (Modifiers 8) = "metaKey" show i = "(" ++ intercalate " <> " ls ++ ")" where ls = foldl (\acc x-> if x .&. i /= mempty then show x:acc else acc) [] [metaKey, altKey, ctrlKey, shiftKey] shiftKey, ctrlKey, altKey, metaKey :: Modifiers shiftKey = Modifiers 1 ctrlKey = Modifiers 2 altKey = Modifiers 4 metaKey = Modifiers 8 data Event = KeyEvent Key Modifiers | MouseEvent MouseEvent | WindowEvent WindowEvent | DeviceEvent DeviceEvent | InterruptEvent | OtherEvent String deriving (Eq,Ord,Show) data MouseEvent = MouseMoved (Int,Int) | MouseButtonPressed (Int,Int) MouseButton | MouseButtonReleased (Int,Int) MouseButton | MouseButtonClicked (Int,Int) MouseButton | MouseWheeled (Int,Int) Direction deriving (Eq,Ord,Show) data MouseButton = LeftMouseButton | RightMouseButton | OtherMouseButton deriving (Eq,Ord,Show) data Direction = Upwards | Downwards | Leftwards | Rightwards deriving (Eq,Ord,Show) data WindowEvent = WindowLostFocus | WindowGainedFocus | WindowSizeChanged (Int,Int) deriving (Eq, Ord, Show) data DeviceEvent = DeviceAttributesReport String | CursorPositionReport (Int,Int) deriving (Eq, Ord, Show)