aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Config.hs88
-rw-r--r--src/Lib.hs6
-rw-r--r--src/Wetterhorn/Constraints.hs13
-rw-r--r--src/Wetterhorn/Core.hs152
-rw-r--r--src/Wetterhorn/Core/ButtonEvent.hs15
-rw-r--r--src/Wetterhorn/Core/KeyEvent.hs22
-rw-r--r--src/Wetterhorn/Core/Keys.hs239
-rw-r--r--src/Wetterhorn/Core/SurfaceEvent.hs16
-rw-r--r--src/Wetterhorn/Core/W.hs379
-rw-r--r--src/Wetterhorn/Dsl/Bind.hs128
-rw-r--r--src/Wetterhorn/Dsl/Buttons.hsc229
-rw-r--r--src/Wetterhorn/Dsl/Input.hs286
-rw-r--r--src/Wetterhorn/Foreign.hs18
-rw-r--r--src/Wetterhorn/Foreign/Export.hs208
-rw-r--r--src/Wetterhorn/Foreign/ForeignInterface.hs81
-rw-r--r--src/Wetterhorn/Foreign/WlRoots.hs67
-rw-r--r--src/Wetterhorn/Keys/Macros.hs145
-rw-r--r--src/Wetterhorn/Keys/MagicModifierKey.hs50
-rw-r--r--src/Wetterhorn/Layout/Combine.hs48
-rw-r--r--src/Wetterhorn/Layout/Full.hs23
-rw-r--r--src/Wetterhorn/StackSet.hs210
-rw-r--r--src/harness_adapter.c81
22 files changed, 0 insertions, 2504 deletions
diff --git a/src/Config.hs b/src/Config.hs
deleted file mode 100644
index e76e6ea..0000000
--- a/src/Config.hs
+++ /dev/null
@@ -1,88 +0,0 @@
-module Config (config) where
-
-import Control.Monad (unless)
-import Data.Bits
-import Data.Data (Proxy (Proxy))
-import Wetterhorn.Core.ButtonEvent as ButtonEvent
-import Wetterhorn.Core.KeyEvent as KeyEvent
-import Wetterhorn.Core.W
-import Wetterhorn.Dsl.Bind
-import Wetterhorn.Dsl.Input
-import Wetterhorn.Keys.Macros
-import Wetterhorn.Keys.MagicModifierKey
-import Wetterhorn.Layout.Full
-
-config :: Config WindowLayout
-config =
- defaultConfig
- { hooks =
- defaultHooks
- { surfaceHook = do
- handleSurface
- },
- layout = WindowLayout Full,
- resetHook = do
- useInputHandler $
- withProxies inputProxies $ do
- ev <- nextInputEvent
-
- bind ev (released btnLeft) $
- run $
- wio $
- putStrLn "Left Button Released!!"
-
- unless (isPressEvent ev) $ do
- forwardEvent ev
- continue
-
- bind ev (Shift .+ Mod1 .+ 'R') $ run requestHotReload
-
- bind ev (Mod1 .+ 't') $ run (shellExec "alacritty")
-
- bind ev (Mod1 .+ 'p') $ do
- ev2 <- nextInputPressEvent
-
- bind ev2 (Mod1 .+ 'p') $
- run $
- wio $
- putStrLn "Test"
-
- bind ev (Mod1 .+ btnLeft) $
- run $
- wio $
- putStrLn "Left Button Press!!"
-
- bind ev (Mod1 .+ 'q') macroStartStopKeybind
-
- bind ev (weak $ Mod1 .+ '@') macroReplayKeybind
-
- bind ev (weak $ ModX 5 .+ btnLeft) $
- run $
- wio $
- putStrLn "Fake Modifier With Button!!!"
-
- bind ev (weak $ ModX 5 .+ 't') $
- run $
- wio $
- putStrLn "Fake Modifier!!"
-
- forwardEvent ev
- }
- where
- inputProxies ::
- Proxy
- '[ MacroSupport,
- MagicModifierProxy 59 SetXtra -- Only log keys when F1 (keycode 59 is pressed)
- ]
- inputProxies = Proxy
-
-data SetXtra
-
-instance InputProxy SetXtra where
- onKeyEvent _ ie =
- case ie of
- (InputKeyEvent ke@(KeyEvent {KeyEvent.modifiers = modifiers})) ->
- return $ InputKeyEvent ke {KeyEvent.modifiers = modifiers .|. modifierToMask (ModX 5)}
- (InputButtonEvent be@(ButtonEvent {ButtonEvent.modifiers = modifiers})) ->
- return $ InputButtonEvent be {ButtonEvent.modifiers = modifiers .|. modifierToMask (ModX 5)}
- _ -> return ie
diff --git a/src/Lib.hs b/src/Lib.hs
deleted file mode 100644
index d36ff27..0000000
--- a/src/Lib.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Lib
- ( someFunc
- ) where
-
-someFunc :: IO ()
-someFunc = putStrLn "someFunc"
diff --git a/src/Wetterhorn/Constraints.hs b/src/Wetterhorn/Constraints.hs
deleted file mode 100644
index 129fd6c..0000000
--- a/src/Wetterhorn/Constraints.hs
+++ /dev/null
@@ -1,13 +0,0 @@
--- | Contains useful constraints and constraint combinators for type-level
--- metaprogramming.
-module Wetterhorn.Constraints where
-
--- | A null constraint. All types implement this.
-class Unconstrained a
-
-instance Unconstrained a
-
--- | Combines multiple constraints by 'And'ing them together.
-class (c1 a, c2 a) => (&&&&) c1 c2 a
-
-instance (c1 a, c2 a) => (&&&&) c1 c2 a
diff --git a/src/Wetterhorn/Core.hs b/src/Wetterhorn/Core.hs
deleted file mode 100644
index d853191..0000000
--- a/src/Wetterhorn/Core.hs
+++ /dev/null
@@ -1,152 +0,0 @@
-{-# HLINT ignore "Use camelCase" #-}
-
-module Wetterhorn.Core
--- ( WState (..),
--- WConfig (..),
--- SurfaceState (..),
--- W,
--- getWConfig,
--- getWState,
--- runW,
--- Wetterhorn,
--- initWetterhorn,
--- wio,
--- incrementState,
--- readWState,
--- defaultConfig,
--- requestHotReload,
--- ctxConfig,
--- KeyEvent (..),
--- KeyState (..),
--- )
-where
-
--- import Control.Arrow (first)
--- import Control.Exception
--- import Data.ByteString (ByteString)
--- import Data.Char (ord)
--- import Data.Map (Map)
--- import Foreign (Ptr, StablePtr, Word32, newStablePtr)
--- import Text.Printf
--- import Wetterhorn.Foreign.ForeignInterface (ForeignInterface)
--- import Wetterhorn.Foreign.WlRoots
--- import qualified Data.ByteString.Char8 as CH
--- import qualified Data.Map as Map
--- import qualified Wetterhorn.Foreign.ForeignInterface as ForeignInterface
---
--- data WContext = WContext
--- { ctxForeignInterface :: ForeignInterface,
--- ctxConfig :: WConfig
--- }
---
--- -- This is the OpaqueState passed to the harness.
--- type Wetterhorn = StablePtr (WContext, WState)
---
--- requestHotReload :: W ()
--- requestHotReload = do
--- fi <- ctxForeignInterface <$> getWContext
--- wio $ ForeignInterface.requestHotReload fi
---
--- requestLog :: String -> W ()
--- requestLog str = do
--- fi <- ctxForeignInterface <$> getWContext
--- wio $ ForeignInterface.requestLog fi str
---
--- requestExit :: Int -> W ()
--- requestExit ec = do
--- fi <- ctxForeignInterface <$> getWContext
--- wio $ ForeignInterface.requestExit fi ec
---
--- initWetterhorn :: WConfig -> IO Wetterhorn
--- initWetterhorn conf = do
--- foreignInterface <- ForeignInterface.getForeignInterface
--- newStablePtr (WContext foreignInterface conf, WState "this is a string" 0)
---
--- defaultBindings :: Map (KeyState, Word32, Word32) (W ())
--- defaultBindings =
--- Map.fromList
--- [ ((KeyPressed, 0x9, sym 'Q'), requestHotReload),
--- ((KeyPressed, 0x8, sym 'r'), wio $ ForeignInterface.doShellExec "wofi --show run"),
--- ((KeyPressed, 0x8, sym 'l'), requestLog "This is a log statement!\n"),
--- ((KeyPressed, 0x8, sym 't'), wio $ ForeignInterface.doShellExec "alacritty"),
--- ((KeyPressed, 0x9, sym 'T'), wio $ ForeignInterface.doShellExec "gnome-terminal"),
--- ((KeyPressed, 0x8, sym 'c'), wio $ ForeignInterface.doShellExec "pavucontrol"),
--- ( (KeyPressed, 0x8, sym 'p'),
--- wio $ do
--- putStrLn "Maps:"
--- putStrLn =<< readFile "/proc/self/maps"
--- ),
--- ((KeyPressed, 0x8, sym 'q'), requestExit 0)
--- ]
--- where
--- sym = fromIntegral . ord
---
--- defaultConfig :: WConfig
--- defaultConfig =
--- WConfig
--- { keybindingHandler = \keyEvent -> do
--- seatPtr <- (wio . ForeignInterface.getSeat . ctxForeignInterface) =<< getWContext
---
--- maybe
--- ( wio $ do
--- wlrSeatSetKeyboard seatPtr (device keyEvent)
--- wlrSeatKeyboardNotifyKey
--- seatPtr
--- (timeMs keyEvent)
--- (keycode keyEvent)
--- ( case state keyEvent of
--- KeyReleased -> 0
--- _ -> 1
--- )
---
--- return True
--- )
--- (fmap (const True))
--- $ Map.lookup
--- (state keyEvent, modifiers keyEvent, keysym keyEvent)
--- defaultBindings,
--- surfaceHandler = \state surface -> wio (printf "Surface %s is %s\n" (show surface) (show state))
--- }
---
--- readWState :: ByteString -> IO WState
--- readWState bs =
--- catch
--- (return $ read (CH.unpack bs))
--- ( \e ->
--- let _ = (e :: SomeException) in return (WState "" 0)
--- )
---
--- newtype W a = W ((WContext, WState) -> IO (a, WState))
---
--- instance Functor W where
--- fmap mfn (W fn) = W $ fmap (first mfn) <$> fn
---
--- instance Applicative W where
--- pure a = W $ \(_, s) -> return (a, s)
--- mfn <*> ma = do
--- fn <- mfn
--- fn <$> ma
---
--- instance Monad W where
--- (W fntoa) >>= fnmb = W $ \(config, state) -> do
--- (a, state') <- fntoa (config, state)
--- let W fntob = fnmb a
--- fntob (config, state')
---
--- getWContext :: W WContext
--- getWContext = W pure
---
--- getWConfig :: W WConfig
--- getWConfig = ctxConfig <$> getWContext
---
--- getWState :: W WState
--- getWState = W $ \(_, s) -> pure (s, s)
---
--- runW :: W a -> (WContext, WState) -> IO (a, WState)
--- runW (W fn) = fn
---
--- incrementState :: W Int
--- incrementState = W $ \(_, WState s i) -> return (i, WState s (i + 1))
---
--- wio :: IO a -> W a
--- wio fn = W $ \(_, b) -> fn >>= \a -> return (a, b)
diff --git a/src/Wetterhorn/Core/ButtonEvent.hs b/src/Wetterhorn/Core/ButtonEvent.hs
deleted file mode 100644
index cc3d905..0000000
--- a/src/Wetterhorn/Core/ButtonEvent.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-module Wetterhorn.Core.ButtonEvent where
-
-import Wetterhorn.Foreign.WlRoots
-import Data.Word (Word32)
-import Foreign (Ptr)
-
-data ButtonState = ButtonReleased | ButtonPressed deriving (Show, Read, Eq, Enum, Ord)
-
-data ButtonEvent = ButtonEvent {
- pointer :: Ptr WlrPointer,
- timeMs :: Word32,
- button :: Word32,
- modifiers :: Word32,
- state :: ButtonState
-} deriving (Eq, Show, Ord)
diff --git a/src/Wetterhorn/Core/KeyEvent.hs b/src/Wetterhorn/Core/KeyEvent.hs
deleted file mode 100644
index 77d273f..0000000
--- a/src/Wetterhorn/Core/KeyEvent.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-module Wetterhorn.Core.KeyEvent
- ( KeyEvent (..),
- KeyState (..),
- )
-where
-
-import Data.Word (Word32)
-import Foreign (Ptr)
-import Wetterhorn.Foreign.WlRoots
-
-data KeyState = KeyPressed | KeyReleased deriving (Show, Read, Eq, Enum, Ord)
-
-data KeyEvent = KeyEvent
- { timeMs :: Word32,
- keycode :: Word32,
- state :: KeyState,
- modifiers :: Word32,
- keysym :: Word32,
- codepoint :: Char,
- device :: Ptr WlrInputDevice
- }
- deriving (Show, Ord, Eq)
diff --git a/src/Wetterhorn/Core/Keys.hs b/src/Wetterhorn/Core/Keys.hs
deleted file mode 100644
index 54d7125..0000000
--- a/src/Wetterhorn/Core/Keys.hs
+++ /dev/null
@@ -1,239 +0,0 @@
-module Wetterhorn.Core.Keys where
-
-import Control.Monad (forever, void, when)
-import Control.Monad.Cont.Class
-import Control.Monad.IO.Class
-import Control.Monad.State (MonadState (get, put), MonadTrans (lift), StateT, evalStateT, gets, modify)
-import Control.Monad.Trans.Cont
-import Data.Bits
-import Data.Word
-import Wetterhorn.Core.ButtonEvent (ButtonEvent)
-import Wetterhorn.Core.KeyEvent
-import qualified Wetterhorn.Core.KeyEvent as KeyEvent
-import qualified Wetterhorn.Core.ButtonEvent as ButtonEvent
-import Wetterhorn.Core.W
-import Wetterhorn.Foreign.WlRoots (wlrSeatKeyboardNotifyKey, wlrSeatSetKeyboard)
-
--- | Forwards the given key event to the focused window.
-forwardKey :: KeyEvent -> W ()
-forwardKey keyEvent = do
- seatPtr <- getSeat
- wio $ do
- wlrSeatSetKeyboard
- seatPtr
- (device keyEvent)
-
- wlrSeatKeyboardNotifyKey
- seatPtr
- (timeMs keyEvent)
- (keycode keyEvent)
- ( case state keyEvent of
- KeyReleased -> 0
- _ -> 1
- )
-
--- | Forwards the current key event to the focused window.
-forwardEvent :: KeyEvent -> KeysM ()
-forwardEvent = liftW . forwardKey
-
--- | Enumeration of possible modifiers
-data Modifier = Shift | Lock | Control | Mod1 | Mod2 | Mod3 | Mod4 | Mod5
- deriving (Eq, Ord, Show, Read, Enum, Bounded)
-
--- | Converts a modifier to its associated mask.
-modifierToMask :: Modifier -> Word32
-modifierToMask m =
- 1
- `shiftL` case m of
- Shift -> 0
- Lock -> 1
- Control -> 2
- Mod1 -> 3
- Mod2 -> 4
- Mod3 -> 5
- Mod4 -> 6
- Mod5 -> 7
-
-data KeysState = KeysState
- { -- | Reference to the top. Used for a continue statement.
- keysTop :: KeysM (),
- handleContinuation :: KeyContinuation -> W ()
- }
-
--- | The Keys monad. This monad abstracts away control flow for handling key
--- bindings. This makes it easy to make key-sequence bindings.
--- newtype KeysM a = KeysM ((KeyEvent -> W ()) -> KeyEvent -> W (KeysMR a))
-newtype KeysM a = KeysM (ContT () (StateT KeysState W) a)
- deriving (Monad, Functor, Applicative, MonadCont, MonadIO)
-
--- | KeysM can be lifted from a W action.
-instance Wlike KeysM where
- liftW = KeysM . lift . lift
-
-type KeyContinuation = KeyEvent -> W ()
-
-useKeysWithContinuation :: (KeyContinuation -> W ()) -> KeysM () -> W ()
-useKeysWithContinuation continuation (forever -> km@(KeysM c)) =
- evalStateT (evalContT c) (KeysState km continuation)
-
-useKeys :: KeysM () -> W ()
-useKeys = useKeysWithContinuation putKeyHandler
-
--- | Returns the next key event.
-nextKeyEvent :: KeysM KeyEvent
-nextKeyEvent = do
- st <- KeysM $ lift get
- KeysM $
- shiftT
- ( \keyHandler ->
- lift . lift $
- handleContinuation st (\kp -> evalStateT (keyHandler kp) st)
- )
-
--- | Discards the rest of the continuation and starts again from the top. Useful
--- for keybinds where once the key is handled, there's nothing left to do.
-continue :: KeysM ()
-continue = do
- st <- KeysM $ lift get
- let (KeysM topCont) = keysTop st
-
- -- This shift discards the rest of the computation and instead returns to the
- -- top of the handler.
- KeysM $ shiftT (\_ -> resetT topCont)
-
--- | Returns the "top" continuation.
-getTop :: KeysM (KeysM ())
-getTop = KeysM (gets keysTop)
-
-putKeyHandler :: KeyContinuation -> W ()
-putKeyHandler handler = do
- s@State {currentHooks = hooks} <- get
- put
- s
- { currentHooks =
- hooks
- { keyHook = void <$> handler
- }
- }
-
-nextButtonEvent :: KeysM ButtonEvent
-nextButtonEvent = do
- st <- KeysM get
- KeysM $
- shiftT $ \h ->
- lift $ lift $ putButtonHandler (\ev -> evalStateT (h ev) st)
- where
- putButtonHandler h = do
- modify $ \st -> st {currentHooks = (currentHooks st) {buttonHook = h}}
-
-nextButtonOrKeyEvent :: KeysM (Either ButtonEvent KeyEvent)
-nextButtonOrKeyEvent = do
- st <- KeysM get
- KeysM $
- shiftT $ \rest ->
- lift $ lift $ do
- putButtonHandler (\ev -> evalStateT (rest (Left ev)) st)
- handleContinuation st (\ev -> evalStateT (rest (Right ev)) st)
-
- where
- putButtonHandler h = do
- modify $ \st -> st {currentHooks = (currentHooks st) {buttonHook = h}}
-
-nextButtonOrKeyPress :: KeysM (Either ButtonEvent KeyEvent)
-nextButtonOrKeyPress = do
- ev <- nextButtonOrKeyEvent
- case ev of
- Left bev | ButtonEvent.state bev == ButtonEvent.ButtonPressed -> return ev
- Left bev -> forwardButtonEvent bev >> nextButtonOrKeyPress
- Right kev | KeyEvent.state kev == KeyEvent.KeyPressed -> return ev
- Right kev -> forwardEvent kev >> nextButtonOrKeyPress
-
- where
- forwardButtonEvent _ = return ()
-
-
--- | Returns the next KeyPressed event. This is likely what 90% of use cases
--- want rather than nextKeyEvent.
-nextKeyPress :: KeysM KeyEvent
-nextKeyPress = do
- k <- nextKeyEvent
- if KeyEvent.state k /= KeyPressed
- then forwardEvent k >> nextKeyPress
- else return k
-
---
--- binding EDSL used to expressively create key bindings and subbindings inside
--- a KeysM () context.
---
-
-data KeyMatcher = KeyMatcher Word32 Char
- deriving (Show)
-
--- | Like a KeyMatcher, but allows additional modifiers to be pressed, not just
--- the exact ones given.
-newtype WeakKeyMatcher = WeakKeyMatcher KeyMatcher
-
--- | Converts a KeyMatcher to a weak key matcher.
-weak :: KeyMatcher -> WeakKeyMatcher
-weak = WeakKeyMatcher
-
-class KeyMatcherId r where
- toKeyMatcher :: r -> KeyMatcher
-
-instance KeyMatcherId KeyMatcher where
- toKeyMatcher = id
-
-instance KeyMatcherId Char where
- toKeyMatcher = KeyMatcher 0
-
-class KeyMatcherBuilder b where
- (.+) :: (KeyMatcherId i) => b -> i -> KeyMatcher
-
-instance KeyMatcherBuilder Modifier where
- (.+) m (toKeyMatcher -> (KeyMatcher mods ch)) =
- KeyMatcher (mods .|. modifierToMask m) ch
-
-infixr 9 .+
-
-class MatchKey m where
- matchKey :: m -> KeyEvent -> Bool
-
-instance MatchKey (KeyEvent -> Bool) where
- matchKey = ($)
-
-instance MatchKey Bool where
- matchKey = const
-
-instance MatchKey Char where
- matchKey ch ev = ch == KeyEvent.codepoint ev
-
-instance MatchKey KeyMatcher where
- matchKey (KeyMatcher m ch) ev =
- ch == KeyEvent.codepoint ev && m == KeyEvent.modifiers ev
-
-instance MatchKey WeakKeyMatcher where
- matchKey (WeakKeyMatcher (KeyMatcher m ch)) ev =
- ch == KeyEvent.codepoint ev && (m .|. ms) == ms
- where
- ms = KeyEvent.modifiers ev
-
-class IsKeysM m where
- toKeysM :: m a -> KeysM a
-
-instance IsKeysM W where
- toKeysM = liftW
-
-instance IsKeysM KeysM where
- toKeysM = id
-
-bind :: (MatchKey m, IsKeysM k) => KeyEvent -> m -> k () -> KeysM ()
-bind ev m act = do
- when (matchKey m ev) $ do
- toKeysM act
- continue
-
-ignoreReleaseEvents :: KeyEvent -> KeysM ()
-ignoreReleaseEvents ev = do
- when (KeyEvent.state ev /= KeyEvent.KeyPressed) $ do
- forwardEvent ev
- continue
diff --git a/src/Wetterhorn/Core/SurfaceEvent.hs b/src/Wetterhorn/Core/SurfaceEvent.hs
deleted file mode 100644
index 3e7eaf3..0000000
--- a/src/Wetterhorn/Core/SurfaceEvent.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-module Wetterhorn.Core.SurfaceEvent
- ( SurfaceEvent (..),
- SurfaceState (..),
- )
-where
-
-import Wetterhorn.Foreign.WlRoots
-
-data SurfaceState = Map | Unmap | Destroy
- deriving (Eq, Ord, Show, Read, Enum)
-
-data SurfaceEvent = SurfaceEvent
- { state :: SurfaceState,
- surface :: Surface
- }
- deriving (Eq, Ord, Show)
diff --git a/src/Wetterhorn/Core/W.hs b/src/Wetterhorn/Core/W.hs
deleted file mode 100644
index 862f9fa..0000000
--- a/src/Wetterhorn/Core/W.hs
+++ /dev/null
@@ -1,379 +0,0 @@
-{-# LANGUAGE DuplicateRecordFields #-}
-
-module Wetterhorn.Core.W where
-
-import Control.Arrow (Arrow (first))
-import Control.Monad ((<=<))
-import Control.Monad.RWS (MonadIO (liftIO), MonadReader (..), MonadState, modify)
-import Control.Monad.Reader (ReaderT (runReaderT))
-import Control.Monad.State (StateT (runStateT), gets, modify')
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.Maybe
-import Data.Data (TypeRep, Typeable, cast, tyConModule, tyConName, tyConPackage)
-import Data.Default.Class (Default, def)
-import Data.Kind (Constraint, Type)
-import Data.Map (Map)
-import qualified Data.Map as M
-import Data.Maybe (fromMaybe, mapMaybe)
-import Data.Proxy
-import Data.Set (Set)
-import qualified Data.Set as Set
-import Foreign (Ptr, StablePtr, intPtrToPtr, ptrToIntPtr)
-import Text.Printf (printf)
-import Text.Read hiding (lift)
-import Type.Reflection (someTypeRep, someTypeRepTyCon)
-import Wetterhorn.Core.ButtonEvent (ButtonEvent)
-import Wetterhorn.Core.KeyEvent
-import Wetterhorn.Core.SurfaceEvent
-import Wetterhorn.Foreign.ForeignInterface (ForeignInterface)
-import qualified Wetterhorn.Foreign.ForeignInterface as ForeignInterface
-import Wetterhorn.Foreign.WlRoots (Surface, WlrSeat)
-import Wetterhorn.StackSet hiding (layout)
-import qualified Wetterhorn.StackSet as StackSet
-
-data RationalRect = RationalRect Rational Rational Rational Rational
-
--- | Wrapper for a message. Messages are sent to layout and layouts are supposed
--- to handle them. This hides a typeable parameter.
-data Message where
- Message :: (Typeable a) => a -> Message
-
--- | casts a message to a type.
-fromMessage :: (Typeable a) => Message -> Maybe a
-fromMessage (Message t) = cast t
-
--- | Wraps a type in a message.
-toMessage :: (Typeable a) => a -> Message
-toMessage = Message
-
-class (Typeable l) => HandleMessage l where
- handleMessage :: Message -> l -> MaybeT W l
- handleMessage _ = return
-
-newtype Window = Window
- { surface :: Surface
- }
- deriving (Show, Ord, Eq, Read)
-
--- | Types of this class "lay out" windows by assigning rectangles and handle
--- messages.
-class (Typeable l, HandleMessage l) => LayoutClass l where
- -- | Constraints on the type to lay out. Sometimes a layout requires the 'a'
- -- type to be "Ord", other times "Eq", this is the mechanism by which this
- -- constraint is expressed.
- type LayoutConstraint l :: Type -> Constraint
-
- -- | Runs the layout in an impure way returning a modified layout and the list
- -- of windows to their rectangles under a monad.
- runLayout :: (LayoutConstraint l a) => Stack a -> l -> W (l, [(a, RationalRect)])
-
- readLayout :: String -> Maybe l
- default readLayout :: (Read l) => String -> Maybe l
- readLayout = readMaybe
-
- serializeLayout :: l -> String
- default serializeLayout :: (Show l) => l -> String
- serializeLayout = show
-
- description :: l -> String
- default description :: (Show l) => l -> String
- description = show
- {-# MINIMAL runLayout #-}
-
--- | Lifts a pure-layout implementation to a signature that complies with
--- 'runLayout'
-pureLayout ::
- (Stack a -> l -> [(a, RationalRect)]) ->
- Stack a ->
- l ->
- W (l, [(a, RationalRect)])
-pureLayout fn as l = return (l, fn as l)
-
--- A Layout which hides the layout parameter under an existential type and
--- asserts the layout hidden can work with Window types.
-data WindowLayout
- = forall l a.
- (LayoutClass l, LayoutConstraint l a, a ~ Window) =>
- WindowLayout l
-
-runWindowLayout :: Stack Window -> WindowLayout -> W (WindowLayout, [(Window, RationalRect)])
-runWindowLayout as (WindowLayout l) = first WindowLayout <$> runLayout as l
-
-handleWindowMessage :: Message -> WindowLayout -> MaybeT W WindowLayout
-handleWindowMessage m (WindowLayout l) = WindowLayout <$> handleMessage m l
-
--- | Using the 'Layout' as a witness, parse existentially wrapped windows
--- from a 'String'.
-readWindowLayout :: WindowLayout -> String -> WindowLayout
-readWindowLayout (WindowLayout l) s
- | (Just x) <- readLayout s =
- WindowLayout (asTypeOf x l)
-readWindowLayout l _ = l
-
--- | Serializes a window layout to a string.
-serializeWindowLayout :: WindowLayout -> String
-serializeWindowLayout (WindowLayout l) = serializeLayout l
-
-type ScreenId = ()
-
-type ScreenDetail = ()
-
-type Tag = String
-
-newtype ReadPtr a = ReadPtr (Ptr ())
-
-instance Read (ReadPtr a) where
- readPrec = fmap (ReadPtr . intPtrToPtr) readPrec
-
-instance Show (ReadPtr a) where
- show (ReadPtr ptr) = show (ptrToIntPtr ptr)
-
-type Wetterhorn = StablePtr (Context, State)
-
-data Context = Context
- { ctxForeignInterface :: ForeignInterface,
- ctxConfig :: Config WindowLayout
- }
-
-defaultHooks :: Hooks
-defaultHooks =
- Hooks
- { keyHook = \_ -> return (),
- surfaceHook = handleSurface,
- buttonHook = \_ -> return ()
- }
-
-defaultConfig :: Config ()
-defaultConfig =
- Config
- { hooks = defaultHooks,
- layout = (),
- resetHook = return ()
- }
-
-data Hooks = Hooks
- { keyHook :: KeyEvent -> W (),
- surfaceHook :: SurfaceEvent -> W (),
- buttonHook :: ButtonEvent -> W ()
- }
-
-data Config l = Config
- { layout :: l,
- hooks :: Hooks,
- resetHook :: W ()
- }
-
--- | Typeclass defining the set of types which can be used as state extensions
--- to the W monad. These state extensions may be persistent or not.
---
--- There are default implementations for all methods if the type implements
--- Read, Show and Default,
-class (Typeable a) => ExtensionClass a where
- -- | The initial value used for the first time an extension is 'gotten' or
- -- demarshalling fails.
- initialValue :: a
-
- -- | Transforms a type into a string. If the type cannot be marshalled, this
- -- function should return Nothing.
- --
- -- If a type cannot be marshalled, it cannot persist across hot reloads.
- marshalExtension :: a -> Maybe String
-
- -- | Reads an extension from a string. If this type is not marshallable or
- -- reading fails, this function should return Nothing.
- demarshalExtension :: String -> Maybe a
-
- -- | If the type implements Default, use the default implementation.
- default initialValue :: (Default a) => a
- initialValue = def
-
- -- | If the type implements Show, use show for the marshalling.
- default marshalExtension :: (Show a) => a -> Maybe String
- marshalExtension = Just . show
-
- -- | If the type implements Read, use read for the demarshalling.
- default demarshalExtension :: (Read a) => String -> Maybe a
- demarshalExtension = readMaybe
-
-data StateExtension where
- StateExtension :: (ExtensionClass a) => a -> StateExtension
-
--- | Puts a state extension.
-xput :: forall a m. (ExtensionClass a, Wlike m) => a -> m ()
-xput val = liftW $ do
- modify' $ \state@State {extensibleState = extensibleState} ->
- state
- { extensibleState =
- M.insert
- ( xRepr (Proxy :: Proxy a)
- )
- (Right $ StateExtension val)
- extensibleState
- }
-
--- | Modifies a state extension.
-xmodify :: forall a m. (ExtensionClass a, Wlike m) => (a -> a) -> m ()
-xmodify fn = xput . fn =<< xget
-
--- | Modifies a state extension in the monadic context.
-xmodifyM :: forall a m. (ExtensionClass a, Wlike m) => (a -> m a) -> m ()
-xmodifyM fn = (xput <=< fn) =<< xget
-
--- | Produces a string representation of a type used to key into the extensible
--- state map.
-xRepr :: forall proxy a. (ExtensionClass a) => proxy a -> String
-xRepr _ = tyconToStr $ someTypeRepTyCon (someTypeRep (Proxy :: Proxy a))
- where
- tyconToStr tc =
- printf "%s.%s.%s" (tyConPackage tc) (tyConModule tc) (tyConName tc)
-
--- | Gets a state extension.
-xget :: forall a m. (ExtensionClass a, Wlike m) => m a
-xget = do
- xs <- liftW $ gets extensibleState
- case M.lookup (xRepr (Proxy :: Proxy a)) xs of
- Just (Right (StateExtension a)) -> return (fromMaybe initialValue (cast a))
- Just (Left str) ->
- let v = fromMaybe initialValue (demarshalExtension str)
- in xput v >> return v
- Nothing ->
- xput (initialValue :: a) >> return initialValue
-
-xgets :: forall a b m. (ExtensionClass a, Wlike m) => (a -> b) -> m b
-xgets fn = fn <$> xget
-
--- State as it is marshalled. Used for derived instances of Show and Read.
-data MarshalledState
- = MarshalledState
- (StackSet ScreenId ScreenDetail Tag String Window)
- (Set Window)
- [(String, String)]
- deriving (Show, Read)
-
-data State = State
- { -- The datastructure containing the state of the windows.
- mapped :: StackSet ScreenId ScreenDetail Tag WindowLayout Window,
- -- | All the windows wetterhorn knows about, even if they are not mapped.
- allWindows :: Set Window,
- -- | Current set of hooks. The initial hooks are provided by the
- -- configuration, but the hooks can change during operation. This is how key
- -- sequences can be mapped.
- currentHooks :: Hooks,
- -- | Map from the typerep string to the state extension.
- extensibleState :: Map String (Either String StateExtension)
- }
-
--- | Initializes a "cold" state from a configuration. A cold state is the
--- initial state on startup. It is constrasted with a "hot" state, which is a
--- persisted state after a hot-reload.
-initColdState :: Config WindowLayout -> IO State
-initColdState Config {layout = layout, hooks = hooks} =
- return $
- State
- ( StackSet (Screen () () (Workspace "0" layout (Stack [] []))) [] []
- )
- mempty
- hooks
- mempty
-
--- | Marshals the serializable parts of the state to a string. This happens
--- during a hot-reload where some state must be saved to persist across hot
--- reloads.
-marshalState :: State -> String
-marshalState
- ( State
- { mapped = mapped,
- allWindows = allWindows,
- extensibleState = xs
- }
- ) =
- show $
- MarshalledState
- (mapLayout serializeWindowLayout mapped)
- allWindows
- (mapMaybe (\(k, v) -> (k,) <$> doMarshalEx v) (M.toList xs))
- where
- doMarshalEx (Left s) = Just s
- doMarshalEx (Right (StateExtension a)) = marshalExtension a
-
--- | Demarshals the string from "marshalState" into a state. Uses the provided
--- config to fill out non-persistent parts of the state.
-demarshalState :: Config WindowLayout -> String -> State
-demarshalState Config {hooks = hooks, layout = layout} str =
- State mapped allWindows hooks xs
- where
- ( MarshalledState
- (mapLayout (readWindowLayout layout) -> mapped)
- allWindows
- (fmap Left . M.fromList -> xs)
- ) = read str
-
--- | This is _the_ main monad used for Wetterhorn operations. Contains
--- everything required to operate. Contains the state, configuration and
--- interface to foreign code.
-newtype W a = W (ReaderT Context (StateT State IO) a)
- deriving (Functor, Applicative, Monad, MonadState State, MonadIO)
-
--- | Let Config be the thing W is a reader for. There is already a way to get
--- the foreign interface in the context.
-instance MonadReader (Config WindowLayout) W where
- local fn (W r) = W $ local (\(Context fi conf) -> Context fi (fn conf)) r
- ask = W $ ctxConfig <$> ask
-
-runW :: W a -> (Context, State) -> IO (a, State)
-runW (W fn) (ctx, st) = runStateT (runReaderT fn ctx) st
-
-foreignInterface :: W ForeignInterface
-foreignInterface = W $ ctxForeignInterface <$> ask
-
-getSeat :: W (Ptr WlrSeat)
-getSeat = (wio . ForeignInterface.getSeat) =<< foreignInterface
-
-requestHotReload :: W ()
-requestHotReload = (wio . ForeignInterface.requestHotReload) =<< foreignInterface
-
-requestExit :: Int -> W ()
-requestExit ec = (wio . flip ForeignInterface.requestExit ec) =<< foreignInterface
-
-shellExec :: String -> W ()
-shellExec = wio . ForeignInterface.doShellExec
-
-wio :: IO a -> W a
-wio = liftIO
-
--- | Type class to lift an arbitrary 'W' computation into another monad.
-class (Monad m) => Wlike m where
- liftW :: W a -> m a
-
--- | Trivial instance of W for Wlike.
-instance Wlike W where
- liftW = id
-
--- Default implementations for common handlers.
-
--- | handles a new surface event. This updates the state to reflect how it
--- should look in the harness.
-handleSurface :: SurfaceEvent -> W ()
-handleSurface (SurfaceEvent state (Window -> win)) =
- case state of
- Destroy ->
- modify $
- \st@State
- { allWindows = allWindows,
- mapped = mapped
- } ->
- st
- { allWindows = Set.delete win allWindows,
- mapped = StackSet.delete win mapped
- }
- Unmap -> modify $
- \st@State {mapped = mapped} ->
- st
- { mapped = StackSet.delete win mapped
- }
- Map -> modify $
- \st@State {mapped = mapped, allWindows = allWindows} ->
- st
- { mapped = StackSet.insertTiled win mapped,
- allWindows = Set.insert win allWindows
- }
diff --git a/src/Wetterhorn/Dsl/Bind.hs b/src/Wetterhorn/Dsl/Bind.hs
deleted file mode 100644
index 0b6adaf..0000000
--- a/src/Wetterhorn/Dsl/Bind.hs
+++ /dev/null
@@ -1,128 +0,0 @@
--- | eDSL for the 'bind' function. The 'bind' function provides an easy way to
--- bind certain actions to other actions.
-module Wetterhorn.Dsl.Bind
- ( bind,
- (.+),
- MatchEvent (..),
- Modifier (..),
- released,
- weak,
- run,
- modifierToMask,
- module X,
- )
-where
-
-import Control.Monad
-import Control.Monad.Trans
-import Data.Bits
-import Data.Word
-import Wetterhorn.Core.ButtonEvent (ButtonEvent(..))
-import qualified Wetterhorn.Core.ButtonEvent as ButtonEvent
-import Wetterhorn.Core.KeyEvent (KeyEvent(..))
-import qualified Wetterhorn.Core.KeyEvent as KeyEvent
-import Wetterhorn.Core.W
-import Wetterhorn.Dsl.Buttons as X
-import Wetterhorn.Dsl.Input
-
-class MatchEvent m where
- matches :: m -> InputEvent -> W Bool
-
-instance MatchEvent (InputEvent -> W Bool) where
- matches = ($)
-
-instance MatchEvent Char where
- matches ch (InputKeyEvent ke) = return $ KeyEvent.codepoint ke == ch
- matches _ _ = return False
-
-instance MatchEvent Button where
- matches (Button b) (InputButtonEvent be) =
- return $ ButtonEvent.button be == b
- matches _ _ = return False
-
--- | Enumeration of possible modifiers.
---
--- ModX can be used for extra user-defined modifiers which are not standard xkb
--- modifiers.
-data Modifier
- = Shift
- | Lock
- | Control
- | Mod1
- | Mod2
- | Mod3
- | Mod4
- | Mod5
- | ModX Int
- deriving (Eq, Ord, Show, Read)
-
--- | Converts a modifier to its associated mask.
-modifierToMask :: Modifier -> Word32
-modifierToMask m =
- 1
- `shiftL` case m of
- Shift -> 0
- Lock -> 1
- Control -> 2
- Mod1 -> 3
- Mod2 -> 4
- Mod3 -> 5
- Mod4 -> 6
- Mod5 -> 7
- ModX b -> b + 8
-
-released :: (MatchEvent m) => m -> InputEvent -> W Bool
-released me ev | not (isPressEvent ev) = matches me ev
-released _ _ = return False
-
-data MatchModifiers = MatchModifiers
- { weakModifierMatch :: Bool,
- modifierMask :: Word32,
- baseMatch :: InputEvent -> W Bool
- }
-
-instance MatchEvent MatchModifiers where
- matches (MatchModifiers weak bits base) ev = do
- mods <- getMods ev
- b <- liftW $ base ev
-
- return $
- b
- && ( (not weak && mods == bits)
- || (weak && (bits .&. mods == bits))
- )
- where
- getMods (InputButtonEvent (ButtonEvent {ButtonEvent.modifiers = mods})) = return mods
- getMods (InputKeyEvent (KeyEvent {KeyEvent.modifiers = mods})) = return mods
- getMods _ = getModifierState
-
-class LiftMatchModifiers a where
- toModifiers :: a -> MatchModifiers
- default toModifiers :: (MatchEvent a) => a -> MatchModifiers
- toModifiers = MatchModifiers False 0 . matches
-
-instance LiftMatchModifiers MatchModifiers where
- toModifiers = id
-
-instance LiftMatchModifiers Char
-
-instance LiftMatchModifiers Button
-
--- toModifiers ch = MatchModifiers False 0 (matches ch)
-
-(.+) :: (LiftMatchModifiers mods) => Modifier -> mods -> MatchModifiers
-(.+) modifier (toModifiers -> (MatchModifiers b mask base)) =
- MatchModifiers b (mask .|. modifierToMask modifier) base
-
-infixr 9 .+
-
-bind :: (MatchEvent match) => InputEvent -> match -> InputM spy () -> InputM spy ()
-bind ev match action = do
- matches' <- liftW $ matches match ev
- when matches' (action >> continue)
-
-weak :: MatchModifiers -> MatchModifiers
-weak m = m {weakModifierMatch = True}
-
-run :: W () -> InputM spy ()
-run = liftW
diff --git a/src/Wetterhorn/Dsl/Buttons.hsc b/src/Wetterhorn/Dsl/Buttons.hsc
deleted file mode 100644
index c3e049c..0000000
--- a/src/Wetterhorn/Dsl/Buttons.hsc
+++ /dev/null
@@ -1,229 +0,0 @@
-module Wetterhorn.Dsl.Buttons where
-
-import Data.Word
-
-#include </usr/include/linux/input-event-codes.h>
-
-data Button = Button Word32
-
-btnMisc :: Button
-btnMisc = Button #const BTN_MISC
-
-btn0 :: Button
-btn0 = Button #const BTN_0
-
-btn1 :: Button
-btn1 = Button #const BTN_1
-
-btn2 :: Button
-btn2 = Button #const BTN_2
-
-btn3 :: Button
-btn3 = Button #const BTN_3
-
-btn4 :: Button
-btn4 = Button #const BTN_4
-
-btn5 :: Button
-btn5 = Button #const BTN_5
-
-btn6 :: Button
-btn6 = Button #const BTN_6
-
-btn7 :: Button
-btn7 = Button #const BTN_7
-
-btn8 :: Button
-btn8 = Button #const BTN_8
-
-btn9 :: Button
-btn9 = Button #const BTN_9
-
-btnMouse :: Button
-btnMouse = Button #const BTN_MOUSE
-
-btnLeft :: Button
-btnLeft = Button #const BTN_LEFT
-
-btnRight :: Button
-btnRight = Button #const BTN_RIGHT
-
-btnMiddle :: Button
-btnMiddle = Button #const BTN_MIDDLE
-
-btnSide :: Button
-btnSide = Button #const BTN_SIDE
-
-btnExtra :: Button
-btnExtra = Button #const BTN_EXTRA
-
-btnForward :: Button
-btnForward = Button #const BTN_FORWARD
-
-btnBack :: Button
-btnBack = Button #const BTN_BACK
-
-btnTask :: Button
-btnTask = Button #const BTN_TASK
-
-btnJoystick :: Button
-btnJoystick = Button #const BTN_JOYSTICK
-
-btnTrigger :: Button
-btnTrigger = Button #const BTN_TRIGGER
-
-btnThumb :: Button
-btnThumb = Button #const BTN_THUMB
-
-btnThumb2 :: Button
-btnThumb2 = Button #const BTN_THUMB2
-
-btnTop :: Button
-btnTop = Button #const BTN_TOP
-
-btnTop2 :: Button
-btnTop2 = Button #const BTN_TOP2
-
-btnPinkie :: Button
-btnPinkie = Button #const BTN_PINKIE
-
-btnBase :: Button
-btnBase = Button #const BTN_BASE
-
-btnBase2 :: Button
-btnBase2 = Button #const BTN_BASE2
-
-btnBase3 :: Button
-btnBase3 = Button #const BTN_BASE3
-
-btnBase4 :: Button
-btnBase4 = Button #const BTN_BASE4
-
-btnBase5 :: Button
-btnBase5 = Button #const BTN_BASE5
-
-btnBase6 :: Button
-btnBase6 = Button #const BTN_BASE6
-
-btnDead :: Button
-btnDead = Button #const BTN_DEAD
-
-btnGamepad :: Button
-btnGamepad = Button #const BTN_GAMEPAD
-
-btnSouth :: Button
-btnSouth = Button #const BTN_SOUTH
-
-btnA :: Button
-btnA = Button #const BTN_A
-
-btnEast :: Button
-btnEast = Button #const BTN_EAST
-
-btnB :: Button
-btnB = Button #const BTN_B
-
-btnC :: Button
-btnC = Button #const BTN_C
-
-btnNorth :: Button
-btnNorth = Button #const BTN_NORTH
-
-btnX :: Button
-btnX = Button #const BTN_X
-
-btnWest :: Button
-btnWest = Button #const BTN_WEST
-
-btnY :: Button
-btnY = Button #const BTN_Y
-
-btnZ :: Button
-btnZ = Button #const BTN_Z
-
-btnTl :: Button
-btnTl = Button #const BTN_TL
-
-btnTr :: Button
-btnTr = Button #const BTN_TR
-
-btnTl2 :: Button
-btnTl2 = Button #const BTN_TL2
-
-btnTr2 :: Button
-btnTr2 = Button #const BTN_TR2
-
-btnSelect :: Button
-btnSelect = Button #const BTN_SELECT
-
-btnStart :: Button
-btnStart = Button #const BTN_START
-
-btnMode :: Button
-btnMode = Button #const BTN_MODE
-
-btnThumbl :: Button
-btnThumbl = Button #const BTN_THUMBL
-
-btnThumbr :: Button
-btnThumbr = Button #const BTN_THUMBR
-
-btnDigi :: Button
-btnDigi = Button #const BTN_DIGI
-
-btnToolPen :: Button
-btnToolPen = Button #const BTN_TOOL_PEN
-
-btnToolRubber :: Button
-btnToolRubber = Button #const BTN_TOOL_RUBBER
-
-btnToolBrush :: Button
-btnToolBrush = Button #const BTN_TOOL_BRUSH
-
-btnToolPencil :: Button
-btnToolPencil = Button #const BTN_TOOL_PENCIL
-
-btnToolAirbrush :: Button
-btnToolAirbrush = Button #const BTN_TOOL_AIRBRUSH
-
-btnToolFinger :: Button
-btnToolFinger = Button #const BTN_TOOL_FINGER
-
-btnToolMouse :: Button
-btnToolMouse = Button #const BTN_TOOL_MOUSE
-
-btnToolLens :: Button
-btnToolLens = Button #const BTN_TOOL_LENS
-
-btnToolQuinttap :: Button
-btnToolQuinttap = Button #const BTN_TOOL_QUINTTAP
-
-btnStylus3 :: Button
-btnStylus3 = Button #const BTN_STYLUS3
-
-btnTouch :: Button
-btnTouch = Button #const BTN_TOUCH
-
-btnStylus :: Button
-btnStylus = Button #const BTN_STYLUS
-
-btnStylus2 :: Button
-btnStylus2 = Button #const BTN_STYLUS2
-
-btnToolDoubletap :: Button
-btnToolDoubletap = Button #const BTN_TOOL_DOUBLETAP
-
-btnToolTripletap :: Button
-btnToolTripletap = Button #const BTN_TOOL_TRIPLETAP
-
-btnToolQuadtap :: Button
-btnToolQuadtap = Button #const BTN_TOOL_QUADTAP
-
-btnWheel :: Button
-btnWheel = Button #const BTN_WHEEL
-
-btnGearDown :: Button
-btnGearDown = Button #const BTN_GEAR_DOWN
-
-btnGearUp :: Button
-btnGearUp = Button #const BTN_GEAR_UP
diff --git a/src/Wetterhorn/Dsl/Input.hs b/src/Wetterhorn/Dsl/Input.hs
deleted file mode 100644
index 1a0c294..0000000
--- a/src/Wetterhorn/Dsl/Input.hs
+++ /dev/null
@@ -1,286 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-
-module Wetterhorn.Dsl.Input
- ( InputM,
- InputEvent (..),
- InputProxy (..),
- NoProxy,
- withProxies,
- forwardEvent,
- forwardKey,
- whenKeyEvent,
- whenButtonEvent,
- useInputHandler,
- unwrap,
- filterEvent,
- isPressEvent,
- nextInputEventThat,
- replayEvents,
- isKeyEvent,
- nextInputPressEvent,
- continue,
- nextInputEvent,
- getModifierState,
- )
-where
-
-import Control.Concurrent (threadDelay)
-import Control.Monad
-import Control.Monad.Cont (MonadCont)
-import Control.Monad.Loops (andM)
-import Control.Monad.RWS
- ( MonadIO (liftIO),
- MonadReader (ask),
- MonadState (get),
- MonadTrans (lift),
- RWST,
- execRWST,
- gets,
- modify,
- )
-import Control.Monad.Trans.Cont
-import Control.Monad.Trans.Maybe (MaybeT (runMaybeT))
-import Data.IORef (newIORef, readIORef, writeIORef)
-import Data.Proxy
-import Data.Word (Word32)
-import qualified Wetterhorn.Core.ButtonEvent as ButtonEvent
-import qualified Wetterhorn.Core.KeyEvent as KeyEvent
-import Wetterhorn.Core.W (W (..))
-import qualified Wetterhorn.Core.W as W
-import Wetterhorn.Foreign.WlRoots (guardNull, wlrKeyboardGetModifiers, wlrSeatGetKeyboard, wlrSeatKeyboardNotifyKey, wlrSeatSetKeyboard)
-
-class InputProxy (spy :: k) where
- onKeyEvent :: Proxy spy -> InputEvent -> MaybeT W InputEvent
-
-instance (InputProxy h, InputProxy t) => InputProxy (h ': t) where
- onKeyEvent _ = onKeyEvent (Proxy :: Proxy h) <=< onKeyEvent (Proxy :: Proxy t)
-
-instance InputProxy '[] where
- onKeyEvent _ = return
-
-data NoProxy
-
-instance InputProxy NoProxy where
- onKeyEvent _ = return
-
-instance (InputProxy s1, InputProxy s2) => InputProxy (s1, s2) where
- onKeyEvent proxy = onKeyEvent (fmap fst proxy) <=< onKeyEvent (fmap snd proxy)
-
--- | Union of event types.
-data InputEvent
- = InputButtonEvent ButtonEvent.ButtonEvent
- | InputKeyEvent KeyEvent.KeyEvent
-
--- | Context for the input.
-newtype InputContext spy = InputContext
- { -- | Top of the input routine. Used in "continue" statement.
- inputTop :: InputM spy ()
- }
-
-newtype InputState spy = InputState
- { inputSource :: InputM spy InputEvent
- }
-
--- | Input monad for handling all kinds of input.
-newtype InputM spy a = InputM (ContT () (RWST (InputContext spy) () (InputState spy) W) a)
- deriving (Monad, Functor, Applicative, MonadCont, MonadIO)
-
-instance MonadFail (InputM spy) where
- fail _ = continue
-
--- | Lifts a W action to an InputM action.
-instance W.Wlike (InputM spy) where
- liftW = InputM . lift . lift
-
--- | Resets the input handler to the top.
-continue :: InputM spy a
-continue = do
- (InputContext {inputTop = (InputM top)}) <- InputM ask
- InputM $ shiftT (\_ -> resetT top)
-
--- | Forwards the given key event to the focused window.
-forwardKey :: KeyEvent.KeyEvent -> W ()
-forwardKey keyEvent = do
- seatPtr <- W.getSeat
- W.wio $ do
- wlrSeatSetKeyboard
- seatPtr
- (KeyEvent.device keyEvent)
-
- wlrSeatKeyboardNotifyKey
- seatPtr
- (KeyEvent.timeMs keyEvent)
- (KeyEvent.keycode keyEvent)
- ( case KeyEvent.state keyEvent of
- KeyEvent.KeyReleased -> 0
- _ -> 1
- )
-
--- | Executes a function if the input event is a key event. If it is not a key
--- event, then nothing happens.
-whenKeyEvent :: (Monad m) => InputEvent -> (KeyEvent.KeyEvent -> m ()) -> m ()
-whenKeyEvent (InputKeyEvent ke) = ($ ke)
-whenKeyEvent _ = const (return ())
-
--- | Executes a function in the input event is a button event. If it is not a
--- button event, then nothing happens.
-whenButtonEvent ::
- (Monad m) => InputEvent -> (ButtonEvent.ButtonEvent -> m ()) -> m ()
-whenButtonEvent (InputButtonEvent be) = ($ be)
-whenButtonEvent _ = const (return ())
-
--- | Forwards the given input event to focused window.
-forwardEvent :: (W.Wlike m) => InputEvent -> m ()
-forwardEvent = \case
- InputKeyEvent kv -> W.liftW $ forwardKey kv
- InputButtonEvent _ -> return ()
-
--- | "Unwraps" a maybe. If the maybe is present, the handler proceeds. If the
--- maybe is not present, the handler restarts execution from the top.
-unwrap :: Maybe a -> InputM spy a
-unwrap (Just val) = return val
-unwrap Nothing = continue
-
--- | Runs the series of events from the top as if they were input.
-replayEvents :: [InputEvent] -> InputM spy ()
-replayEvents events = do
- ioref <- liftIO (newIORef events)
-
- (InputM oldInput) <- InputM $ gets inputSource
-
- let newInput =
- InputM $
- shiftT
- ( \thingToDo -> do
- r <- liftIO (readIORef ioref)
- case r of
- [] -> do
- modify $ \st -> st {inputSource = InputM oldInput}
- a <- oldInput
- lift (thingToDo a)
- (a : as) -> do
- liftIO (writeIORef ioref as)
- lift (thingToDo a)
- )
-
- InputM $ modify $ \st -> st {inputSource = newInput}
- where
- delay to act = liftIO (threadDelay to) >> act
-
--- | Call in the reset handler with the InputM handler you wolud like to use.
-useInputHandler :: (InputProxy spy) => InputM spy () -> W ()
-useInputHandler (forever -> top@(InputM ctop)) = do
- void $ execRWST (runContT ctop return) (InputContext top) (InputState useSeatEvents)
-
--- | Returns the next input event that's either a kep press or a button press.
-nextInputPressEvent :: InputM spy InputEvent
-nextInputPressEvent = nextInputEventThat (andM [isPressEvent, not . modifierKey])
-
-modifierKey :: InputEvent -> Bool
-modifierKey (InputKeyEvent (KeyEvent.KeyEvent {codepoint = '\NUL'})) = True
-modifierKey _ = False
-
-nextInputEventThat :: (InputEvent -> Bool) -> InputM spy InputEvent
-nextInputEventThat fn =
- nextInputEvent
- >>= ( \ie ->
- if fn ie
- then return ie
- else forwardEvent ie >> nextInputEventThat fn
- )
-
-isKeyEvent :: InputEvent -> Bool
-isKeyEvent (InputKeyEvent _) = True
-isKeyEvent _ = False
-
-isPressEvent :: InputEvent -> Bool
-isPressEvent (InputButtonEvent be)
- | ButtonEvent.state be == ButtonEvent.ButtonPressed =
- True
-isPressEvent (InputKeyEvent ke)
- | KeyEvent.state ke == KeyEvent.KeyPressed =
- True
-isPressEvent _ = False
-
--- | Returns the event only if it matches the filter. If it does not match the
--- filter, execution resets to the top.
-filterEvent :: (InputEvent -> Bool) -> InputEvent -> InputM spy InputEvent
-filterEvent fn ev | fn ev = return ev
-filterEvent _ _ = continue
-
-getModifierState :: W Word32
-getModifierState = do
- seat <- W.getSeat
- keyboard <- W.wio $ wlrSeatGetKeyboard seat
- maybe (return 0) (W.wio . wlrKeyboardGetModifiers) (guardNull keyboard)
-
-nextInputEvent :: InputM spy InputEvent
-nextInputEvent = join $ InputM $ gets inputSource
-
-withProxies :: Proxy spy -> InputM spy a -> InputM spy a
-withProxies _ = id
-
--- | Gets the next input event.
-useSeatEvents :: forall spy. (InputProxy spy) => InputM spy InputEvent
-useSeatEvents =
- InputM $
- shiftT
- ( \thingToDo -> do
- putButtonHandler $ \be -> do
- runSpies thingToDo (InputButtonEvent be)
-
- putKeyHandler $ \ke -> do
- runSpies thingToDo (InputKeyEvent ke)
- )
- where
- runSpies fn ev = do
- evM <- lift $ runMaybeT (onKeyEvent (Proxy :: Proxy spy) ev)
- mapM_
- ( \ev' -> do
- clearButtonHandler
- clearKeyHandler
- fn ev'
- )
- evM
-
- clearButtonHandler =
- lift $
- modify $ \st ->
- st
- { W.currentHooks =
- (W.currentHooks st)
- { W.buttonHook = const (return ())
- }
- }
-
- clearKeyHandler =
- lift $
- modify $ \st ->
- st
- { W.currentHooks =
- (W.currentHooks st)
- { W.keyHook = const (return ())
- }
- }
-
- putButtonHandler h = lift $ do
- (r, s) <- (,) <$> ask <*> get
- lift $
- modify $ \st ->
- st
- { W.currentHooks =
- (W.currentHooks st)
- { W.buttonHook = \be -> void (execRWST (h be) r s)
- }
- }
-
- putKeyHandler h = lift $ do
- (r, s) <- (,) <$> ask <*> get
- lift $
- modify $ \st ->
- st
- { W.currentHooks =
- (W.currentHooks st)
- { W.keyHook = \ke -> void (execRWST (h ke) r s)
- }
- }
diff --git a/src/Wetterhorn/Foreign.hs b/src/Wetterhorn/Foreign.hs
deleted file mode 100644
index 2d0a42c..0000000
--- a/src/Wetterhorn/Foreign.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-module Wetterhorn.Foreign
- ( TypedIntPtr (..),
- toPtr,
- fromPtr,
- )
-where
-
-import Foreign (IntPtr, Ptr)
-import qualified Foreign
-
-toPtr :: TypedIntPtr a -> Ptr a
-toPtr (TypedIntPtr ip) = Foreign.intPtrToPtr ip
-
-fromPtr :: Ptr a -> TypedIntPtr a
-fromPtr = TypedIntPtr . Foreign.ptrToIntPtr
-
-newtype TypedIntPtr a = TypedIntPtr IntPtr
- deriving (Show, Read, Eq, Ord, Num)
diff --git a/src/Wetterhorn/Foreign/Export.hs b/src/Wetterhorn/Foreign/Export.hs
deleted file mode 100644
index 51bd72b..0000000
--- a/src/Wetterhorn/Foreign/Export.hs
+++ /dev/null
@@ -1,208 +0,0 @@
--- | This module does not export anything. It exists simply to provide C-symbols
--- for the plugin.
-module Wetterhorn.Foreign.Export () where
-
-import Config
-import Control.Arrow (Arrow (first))
-import Control.Monad (forM_)
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Char8 as CH
-import Foreign
- ( Ptr,
- Storable (poke, pokeByteOff),
- Word32,
- Word8,
- deRefStablePtr,
- freeStablePtr,
- mallocBytes,
- newStablePtr,
- )
-import Foreign.C (CChar, CInt (..))
-import Wetterhorn.Core.ButtonEvent (ButtonEvent (ButtonEvent), ButtonState (ButtonPressed, ButtonReleased))
-import Wetterhorn.Core.KeyEvent (KeyEvent (..), KeyState (..))
-import Wetterhorn.Core.SurfaceEvent (SurfaceEvent (SurfaceEvent))
-import Wetterhorn.Core.W (W, Wetterhorn)
-import qualified Wetterhorn.Core.W as W
-import Wetterhorn.Foreign.ForeignInterface
-import Wetterhorn.Foreign.WlRoots
-
-type Wetter = (W.Config W.WindowLayout, W.State)
-
-toWetter :: (W.Context, W.State) -> (W.Config W.WindowLayout, W.State)
-toWetter = first W.ctxConfig
-
-runForeign :: (Wetter -> W ()) -> Wetterhorn -> IO Wetterhorn
-runForeign fn stblptr = do
- w@(ctx, st) <- deRefStablePtr stblptr
- freeStablePtr stblptr
- (_, state') <- W.runW (fn $ toWetter w) (ctx, st)
- newStablePtr (ctx, state')
-
-runForeignWithReturn ::
- (Storable a) => (Wetter -> W a) -> Ptr a -> Wetterhorn -> IO Wetterhorn
-runForeignWithReturn fn ptr stableptr = do
- w@(ctx, st) <- deRefStablePtr stableptr
- freeStablePtr stableptr
- (val, state') <- W.runW (fn $ toWetter w) (ctx, st)
- poke ptr val
- newStablePtr (ctx, state')
-
-runForeignWithReturn2 ::
- (Storable a, Storable b) =>
- (Wetter -> W (a, b)) ->
- Ptr a ->
- Ptr b ->
- Wetterhorn ->
- IO Wetterhorn
-runForeignWithReturn2 fn ptrA ptrB stableptr = do
- w@(ctx, st) <- deRefStablePtr stableptr
- freeStablePtr stableptr
- ((vA, vB), state') <- W.runW (fn $ toWetter w) (ctx, st)
- poke ptrA vA
- poke ptrB vB
- newStablePtr (ctx, state')
-
--- | This function is the implementation of the "hotstart" mechanism. It gives a
--- pointer to the previously marshalled state and the length of that array and
--- this function returns a Wetterhorn instance.
-foreign export ccall "plugin_hot_start"
- pluginHotStart ::
- Ptr CChar -> Word32 -> IO Wetterhorn
-
-pluginHotStart :: Ptr CChar -> Word32 -> IO Wetterhorn
-pluginHotStart chars len = do
- bs <- BS.packCStringLen (chars, fromIntegral len)
- foreignInterface <- getForeignInterface
- wtr <-
- newStablePtr
- ( W.Context foreignInterface config,
- W.demarshalState config (CH.unpack bs)
- )
- runForeign (\(conf, _) -> W.resetHook conf) wtr
-
--- | This function is called when a "coldstart" request is receieved. It just
--- calles the function "wetterhorn". This function should be defined in the main
--- code as it's sort-of the equivalent of XMonad's "main" function.
-foreign export ccall "plugin_cold_start"
- pluginColdStart :: IO Wetterhorn
-
-pluginColdStart :: IO Wetterhorn
-pluginColdStart = do
- foreignInterface <- getForeignInterface
- state <- W.initColdState config
- wtr <- newStablePtr (W.Context foreignInterface config, state)
- runForeign (\(conf, _) -> W.resetHook conf) wtr
-
--- | Marshals the opaque state to a C-style byte array and size pointer.
-foreign export ccall "plugin_marshal_state"
- pluginMarshalState :: Wetterhorn -> Ptr Word32 -> IO (Ptr Word8)
-
-pluginMarshalState :: Wetterhorn -> Ptr Word32 -> IO (Ptr Word8)
-pluginMarshalState stblptr outlen = do
- (_, st) <- deRefStablePtr stblptr
- let bs = CH.pack (W.marshalState st)
- ret <- mallocBytes (BS.length bs)
- poke outlen (fromIntegral $ BS.length bs)
- forM_ (zip [0 ..] (BS.unpack bs)) $ \(off, w8) -> do
- pokeByteOff ret off w8
- return ret
-
-foreign export ccall "plugin_handle_button"
- pluginHandleButton :: Ptr WlrPointerButtonEvent -> Word32 -> Wetterhorn -> IO Wetterhorn
-
-pluginHandleButton :: Ptr WlrPointerButtonEvent -> Word32 -> Wetterhorn -> IO Wetterhorn
-pluginHandleButton eventPtr modifiers = do
- runForeign $
- \( _,
- W.State {W.currentHooks = W.Hooks {buttonHook = buttonHook}}
- ) -> do
- event <- W.wio $
- runForeignDemarshal eventPtr $ do
- ButtonEvent
- <$> demarshal
- <*> demarshal
- <*> demarshal
- <*> pure modifiers
- <*> ( ( \u8 ->
- if (u8 :: Word8) == 0
- then ButtonReleased
- else ButtonPressed
- )
- <$> demarshal
- )
-
- buttonHook event
-
-foreign export ccall "plugin_handle_keybinding"
- pluginHandleKeybinding ::
- Ptr WlrInputDevice ->
- Ptr WlrEventKeyboardKey ->
- Word32 ->
- Word32 ->
- Word32 ->
- Ptr CInt ->
- Wetterhorn ->
- IO Wetterhorn
-
-pluginHandleKeybinding ::
- Ptr WlrInputDevice ->
- Ptr WlrEventKeyboardKey ->
- Word32 ->
- Word32 ->
- Word32 ->
- Ptr CInt ->
- Wetterhorn ->
- IO Wetterhorn
-pluginHandleKeybinding inputDevicePtr eventPtr mods sym cp =
- runForeignWithReturn $
- \( _,
- W.State {W.currentHooks = W.Hooks {keyHook = keyHook}}
- ) -> do
- event <- W.wio $
- runForeignDemarshal eventPtr $ do
- tMs <- demarshal
- kc <- demarshal
- _ <- (demarshal :: ForeignDemarshal Word32)
- keyState <- demarshal
- return $
- KeyEvent
- tMs
- kc
- (if keyState == (0 :: Word8) then KeyReleased else KeyPressed)
- mods
- sym
- (toEnum $ fromIntegral cp)
- inputDevicePtr
- keyHook event
- return 1
-
--- | Function exported to the harness to handle the mapping/unmapping/deletion
--- of an XDG surface.
-foreign export ccall "plugin_handle_surface"
- pluginHandleSurface ::
- Ptr WlrXdgSurface -> CInt -> Wetterhorn -> IO Wetterhorn
-
-pluginHandleSurface :: Ptr WlrXdgSurface -> CInt -> Wetterhorn -> IO Wetterhorn
-pluginHandleSurface p t =
- runForeign
- ( \(_, W.State {currentHooks = W.Hooks {surfaceHook = surfaceHook}}) ->
- surfaceHook $
- SurfaceEvent (toEnum $ fromIntegral t) (toSurface p)
- )
-
--- | Function exported to the harness to handle the mapping/unmapping/deletion
--- of an XWayland surface.
-foreign export ccall "plugin_handle_xwayland_surface"
- pluginHandleXWaylandSurface ::
- Ptr WlrXWaylandSurface -> CInt -> Wetterhorn -> IO Wetterhorn
-
-pluginHandleXWaylandSurface ::
- Ptr WlrXWaylandSurface -> CInt -> Wetterhorn -> IO Wetterhorn
-pluginHandleXWaylandSurface p t =
- runForeign
- ( \( _,
- W.State
- { currentHooks = W.Hooks {surfaceHook = surfaceHook}
- }
- ) -> surfaceHook $ SurfaceEvent (toEnum $ fromIntegral t) (toSurface p)
- )
diff --git a/src/Wetterhorn/Foreign/ForeignInterface.hs b/src/Wetterhorn/Foreign/ForeignInterface.hs
deleted file mode 100644
index 471e3a9..0000000
--- a/src/Wetterhorn/Foreign/ForeignInterface.hs
+++ /dev/null
@@ -1,81 +0,0 @@
-module Wetterhorn.Foreign.ForeignInterface
- ( getForeignInterface,
- ForeignInterface (..),
- ForeignDemarshal (..),
- runForeignDemarshal,
- demarshal,
- doShellExec,
- )
-where
-
-import Control.Monad.State (MonadState (get, put), MonadTrans (lift), StateT, evalStateT)
-import Data.Void (Void)
-import Foreign (Ptr, Storable (peek, sizeOf), castPtr, plusPtr)
-import Foreign.C (CChar, CInt (..))
-import Foreign.C.String
-import GHC.Exts (FunPtr)
-import Wetterhorn.Foreign.WlRoots
-
-newtype ForeignDemarshal a = ForeignDemarshal (StateT (Ptr ()) IO a)
- deriving (Functor, Monad, Applicative, MonadState (Ptr ()))
-
-runForeignDemarshal :: Ptr b -> ForeignDemarshal a -> IO a
-runForeignDemarshal p (ForeignDemarshal dm) = evalStateT dm (castPtr p)
-
-demarshal :: (Storable a) => ForeignDemarshal a
-demarshal = do
- ptr <- get
- val <- ForeignDemarshal $ lift $ peek $ castPtr ptr
- put (plusPtr ptr (sizeOf val))
- return val
-
-type CtxT = Ptr Void
-
-type ForeignCallGetPtr = CtxT -> IO (Ptr ())
-
-type ForeignCall = CtxT -> IO ()
-
-type ForeignCallStr = CtxT -> CString -> IO ()
-
-type ForeignCallInt = CtxT -> CInt -> IO ()
-
-foreign import ccall "get_foreign_interface" foreignInterfacePtr :: IO (Ptr ())
-
-foreign import ccall "dynamic" toForeignCall :: FunPtr ForeignCall -> ForeignCall
-
-foreign import ccall "dynamic" toForeignCallStr :: FunPtr ForeignCallStr -> ForeignCallStr
-
-foreign import ccall "dynamic" toForeignCallInt :: FunPtr ForeignCallInt -> ForeignCallInt
-
-foreign import ccall "dynamic" toForeignCallGetPtr :: FunPtr ForeignCallGetPtr -> ForeignCallGetPtr
-
-foreign import ccall "shell_exec" shellExec :: Ptr CChar -> IO ()
-
-data ForeignInterface = ForeignInterface
- { requestHotReload :: IO (),
- requestLog :: String -> IO (),
- requestExit :: Int -> IO (),
- getSeat :: IO (Ptr WlrSeat)
- }
-
-doShellExec :: String -> IO ()
-doShellExec str = withCString str shellExec
-
-getForeignInterface :: IO ForeignInterface
-getForeignInterface = do
- ptr <- foreignInterfacePtr
- runForeignDemarshal ptr $ do
- ctx <- demarshal
- requestHotReloadFn <- demarshal
- doLogFn <- demarshal
- doRequestExit <- demarshal
- getSeatFn <- demarshal
-
- return $
- ForeignInterface
- { requestHotReload = toForeignCall requestHotReloadFn ctx,
- requestLog = \str ->
- withCString str $ \cs -> toForeignCallStr doLogFn ctx cs,
- requestExit = toForeignCallInt doRequestExit ctx . fromIntegral,
- getSeat = castPtr <$> toForeignCallGetPtr getSeatFn ctx
- }
diff --git a/src/Wetterhorn/Foreign/WlRoots.hs b/src/Wetterhorn/Foreign/WlRoots.hs
deleted file mode 100644
index 0581b77..0000000
--- a/src/Wetterhorn/Foreign/WlRoots.hs
+++ /dev/null
@@ -1,67 +0,0 @@
-module Wetterhorn.Foreign.WlRoots where
-
-import Foreign (IntPtr, Ptr, Word32, intPtrToPtr, ptrToIntPtr, nullPtr)
-import Text.Read
-
-data WlrKeyboard
-
-data WlrPointer
-
-data WlrPointerButtonEvent
-
-data WlrSeat
-
-data WlrInputDevice
-
-data WlrEventKeyboardKey
-
-data WlrXdgSurface
-
-data WlrXWaylandSurface
-
-data Surface
- = XdgSurface (Ptr WlrXdgSurface)
- | XWaylandSurface (Ptr WlrXWaylandSurface)
- deriving (Ord, Eq)
-
-instance Show Surface where
- show (XdgSurface p) = show (XdgSerializeSurface (ptrToIntPtr p))
- show (XWaylandSurface p) = show (XWaylandSerializeSurface (ptrToIntPtr p))
-
-instance Read Surface where
- readPrec = fmap toSurf readPrec
- where
- toSurf (XdgSerializeSurface ip) = XdgSurface (intPtrToPtr ip)
- toSurf (XWaylandSerializeSurface ip) = XWaylandSurface (intPtrToPtr ip)
-
--- | Type which exists specifically to derive instances of read and show.
-data SerializableSurface
- = XdgSerializeSurface IntPtr
- | XWaylandSerializeSurface IntPtr
- deriving (Read, Show)
-
-class ForeignSurface a where
- toSurface :: Ptr a -> Surface
-
-instance ForeignSurface WlrXdgSurface where
- toSurface = XdgSurface
-
-instance ForeignSurface WlrXWaylandSurface where
- toSurface = XWaylandSurface
-
-guardNull :: Ptr a -> Maybe (Ptr a)
-guardNull p | p == nullPtr = Nothing
-guardNull p = Just p
-
-foreign import ccall "wlr_seat_set_keyboard" wlrSeatSetKeyboard ::
- Ptr WlrSeat -> Ptr WlrInputDevice -> IO ()
-
-foreign import ccall "wlr_seat_get_keyboard" wlrSeatGetKeyboard ::
- Ptr WlrSeat -> IO (Ptr WlrKeyboard)
-
-foreign import ccall "wlr_keyboard_get_modifiers" wlrKeyboardGetModifiers ::
- Ptr WlrKeyboard -> IO Word32
-
-foreign import ccall "wlr_seat_keyboard_notify_key"
- wlrSeatKeyboardNotifyKey ::
- Ptr WlrSeat -> Word32 -> Word32 -> Word32 -> IO ()
diff --git a/src/Wetterhorn/Keys/Macros.hs b/src/Wetterhorn/Keys/Macros.hs
deleted file mode 100644
index a794193..0000000
--- a/src/Wetterhorn/Keys/Macros.hs
+++ /dev/null
@@ -1,145 +0,0 @@
--- There are constraints used for better type-level enforced safety rules.
-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
-
-module Wetterhorn.Keys.Macros
- ( MacroSupport,
- macroStartStopKeybind,
- macroReplayKeybind,
- stopMacroRecording,
- startRecording,
- )
-where
-
-import Control.Monad.IO.Class (MonadIO (liftIO))
-import Control.Monad.Trans (MonadTrans (lift))
-import Data.Default.Class
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Type.Bool
-import Data.Type.Equality
-import Data.Word
-import Foreign (Ptr)
-import GHC.TypeError
-import Wetterhorn.Core.KeyEvent
-import Wetterhorn.Core.W
-import Wetterhorn.Dsl.Input
-import Wetterhorn.Foreign.WlRoots (WlrInputDevice)
-
-data RecordedKey = RecordedKey Word32 Word32 KeyState Word32 Word32 Char
- deriving (Read, Show)
-
-data MacrosState = MacrosState
- { macros :: Map String [RecordedKey],
- currentlyRecording :: Maybe String
- }
- deriving (Read, Show)
-
-instance Default MacrosState where
- def = MacrosState mempty def
-
-instance ExtensionClass MacrosState
-
-type family Find a ls where
- Find b (a : t) = (b == a) || Find b t
- Find _ '[] = False
-
--- | Provides a Vim-esque keybinding behavior for macro recording.
---
--- Designed to be used like:
---
--- bind ev (Mod1 .+ 'q') macroStartStopKeybind
-macroStartStopKeybind :: (HasMacroSupport spy) => InputM spy ()
-macroStartStopKeybind = do
- currentlyRecordingMacro
- >>= ( \case
- Just ch -> do
- liftIO $ putStrLn $ "Done Recording: " ++ ch
- stopMacroRecording
- Nothing -> do
- (InputKeyEvent (KeyEvent {codepoint = cp})) <- nextInputPressEvent
- liftIO $ putStrLn $ "Recording: " ++ [cp]
- startRecording [cp]
- )
-
--- | Provides a keybinding for replaying a macro.
---
--- Designed to be used like:
---
--- bind ev (weak $ Mod1 .+ '@') macroReplayKeybind
-macroReplayKeybind :: (HasMacroSupport spy) => InputM spy ()
-macroReplayKeybind = do
- ( InputKeyEvent
- (KeyEvent {codepoint = cp, device = device})
- ) <-
- nextInputPressEvent
- replayMacro device [cp]
-
-startRecording :: (Wlike m) => String -> m ()
-startRecording ch =
- xmodify
- ( \m@MacrosState {macros = macros} ->
- m
- { macros = Map.delete ch macros,
- currentlyRecording = Just ch
- }
- )
-
-stopMacroRecording :: (Wlike m) => m ()
-stopMacroRecording = xmodify (\m -> m {currentlyRecording = Nothing})
-
-currentlyRecordingMacro :: (Wlike m) => m (Maybe String)
-currentlyRecordingMacro = xgets currentlyRecording
-
-replayMacro :: Ptr WlrInputDevice -> String -> InputM spy ()
-replayMacro inputDevice s = do
- m <- liftW (Map.lookup s <$> xgets macros)
- -- 'tail' is to cut off the last keystroke which stops the recording.
- mapM_ (replayEvents . map toInputEvent . reverse . tail) m
- where
- toInputEvent :: RecordedKey -> InputEvent
- toInputEvent (RecordedKey ts kc st mo keysym cp) =
- InputKeyEvent $ KeyEvent ts kc st mo keysym cp inputDevice
-
-pushMacroKey :: (Wlike m) => KeyEvent -> m ()
-pushMacroKey ke = do
- cur <- xgets currentlyRecording
- whenJust cur $ \ch -> do
- let recordedKey = toRecordedKey ke
- in xmodify $ \m@MacrosState {macros = macros} ->
- m {macros = Map.insertWith (++) ch [recordedKey] macros}
- where
- whenJust (Just a) fn = fn a
- whenJust _ _ = return ()
-
- toRecordedKey (KeyEvent ts c s m keysym cp _) = RecordedKey ts c s m keysym cp
-
--- | Phantom type defining a proxy required to support macros.
-data MacroSupport
-
--- | Instance for macro support.
-instance InputProxy MacroSupport where
- onKeyEvent _ ie = do
- lift $ whenKeyEvent ie pushMacroKey
- return ie
-
-class HasMacroSupport t
-
-instance
- ( If
- (Find MacroSupport t)
- True
- ( TypeError
- ( Text "This Requires the Macro Proxy to be Enabled."
- :<>: Text "Please enable this by adding MacroSupport to your"
- :<>: Text "inputProxies list.\n"
- :<>: Text "i.e. Change "
- :<>: ShowType t
- :<>: Text " to "
- :<>: ShowType (MacroSupport ': t)
- )
- )
- ~ True
- ) =>
- HasMacroSupport t
-
-instance HasMacroSupport MacroSupport
diff --git a/src/Wetterhorn/Keys/MagicModifierKey.hs b/src/Wetterhorn/Keys/MagicModifierKey.hs
deleted file mode 100644
index 6bc8bb3..0000000
--- a/src/Wetterhorn/Keys/MagicModifierKey.hs
+++ /dev/null
@@ -1,50 +0,0 @@
-module Wetterhorn.Keys.MagicModifierKey where
-
-import Data.Data
-import Data.Default.Class
-import GHC.TypeNats
-import Wetterhorn.Core.KeyEvent
-import Wetterhorn.Core.W
-import Wetterhorn.Dsl.Bind
-import Wetterhorn.Dsl.Input
-import Control.Monad.RWS (MonadTrans(lift))
-import Control.Monad.Trans.Maybe (MaybeT(..))
-
-data MagicModifierProxy (keycode :: Natural) inputproxy
- deriving (Typeable)
-
-newtype MagicModifierState (keycode :: Natural) = MagicModifierState {isPressed :: Bool}
- deriving (Typeable, Eq, Show, Ord, Read)
-
-instance Default (MagicModifierState k) where
- def = MagicModifierState False
-
-instance (KnownNat k) => ExtensionClass (MagicModifierState k)
-
-instance
- (KnownNat keycode, InputProxy inputproxy) =>
- InputProxy (MagicModifierProxy keycode inputproxy)
- where
- onKeyEvent proxy ie = do
- case ie of
- (InputKeyEvent (KeyEvent {keycode = kc, state = state}))
- | fromIntegral kc == natVal (keycodeProxy proxy) -> do
- lift $ setMagicModifierPressed proxy (state == KeyPressed)
- MaybeT (return Nothing)
- _ -> do
- pressed <- lift $ isMagicModifierPressed proxy
- if pressed
- then onKeyEvent (Proxy :: Proxy inputproxy) ie
- else return ie
- where
- keycodeProxy :: Proxy (MagicModifierProxy kc a) -> Proxy kc
- keycodeProxy _ = Proxy
-
- isMagicModifierPressed p = isPressed <$> getModState p
- setMagicModifierPressed p = modifyModState p . const
-
- getModState :: (KnownNat kc) => Proxy (MagicModifierProxy kc a) -> W (MagicModifierState kc)
- getModState _ = xget
-
- modifyModState :: (KnownNat kc) => Proxy (MagicModifierProxy kc a) -> (MagicModifierState kc -> Bool) -> W ()
- modifyModState _ fn = xmodify (MagicModifierState . fn)
diff --git a/src/Wetterhorn/Layout/Combine.hs b/src/Wetterhorn/Layout/Combine.hs
deleted file mode 100644
index 10a0208..0000000
--- a/src/Wetterhorn/Layout/Combine.hs
+++ /dev/null
@@ -1,48 +0,0 @@
-{-# LANGUAGE ViewPatterns #-}
-
-module Wetterhorn.Layout.Combine where
-
-import Data.Typeable
-import Wetterhorn.Constraints
-import Wetterhorn.Core.W
-
-data (|||) a b = Comb LR a b
- deriving (Typeable, Read, Show)
-
-data Next = Next
- deriving (Typeable)
-
-data Reset = Reset
- deriving (Typeable)
-
-(|||) :: a -> b -> (a ||| b)
-a ||| b = Comb L a b
-
-data LR = L | R deriving (Read, Show, Ord, Eq, Enum)
-
-instance (HandleMessage a, HandleMessage b) => HandleMessage (a ||| b) where
- handleMessage (fromMessage -> Just Next) (Comb L l r) = return (Comb R l r)
- handleMessage (fromMessage -> Just Reset) (Comb _ l r) = return (Comb L l r)
- handleMessage mesg (Comb L l r) =
- Comb L <$> handleMessage mesg l <*> pure r
- handleMessage mesg (Comb R l r) =
- Comb L l <$> handleMessage mesg r
-
-instance (LayoutClass a, LayoutClass b) => LayoutClass (a ||| b) where
- -- In order to use this layout class, the lay-out type 'a' must satisfy BOTH
- -- the left and right constraints.
- type LayoutConstraint (a ||| b) = LayoutConstraint a &&&& LayoutConstraint b
-
- runLayout as (Comb R r l) = do
- (r', ret) <- runLayout as r
- return (Comb R r' l, ret)
- runLayout as (Comb L r l) = do
- (l', ret) <- runLayout as l
- return (Comb R r l', ret)
-
- serializeLayout (Comb lr l r) = show (Comb lr (serializeLayout l) (serializeLayout r))
- readLayout str = Comb lr <$> l <*> r
- where
- (Comb lr (readLayout -> l) (readLayout -> r)) = read str
-
- description (Comb _ l r) = description l ++ " ||| " ++ description r
diff --git a/src/Wetterhorn/Layout/Full.hs b/src/Wetterhorn/Layout/Full.hs
deleted file mode 100644
index b7e4d91..0000000
--- a/src/Wetterhorn/Layout/Full.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-module Wetterhorn.Layout.Full where
-
-import Data.Data (Typeable)
-import Data.Default.Class
-import Wetterhorn.Constraints
-import Wetterhorn.Core.W
-import Wetterhorn.StackSet
-
-data Full = Full
- deriving (Read, Show, Typeable)
-
-instance Default Full where
- def = Full
-
-instance HandleMessage Full
-
-instance LayoutClass Full where
- type LayoutConstraint Full = Unconstrained
-
- runLayout = pureLayout $ \l _ ->
- case l of
- (focused -> Just a) -> [(a, RationalRect 1 1 1 1)]
- _ -> []
diff --git a/src/Wetterhorn/StackSet.hs b/src/Wetterhorn/StackSet.hs
deleted file mode 100644
index 86d1b8e..0000000
--- a/src/Wetterhorn/StackSet.hs
+++ /dev/null
@@ -1,210 +0,0 @@
-module Wetterhorn.StackSet where
-
-import Control.Monad (void)
-import Data.Monoid (First(..))
-import Control.Monad.Identity
-import Control.Monad.Writer (MonadWriter (tell), execWriter)
-import Data.Maybe (isJust, mapMaybe)
-import Data.Maybe (isJust)
-
--- | The root datastructure for holding the state of the windows.
-data StackSet s sd t l a = StackSet
- { -- | The currently selected screen.
- current :: Screen s sd t l a,
- -- | Remaining visible screens.
- visible :: [Screen s sd t l a],
- -- | Workspaces that exist, but are not on a screen.
- hidden :: [Workspace t l a]
- }
- deriving (Read, Show, Eq, Ord, Functor)
-
-class TraverseWorkspace f where
- traverseWorkspaces ::
- (Applicative m) => (Workspace t l a -> m (Workspace t' l' a')) -> f t l a -> m (f t' l' a')
-
-traverseWorkspaces_ :: (TraverseWorkspace f, Monad m) => (Workspace t l a -> m ()) -> f t l a -> m ()
-traverseWorkspaces_ f = void . traverseWorkspaces (\w -> f w >> pure w)
-
-foldMapWorkspaces ::
- (Monoid m, TraverseWorkspace f) => (Workspace t l a -> m) -> f t l a -> m
-foldMapWorkspaces fn = execWriter . traverseWorkspaces_ (tell . fn)
-
-mapWorkspaces ::
- (TraverseWorkspace f) =>
- (Workspace t l a -> Workspace t' l' a') ->
- f t l a ->
- f t' l' a'
-mapWorkspaces fn = runIdentity . traverseWorkspaces (pure . fn)
-
-instance TraverseWorkspace Workspace where
- traverseWorkspaces f = f
-
-instance TraverseWorkspace (Screen s sd) where
- traverseWorkspaces f scr = (\w' -> scr {workspace = w'}) <$> f (workspace scr)
-
-instance TraverseWorkspace (StackSet s sd) where
- traverseWorkspaces f (StackSet cur vis hid) =
- StackSet
- <$> traverseWorkspaces f cur
- <*> traverse (traverseWorkspaces f) vis
- <*> traverse (traverseWorkspaces f) hid
-
-instance Traversable Stack where
- traverse f (Stack u d) =
- Stack <$> traverse f u <*> traverse f d
-
-instance (TraverseWorkspace f) => Foldable (f t l) where
- foldMap fn =
- execWriter
- . traverseWorkspaces_ (\(Workspace _ _ s) -> tell (foldMap (fn . windowInSeat) s))
-
-instance (Functor (f t l), TraverseWorkspace f) => Traversable (f t l) where
- sequenceA =
- traverseWorkspaces $
- \(Workspace t l sf) -> Workspace t l <$> traverse sequenceA sf
-
-class HasFocus f where
- focused :: f a -> Maybe a
-
-data Rectangle = Rectangle Int Int Int Int
- deriving (Read, Show, Eq, Ord)
-
-instance HasFocus (StackSet s sd t l) where
- focused (StackSet c _ _) = focused c
-
-data Screen s sd t l a = Screen
- { screenDetail :: sd,
- screenId :: s,
- workspace :: Workspace t l a
- }
- deriving (Read, Show, Eq, Ord, Functor)
-
-instance HasFocus (Screen s sd t l) where
- focused (Screen _ _ w) = focused w
-
--- | Defines where a window should appear.
-data WindowSeat a = Floating Rectangle a | Tiled a
- deriving (Read, Show, Eq, Ord, Functor, Foldable)
-
-windowInSeat :: WindowSeat a -> a
-windowInSeat (Floating _ a) = a
-windowInSeat (Tiled a) = a
-
-instance Traversable WindowSeat where
- sequenceA (Floating r fa) = Floating r <$> fa
- sequenceA (Tiled fa) = Tiled <$> fa
-
-instance HasFocus WindowSeat where
- focused (Floating _ a) = Just a
- focused (Tiled a) = Just a
-
-data Workspace t l a = Workspace
- { tag :: t,
- layout :: l,
- stack :: Stack (WindowSeat a)
- }
- deriving (Read, Show, Eq, Ord, Functor)
-
-instance HasFocus (Workspace t l) where
- focused (Workspace _ _ s) = windowInSeat <$> focused s
-
-data Stack a = Stack
- { -- | The elements above the focused one.
- up :: ![a],
- -- | The elements below the focused one including the focused one itself.
- down :: ![a]
- }
- deriving (Read, Show, Eq, Ord, Functor, Foldable)
-
-instance HasFocus Stack where
- focused (Stack _ (a : _)) = Just a
- focused _ = Nothing
-
--- | Change the tag in a structure.
-mapTag :: (TraverseWorkspace f) => (t -> t') -> f t l a -> f t' l a
-mapTag fn = mapWorkspaces (\w -> w {tag = fn (tag w)})
-
--- | Change the layout in a structure.
-mapLayout :: (TraverseWorkspace f) => (l -> l') -> f t l a -> f t l' a
-mapLayout fn = mapWorkspaces (\w -> w {layout = fn (layout w)})
-
--- | Return all the tags in a structure.
-tags :: (TraverseWorkspace f) => f t l a -> [t]
-tags = foldMapWorkspaces ((: []) . tag)
-
--- | Insert a new window into the StackSet. The optional rectangle indicates if
--- the window should be floating or tiled.
---
--- The window is inserted just above the the currently focused window and is
--- given focus.
-insert :: a -> Maybe Rectangle -> StackSet s sd t l a -> StackSet s sd t l a
-insert win rect =
- runIdentity
- . onCurrentStack
- ( \(Stack u d) ->
- return $
- (\w -> Stack u (w : d)) $
- maybe (Tiled win) (`Floating` win) rect
- )
-
--- | Find the tag associated with a window.
-findTag :: (TraverseWorkspace f, Eq a) => a -> f t l a -> Maybe t
-findTag a =
- getFirst
- . foldMapWorkspaces
- ( \ws ->
- foldMap
- ( \a' ->
- First $ if a' == a then Just (tag ws) else Nothing
- )
- ws
- )
-
--- | Return true if the window exist in a structure
-elem :: (TraverseWorkspace f, Eq a) => a -> f t l a -> Bool
-elem a = isJust . findTag a
-
--- | Convenience function for inserting a window in stack set tiled.
-insertTiled :: a -> StackSet s sd t l a -> StackSet s sd t l a
-insertTiled win = insert win Nothing
-
-integrate :: Stack a -> [a]
-integrate (Stack u d) = u ++ d
-
-differentiate :: [a] -> Stack a
-differentiate = Stack []
-
-applyStack ::
- (Monad m) =>
- (Stack (WindowSeat a) -> m (Stack (WindowSeat a))) ->
- Workspace t l a ->
- m (Workspace t l a)
-applyStack fn (Workspace t l s) = Workspace t l <$> fn s
-
--- | Apply a function to the currently focused stack.
-onCurrentStack ::
- (Monad m) =>
- (Stack (WindowSeat a) -> m (Stack (WindowSeat a))) ->
- StackSet s sd t l a ->
- m (StackSet s sd t l a)
-onCurrentStack fn (StackSet cur vis hid) =
- StackSet <$> cur' cur <*> pure vis <*> pure hid
- where
- cur' (Screen s sd ws) = Screen s sd <$> ws' ws
- ws' (Workspace t l s) = Workspace t l <$> fn s
-
-catMaybes :: StackSet s sd t l (Maybe a) -> StackSet s sd t l a
-catMaybes (StackSet cur hidden visible) =
- StackSet (catMaybesS cur) (map catMaybesS hidden) (map catMaybesW visible)
- where
- catMaybesS (Screen a b ws) = Screen a b $ catMaybesW ws
- catMaybesW (Workspace a b st) = Workspace a b $ catMaybesSt st
- catMaybesSt (Stack up down) =
- Stack (mapMaybe sequenceA up) (mapMaybe sequenceA down)
-
-filter :: (a -> Bool) -> StackSet s sd t l a -> StackSet s sd t l a
-filter ffn =
- Wetterhorn.StackSet.catMaybes . fmap (\a -> if ffn a then Just a else Nothing)
-
-delete :: (Eq a) => a -> StackSet s sd t l a -> StackSet s sd t l a
-delete win = Wetterhorn.StackSet.filter (/=win)
diff --git a/src/harness_adapter.c b/src/harness_adapter.c
deleted file mode 100644
index 24b813c..0000000
--- a/src/harness_adapter.c
+++ /dev/null
@@ -1,81 +0,0 @@
-// This file provides functions for the wetterhorn harness that are not
-// expressible directly in haskell.
-//
-// Currently these functions exclusively enable/disable the Haskell runtime.
-
-#include "HsFFI.h"
-#include "plugin_interface.h"
-#include <stdio.h>
-#include <stdlib.h>
-#include <unistd.h>
-
-const char *plugin_name = "Wetterhorn";
-
-void* foreign_interface;
-
-void* get_foreign_interface()
-{
- return foreign_interface;
-}
-
-extern void performMajorGC();
-
-void plugin_metaload(int argc, char** argv)
-{
- // hs_init(&argc, &argv);
-}
-
-void plugin_load(int argc, char **argv, foreign_interface_t* fintf) {
- hs_init(&argc, &argv);
- foreign_interface = fintf;
-}
-
-void plugin_teardown(opqst_t st) {
- hs_exit();
-}
-
-void shell_exec(const char* cmd) {
- if (fork() == 0) {
- execl("/bin/sh", "/bin/sh", "-c", cmd, NULL);
- exit(1);
- }
-}
-
-static const char msg[] =
- "Wetterhorn Plugin v 0.01\n\n"
- "Welcome, and thank you for your interest.\n\n"
- "This is merely a plugin to the Wetterhorn Compositor and not meant to be\n"
- "executed as a standalone binary. This plugin requires a harness to run\n"
- "To use this file, please use './wtr_harness [full-path-to-wtr.so]'\n"
- "That will allow you to see how this compositor works in all its glory!\n";
-static const int msg_sz = sizeof(msg);
-
-/*
- * Implemens a basic _start that prints inforamtion and exits for users on an
- * x86_64 system.
- */
-__attribute__((naked)) void _start()
-{
-
- // Make system call to print the message
- asm(
- // Load the address of the string into rsi
- "mov %0, %%rsi\n"
- // Load the string length into edx
- "mov %1, %%edx\n"
- // Load the file descriptor for stdout into edi
- "mov $1, %%edi\n"
- // Load the syscall number for sys_write into eax
- "mov $1, %%eax\n"
- // Make the syscall
- "syscall\n"
-
- // Exit the program.
- "mov $0, %%rdi\n"
- "mov $60, %%rax\n"
- "syscall\n"
- :
- : "r"(msg), "r"(msg_sz) // Input: address of msg
- : "%rsi", "%edx", "%edi" // Clobbered registers
- );
-}
generated by cgit (git 2.34.1) at 2026-01-03 03:52:34 +0000