optics-core 0.4.1.1 → 0.4.2

raw patch · 32 files changed

+423/−244 lines, 32 filesdep ~containersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• optics-core.cabal +16/−5
• src/Data/IntMap/Optics.hs +5/−4
• src/Data/IntSet/Optics.hs +4/−3
• src/Data/Map/Optics.hs +5/−4
• src/Data/Sequence/Optics.hs +5/−3
• src/Data/Set/Optics.hs +4/−3
• src/Data/Tree/Optics.hs +4/−3
• src/Data/Tuple/Optics.hs +0/−1
• src/Optics/AffineFold.hs +4/−3
• src/Optics/AffineTraversal.hs +33/−3
• src/Optics/At/Core.hs +5/−4
• src/Optics/Each/Core.hs +21/−7
• src/Optics/Fold.hs +6/−5
• src/Optics/Generic.hs +14/−6
• src/Optics/Indexed/Core.hs +0/−1
• src/Optics/Internal/Generic.hs +46/−47
• src/Optics/Internal/Generic/TypeLevel.hs +30/−32
• src/Optics/Internal/Indexed.hs +21/−23
• src/Optics/Internal/Magic.hs +0/−2
• src/Optics/Internal/Optic.hs +0/−2
• src/Optics/Internal/Optic/Subtyping.hs +4/−6
• src/Optics/Internal/Optic/TypeLevel.hs +36/−39
• src/Optics/Internal/Optic/Types.hs +0/−2
• src/Optics/IxAffineTraversal.hs +33/−0
• src/Optics/IxFold.hs +0/−1
• src/Optics/IxTraversal.hs +35/−5
• src/Optics/Label.hs +29/−18
• src/Optics/Mapping.hs +0/−1
• src/Optics/Re.hs +1/−2
• src/Optics/ReadOnly.hs +0/−2
• src/Optics/Traversal.hs +52/−7

@@ -1,3 +1,13 @@+# optics-core-0.4.2 (2025-02-10)+* Rename `PathTree` data constructor to `PathNode`, to avoid pun with type+  constructor.+* Add support for using `gafield` as a label in GHC >= 9.6 using `#"?field"`+  syntax.+* Add `unsafePartsOf` to `Optics.Traversal`.+* Add `failing`-like combinators for traversals: `adisjoin`+  (`Optics.AffineTraversal`), `iadisjoin` (`Optics.IxAffineTraversal`),+  `idisjoin` (`Optics.IxTraversal`) and `disjoin` (`Optics.Traversal`).+ # optics-core-0.4.1.1 (2023-06-22) * Add INLINE pragmas to small functions that really should inline 

@@ -1,13 +1,15 @@-cabal-version: 2.2+cabal-version: 3.0 name:          optics-core-version:       0.4.1.1+version:       0.4.2 license:       BSD-3-Clause license-file:  LICENSE build-type:    Simple 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.7-                || ==9.0.2 || ==9.2.8 || ==9.4.5 || ==9.6.2, 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.8+                      , 9.4.8, 9.6.7, 9.8.4, 9.10.3, 9.12.2, 9.14.1+                      }+               GHCJS == { 8.4 } synopsis:      Optics as an abstract interface: core definitions category:      Data, Optics, Lenses description:@@ -35,11 +37,17 @@  common language     ghc-options:        -Wall -Wcompat+    if impl(ghc <9.4)+      ghc-options:      -Wno-unticked-promoted-constructors      default-language:   Haskell2010 +    if impl(ghc < 8.6)+      default-extensions: TypeInType+     default-extensions: BangPatterns                         ConstraintKinds+                        DataKinds                         DefaultSignatures                         DeriveFoldable                         DeriveFunctor@@ -56,6 +64,7 @@                         LambdaCase                         OverloadedLabels                         PatternSynonyms+                        PolyKinds                         RankNTypes                         ScopedTypeVariables                         TupleSections@@ -73,7 +82,7 @@    build-depends: base                   >= 4.10       && <5                , array                  >= 0.5.2.0    && <0.6-               , containers             >= 0.5.10.2   && <0.7+               , containers             >= 0.5.10.2   && <0.9                , indexed-profunctors    >= 0.1        && <0.2                , transformers           >= 0.5        && <0.7                , indexed-traversable    >= 0.1        && <0.2@@ -154,3 +163,5 @@                    Optics.Internal.Setter                    Optics.Internal.Traversal                    Optics.Internal.Utils++  x-docspec-options: -XTypeApplications -XTypeOperators -XFlexibleContexts -XStandaloneDeriving -XDeriveGeneric -XDataKinds -XOverloadedLabels -XTupleSections

