diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,15 @@ +## generic-lens-2.3.0.0 (2025-08-27) + +Tested with GHC 8.4 - 9.14 alpha1. + +- Add `OverloadedLabels` support for positional lenses, e.g. `#3` as an + abbreviation for `position @3`, starting with GHC 9.6. + +### Breaking API changes: +- `AsType` now includes a reflexive case for consistency with `HasType`: every + type can be treated 'as' itself. + + ## generic-lens-2.2.2.0 (2023-04-15) - Support unprefixed constructor prisms on GHC 9.6 (#152) @@ -73,7 +85,7 @@ - The type parameters of the classes have been changed to accommodate the type-changing update: - + `class HasField name a s` -> `class HasField name s t a b` etc. - + Accordingly, `field :: Lens' s a` -> `field :: Lens s t a b` diff --git a/generic-lens.cabal b/generic-lens.cabal --- a/generic-lens.cabal +++ b/generic-lens.cabal @@ -1,5 +1,6 @@ +cabal-version: 2.0 name: generic-lens -version: 2.2.2.0 +version: 2.3.0.0 synopsis: Generically derive traversals, lenses and prisms. description: This library uses GHC.Generics to derive efficient optics (traversals, lenses and prisms) for algebraic data types in a type-directed way, with a focus on good type inference and error messages when possible. . @@ -13,13 +14,27 @@ maintainer: kiss.csongor.kiss@gmail.com category: Generics, Records, Lens build-type: Simple -cabal-version: >= 1.10 -Tested-With: GHC == 8.4.1, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.3, GHC == 9.0.1, GHC == 9.2.1 +tested-with: + GHC == 9.14.1 + GHC == 9.12.2 + GHC == 9.10.2 + GHC == 9.8.4 + GHC == 9.6.7 + GHC == 9.4.8 + GHC == 9.2.8 + GHC == 9.0.2 + GHC == 8.10.7 + GHC == 8.8.4 + GHC == 8.6.5 + GHC == 8.4.4 + + extra-source-files: examples/StarWars.hs , examples/Examples.hs - , ChangeLog.md +extra-doc-files: ChangeLog.md + library exposed-modules: Data.Generics.Wrapped , Data.Generics.Product @@ -45,24 +60,24 @@ , Data.Generics.Internal.VL.Iso build-depends: base >= 4.11 && < 5 - , generic-lens-core == 2.2.1.0 + , generic-lens-core ^>= 2.3.0.0 , profunctors - , text >= 1.2 && < 1.3 || >= 2.0 && < 2.1 hs-source-dirs: src default-language: Haskell2010 + default-extensions: TypeOperators ghc-options: -Wall test-suite inspection-tests type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs - other-modules: Util Test24 Test88 Test25 Test40 Test62 Test63 CustomChildren + other-modules: Util Test24 Test88 Test25 Test40 Test62 Test63 Test146 CustomChildren - build-depends: base >= 4.11 && <= 5.0 + build-depends: base , generic-lens , lens - , profunctors + , mtl , inspection-testing >= 0.2 , HUnit @@ -74,7 +89,7 @@ hs-source-dirs: test main-is: Bifunctor.hs - build-depends: base >= 4.11 && <= 5.0 + build-depends: base , generic-lens , lens , HUnit @@ -87,10 +102,9 @@ hs-source-dirs: test/syb main-is: Tree.hs - build-depends: base >= 4.11 && <= 5.0 + build-depends: base , generic-lens , lens - , profunctors , HUnit default-language: Haskell2010 @@ -101,7 +115,6 @@ type: exitcode-stdio-1.0 ghc-options: -threaded main-is: doctest.hs - build-depends: base >4 && <5 + build-depends: base >= 4 && <5 , doctest - , lens hs-source-dirs: examples diff --git a/src/Data/Generics/Labels.hs b/src/Data/Generics/Labels.hs --- a/src/Data/Generics/Labels.hs +++ b/src/Data/Generics/Labels.hs @@ -1,10 +1,14 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} +#if MIN_VERSION_base(4,12,0) +{-# LANGUAGE NoStarIsType #-} +#endif {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -22,7 +26,8 @@ -- Stability : experimental -- Portability : non-portable -- --- Provides an (orphan) IsLabel instance for field lenses and constructor prisms. +-- Provides an (orphan) IsLabel instance for field lenses and constructor +-- prisms, as well as positional lenses on GHC >=9.6. -- Use at your own risk. -------------------------------------------------------------------------------- @@ -66,6 +71,14 @@ -- instance (AsConstructor name s t a b) => IsLabel name (Prism s t a b) where ... -- @ -- +-- Starting with GHC 9.6, you can also write e.g. @#2@ and @#15@ instead of +-- @position \@1@ and @position \@15@, so we morally have +-- +-- @ +-- instance (HasPosition i s t a b) => IsLabel (Show i) (Lens s t a b) where ... +-- @ +-- +-- -- Remember: -- -- @ @@ -107,17 +120,29 @@ instance {-# INCOHERENT #-} AsConstructor' name s a => Constructor name s s a a where constructorPrism = _Ctor' @name -data LabelType = FieldType | LegacyConstrType | ConstrType +data LabelType = FieldType | LegacyConstrType | ConstrType | PositionType type family ClassifyLabel (name :: Symbol) :: LabelType where ClassifyLabel name = - If (CmpSymbol "_@" name == 'LT && CmpSymbol "_[" name == 'GT) - 'LegacyConstrType - ( If (CmpSymbol "@" name == 'LT && CmpSymbol "[" name == 'GT) - 'ConstrType - 'FieldType + If (StartsWithDigit name) + 'PositionType + ( If (StartsWithUnderscoreAndUpperCase name) + 'LegacyConstrType + ( If (StartsWithUpperCase name) + 'ConstrType + 'FieldType + ) ) +type StartsWithDigit name = + CmpSymbol "/" name == 'LT && CmpSymbol ":" name == 'GT + +type StartsWithUnderscoreAndUpperCase name = + CmpSymbol "_@" name == 'LT && CmpSymbol "_[" name == 'GT + +type StartsWithUpperCase name = + CmpSymbol "@" name == 'LT && CmpSymbol "[" name == 'GT + instance ( labelType ~ ClassifyLabel name , IsLabelHelper labelType name p f s t a b , pafb ~ p a (f b), psft ~ p s (f t)) => IsLabel name (pafb -> psft) where @@ -131,6 +156,9 @@ -- done in the 'IsLabel' instance above). If so, then we're dealing with a -- constructor name, which should be a prism, and otherwise, it's a field name, -- so we have a lens. +-- +-- On GHC >=9.6, we also check whether the symbol starts with a digit, in which +-- case we are dealing with an index for a positional lens. class IsLabelHelper labelType name p f s t a b where labelOutput :: p a (f b) -> p s (f t) @@ -144,3 +172,37 @@ instance ( Applicative f, Choice p, Constructor name s t a b ) => IsLabelHelper 'ConstrType name p f s t a b where labelOutput = constructorPrism @name + +class Position (i :: Nat) s t a b | s i -> a, t i -> b, s i b -> t, t i a -> s where + positionLens :: Lens s t a b + +instance {-# INCOHERENT #-} HasPosition i s t a b => Position i s t a b where + positionLens = position @i + +instance {-# INCOHERENT #-} HasPosition' i s a => Position i s s a a where + positionLens = position' @i + +instance ( Functor f, Position i s t a b, i ~ ParseNat name + ) => IsLabelHelper 'PositionType name (->) f s t a b where + labelOutput = positionLens @i + +-- 'ParseNat' is only necessary for positional lenses, which can only actually +-- be used with OverloadedLabels since GHC 9.6. Therefore, it is fine that this +-- code only compiles with GHC >=9.4 due to the use of newer GHC features (such +-- as 'UnconsSymbol'). +#if MIN_VERSION_base(4,17,0) +type ParseNat name = ParseNat' 0 (UnconsSymbol name) + +type family ParseNat' acc m where + ParseNat' acc ('Just '(hd, tl)) = + ParseNat' (10 * acc + DigitToNat hd) (UnconsSymbol tl) + ParseNat' acc 'Nothing = acc + +type DigitToNat c = + If ('0' <=? c && c <=? '9') + (CharToNat c - CharToNat '0') + (TypeError ('Text "Invalid position number")) +#else +type family ParseNat name where + ParseNat name = TypeError ('Text "Positional lenses not supported") +#endif diff --git a/src/Data/Generics/Product/Typed.hs b/src/Data/Generics/Product/Typed.hs --- a/src/Data/Generics/Product/Typed.hs +++ b/src/Data/Generics/Product/Typed.hs @@ -57,7 +57,8 @@ -- human = Human "Tunyasz" 50 "London" False -- :} --- |Records that have a field with a unique type. +-- |Types that contain another type, either by being a record with a field +-- with that type, or by actually being that type. class HasType a s where -- |A lens that focuses on a field with a unique type in its parent type. -- Compatible with the lens package's 'Control.Lens.Lens' type. @@ -102,6 +103,7 @@ typed = VL.ravel Core.derived {-# INLINE typed #-} +-- |Every type 'has' itself. instance {-# OVERLAPPING #-} HasType a a where getTyped = id {-# INLINE getTyped #-} diff --git a/src/Data/Generics/Sum/Typed.hs b/src/Data/Generics/Sum/Typed.hs --- a/src/Data/Generics/Sum/Typed.hs +++ b/src/Data/Generics/Sum/Typed.hs @@ -27,7 +27,7 @@ module Data.Generics.Sum.Typed ( -- *Prisms -- - -- $setup + -- $setup AsType (..) ) where @@ -61,10 +61,11 @@ -- dog = Dog (MkDog "Shep" (Age 3)) -- cat = Cat "Mog" (Age 5) -- duck = Duck (Age 2) --- :} +-- >>> :} --- |Sums that have a constructor with a field of the given type. +-- |Types that can represent another type, either by being a sum with a +-- constructor containing that type, or by actually being that type. class AsType a s where -- |A prism that projects a constructor uniquely identifiable by the type of -- its field. Compatible with the lens package's 'Control.Lens.Prism' type. @@ -86,16 +87,39 @@ {-# INLINE _Typed #-} -- |Inject by type. + -- + -- + -- >>> :{ + -- dog :: Dog + -- dog = MkDog "Fido" (Age 11) + -- dogAsAnimal :: Animal + -- dogAsAnimal = injectTyped dog + -- dogAsItself :: Dog + -- dogAsItself = injectTyped dog + -- >>> :} injectTyped :: a -> s injectTyped = build _Typed -- |Project by type. + -- + -- + -- >>> :{ + -- dogAsAnimal :: Animal + -- dogAsAnimal = Dog (MkDog "Fido" (Age 11)) + -- mDog :: Maybe Dog + -- mDog = projectTyped dogAsAnimal + -- >>> :} projectTyped :: s -> Maybe a projectTyped = either (const Nothing) Just . match _Typed {-# MINIMAL (injectTyped, projectTyped) | _Typed #-} + +-- |Every type can be treated 'as' itself. +instance {-# OVERLAPPING #-} AsType a a where + injectTyped = id + projectTyped = Just instance Core.Context a s => AsType a s where _Typed eta = prism2prismvl Core.derived eta diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -33,6 +33,7 @@ import Test24 () import Test25 () import Test88 () +import Test146 () import CustomChildren (customTypesTest) @@ -250,10 +251,10 @@ , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose) , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose_) , $(inspectTest $ 'sum1PrismManual === 'sum1PrismB) - -- , $(inspectTest $ 'subtypePrismManual === 'subtypePrismGeneric) (TODO: fails on 8.4) + -- , $(inspectTest $ 'subtypePrismManual === 'subtypePrismGeneric) -- TODO: fails on 8.4 , $(inspectTest $ 'sum2PrismManualChar === 'sum2TypePrismChar) , $(inspectTest $ 'sum2PrismManual === 'sum2TypePrism) - , $(inspectTest $ 'sum1PrismManualChar === 'sum1TypePrismChar) + -- , $(inspectTest $ 'sum1PrismManualChar === 'sum1TypePrismChar) -- TODO fails >=9.12 , $(inspectTest $ 'sum2PrismManualChar === 'sum2TypePrismChar) , $(inspectTest $ 'sum1PrismManual === 'sum1TypePrism) , $(inspectTest $ 'intTraversalManual === 'intTraversalDerived) @@ -271,9 +272,17 @@ , (valLabel ^? #RecB . _1 ) ~=? Just 3 , (valLabel ^? #RecB ) ~=? Just (3, True) , (valLabel ^? #RecC ) ~=? Nothing + + , (valLabel ^. #1 ) ~=? 3 + , let + i x = x :: Int + largeTuple = (i 1, i 2, i 3, i 4, i 5, i 6, i 7, i 8, i 9, i 10, i 11, i 12, i 13, i 14, i 15) + largeTuple' = (i 1, i 2, i 3, i 4, i 5, i 6, i 7, i 8, i 9, i 10, i 11, i 13, i 13, i 14, i 15) + in + (largeTuple ^. #13, largeTuple & #12 +~ 1) ~=? (13, largeTuple') #endif , customTypesTest ] - where valLabel = RecB 3 True + where valLabel = RecB 3 True -- TODO: add test for traversals over multiple types diff --git a/test/Test146.hs b/test/Test146.hs new file mode 100644 --- /dev/null +++ b/test/Test146.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} + +module Test146 where + +import Control.Monad.Except +import Data.Generics.Sum +import GHC.Generics + +data Error = Error + deriving (Generic) + +poly :: (AsType Error e, MonadError e m) => m () +poly = undefined + +mono :: ExceptT Error IO () +mono = poly