Lens over tea

LoT.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes          #-}

import Data.Functor
import Data.Functor.Identity

type Lens  s t a b = Functor f => (a -> f b) -> s -> f t
-- s == t and a == b
type Lens' s   a   = Functor f => (a -> f a) -> s -> f s

-- _1 :: Functor f => (a -> f b) -> (a, x) -> f (b, x)
_1 :: Lens (a, x) (b, x) a b
_1 = \(f :: a -> f b)
      (s :: (a, x))
     -> let fb :: Functor f => f b
            fb = f (fst s)

            x :: x
            x = snd s
        in fmap (\b -> (b, x)) fb

-- *Main> runIdentity $ (return . (+1)) `_1` (1, "foo")
-- (2,"foo")

-- _2 :: Functor f => (a -> f b) -> (x, a) -> f (x, b)
_2 :: Lens (x, a) (x, b) a b
_2 = \(f :: a -> f b)
      (s :: (x, a))
     -> let fb :: Functor f => f b
            fb = f (snd s)

            x :: x
            x = fst s
        in fmap (\b -> (x, b)) fb
-- *Main> runIdentity $ (return . (++"bar")) `_2` (1, "foo")
-- (1,"foobar")

-- Make a lens out of a getter and a setter.
lens :: (s -> a)
     -> (s -> b -> t)
     -> Lens s t a b     -- Functor f => (a -> f b) -> s -> f t
lens = \(get :: s -> a)
        (set :: s -> b -> t)
        (f   :: a -> f b)
        (s   :: s)
       -> let fb :: Functor f => f b
              fb = f (get s)

              b_t :: b -> t
              b_t = set s
          in fmap b_t fb

-- _1' :: Functor f => (a -> f b) -> (a, x) -> f (b, x)
_1' :: Lens (a, x) (b, x) a b
_1' = \(f :: a -> f b)
       (s :: (a, x))
      -> {- s == (a, x)
            t == (b, x)
            a == a
            b == b
         -}
         let get :: (a, x) -> a
             get = fst

             set :: (a, x) -> b -> (b, x)
             set = \s b -> (b, snd s)
         in lens get set f s

-- *Main> runIdentity $ (return . (+1)) `_1'` (1, "foo")
-- (2,"foo")

-- Combine 2 lenses to make a lens which works on Either.
choosing :: Lens s1 t1 a b -- (Functor f => (a -> f b) -> s1 -> f t1)
         -> Lens s2 t2 a b -- (Functor f => (a -> f b) -> s2 -> f t2)
         -- (Functor f => (a -> f b)
         --            -> Either s1 s2
         --            -> f (Either t1 t2)
         -> Lens (Either s1 s2) (Either t1 t2) a b
choosing l1 l2 = \(f :: a -> f b)
                  (s :: Either s1 s2)
                 -> case s of
                      Left  s1 -> fmap (\t1 -> Left  t1) $ l1 f s1
                      Right s2 -> fmap (\t2 -> Right t2) $ l2 f s2

-- Functor f => (a -> f b)
--           -> Either (a, x) (y, a)
--           -> f (Either (b, x) (y, b))
choosing_1_2 :: Lens (Either (a, x) (y, a))
                     (Either (b, x) (y, b))
                     a
                     b
choosing_1_2 = choosing _1 _2

-- *Main> runIdentity $ choosing_1_2 (return . (+1)) (Left (1, "foo"))
-- Left (2,"foo")
-- *Main> runIdentity $ choosing_1_2 (return . (++"bar")) (Right (1, "foo"))
-- Right (1,"foobar")
-- *Main> runIdentity $ choosing_1_2 (return . (+1)) (Right (1, "foo"))
-- <Type error>
-- *Main> runIdentity $ choosing_1_2 (return . (++"bar")) (Left (1, "foo"))
-- <Type error>

data Storey x f a = Storey x (f a) deriving Show

instance Functor f => Functor (Storey x f) where
  fmap f (Storey x fa) = Storey x (fmap f fa)

view :: Lens s t a b -- Functor f => (a -> f b) -> s -> f t
     -> s
     -> a
view = \(l :: (a -> Storey a Identity b) -> s -> Storey a Identity t)
        (s :: s)
       -> let f :: a -> Storey a f b
              f a = Storey a undefined

              Storey a _ = l f s
          in a

-- *Main Data.Functor.Identity> view _1 (1,"foo")
-- 1
-- *Main Data.Functor.Identity> view _2 (1,"foo")
-- "foo"

newtype Const r a = Const r

instance Functor (Const r) where
  fmap _ (Const r) = Const r

-- fmap id      = id
-- fmap (p . q) = (fmap p) . (fmap q)

view' :: Lens s t a b -- Functor f => (a -> f b) -> s -> f t
      -> s
      -> a
view' = \(l :: (a -> Const a b) -> s -> Const a t)
         (s :: s)
        -> let f :: a -> Const a b
               f a = Const a

               Const a = l f s
           in a

-- *Main Data.Functor.Identity> view' _1 (1,"foo")
-- 1
-- *Main Data.Functor.Identity> view' _2 (1,"foo")
-- "foo"

-- Modify the target of a lens and return the result. (Bonus points if you
-- do it without lambdas and defining new functions.)
(<%~) :: Lens s t a b  -- Functor f => (a -> f b) -> s -> f t
      -> (a -> b)
      -> s
      -> (b, t)
(<%~) = \(l :: (a -> Storey a Identity b) -> s -> Storey a Identity t)
         (f :: a -> b)
         (s :: s)
        -> let g :: a -> Storey a Identity b
               g a = Storey a (Identity (f a))

               ft :: Storey a Identity t
               ft = l g s

               Storey a fa = ft

           in (f a, runIdentity fa)

-- *Main> (<%~) _1 (+1) (1,"foo")
-- (2,(2,"foo"))

-- Modify the target of a lens, but return the old value.
(<<%~) :: Lens s t a b  -- Functor f => (a -> f b) -> s -> f t
       -> (a -> b)
       -> s
       -> (a, t)
(<<%~) = \(l :: (a -> Storey a Identity b) -> s -> Storey a Identity t)
          (f :: a -> b)
          (s :: s)
         -> let g :: a -> Storey a Identity b
                g a = Storey a (Identity (f a))

                ft :: Storey a Identity t
                ft = l g s

                Storey a fa = ft

            in (a, runIdentity fa)

-- *Main> (<<%~) _1 (+1) (1,"foo")
-- (1,(2,"foo"))

-- There's a () in every value. (No idea what this one is for, maybe it'll
-- become clear later.)
united :: Lens' a () -- Functor f => (() -> f ()) -> a -> f a
united = \(f :: () -> f ())
          (a :: a)
         -> a <$ f ()

-- *Main> united (\() -> [()]) 12
-- [12]

{-# LANGUAGE RankNTypes #-}

import Data.Functor
import Data.Functor.Identity

type Lens  s t a b = Functor f => (a -> f b) -> s -> f t
-- s == t and a == b
type Lens' s   a   = Functor f => (a -> f a) -> s -> f s

data Storey x f a = Storey x (f a) deriving Show

instance Functor f => Functor (Storey x f) where
  fmap f (Storey x fa) = Storey x (fmap f fa)

-- _1 :: Functor f => (a -> f b) -> (a, x) -> f (b, x)
_1 :: Lens (a, x) (b, x) a b
_1 f s = fmap (\b -> (b, snd s)) $ f (fst s)

-- *Main> runIdentity $ _1 (return . (+1)) (1, "foo")
-- (2,"foo")

-- _2 :: Functor f => (a -> f b) -> (x, a) -> f (x, b)
_2 :: Lens (x, a) (x, b) a b
_2 f s = fmap (\a -> (fst s, a)) $ f (snd s)

-- *Main> runIdentity $ _2 (return . (++"bar")) (1, "foo")
-- (1,"foobar")

-- Make a lens out of a getter and a setter.
lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
lens get set = \f s -> fmap (set s) $ f (get s)

_1' :: Lens (a, x) (b, x) a b
_1' = \f s -> lens fst (\s b -> (b, snd s)) f s

-- *Main> runIdentity $ _1' (return . (+1)) (1, "foo")
-- (2,"foo")

-- Combine 2 lenses to make a lens which works on Either.
choosing :: Lens s1 t1 a b -> Lens s2 t2 a b
         -> Lens (Either s1 s2) (Either t1 t2) a b
choosing l1 l2 = \f s -> case s of
  Left  s1 -> fmap Left  $ l1 f s1
  Right s2 -> fmap Right $ l2 f s2

-- *Main> runIdentity $ choosing _1 _2 (return . (+1)) (Left (1, "foo"))
-- Left (2,"foo")

-- Modify the target of a lens and return the result. (Bonus points if you
-- do it without lambdas and defining new functions.)
(<%~) :: Lens s t a b -> (a -> b) -> s -> (b, t)
(<%~) l f s = (f a, runIdentity fa)
  where
    Storey a fa = l (\a -> Storey a (Identity (f a))) s

-- *Main> (<%~) _1 (+1) (1, "foo")
-- (2,(2,"foo"))

-- Modify the target of a lens, but return the old value.
(<<%~) :: Lens s t a b -> (a -> b) -> s -> (a, t)
(<<%~) l f s = (a, runIdentity fa)
  where
    Storey a fa = l (\a -> Storey a (Identity (f a))) s

-- *Main> (<<%~) _1 (+1) (1, "foo")
-- (1,(2,"foo"))

-- There's a () in every value. (No idea what this one is for, maybe it'll
-- become clear later.)
united :: Lens' a ()
united = \f a -> a <$ f ()

-- *Main> united (\() -> [()]) 12
-- [12]

A hint: you can get a much shorter <%~ using the tuple functor.

Also, _1 and _2 can be written nicer with tuple sections and some pattern matching:

_1 :: Lens' (a, x) a
_1 f (a, x) = (, x) <$> f a

_2 :: Lens' (x, a) a
_2 f (x, a) = (x, ) <$> f a

(If you want the lazy behavior from lens – when undefined & _1 .~ 1 gives you (1, undefined) instead of undefined – use lazy patterns like _1 f ~(a, x) = .... This is what you get with your fst/snd version, too.)