From ba6e32758d41f1117fc125b32008c2f411eec8b1 Mon Sep 17 00:00:00 2001
From: Don Stewart <dons@cse.unsw.edu.au>
Date: Fri, 4 May 2007 10:16:49 +0200
Subject: 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

darcs-hash:20070504081649-9c5c1-954b406e8c21c2ca4428960e4fc1f9ffb17fb296.gz
---
 Operations.hs | 44 ++++++++++++++++++++++++--------------------
 1 file changed, 24 insertions(+), 20 deletions(-)

(limited to 'Operations.hs')

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
-- 
cgit v1.2.3