Skip to content

Instantly share code, notes, and snippets.

@alpmestan alpmestan/coyo.hs
Last active May 10, 2018

Embed
What would you like to do?
Coyoneda lemma & fmap fusion
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
import Data.Monoid
import System.Environment
data Coyoneda f a where
Coyoneda :: (b -> a) -> f b -> Coyoneda f a
instance Functor (Coyoneda f) where
fmap f (Coyoneda b2a fb) = Coyoneda (f . b2a) fb
coyo :: f a -> Coyoneda f a
coyo = Coyoneda id
uncoyo :: Functor f => Coyoneda f a -> f a
uncoyo (Coyoneda b2a fb) = fmap b2a fb
withCoyo :: Functor f
=> (Coyoneda f a -> Coyoneda f b)
-> f a
-> f b
withCoyo f = uncoyo . f . coyo
{-
uncoyo . fmap f . fmap g . coyo
= uncoyo . fmap f . fmap g . Coyoneda id
= uncoyo . fmap f . Coyoneda (g . id)
= uncoyo . fmap f . Coyoneda g
= uncoyo . Coyoneda (f . g)
= fmap (f . g)
-}
data Tree a = Bin a (Tree a) (Tree a)
| Nil
deriving (Eq, Show)
instance Functor Tree where
fmap _ Nil = Nil
fmap f (Bin a l r) = Bin (f a) (fmap f l) (fmap f r)
instance Foldable Tree where
foldMap _ Nil = mempty
foldMap f (Bin a l r) = f a <> foldMap f l <> foldMap f r
sumTree :: Num a => Tree a -> a
sumTree = getSum . foldMap Sum
t :: Tree Integer
t = go 1
where go r = Bin r (go (2*r)) (go (2*r + 1))
takeDepth :: Int -> Tree a -> Tree a
takeDepth _ Nil = Nil
takeDepth 0 _ = Nil
takeDepth d (Bin r t1 t2) = Bin r (takeDepth (d-1) t1) (takeDepth (d-1) t2)
transform :: (Functor f, Num a) => f a -> f a
transform = fmap (^2) . fmap (+1) . fmap (*2)
main :: IO ()
main = getArgs >>= \args -> case args of
[k] -> print . sumTree . takeDepth (read k) $ transform t
[k, "--coyo"] ->
print . sumTree . takeDepth (read k) $ withCoyo transform t
_ -> error "wrong arguments"
@ulysses4ever

This comment has been minimized.

Copy link

ulysses4ever commented Aug 25, 2017

Derive-pragmas at the top are redundant.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.