1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
|
{-# LANGUAGE GADTs, RankNTypes, FlexibleInstances, MultiParamTypeClasses,
FlexibleContexts, UndecidableInstances, ViewPatterns, StandaloneDeriving,
RankNTypes, TupleSections #-}
{- This module provides a more powerful version of the choose layout, using a
- list to store the layouts, and thus the list is navigatable. -}
module Internal.LayoutZipper where
import Control.Monad.Identity (runIdentity)
import Data.Maybe (fromMaybe)
import Control.Arrow (second)
import XMonad
import qualified XMonad.StackSet as W
import Data.Proxy
data LNil a = LNil deriving (Read, Show)
data LCons l t a = LCons (l a) (t a) deriving (Read, Show)
data LayoutZipper l a = LayoutZipper Int (l a)
deriving (Read, Show)
-- Combinator for combining layouts together into a LayoutList. This amy then be
-- used with the layoutZipper to create a layout zipper.
(|:) :: (LayoutSelect t a, LayoutClass l a) => l a -> t a -> LCons l t a
(|:) = LCons
infixr 5 |:
-- Create a layoutZipper that defaults to the first layout in the list.
layoutZipper :: (LayoutSelect l a) => l a -> LayoutZipper l a
layoutZipper = LayoutZipper 0
-- The termination of a layout zipper.
nil :: LNil a
nil = LNil
-- Message to navigate to a layout.
data NavigateLayout =
-- Sets the layout based on the given function.
SetLayout {
changeLayoutFn :: Int -> Int -- Function to use to change the layout.
, circularBool :: Bool -- True if the layouts should be treated as circular.
}
deriving (Typeable)
toNextLayout :: NavigateLayout
toNextLayout = SetLayout (+1) True
toPreviousLayout :: NavigateLayout
toPreviousLayout = SetLayout (\x -> x - 1) True
toFirstLayout :: NavigateLayout
toFirstLayout = SetLayout (const 0) True
instance Message NavigateLayout where
class LayoutSelect l a where
update :: forall r m. (Monad m) =>
Int ->
l a ->
(forall l'. (LayoutClass l' a) => l' a -> m (r, Maybe (l' a))) ->
m (Maybe (r, l a))
nLayouts :: l a -> Int
instance (Read (l a), LayoutClass l a, LayoutSelect t a) =>
LayoutSelect (LCons l t) a where
update 0 (LCons layout t) fn = do
(r, layout') <- fn layout
return $ Just (r, LCons (fromMaybe layout layout') t)
update n (LCons l t) fn = do
(fmap . fmap) (second $ \t' -> LCons l t') $ update (n - 1) t fn
nLayouts (LCons _ t) = 1 + nLayouts t
instance LayoutSelect LNil a where
update _ _ _ = return Nothing
nLayouts _ = 0
instance (Show (l a), Typeable l, LayoutSelect l a) => LayoutClass (LayoutZipper l) a where
runLayout (W.Workspace i (LayoutZipper idx l) ms) r = do
r <- update idx l $ \layout ->
runLayout (W.Workspace i layout ms) r
case r of
Nothing -> return ([], Nothing)
Just (r, la) -> return (r, Just (LayoutZipper idx la))
pureLayout (LayoutZipper idx l) r s = runIdentity $ do
r <- update idx l $ \layout -> return (pureLayout layout r s, Nothing)
case r of
Nothing -> return []
Just (r, a) -> return r
emptyLayout (LayoutZipper idx l) r = do
r <- update idx l $ \layout -> emptyLayout layout r
case r of
Nothing -> return ([], Nothing)
Just (r, la) -> return (r, Just (LayoutZipper idx la))
handleMessage (LayoutZipper idx l) (fromMessage -> Just (SetLayout fn circ)) =
let clip = if circ then mod else \i n -> max 0 $ min (n - 1) i in
return $ Just $ LayoutZipper (clip (fn idx) (nLayouts l)) l
handleMessage (LayoutZipper idx l) m = do
r <- update idx l $ \layout -> ((),) <$> handleMessage layout m
return $ LayoutZipper idx . snd <$> r
pureMessage (LayoutZipper idx l) m = runIdentity $ do
r <- update idx l $ \layout -> return ((), pureMessage layout m)
return $ LayoutZipper idx . snd <$> r
description (LayoutZipper idx l) = runIdentity $ do
r <- update idx l $ \l -> return (description l, Nothing)
return $
case r of
Nothing -> "No Layout"
Just (descr, _) -> descr
|
