diff options
author | Don Stewart <dons@galois.com> | 2007-10-14 01:21:50 +0200 |
---|---|---|
committer | Don Stewart <dons@galois.com> | 2007-10-14 01:21:50 +0200 |
commit | a175d7fbee65b22aec5f6e9dbf6d987dd040a44a (patch) | |
tree | c19cd31940cd8a98fe95d63fcfaa5cc15efd316f | |
parent | 2cdd0ccc222f5780c23765a93c4e477424aa77b0 (diff) | |
download | metatile-a175d7fbee65b22aec5f6e9dbf6d987dd040a44a.tar metatile-a175d7fbee65b22aec5f6e9dbf6d987dd040a44a.zip |
document, and use better names, for serialising/existential-dispatch framework
darcs-hash:20071013232150-cba2c-dc3ee2254f4ebdb5d0099ec0a38c5665f1ad4d3f
-rw-r--r-- | Operations.hs | 8 | ||||
-rw-r--r-- | XMonad.hs | 25 |
2 files changed, 20 insertions, 13 deletions
diff --git a/Operations.hs b/Operations.hs index 0edfbb9..5b3bb2d 100644 --- a/Operations.hs +++ b/Operations.hs @@ -369,10 +369,10 @@ data ChangeLayout = NextLayout | PrevLayout | JumpToLayout String instance Message ChangeLayout instance ReadableLayout Window where - defaults = Layout (Select []) : - Layout Full : Layout (Tall 1 0.1 0.5) : - Layout (Mirror $ Tall 1 0.1 0.5) : - serialisedLayouts + readTypes = Layout (Select []) : + Layout Full : Layout (Tall 1 0.1 0.5) : + Layout (Mirror $ Tall 1 0.1 0.5) : + serialisedLayouts data Select a = Select [Layout a] deriving (Show, Read) @@ -134,10 +134,11 @@ atom_WM_STATE = getAtom "WM_STATE" -- | An existential type that can hold any object that is in the LayoutClass. data Layout a = forall l. LayoutClass l a => Layout (l a) + -- | This class defines a set of layout types (held in Layout -- objects) that are used when trying to read an existentially wrapped Layout. class ReadableLayout a where - defaults :: [Layout a] + readTypes :: [Layout a] -- | The different layout modes -- @@ -180,21 +181,27 @@ class (Show (layout a), Read (layout a)) => LayoutClass layout a where description :: layout a -> String description = show +-- Here's the magic for parsing serialised state of existentially +-- wrapped layouts: attempt to parse using the Read instance from each +-- type in our list of types, if any suceed, take the first one. instance ReadableLayout a => Read (Layout a) where - readsPrec _ s = take 1 $ concatMap rl defaults - -- We take the first parse only, because multiple matches - -- indicate a bad parse. - where rl (Layout x) = map (first Layout) $ rl' x - rl' :: LayoutClass l a => l a -> [(l a,String)] - rl' _ = reads s + + -- We take the first parse only, because multiple matches indicate a bad parse. + readsPrec _ s = take 1 $ concatMap readLayout readTypes + where + readLayout (Layout x) = map (first Layout) $ readAsType x + + -- the type indicates which Read instance to dispatch to. + -- That is, read asTypeOf the argument from the readTypes. + readAsType :: LayoutClass l a => l a -> [(l a, String)] + readAsType _ = reads s instance ReadableLayout a => LayoutClass Layout a where doLayout (Layout l) r s = fmap (fmap Layout) `liftM` doLayout l r s handleMessage (Layout l) = fmap (fmap Layout) . handleMessage l description (Layout l) = description l -instance Show (Layout a) where - show (Layout l) = show l +instance Show (Layout a) where show (Layout l) = show l -- | This calls doLayout if there are any windows to be laid out. runLayout :: LayoutClass l a => l a -> Rectangle -> StackOrNot a -> X ([(a, Rectangle)], Maybe (l a)) |