Build Prism path selectively base on values

Question

Here is the data structure

data Fruit = Apple String Int 
           | Banana String
           | ....
           | Orange Int Int

data Baseket = BaseketA Fruit
             | BaseketB Fruit Int

makePrism ''Fruit
makePrism ''Baseket

Question is how can I compose a lenses path that points to BasketA and fruits with a name ? ( like Apple and Banana here , but leave out Orange ) ?

Like, to change the name of Fruit in Baseket A ( either Apple or Banana ), if it is orange ,then dont' do anything.

over _Baseket_A._1. _HAS_A_NAME._1 (\x -> x ++ " 's fruit ")

Like drill down if "Fruit" is a "Apple" or "Banana" and apply the function underneath.

over _Baseket_A._1.(\x -> x in set("_Apple","_Banana")) ._1 (\x -> x ++ " 's fruit ")

Answer 1

If you want to generate such an optic automatically, then it's sufficient to name the String field. Unfortunately, this means naming all the fields, since you can't mix named and unnamed fields:

data Fruit = Apple { _name :: String, _x :: Int }
           | Banana { _name :: String, _x :: Int }
           | Orange { _x :: Int, _y :: Int }

data Baseket = BaseketA Fruit
             | BaseketB Fruit Int

makeLenses ''Fruit
makePrisms ''Baseket

The makeLenses ''Fruit call here generates a name traversal that selects only those fruit constructors with a _name field, and the traversal:

aName :: Traversal' Baseket String
aName = _BaseketA . name

appears to be the optic you're looking for:

> print $ over aName (\x -> x ++ "'s fruit") (BaseketA $ Apple "Joe" 5)
BaseketA (Apple {_name = "Joe's fruit", _x = 5})

If you don't want to name your fields, you can write the traversal from scratch which looks like this:

name2 :: Traversal' Fruit String
name2 f (Apple n x) = Apple <$> f n <*> pure x
name2 f (Banana n x) = Banana <$> f n <*> pure x
name2 _ rest = pure rest

but this requires explicitly handling every constructor with a name. If you want to avoid that, you can probably use a generics solution, which looks like this:

import Data.Data.Lens

-- Note: derive a `Data` instance for `Fruit` to use this
name3 :: Traversal' Fruit String
name3 = template

Be warned that template acts recursively, finding all String values within the structure, so it may not be what you want in a more general case. For example, if you add a Lemon constructor:

... | Lemon { _x :: Int, _u :: Maybe String }

the name3 = template solution will include the String recursively from the Maybe String field.

If you only want Strings that are immediate children, there doesn't appear to be a non-recursive variant of template available. The following will work, but it's pretty ugly:

name4 :: Traversal' Fruit String
name4 f = gtraverse (mkA f)
  where
    mkA :: forall f a d. (Applicative f, Typeable a, Data d) => (a -> f a) -> d -> f d
    mkA f = case eqT @a @d of Just Refl -> f
                              Nothing -> pure

though maybe there's an easier way that I'm missing.

In either case, name3 and name4 will both traverse multiple strings, so if you have an Avocado String String constructor, both strings will be traversed. Use the name1 or name2 solution if you only want one of the two strings.

Anyway, here's full code illustrating all four solutions. Note the difference for the added Lemon constructor between the recursive generic name3 and the non-recursive generic name4:

{-# LANGUAGE GADTs #-}
{-# LANGUAGE TemplateHaskell #-}

module SelectivePrism where

import Control.Lens
import Data.Data.Lens
import Data.Data

data Fruit = Apple  { _name1 :: String, _x :: Int }
           | Banana { _name1 :: String, _y :: Int }
           | Orange { _x :: Int, _y :: Int }
           | Lemon { _x :: Int, _u :: Maybe String }
           deriving (Show, Data)

data Baseket = BaseketA Fruit
             | BaseketB Fruit Int
             deriving (Show)

makeLenses ''Fruit
makePrisms ''Baseket

name2 :: Traversal' Fruit String
name2 f (Apple n x) = Apple <$> f n <*> pure x
name2 f (Banana n x) = Banana <$> f n <*> pure x
name2 _ rest = pure rest

name3 :: Traversal' Fruit String
name3 = template

name4 :: Traversal' Fruit String
name4 f = gtraverse (mkA f)
  where
    mkA :: forall f a d. (Applicative f, Typeable a, Data d) => (a -> f a) -> d -> f d
    mkA f = case eqT @a @d of Just Refl -> f
                              Nothing -> pure

test name = do
  print $ over (_BaseketA.name) (\x -> x ++ "'s fruit") (BaseketA $ Apple "Joe" 5)
  print $ over (_BaseketA.name) (\x -> x ++ "'s fruit") (BaseketA $ Orange 4 2)
  print $ over (_BaseketA.name) (\x -> x ++ "'s fruit") (BaseketA $ Lemon 3 (Just "not a name"))

main = do
  test name1   -- `makeLenses` with named fields
  test name2   -- explicit traversal
  test name3   -- generics
  test name4   -- generics (non-recursive)