generic-lens 2.2.2.0 → 2.3.0.0

raw patch · 7 files changed

+169/−30 lines, 7 filesdep +mtldep −textdep ~basedep ~generic-lens-corenew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: mtl

Dependencies removed: text

Dependency ranges changed: base, generic-lens-core

API changes (from Hackage documentation)

Files

• ChangeLog.md +14/−2
• generic-lens.cabal +27/−14
• src/Data/Generics/Labels.hs +69/−7
• src/Data/Generics/Product/Typed.hs +3/−1
• src/Data/Generics/Sum/Typed.hs +27/−3
• test/Spec.hs +12/−3
• test/Test146.hs +17/−0

@@ -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`

@@ -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

@@ -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

@@ -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 #-}

@@ -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

@@ -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

@@ -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