blob: 8079da3ae799fffab8bd1e0018c859721fc0c7c0 (
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
46
47
48
49
|
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-missing-export-lists #-}
module Montis.Layout.Combine where
import Data.Typeable
import Montis.Constraints
import Montis.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 (HandleMessage a, HandleMessage b) => HandleMessage (a ||| b) where
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
instance (LayoutClass a, LayoutClass b) => LayoutClass (a ||| b) where
-- In order to use this layout class, the lay-out type 'a' must satisfy BOTH
-- the left and right constraints.
type LayoutConstraint (a ||| b) = LayoutConstraint a &&&& LayoutConstraint 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)
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
|
