From a88da2b66780a7dadb5b647e9cd381dff2f1394a Mon Sep 17 00:00:00 2001
From: Andrzej Rybczak <andrzej@rybczak.net>
Date: Fri, 1 Dec 2023 19:05:46 +0100
Subject: [PATCH] Add support for gafield as a label in GHC >= 9.6

---
 optics-core/src/Optics/Generic.hs           |  9 ++++++++-
 optics-core/src/Optics/Label.hs             | 14 +++++++++++---
 optics/tests/Optics/Tests/Labels/Generic.hs |  9 +++++++++
 3 files changed, 28 insertions(+), 4 deletions(-)

diff --git a/optics-core/src/Optics/Generic.hs b/optics-core/src/Optics/Generic.hs
index 00fbff9d..6160ef11 100644
--- a/optics-core/src/Optics/Generic.hs
+++ b/optics-core/src/Optics/Generic.hs
@@ -166,7 +166,6 @@ instance (a ~ Void0, b ~ Void0) => GField name Void0 Void0 a b where
 -- ...Type ‘NoG’ doesn't have a Generic instance
 -- ...In the...
 -- ...
---
 -- /Note:/ trying to access a field that doesn't exist in any data constructor
 -- results in an error:
 --
@@ -176,6 +175,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..78c28de0 100644
--- a/optics-core/src/Optics/Label.hs
+++ b/optics-core/src/Optics/Label.hs
@@ -535,7 +535,9 @@ type GenericLabelOpticContext repDefined name k s t a b =
   , Unless repDefined (NoLabelOpticError name k s t a b)
   , 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 +595,16 @@ instance
   ) => GenericOptic repDefined name A_Lens s t a b where
   genericOptic = gfieldImpl @name
 
+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)