Constrain layout messages to be members of a Message class

Using Typeables as the only constraint on layout messages is a bit
scary, as a user can send arbitrary values to layoutMsg, whether they
make sense or not: there's basically no type feedback on the values you
supply to layoutMsg.

Folloing Simon Marlow's dynamically extensible exceptions paper, we use
an existential type, and a Message type class, to constrain valid
arguments to layoutMsg to be valid members of Message.

That is, a user writes some data type for messages their layout
algorithm accepts:

  data MyLayoutEvent = Zoom
                     | Explode
                     | Flaming3DGlassEffect
                     deriving (Typeable)

and they then add this to the set of valid message types:

  instance Message MyLayoutEvent

Done. We also reimplement the dynamic type check while we're here, to
just directly use 'cast', rather than expose a raw fromDynamic/toDyn.

With this, I'm much happier about out dynamically extensible layout
event subsystem.

darcs-hash:20070504081649-9c5c1-954b406e8c21c2ca4428960e4fc1f9ffb17fb296

3 files changed, 54 insertions, 32 deletions

diff --git a/Config.hs b/Config.hs
index 841b3ee..196515d 100644
--- a/Config.hs
+++ b/Config.hs
@@ -154,8 +154,8 @@ keys = M.fromList $
     , ((modMask,               xK_j     ), raise GT)
     , ((modMask,               xK_k     ), raise LT)
 
-    , ((modMask,               xK_h     ), layoutMsg Shrink)
-    , ((modMask,               xK_l     ), layoutMsg Expand)
+    , ((modMask,               xK_h     ), sendMessage Shrink)
+    , ((modMask,               xK_l     ), sendMessage Expand)
 
     , ((modMask .|. shiftMask, xK_c     ), kill)
 
diff --git a/Operations.hs b/Operations.hs
index 73e3c1d..c90ff09 100644
--- a/Operations.hs
+++ b/Operations.hs
@@ -16,7 +16,6 @@ module Operations where
 import Data.List
 import Data.Maybe
 import Data.Bits
-import Data.Dynamic ( Typeable, toDyn, fromDynamic )
 import qualified Data.Map as M
 
 import Control.Monad.State
@@ -73,41 +72,46 @@ clearEnterEvents = do
 -- uppermost.
 --
 switchLayout :: X ()
-switchLayout = layout (\(x, xs) -> let xs' = xs ++ [x]
-                                   in (head xs', tail xs'))
+switchLayout = layout (\(x, xs) -> let xs' = xs ++ [x] in (head xs', tail xs'))
 
+-- | Throw an (extensible) message value to the current Layout scheme,
+-- possibly modifying how we layout the windows, then refresh.
 --
--- TODO, using Typeable for extensible stuff is a bit gunky. Check --
--- 'extensible exceptions' paper for other ideas.
+-- TODO, this will refresh on Nothing.
 --
--- Basically this thing specifies the basic operations that vary between
--- layouts.
---
-data ShrinkOrExpand = Shrink | Expand deriving (Typeable, Eq)
-
-layoutMsg :: Typeable a => a -> X () -- FIXME: The below shouldn't refresh on Nothing
-layoutMsg a = layout $ \x@(l, ls) -> maybe x (flip (,) ls) (modifyLayout l (toDyn a))
+sendMessage :: Message a => a -> X ()
+sendMessage a = layout $ \x@(l, ls) -> maybe x (flip (,) ls) (modifyLayout l (SomeMessage a))
 
+------------------------------------------------------------------------
 --
--- Standard layout algorithms:
+-- Builtin layout algorithms:
 --
 --   fullscreen mode
 --   tall mode
 --   wide mode
+-- 
+-- The latter algorithms support the following operations:
+--
+--      Shrink
+--      Expand
 --
-full :: Layout
-tall, wide :: Rational -> Rational -> Layout
 
-full            = Layout { doLayout     = \sc ws -> [ (w,sc) | w <- ws ]
-                         , modifyLayout = const Nothing }
+data Resize = Shrink | Expand deriving (Typeable, Show)
+instance Message Resize
 
+full :: Layout
+full = Layout { doLayout     = \sc ws -> [ (w,sc) | w <- ws ]
+              , modifyLayout = const Nothing } -- no changes
+
+tall, wide :: Rational -> Rational -> Layout
 wide delta frac = mirrorLayout (tall delta frac)
 
 tall delta frac = Layout { doLayout     = tile frac
-                         , modifyLayout = fmap f . fromDynamic }
+                         , modifyLayout = fmap handler . fromMessage }
 
