Ticket #6168: Bug.hs

File Bug.hs, 1.9 KB (added by selinger, 3 years ago)
Line 
1{-# OPTIONS -XTypeFamilies -XFunctionalDependencies -XFlexibleInstances #-}
2
3module Bug where
4
5liftM :: (Monad m) => (a -> b) -> (m a -> m b)
6liftM f a = do
7  x <- a
8  return $ f x
9
10class Tuple t s | s -> t, t -> s where
11  tuple :: s -> t
12  untuple :: t -> s
13
14instance Tuple (a,b,c,d,e,f,g,h,i) (a,(b,(c,(d,(e,(f,(g,(h,(i,()))))))))) where
15    tuple (a,(b,(c,(d,(e,(f,(g,(h,(i,()))))))))) = (a,b,c,d,e,f,g,h,i)
16    untuple (a,b,c,d,e,f,g,h,i) = (a,(b,(c,(d,(e,(f,(g,(h,(i,())))))))))
17
18instance Tuple (a,b,c,d,e,f,g,h,i,j) (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,())))))))))) where
19    tuple (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,())))))))))) = (a,b,c,d,e,f,g,h,i,j)
20    untuple (a,b,c,d,e,f,g,h,i,j) = (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,()))))))))))
21
22type family Subst x y a
23type instance Subst x y () = ()
24type instance Subst x y (a,b) = (Subst x y a, Subst x y b)
25type instance Subst x y (a,b,c,d,e,f,g,h,i) = (Subst x y a, Subst x y b, Subst x y c, Subst x y d, Subst x y e, Subst x y f, Subst x y g, Subst x y h, Subst x y i)
26type instance Subst x y (a,b,c,d,e,f,g,h,i,j) = (Subst x y a, Subst x y b, Subst x y c, Subst x y d, Subst x y e, Subst x y f, Subst x y g, Subst x y h, Subst x y i, Subst x y j)
27
28class (t ~ Subst Int Int t) => Mydata t where
29  mymap :: (Monad m) => t -> (d -> m d') -> (c -> m c') -> Subst d c t -> m (Subst d' c' t)
30
31instance Mydata () where
32  mymap s f g () = return ()
33
34instance (Mydata a, Mydata b) => Mydata (a,b) where
35  mymap ~(a,b) f g (x,y) = do
36    x' <- mymap a f g x
37    y' <- mymap b f g y
38    return (x', y')
39
40instance (Mydata a, Mydata b, Mydata c, Mydata d, Mydata e, Mydata f, Mydata g, Mydata h, Mydata i) => Mydata (a,b,c,d,e,f,g,h,i) where
41  mymap s f g xs = liftM tuple $ mymap (untuple s) f g (untuple xs)
42
43instance (Mydata a, Mydata b, Mydata c, Mydata d, Mydata e, Mydata f, Mydata g, Mydata h, Mydata i, Mydata j) => Mydata (a,b,c,d,e,f,g,h,i,j) where
44  mymap s f g xs = liftM tuple $ mymap (untuple s) f g (untuple xs)