4 files changed, 189 insertions, 83 deletions
diff --git a/src/Wetterhorn/Core/ForeignInterface.hs b/src/Wetterhorn/Core/ForeignInterface.hs
deleted file mode 100644
index 5dc1454..0000000
--- a/src/Wetterhorn/Core/ForeignInterface.hs
+++ /dev/null
@@ -1,83 +0,0 @@
-module Wetterhorn.Core.ForeignInterface
-  ( getForeignInterface,
-    ForeignInterface (..),
-    ForeignDemarshal (..),
-    runForeignDemarshal,
-    demarshal,
-    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.C (CChar, CInt (..))
-import Foreign.C.String
-import GHC.Exts (FunPtr)
-import Wetterhorn.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/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