Ticket #6168: Bug.hs

{-# OPTIONS -XTypeFamilies -XFunctionalDependencies -XFlexibleInstances #-}

module Bug where

liftM :: (Monad m) => (a -> b) -> (m a -> m b)
liftM f a = do
  x <- a
  return $ f x

class Tuple t s | s -> t, t -> s where
  tuple :: s -> t
  untuple :: t -> s

instance Tuple (a,b,c,d,e,f,g,h,i) (a,(b,(c,(d,(e,(f,(g,(h,(i,()))))))))) where
    tuple (a,(b,(c,(d,(e,(f,(g,(h,(i,()))))))))) = (a,b,c,d,e,f,g,h,i)
    untuple (a,b,c,d,e,f,g,h,i) = (a,(b,(c,(d,(e,(f,(g,(h,(i,())))))))))

instance Tuple (a,b,c,d,e,f,g,h,i,j) (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,())))))))))) where
    tuple (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,())))))))))) = (a,b,c,d,e,f,g,h,i,j)
    untuple (a,b,c,d,e,f,g,h,i,j) = (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,()))))))))))

type family Subst x y a
type instance Subst x y () = ()
type instance Subst x y (a,b) = (Subst x y a, Subst x y b)
type 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)
type 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)

class (t ~ Subst Int Int t) => Mydata t where
  mymap :: (Monad m) => t -> (d -> m d') -> (c -> m c') -> Subst d c t -> m (Subst d' c' t)

instance Mydata () where
  mymap s f g () = return ()

instance (Mydata a, Mydata b) => Mydata (a,b) where
  mymap ~(a,b) f g (x,y) = do
    x' <- mymap a f g x
    y' <- mymap b f g y
    return (x', y')

instance (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
  mymap s f g xs = liftM tuple $ mymap (untuple s) f g (untuple xs)

instance (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
  mymap s f g xs = liftM tuple $ mymap (untuple s) f g (untuple xs)