Skip to content

Commit

Permalink
Add support for gafield as a label in GHC >= 9.6
Browse files Browse the repository at this point in the history
  • Loading branch information
arybczak committed Dec 1, 2023
1 parent 40681b2 commit a88da2b
Show file tree
Hide file tree
Showing 3 changed files with 28 additions and 4 deletions.
9 changes: 8 additions & 1 deletion optics-core/src/Optics/Generic.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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:
--
Expand All @@ -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
Expand Down
14 changes: 11 additions & 3 deletions optics-core/src/Optics/Label.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
)
Expand Down Expand Up @@ -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

----------------------------------------
Expand Down
9 changes: 9 additions & 0 deletions optics/tests/Optics/Tests/Labels/Generic.hs
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
Expand Down Expand Up @@ -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 }
Expand Down Expand Up @@ -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)
Expand Down

0 comments on commit a88da2b

Please sign in to comment.