https://reddit.com/r/haskell/comments/z2tjxu/a_lens_problem/

W.hs

{-# LANGUAGE OverloadedStrings, DerivingVia, LambdaCase, FunctionalDependencies, MultiParamTypeClasses #-}
module W where

import Control.Monad.Trans.Free
import Control.Monad.Writer
import Control.Applicative
import Data.Functor.Classes (Eq1(..))
import Data.Text (Text)
import qualified Data.Text as T

data Node a = Node a a deriving (Eq, Functor, Show, Foldable, Traversable)
type MultiTree b = FreeT Node [] (b)

instance Eq1 Node where
  liftEq eq (Node x y) (Node x' y') = eq x x' && eq y y'

trees :: MultiTree Text
trees = FreeT [
  Free (Node 
    (FreeT [
      Pure "John",
      Pure "Mary",
      Pure "Andy"]) 
    (FreeT [
      Pure "runs", 
      Free (Node 
        (FreeT [Pure "eats"]) 
        (FreeT [Pure "lettuce", Pure "garlic"])) 
      ]) )
  ]

-- Nondeterministic tree traversal

enum :: MultiTree a -> [[a]]
enum (FreeT ts) = ts >>= \case
  Free (Node xs ys) -> liftA2 (++) (enum xs) (enum ys)
  Pure w -> [[w]]

example :: [Text]
example = T.unwords <$> enum trees

--

-- Viewing the tree as an expression of a nondeterministic computation

class ApWriter w m | m -> w where
  write :: w -> m ()

trees' :: (ApWriter Text m, Alternative m) => m ()
trees' =
     (write "John" <|> write "Mary" <|> write "Andy")
  *> (   write "runs"
     <|> (  write "eats"
         *> (write "lettuce" <|> write "garlic")))
  
newtype Search w a = Search [(a, [w])]
  deriving (Functor, Applicative, Monad, Alternative) via (WriterT [w] [])

instance ApWriter w (Search w) where
  write w = Search [((), [w])]

eval :: Search w () -> [[w]]
eval (Search ws) = fmap snd ws

example2 :: [Text]
example2 = T.unwords <$> eval trees'

--

-- From multitrees to (monadic) nondeterministic writers

choose :: Alternative m => [a] -> m a
choose xs = asum (pure <$> xs)

enum' :: (ApWriter a m, Alternative m, Monad m) => MultiTree a -> m ()
enum' (FreeT ts) = choose ts >>= \case
  Free (Node xs ys) -> enum' xs *> enum' ys
  Pure w -> write w

example3 :: [Text]
example3 = T.unwords <$> eval (enum' trees)

--

-- From (applicative) nondeterministic writers to multitrees

newtype MultiTreeM w a = MultiTreeM { runMTM :: MultiTree w }
  deriving Functor

instance Applicative (MultiTreeM w) where
  pure x = error "This is actually an Apply (no pure)"
  MultiTreeM xs <*> MultiTreeM ys = MultiTreeM (FreeT [Free (Node xs ys)])

instance Alternative (MultiTreeM w) where
  empty = MultiTreeM (FreeT [])
  MultiTreeM (FreeT xs) <|> MultiTreeM (FreeT ys) = MultiTreeM (FreeT (xs ++ ys))

instance ApWriter w (MultiTreeM w) where
  write w = MultiTreeM (FreeT [Pure w])

example4 :: Bool
example4 = trees == runMTM trees'  -- True