Ticket #4355: tcBug.hs

File tcBug.hs, 2.6 KB (added by maltem, 4 years ago)
Line 
1{-# LANGUAGE DeriveDataTypeable, ExistentialQuantification, Rank2Types, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, PatternGuards #-}
2
3module TcBug where
4
5import Control.Arrow
6import Control.Monad.Trans
7import Control.Monad.Reader
8import Data.Typeable
9import Data.Maybe
10
11class (Eq t, Typeable t) => Transformer t a | t -> a where
12    transform :: (LayoutClass l a) => t -> l a ->
13        (forall l'. (LayoutClass l' a) => l' a -> (l' a -> l a) -> b) -> b
14
15class HList c a where
16    find :: (Transformer t a) => c -> t -> Maybe Int
17
18class Typeable a => Message a
19
20data (LayoutClass l a) => EL l a = forall l'. (LayoutClass l' a) => EL (l' a) (l' a -> l a)
21
22unEL :: (LayoutClass l a) => EL l a -> (forall l'. (LayoutClass l' a) => l' a -> b) -> b
23unEL (EL x _) k = k x
24
25transform' :: (Transformer t a, LayoutClass l a) => t -> EL l a -> EL l a
26transform' t (EL l det) = transform t l (\l' det' -> EL l' (det . det'))
27
28data Toggle a = forall t. (Transformer t a) => Toggle t
29    deriving (Typeable)
30
31instance (Typeable a) => Message (Toggle a)
32
33data MultiToggle ts l a = MultiToggle{
34    currLayout :: EL l a,
35    currIndex :: Maybe Int,
36    transformers :: ts
37}
38
39instance (Show ts, Show (l a), LayoutClass l a) => Show (MultiToggle ts l a) where
40
41class Show (layout a) => LayoutClass layout a where
42    handleMessage :: layout a -> SomeMessage -> IO (Maybe (layout a))
43    handleMessage l  = return . pureMessage l
44
45    pureMessage :: layout a -> SomeMessage -> Maybe (layout a)
46    pureMessage _ _  = Nothing
47
48instance (Typeable a, Show ts, HList ts a, LayoutClass l a) => LayoutClass (MultiToggle ts l) a where
49    handleMessage mt m
50        | Just (Toggle t) <- fromMessage m
51        , i@(Just _) <- find (transformers mt) t
52            = case currLayout mt of
53                EL l det -> do
54                    l' <- fromMaybe l `fmap` handleMessage l (SomeMessage ReleaseResources)
55                    return . Just $
56                        mt {
57                            currLayout = (if cur then id else transform' t) (EL (det l') id),
58                            currIndex = if cur then Nothing else i
59                        }
60                    where cur = (i == currIndex mt)
61        | otherwise
62            = case currLayout mt of
63                EL l det -> fmap (fmap (\x -> mt { currLayout = EL x det })) $
64                    handleMessage l m
65
66data LayoutMessages = ReleaseResources
67    deriving (Typeable, Eq)
68
69instance Message LayoutMessages
70
71data SomeMessage = forall a. Message a => SomeMessage a
72
73fromMessage :: Message m => SomeMessage -> Maybe m
74fromMessage (SomeMessage m) = cast m
75