diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,14 @@ +# optics-core-0.4.1 (2022-03-22) +* Add support for GHC-9.2 +* Add `is` ([#410](https://github.com/well-typed/optics/pull/410)) +* Improve error messages related to the `JoinKinds` class + ([#439](https://github.com/well-typed/optics/pull/439)) +* Port `universeOf`, `cosmosOf`, `paraOf`, `rewriteOf`, `transformOf`, + `rewriteMOf` and `transformMOf` from `Control.Lens.Plated` + ([#379](https://github.com/well-typed/optics/pull/379)) +* Add `(%?)` composition operator + ([#434](https://github.com/well-typed/optics/pull/434)) + # optics-core-0.4 (2021-02-22) * See [migration-guide-0.4.md](https://github.com/well-typed/optics/blob/master/migration-guide-0.4.md) for more details * Add support for GHC-9.0 diff --git a/optics-core.cabal b/optics-core.cabal --- a/optics-core.cabal +++ b/optics-core.cabal @@ -1,12 +1,13 @@ +cabal-version: 2.2 name: optics-core -version: 0.4 -license: BSD3 +version: 0.4.1 +license: BSD-3-Clause license-file: LICENSE build-type: Simple -cabal-version: 1.24 maintainer: optics@well-typed.com author: Adam Gundry, Andres Löh, Andrzej Rybczak, Oleg Grenrus -tested-with: GHC ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.3, GHCJS ==8.4 +tested-with: GHC ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 + || ==9.0.2 || ==9.2.2, GHCJS ==8.4 synopsis: Optics as an abstract interface: core definitions category: Data, Optics, Lenses description: @@ -32,10 +33,40 @@ manual: True description: Require explicit GenericLabelOptics instances in order to use generics-based labels +common language + ghc-options: -Wall -Wcompat + + default-language: Haskell2010 + + default-extensions: BangPatterns + ConstraintKinds + DefaultSignatures + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + EmptyCase + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + OverloadedLabels + PatternSynonyms + RankNTypes + ScopedTypeVariables + TupleSections + TypeApplications + TypeFamilies + TypeOperators + ViewPatterns + library - default-language: Haskell2010 + import: language hs-source-dirs: src - ghc-options: -Wall if flag(explicit-generic-labels) cpp-options: -DEXPLICIT_GENERIC_LABELS @@ -88,6 +119,7 @@ Optics.Operators.Unsafe Optics.Re Optics.ReadOnly + Optics.Core.Extras -- optics for data types Data.Either.Optics @@ -122,20 +154,3 @@ Optics.Internal.Setter Optics.Internal.Traversal Optics.Internal.Utils - - default-extensions: BangPatterns - DefaultSignatures - DeriveFunctor - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - InstanceSigs - LambdaCase - MultiParamTypeClasses - RankNTypes - ScopedTypeVariables - TupleSections - TypeApplications - TypeFamilies - TypeOperators diff --git a/src/Data/List/Optics.hs b/src/Data/List/Optics.hs --- a/src/Data/List/Optics.hs +++ b/src/Data/List/Optics.hs @@ -70,7 +70,7 @@ ) where import Control.Monad (guard) -import Data.List +import qualified Data.List as L import Optics.Prism @@ -86,7 +86,7 @@ -- >>> prefixed "pre" # "amble" -- "preamble" prefixed :: Eq a => [a] -> Prism' [a] [a] -prefixed ps = prism' (ps ++) (stripPrefix ps) +prefixed ps = prism' (ps ++) (L.stripPrefix ps) {-# INLINE prefixed #-} -- | A 'Prism' stripping a suffix from a list when used as a diff --git a/src/Data/Maybe/Optics.hs b/src/Data/Maybe/Optics.hs --- a/src/Data/Maybe/Optics.hs +++ b/src/Data/Maybe/Optics.hs @@ -6,9 +6,11 @@ module Data.Maybe.Optics ( _Nothing , _Just + , (%?) ) where +import Optics.Internal.Optic import Optics.Prism -- | A 'Prism' that matches on the 'Nothing' constructor of 'Maybe'. @@ -34,3 +36,17 @@ Just y -> Right y ) {-# INLINE _Just #-} + +-- | Shortcut for @'%' '_Just' '%'@. +-- +-- Useful for composing lenses of 'Maybe' type. +-- +-- @since 0.4.1 +infixl 9 %? +(%?) + :: (AppendIndices is js ks, JoinKinds k A_Prism k', JoinKinds k' l m) + => Optic k is s t (Maybe u) (Maybe v) + -> Optic l js u v a b + -> Optic m ks s t a b +o1 %? o2 = o1 % _Just % o2 +{-# INLINE (%?) #-} diff --git a/src/Numeric/Optics.hs b/src/Numeric/Optics.hs --- a/src/Numeric/Optics.hs +++ b/src/Numeric/Optics.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} -- | -- Module: Numeric.Optics -- Description: Optics for working with numeric types. diff --git a/src/Optics/AffineFold.hs b/src/Optics/AffineFold.hs --- a/src/Optics/AffineFold.hs +++ b/src/Optics/AffineFold.hs @@ -147,8 +147,10 @@ -- >>> isn't _Just Nothing -- True -- +-- The negation of this operator is 'Optics.Core.Extras.is' from +-- "Optics.Core.Extras". isn't :: Is k An_AffineFold => Optic' k is s a -> s -> Bool -isn't k s = not (isJust (preview k s)) +isn't k s = isNothing (preview k s) {-# INLINE isn't #-} -- $setup diff --git a/src/Optics/Cons/Core.hs b/src/Optics/Cons/Core.hs --- a/src/Optics/Cons/Core.hs +++ b/src/Optics/Cons/Core.hs @@ -9,8 +9,6 @@ -- module from @optics-extra@, so if you are not simply depending on @optics@ -- you may wish to import that module instead. -- -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} module Optics.Cons.Core ( -- * Cons diff --git a/src/Optics/Core/Extras.hs b/src/Optics/Core/Extras.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Core/Extras.hs @@ -0,0 +1,23 @@ +module Optics.Core.Extras + ( + is + ) + where + +import Data.Maybe + +import Optics.Optic +import Optics.AffineFold + +-- | Check to see if this 'AffineFold' matches. +-- +-- >>> is _Just Nothing +-- False +-- +-- @since 0.4.1 +is :: Is k An_AffineFold => Optic' k is s a -> s -> Bool +is k s = isJust (preview k s) +{-# INLINE is #-} + +-- $setup +-- >>> import Optics.Core diff --git a/src/Optics/Empty/Core.hs b/src/Optics/Empty/Core.hs --- a/src/Optics/Empty/Core.hs +++ b/src/Optics/Empty/Core.hs @@ -16,8 +16,6 @@ -- True -- {-# LANGUAGE CPP #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} module Optics.Empty.Core ( AsEmpty(..) , pattern Empty diff --git a/src/Optics/Fold.hs b/src/Optics/Fold.hs --- a/src/Optics/Fold.hs +++ b/src/Optics/Fold.hs @@ -70,6 +70,9 @@ , findOf , findMOf , lookupOf + , universeOf + , cosmosOf + , paraOf -- * Combinators , pre @@ -674,6 +677,36 @@ lookupOf :: (Is k A_Fold, Eq a) => Optic' k is s (a, v) -> a -> s -> Maybe v lookupOf o a = foldrOf o (\(a', v) next -> if a == a' then Just v else next) Nothing {-# INLINE lookupOf #-} + +-- | Given a 'Fold' that knows how to locate immediate children, retrieve all of +-- the transitive descendants of a node, including itself. +-- +-- @since 0.4.1 +universeOf :: Is k A_Fold => Optic' k is a a -> a -> [a] +universeOf o = (`appEndo` []) . go + where + go a = Endo (a :) <> foldMapOf o go a +{-# INLINE universeOf #-} + +-- | Given a 'Fold' that knows how to locate immediate children, fold all of the +-- transitive descendants of a node, including itself. +-- +-- @since 0.4.1 +cosmosOf :: forall k is a. Is k A_Fold => Optic' k is a a -> Fold a a +cosmosOf o = foldVL go + where + go :: Applicative f => (a -> f ()) -> a -> f () + go f a = f a *> traverseOf_ o (go f) a +{-# INLINE cosmosOf #-} + +-- | Perform a fold-like computation on each value, technically a paramorphism. +-- +-- @since 0.4.1 +paraOf :: Is k A_Fold => Optic' k is a a -> (a -> [r] -> r) -> a -> r +paraOf o f = go + where + go a = f a (go <$> toListOf o a) +{-# INLINE paraOf #-} -- $setup -- >>> import Optics.Core diff --git a/src/Optics/Generic.hs b/src/Optics/Generic.hs --- a/src/Optics/Generic.hs +++ b/src/Optics/Generic.hs @@ -1,7 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE EmptyCase #-} {-# LANGUAGE UndecidableInstances #-} -- | -- Module: Optics.Generic diff --git a/src/Optics/Internal/Generic.hs b/src/Optics/Internal/Generic.hs --- a/src/Optics/Internal/Generic.hs +++ b/src/Optics/Internal/Generic.hs @@ -1,6 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE EmptyCase #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} @@ -426,13 +425,13 @@ instance ( GConstructorTuple g h a b ) => GConstructorSum '[] (M1 C m g) (M1 C m h) a b where - gconstructorSum = _M1 % gconstructorTuple + gconstructorSum = castOptic (_M1 % gconstructorTuple) class GConstructorTuple g h a b | g -> a , h -> b , g b -> h , h a -> g where - gconstructorTuple :: Prism (g x) (h x) a b + gconstructorTuple :: Iso (g x) (h x) a b -- Fon uncluttering types in below instances a bit. type F m a = M1 S m (Rec0 a) @@ -450,14 +449,14 @@ ( a ~ () , b ~ () ) => GConstructorTuple U1 U1 a b where - gconstructorTuple = castOptic _U1 + gconstructorTuple = _U1 {-# INLINE gconstructorTuple #-} instance ( r ~ a , s ~ b ) => GConstructorTuple (F m a) (F m b) r s where - gconstructorTuple = castOptic coerced + gconstructorTuple = coerced {-# INLINE gconstructorTuple #-} instance @@ -466,7 +465,7 @@ ) => GConstructorTuple (F m1 a1 :*: F m2 a2) (F m1 b1 :*: F m2 b2) r s where - gconstructorTuple = castOptic $ iso + gconstructorTuple = iso (\(M1 (K1 a1) :*: M1 (K1 a2)) -> (a1, a2)) (\(b1, b2) -> M1 (K1 b1) :*: M1 (K1 b2)) {-# INLINE gconstructorTuple #-} @@ -478,7 +477,7 @@ ) => GConstructorTuple (F m1 a1 :*: F m2 a2 :*: F m3 a3) (F m1 b1 :*: F m2 b2 :*: F m3 b3) r s where - gconstructorTuple = castOptic $ iso + gconstructorTuple = iso (\(M1 (K1 a1) :*: M1 (K1 a2) :*: M1 (K1 a3)) -> (a1, a2, a3)) (\(b1, b2, b3) -> M1 (K1 b1) :*: M1 (K1 b2) :*: M1 (K1 b3)) {-# INLINE gconstructorTuple #-} @@ -490,7 +489,7 @@ ) => GConstructorTuple ((F m1 a1 :*: F m2 a2) :*: (F m3 a3 :*: F m4 a4)) ((F m1 b1 :*: F m2 b2) :*: (F m3 b3 :*: F m4 b4)) r s where - gconstructorTuple = castOptic $ iso + gconstructorTuple = iso (\((M1 (K1 a1) :*: M1 (K1 a2)) :*: (M1 (K1 a3) :*: M1 (K1 a4))) -> (a1, a2, a3, a4)) (\(b1, b2, b3, b4) -> (M1 (K1 b1) :*: M1 (K1 b2)) :*: (M1 (K1 b3) :*: M1 (K1 b4))) {-# INLINE gconstructorTuple #-} @@ -502,7 +501,7 @@ ) => GConstructorTuple ((F m1 a1 :*: F m2 a2) :*: (F m3 a3 :*: F m4 a4 :*: F m5 a5)) ((F m1 b1 :*: F m2 b2) :*: (F m3 b3 :*: F m4 b4 :*: F m5 b5)) r s where - gconstructorTuple = castOptic $ iso + gconstructorTuple = iso (\((M1 (K1 a1) :*: M1 (K1 a2)) :*: (M1 (K1 a3) :*: M1 (K1 a4) :*: M1 (K1 a5))) -> (a1, a2, a3, a4, a5)) (\(b1, b2, b3, b4, b5) -> diff --git a/src/Optics/Internal/Optic/Subtyping.hs b/src/Optics/Internal/Optic/Subtyping.hs --- a/src/Optics/Internal/Optic/Subtyping.hs +++ b/src/Optics/Internal/Optic/Subtyping.hs @@ -159,276 +159,276 @@ -- BEGIN GENERATED CONTENT -- An_Iso ----- -instance JoinKinds An_Iso An_Iso An_Iso where +instance k ~ An_Iso => JoinKinds An_Iso An_Iso k where joinKinds r = r -instance JoinKinds An_Iso A_ReversedLens A_ReversedLens where +instance k ~ A_ReversedLens => JoinKinds An_Iso A_ReversedLens k where joinKinds r = r -instance JoinKinds An_Iso A_ReversedPrism A_ReversedPrism where +instance k ~ A_ReversedPrism => JoinKinds An_Iso A_ReversedPrism k where joinKinds r = r -instance JoinKinds An_Iso A_Prism A_Prism where +instance k ~ A_Prism => JoinKinds An_Iso A_Prism k where joinKinds r = r -instance JoinKinds An_Iso A_Review A_Review where +instance k ~ A_Review => JoinKinds An_Iso A_Review k where joinKinds r = r -instance JoinKinds An_Iso A_Lens A_Lens where +instance k ~ A_Lens => JoinKinds An_Iso A_Lens k where joinKinds r = r -instance JoinKinds An_Iso A_Getter A_Getter where +instance k ~ A_Getter => JoinKinds An_Iso A_Getter k where joinKinds r = r -instance JoinKinds An_Iso An_AffineTraversal An_AffineTraversal where +instance k ~ An_AffineTraversal => JoinKinds An_Iso An_AffineTraversal k where joinKinds r = r -instance JoinKinds An_Iso An_AffineFold An_AffineFold where +instance k ~ An_AffineFold => JoinKinds An_Iso An_AffineFold k where joinKinds r = r -instance JoinKinds An_Iso A_Traversal A_Traversal where +instance k ~ A_Traversal => JoinKinds An_Iso A_Traversal k where joinKinds r = r -instance JoinKinds An_Iso A_Fold A_Fold where +instance k ~ A_Fold => JoinKinds An_Iso A_Fold k where joinKinds r = r -instance JoinKinds An_Iso A_Setter A_Setter where +instance k ~ A_Setter => JoinKinds An_Iso A_Setter k where joinKinds r = r -- A_ReversedLens ----- -instance JoinKinds A_ReversedLens A_ReversedLens A_ReversedLens where +instance k ~ A_ReversedLens => JoinKinds A_ReversedLens A_ReversedLens k where joinKinds r = r -instance JoinKinds A_ReversedLens An_Iso A_ReversedLens where +instance k ~ A_ReversedLens => JoinKinds A_ReversedLens An_Iso k where joinKinds r = r --- no JoinKinds A_ReversedLens A_ReversedPrism -instance JoinKinds A_ReversedLens A_Prism A_Review where +-- no JoinKinds A_ReversedLens A_ReversedPrism +instance k ~ A_Review => JoinKinds A_ReversedLens A_Prism k where joinKinds r = r -instance JoinKinds A_ReversedLens A_Review A_Review where +instance k ~ A_Review => JoinKinds A_ReversedLens A_Review k where joinKinds r = r --- no JoinKinds A_ReversedLens A_Lens --- no JoinKinds A_ReversedLens A_Getter --- no JoinKinds A_ReversedLens An_AffineTraversal --- no JoinKinds A_ReversedLens An_AffineFold --- no JoinKinds A_ReversedLens A_Traversal --- no JoinKinds A_ReversedLens A_Fold --- no JoinKinds A_ReversedLens A_Setter +-- no JoinKinds A_ReversedLens A_Lens +-- no JoinKinds A_ReversedLens A_Getter +-- no JoinKinds A_ReversedLens An_AffineTraversal +-- no JoinKinds A_ReversedLens An_AffineFold +-- no JoinKinds A_ReversedLens A_Traversal +-- no JoinKinds A_ReversedLens A_Fold +-- no JoinKinds A_ReversedLens A_Setter -- A_ReversedPrism ----- -instance JoinKinds A_ReversedPrism A_ReversedPrism A_ReversedPrism where +instance k ~ A_ReversedPrism => JoinKinds A_ReversedPrism A_ReversedPrism k where joinKinds r = r -instance JoinKinds A_ReversedPrism An_Iso A_ReversedPrism where +instance k ~ A_ReversedPrism => JoinKinds A_ReversedPrism An_Iso k where joinKinds r = r --- no JoinKinds A_ReversedPrism A_ReversedLens -instance JoinKinds A_ReversedPrism A_Prism An_AffineFold where +-- no JoinKinds A_ReversedPrism A_ReversedLens +instance k ~ An_AffineFold => JoinKinds A_ReversedPrism A_Prism k where joinKinds r = r --- no JoinKinds A_ReversedPrism A_Review -instance JoinKinds A_ReversedPrism A_Lens A_Getter where +-- no JoinKinds A_ReversedPrism A_Review +instance k ~ A_Getter => JoinKinds A_ReversedPrism A_Lens k where joinKinds r = r -instance JoinKinds A_ReversedPrism A_Getter A_Getter where +instance k ~ A_Getter => JoinKinds A_ReversedPrism A_Getter k where joinKinds r = r -instance JoinKinds A_ReversedPrism An_AffineTraversal An_AffineFold where +instance k ~ An_AffineFold => JoinKinds A_ReversedPrism An_AffineTraversal k where joinKinds r = r -instance JoinKinds A_ReversedPrism An_AffineFold An_AffineFold where +instance k ~ An_AffineFold => JoinKinds A_ReversedPrism An_AffineFold k where joinKinds r = r -instance JoinKinds A_ReversedPrism A_Traversal A_Fold where +instance k ~ A_Fold => JoinKinds A_ReversedPrism A_Traversal k where joinKinds r = r -instance JoinKinds A_ReversedPrism A_Fold A_Fold where +instance k ~ A_Fold => JoinKinds A_ReversedPrism A_Fold k where joinKinds r = r --- no JoinKinds A_ReversedPrism A_Setter +-- no JoinKinds A_ReversedPrism A_Setter -- A_Prism ----- -instance JoinKinds A_Prism A_Prism A_Prism where +instance k ~ A_Prism => JoinKinds A_Prism A_Prism k where joinKinds r = r -instance JoinKinds A_Prism An_Iso A_Prism where +instance k ~ A_Prism => JoinKinds A_Prism An_Iso k where joinKinds r = r -instance JoinKinds A_Prism A_ReversedLens A_Review where +instance k ~ A_Review => JoinKinds A_Prism A_ReversedLens k where joinKinds r = r -instance JoinKinds A_Prism A_ReversedPrism An_AffineFold where +instance k ~ An_AffineFold => JoinKinds A_Prism A_ReversedPrism k where joinKinds r = r -instance JoinKinds A_Prism A_Review A_Review where +instance k ~ A_Review => JoinKinds A_Prism A_Review k where joinKinds r = r -instance JoinKinds A_Prism A_Lens An_AffineTraversal where +instance k ~ An_AffineTraversal => JoinKinds A_Prism A_Lens k where joinKinds r = r -instance JoinKinds A_Prism A_Getter An_AffineFold where +instance k ~ An_AffineFold => JoinKinds A_Prism A_Getter k where joinKinds r = r -instance JoinKinds A_Prism An_AffineTraversal An_AffineTraversal where +instance k ~ An_AffineTraversal => JoinKinds A_Prism An_AffineTraversal k where joinKinds r = r -instance JoinKinds A_Prism An_AffineFold An_AffineFold where +instance k ~ An_AffineFold => JoinKinds A_Prism An_AffineFold k where joinKinds r = r -instance JoinKinds A_Prism A_Traversal A_Traversal where +instance k ~ A_Traversal => JoinKinds A_Prism A_Traversal k where joinKinds r = r -instance JoinKinds A_Prism A_Fold A_Fold where +instance k ~ A_Fold => JoinKinds A_Prism A_Fold k where joinKinds r = r -instance JoinKinds A_Prism A_Setter A_Setter where +instance k ~ A_Setter => JoinKinds A_Prism A_Setter k where joinKinds r = r -- A_Review ----- -instance JoinKinds A_Review A_Review A_Review where +instance k ~ A_Review => JoinKinds A_Review A_Review k where joinKinds r = r -instance JoinKinds A_Review An_Iso A_Review where +instance k ~ A_Review => JoinKinds A_Review An_Iso k where joinKinds r = r -instance JoinKinds A_Review A_ReversedLens A_Review where +instance k ~ A_Review => JoinKinds A_Review A_ReversedLens k where joinKinds r = r --- no JoinKinds A_Review A_ReversedPrism -instance JoinKinds A_Review A_Prism A_Review where +-- no JoinKinds A_Review A_ReversedPrism +instance k ~ A_Review => JoinKinds A_Review A_Prism k where joinKinds r = r --- no JoinKinds A_Review A_Lens --- no JoinKinds A_Review A_Getter --- no JoinKinds A_Review An_AffineTraversal --- no JoinKinds A_Review An_AffineFold --- no JoinKinds A_Review A_Traversal --- no JoinKinds A_Review A_Fold --- no JoinKinds A_Review A_Setter +-- no JoinKinds A_Review A_Lens +-- no JoinKinds A_Review A_Getter +-- no JoinKinds A_Review An_AffineTraversal +-- no JoinKinds A_Review An_AffineFold +-- no JoinKinds A_Review A_Traversal +-- no JoinKinds A_Review A_Fold +-- no JoinKinds A_Review A_Setter -- A_Lens ----- -instance JoinKinds A_Lens A_Lens A_Lens where +instance k ~ A_Lens => JoinKinds A_Lens A_Lens k where joinKinds r = r -instance JoinKinds A_Lens An_Iso A_Lens where +instance k ~ A_Lens => JoinKinds A_Lens An_Iso k where joinKinds r = r --- no JoinKinds A_Lens A_ReversedLens -instance JoinKinds A_Lens A_ReversedPrism A_Getter where +-- no JoinKinds A_Lens A_ReversedLens +instance k ~ A_Getter => JoinKinds A_Lens A_ReversedPrism k where joinKinds r = r -instance JoinKinds A_Lens A_Prism An_AffineTraversal where +instance k ~ An_AffineTraversal => JoinKinds A_Lens A_Prism k where joinKinds r = r --- no JoinKinds A_Lens A_Review -instance JoinKinds A_Lens A_Getter A_Getter where +-- no JoinKinds A_Lens A_Review +instance k ~ A_Getter => JoinKinds A_Lens A_Getter k where joinKinds r = r -instance JoinKinds A_Lens An_AffineTraversal An_AffineTraversal where +instance k ~ An_AffineTraversal => JoinKinds A_Lens An_AffineTraversal k where joinKinds r = r -instance JoinKinds A_Lens An_AffineFold An_AffineFold where +instance k ~ An_AffineFold => JoinKinds A_Lens An_AffineFold k where joinKinds r = r -instance JoinKinds A_Lens A_Traversal A_Traversal where +instance k ~ A_Traversal => JoinKinds A_Lens A_Traversal k where joinKinds r = r -instance JoinKinds A_Lens A_Fold A_Fold where +instance k ~ A_Fold => JoinKinds A_Lens A_Fold k where joinKinds r = r -instance JoinKinds A_Lens A_Setter A_Setter where +instance k ~ A_Setter => JoinKinds A_Lens A_Setter k where joinKinds r = r -- A_Getter ----- -instance JoinKinds A_Getter A_Getter A_Getter where +instance k ~ A_Getter => JoinKinds A_Getter A_Getter k where joinKinds r = r -instance JoinKinds A_Getter An_Iso A_Getter where +instance k ~ A_Getter => JoinKinds A_Getter An_Iso k where joinKinds r = r --- no JoinKinds A_Getter A_ReversedLens -instance JoinKinds A_Getter A_ReversedPrism A_Getter where +-- no JoinKinds A_Getter A_ReversedLens +instance k ~ A_Getter => JoinKinds A_Getter A_ReversedPrism k where joinKinds r = r -instance JoinKinds A_Getter A_Prism An_AffineFold where +instance k ~ An_AffineFold => JoinKinds A_Getter A_Prism k where joinKinds r = r --- no JoinKinds A_Getter A_Review -instance JoinKinds A_Getter A_Lens A_Getter where +-- no JoinKinds A_Getter A_Review +instance k ~ A_Getter => JoinKinds A_Getter A_Lens k where joinKinds r = r -instance JoinKinds A_Getter An_AffineTraversal An_AffineFold where +instance k ~ An_AffineFold => JoinKinds A_Getter An_AffineTraversal k where joinKinds r = r -instance JoinKinds A_Getter An_AffineFold An_AffineFold where +instance k ~ An_AffineFold => JoinKinds A_Getter An_AffineFold k where joinKinds r = r -instance JoinKinds A_Getter A_Traversal A_Fold where +instance k ~ A_Fold => JoinKinds A_Getter A_Traversal k where joinKinds r = r -instance JoinKinds A_Getter A_Fold A_Fold where +instance k ~ A_Fold => JoinKinds A_Getter A_Fold k where joinKinds r = r --- no JoinKinds A_Getter A_Setter +-- no JoinKinds A_Getter A_Setter -- An_AffineTraversal ----- -instance JoinKinds An_AffineTraversal An_AffineTraversal An_AffineTraversal where +instance k ~ An_AffineTraversal => JoinKinds An_AffineTraversal An_AffineTraversal k where joinKinds r = r -instance JoinKinds An_AffineTraversal An_Iso An_AffineTraversal where +instance k ~ An_AffineTraversal => JoinKinds An_AffineTraversal An_Iso k where joinKinds r = r --- no JoinKinds An_AffineTraversal A_ReversedLens -instance JoinKinds An_AffineTraversal A_ReversedPrism An_AffineFold where +-- no JoinKinds An_AffineTraversal A_ReversedLens +instance k ~ An_AffineFold => JoinKinds An_AffineTraversal A_ReversedPrism k where joinKinds r = r -instance JoinKinds An_AffineTraversal A_Prism An_AffineTraversal where +instance k ~ An_AffineTraversal => JoinKinds An_AffineTraversal A_Prism k where joinKinds r = r --- no JoinKinds An_AffineTraversal A_Review -instance JoinKinds An_AffineTraversal A_Lens An_AffineTraversal where +-- no JoinKinds An_AffineTraversal A_Review +instance k ~ An_AffineTraversal => JoinKinds An_AffineTraversal A_Lens k where joinKinds r = r -instance JoinKinds An_AffineTraversal A_Getter An_AffineFold where +instance k ~ An_AffineFold => JoinKinds An_AffineTraversal A_Getter k where joinKinds r = r -instance JoinKinds An_AffineTraversal An_AffineFold An_AffineFold where +instance k ~ An_AffineFold => JoinKinds An_AffineTraversal An_AffineFold k where joinKinds r = r -instance JoinKinds An_AffineTraversal A_Traversal A_Traversal where +instance k ~ A_Traversal => JoinKinds An_AffineTraversal A_Traversal k where joinKinds r = r -instance JoinKinds An_AffineTraversal A_Fold A_Fold where +instance k ~ A_Fold => JoinKinds An_AffineTraversal A_Fold k where joinKinds r = r -instance JoinKinds An_AffineTraversal A_Setter A_Setter where +instance k ~ A_Setter => JoinKinds An_AffineTraversal A_Setter k where joinKinds r = r -- An_AffineFold ----- -instance JoinKinds An_AffineFold An_AffineFold An_AffineFold where +instance k ~ An_AffineFold => JoinKinds An_AffineFold An_AffineFold k where joinKinds r = r -instance JoinKinds An_AffineFold An_Iso An_AffineFold where +instance k ~ An_AffineFold => JoinKinds An_AffineFold An_Iso k where joinKinds r = r --- no JoinKinds An_AffineFold A_ReversedLens -instance JoinKinds An_AffineFold A_ReversedPrism An_AffineFold where +-- no JoinKinds An_AffineFold A_ReversedLens +instance k ~ An_AffineFold => JoinKinds An_AffineFold A_ReversedPrism k where joinKinds r = r -instance JoinKinds An_AffineFold A_Prism An_AffineFold where +instance k ~ An_AffineFold => JoinKinds An_AffineFold A_Prism k where joinKinds r = r --- no JoinKinds An_AffineFold A_Review -instance JoinKinds An_AffineFold A_Lens An_AffineFold where +-- no JoinKinds An_AffineFold A_Review +instance k ~ An_AffineFold => JoinKinds An_AffineFold A_Lens k where joinKinds r = r -instance JoinKinds An_AffineFold A_Getter An_AffineFold where +instance k ~ An_AffineFold => JoinKinds An_AffineFold A_Getter k where joinKinds r = r -instance JoinKinds An_AffineFold An_AffineTraversal An_AffineFold where +instance k ~ An_AffineFold => JoinKinds An_AffineFold An_AffineTraversal k where joinKinds r = r -instance JoinKinds An_AffineFold A_Traversal A_Fold where +instance k ~ A_Fold => JoinKinds An_AffineFold A_Traversal k where joinKinds r = r -instance JoinKinds An_AffineFold A_Fold A_Fold where +instance k ~ A_Fold => JoinKinds An_AffineFold A_Fold k where joinKinds r = r --- no JoinKinds An_AffineFold A_Setter +-- no JoinKinds An_AffineFold A_Setter -- A_Traversal ----- -instance JoinKinds A_Traversal A_Traversal A_Traversal where +instance k ~ A_Traversal => JoinKinds A_Traversal A_Traversal k where joinKinds r = r -instance JoinKinds A_Traversal An_Iso A_Traversal where +instance k ~ A_Traversal => JoinKinds A_Traversal An_Iso k where joinKinds r = r --- no JoinKinds A_Traversal A_ReversedLens -instance JoinKinds A_Traversal A_ReversedPrism A_Fold where +-- no JoinKinds A_Traversal A_ReversedLens +instance k ~ A_Fold => JoinKinds A_Traversal A_ReversedPrism k where joinKinds r = r -instance JoinKinds A_Traversal A_Prism A_Traversal where +instance k ~ A_Traversal => JoinKinds A_Traversal A_Prism k where joinKinds r = r --- no JoinKinds A_Traversal A_Review -instance JoinKinds A_Traversal A_Lens A_Traversal where +-- no JoinKinds A_Traversal A_Review +instance k ~ A_Traversal => JoinKinds A_Traversal A_Lens k where joinKinds r = r -instance JoinKinds A_Traversal A_Getter A_Fold where +instance k ~ A_Fold => JoinKinds A_Traversal A_Getter k where joinKinds r = r -instance JoinKinds A_Traversal An_AffineTraversal A_Traversal where +instance k ~ A_Traversal => JoinKinds A_Traversal An_AffineTraversal k where joinKinds r = r -instance JoinKinds A_Traversal An_AffineFold A_Fold where +instance k ~ A_Fold => JoinKinds A_Traversal An_AffineFold k where joinKinds r = r -instance JoinKinds A_Traversal A_Fold A_Fold where +instance k ~ A_Fold => JoinKinds A_Traversal A_Fold k where joinKinds r = r -instance JoinKinds A_Traversal A_Setter A_Setter where +instance k ~ A_Setter => JoinKinds A_Traversal A_Setter k where joinKinds r = r -- A_Fold ----- -instance JoinKinds A_Fold A_Fold A_Fold where +instance k ~ A_Fold => JoinKinds A_Fold A_Fold k where joinKinds r = r -instance JoinKinds A_Fold An_Iso A_Fold where +instance k ~ A_Fold => JoinKinds A_Fold An_Iso k where joinKinds r = r --- no JoinKinds A_Fold A_ReversedLens -instance JoinKinds A_Fold A_ReversedPrism A_Fold where +-- no JoinKinds A_Fold A_ReversedLens +instance k ~ A_Fold => JoinKinds A_Fold A_ReversedPrism k where joinKinds r = r -instance JoinKinds A_Fold A_Prism A_Fold where +instance k ~ A_Fold => JoinKinds A_Fold A_Prism k where joinKinds r = r --- no JoinKinds A_Fold A_Review -instance JoinKinds A_Fold A_Lens A_Fold where +-- no JoinKinds A_Fold A_Review +instance k ~ A_Fold => JoinKinds A_Fold A_Lens k where joinKinds r = r -instance JoinKinds A_Fold A_Getter A_Fold where +instance k ~ A_Fold => JoinKinds A_Fold A_Getter k where joinKinds r = r -instance JoinKinds A_Fold An_AffineTraversal A_Fold where +instance k ~ A_Fold => JoinKinds A_Fold An_AffineTraversal k where joinKinds r = r -instance JoinKinds A_Fold An_AffineFold A_Fold where +instance k ~ A_Fold => JoinKinds A_Fold An_AffineFold k where joinKinds r = r -instance JoinKinds A_Fold A_Traversal A_Fold where +instance k ~ A_Fold => JoinKinds A_Fold A_Traversal k where joinKinds r = r --- no JoinKinds A_Fold A_Setter +-- no JoinKinds A_Fold A_Setter -- A_Setter ----- -instance JoinKinds A_Setter A_Setter A_Setter where +instance k ~ A_Setter => JoinKinds A_Setter A_Setter k where joinKinds r = r -instance JoinKinds A_Setter An_Iso A_Setter where +instance k ~ A_Setter => JoinKinds A_Setter An_Iso k where joinKinds r = r --- no JoinKinds A_Setter A_ReversedLens --- no JoinKinds A_Setter A_ReversedPrism -instance JoinKinds A_Setter A_Prism A_Setter where +-- no JoinKinds A_Setter A_ReversedLens +-- no JoinKinds A_Setter A_ReversedPrism +instance k ~ A_Setter => JoinKinds A_Setter A_Prism k where joinKinds r = r --- no JoinKinds A_Setter A_Review -instance JoinKinds A_Setter A_Lens A_Setter where +-- no JoinKinds A_Setter A_Review +instance k ~ A_Setter => JoinKinds A_Setter A_Lens k where joinKinds r = r --- no JoinKinds A_Setter A_Getter -instance JoinKinds A_Setter An_AffineTraversal A_Setter where +-- no JoinKinds A_Setter A_Getter +instance k ~ A_Setter => JoinKinds A_Setter An_AffineTraversal k where joinKinds r = r --- no JoinKinds A_Setter An_AffineFold -instance JoinKinds A_Setter A_Traversal A_Setter where +-- no JoinKinds A_Setter An_AffineFold +instance k ~ A_Setter => JoinKinds A_Setter A_Traversal k where joinKinds r = r --- no JoinKinds A_Setter A_Fold +-- no JoinKinds A_Setter A_Fold -- END GENERATED CONTENT diff --git a/src/Optics/Label.hs b/src/Optics/Label.hs --- a/src/Optics/Label.hs +++ b/src/Optics/Label.hs @@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeInType #-} @@ -65,16 +64,20 @@ -- >>> :set -XDuplicateRecordFields -- >>> :set -XOverloadedLabels -- >>> import GHC.Generics (Generic) +-- -- >>> :{ +-- data Pet +-- = Cat { name :: String, age :: Int, lazy :: Bool } +-- | Fish { name :: String, age :: Int, lazy :: Bool } +-- deriving (Show, Generic) +-- :} +-- +-- >>> :{ -- data Human = Human -- { name :: String -- , age :: Integer -- , pets :: [Pet] -- } deriving (Show, Generic) --- data Pet --- = Cat { name :: String, age :: Int, lazy :: Bool } --- | Fish { name :: String, age :: Int, lazy :: Bool } --- deriving (Show, Generic) -- :} -- -- /Note:/ Generic deriving of optics works well on a moderate scale, but for @@ -148,23 +151,20 @@ -- alleviate these issues. We're quite close to having a reasonable solution -- with the following trifecta: -- --- - @@ - introduced in GHC 8.0.1, addresses (1) +-- - @@ - introduced in GHC 8.0.1, addresses (1) -- --- - @@ - accepted GHC proposal, addresses (2) +-- - @@ and @@ - introduced in GHC 9.2.1, addresses (2) -- --- - @@ - accepted GHC proposal, addresses (3) +-- - @@ - restricted version introduced in GHC 9.2.1, addresses (3) -- --- It needs to be noted however that both @NoFieldSelectors@ and --- @RecordDotSyntax@ are not yet implemented, with the latter depending on --- adding @setField@ to @HasField@ --- (), not yet --- merged. +-- It needs to be noted however that @OverloadedRecordUpdate@ is not yet usable +-- out of the box as it requires the user to enable @RebindableSyntax@ and +-- provide their own @HasField@ class. -- -- Is there no hope then for people who would like to work with records in a --- reasonable way without waiting for these extensions? Not necessarily, as by --- following a couple of simple patterns we can get pretty much the same (and --- more) features with labels as optics, just with a slightly more verbose --- syntax. +-- reasonable way without waiting? Not necessarily, as by following a couple of +-- simple patterns we can get pretty much the same (and more) features with +-- labels as optics, just with a slightly more verbose syntax. -- $solution -- @@ -174,7 +174,7 @@ -- name and @#field@ to be an overloaded label that becomes an optic refering to -- this field in the appropriate context. With this approach we get working -- autocompletion and jump-to-definition in editors supporting @ctags@/@etags@ --- in combination with @@, +-- in combination with @@, -- both of which (especially the latter) are very important for developer's -- productivity in real-world code bases. -- @@ -211,9 +211,11 @@ -- makeFieldLabelsNoPrefix ''Movie -- @ -- --- For production software the recommended approach is generation with Template --- Haskell as it scales well in terms of compilation time and provides the best --- performance in general. +-- Generally speaking, both techniques trade blows in terms of compile time and +-- run time resources. Generic optics are a bit slower to compile without +-- optimizations than Template Haskell generated ones and their updating part +-- might be slightly slower for larger data types with GHC < 9.2. On the other +-- hand, generic optics are much more developer friendly. -- -- /Note:/ there exists a similar approach that involves prefixing field names -- (either with the underscore or name of the data type) and generation of @@ -227,8 +229,9 @@ -- -- Prefixless fields (especially ones with common names such as @id@ or @name@) -- leak into global namespace as accessor functions and can generate a lot of --- name clashes. Before @NoFieldSelectors@ is available, this can be alleviated by --- splitting modules defining types into two, namely: +-- name clashes. If you can't use GHC >= 9.2 and take advantage of the +-- @NoFieldSelectors@ language extension, this can be alleviated by splitting +-- modules defining types into two, namely: -- -- (1) A private one that exports full type definitions, i.e. with their fields -- and constructors. diff --git a/src/Optics/Optic.hs b/src/Optics/Optic.hs --- a/src/Optics/Optic.hs +++ b/src/Optics/Optic.hs @@ -13,7 +13,7 @@ -- * the subtyping relation 'Is' with an accompanying 'castOptic' function to -- convert an optic kind; -- --- * the 'Join' operation used to find the optic kind resulting from a +-- * the 'JoinKinds' class used to find the optic kind resulting from a -- composition. -- -- Each optic kind is identified by a "tag type" (such as 'A_Lens'), which is an @@ -36,7 +36,7 @@ -- * Composition -- | The usual operator for composing optics is ('%'), which allows different -- optic kinds to be composed, automatically calculating the resulting optic - -- kind using 'Join'. + -- kind using 'JoinKinds'. -- -- The ('.') function composition operator cannot be used to compose optics, -- because /optics are not functions/. The ('Control.Category..') operator diff --git a/src/Optics/Prism.hs b/src/Optics/Prism.hs --- a/src/Optics/Prism.hs +++ b/src/Optics/Prism.hs @@ -15,18 +15,20 @@ , prism -- * Elimination - -- | A 'Prism' is in particular an 'Optics.AffineFold.AffineFold', a + -- | A 'Prism' is in particular an 'Optics.AffineFold.AffineFold', + -- an 'Optics.AffineTraversal.AffineTraversal', a -- 'Optics.Review.Review' and a 'Optics.Setter.Setter', therefore you can -- specialise types to obtain: -- -- @ - -- 'Optics.AffineFold.preview' :: 'Prism'' s a -> s -> Maybe a - -- 'Optics.Review.review' :: 'Prism'' s a -> a -> s + -- 'Optics.AffineFold.preview' :: 'Prism'' s a -> s -> Maybe a + -- 'Optics.Review.review' :: 'Prism'' s a -> a -> s -- @ -- -- @ - -- 'Optics.Setter.over' :: 'Prism' s t a b -> (a -> b) -> s -> t - -- 'Optics.Setter.set' :: 'Prism' s t a b -> b -> s -> t + -- 'Optics.Setter.over' :: 'Prism' s t a b -> (a -> b) -> s -> t + -- 'Optics.Setter.set' :: 'Prism' s t a b -> b -> s -> t + -- 'Optics.AffineTraversal.matching' :: 'Prism' s t a b -> s -> Either t a -- @ -- -- If you want to 'Optics.AffineFold.preview' a type-modifying 'Prism' that is diff --git a/src/Optics/Setter.hs b/src/Optics/Setter.hs --- a/src/Optics/Setter.hs +++ b/src/Optics/Setter.hs @@ -54,6 +54,8 @@ , set , set' , over' + , rewriteOf + , transformOf -- * Subtyping , A_Setter @@ -152,6 +154,35 @@ mapped :: Functor f => Setter (f a) (f b) a b mapped = Optic mapped__ {-# INLINE mapped #-} + +-- | Rewrite by applying a rule everywhere you can. Ensures that the rule cannot +-- be applied anywhere in the result: +-- +-- @ +-- propRewriteOf l r x = 'all' ('Data.Just.isNothing' '.' r) ('universeOf' l ('rewriteOf' l r x)) +-- @ +-- +-- Usually 'transformOf' is more appropriate, but 'rewriteOf' can give better +-- compositionality. Given two single transformations @f@ and @g@, you can +-- construct @\\a -> f a '<|>' g a@ which performs both rewrites until a fixed +-- point. +-- +-- @since 0.4.1 +rewriteOf :: Is k A_Setter => Optic k is a b a b -> (b -> Maybe a) -> a -> b +rewriteOf o f = go + where + go = transformOf o $ \x -> maybe x go (f x) +{-# INLINE rewriteOf #-} + +-- | Transform every element by recursively applying a given 'Setter' in a +-- bottom-up manner. +-- +-- @since 0.4.1 +transformOf :: Is k A_Setter => Optic k is a b a b -> (b -> b) -> a -> b +transformOf o f = go + where + go = f . over o go +{-# INLINE transformOf #-} -- $setup -- >>> import Optics.Core diff --git a/src/Optics/Traversal.hs b/src/Optics/Traversal.hs --- a/src/Optics/Traversal.hs +++ b/src/Optics/Traversal.hs @@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE EmptyCase #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} -- | @@ -60,6 +59,8 @@ , mapAccumLOf , scanr1Of , scanl1Of + , rewriteMOf + , transformMOf , failover , failover' @@ -246,6 +247,34 @@ step (Just s) a = let r = f a s in (r, Just r) in fst . mapAccumROf o step Nothing {-# INLINE scanr1Of #-} + +-- | Rewrite by applying a monadic rule everywhere you recursing with a +-- user-specified 'Traversal'. +-- +-- Ensures that the rule cannot be applied anywhere in the result. +-- +-- @since 0.4.1 +rewriteMOf + :: (Is k A_Traversal, Monad m) + => Optic k is a b a b + -> (b -> m (Maybe a)) -> a -> m b +rewriteMOf l f = go + where + go = transformMOf l (\x -> f x >>= maybe (return x) go) +{-# INLINE rewriteMOf #-} + +-- | Transform every element in a tree using a user supplied 'Traversal' in a +-- bottom-up manner with a monadic effect. +-- +-- @since 0.4.1 +transformMOf + :: (Is k A_Traversal, Monad m) + => Optic k is a b a b + -> (b -> m b) -> a -> m b +transformMOf l f = go + where + go t = traverseOf l go t >>= f +{-# INLINE transformMOf #-} -- | Try to map a function over this 'Traversal', returning Nothing if the -- traversal has no targets.