Q5.lhs

\begin{code}
{-# LANGUAGE RankNTypes, DeriveFunctor, DeriveFoldable, DeriveTraversable, TupleSections #-}
import Data.Functor.Identity
import Data.Profunctor
import Data.Profunctor.Traversing
import Data.Traversable
import Data.Tuple (swap)

data Q5 a b = Q51 a (Identity b) | Q52 [b] 

lq5Twan :: Applicative f => (b -> f b') -> Q5 a b -> f (Q5 a b') 
lq5Twan f (Q51 a bs) = Q51 a <$> traverse f bs 
lq5Twan f (Q52 bs) = Q52 <$> traverse f bs 

data BT tt tt' b t t' a = BT1 (tt -> b) (t a) | BT2 (tt' -> b) (t' a) deriving (Functor,Foldable,Traversable) 
runBT (BT1 f x) = f x 
runBT (BT2 f x) = f x 

lq5Profunctor :: forall p a b b' . Traversing p => p b b' -> p (Q5 a b) (Q5 a b') 
lq5Profunctor = dimap pre post . second' . traverse' where 
  pre (Q51 a x) = ((), BT1 (Q51 a) x) 
  pre (Q52 bs) = ((), BT2 Q52 bs) 
  post ((),x) = runBT x
\end{code}

\begin{code}
instance Functor (Q5 a) where fmap = fmapDefault
instance Foldable (Q5 a) where foldMap = foldMapDefault
instance Traversable (Q5 a) where
    traverse f (Q51 a bs) = Q51 a <$> traverse f bs 
    traverse f (Q52 bs) = Q52 <$> traverse f bs 

lq5Twan' :: Applicative f => (b -> f b') -> Q5 a b -> f (Q5 a b') 
lq5Twan' = traverse

lq5Profunctor' :: forall p a b b' . Traversing p => p b b' -> p (Q5 a b) (Q5 a b') 
lq5Profunctor' = traverse'
\end{code}

And in general: three steps:

1. create a Traversable newtype over your type
2. dimap pre post . traverse'
3. Profit!

Compare that to writing Lens

1. bijection your 's' to (a, r) (Note: 'r' can be 's'!)
2. dimap to from . first'
3. Profit!

Trivial examples:

\begin{code}
type Lens s t a b = forall p. Strong p => p a b -> p s t

_1 :: Lens (a, c) (b, c) a b
_1 = dimap id id . first'

_2 :: Lens (c, a) (c, b) a b
_2 = dimap swap swap . first'
\end{code}

Note again, that in usual `lens` definition we pick r to be s:
we "carry over" the whole "s", though "s - a = r" would be enough.
But in practice constructing "residual" is expensive.
Think about record with 10 fields: residual in a single field lens 
would be 9-tuple - not really worth it.

Interlude, one can define Traversal over first argument too.
Using Bitraversable class that would be direct.

In this case it's Affine (Traversal), so we can do "better" than using `traverse'`.

\begin{code}
lq5ProFirst :: forall p a a' b. (Choice p, Strong p) => p a a' -> p (Q5 a b) (Q5 a' b)
lq5ProFirst = dimap f g . right' . first' where
    -- Think why we have chosen [b] + a * b
    -- compare to definition of Q5!
    --
    -- The r + r' * s shape justifies the name Affine, btw.
    f :: Q5 a b -> Either [b] (a, Identity b)
    f (Q51 a x) = Right (a, x)
    f (Q52 bs)  = Left bs

    g (Left bs) = Q52 bs
    g (Right (a, x)) = Q51 a x
\end{code}

Note: how the same 

1. bijection to some structure (`r' + r * a` in this case
2. dimap to from . ...
3. Profit

pattern is applied again.

Another way to think about it is that we

1. Use `Iso` (for all Profunctor!) to massage value into the form, so
2. we can use "Optic specific" transform
3. Profit!

And optic specific:
- Lens -> Products
- Prism -> Coproducts (Sums)
- Traversal -> Traversable
- Setter -> Functor (Mapping type class has map' :: Functor f => p a b -> p (f a) (f b))
- etc.

So the fact that defining arbitrary Traversals directly is more handy with
`wander`, than `traverse'` (as you can omit `dimap`!) is more related to the
fact that we have

\begin{spec}
class Traversable t where
    traverse :: Applicative f => (a -> f b) -> t a -> f (t b)
\end{spec}

... and we (well, me) don't yet know another elegant way to capture "the
essense of Traversable". (I don't think FunList is particularly "elegant")


Sidenote: we can define Lens using Traversing/Mapping -like class too,
hopefully it gives you another viewpoint too.

\begin{code}
class Functor t => Singular t where
    single :: Functor f => (a -> f b) -> t a -> f (t b)

fmapSingle :: Singular t => (a -> b) -> t a -> t b
fmapSingle ab ta = runIdentity (single (Identity . ab) ta)

instance Singular Identity where
    single f (Identity a) = Identity <$> f a

instance Singular ((,) a) where
    single f (a, b) = (a,) <$> f b

class Profunctor p => Strong' p where
    single' :: Singular f => p a b -> p (f a) (f b)

instance Strong' (->) where
    single' ab = fmap ab

instance Functor f => Strong' (Star f) where
    single' (Star afb) = Star (single afb)

-- lens using Strong' & Single: 1. 2. 3.
lens' :: Strong' p => (s -> a) -> (s -> b -> t) -> p a b -> p s t
lens' sa sbt = dimap (\s -> (s, sa s)) (\(s,b) -> sbt s b) . single'
\end{code}

Cheers, Oleg