same as LensList.hs, but for an arbitrary Traversable

LensTraversable.hs

-- in response to https://twitter.com/sjoerd_visscher/status/1574390090406989824
--
-- The challenge is to implement a partial function of type
--
--     list :: Traversable f
--          => f (Lens s t a b)
--          -> Lens (f s) (f t) (f a) (f b)
--
-- using the existential representation of lenses.
--
-- This solution is based on my solution [1] for the previous challenge [2].
--
-- [1] https://gist.github.com/gelisam/06cecf37d65a93df2532e7cf3ba2db96
-- [2] https://twitter.com/_julesh_/status/1573281637378527232
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable, GADTs #-}

import Control.Monad.Trans.State (evalState, get, put)
import Data.Foldable (Foldable(toList))
import Data.Traversable (for)


-- Recall the solution from the previous challenge:

data Lens s t a b where
  Lens
    :: (s -> (u, a))
    -> ((u, b) -> t)
    -> Lens s t a b

listL
  :: [Lens s t a b]
  -> Lens [s] [t] [a] [b]
listL = foldr cons nil

nil
  :: Lens [s] [t] [a] [b]
nil
  = Lens
      (\[] -> ((), []))
      (\((),[]) -> [])

cons
  :: Lens s t a b
  -> Lens [s] [t] [a] [b]
  -> Lens [s] [t] [a] [b]
cons (Lens split1 join1)
     (Lens splitN joinN)
  = Lens
      ( \(s:ss)
     -> let (u,a) = split1 s
     in let (us,as) = splitN ss
     in ((u,us), a:as)
      )
      ( \((u,us), b:bs)
     -> let t = join1 (u,b)
     in let ts = joinN (us,bs)
     in t:ts
      )


-- One key assumption in this challenge is that all the containers have the
-- same number of elements. This is a very useful assumption, because if we
-- have two containers with the same number of elements and one of the two
-- containers is 'Traversable', we can transfer the elements from one container
-- to the other:
replaceElements
  :: Traversable f
  => f a -> [b] -> f b
replaceElements fa bs0
  = flip evalState bs0 $ do
      for fa $ \_ -> do
        bbs <- get
        case bbs of
          b:bs -> do
            put bs
            pure b
          [] -> do
            error "replaceElements: not enough elements given"

-- We can now solve the challenge by delegating to the 'listL' solution from
-- the previous challenge, using 'replaceElements' to convert between lists and
-- 'f'. 
listF
  :: Traversable f
  => f (Lens s t a b)
  -> Lens (f s) (f t) (f a) (f b)
listF fl
  = case listL (toList fl) of
      Lens splitL joinL
        -> Lens
             ( \fs
            -> let (u,as) = splitL (toList fs)
            in (u, replaceElements fs as)
             )
             ( \(u,fb)
            -> let ts = joinL (u, toList fb)
            in replaceElements fb ts
             )


-- We're done with the challenge, but in order to demonstrate that the
-- implementation works as intended, let's define a 'Traversable', some lenses,
-- and some lens operations:

_1 :: Lens (a,u) (b,u) a b
_1 = Lens
       (\(a,u) -> (u,a))
       (\(u,b) -> (b,u))

_2 :: Lens (u,a) (u,b) a b
_2 = Lens
       (\(u,a) -> (u,a))
       (\(u,b) -> (u,b))

data Triple a = Triple a a a
  deriving (Show, Functor, Foldable, Traversable)

reverseTriple :: Triple a -> Triple a
reverseTriple (Triple x y z) = Triple z y x

view
  :: Lens s t a b
  -> (s -> a)
view (Lens split _)
  = snd . split

over
  :: Lens s t a b
  -> (a -> b)
  -> (s -> t)
over (Lens split join) f
  = join
  . (\(u, a) -> (u, f a))
  . split

-- We are now ready to demonstrate that @listF@ behaves as intended:
main :: IO ()
main = do
  let ss = Triple ("A","a")
                  ("B","b")
                  ("C","c")
  let ll = Triple _1 _2 _1

  -- Triple "A" "b" "C"
  print $ view (listF ll) ss

  -- Triple ("C","a") ("B","b") ("A","c")
  print $ over (listF ll) reverseTriple ss