same as LensList.hs but with Profunctor Optics

LensListProfunctor.hs

-- in response to https://twitter.com/xgrommx/status/1574392204071575558
--
-- The challenge is to implement a partial function of type
--
-- list :: [Lens s t a b]
-- -> Lens [s] [t] [a] [b]
--
-- while using the profunctor representation of lenses. This is based on my
-- implementation [1] of the previous challenge [2].
--
-- [1] https://gist.github.com/gelisam/06cecf37d65a93df2532e7cf3ba2db96
-- [2] https://twitter.com/_julesh_/status/1573281637378527232

-- Please use ghc-9.2 or higher, ImpredicativeTypes was broken before that.
{-# LANGUAGE ImpredicativeTypes #-}
module Main where

import Control.Category ((>>>))
import Data.Profunctor

-- one of many implementation of profunctor optics
import Fresnel.Getter (view)
import Fresnel.Lens (Lens, Lens', alongside)
import Fresnel.Setter (over)
import Fresnel.Tuple (fst_, snd_)


-- Using a fold as before. Note that we need ImpredicativeTypes in order to
-- write the type @[Lens s t a b]@, because Lens is defined as
--
--     type Lens = forall p. ...
--
-- and foralls are not allowed inside lists unless ImpredicativeTypes is
-- enabled.
list
  :: [Lens s t a b]
  -> Lens [s] [t] [a] [b]
list = foldr cons nil

-- Still assuming that the @[s]@ and @[b]@ lists are empty.
nil
  :: Lens [s] [t] [a] [b]
nil
  = -- p [a] [b]
    dimap
      (\[] -> [])  -- [s] -> [a]
      (\[] -> [])  -- [b] -> [t]
    -- p [s] [t]

-- Still assuming that the @[s]@ and @[b]@ lists are non-empty.
-- The magic happens in @alongside@, so let's look at how fresnel implements it [1]:
--
--     alongside :: Lens s1 t1 a1 b1 -> Lens s2 t2 a2 b2 -> Lens (s1, s2) (t1, t2) (a1, a2) (b1, b2)
--     alongside o1 o2 = withLens o1 $ \ get1 set1 -> withLens o2 $ \ get2 set2 ->
--       lens (get1 *** get2) (uncurry (***) . (set1 *** set2))
--
-- Oh my, @fresnel@'s implementation doesn't use the profunctor representation
-- at all, it converts its profunctor representation to the getter-setter
-- representation and implements @alongside@ using that representation!
--
-- If that seems like cheating, don't worry, there are other implementations
-- which use the profunctor representation directly. For example, here is the
-- implementation from the mezzolens library [2]:
--
--     alongside :: Lens ta tb a b -> Lens sc sd c d -> Lens (ta,sc) (tb,sd) (a,c) (b,d)
--     alongside lab lcd = dimap swap swap . runAlongSide . lab . AlongSide . dimap swap swap . runAlongSide . lcd . AlongSide
--
--     newtype AlongSide p c d a b = AlongSide { runAlongSide :: p (c,a) (d,b) }
--
--     instance Profunctor p => Profunctor (AlongSide p c d) where
--       dimap f g (AlongSide pab) = AlongSide $ dimap (fmap f) (fmap g) pab
--
--     instance Strong p => Strong (AlongSide p c d) where
--       _2 (AlongSide pab) = AlongSide . dimap shuffle shuffle . _2 $ pab
--        where
--         shuffle (x,(y,z)) = (y,(x,z))
--
-- [1] https://hackage.haskell.org/package/fresnel-0.0.0.1/docs/src/Fresnel.Lens.html#alongside
-- [2] https://hackage.haskell.org/package/mezzolens-0.0.0/docs/src/Mezzolens.html#alongside
cons
  :: Lens s t a b
  -> Lens [s] [t] [a] [b]
  -> Lens [s] [t] [a] [b]
cons l ls
    = -- p [a] [b]
      dimap
        (\(a,as) -> (a:as))
        (\(b:bs) -> (b,bs))
      -- p (a,[a]) (b,[b])
  >>> alongside l ls  -- Lens s1 t1 a1 b1 -> Lens s2 t2 a2 b2 -> Lens (s1, s2) (t1, t2) (a1, a2) (b1, b2)
      -- p (s,[s]) (t,[t])
  >>> dimap
        (\(s:ss) -> (s,ss))
        (\(t,ts) -> (t:ts))
      -- p [s] [t]

-- Demonstrating that @list@ behaves as intended:
main :: IO ()
main = do
  let ss = [ ("A","a")
           , ("B","b")
           , ("C","c")
           ]
  let ll :: [Lens' (String,String) String]
      ll = [fst_, snd_, fst_]

  -- ["A","b","C"]
  print $ view (list ll) ss

  -- [("C","a"),("B","b"),("A","c")]
  print $ over (list ll) reverse ss