diff options
Diffstat (limited to 'plug')
27 files changed, 2660 insertions, 0 deletions
diff --git a/plug/README.md b/plug/README.md new file mode 100644 index 0000000..5592f08 --- /dev/null +++ b/plug/README.md @@ -0,0 +1 @@ +The Plugin for the Montis Runtime. diff --git a/plug/package.yaml b/plug/package.yaml new file mode 100644 index 0000000..a9f29ae --- /dev/null +++ b/plug/package.yaml @@ -0,0 +1,86 @@ +name: montis + +github: "jrahm/montis" +license: BSD-3-Clause +author: "Author name here" +maintainer: "example@example.com" +copyright: "2024 Author name here" + +extra-source-files: +- README.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at <https://github.com/githubuser/montis#readme> + + +dependencies: +- base >= 4.7 && < 5 +- mtl +- bytestring +- containers +- data-default-class +- transformers +- monad-loops +- singletons + + +ghc-options: +- -Wall +- -Wcompat +- -Widentities +- -Wincomplete-record-updates +- -Wincomplete-uni-patterns +- -Wmissing-export-lists +- -Wmissing-home-modules +- -Wpartial-fields +- -Wredundant-constraints +- -XGHC2021 +- -XTypeFamilies +- -XUndecidableInstances +- -XGADTs +- -XFunctionalDependencies +- -XUndecidableSuperClasses +- -XDefaultSignatures +- -XViewPatterns +- -XDerivingVia +- -XDisambiguateRecordFields +- -XLambdaCase +- -XDataKinds +- -fPIC + +executables: + montis.so: + main: Config.hs + source-dirs: src + c-sources: src/harness_adapter.c + ghc-options: + - -shared + - -dynamic + - -no-hs-main + - -lHSrts-1.0.2-ghc9.8.4 + - -O3 + cc-options: + - -g3 + - -O2 + - -shared + - -I../build/rt/ + - -I../rt/include/ + - -I../wlroots/include + - -DWLR_USE_UNSTABLE + +tests: + montis-test: + main: Spec.hs + source-dirs: test + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - montis diff --git a/plug/plug.stamp b/plug/plug.stamp new file mode 100644 index 0000000..e69de29 --- /dev/null +++ b/plug/plug.stamp diff --git a/plug/src/Config.hs b/plug/src/Config.hs new file mode 100644 index 0000000..e76e6ea --- /dev/null +++ b/plug/src/Config.hs @@ -0,0 +1,88 @@ +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/plug/src/Lib.hs b/plug/src/Lib.hs new file mode 100644 index 0000000..d36ff27 --- /dev/null +++ b/plug/src/Lib.hs @@ -0,0 +1,6 @@ +module Lib + ( someFunc + ) where + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/plug/src/Wetterhorn/Constraints.hs b/plug/src/Wetterhorn/Constraints.hs new file mode 100644 index 0000000..129fd6c --- /dev/null +++ b/plug/src/Wetterhorn/Constraints.hs @@ -0,0 +1,13 @@ +-- | 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/plug/src/Wetterhorn/Core.hs b/plug/src/Wetterhorn/Core.hs new file mode 100644 index 0000000..d853191 --- /dev/null +++ b/plug/src/Wetterhorn/Core.hs @@ -0,0 +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 (..), +-- ) +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/plug/src/Wetterhorn/Core/ButtonEvent.hs b/plug/src/Wetterhorn/Core/ButtonEvent.hs new file mode 100644 index 0000000..cc3d905 --- /dev/null +++ b/plug/src/Wetterhorn/Core/ButtonEvent.hs @@ -0,0 +1,15 @@ +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/plug/src/Wetterhorn/Core/KeyEvent.hs b/plug/src/Wetterhorn/Core/KeyEvent.hs new file mode 100644 index 0000000..77d273f --- /dev/null +++ b/plug/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/plug/src/Wetterhorn/Core/Keys.hs b/plug/src/Wetterhorn/Core/Keys.hs new file mode 100644 index 0000000..54d7125 --- /dev/null +++ b/plug/src/Wetterhorn/Core/Keys.hs @@ -0,0 +1,239 @@ +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/plug/src/Wetterhorn/Core/SurfaceEvent.hs b/plug/src/Wetterhorn/Core/SurfaceEvent.hs new file mode 100644 index 0000000..3e7eaf3 --- /dev/null +++ b/plug/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/plug/src/Wetterhorn/Core/W.hs b/plug/src/Wetterhorn/Core/W.hs new file mode 100644 index 0000000..862f9fa --- /dev/null +++ b/plug/src/Wetterhorn/Core/W.hs @@ -0,0 +1,379 @@ +{-# 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 |