-- code of the article "An Investigation of the Laws of Traversals"
-- by Mauro Jaskelioff and Ondrej Rypacek

import Data.Monoid

class Functor f => Applicative f where
    pure   :: x -> f x
    (<*>)  :: f (a -> b) -> f a -> f b

newtype K a b = K {unK :: a}

instance Monoid a => Applicative (K a) where
     pure x   = K mempty
     f <*> x  = K (mappend (unK f) (unK x))

instance Functor Id where
    fmap f x = Id (f (unId x))

instance (Functor f, Functor g) => Functor (C f g) where
    fmap f (Comp fgx) = Comp (fmap (fmap f) fgx)
  
newtype Id a = Id {unId :: a}

instance Applicative Id where
     pure      = Id
     f <*> x   = Id (unId f (unId x))

newtype C f g a = Comp {unComp :: f (g a) }

instance (Applicative f, Applicative g) => Applicative (C f g) where
    pure       = Comp . pure . pure
    f <*> x    = Comp (pure (<*>) <*> unComp f <*> unComp x)

instance Traversable [] where
    dist []       = pure []
    dist (x:xs)   = pure (:) <*> x <*> dist xs

instance Functor Bin where
     fmap _ Leaf          = Leaf
     fmap f (Node l a r)  = Node (fmap f l) (f a) (fmap f r)

data Bin a = Leaf | Node (Bin a) a (Bin a)   

instance Traversable Bin where
    dist Leaf          = pure Leaf
    dist (Node l a r)  = pure Node <*> dist l <*> a <*> dist r 

instance Traversable Id where
    dist (Id x)  = fmap Id x

instance Functor (K a) where
     fmap f (K x) = K x

toList  :: Traversable t => t a -> [a]
toList  = unK . dist . fmap wrap
     where  wrap    :: x -> K [x] a
            wrap x  = K [x]

distL, distL2, distL3  :: Applicative f => [f a] -> f [a]
distL _                = pure []  

distL2 []              = pure []  
distL2 [x]             = pure []
distL2 (x:y:xs)        = pure (:) <*> x <*> distL2 (y:xs)

distL3 []              = pure []
distL3 (x:xs)          = pure (:) <*> x' <*> distL3 xs
                           where x' = pure (\x y -> x) <*> x <*> x

class Functor t => Traversable t where
    traverse  :: Applicative f => (a -> f b) -> t a -> f (t b)
    dist      :: Applicative f => t (f a) -> f (t a)
    consume   :: Applicative f => (t a -> b) -> t (f a) -> f b

    traverse f   = dist . fmap f
    dist         = consume id
    consume f    = fmap f . traverse id