diff --git a/optics-core/src/Optics/Generic.hs b/optics-core/src/Optics/Generic.hs index 00fbff9d..326c163e 100644 --- a/optics-core/src/Optics/Generic.hs +++ b/optics-core/src/Optics/Generic.hs @@ -176,6 +176,14 @@ instance (a ~ Void0, b ~ Void0) => GField name Void0 Void0 a b where -- ...In the... -- ... -- +-- /Note:/ 'gafield' is supported by 'Optics.Label.labelOptic' and can be used +-- with a concise syntax via @OverloadedLabels@ with GHC >= 9.6. +-- +-- @ +-- λ> herring ^? #"?name" +-- Just \"Henry\" +-- @ +-- -- @since 0.4 -- class GAffineField (name :: Symbol) s t a b | name s -> t a b diff --git a/optics-core/src/Optics/Label.hs b/optics-core/src/Optics/Label.hs index 2a1fda99..67373ac0 100644 --- a/optics-core/src/Optics/Label.hs +++ b/optics-core/src/Optics/Label.hs @@ -533,9 +533,14 @@ type GenericLabelOpticContext repDefined name k s t a b = , repDefined ~ (Defined (Rep s) && Defined (Rep t)) #endif , Unless repDefined (NoLabelOpticError name k s t a b) + -- If a label starts with "_[A-Z]", assume it's a name of a constructor. + -- Otherwise, if it starts with "?[a-z]", assume it's a name of a partial + -- field. Otherwise it's a total field. , k ~ If (CmpSymbol "_@" name == 'LT && CmpSymbol "_[" name == 'GT) A_Prism - A_Lens + (If (CmpSymbol "?`" name == 'LT && CmpSymbol "?{" name == 'GT) + An_AffineTraversal + A_Lens) , GenericOptic repDefined name k s t a b , Dysfunctional name k s t a b ) @@ -593,10 +598,18 @@ instance ) => GenericOptic repDefined name A_Lens s t a b where genericOptic = gfieldImpl @name +-- | This instance can only be used via label syntax with GHC >= 9.6 since it's +-- the first release with unrestricted overloaded labels. +instance + ( GAffineFieldImpl repDefined name s t a b + , origName ~ AppendSymbol "?" name + ) => GenericOptic repDefined origName An_AffineTraversal s t a b where + genericOptic = gafieldImpl @repDefined @name + instance ( GConstructorImpl repDefined name s t a b - , _name ~ AppendSymbol "_" name - ) => GenericOptic repDefined _name A_Prism s t a b where + , origName ~ AppendSymbol "_" name + ) => GenericOptic repDefined origName A_Prism s t a b where genericOptic = gconstructorImpl @repDefined @name ---------------------------------------- diff --git a/optics/tests/Optics/Tests/Labels/Generic.hs b/optics/tests/Optics/Tests/Labels/Generic.hs index b6d3ff52..03ed4c02 100644 --- a/optics/tests/Optics/Tests/Labels/Generic.hs +++ b/optics/tests/Optics/Tests/Labels/Generic.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} @@ -90,7 +91,11 @@ label4rhs s b = s { fish = case fish s of } label5lhs, label5rhs :: Human Mammal -> Bool -> Human Mammal +#if __GLASGOW_HASKELL__ >= 906 +label5lhs s b = set (#pets % traversed % #"?lazy") b s +#else label5lhs s b = set (#pets % traversed % gafield @"lazy") b s +#endif label5rhs s b = s { pets = (`map` pets s) $ \case Dog name0 age0 -> Dog { name = name0, age = age0 } Cat name0 age0 _ -> Cat { name = name0, age = age0, lazy = b } @@ -152,7 +157,11 @@ howManyGoldFish :: Int howManyGoldFish = lengthOf (#pets % folded % #_GoldFish) humanWithFish hasLazyPets :: Bool +#if __GLASGOW_HASKELL__ >= 906 +hasLazyPets = orOf (#pets % folded % #"?lazy") human +#else hasLazyPets = orOf (#pets % folded % gafield @"lazy") human +#endif yearLater :: Human Mammal yearLater = human & #age %~ (+1)