testsuite: Assert that testsuite ways are known
[ghc.git] / testsuite / tests / typecheck / should_compile / T4355.hs
1 {-# OPTIONS_GHC -fno-warn-redundant-constraints -fno-warn-missing-methods #-}
2 {-# LANGUAGE DeriveDataTypeable, ExistentialQuantification, RankNTypes, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, PatternGuards, DatatypeContexts #-}
3
4 module T4355 where
5
6 import Control.Arrow
7 import Control.Monad.Trans -- From mtl
8 import Control.Monad.Reader -- Ditto
9 import Data.Typeable
10 import Data.Maybe
11
12 class (Eq t, Typeable t) => Transformer t a | t -> a where
13 transform :: (LayoutClass l a) => t -> l a ->
14 (forall l'. (LayoutClass l' a) => l' a -> (l' a -> l a) -> b) -> b
15
16 class HList c a where
17 find :: (Transformer t a) => c -> t -> Maybe Int
18
19 class Typeable a => Message a
20
21 data (LayoutClass l a) => EL l a = forall l'. (LayoutClass l' a) => EL (l' a) (l' a -> l a)
22
23 unEL :: (LayoutClass l a) => EL l a -> (forall l'. (LayoutClass l' a) => l' a -> b) -> b
24 unEL (EL x _) k = k x
25
26 transform' :: (Transformer t a, LayoutClass l a) => t -> EL l a -> EL l a
27 transform' t (EL l det) = transform t l (\l' det' -> EL l' (det . det'))
28
29 data Toggle a = forall t. (Transformer t a) => Toggle t
30 deriving (Typeable)
31
32 instance (Typeable a) => Message (Toggle a)
33
34 data MultiToggle ts l a = MultiToggle{
35 currLayout :: EL l a,
36 currIndex :: Maybe Int,
37 transformers :: ts
38 }
39
40 instance (Show ts, Show (l a), LayoutClass l a) => Show (MultiToggle ts l a) where
41
42 class Show (layout a) => LayoutClass layout a where
43 handleMessage :: layout a -> SomeMessage -> IO (Maybe (layout a))
44
45 instance (Typeable a, Show ts, HList ts a, LayoutClass l a)
46 => LayoutClass (MultiToggle ts l) a where
47 handleMessage mt m
48 | Just (Toggle t) <- fromMessage m
49 , i@(Just _) <- find (transformers mt) t
50 = case currLayout mt of
51 EL l det -> do
52 return . Just $
53 mt {
54 currLayout = (if cur then id else transform' t) (EL (det l) id)
55 }
56 where cur = (i == currIndex mt)
57
58 data SomeMessage = forall a. Message a => SomeMessage a
59
60 fromMessage :: Message m => SomeMessage -> Maybe m
61 fromMessage (SomeMessage m) = cast m