This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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" |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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