Profunctor lenses

profunctors.lhs

Profunctor lenses
=================

First, we enable the RankNTypes extension which gives us 'forall' and also import some modules:

> {-# LANGUAGE RankNTypes #-}
> module ProfunctorLenses where
> import Data.Profunctor
> import Data.Tagged
> import Data.Bifunctor
> import Data.Void
> import Control.Arrow hiding (first, second)
> import Control.Applicative

> class Bicontravariant f where
>   contrabimap :: (a -> b) -> (c -> d) -> f b d -> f a c
>   
>   contrafirst :: (a -> b) -> f b x -> f a x
>   contrafirst = flip contrabimap id
>   
>   contrasecond :: (c -> d) -> f x d -> f x c
>   contrasecond = contrabimap id
>
> contracoerce :: (Bicontravariant p, Profunctor p) => p x a -> p x b
> contracoerce = rmap absurd . contrasecond absurd
> 
> coerce :: (Bifunctor p, Profunctor p) => p a x -> p b x
> coerce = first absurd . lmap absurd

> type Optic p s t a b = p a b -> p s t
> type UnOptic p s t a b = p t s -> p b a
> type Iso s t a b = forall p. Profunctor p => Optic p s t a b
> type Prism s t a b = forall p. Choice p => Optic p s t a b
> type Lens s t a b = forall p. Strong p => Optic p s t a b
> type Setter s t a b = forall p. (Bifunctor p, Profunctor p) => Optic p s t a b
> type Getter s t a b = forall p. (Bicontravariant p, Profunctor p) => Optic p s t a b
> 
> newtype Flip p a b = Flip { unFlip :: p b a }

> view :: Optic (Forget a) s t a b -> s -> a
> view p = runForget $ p (Forget id)

> review :: Optic Tagged s t a b -> b -> t
> review p = unTagged . p . Tagged 

> over :: Optic (->) s t a b -> (a -> b) -> (s -> t)
> over = id
 
> set :: Optic (->) s t a b -> b -> s -> t
> set p = over p . const

> iso :: (s -> a) -> (b -> t) -> Iso s t a b
> iso = dimap
 
> lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
> lens f g = dimap (f &&& id) (uncurry $ flip g) . first'

> prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
> prism f g = dimap g (either id f) . right'

> data Un p a b s t = Un { runUn :: p t s -> p b a }

> instance Profunctor p => Profunctor (Un p s t) where
>   rmap f (Un p) = Un $ p . lmap f
>   lmap f (Un p) = Un $ p . rmap f
>   dimap f g (Un p) = Un $ p . dimap g f

> class Profunctor p => UnStrong p where
>   unfirst' :: p (a,c) (b,c) -> p a b
>   unsecond' :: p (c,a) (c,b) -> p a b
>
> instance UnStrong Tagged where
>   unfirst' (Tagged a) = Tagged $ fst a
>   unsecond' (Tagged a) = Tagged $ snd a
> 

> class Profunctor p => UnChoice p where
>   unleft' :: p (Either a c) (Either b c) -> p a b
>   unright' :: p (Either c a) (Either c b) -> p a b
> 
> instance UnChoice (Forget r) where
>   unleft' (Forget f) = Forget $ f . Left
>   unright' (Forget f) = Forget $ f . Right

> un :: Optic (Un p a b) s t a b -> UnOptic p s t a b
> un p = runUn $ p $ Un id

> reset :: Optic (Un (->) a b) s t a b -> s -> b -> a
> reset = set . un

> reover :: Optic (Un (->) a b) s t a b -> (t -> s) -> (b -> a)
> reover = over . un

--------------------------------------------------------------------------------

--------------------------------------------------------------------------------

> _fst :: Lens (a,c) (b,c) a b
> _fst = first'
> 
> _snd :: Lens (c,a) (c,b) a b
> _snd = second'
> 
> _Right :: Prism (Either c a) (Either c b) a b
> _Right = right'
> 
> _Left :: Prism (Either a c) (Either b c) a b
> _Left = left'

>
> class Swapped f where
>   swapped :: Iso (f a b) (f c d) (f b a) (f d c)
> 
> instance Swapped Either where
>   swapped = iso (either Right Left) (either Right Left)
>
> instance Swapped (,) where
>   swapped = iso (snd &&& fst) (snd &&& fst)