@@ -50,6 +50,11 @@ import Optics.IxFold import Optics.Optic +-- $setup+-- >>> import qualified Data.IntMap as IntMap+-- >>> import Data.Monoid (Sum (..))+-- >>> import Optics.Core+ -- | Construct a map from an 'IxFold'. -- -- The construction is left-biased (see 'IntMap.union'), i.e. the first occurrences of@@ -132,7 +137,3 @@     Nothing      -> point s     Just (k', v) -> f k' v <&> \v' -> IntMap.insert k' v' s {-# INLINE ge #-}---- $setup--- >>> import Data.Monoid--- >>> import Optics.Core

@@ -17,6 +17,10 @@ import Optics.Optic import Optics.Setter +-- $setup+-- >>> import qualified Data.IntSet as IntSet+-- >>> import Optics.Core+ -- | IntSet isn't Foldable, but this 'Fold' can be used to access the members of -- an 'IntSet'. --@@ -49,6 +53,3 @@ setOf :: Is k A_Fold => Optic' k is s Int -> s -> IntSet setOf l = foldMapOf l IntSet.singleton {-# INLINE setOf #-}---- $setup--- >>> import Optics.Core

@@ -57,6 +57,11 @@ import Optics.IxFold import Optics.Optic +-- $setup+-- >>> import qualified Data.Map as Map+-- >>> import Data.Monoid (Sum (..))+-- >>> import Optics.Core+ -- | Construct a map from an 'IxFold'. -- -- The construction is left-biased (see 'Map.union'), i.e. the first@@ -139,7 +144,3 @@     Nothing      -> point s     Just (k', v) -> f k' v <&> \v' -> Map.insert k' v' s {-# INLINE ge #-}---- $setup--- >>> import Data.Monoid--- >>> import Optics.Core

@@ -20,6 +20,11 @@ import Optics.Optic import Optics.Traversal +-- $setup+-- >>> import Data.Sequence (ViewL (..), ViewR (..))+-- >>> import qualified Data.Sequence as Seq+-- >>> import Optics.Core+ -- * Sequence isomorphisms  -- | A 'Seq' is isomorphic to a 'ViewL'@@ -136,6 +141,3 @@ seqOf :: Is k A_Fold => Optic' k is s a -> s -> Seq a seqOf l = foldMapOf l Seq.singleton {-# INLINE seqOf #-}---- $setup--- >>> import Optics.Core

@@ -16,6 +16,10 @@ import Optics.Optic import Optics.Setter +-- $setup+-- >>> import qualified Data.Set as Set+-- >>> import Optics.Core+ -- | This 'Setter' can be used to change the type of a 'Set' by mapping the -- elements to new values. --@@ -39,6 +43,3 @@ setOf :: (Is k A_Fold, Ord a) => Optic' k is s a -> s -> Set a setOf l = foldMapOf l Set.singleton {-# INLINE setOf #-}---- $setup--- >>> import Optics.Core

@@ -13,6 +13,10 @@  import Optics.Lens +-- $setup+-- >>> import Data.Tree (Tree (..))+-- >>> import Optics.Core+ -- | A 'Lens' that focuses on the root of a 'Tree'. -- -- >>> view root $ Node 42 []@@ -27,6 +31,3 @@ branches :: Lens' (Tree a) [Tree a] branches = lensVL $ \f (Node a as) -> Node a <$> f as {-# INLINE branches #-}---- $setup--- >>> import Optics.Core

@@ -1,4 +1,3 @@-{-# LANGUAGE DataKinds #-} -- | -- Module: Data.Tuple.Optics -- Description: 'Lens'es for tuple types.

@@ -60,6 +60,10 @@ import Optics.Internal.Bi import Optics.Internal.Optic +-- $setup+-- >>> import Data.Maybe (listToMaybe)+-- >>> import Optics.Core+ -- | Type synonym for an affine fold. type AffineFold s a = Optic' An_AffineFold NoIx s a @@ -152,6 +156,3 @@ isn't :: Is k An_AffineFold => Optic' k is s a -> s -> Bool isn't k s = isNothing (preview k s) {-# INLINE isn't #-}---- $setup--- >>> import Optics.Core

@@ -48,6 +48,12 @@   -- * Additional elimination forms   , withAffineTraversal +  -- * Monoid structure+  -- | 'AffineTraversal' admits a monoid structure where 'adisjoin' returns the+  -- result from the second affine traversal only if the first does not return a+  -- result. The identity element is 'ignored' (which traverses no elements).+  , adisjoin+   -- * Subtyping   , An_AffineTraversal   -- | <<diagrams/AffineTraversal.png AffineTraversal in the optics hierarchy>>@@ -63,7 +69,11 @@ import Data.Profunctor.Indexed  import Optics.Internal.Optic+import Optics.Internal.Utils +-- $setup+-- >>> import Optics.Core+ -- | Type synonym for a type-modifying affine traversal. type AffineTraversal s t a b = Optic An_AffineTraversal NoIx s t a b @@ -165,6 +175,29 @@ matching o = withAffineTraversal o $ \match _ -> match {-# INLINE matching #-} +-- | Try the first 'AffineTraversal'. If it does not return an entry, try the+-- second one.+--+-- >>> over (ix 2 `adisjoin` ix 1) (*5) [1,2,3]+-- [1,2,15]+-- >>> over (ix 2 `adisjoin` ix 1) (*5) [1,2]+-- [1,10]+--+-- @since 0.4.3+--+adisjoin+  :: (Is k An_AffineTraversal, Is l An_AffineTraversal)+  => Optic k is s t a b+  -> Optic l js s t a b+  -> AffineTraversal s t a b+adisjoin a b = atraversalVL $ \point f s ->+  let OrT visited fu = atraverseOf a (OrT False . point) (wrapOrT . f) s+  in if visited+     then fu+     else atraverseOf b point f s+infixl 3 `adisjoin` -- Same as (<|>)+{-# INLINE adisjoin #-}+ -- | Filter result(s) of a traversal that don't satisfy a predicate. -- -- /Note:/ This is /not/ a legal 'Optics.Traversal.Traversal', unless you are@@ -186,6 +219,3 @@ unsafeFiltered :: (a -> Bool) -> AffineTraversal' a a unsafeFiltered p = atraversalVL (\point f a -> if p a then f a else point a) {-# INLINE unsafeFiltered #-}---- $setup--- >>> import Optics.Core

@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE TypeInType #-} -- | -- Module: Optics.At.Core -- Description: Optics for 'Map' and 'Set'-like containers.@@ -69,6 +68,11 @@ import Optics.Optic import Optics.Setter +-- $setup+-- >>> import Optics.Core+-- >>> import qualified Data.Map as Map+-- >>> import qualified Data.IntSet as IntSet+ -- | Type family that takes a key-value container type and returns the type of -- keys (indices) into the container, for example @'Index' ('Map' k a) ~ k@. -- This is shared by 'Ixed', 'At' and 'Contains'.@@ -483,6 +487,3 @@            go (a:as) i = (a:) <$> (go as $! i - 1)        in go xs0 k {-# INLINE ixListVL #-}---- $setup--- >>> import Optics.Core

@@ -176,25 +176,39 @@   {-# INLINE[1] each #-}  -- | @'each' :: 'IxTraversal' 'Int' [a] [b] a b@-instance Each Int [a] [b] a b+instance Each Int [a] [b] a b where+  each = itraversed+  {-# INLINE[1] each #-}  -- | @'each' :: 'IxTraversal' 'Int' (NonEmpty a) (NonEmpty b) a b@-instance Each Int (NonEmpty a) (NonEmpty b) a b+instance Each Int (NonEmpty a) (NonEmpty b) a b where+  each = itraversed+  {-# INLINE[1] each #-}  -- | @'each' :: 'IxTraversal' () ('Identity' a) ('Identity' b) a b@-instance Each () (Identity a) (Identity b) a b+instance Each () (Identity a) (Identity b) a b where+  each = itraversed+  {-# INLINE[1] each #-}  -- | @'each' :: 'IxTraversal' () ('Maybe' a) ('Maybe' b) a b@-instance Each () (Maybe a) (Maybe b) a b+instance Each () (Maybe a) (Maybe b) a b where+  each = itraversed+  {-# INLINE[1] each #-}  -- | @'each' :: 'IxTraversal' 'Int' ('Seq' a) ('Seq' b) a b@-instance Each Int (Seq a) (Seq b) a b+instance Each Int (Seq a) (Seq b) a b where+  each = itraversed+  {-# INLINE[1] each #-}  -- | @'each' :: 'IxTraversal' [Int] ('Tree' a) ('Tree' b) a b@-instance Each [Int] (Tree a) (Tree b) a b+instance Each [Int] (Tree a) (Tree b) a b where+  each = itraversed+  {-# INLINE[1] each #-}  -- | @'each' :: 'Ix' i => 'IxTraversal' i ('Array' i a) ('Array' i b) a b@-instance (Ix i, i ~ j) => Each i (Array i a) (Array j b) a b+instance (Ix i, i ~ j) => Each i (Array i a) (Array j b) a b where+  each = itraversed+  {-# INLINE[1] each #-}  -- $setup -- >>> import Optics.Core

@@ -106,7 +106,7 @@ import Control.Applicative.Backwards import Control.Monad import Data.Foldable-import Data.Function+import Data.Function (fix) import Data.Monoid  import Data.Profunctor.Indexed@@ -117,6 +117,10 @@ import Optics.Internal.Optic import Optics.Internal.Utils +-- $setup+-- >>> import Optics.Core+-- >>> import Data.Function (on)+ -- | Type synonym for a fold. type Fold s a = Optic' A_Fold NoIx s a @@ -218,7 +222,7 @@ -- This can be useful to lift operations from @Data.List@ and elsewhere into a -- 'Fold'. ----- >>> toListOf (folding tail) [1,2,3,4]+-- >>> toListOf (folding (drop 1)) [1,2,3,4] -- [2,3,4] folding :: Foldable f => (s -> f a) -> Fold s a folding f = Optic (contrafirst f . foldVL__ traverse_)@@ -707,6 +711,3 @@   where     go a = f a (go <$> toListOf o a) {-# INLINE paraOf #-}---- $setup--- >>> import Optics.Core

@@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} -- | -- Module: Optics.Generic@@ -53,6 +52,11 @@ import Optics.Prism import Optics.Traversal +-- $setup+-- >>> import GHC.Generics (Generic)+-- >>> import Optics.Core+-- >>> newtype NoG = NoG { fromNoG :: Char }+ -- | Hidden type for preventing GHC from solving constraints too early. data Void0 @@ -176,6 +180,14 @@ -- ...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@@ -361,7 +373,7 @@   gplate :: Traversal' s a  instance GPlateContext a s => GPlate a s where-  gplate = traversalVL (gplateInner @'True)+  gplate = traversalVL (gplateInner @True)   {-# INLINE gplate #-}  -- | Hide implementation from haddock.@@ -377,7 +389,3 @@ instance GPlate Void0 a where   gplate = error "unreachable" --- $setup--- >>> :set -XDataKinds -XDeriveGeneric -XStandaloneDeriving -XOverloadedLabels--- >>> import Optics.Core--- >>> newtype NoG = NoG { fromNoG :: Char }

@@ -1,4 +1,3 @@-{-# LANGUAGE DataKinds #-} -- | -- Module: Optics.Indexed.Core -- Description: Core definitions for indexed optics.

@@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} @@ -130,7 +129,7 @@ instance   ( GSetFieldSum path1 g1 h1 b   , GSetFieldSum path2 g2 h2 b-  ) => GSetFieldSum ('PathTree path1 path2) (g1 :+: g2) (h1 :+: h2) b where+  ) => GSetFieldSum (PathNode path1 path2) (g1 :+: g2) (h1 :+: h2) b where   gsetFieldSum (L1 x) = L1 . gsetFieldSum @path1 x   gsetFieldSum (R1 y) = R1 . gsetFieldSum @path2 y   {-# INLINE gsetFieldSum #-}@@ -139,15 +138,15 @@   ( path ~ GSetFieldPath con epath   , When (IsLeft epath) (HideReps g h)   , GSetFieldProd path g h b-  ) => GSetFieldSum ('PathLeaf epath) (M1 C ('MetaCons con fix hs) g)-                                      (M1 C ('MetaCons con fix hs) h) b where+  ) => GSetFieldSum (PathLeaf epath) (M1 C (MetaCons con fix hs) g)+                                      (M1 C (MetaCons con fix hs) h) b where   gsetFieldSum (M1 x) = M1 . gsetFieldProd @path x  type family GSetFieldPath (con :: Symbol) (e :: Either Symbol [Path]) :: [Path] where-  GSetFieldPath _   ('Right path) = path-  GSetFieldPath con ('Left name)  = TypeError-    ('Text "Data constructor " ':<>: QuoteSymbol con ':<>:-     'Text " doesn't have a field named " ':<>: QuoteSymbol name)+  GSetFieldPath _   (Right path) = path+  GSetFieldPath con (Left name)  = TypeError+    (Text "Data constructor " :<>: QuoteSymbol con :<>:+     Text " doesn't have a field named " :<>: QuoteSymbol name)  class GSetFieldProd (path :: [Path]) g h b | path h -> b                                            , path g b -> h where@@ -156,27 +155,27 @@ -- fast path left instance {-# OVERLAPPING #-}   ( GSetFieldProd path g1 h1 b-  ) => GSetFieldProd ('PathLeft : path) (g1 :*: g2) (h1 :*: g2) b where+  ) => GSetFieldProd (PathLeft : path) (g1 :*: g2) (h1 :*: g2) b where   gsetFieldProd (x :*: y) = (:*: y) . gsetFieldProd @path x  -- slow path left instance   ( GSetFieldProd path g1 h1 b   , g2 ~ h2-  ) => GSetFieldProd ('PathLeft : path) (g1 :*: g2) (h1 :*: h2) b where+  ) => GSetFieldProd (PathLeft : path) (g1 :*: g2) (h1 :*: h2) b where   gsetFieldProd (x :*: y) = (:*: y) . gsetFieldProd @path x  -- fast path right instance {-# OVERLAPPING #-}   ( GSetFieldProd path g2 h2 b-  ) => GSetFieldProd ('PathRight : path) (g1 :*: g2) (g1 :*: h2) b where+  ) => GSetFieldProd (PathRight : path) (g1 :*: g2) (g1 :*: h2) b where   gsetFieldProd (x :*: y) = (x :*:) . gsetFieldProd @path y  -- slow path right instance   ( GSetFieldProd path g2 h2 b   , g1 ~ h1-  ) => GSetFieldProd ('PathRight : path) (g1 :*: g2) (h1 :*: h2) b where+  ) => GSetFieldProd (PathRight : path) (g1 :*: g2) (h1 :*: h2) b where   gsetFieldProd (x :*: y) = (x :*:) . gsetFieldProd @path y  instance@@ -203,10 +202,10 @@   , HasField name s a -- require the field to be in scope   , Unless (AnyHasPath path)     (TypeError-      ('Text "Type " ':<>: QuoteType s ':<>:-       'Text " doesn't have a field named " ':<>: QuoteSymbol name))+      (Text "Type " :<>: QuoteType s :<>:+       Text " doesn't have a field named " :<>: QuoteSymbol name))   , GAffineFieldSum path (Rep s) (Rep t) a b-  ) => GAffineFieldImpl 'True name s t a b where+  ) => GAffineFieldImpl True name s t a b where   gafieldImpl = withAffineTraversal     (atraversalVL (\point f s -> to <$> gafieldSum @path point f (from s)))     (\match update -> atraversalVL $ \point f s ->@@ -226,14 +225,14 @@ instance   ( GAffineFieldSum path1 g1 h1 a b   , GAffineFieldSum path2 g2 h2 a b-  ) => GAffineFieldSum ('PathTree path1 path2) (g1 :+: g2) (h1 :+: h2) a b where+  ) => GAffineFieldSum (PathNode path1 path2) (g1 :+: g2) (h1 :+: h2) a b where   gafieldSum point f (L1 x) = L1 <$> gafieldSum @path1 point f x   gafieldSum point f (R1 y) = R1 <$> gafieldSum @path2 point f y   {-# INLINE gafieldSum #-}  instance   ( GAffineFieldMaybe epath g h a b-  ) => GAffineFieldSum ('PathLeaf epath) (M1 C m g) (M1 C m h) a b where+  ) => GAffineFieldSum (PathLeaf epath) (M1 C m g) (M1 C m h) a b where   gafieldSum point f (M1 x) = M1 <$> gafieldMaybe @epath point f x  class GAffineFieldMaybe (epath :: Either Symbol [Path]) g h a b where@@ -241,12 +240,12 @@  instance   ( g ~ h-  ) => GAffineFieldMaybe ('Left name) g h a b where+  ) => GAffineFieldMaybe (Left name) g h a b where   gafieldMaybe point _ g = point g  instance   ( GFieldProd prodPath g h a b-  ) => GAffineFieldMaybe ('Right prodPath) g h a b where+  ) => GAffineFieldMaybe (Right prodPath) g h a b where   gafieldMaybe _ f g = gfieldProd @prodPath f g  ----------------------------------------@@ -260,27 +259,27 @@ -- fast path left instance {-# OVERLAPPING #-}   ( GFieldProd path g1 h1 a b-  ) => GFieldProd ('PathLeft : path) (g1 :*: g2) (h1 :*: g2) a b where+  ) => GFieldProd (PathLeft : path) (g1 :*: g2) (h1 :*: g2) a b where   gfieldProd f (x :*: y) = (:*: y) <$> gfieldProd @path f x  -- slow path left instance   ( GFieldProd path g1 h1 a b   , g2 ~ h2-  ) => GFieldProd ('PathLeft : path) (g1 :*: g2) (h1 :*: h2) a b where+  ) => GFieldProd (PathLeft : path) (g1 :*: g2) (h1 :*: h2) a b where   gfieldProd f (x :*: y) = (:*: y) <$> gfieldProd @path f x  -- fast path right instance {-# OVERLAPPING #-}   ( GFieldProd path g2 h2 a b-  ) => GFieldProd ('PathRight : path) (g1 :*: g2) (g1 :*: h2) a b where+  ) => GFieldProd (PathRight : path) (g1 :*: g2) (g1 :*: h2) a b where   gfieldProd f (x :*: y) = (x :*:) <$> gfieldProd @path f y  -- slow path right instance   ( GFieldProd path g2 h2 a b   , g1 ~ h1-  ) => GFieldProd ('PathRight : path) (g1 :*: g2) (h1 :*: h2) a b where+  ) => GFieldProd (PathRight : path) (g1 :*: g2) (h1 :*: h2) a b where   gfieldProd f (x :*: y) = (x :*:) <$> gfieldProd @path f y  instance@@ -305,11 +304,11 @@   ( Generic s   , Generic t   , path ~ If (n <=? 0)-              (TypeError ('Text "There is no 0th position"))+              (TypeError (Text "There is no 0th position"))               (GetPositionPaths s n (Rep s))   , When (n <=? 0) (HideReps (Rep s) (Rep t))   , GPositionSum path (Rep s) (Rep t) a b-  ) => GPositionImpl 'True n s t a b where+  ) => GPositionImpl True n s t a b where   gpositionImpl = withLens     (lensVL (\f s -> to <$> gpositionSum @path f (from s)))     (\get set -> lensVL $ \f s -> set s <$> f (get s))@@ -331,7 +330,7 @@ instance   ( GPositionSum path1 g1 h1 a b   , GPositionSum path2 g2 h2 a b-  ) => GPositionSum ('PathTree path1 path2) (g1 :+: g2) (h1 :+: h2) a b where+  ) => GPositionSum (PathNode path1 path2) (g1 :+: g2) (h1 :+: h2) a b where   gpositionSum f (L1 x) = L1 <$> gpositionSum @path1 f x   gpositionSum f (R1 y) = R1 <$> gpositionSum @path2 f y   {-# INLINE gpositionSum #-}@@ -340,21 +339,21 @@   ( path ~ GPositionPath con epath   , When (IsLeft epath) (HideReps g h)   , GFieldProd path g h a b-  ) => GPositionSum ('PathLeaf epath) (M1 C ('MetaCons con fix hs) g)-                                      (M1 C ('MetaCons con fix hs) h) a b where+  ) => GPositionSum (PathLeaf epath) (M1 C (MetaCons con fix hs) g)+                                      (M1 C (MetaCons con fix hs) h) a b where   gpositionSum f (M1 x) = M1 <$> gfieldProd @path f x  type family GPositionPath con (e :: Either (Nat, Nat) [Path]) :: [Path] where-  GPositionPath _   ('Right path)   = path-  GPositionPath con ('Left '(n, k)) = TypeError-    ('Text "Data constructor " ':<>: QuoteSymbol con ':<>:-     'Text " has " ':<>: ShowFieldNumber k ':<>: 'Text ", " ':<>:-     ToOrdinal n ':<>: 'Text " requested")+  GPositionPath _   (Right path)   = path+  GPositionPath con (Left '(n, k)) = TypeError+    (Text "Data constructor " :<>: QuoteSymbol con :<>:+     Text " has " :<>: ShowFieldNumber k :<>: Text ", " :<>:+     ToOrdinal n :<>: Text " requested")  type family ShowFieldNumber (k :: Nat) :: ErrorMessage where-  ShowFieldNumber 0 = 'Text "no fields"-  ShowFieldNumber 1 = 'Text "1 field"-  ShowFieldNumber k = 'ShowType k ':<>: 'Text " fields"+  ShowFieldNumber 0 = Text "no fields"+  ShowFieldNumber 1 = Text "1 field"+  ShowFieldNumber k = ShowType k :<>: Text " fields"  ---------------------------------------- -- Constructor@@ -374,12 +373,12 @@   , epath ~ GetNamePath name (Rep s) '[]   , path ~ FromRight     (TypeError-      ('Text "Type " ':<>: QuoteType s ':<>:-       'Text " doesn't have a constructor named " ':<>: QuoteSymbol name))+      (Text "Type " :<>: QuoteType s :<>:+       Text " doesn't have a constructor named " :<>: QuoteSymbol name))     epath   , When (IsLeft epath) (HideReps (Rep s) (Rep t))   , GConstructorSum path (Rep s) (Rep t) a b-  ) => GConstructorImpl 'True name s t a b where+  ) => GConstructorImpl True name s t a b where   gconstructorImpl = withPrism (generic % gconstructorSum @path) prism   {-# INLINE gconstructorImpl #-} @@ -399,27 +398,27 @@ -- fast path left instance {-# OVERLAPPING #-}   ( GConstructorSum path g1 h1 a b-  ) => GConstructorSum ('PathLeft : path) (g1 :+: g2) (h1 :+: g2) a b where+  ) => GConstructorSum (PathLeft : path) (g1 :+: g2) (h1 :+: g2) a b where   gconstructorSum = _L1 % gconstructorSum @path  -- slow path left instance   ( GConstructorSum path g1 h1 a b   , g2 ~ h2-  ) => GConstructorSum ('PathLeft : path) (g1 :+: g2) (h1 :+: h2) a b where+  ) => GConstructorSum (PathLeft : path) (g1 :+: g2) (h1 :+: h2) a b where   gconstructorSum = _L1 % gconstructorSum @path  -- fast path right instance {-# OVERLAPPING #-}   ( GConstructorSum path g2 h2 a b-  ) => GConstructorSum ('PathRight : path) (g1 :+: g2) (g1 :+: h2) a b where+  ) => GConstructorSum (PathRight : path) (g1 :+: g2) (g1 :+: h2) a b where   gconstructorSum = _R1 % gconstructorSum @path  -- slow path right instance   ( GConstructorSum path g2 h2 a b   , g1 ~ h1-  ) => GConstructorSum ('PathRight : path) (g1 :+: g2) (h1 :+: h2) a b where+  ) => GConstructorSum (PathRight : path) (g1 :+: g2) (h1 :+: h2) a b where   gconstructorSum = _R1 % gconstructorSum @path  instance@@ -439,9 +438,9 @@ instance {-# OVERLAPPABLE #-}   ( Dysfunctional () () g h a b   , TypeError-    ('Text "Generic based access supports constructors" ':$$:-     'Text "containing up to 5 fields. Please generate" ':$$:-     'Text "PrismS with Template Haskell if you need more.")+    (Text "Generic based access supports constructors" :$$:+     Text "containing up to 5 fields. Please generate" :$$:+     Text "PrismS with Template Haskell if you need more.")   ) => GConstructorTuple g h a b where   gconstructorTuple = error "unreachable" @@ -545,7 +544,7 @@ class GPlateInner (repDefined :: Bool) s a where   gplateInner :: TraversalVL' s a -instance (Generic s, GPlateImpl (Rep s) a) => GPlateInner 'True s a where+instance (Generic s, GPlateImpl (Rep s) a) => GPlateInner True s a where   gplateInner f = fmap to . gplateImpl f . from  instance {-# INCOHERENT #-} GPlateInner repNotDefined s a where

@@ -1,5 +1,3 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} @@ -33,7 +31,7 @@ -- a data type. Computed up front by generic optics for early error reporting -- and efficient data traversal. data PathTree e-  = PathTree (PathTree e) (PathTree e)+  = PathNode (PathTree e) (PathTree e)   | PathLeaf (Either e [Path])  data Path = PathLeft | PathRight@@ -44,12 +42,12 @@ -- | Compute paths to a field with a specific name. type family GetFieldPaths s (name :: Symbol) g :: PathTree Symbol where   GetFieldPaths s name (M1 D _ g)  = GetFieldPaths s name g-  GetFieldPaths s name (g1 :+: g2) = 'PathTree (GetFieldPaths s name g1)-                                               (GetFieldPaths s name g2)-  GetFieldPaths s name (M1 C _ g)  = 'PathLeaf (GetNamePath name g '[])+  GetFieldPaths s name (g1 :+: g2) = PathNode (GetFieldPaths s name g1)+                                              (GetFieldPaths s name g2)+  GetFieldPaths s name (M1 C _ g)  = PathLeaf (GetNamePath name g '[]) -  GetFieldPaths s name V1 = TypeError ('Text "Type " ':<>: QuoteType s ':<>:-                                       'Text " has no data constructors")+  GetFieldPaths s name V1 = TypeError (Text "Type " :<>: QuoteType s :<>:+                                       Text " has no data constructors")  -- | Compute path to a constructor in a sum or a field in a product with a -- specific name.@@ -57,16 +55,16 @@   GetNamePath name (M1 D _ g) acc = GetNamePath name g acc    -- Find path to a constructor in a sum type.-  GetNamePath name (M1 C ('MetaCons name _ _) _) acc = 'Right (Reverse acc '[])-  GetNamePath name (g1 :+: g2) acc = FirstRight (GetNamePath name g1 ('PathLeft  : acc))-                                                (GetNamePath name g2 ('PathRight : acc))+  GetNamePath name (M1 C (MetaCons name _ _) _) acc = Right (Reverse acc '[])+  GetNamePath name (g1 :+: g2) acc = FirstRight (GetNamePath name g1 (PathLeft  : acc))+                                                (GetNamePath name g2 (PathRight : acc))    -- Find path to a field in a product type.-  GetNamePath name (M1 S ('MetaSel ('Just name) _ _ _) _) acc = 'Right (Reverse acc '[])-  GetNamePath name (g1 :*: g2) acc = FirstRight (GetNamePath name g1 ('PathLeft  : acc))-                                                (GetNamePath name g2 ('PathRight : acc))+  GetNamePath name (M1 S (MetaSel (Just name) _ _ _) _) acc = Right (Reverse acc '[])+  GetNamePath name (g1 :*: g2) acc = FirstRight (GetNamePath name g1 (PathLeft  : acc))+                                                (GetNamePath name g2 (PathRight : acc)) -  GetNamePath name _ _ = 'Left name+  GetNamePath name _ _ = Left name  ---------------------------------------- -- Paths to a position@@ -74,12 +72,12 @@ -- | Compute paths to a field at a specific position. type family GetPositionPaths s (pos :: Nat) g :: PathTree (Nat, Nat) where   GetPositionPaths s pos (M1 D _ g)  = GetPositionPaths s pos g-  GetPositionPaths s pos (g1 :+: g2) = 'PathTree (GetPositionPaths s pos g1)-                                                 (GetPositionPaths s pos g2)-  GetPositionPaths s pos (M1 C _ g)  = 'PathLeaf (GetPositionPath pos g 0 '[])+  GetPositionPaths s pos (g1 :+: g2) = PathNode (GetPositionPaths s pos g1)+                                                (GetPositionPaths s pos g2)+  GetPositionPaths s pos (M1 C _ g)  = PathLeaf (GetPositionPath pos g 0 '[]) -  GetPositionPaths s pos V1 = TypeError ('Text "Type " ':<>: QuoteType s ':<>:-                                         'Text " has no data constructors")+  GetPositionPaths s pos V1 = TypeError (Text "Type " :<>: QuoteType s :<>:+                                         Text " has no data constructors")  -- | Compute path to a constructor in a sum or a field in a product at a -- specific position.@@ -89,25 +87,25 @@    -- Find field at a position in a sum type.   GetPositionPath pos (M1 C _ _) k acc =-    If (pos == k + 1) ('Right (Reverse acc '[])) ('Left '(pos, k + 1))+    If (pos == k + 1) (Right (Reverse acc '[])) (Left '(pos, k + 1))   GetPositionPath pos (g1 :+: g2) k acc =-    ContinueWhenLeft (GetPositionPath pos g1 k ('PathLeft : acc)) g2 acc+    ContinueWhenLeft (GetPositionPath pos g1 k (PathLeft : acc)) g2 acc    -- Find field at a position in a product type.   GetPositionPath pos (M1 S _ _) k acc =-    If (pos == k + 1) ('Right (Reverse acc '[])) ('Left '(pos, k + 1))+    If (pos == k + 1) (Right (Reverse acc '[])) (Left '(pos, k + 1))   GetPositionPath pos (g1 :*: g2) k acc =-    ContinueWhenLeft (GetPositionPath pos g1 k ('PathLeft : acc)) g2 acc+    ContinueWhenLeft (GetPositionPath pos g1 k (PathLeft : acc)) g2 acc    -- The second element is the number of fields in the data constructor.-  GetPositionPath pos _ k _ = 'Left '(pos, k)+  GetPositionPath pos _ k _ = Left '(pos, k)  -- | If the left branch had the position we're looking for, return it. Otherwise -- continue with the right branch. type family ContinueWhenLeft (r :: Either (Nat, Nat) [Path]) g acc   :: Either (Nat, Nat) [Path] where-  ContinueWhenLeft ('Right path) _ _ = 'Right path-  ContinueWhenLeft ('Left '(pos, k)) g acc = GetPositionPath pos g k ('PathRight : acc)+  ContinueWhenLeft (Right path) _ _ = Right path+  ContinueWhenLeft (Left '(pos, k)) g acc = GetPositionPath pos g k (PathRight : acc)  ---------------------------------------- -- Misc@@ -121,11 +119,11 @@  -- | Check if any leaf in the tree has a '[Path]'. type family AnyHasPath (path :: PathTree e) :: Bool where-  AnyHasPath ('PathTree path1 path2) = AnyHasPath path1 || AnyHasPath path2-  AnyHasPath ('PathLeaf ('Right _))  = 'True-  AnyHasPath ('PathLeaf ('Left _ ))  = 'False+  AnyHasPath (PathNode path1 path2) = AnyHasPath path1 || AnyHasPath path2+  AnyHasPath (PathLeaf (Right _))  = True+  AnyHasPath (PathLeaf (Left _ ))  = False  type family NoGenericError t where   NoGenericError t = TypeError-    ('Text "Type " ':<>: QuoteType t ':<>:-     'Text " doesn't have a Generic instance")+    (Text "Type " :<>: QuoteType t :<>:+     Text " doesn't have a Generic instance")

@@ -1,5 +1,3 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeInType #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} @@ -20,9 +18,9 @@  instance   ( TypeError-    ('Text "‘" ':<>: 'Text f ':<>: 'Text "’ accepts only optics with no indices")-  , (x ': xs) ~ NoIx-  ) => AcceptsEmptyIndices f (x ': xs)+    (Text "‘" :<>: Text f :<>: Text "’ accepts only optics with no indices")+  , (x : xs) ~ NoIx+  ) => AcceptsEmptyIndices f (x : xs)  instance AcceptsEmptyIndices f '[] @@ -32,10 +30,10 @@  instance   ( TypeError-    ('Text "Indexed optic is expected")+    (Text "Indexed optic is expected")   ) => NonEmptyIndices '[] -instance NonEmptyIndices (x ': xs)+instance NonEmptyIndices (x : xs)  -- | Generate sensible error messages in case a user tries to pass either an -- unindexed optic or indexed optic with unflattened indices where indexed optic@@ -46,57 +44,57 @@  instance   ( TypeError-    ('Text "Indexed optic is expected")+    (Text "Indexed optic is expected")   , '[] ~ '[i]   ) => HasSingleIndex '[] i  instance   ( TypeError-    ('Text "Use (<%>) or icompose to combine indices of type "-     ':<>: ShowTypes is)+    (Text "Use (<%>) or icompose to combine indices of type "+     :<>: ShowTypes is)   , is ~ '[i1, i2]   , is ~ '[i]   ) => HasSingleIndex '[i1, i2] i  instance   ( TypeError-    ('Text "Use icompose3 to combine indices of type "-     ':<>: ShowTypes is)+    (Text "Use icompose3 to combine indices of type "+     :<>: ShowTypes is)   , is ~ '[i1, i2, i3]   , is ~ '[i]   ) => HasSingleIndex [i1, i2, i3] i  instance   ( TypeError-    ('Text "Use icompose4 to combine indices of type "-     ':<>: ShowTypes is)+    (Text "Use icompose4 to combine indices of type "+     :<>: ShowTypes is)   , is ~ '[i1, i2, i3, i4]   , is ~ '[i]   ) => HasSingleIndex '[i1, i2, i3, i4] i  instance   ( TypeError-    ('Text "Use icompose5 to flatten indices of type "-     ':<>: ShowTypes is)+    (Text "Use icompose5 to flatten indices of type "+     :<>: ShowTypes is)   , is ~ '[i1, i2, i3, i4, i5]   , is ~ '[i]   ) => HasSingleIndex '[i1, i2, i3, i4, i5] i  instance   ( TypeError-    ('Text "Use icomposeN to flatten indices of type "-     ':<>: ShowTypes is)-  , is ~ (i1 ': i2 ': i3 ': i4 ': i5 ': i6 : is')+    (Text "Use icomposeN to flatten indices of type "+     :<>: ShowTypes is)+  , is ~ (i1 : i2 : i3 : i4 : i5 : i6 : is')   , is ~ '[i]-  ) => HasSingleIndex (i1 ': i2 ': i3 ': i4 ': i5 ': i6 ': is') i+  ) => HasSingleIndex (i1 : i2 : i3 : i4 : i5 : i6 : is') i  ---------------------------------------- -- Helpers for HasSingleIndex  type family ShowTypes (types :: [Type]) :: ErrorMessage where-  ShowTypes '[i]      = QuoteType i-  ShowTypes '[i, j]   = QuoteType i ':<>: 'Text " and " ':<>: QuoteType j-  ShowTypes (i ': is) = QuoteType i ':<>: 'Text ", " ':<>: ShowTypes is+  ShowTypes '[i]     = QuoteType i+  ShowTypes '[i, j]  = QuoteType i :<>: Text " and " :<>: QuoteType j+  ShowTypes (i : is) = QuoteType i :<>: Text ", " :<>: ShowTypes is  ---------------------------------------- 

@@ -1,5 +1,3 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} 

@@ -1,5 +1,3 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeInType #-} {-# OPTIONS_HADDOCK not-home #-}  -- | Core optic types and subtyping machinery.

@@ -1,6 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeInType #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} @@ -33,9 +31,9 @@  -- | Overlappable instance for a custom type error. instance {-# OVERLAPPABLE #-} TypeError-  ('ShowType k ':<>: 'Text " cannot be used as " ':<>: 'ShowType l-   ':$$: 'Text "Perhaps you meant one of these:"-   ':$$: ShowEliminations (EliminationForms k)+  (ShowType k :<>: Text " cannot be used as " :<>: ShowType l+   :$$: Text "Perhaps you meant one of these:"+   :$$: ShowEliminations (EliminationForms k)   ) => Is k l where   implies _ = error "unreachable" @@ -434,6 +432,6 @@  instance {-# OVERLAPPABLE #-}   ( JoinKinds k l m-  , TypeError ('ShowType k ':<>: 'Text " cannot be composed with " ':<>: 'ShowType l)+  , TypeError (ShowType k :<>: Text " cannot be composed with " :<>: ShowType l)   ) => JoinKinds k l m where   joinKinds _ = error "unreachable"

@@ -1,6 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeInType #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} @@ -26,23 +24,23 @@ -- Elimination forms in error messages  type family ShowSymbolWithOrigin symbol origin :: ErrorMessage where-  ShowSymbolWithOrigin symbol origin = 'Text "  "-                                 ':<>: QuoteSymbol symbol-                                 ':<>: 'Text " (from "-                                 ':<>: 'Text origin-                                 ':<>: 'Text ")"+  ShowSymbolWithOrigin symbol origin = Text "  "+                                 :<>: QuoteSymbol symbol+                                 :<>: Text " (from "+                                 :<>: Text origin+                                 :<>: Text ")"  type family ShowSymbolsWithOrigin (fs :: [(Symbol, Symbol)]) :: ErrorMessage where   ShowSymbolsWithOrigin '[ '(symbol, origin) ] =     ShowSymbolWithOrigin symbol origin-  ShowSymbolsWithOrigin ('(symbol, origin) ': rest) =-    ShowSymbolWithOrigin symbol origin ':$$: ShowSymbolsWithOrigin rest+  ShowSymbolsWithOrigin ('(symbol, origin) : rest) =+    ShowSymbolWithOrigin symbol origin :$$: ShowSymbolsWithOrigin rest  type family ShowOperators (ops :: [Symbol]) :: ErrorMessage where   ShowOperators '[op] =-    QuoteSymbol op ':<>: 'Text " (from Optics.Operators)"-  ShowOperators (op ': rest) =-    QuoteSymbol op ':<>: 'Text " " ':<>: ShowOperators rest+    QuoteSymbol op :<>: Text " (from Optics.Operators)"+  ShowOperators (op : rest) =+    QuoteSymbol op :<>: Text " " :<>: ShowOperators rest  type family AppendEliminations a b where   AppendEliminations '(fs1, ops1) '(fs2, ops2) =@@ -50,7 +48,7 @@  type family ShowEliminations forms :: ErrorMessage where   ShowEliminations '(fs, ops) =-    ShowSymbolsWithOrigin fs ':$$: 'Text "  " ':<>: ShowOperators ops+    ShowSymbolsWithOrigin fs :$$: Text "  " :<>: ShowOperators ops  ---------------------------------------- -- Lists@@ -68,14 +66,13 @@ -- 'Curry' xs y = 'foldr' (->) y xs -- @ type family Curry (xs :: IxList) (y :: Type) :: Type where-  Curry '[]       y = y-  Curry (x ': xs) y = x -> Curry xs y+  Curry '[]      y = y+  Curry (x : xs) y = x -> Curry xs y  -- | Append two type-level lists together. type family Append (xs :: [k]) (ys :: [k]) :: [k] where-  Append '[]       ys  = ys -- needed for (<%>) and (%>)-  Append xs        '[] = xs -- needed for (<%)-  Append (x ': xs) ys  = x ': Append xs ys+  Append '[]      ys  = ys+  Append (x : xs) ys  = x : Append xs ys  -- | Class that is inhabited by all type-level lists @xs@, providing the ability -- to compose a function under @'Curry' xs@.@@ -88,7 +85,7 @@ instance CurryCompose '[] where   composeN = id -instance CurryCompose xs => CurryCompose (x ': xs) where+instance CurryCompose xs => CurryCompose (x : xs) where   composeN ij f = composeN @xs ij . f  ----------------------------------------@@ -119,57 +116,57 @@ instance ys ~ zs => AppendIndices '[] ys zs where   appendIndices = IxEq -instance AppendIndices xs ys ks => AppendIndices (x ': xs) ys (x ': ks) where-  appendIndices :: forall i. IxEq i (Curry (x ': xs) (Curry ys i)) (Curry (x ': ks) i)+instance AppendIndices xs ys ks => AppendIndices (x : xs) ys (x : ks) where+  appendIndices :: forall i. IxEq i (Curry (x : xs) (Curry ys i)) (Curry (x : ks) i)   appendIndices | IxEq <- appendIndices @xs @ys @ks @i = IxEq  ---------------------------------------- -- Either --- | If lhs is 'Right', return it. Otherwise check rhs.+-- | If lhs is Right', return it. Otherwise check rhs. type family FirstRight (m1 :: Either e a) (m2 :: Either e a) :: Either e a where-  FirstRight ('Right a) _ = 'Right a-  FirstRight          _ b = b+  FirstRight (Right a) _ = Right a+  FirstRight         _ b = b  type family FromRight (def :: b) (e :: Either a b) :: b where-  FromRight _   ('Right b) = b-  FromRight def ('Left  _) = def+  FromRight _   (Right b) = b+  FromRight def (Left  _) = def  type family IsLeft (e :: Either a b) :: Bool where-  IsLeft ('Left _)  = 'True-  IsLeft ('Right _) = 'False+  IsLeft (Left _)  = True+  IsLeft (Right _) = False  ---------------------------------------- -- Errors  -- | Show a custom type error if @p@ is true. type family When (p :: Bool) (err :: Constraint) :: Constraint where-  When 'True  err = err-  When 'False _   = ()+  When True  err = err+  When False _   = ()  -- | Show a custom type error if @p@ is false (or stuck). type family Unless (p :: Bool) (err :: Constraint) :: Constraint where-  Unless 'True  _   = ()-  Unless 'False err = err+  Unless True  _   = ()+  Unless False err = err  -- | Use with 'Unless' to detect stuck (undefined) type families. type family Defined (f :: k) :: Bool where   Defined (f _) = Defined f-  Defined _     = 'True+  Defined _     = True  -- | Show a type surrounded by quote marks. type family QuoteType (x :: t) :: ErrorMessage where-  QuoteType x = 'Text "‘" ':<>: 'ShowType x ':<>: 'Text "’"+  QuoteType x = Text "‘" :<>: ShowType x :<>: Text "’"  -- | Show a symbol surrounded by quote marks. type family QuoteSymbol (x :: Symbol) :: ErrorMessage where-  QuoteSymbol x = 'Text "‘" ':<>: 'Text x ':<>: 'Text "’"+  QuoteSymbol x = Text "‘" :<>: Text x :<>: Text "’"  type family ToOrdinal (n :: Nat) :: ErrorMessage where-  ToOrdinal 1 = 'Text "1st"-  ToOrdinal 2 = 'Text "2nd"-  ToOrdinal 3 = 'Text "3rd"-  ToOrdinal n = 'ShowType n ':<>: 'Text "th"+  ToOrdinal 1 = Text "1st"+  ToOrdinal 2 = Text "2nd"+  ToOrdinal 3 = Text "3rd"+  ToOrdinal n = ShowType n :<>: Text "th"  ---------------------------------------- -- Misc

@@ -1,5 +1,3 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeInType #-} {-# OPTIONS_HADDOCK not-home #-}  -- | This module is intended for internal use only, and may change without

@@ -36,6 +36,13 @@   -- * Additional introduction forms   , ignored +  -- * Monoid structure+  -- | 'IxAffineTraversal' admits a monoid structure where 'iadisjoin' returns+  -- the result from the second indexed affine traversal only if the first does+  -- not return a result. The identity element is 'ignored' (which traverses no+  -- elements).+  , iadisjoin+   -- * Subtyping   , An_AffineTraversal @@ -49,6 +56,7 @@ import Data.Profunctor.Indexed  import Optics.AffineFold+import Optics.AffineTraversal import Optics.Internal.Indexed import Optics.Internal.Optic import Optics.Internal.Utils@@ -129,6 +137,31 @@ ignored :: IxAffineTraversal i s s a b ignored = iatraversalVL $ \point _ -> point {-# INLINE ignored #-}++-- | Try the first 'IxAffineTraversal'. If it does not return a entry, try the+-- second one.+--+-- >>> iover (ifst `iadisjoin` isnd) (++) ("foo", "bar")+-- ("barfoo","bar")+--+-- >>> iover (ignored `iadisjoin` isnd) (++) ("foo", "bar")+-- ("foo","foobar")+--+-- @since 0.4.3+--+iadisjoin+  :: ( Is k An_AffineTraversal, Is l An_AffineTraversal+     , is1 `HasSingleIndex` i, is2 `HasSingleIndex` i)+  => Optic k is1 s t a b+  -> Optic l is2 s t a b+  -> IxAffineTraversal i s t a b+iadisjoin a b = conjoined (adisjoin a b) $ iatraversalVL $ \point f s ->+  let OrT visited fu = iatraverseOf a (OrT False . point) (\i -> wrapOrT . f i) s+  in if visited+     then fu+     else iatraverseOf b point f s+infixl 3 `iadisjoin` -- Same as (<|>)+{-# INLINE iadisjoin #-}  -- $setup -- >>> import Optics.Core

@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-} -- | -- Module: Optics.IxFold -- Description: An indexed version of a 'Optics.Fold.Fold'.

@@ -1,4 +1,3 @@-{-# LANGUAGE DataKinds #-} -- | -- Module: Optics.IxTraversal -- Description: An indexed version of a 'Optics.Traversal.Traversal'.@@ -60,11 +59,17 @@   , ipartsOf   , isingular -  -- * Monoid structure-  -- | 'IxTraversal' admits a (partial) monoid structure where 'iadjoin'-  -- combines non-overlapping indexed traversals, and the identity element is-  -- 'ignored' (which traverses no elements).+  -- * Monoid structures+  -- | 'IxTraversal' admits two monoid structures:   --+  -- * 'iadjoin' combines non-overlapping indexed traversals.+  --+  -- * 'idisjoin' returns results from the second indexed traversal only if the+  --   first returns no results.+  --+  -- In both cases, the identity element is 'ignored' (which traverses no+  -- elements).+  --   -- If you merely need an 'IxFold', you can use indexed traversals as indexed   -- folds and combine them with one of the monoid structures on indexed folds   -- (see "Optics.IxFold#monoids"). In particular, 'isumming' can be used to@@ -76,6 +81,7 @@   -- and the ('<>') operator could not be used to combine optics of different   -- kinds.   , iadjoin+  , idisjoin    -- * Subtyping   , A_Traversal@@ -355,6 +361,30 @@       Just a' -> put Nothing >> pure a'       Nothing ->                pure a {-# INLINE isingular #-}++-- | Try the first 'IxTraversal'. If it returns no entries, try the second one.+--+-- >>> iover (_1 % itraversed `idisjoin` _2 % itraversed) (+) ([0, 0, 0], (3, 5))+-- ([0,1,2],(3,5))+--+-- >>> iover (ignored `idisjoin` _2 % itraversed) (+) ([0, 0, 0], (3, 5))+-- ([0,0,0],(3,8))+--+-- @since 0.4.3+--+idisjoin+  :: ( Is k A_Traversal, Is l A_Traversal+     , is1 `HasSingleIndex` i, is2 `HasSingleIndex` i)+  => Optic k is1 s t a b+  -> Optic l is2 s t a b+  -> IxTraversal i s t a b+idisjoin a b = conjoined (disjoin a b) $ itraversalVL $ \f s ->+  let OrT visited fu = itraverseOf a (\i -> wrapOrT . f i) s+  in if visited+     then fu+     else itraverseOf b f s+infixl 3 `idisjoin` -- Same as (<|>)+{-# INLINE idisjoin #-}  -- | Combine two disjoint indexed traversals into one. --

@@ -1,7 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeInType #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -- |@@ -533,9 +531,14 @@   , repDefined ~ (Defined (Rep s) && Defined (Rep t)) #endif   , Unless repDefined (NoLabelOpticError name k s t a b)-  , k ~ If (CmpSymbol "_@" name == 'LT && CmpSymbol "_[" name == 'GT)+  -- If a label starts with "_[A-Z]", assume it's a name of a constructor.+  -- Otherwise, if it starts with "?[a-z]", assume it's a name of a partial+  -- field. Otherwise it's a total field.+  , 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   )@@ -543,19 +546,19 @@ -- | If there is no specific 'LabelOptic' instance, display a custom type error. type family NoLabelOpticError name k s t a b where   NoLabelOpticError name k s t a b = TypeError-    ('Text "No instance for LabelOptic " ':<>: 'ShowType name-     ':<>: 'Text " " ':<>: QuoteType k-     ':<>: 'Text " " ':<>: QuoteType s-     ':<>: 'Text " " ':<>: QuoteType t-     ':<>: 'Text " " ':<>: QuoteType a-     ':<>: 'Text " " ':<>: QuoteType b-     ':$$: 'Text "Possible solutions:"-     ':$$: 'Text "- Check and correct spelling of the label"-     ':$$: 'Text "- Define the LabelOptic instance by hand or via Template Haskell"+    (Text "No instance for LabelOptic " :<>: ShowType name+     :<>: Text " " :<>: QuoteType k+     :<>: Text " " :<>: QuoteType s+     :<>: Text " " :<>: QuoteType t+     :<>: Text " " :<>: QuoteType a+     :<>: Text " " :<>: QuoteType b+     :$$: Text "Possible solutions:"+     :$$: Text "- Check and correct spelling of the label"+     :$$: Text "- Define the LabelOptic instance by hand or via Template Haskell" #ifdef EXPLICIT_GENERIC_LABELS-     ':$$: 'Text "- Derive a GenericLabelOptics instance for " ':<>: QuoteType s+     :$$: Text "- Derive a GenericLabelOptics instance for " :<>: QuoteType s #else-     ':$$: 'Text "- Derive a Generic instance for " ':<>: QuoteType s+     :$$: Text "- Derive a Generic instance for " :<>: QuoteType s #endif     ) @@ -578,7 +581,7 @@ -- @since 0.4 class Generic a => GenericLabelOptics a where   type HasGenericLabelOptics a :: Bool-  type HasGenericLabelOptics a = 'True+  type HasGenericLabelOptics a = True  ---------------------------------------- @@ -593,10 +596,18 @@   ) => GenericOptic repDefined name A_Lens s t a b where   genericOptic = gfieldImpl @name +-- | This instance can only be used via label syntax with GHC >= 9.6 since it's+-- the first release with unrestricted overloaded labels. 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  ----------------------------------------

@@ -6,7 +6,6 @@ -- @'Optic'' ('MappedOptic' k) 'NoIx' (f s) (f a)@, in other words optic operating on values -- in a 'Functor'. ---{-# LANGUAGE DataKinds #-} module Optics.Mapping   ( MappingOptic (..)   ) where

@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilyDependencies #-} -- | -- Module: Optics.Re -- Description: The 're' operator allows some optics to be reversed.@@ -22,8 +23,6 @@ -- -- <<diagrams/reoptics.png Reversed Optics>> ---{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilyDependencies #-} module Optics.Re   ( ReversibleOptic(..)   ) where

@@ -1,5 +1,3 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeInType #-} -- | -- Module: Optics.ReadOnly -- Description: Converting read-write optics into their read-only counterparts.

@@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} -- | -- Module: Optics.Traversal@@ -67,13 +66,20 @@     -- * Combinators   , backwards   , partsOf+  , unsafePartsOf   , singular -  -- * Monoid structure-  -- | 'Traversal' admits a (partial) monoid structure where 'adjoin' combines-  -- non-overlapping traversals, and the identity element is-  -- 'Optics.IxAffineTraversal.ignored' (which traverses no elements).+  -- * Monoid structures+  -- | 'Traversal' admits two monoid structures:   --+  -- * 'adjoin' combines non-overlapping traversals.+  --+  -- * 'disjoin' returns results from the second traversal only if the first+  --   returns no results.+  --+  -- In both cases, the identity element is 'Optics.IxAffineTraversal.ignored'+  -- (which traverses no elements).+  --   -- If you merely need a 'Fold', you can use traversals as folds and combine   -- them with one of the monoid structures on folds (see   -- "Optics.Fold#monoids"). In particular, 'summing' can be used to concatenate@@ -84,6 +90,7 @@   -- is not a unique choice of monoid to use that works for all optics, and the   -- ('<>') operator could not be used to combine optics of different kinds.   , adjoin+  , disjoin    -- * Subtyping   , A_Traversal@@ -380,7 +387,7 @@ -- So technically, this is only a 'Lens' if you do not change the number of -- results it returns. partsOf-  :: forall k is s t a. Is k A_Traversal+  :: Is k A_Traversal   => Optic k is s t a a   -> Lens s t [a] [a] partsOf o = lensVL $ \f s -> evalState (traverseOf o update s)@@ -391,6 +398,22 @@       []       ->            pure a {-# INLINE partsOf #-} +-- | A variant of 'partsOf' that allows changing the type of elements.+--+-- /Warning:/ if you don't supply at least as many @b@'s as you were given @a@'s,+-- the reconstruction of @t@ will result in an error.+unsafePartsOf+  :: Is k A_Traversal+  => Optic k is s t a b+  -> Lens s t [a] [b]+unsafePartsOf o = lensVL $ \f s -> evalState (traverseOf o update s)+  <$> f (toListOf (getting $ castOptic @A_Traversal o) s)+  where+    update _ = get >>= \case+      b : bs -> put bs >> pure b+      []     -> error "unsafePartsOf: not enough elements were supplied"+{-# INLINE unsafePartsOf #-}+ -- | Convert a traversal to an 'AffineTraversal' that visits the first element -- of the original traversal. --@@ -401,7 +424,7 @@ -- -- @since 0.3 singular-  :: forall k is s a. Is k A_Traversal+  :: Is k A_Traversal   => Optic' k is s a   -> AffineTraversal' s a singular o = atraversalVL $ \point f s ->@@ -413,6 +436,28 @@       Just a' -> put Nothing >> pure a'       Nothing ->                pure a {-# INLINE singular #-}++-- | Try the first 'Traversal'. If it returns no entries, try the second one.+--+-- >>> over (_1 `disjoin` _2) succ (0, 0)+-- (1,0)+-- >>> over (ignored `disjoin` _2) succ (0, 0)+-- (0,1)+--+-- @since 0.4.3+--+disjoin+  :: (Is k A_Traversal, Is l A_Traversal)+  => Optic k is s t a b+  -> Optic l js s t a b+  -> Traversal s t a b+disjoin a b = traversalVL $ \f s ->+  let OrT visited fu = traverseOf a (wrapOrT . f) s+  in if visited+     then fu+     else traverseOf b f s+infixl 3 `disjoin` -- Same as (<|>)+{-# INLINE disjoin #-}  -- | Combine two disjoint traversals into one. --