Skip to content

Instantly share code, notes, and snippets.

@hiratara
Created November 18, 2012 07:39
  • Star 1 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save hiratara/4104020 to your computer and use it in GitHub Desktop.
{-# LANGUAGE RankNTypes #-}
module Main where
import Control.Monad
import Control.Monad.Identity
import Data.Functor.Compose
natComp :: (Functor m1, Functor m2, Functor m3, Functor m4) =>
(forall a.m1 a -> m2 a) -> (forall a.m3 a -> m4 a)
-> (forall a.m3 (m1 a) -> m4 (m2 a))
s `natComp` t = (fmap s) . t
join' :: Monad m => Compose m m a -> m a
join' (Compose m) = join m
clockwise1 :: (Functor m, Monad m) => m (m (m a)) -> m a
clockwise1 = join . (join' `natComp` id) . iso
where iso :: Functor f => f (f (f a)) -> f (Compose f f a)
iso = fmap Compose
unticlockwise1 :: (Functor m, Monad m) => m (m (m a)) -> m a
unticlockwise1 = join . (id `natComp` join') . iso
where iso :: Functor f => f (f a) -> Compose f f a
iso = Compose
return' :: Monad m => Identity a -> m a
return' (Identity x) = return x
clockwise2 :: (Functor m, Monad m) => m a -> m a
clockwise2 = join . (id `natComp` return') . iso
where iso :: b -> Identity b
iso = Identity
unticlockwise2 :: (Functor m, Monad m) => m a -> m a
unticlockwise2 = id
clockwise3 :: (Functor m, Monad m) => m a -> m a
clockwise3 = id
unticlockwise3 :: (Functor m, Monad m) => m a -> m a
unticlockwise3 = join . (return' `natComp` id) . iso
where iso :: Functor f => f b -> f (Identity b)
iso = fmap Identity
main :: IO ()
main = do
print $ let arg = [["abc", "def"], ["ghi"]]
in clockwise1 arg == unticlockwise1 arg
print $ clockwise2 "abc" == unticlockwise2 "abc"
print $ clockwise3 "abc" == unticlockwise3 "abc"
module Main where
import Data.Monoid
assoc :: ((a, b), c) -> (a, (b, c))
assoc ((x, y), z) = (x, (y, z))
prod :: (a -> b, c -> d) -> (a, c) -> (b, d)
prod (f, g) (x, y) = (f x, g y)
mappend' :: Monoid a => (a, a) -> a
mappend' = uncurry mappend
mempty' :: Monoid b => a -> b
mempty' = const mempty
clockwise1 :: Monoid a => ((a, a), a) -> a
clockwise1 = mappend' . prod (id, mappend') . assoc
unticlockwise1 :: Monoid a => ((a, a), a) -> a
unticlockwise1 = mappend' . prod (mappend', id)
clockwise2 :: Monoid a => ((), a) -> a
clockwise2 = mappend' . prod (mempty', id)
unticlockwise2 :: Monoid a => ((), a) -> a
unticlockwise2 = snd
clockwise3 :: Monoid a => (a, ()) -> a
clockwise3 = mappend' . prod (id, mempty')
unticlockwise3 :: Monoid a => (a, ()) -> a
unticlockwise3 = fst
main :: IO ()
main = do
print $ let args = (("abc", "def"), "ghi")
in clockwise1 args == unticlockwise1 args
print $ let args = ((), "ghi")
in clockwise2 args == unticlockwise2 args
print $ let args = ("abc", ())
in clockwise3 args == unticlockwise3 args
return ()
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment