Skip to content

Instantly share code, notes, and snippets.

@kl0tl
Last active July 23, 2017 19:28
Show Gist options
  • Save kl0tl/1e9067eb39747d1c7195e200291bc5e6 to your computer and use it in GitHub Desktop.
Save kl0tl/1e9067eb39747d1c7195e200291bc5e6 to your computer and use it in GitHub Desktop.
Lenses!
:set -i.
{-# 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
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
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
{-# 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
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
{-# 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
{-# 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
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)
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
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment