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
|
{-# LANGUAGE Haskell2010 #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints -fno-warn-missing-methods #-}
{-# LANGUAGE DeriveDataTypeable, ExistentialQuantification, RankNTypes, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, PatternGuards, DatatypeContexts #-}
module T4355 where
import Control.Arrow
import Control.Monad.Trans -- From mtl
import Control.Monad.Reader -- Ditto
import Data.Typeable
import Data.Maybe
class (Eq t, Typeable t) => Transformer t a | t -> a where
transform :: (LayoutClass l a) => t -> l a ->
(forall l'. (LayoutClass l' a) => l' a -> (l' a -> l a) -> b) -> b
class HList c a where
find :: (Transformer t a) => c -> t -> Maybe Int
class Typeable a => Message a
data (LayoutClass l a) => EL l a = forall l'. (LayoutClass l' a) => EL (l' a) (l' a -> l a)
unEL :: (LayoutClass l a) => EL l a -> (forall l'. (LayoutClass l' a) => l' a -> b) -> b
unEL (EL x _) k = k x
transform' :: (Transformer t a, LayoutClass l a) => t -> EL l a -> EL l a
transform' t (EL l det) = transform t l (\l' det' -> EL l' (det . det'))
data Toggle a = forall t. (Transformer t a) => Toggle t
deriving (Typeable)
instance (Typeable a) => Message (Toggle a)
data MultiToggle ts l a = MultiToggle{
currLayout :: EL l a,
currIndex :: Maybe Int,
transformers :: ts
}
instance (Show ts, Show (l a), LayoutClass l a) => Show (MultiToggle ts l a) where
class Show (layout a) => LayoutClass layout a where
handleMessage :: layout a -> SomeMessage -> IO (Maybe (layout a))
instance (Typeable a, Show ts, HList ts a, LayoutClass l a)
=> LayoutClass (MultiToggle ts l) a where
handleMessage mt m
| Just (Toggle t) <- fromMessage m
, i@(Just _) <- find (transformers mt) t
= case currLayout mt of
EL l det -> do
return . Just $
mt {
currLayout = (if cur then id else transform' t) (EL (det l) id)
}
where cur = (i == currIndex mt)
data SomeMessage = forall a. Message a => SomeMessage a
fromMessage :: Message m => SomeMessage -> Maybe m
fromMessage (SomeMessage m) = cast m
|
