van Laarhoven ~ Store comonadic lenses

Lens.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE Rank2Types    #-}
{-# LANGUAGE TupleSections #-}

import           Control.Applicative
import           Control.Monad.Identity

{- Polymorphic van Laarhoven lenses -}

type LensFam a a' b b' = forall f. Functor f => (b -> f b') -> a -> f a'
--   Lens    a    b    = LensFam a a b b

{- Polymorphic lenses as costate coalgebras -}

type LensFamC a a' b b' = a -> IStore b b' a'
--   LensC    a    b    = LensFamC a a b b

data IStore b b' a' = IStore b (b' -> a') deriving Functor
--   Store  b    a' = IStore b b a'

{- Isomorphisms btw vL and coco lenses -}

to :: LensFamC a a' b b' -> LensFam a a' b b'
--        LensC    a    b    -> Lens    a    b
to k m a = fmap f $ m b where
   IStore b f = k a

fro :: LensFam a a' b b' -> LensFamC a a' b b'
--        Lens    a    b    -> LensC    a    b
fro r a = r idA a

{- The lenses -}

get :: LensFam a a' b b' -> a -> b
--     Lens    a    b    -> a -> b
get r = getConst . r Const

getC :: LensFamC a a' b b' -> a -> b
--      LenC     a    b    -> a -> b
getC k a = b where
  IStore b f = k a

modify :: LensFam a a' b b' -> (b -> b') -> a -> a'
--        Lens    a    b    -> (b -> b ) -> a -> a
modify r m = runIdentity . r (Identity . m)

modifyC :: LensFamC a a' b b' -> (b -> b') -> a -> a'
--         LensC    a    b    -> (b -> b ) -> a -> a
modifyC k m a = f (m b) where
  IStore b f = k a

set :: LensFam a a' b b' -> b' -> a -> a'
--     Lens    a    b    -> b  -> a -> a
set r b = modify r (const b)

setC :: LensFamC a a' b b' -> b' -> a -> a'
--      LensC    a    b    -> b  -> a -> a
setC r b = modifyC r (const b)

_1 :: LensFam (a,b) (a',b) a a'
--    Lens    (a,b)        a
_1 x (a,b) = (,b) <$> x a

_2 :: LensFam (a,b) (a,b') b b'
--    Lens    (a,b)        b
_2 x (a,b) = (a,) <$> x b

_1C :: LensFamC (a,b) (a',b) a a'
--     LensC    (a,b)        a
_1C (a,b) = IStore a (,b)

_2C :: LensFamC (a,b) (a,b') b b'
--     LensC    (a,b)        b
_2C (a,b) = IStore b (a,)

compose :: LensFam b b' c c' -> LensFam a a' b b' -> LensFam a a' c c'
--         Lens    b    c    -> Lens    a    b    -> Lens    a    c
compose r s = s . r

composeC :: LensFamC b b' c c' -> LensFamC a a' b b' -> LensFamC a a' c c'
--          LensC    a    b    -> LensC    b    c    -> LensC    a    c
composeC r s a = fmap b'a' $ r b where
  IStore b b'a' = s a

idF :: LensFam a a' a a'
--     Lens    a    a
idF = id

idA :: LensFamC a a' a a'
--     LensC    a    a
idA a = IStore a id