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 ")
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)