Huge refactor for the Haskell code.HEADmain

This adds new layout configuration, preparing for actually using the
layouts. This also restructures the code and tries to keep code
interfacing with the foreign structures together and rename them to more
sensible names.

1 files changed, 151 insertions, 0 deletions

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