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
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
|
module Wetterhorn.Core.W where
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 Data.Data (Typeable, cast)
import Data.Kind (Constraint, Type)
import Data.Set (Set)
import Foreign (StablePtr)
import Text.Read
import Wetterhorn.Core.KeyEvent
import Wetterhorn.Core.SurfaceEvent
import Wetterhorn.Foreign
import Wetterhorn.Foreign.ForeignInterface (ForeignInterface)
import Wetterhorn.StackSet hiding (layout)
data RationalRect = RationalRect Rational Rational Rational Rational
-- | Wrapper for a message. Messages are sent to layout and layouts are supposed
-- to handle them. This hides a typeable parameter.
data Message where
Message :: (Typeable a) => a -> Message
-- | casts a message to a type.
fromMessage :: (Typeable a) => Message -> Maybe a
fromMessage (Message t) = cast t
-- | Wraps a type in a message.
toMessage :: (Typeable a) => a -> Message
toMessage = Message
-- | Types of this class "lay out" windows by assigning rectangles and handle
-- messages.
class (Typeable 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
-- | 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
readLayout :: String -> Maybe l
default readLayout :: (Read l) => String -> Maybe l
readLayout = readMaybe
serializeLayout :: l -> String
default serializeLayout :: (Show l) => l -> String
serializeLayout = show
description :: l -> String
default description :: (Show l) => l -> String
description = show
-- 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
runWindowLayout :: [Window] -> WindowLayout -> W (WindowLayout, [(Window, RationalRect)])
runWindowLayout as (WindowLayout l) = first WindowLayout <$> runLayout as l
handleWindowMessage :: Message -> WindowLayout -> W WindowLayout
handleWindowMessage m (WindowLayout l) = WindowLayout <$> handleMessage m l
-- | Using the 'Layout' as a witness, parse existentially wrapped windows
-- from a 'String'.
readWindowLayout :: WindowLayout -> String -> WindowLayout
readWindowLayout (WindowLayout l) s
| (Just x) <- readLayout s =
WindowLayout (asTypeOf x l)
readWindowLayout l _ = l
serializeWindowLayout :: WindowLayout -> String
serializeWindowLayout (WindowLayout l) = serializeLayout l
type ScreenId = ()
type ScreenDetail = ()
type Tag = String
newtype Window = Window (TypedIntPtr ())
deriving (Eq, Ord, Show, Read)
type Wetterhorn = StablePtr (Context, State)
data Context = Context
{ ctxForeignInterface :: ForeignInterface,
ctxConfig :: Config WindowLayout
}
defaultConfig :: Config ()
defaultConfig =
Config
{ keyHook = \_ -> return (),
surfaceHook = \_ -> return (),
layout = ()
}
data Config l = Config
{ keyHook :: KeyEvent -> W (),
surfaceHook :: SurfaceEvent -> W (),
layout :: l
}
data State = State
{ mapped :: StackSet ScreenId ScreenDetail Tag WindowLayout Window,
allWindows :: Set Window
}
initColdState :: WindowLayout -> IO State
initColdState l = return $ State (StackSet (Screen () () (Workspace "0" l (Stack [] []))) [] []) mempty
marshalState :: State -> String
marshalState (State mapped allWindows) =
show
( mapLayout serializeWindowLayout mapped,
allWindows
)
demarshalState :: WindowLayout -> String -> State
demarshalState witness str = State mapped allWindows
where
(mapLayout (readWindowLayout witness) -> mapped, allWindows) = read str
newtype W a = W (ReaderT Context (StateT State IO) a)
deriving (Functor, Applicative, Monad, MonadState State, MonadReader Context, MonadIO)
runW :: W a -> (Context, State) -> IO (a, State)
runW (W fn) (ctx, st) = runStateT (runReaderT fn ctx) st
wio :: IO a -> W a
wio = liftIO
|
