Lenses!

.ghci

:set -i.

Existential.hs

{-# LANGUAGE ExistentialQuantification #-}

module Existential where

data Lens s a = forall b. Lens (s -> (a, b)) ((a, b) -> s)

(&&&) :: (a -> a') -> (b -> b') -> (a, b) -> (a', b')
(&&&) f g (x, y) = (f x, g y)

assoc :: (a, (b, c)) -> ((a, b), c)
assoc (x, (y, z)) = ((x, y), z)

assoc' :: ((a, b), c) -> (a, (b, c))
assoc' ((x, y), z) = (x, (y, z))

fork :: (a -> b) -> (a -> c) -> a -> (b, c)
fork f g x = (f x, g x)

swap :: (a, b) -> (b, a)
swap (x, y) = (y, x)

get :: Lens s a -> s -> a
get (Lens fwd _) = fst . fwd

update :: Lens s a -> (a -> a) -> s -> s
update (Lens fwd bwd) f = bwd . (f &&& id) . fwd

set :: Lens s a -> a -> s -> s
set lens v = update lens (const v)

compose :: Lens a b -> Lens b c -> Lens a c
compose (Lens fwd_ab bwd_ab) (Lens fwd_bc bwd_bc) = Lens fwd_ac bwd_ac
  where fwd_ac = assoc' . (fwd_bc &&& id) . fwd_ab
        bwd_ac = bwd_ab . (bwd_bc &&& id) . assoc

GetterSetter.hs

module GetterSetter where

data Lens s a = Lens { get :: s -> a, set :: a -> s -> s }

update :: Lens s a -> (a -> a) -> s -> s
update lens f x = set lens (f (get lens x)) x

compose :: Lens a b -> Lens b c -> Lens a c
compose lens_ab lens_bc = Lens getter_ac setter_ac
  where getter_ac = get lens_bc . get lens_ab
        setter_ac v x = set lens_ab (set lens_bc v (get lens_ab x)) x

GetterSetter<->Existential.hs

import qualified GetterSetter
import qualified Existential

fromExistential :: Existential.Lens s a -> GetterSetter.Lens s a
fromExistential lens = GetterSetter.Lens getter setter
  where getter = Existential.get lens
        setter = Existential.set lens

toExistential :: GetterSetter.Lens s a -> Existential.Lens s a
toExistential (GetterSetter.Lens getter setter) = Existential.Lens fwd bwd
  where fwd = Existential.fork getter (flip setter)
        bwd = uncurry ($) . Existential.swap

GetterSetter<->StoreCoalgebra.hs

{-# LANGUAGE Rank2Types, FlexibleContexts #-}

import qualified GetterSetter
import qualified StoreCoalgebra

toStoreCoalgebra :: GetterSetter.Lens s a -> StoreCoalgebra.Lens s a
toStoreCoalgebra lens x = StoreCoalgebra.Store hole piece
  where hole v = GetterSetter.set lens v x
        piece = GetterSetter.get lens x

fromStoreCoalgebra :: StoreCoalgebra.Lens s a -> GetterSetter.Lens s a
fromStoreCoalgebra coalg = GetterSetter.Lens getter setter
  where getter = StoreCoalgebra.get coalg
        setter = StoreCoalgebra.set coalg

GetterSetter<->ViewUpdate.hs

import qualified GetterSetter
import qualified ViewUpdate

toViewUpdate :: GetterSetter.Lens s a -> ViewUpdate.Lens s a
toViewUpdate lens = ViewUpdate.Lens view update
  where view = GetterSetter.get lens
        update = GetterSetter.update lens

fromViewUpdate :: ViewUpdate.Lens s a -> GetterSetter.Lens s a
fromViewUpdate lens = GetterSetter.Lens getter setter
  where getter = ViewUpdate.view lens
        setter = ViewUpdate.set lens

StoreCoalgebra.hs

{-# LANGUAGE Rank2Types, FlexibleContexts #-}

module StoreCoalgebra where

class (Functor w) => Comonad w where
  extract :: w a -> a

  duplicate :: w a -> w (w a)
  duplicate = extend id

  extend :: (w a -> b) -> w a -> w b
  extend f = fmap f . duplicate

data Store i a  = Store { peek :: i -> a, pos :: i }
instance Functor (Store i) where
  fmap f (Store hole piece) = Store (f . hole) piece
instance Comonad (Store i) where
  extract (Store hole piece) = hole piece
  duplicate (Store hole piece) = Store (Store hole) piece

type Coalgebra w a = (Comonad w) => a -> w a
type Lens s a = Coalgebra (Store a) s

get :: Lens s a -> s -> a
get coalg = pos . coalg

update :: Lens s a -> (a -> a) -> s -> s
update coalg f x = let Store hole piece = coalg x
                   in hole $ f piece

set :: Lens s a -> a -> s -> s
set coalg v = update coalg (const v)

compose :: Lens a b -> Lens b c -> Lens a c
compose lens_ab lens_bc a =
  let Store hole_ba b = lens_ab a in
  let Store hole_cb c = lens_bc b in
      Store (hole_ba . hole_cb) c

StoreCoalgebra<->Existential.hs

{-# LANGUAGE Rank2Types, FlexibleContexts, TupleSections #-}

import qualified StoreCoalgebra
import qualified Existential

toExistential :: StoreCoalgebra.Lens s a -> Existential.Lens s a
toExistential coalg = Existential.Lens fwd bwd
  where fwd = Existential.fork StoreCoalgebra.pos StoreCoalgebra.peek . coalg
        bwd = uncurry ($) . Existential.swap

fromExistential :: Existential.Lens s a -> StoreCoalgebra.Lens s a
fromExistential (Existential.Lens fwd bwd) x =
    let (piece, hole) = fwd x
    in StoreCoalgebra.Store (bwd . (,hole)) piece

ViewUpdate.hs

module ViewUpdate where

data Lens s a = Lens { view :: s -> a, update :: (a -> a) -> s -> s }

set :: Lens s a -> a -> s -> s
set lens v = update lens (const v)

compose :: Lens a b -> Lens b c -> Lens a c
compose lens_ab lens_bc = Lens view_ac update_ac
  where view_ac = view lens_bc . view lens_ab
        update_ac f = update lens_ab (update lens_bc f)

ViewUpdate<->Existential.hs

import qualified ViewUpdate
import qualified Existential

toExistential :: ViewUpdate.Lens s a -> Existential.Lens s a
toExistential (ViewUpdate.Lens view update) = Existential.Lens fwd bwd
  where fwd = Existential.fork view (flip update)
        bwd = ($id) . snd

fromExistential :: Existential.Lens s a -> ViewUpdate.Lens s a
fromExistential (Existential.Lens fwd bwd) = ViewUpdate.Lens view update
  where view = fst . fwd
        update f = bwd . (f Existential.&&& id) . fwd

ViewUpdate<->StoreCoalgebra.hs

{-# LANGUAGE Rank2Types, FlexibleContexts #-}

import qualified ViewUpdate
import qualified StoreCoalgebra

toStoreCoalgebra :: ViewUpdate.Lens s a -> StoreCoalgebra.Lens s a
toStoreCoalgebra lens x = StoreCoalgebra.Store hole piece
  where hole v = ViewUpdate.set lens v x
        piece = ViewUpdate.view lens x

fromStoreCoalgebra :: StoreCoalgebra.Lens s a -> ViewUpdate.Lens s a
fromStoreCoalgebra coalg = ViewUpdate.Lens view update
  where view = StoreCoalgebra.get coalg
        update = StoreCoalgebra.update coalg