-- 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