aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--package.yaml12
-rw-r--r--src/Config.hs16
-rw-r--r--src/Wetterhorn/Constraints.hs12
-rw-r--r--src/Wetterhorn/Core.hs318
-rw-r--r--src/Wetterhorn/Core/KeyEvent.hs22
-rw-r--r--src/Wetterhorn/Core/SurfaceEvent.hs16
-rw-r--r--src/Wetterhorn/Core/W.hs151
-rw-r--r--src/Wetterhorn/Foreign.hs18
-rw-r--r--src/Wetterhorn/Foreign/Export.hs (renamed from src/Wetterhorn/FFI.hs)55
-rw-r--r--src/Wetterhorn/Foreign/ForeignInterface.hs (renamed from src/Wetterhorn/Core/ForeignInterface.hs)10
-rw-r--r--src/Wetterhorn/Foreign/WlRoots.hs (renamed from src/Wetterhorn/WlRoots.hs)2
-rw-r--r--src/Wetterhorn/Layout/Combine.hs45
-rw-r--r--src/Wetterhorn/Layout/Full.hs18
-rw-r--r--src/Wetterhorn/StackSet.hs185
14 files changed, 674 insertions, 206 deletions
diff --git a/package.yaml b/package.yaml
index ebc64c1..fee7560 100644
--- a/package.yaml
+++ b/package.yaml
@@ -33,6 +33,8 @@ dependencies:
- mtl
- bytestring
- containers
+- data-default
+
ghc-options:
- -Wall
@@ -44,10 +46,14 @@ ghc-options:
- -Wmissing-home-modules
- -Wpartial-fields
- -Wredundant-constraints
-- -XTupleSections
+- -XGHC2021
+- -XTypeFamilies
+- -XUndecidableInstances
+- -XGADTs
+- -XFunctionalDependencies
+- -XUndecidableSuperClasses
+- -XDefaultSignatures
- -XViewPatterns
-- -XGeneralizedNewtypeDeriving
-- -XRankNTypes
- -fPIC
executables:
diff --git a/src/Config.hs b/src/Config.hs
index 818150e..e49a869 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -1,6 +1,14 @@
-module Config (wetterhorn) where
+module Config where
-import Wetterhorn.Core
+import Wetterhorn.Core.W
+import Wetterhorn.Layout.Full
+import Wetterhorn.Layout.Combine
-wetterhorn :: IO Wetterhorn
-wetterhorn = initWetterhorn defaultConfig
+config = defaultConfig {
+ keyHook = wio . print,
+ surfaceHook = wio . print,
+ layout = WindowLayout Full
+}
+
+-- wetterhorn :: IO Wetterhorn
+-- wetterhorn = initWetterhorn defaultConfig
diff --git a/src/Wetterhorn/Constraints.hs b/src/Wetterhorn/Constraints.hs
new file mode 100644
index 0000000..cdc5afe
--- /dev/null
+++ b/src/Wetterhorn/Constraints.hs
@@ -0,0 +1,12 @@
+-- | Contains useful constraints and constraint combinators.
+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
index d3515fc..d853191 100644
--- a/src/Wetterhorn/Core.hs
+++ b/src/Wetterhorn/Core.hs
@@ -1,176 +1,152 @@
{-# HLINT ignore "Use camelCase" #-}
module Wetterhorn.Core
- ( WState (..),
- WConfig (..),
- SurfaceState (..),
- W,
- getWConfig,
- getWState,
- runW,
- Wetterhorn,
- initWetterhorn,
- wio,
- incrementState,
- readWState,
- defaultConfig,
- requestHotReload,
- ctxConfig,
- KeyEvent (..),
- KeyState (..),
- )
+-- ( 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 Control.Monad (when)
-import Data.ByteString (ByteString)
-import qualified Data.ByteString.Char8 as CH
-import Data.Char (chr, ord)
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Maybe (fromMaybe)
-import Foreign (Ptr, StablePtr, Word32, castForeignPtr, newStablePtr, ptrToIntPtr)
-import Numeric (showHex)
-import Text.Printf
-import Wetterhorn.Core.ForeignInterface (ForeignInterface)
-import qualified Wetterhorn.Core.ForeignInterface as ForeignInterface
-import Wetterhorn.WlRoots
-
-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)
-
-data WState = WState
- { someString :: String,
- integer :: Int
- }
- deriving (Show, Read)
-
-data SurfaceState = Map | Unmap | Destroy deriving (Eq, Ord, Show, Enum)
-
-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)
-
-data WConfig = WConfig
- { keybindingHandler :: KeyEvent -> W Bool,
- surfaceHandler :: SurfaceState -> Surface -> W ()
- }
-
-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 '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)
+-- 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/KeyEvent.hs b/src/Wetterhorn/Core/KeyEvent.hs
new file mode 100644
index 0000000..77d273f
--- /dev/null
+++ b/src/Wetterhorn/Core/KeyEvent.hs
@@ -0,0 +1,22 @@
+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/SurfaceEvent.hs b/src/Wetterhorn/Core/SurfaceEvent.hs
new file mode 100644
index 0000000..3e7eaf3
--- /dev/null
+++ b/src/Wetterhorn/Core/SurfaceEvent.hs
@@ -0,0 +1,16 @@
+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
new file mode 100644
index 0000000..89ebf4b
--- /dev/null
+++ b/src/Wetterhorn/Core/W.hs
@@ -0,0 +1,151 @@
+module Wetterhorn.Core.W where
+
+import Control.Arrow (Arrow (first))
+import Control.Monad.RWS (MonadIO (liftIO), MonadReader, MonadState)
+import Control.Monad.Reader (ReaderT (runReaderT))
+import Control.Monad.State (StateT (runStateT))
+import Data.Data (Typeable, cast)
+import Data.Kind (Constraint, Type)
+import Data.Set (Set)
+import Foreign (StablePtr)
+import Text.Read
+import Wetterhorn.Core.KeyEvent
+import Wetterhorn.Core.SurfaceEvent
+import Wetterhorn.Foreign
+import Wetterhorn.Foreign.ForeignInterface (ForeignInterface)
+import Wetterhorn.StackSet hiding (layout)
+
+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
+
+-- | Types of this class "lay out" windows by assigning rectangles and handle
+-- messages.
+class (Typeable 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 C l :: Type -> Constraint
+
+ -- | Executes the layout on some windows in a pure way. Returns a list of
+ -- windows to their assigned rectangle.
+ pureLayout :: (C l a) => [a] -> l -> [(a, RationalRect)]
+ pureLayout as _ = map (,RationalRect 0 0 0 0) as
+
+ -- | Runs the layout in an impure way returning a modified layout and the list
+ -- of windows to their rectangles under a monad.
+ runLayout :: (C l a) => [a] -> l -> W (l, [(a, RationalRect)])
+ runLayout as l = return (l, pureLayout as l)
+
+ -- | Handles a message in a pure way. Returns the new layout after handling
+ -- the message.
+ pureMessage :: Message -> l -> l
+ pureMessage _ = id
+
+ -- | Handles a message in an impure way.
+ handleMessage :: Message -> l -> W l
+ handleMessage m = return . pureMessage m
+
+ 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
+
+-- 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, C l a, a ~ Window) => WindowLayout l
+
+runWindowLayout :: [Window] -> WindowLayout -> W (WindowLayout, [(Window, RationalRect)])
+runWindowLayout as (WindowLayout l) = first WindowLayout <$> runLayout as l
+
+handleWindowMessage :: Message -> WindowLayout -> 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
+
+serializeWindowLayout :: WindowLayout -> String
+serializeWindowLayout (WindowLayout l) = serializeLayout l
+
+type ScreenId = ()
+
+type ScreenDetail = ()
+
+type Tag = String
+
+newtype Window = Window (TypedIntPtr ())
+ deriving (Eq, Ord, Show, Read)
+
+type Wetterhorn = StablePtr (Context, State)
+
+data Context = Context
+ { ctxForeignInterface :: ForeignInterface,
+ ctxConfig :: Config WindowLayout
+ }
+
+defaultConfig :: Config ()
+defaultConfig =
+ Config
+ { keyHook = \_ -> return (),
+ surfaceHook = \_ -> return (),
+ layout = ()
+ }
+
+data Config l = Config
+ { keyHook :: KeyEvent -> W (),
+ surfaceHook :: SurfaceEvent -> W (),
+ layout :: l
+ }
+
+data State = State
+ { mapped :: StackSet ScreenId ScreenDetail Tag WindowLayout Window,
+ allWindows :: Set Window
+ }
+
+initColdState :: WindowLayout -> IO State
+initColdState l = return $ State (StackSet (Screen () () (Workspace "0" l (Stack [] []))) [] []) mempty
+
+marshalState :: State -> String
+marshalState (State mapped allWindows) =
+ show
+ ( mapLayout serializeWindowLayout mapped,
+ allWindows
+ )
+
+demarshalState :: WindowLayout -> String -> State
+demarshalState witness str = State mapped allWindows
+ where
+ (mapLayout (readWindowLayout witness) -> mapped, allWindows) = read str
+
+newtype W a = W (ReaderT Context (StateT State IO) a)
+ deriving (Functor, Applicative, Monad, MonadState State, MonadReader Context, MonadIO)
+
+runW :: W a -> (Context, State) -> IO (a, State)
+runW (W fn) (ctx, st) = runStateT (runReaderT fn ctx) st
+
+wio :: IO a -> W a
+wio = liftIO
diff --git a/src/Wetterhorn/Foreign.hs b/src/Wetterhorn/Foreign.hs
new file mode 100644
index 0000000..2d0a42c
--- /dev/null
+++ b/src/Wetterhorn/Foreign.hs
@@ -0,0 +1,18 @@
+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/FFI.hs b/src/Wetterhorn/Foreign/Export.hs
index 6173291..0d71a4e 100644
--- a/src/Wetterhorn/FFI.hs
+++ b/src/Wetterhorn/Foreign/Export.hs
@@ -1,6 +1,6 @@
-- | This module does not export anything. It exists simply to provide C-symbols
-- for the plugin.
-module Wetterhorn.FFI () where
+module Wetterhorn.Foreign.Export () where
import Config
import Control.Monad (forM_)
@@ -17,30 +17,33 @@ import Foreign
newStablePtr,
)
import Foreign.C (CChar, CInt (..))
-import Wetterhorn.Core
-import Wetterhorn.Core.ForeignInterface
-import Wetterhorn.WlRoots
-
-runForeign :: (WConfig -> W ()) -> Wetterhorn -> IO Wetterhorn
+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
+
+runForeign :: (forall l. W.Config l -> W ()) -> Wetterhorn -> IO Wetterhorn
runForeign fn stblptr = do
(ctx, st) <- deRefStablePtr stblptr
freeStablePtr stblptr
- (_, state') <- runW (fn $ ctxConfig ctx) (ctx, st)
+ (_, state') <- W.runW (fn $ W.ctxConfig ctx) (ctx, st)
newStablePtr (ctx, state')
-runForeignWithReturn :: (Storable a) => (WConfig -> W a) -> Ptr a -> Wetterhorn -> IO Wetterhorn
+runForeignWithReturn :: (Storable a) => (forall l. W.Config l -> W a) -> Ptr a -> Wetterhorn -> IO Wetterhorn
runForeignWithReturn fn ptr stableptr = do
(ctx, st) <- deRefStablePtr stableptr
freeStablePtr stableptr
- (val, state') <- runW (fn $ ctxConfig ctx) (ctx, st)
+ (val, state') <- W.runW (fn $ W.ctxConfig ctx) (ctx, st)
poke ptr val
newStablePtr (ctx, state')
-runForeignWithReturn2 :: (Storable a, Storable b) => (WConfig -> W (a, b)) -> Ptr a -> Ptr b -> Wetterhorn -> IO Wetterhorn
+runForeignWithReturn2 :: (Storable a, Storable b) => (forall l. W.Config l -> W (a, b)) -> Ptr a -> Ptr b -> Wetterhorn -> IO Wetterhorn
runForeignWithReturn2 fn ptrA ptrB stableptr = do
(ctx, st) <- deRefStablePtr stableptr
freeStablePtr stableptr
- ((vA, vB), state') <- runW (fn $ ctxConfig ctx) (ctx, st)
+ ((vA, vB), state') <- W.runW (fn $ W.ctxConfig ctx) (ctx, st)
poke ptrA vA
poke ptrB vB
newStablePtr (ctx, state')
@@ -55,10 +58,11 @@ foreign export ccall "plugin_hot_start"
pluginHotStart :: Ptr CChar -> Word32 -> IO Wetterhorn
pluginHotStart chars len = do
bs <- BS.packCStringLen (chars, fromIntegral len)
- wtrPtr <- wetterhorn
- (conf, _) <- deRefStablePtr wtrPtr
- freeStablePtr wtrPtr
- newStablePtr . (conf,) =<< readWState bs
+ foreignInterface <- getForeignInterface
+ newStablePtr
+ ( W.Context foreignInterface config,
+ W.demarshalState (W.layout config) (CH.unpack bs)
+ )
-- | This function is called when a "coldstart" request is receieved. It just
-- calles the function "wetterhorn". This function should be defined in the main
@@ -67,7 +71,10 @@ foreign export ccall "plugin_cold_start"
pluginColdStart :: IO Wetterhorn
pluginColdStart :: IO Wetterhorn
-pluginColdStart = wetterhorn
+pluginColdStart = do
+ foreignInterface <- getForeignInterface
+ state <- W.initColdState (W.layout config)
+ newStablePtr (W.Context foreignInterface config, state)
-- | Marshals the opaque state to a C-style byte array and size pointer.
foreign export ccall "plugin_marshal_state"
@@ -76,7 +83,7 @@ foreign export ccall "plugin_marshal_state"
pluginMarshalState :: Wetterhorn -> Ptr Word32 -> IO (Ptr Word8)
pluginMarshalState stblptr outlen = do
(_, st) <- deRefStablePtr stblptr
- let bs = CH.pack (show st)
+ 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
@@ -105,7 +112,7 @@ pluginHandleKeybinding ::
IO Wetterhorn
pluginHandleKeybinding inputDevicePtr eventPtr mods sym cp =
runForeignWithReturn $ \config -> do
- event <- wio $
+ event <- W.wio $
runForeignDemarshal eventPtr $ do
tMs <- demarshal
kc <- demarshal
@@ -120,7 +127,8 @@ pluginHandleKeybinding inputDevicePtr eventPtr mods sym cp =
sym
(toEnum $ fromIntegral cp)
inputDevicePtr
- (\b -> if b then 1 else 0) <$> keybindingHandler config event
+ W.keyHook config event
+ return 1
-- | Function exported to the harness to handle the mapping/unmapping/deletion
-- of an XDG surface.
@@ -130,7 +138,12 @@ foreign export ccall "plugin_handle_surface"
pluginHandleSurface :: Ptr WlrXdgSurface -> CInt -> Wetterhorn -> IO Wetterhorn
pluginHandleSurface p t =
- runForeign (\c -> surfaceHandler c (toEnum $ fromIntegral t) (toSurface p))
+ runForeign
+ ( \c ->
+ W.surfaceHook
+ c
+ $ SurfaceEvent (toEnum $ fromIntegral t) (toSurface p)
+ )
-- | Function exported to the harness to handle the mapping/unmapping/deletion
-- of an XWayland surface.
@@ -140,4 +153,4 @@ foreign export ccall "plugin_handle_xwayland_surface"
pluginHandleXWaylandSurface :: Ptr WlrXWaylandSurface -> CInt -> Wetterhorn -> IO Wetterhorn
pluginHandleXWaylandSurface p t =
- runForeign (\c -> surfaceHandler c (toEnum $ fromIntegral t) (toSurface p))
+ runForeign (\c -> W.surfaceHook c $ SurfaceEvent (toEnum $ fromIntegral t) (toSurface p))
diff --git a/src/Wetterhorn/Core/ForeignInterface.hs b/src/Wetterhorn/Foreign/ForeignInterface.hs
index 5dc1454..471e3a9 100644
--- a/src/Wetterhorn/Core/ForeignInterface.hs
+++ b/src/Wetterhorn/Foreign/ForeignInterface.hs
@@ -1,22 +1,20 @@
-module Wetterhorn.Core.ForeignInterface
+module Wetterhorn.Foreign.ForeignInterface
( getForeignInterface,
ForeignInterface (..),
ForeignDemarshal (..),
runForeignDemarshal,
demarshal,
- doShellExec
+ doShellExec,
)
where
import Control.Monad.State (MonadState (get, put), MonadTrans (lift), StateT, evalStateT)
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Char8 as BC
import Data.Void (Void)
-import Foreign (Ptr, Storable (peek, sizeOf), Word8, castPtr, plusPtr)
+import Foreign (Ptr, Storable (peek, sizeOf), castPtr, plusPtr)
import Foreign.C (CChar, CInt (..))
import Foreign.C.String
import GHC.Exts (FunPtr)
-import Wetterhorn.WlRoots
+import Wetterhorn.Foreign.WlRoots
newtype ForeignDemarshal a = ForeignDemarshal (StateT (Ptr ()) IO a)
deriving (Functor, Monad, Applicative, MonadState (Ptr ()))
diff --git a/src/Wetterhorn/WlRoots.hs b/src/Wetterhorn/Foreign/WlRoots.hs
index 7a2a237..56f2a2c 100644
--- a/src/Wetterhorn/WlRoots.hs
+++ b/src/Wetterhorn/Foreign/WlRoots.hs
@@ -1,4 +1,4 @@
-module Wetterhorn.WlRoots where
+module Wetterhorn.Foreign.WlRoots where
import Foreign (Ptr, Word32)
diff --git a/src/Wetterhorn/Layout/Combine.hs b/src/Wetterhorn/Layout/Combine.hs
new file mode 100644
index 0000000..983ceb1
--- /dev/null
+++ b/src/Wetterhorn/Layout/Combine.hs
@@ -0,0 +1,45 @@
+{-# 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 (LayoutClass a, LayoutClass b) => LayoutClass (a ||| b) where
+ type C (a ||| b) = C a &&&& C 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)
+
+ 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
+
+ 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
new file mode 100644
index 0000000..8296c7b
--- /dev/null
+++ b/src/Wetterhorn/Layout/Full.hs
@@ -0,0 +1,18 @@
+module Wetterhorn.Layout.Full where
+
+import Data.Data (Typeable)
+import Data.Default
+import Wetterhorn.Constraints
+import Wetterhorn.Core.W
+
+data Full = Full
+ deriving (Read, Show, Typeable)
+
+instance Default Full where
+ def = Full
+
+instance LayoutClass Full where
+ type C Full = Unconstrained
+
+ pureLayout (a : _) _ = [(a, RationalRect 1 1 1 1)]
+ pureLayout _ _ = []
diff --git a/src/Wetterhorn/StackSet.hs b/src/Wetterhorn/StackSet.hs
new file mode 100644
index 0000000..464fd54
--- /dev/null
+++ b/src/Wetterhorn/StackSet.hs
@@ -0,0 +1,185 @@
+module Wetterhorn.StackSet where
+
+import Control.Monad.Identity
+import Control.Monad.Writer (First (..), MonadWriter (tell), execWriter)
+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)
+
+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
+
+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
generated by cgit (git 2.34.1) at 2025-04-28 13:45:46 +0000