How to get the HasNames instances less manually?

gistfile1.txt

{-# LANGUAGE OverloadedStrings #-}

import ClassyPrelude
import Control.Lens

newtype Name = Name Text deriving (Monoid, Semigroup, IsString, Show)

newtype LongName = LongName Text deriving (IsString, Show)

data Foo1 = Foo1 Int Name Bool deriving Show

data Foo2 = Foo2 ([Foo1], Char) deriving Show

data Foo3 = Foo3 Name Foo2 LongName Int deriving Show

-- HasNames a means that a has 'Name' values inside that can be traversed.
class HasNames a where
  traverseNames :: Traversal' a Name

instance HasNames Name where
  traverseNames = id

-- The 'Name' is the part before the comma. There is exactly one 'Name', so 'traverseNames' here is actualy
-- a Lens'.
instance HasNames LongName where
  traverseNames =
    let getter (LongName x) = Name $ takeWhile (/= ',') x
        setter (LongName x) (Name newFront) =
          let front = takeWhile (/= ',') x
              rest = drop (length front) x
              back = drop (length front + 1) x
          in if null rest
             then LongName newFront
             else LongName $ newFront <> "," <> back
    in lens getter setter

instance HasNames Foo1 where
  traverseNames f (Foo1 x y z) = Foo1 x <$> traverseNames f y <*> pure z

instance HasNames Foo2 where
  traverseNames f (Foo2 x) = Foo2 <$> (_1 . each . traverseNames) f x

instance HasNames Foo3 where
  traverseNames f (Foo3 w x y z) = Foo3 <$> f w <*> traverseNames f x <*> traverseNames f y <*> pure z

foo1 :: Foo1
foo1 = Foo1 1 "abc" True

foo2 :: Foo2
foo2 = Foo2 ([foo1, foo1], 'a')

foo3 :: Foo3
foo3 = Foo3 "def" foo2 "ghi,jkl" 123

foo3' :: Foo3
foo3' = foo3 & traverseNames %~ (\x -> x <> x)

main :: IO ()
main = print foo3'