Skip to content

Instantly share code, notes, and snippets.

@mbbx6spp
Last active May 12, 2019 18:55
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save mbbx6spp/51bf2b694dc9bbf81b60f2f616453eb3 to your computer and use it in GitHub Desktop.
Save mbbx6spp/51bf2b694dc9bbf81b60f2f616453eb3 to your computer and use it in GitHub Desktop.
Doodle to help explain Profunctors and Yoneda embedding application.
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Profunctors where
import Data.Either
import Data.Maybe
import Data.Functor
import Data.Function ((.), ($))
class Iso a b where
to :: a -> b
from :: b -> a
-- law: a = from . to a
type Lens s t a b
= forall p. Strong (p :: * -> * -> *) => p a b -> p s t
type Prism s t a b
= forall p. Choice (p :: * -> * -> *) => p a b -> p s t
class Profunctor (p :: * -> * -> *) where
dimap :: (a -> b) -> (c -> d) -> (p b c -> p a d)
-- laws:
-- dimap identity identity = identity
-- dimap (f' . f) (g . g') = dimap f g · dimap f' g'
instance Profunctor (->) where
dimap f g h = g . h . f
class Profunctor p => Strong (p :: * -> * -> *) where
first' :: p a b -> p (a, c) (b, c)
class Profunctor p => Choice (p :: * -> * -> *) where
left' :: p a b -> p (Either a c) (Either b c)
class Profunctor p => Cartesian (p :: * -> * -> *) where
first :: p a b -> p (a, c) (b, c)
second :: p a b -> p (c, a) (c, b)
-- laws:
-- dimap runit runit' h = first h
-- dimap assoc assoc' (first (first h)) = first h
-- where
-- runit :: (a, ()) -> a
-- runit' :: a -> (a, ())
-- assoc :: (a, (b, c)) -> ((a, b), c)
-- assoc' :: ((a, b), c) -> (a, (b, c))
instance Cartesian (->) where
first f (a, c) = (f a, c)
second f (c, a) = ( c, f a)
class Profunctor p => Monoidal p where
par :: p a b -> p c d -> p (a, c) (b, d)
empty :: p () ()
-- laws:
-- dimap assoc assoc' (par (par h j) k) = par h (par j k)
-- dimap runit runit' h = par h empty
-- dimap lunit lunit' h = par empty h
-- where
-- lunit :: ((), a) -> a
-- lunit' :: a -> ((), a)
-- runit :: (a, ()) -> a
-- runit' :: a -> (a, ())
instance Monoidal (->) where
par f g (a, c) = (f a, g c)
empty = identity
-- Natural transformations
type f ~> g = forall x. f x -> g x
-- Examples of natural transformations
-- safeHead :: [a] -> Maybe a
safeHead :: [] ~> Maybe
safeHead [] = Nothing
safeHead (a: _) = Just a
-- singletonList :: Maybe a -> [a]
singletonList :: Maybe ~> []
singletonList Nothing = []
singletonList (Just a) = [a]
-- Reader and the Yoneda Lemma
newtype Reader a x
= Reader { runReader :: a -> x }
instance Functor (Reader a) where
fmap f x = Reader (f . runReader x)
newtype Yoneda f a = Yoneda {
runYoneda :: Functor f => Reader a ~> f
}
toYoneda :: Functor f => f a -> Yoneda f a
toYoneda fa = Yoneda (\x -> fmap (runReader x) fa)
fromYoneda :: Functor f => Yoneda f a -> f a
fromYoneda yo = runYoneda yo (Reader identity)
-- auxilliary functions
identity :: a -> a
identity a = a
flip :: (b -> a -> c) -> a -> b -> c
flip f a b = f b a
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment