lensblurg

-- how can we pull out an element from a structure? one approach is zippers.

data PairContext a b = InFst b | InSnd a

data PairZipper a b c = PairZipper c (PairContext a b)

lookFst :: (a,b) -> PairZipper a b a
lookFst (a,b) = PairZipper a (InFst b)

unzipFst :: PairZipper a b a -> (a,b)
unzipFst (PairZipper a (InFst b)) = (a,b)

lookSnd :: (a,b) -> PairZipper a b b
lookSnd (a,b) = PairZipper b (InSnd a)

unzipSnd :: PairZipper a b b -> (a,b)
unzipSnd (PairZipper b (InSnd a)) = (a,b)

viewPZ :: PairZipper a b c -> c
viewPZ (PairZipper c l) = c

overPZ :: (c -> c) -> PairZipper a b c -> PairZipper a b c
overPZ f (PairZipper c l) = PairZipper (f c) l

-- question: how can we compose these so that we can lookFst, then lookSnd, and have this be another kind of Zipper-like thing?
-- answer: too hard, forget it.

data ListContext a = ListCtx [a] [a]

data ListZipper a = ListZipper a (ListContext a)
-- what about empty lists? nevermind that.

lookHead :: [a] -> ListZipper a
lookHead (a:as) = ListZipper a (ListCtx [] as)

unzipLZ :: ListZipper a -> [a]
unzipLZ (ListZipper a (ListCtx bfr aft)) = bfr ++ [a] ++ aft

viewLZ :: ListZipper a -> a
viewLZ (ListZipper a l) = a

overLZ :: (a -> a) -> ListZipper a -> ListZipper a
overLZ f (ListZipper a l) = ListZipper (f a) l

-- question: how can we compose these? again, too hard. forget it!

data Tree a = Leaf a | Branch a (Tree a) (Tree a)

data TreeCtx a = Here | InLeft a (TreeCtx a) (Tree a) | InRight a (Tree a) (TreeCtx a)

data TreeZipper a = TreeZipper (Tree a) (TreeCtx a)

lookRoot :: Tree a -> TreeZipper a
lookRoot t = TreeZipper t Here

unzipTZ :: TreeZipper a -> Tree a
unzipTZ (TreeZipper t Here) = t
unzipTZ (TreeZipper l (InLeft a c r)) = unzipTZ (TreeZipper (Branch a l r) c)
unzipTZ (TreeZipper r (InRight a l c)) = unzipTZ (TreeZipper (Branch a l r) c)

viewTZ :: TreeZipper a -> a
viewTZ (TreeZipper (Leaf a) c) = a
viewTZ (TreeZipper (Branch a l r) c) = a

overTZ :: (a -> a) -> TreeZipper a -> TreeZipper a
overTZ f (TreeZipper (Leaf a) c) = TreeZipper (Leaf (f a)) c
overTZ f (TreeZipper (Branch a l r) c) = TreeZipper (Branch (f a) l r) c

-- question: ... well you get the idea

-- why not just use...

data Focused s a = Focused { foc :: a, loc :: a -> s }

-- We can now be pretty generic:

unfocusF :: Focused s a -> s
unfocusF (Focused foc loc) = loc foc

type Focuser s a = s -> Focused s a

viewF :: Focuser s a -> s -> a
viewF l s = foc (l s)

overF :: Focuser s a -> (a -> a) -> s -> s
overF l f s = let Focused foc loc = l s
              in loc (f foc)

-- let's also introduce a new function that makes life simpler:

setF :: Focuser s a -> a -> s -> s
setF l a s = overF l (const a) s

-- let's look at our various zippers, but this time viewed as focused elements:

lookFstF :: Focuser (a,b) a
lookFstF (a,b) = Focused a (,b)

lookSndF :: Focuser (a,b) b
lookSndF (a,b) = Focused b (a,)

lookHeadF :: Focuser [a] a
lookHeadF (a:as) = Focused a (:as)

lookRootF :: Focuser (Tree a) a
lookRootF (Leaf a) = Focused a Leaf
lookRootF (Branch a l r) = Focused a (\a' -> Branch a' l r)

-- We can now answer our question about how to compose:

(>-) :: Focuser a b -> Focuser b c -> Focuser a c
(l >- l') a = let Focused foc loc = l a
                  Focused foc' loc' = l' foc
              in Focused foc' (loc.loc')

-- this does exactly what you'd hope: lookFstF >- lookSndF :: Focuser ((a,b),c) b  is exactly
-- the gadget that looks at the first element of the outer pair, then at the second of that
-- same for, say, lists:  lookHeadF >- lookFstF :: Focuser [(a,b)] a  looks at the first
-- component of the head of a list of pairs. and so on generically.

-- But over has an unusual restriction: the action on the focused element can't change the
-- elements type. Sometimes that seems reasonable, like for a list which have to be homogeneously
-- typed, but other times it's an unnecessary constraint, such as for pairs. Why can't we, for
-- instance, focus on the first component of an (a,b) and then somehow act on it to produce
-- an (a',b)? We need to generalize focusing for this to work:

data Focused' t a b = Focused' { foc' :: a, loc' :: b -> t }

type Focuser' s t a b = s -> Focused' t a b

-- fortunately, that's _all_ we have to change. the rest is identical, other than types:

unfocusF' :: Focused' s a a -> s
unfocusF' (Focused' foc loc) = loc foc

viewF' :: Focuser' s t a b -> s -> a
viewF' l s = foc' (l s)

overF' :: Focuser' s t a b -> (a -> b) -> s -> t
overF' l f s = let Focused' foc loc = l s
               in loc (f foc)

setF' :: Focuser' s t a b -> b -> s -> t
setF' l b s = overF' l (const b) s

lookFstF' :: Focuser' (a,b) (a',b) a a'
lookFstF' (a,b) = Focused' a (,b)

lookSndF' :: Focuser' (a,b) (a,b') b b'
lookSndF' (a,b) = Focused' b (a,)

lookHeadF' :: Focuser' [a] [a] a a
lookHeadF' (a:as) = Focused' a (:as)

lookRootF' :: Focuser' (Tree a) (Tree a) a a
lookRootF' (Leaf a) = Focused' a Leaf
lookRootF' (Branch a l r) = Focused' a (\a' -> Branch a' l r)

-- We can now answer our question about how to compose:

(>--) :: Focuser' s t a b -> Focuser' a b u v -> Focuser' s t u v
(l >-- l') a = let Focused' foc loc = l a
                   Focused' foc' loc' = l' foc
               in Focused' foc' (loc.loc')

-- so we have some nice examples now, for instance:  setF' lookFstF' 3 ("a","b") == (3,"b")

-- it would be nice, however, if we could use lenses to traverse structures, not just
-- look at them or change them. but traverse has a funny type:
--   traverse :: (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b)
-- this looks almost like the type of overF' l, for some l, but not quite. We have these
-- extra f's and t's in there. We can factor out the f's to make things closer:

type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t

-- which lets us say that
--   traverse :: Traversable t => Traversal (t a) (t b) a b
-- which expands to the correct type, but we still need to somehow fit our Focuser's
-- into the mold of the definition of Traversal. Well, as it happens, our Focuser'
-- type is equivalent to the type

type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t

type SimpleLens s a = Lens s s a a

-- which makes it rather easy to see what we need to do: replace Focuser' with Lens!

-- getting the equivalent views requires some tricky thinking about the types, however.
-- the way we viewed the focused element before was to just focus and pull out the foc
-- field, but there is no foc field in Lens. So instead we have to somehow convince a Lens
-- that it can pull out an a from an s some other way. But we can take advantage of the
-- fact that a Lens is polymorphic on its functor -- that tells us that the lens must
-- be constructed using only the functorial structure, nothing else, because it has to
-- work for all functors, not just one particular one. The Const functor gives us
-- exactly what we want. If we instantiate Lens with f = Const a, we get
--   (a -> Const a b) -> s -> Const a t
-- but Const a b can be seen as an a masquerading as a b. Same for Const a t. Any purely
-- functorially-defined actions on a Const a b will look to the type system like something
-- has happened, but the a content will remain unaffected. That means that any Lens
-- will leave such a thing alone. We just need to provide our lense with a function
--   a -> Const a b
-- that can hide the a away. But that's just what the Const constructor does:

view :: Lens s t a b -> s -> a
view l s = getConst (l Const s)

-- It's good at this point to give an intuition about these Lenses, now that we have the
-- simlest way of interacting with them. The first argument to the Lens can be seen as
-- an action to perform on the a element that's embedded in the s element. In the case of
-- view, the action is to masquerade the element as a b, so that the loc-like behavior
-- of l, which is now just implicit in l, will smuggle the a up and out, where getConst
-- can reveal it as an a.

-- similarly for over, we want f to be some useful functor, which happens to be Identity,
-- because a ~ Identity a in a trivial way, so
--   (a -> b) -> s -> t  ~  (a -> Identity b) -> s -> Identity t

data Identity a = Identity { getIdentity :: a }

instance Functor Identity where
  fmap f (Identity a) = Identity (f a)

over :: Lens s t a b -> (a -> b) -> s -> t
over l f s = getIdentity (l (Identity . f) s)

-- we can of course convert back and forth between Focuser's and Lenses.

lens :: Focuser' s t a b -> Lens s t a b
lens l f s = let Focused' foc loc = l s
             in fmap loc (f foc)

focuser :: Lens s t a b -> Focuser' s t a b
focuser l s = Focused' (view l s) (\b -> over l (const b) s)

-- The equivalence of Lens and Focuser' is relatively straightforward to show using
-- beta reduction and eta equivalence.

{-
  focuser (lens l)
= focuser (\f x -> fmap (loc (l x)) (f (foc (l x))))
= let l' = (\f x -> fmap (loc (l x)) (f (foc (l x))))
  in \s -> Focus (view l s)
                 (\a -> over l' (const a) s)
= let l' f x = fmap (loc (l x)) (f (foc (l x)))
  in \s -> Focus (getConst (l Const s))
                 (\a -> runIdentity (l' (Identity . const a) s))
= let l' f x = fmap (loc (l x)) (f (foc (l x)))
  in \s -> Focus (getConst (fmap (loc (l s)) (Const (foc (l s)))))
                 (\a -> runIdentity (fmap (loc (l s)) (Identity (const a (foc (l s))))))
= \s -> Focus (getConst Const (foc (l s)))
              (\a -> runIdentity (Identity (loc (l s) a)))
= \s -> Focus (foc (l s))
              (\a -> loc (l s) a)
= \s -> Focus (foc (l s))
              (loc (l s))
= \s -> l s
= l
-}

-- here are our Focuser's again, this time as Lenses:

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

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

_head :: SimpleLens [a] a
_head f (a:as) = (:as) <$> f a

_root :: SimpleLens (Tree a) a
_root f (Leaf a) = Leaf <$> f a
_root f (Branch a l r) = (\a' -> Branch a' l r) <$> f a

-- Notice that this is more or less exactly how things would behave if we focused
-- with whichever focuser, used an action on the focus, and then unfocused. Except here,
-- the unfocus function application is not the normal application but is instead
-- functorial, using fmap in its infix form (<$>).
--
-- That means that we can compose lenses as functions with (.) instead of defining a custom
-- composition, and we get something rather sensible looking:
--   _head._1 :: SimpleLens [(a,b)] a
--   = \f ((a,b):ps) -> (:ps) <$> (,b) <$> f a
-- sometimes this is described as composing "backwards", but it really shouldn't be
-- seen like that. instead, you just need to think of lenses as things which turn
-- actions on parts into actions on wholes. so _1 doesn't "retrieve" the first component
-- of a pair, rather, it turns an action on the first component into an action on the whole
-- pair. same with _head -- it turns an action on the head element into an action on the
-- whole list. that means that if you compose two lenses, you're making an action on the whole
-- that runs an action on a part that runs an action on an even smaller part. That's just what
-- fmap does: it pushes actions down into structure. Lenses just happen to do that in a
-- very specific way, to a focused place, rather than in the usual "apply everywhere" way
-- that normal functor intuitions provide.
--
-- This schema also lets us produce lenses really easily. The general picture is
--   _l f m = (\a' -> [a'/a]m) <$> f a
-- where m is some pattern with variable a, and [a'/a]m is the pattern with all occurances
-- of a replaced by a', just so we don't get confused with the new bound variable.