blob: 983ceb19527d3e3263b900fae351830239069b09 (
plain) (
blame)
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
|
{-# LANGUAGE ViewPatterns #-}
module Wetterhorn.Layout.Combine where
import Data.Typeable
import Wetterhorn.Constraints
import Wetterhorn.Core.W
data (|||) a b = Comb LR a b
deriving (Typeable, Read, Show)
data Next = Next
deriving (Typeable)
data Reset = Reset
deriving (Typeable)
(|||) :: a -> b -> (a ||| b)
a ||| b = Comb L a b
data LR = L | R deriving (Read, Show, Ord, Eq, Enum)
instance (LayoutClass a, LayoutClass b) => LayoutClass (a ||| b) where
type C (a ||| b) = C a &&&& C b
runLayout as (Comb R r l) = do
(r', ret) <- runLayout as r
return (Comb R r' l, ret)
runLayout as (Comb L r l) = do
(l', ret) <- runLayout as l
return (Comb R r l', ret)
handleMessage (fromMessage -> Just Next) (Comb L l r) = return (Comb R l r)
handleMessage (fromMessage -> Just Reset) (Comb _ l r) = return (Comb L l r)
handleMessage mesg (Comb L l r) =
Comb L <$> handleMessage mesg l <*> pure r
handleMessage mesg (Comb R l r) =
Comb L l <$> handleMessage mesg r
serializeLayout (Comb lr l r) = show (Comb lr (serializeLayout l) (serializeLayout r))
readLayout str = Comb lr <$> l <*> r
where
(Comb lr (readLayout -> l) (readLayout -> r)) = read str
description (Comb _ l r) = description l ++ " ||| " ++ description r
|
