wip

6 files changed, 65 insertions, 37 deletions

diff --git a/package.yaml b/package.yaml
index fee7560..e5e199b 100644
--- a/package.yaml
+++ b/package.yaml
@@ -34,6 +34,7 @@ dependencies:
 - bytestring
 - containers
 - data-default
+- transformers
 
 
 ghc-options:
@@ -54,6 +55,7 @@ ghc-options:
 - -XUndecidableSuperClasses
 - -XDefaultSignatures
 - -XViewPatterns
+- -XDerivingVia
 - -fPIC
 
 executables:
diff --git a/src/Wetterhorn/Constraints.hs b/src/Wetterhorn/Constraints.hs
index cdc5afe..129fd6c 100644
--- a/src/Wetterhorn/Constraints.hs
+++ b/src/Wetterhorn/Constraints.hs
@@ -1,4 +1,5 @@
--- | Contains useful constraints and constraint combinators.
+-- | Contains useful constraints and constraint combinators for type-level
+-- metaprogramming.
 module Wetterhorn.Constraints where
 
 -- | A null constraint. All types implement this.
diff --git a/src/Wetterhorn/Core/W.hs b/src/Wetterhorn/Core/W.hs
index 89ebf4b..11bac05 100644
--- a/src/Wetterhorn/Core/W.hs
+++ b/src/Wetterhorn/Core/W.hs
@@ -4,10 +4,11 @@ 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 Control.Monad.Trans.Maybe
 import Data.Data (Typeable, cast)
 import Data.Kind (Constraint, Type)
 import Data.Set (Set)
-import Foreign (StablePtr)
+import Foreign (Ptr, StablePtr, intPtrToPtr, ptrToIntPtr)
 import Text.Read
 import Wetterhorn.Core.KeyEvent
 import Wetterhorn.Core.SurfaceEvent
@@ -30,32 +31,21 @@ fromMessage (Message t) = cast t
 toMessage :: (Typeable a) => a -> Message
 toMessage = Message
 
+class (Typeable l) => HandleMessage l where
+  handleMessage :: Message -> l -> MaybeT W l
+  handleMessage _ = return
+
 -- | Types of this class "lay out" windows by assigning rectangles and handle
 -- messages.
-class (Typeable l) => LayoutClass l where
+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 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
+  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 :: (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
+  runLayout :: (LayoutConstraint l a) => Stack a -> l -> W (l, [(a, RationalRect)])
 
   readLayout :: String -> Maybe l
   default readLayout :: (Read l) => String -> Maybe l
@@ -68,16 +58,28 @@ class (Typeable l) => LayoutClass l where
   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, C l a, a ~ Window) => WindowLayout l
+  = forall l a.
+    (LayoutClass l, LayoutConstraint l a, a ~ Window) =>
+    WindowLayout l
 
-runWindowLayout :: [Window] -> WindowLayout -> W (WindowLayout, [(Window, RationalRect)])
+runWindowLayout :: Stack Window -> WindowLayout -> W (WindowLayout, [(Window, RationalRect)])
 runWindowLayout as (WindowLayout l) = first WindowLayout <$> runLayout as l
 
-handleWindowMessage :: Message -> WindowLayout -> W WindowLayout
+handleWindowMessage :: Message -> WindowLayout -> MaybeT W WindowLayout
 handleWindowMessage m (WindowLayout l) = WindowLayout <$> handleMessage m l
 
 -- | Using the 'Layout' as a witness, parse existentially wrapped windows
@@ -85,7 +87,7 @@ handleWindowMessage m (WindowLayout l) = WindowLayout <$> handleMessage m l
 readWindowLayout :: WindowLayout -> String -> WindowLayout
 readWindowLayout (WindowLayout l) s
   | (Just x) <- readLayout s =
-      WindowLayout (asTypeOf x l)
+    WindowLayout (asTypeOf x l)
 readWindowLayout l _ = l
 
 serializeWindowLayout :: WindowLayout -> String
@@ -97,8 +99,17 @@ type ScreenDetail = ()
 
 type Tag = String
 
-newtype Window = Window (TypedIntPtr ())
-  deriving (Eq, Ord, Show, Read)
+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)
+
+newtype Window = Window (Ptr ())
+  deriving (Eq, Ord)
+  deriving (Read, Show) via (ReadPtr (Ptr ()))
 
 type Wetterhorn = StablePtr (Context, State)
 
diff --git a/src/Wetterhorn/Layout/Combine.hs b/src/Wetterhorn/Layout/Combine.hs
index 983ceb1..10a0208 100644
--- a/src/Wetterhorn/Layout/Combine.hs
+++ b/src/Wetterhorn/Layout/Combine.hs
@@ -20,8 +20,18 @@ 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
-  type C (a ||| b) = C a &&&& C b
+  -- 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
@@ -30,13 +40,6 @@ instance (LayoutClass a, LayoutClass b) => LayoutClass (a ||| b) where
     (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
diff --git a/src/Wetterhorn/Layout/Full.hs b/src/Wetterhorn/Layout/Full.hs
index 8296c7b..240b719 100644
--- a/src/Wetterhorn/Layout/Full.hs
+++ b/src/Wetterhorn/Layout/Full.hs
@@ -4,6 +4,7 @@ import Data.Data (Typeable)
 import Data.Default
 import Wetterhorn.Constraints
 import Wetterhorn.Core.W
+import Wetterhorn.StackSet
 
 data Full = Full
   deriving (Read, Show, Typeable)
@@ -11,8 +12,12 @@ data Full = Full
 instance Default Full where
   def = Full
 
+instance HandleMessage Full
+
 instance LayoutClass Full where
-  type C Full = Unconstrained
+  type LayoutConstraint Full = Unconstrained
 
-  pureLayout (a : _) _ = [(a, RationalRect 1 1 1 1)]
-  pureLayout _ _ = []
+  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
index 464fd54..f6379eb 100644
--- a/src/Wetterhorn/StackSet.hs
+++ b/src/Wetterhorn/StackSet.hs
@@ -165,6 +165,12 @@ elem a = isJust . findTag a
 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))) ->