-    where f s = tall delta ((op s) frac delta)
-          op Shrink = (-) ; op Expand = (+)
+    where handler s = tall delta $ (case s of
+                                    Shrink -> (-)
+                                    Expand -> (+)) frac delta
 
 -- | Mirror a rectangle
 mirrorRect :: Rectangle -> Rectangle
diff --git a/XMonad.hs b/XMonad.hs
index 8293212..b20f3f7 100644
--- a/XMonad.hs
+++ b/XMonad.hs
@@ -17,6 +17,7 @@
 
 module XMonad (
     X, WindowSet, WorkspaceId(..), ScreenId(..), XState(..), XConf(..), Layout(..),
+    Typeable, Message, SomeMessage(..), fromMessage,
     runX, io, withDisplay, isRoot, spawn, trace, whenJust
   ) where
 
@@ -28,7 +29,7 @@ import System.IO
 import System.Posix.Process (executeFile, forkProcess, getProcessStatus)
 import System.Exit
 import Graphics.X11.Xlib
-import Data.Dynamic ( Dynamic )
+import Data.Typeable
 
 import qualified Data.Map as M
 
@@ -36,10 +37,8 @@ import qualified Data.Map as M
 -- Just the display, width, height and a window list
 data XState = XState
     { workspace         :: !WindowSet                      -- ^ workspace list
-    , layouts           :: !(M.Map WorkspaceId (Layout, [Layout]))
-                                                           -- ^ mapping of workspaces 
-                                                           -- to descriptions of their layouts
-    }
+    , layouts           :: !(M.Map WorkspaceId (Layout, [Layout]))  }
+                       -- ^ mapping of workspaces to descriptions of their layouts
 
 data XConf = XConf
     { display           :: Display      -- ^ the X11 display
@@ -52,8 +51,7 @@ data XConf = XConf
 
     , xineScreens       :: ![Rectangle] -- ^ dimensions of each screen
     , normalBorder      :: !Color       -- ^ border color of unfocused windows
-    , focusedBorder     :: !Color       -- ^ border color of the focused window
-    }
+    , focusedBorder     :: !Color     } -- ^ border color of the focused window
 
 type WindowSet = StackSet WorkspaceId ScreenId Window
 
@@ -95,10 +93,30 @@ isRoot w = liftM (w==) (asks theRoot)
 -- Layout handling
 
 -- | The different layout modes
--- 'doLayout', a pure function to layout a Window set
--- 'modifyLayout', 
+-- 'doLayout', a pure function to layout a Window set 'modifyLayout', 
+-- 'modifyLayout' can be considered a branch of an exception handler.
+--
 data Layout = Layout { doLayout     :: Rectangle -> [Window] -> [(Window, Rectangle)]
-                     , modifyLayout :: Dynamic -> Maybe Layout }
+                     , modifyLayout :: SomeMessage -> Maybe Layout }
+
+-- Based on ideas in /An Extensible Dynamically-Typed Hierarchy of Exceptions/,
+-- Simon Marlow, 2006. Use extensible messages to the modifyLayout handler.
+-- 
+-- User-extensible messages must be a member of this class:
+--
+class (Typeable a, Show a) => Message a
+
+--
+-- A wrapped value of some type in the Message class.
+--
+data SomeMessage = forall a. Message a => SomeMessage a
+
+--
+-- And now, unwrap a given, unknown Message type, performing a (dynamic)
+-- type check on the result.
+--
+fromMessage :: Message m => SomeMessage -> Maybe m
+fromMessage (SomeMessage m) = cast m
 
 -- ---------------------------------------------------------------------
 -- Utilities