summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAdamGundry <>2019-10-18 21:20:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-10-18 21:20:00 (GMT)
commit71657882cfcdedbbf2d7f8abf1b3f79f05b38a08 (patch)
tree8088d1c7d07a5b673ce19932db58d98427da31c6
parent69814fa24383c7285fae3f79b0a26c8b26bf8399 (diff)
version 0.2HEAD0.2master
-rw-r--r--CHANGELOG.md11
-rw-r--r--optics-core.cabal11
-rw-r--r--src/Data/IntMap/Optics.hs2
-rw-r--r--src/GHC/Generics/Optics.hs2
-rw-r--r--src/Optics/AffineFold.hs3
-rw-r--r--src/Optics/AffineTraversal.hs4
-rw-r--r--src/Optics/Arrow.hs4
-rw-r--r--src/Optics/At/Core.hs26
-rw-r--r--src/Optics/Coerce.hs3
-rw-r--r--src/Optics/Empty/Core.hs5
-rw-r--r--src/Optics/Fold.hs7
-rw-r--r--src/Optics/Getter.hs7
-rw-r--r--src/Optics/Indexed/Core.hs3
-rw-r--r--src/Optics/Internal/Bi.hs11
-rw-r--r--src/Optics/Internal/Concrete.hs117
-rw-r--r--src/Optics/Internal/Fold.hs3
-rw-r--r--src/Optics/Internal/Indexed.hs20
-rw-r--r--src/Optics/Internal/IxFold.hs3
-rw-r--r--src/Optics/Internal/IxSetter.hs3
-rw-r--r--src/Optics/Internal/IxTraversal.hs3
-rw-r--r--src/Optics/Internal/Optic.hs19
-rw-r--r--src/Optics/Internal/Optic/Subtyping.hs3
-rw-r--r--src/Optics/Internal/Optic/TypeLevel.hs19
-rw-r--r--src/Optics/Internal/Optic/Types.hs38
-rw-r--r--src/Optics/Internal/Profunctor.hs705
-rw-r--r--src/Optics/Internal/Setter.hs3
-rw-r--r--src/Optics/Internal/Tagged.hs50
-rw-r--r--src/Optics/Internal/Traversal.hs3
-rw-r--r--src/Optics/Internal/Utils.hs74
-rw-r--r--src/Optics/Iso.hs114
-rw-r--r--src/Optics/IxAffineFold.hs3
-rw-r--r--src/Optics/IxAffineTraversal.hs3
-rw-r--r--src/Optics/IxFold.hs7
-rw-r--r--src/Optics/IxGetter.hs7
-rw-r--r--src/Optics/IxLens.hs7
-rw-r--r--src/Optics/IxSetter.hs8
-rw-r--r--src/Optics/IxTraversal.hs11
-rw-r--r--src/Optics/Lens.hs14
-rw-r--r--src/Optics/Optic.hs7
-rw-r--r--src/Optics/Prism.hs16
-rw-r--r--src/Optics/Re.hs3
-rw-r--r--src/Optics/ReadOnly.hs3
-rw-r--r--src/Optics/Review.hs5
-rw-r--r--src/Optics/Setter.hs4
-rw-r--r--src/Optics/Traversal.hs5
45 files changed, 377 insertions, 1002 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
index 0000000..9c19b54
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,11 @@
+# optics-core-0.2 (2019-10-18)
+* Add `non`, `non'` and `anon` to `Optics.Iso`
+* `ix` can produce optic kinds other than `AffineTraversal`
+* Generalise type of `generic1`
+* Move some internal definitions out to new `indexed-profunctors` package
+* Introduce `OpticKind` and `IxList` type synonyms for better type inference
+* Make `itraverse` for `Seq` faster for `containers >= 0.6.0`
+* Assorted documentation improvements
+
+# optics-core-0.1 (2019-09-02)
+* Initial release
diff --git a/optics-core.cabal b/optics-core.cabal
index 84f4d47..afdf4e3 100644
--- a/optics-core.cabal
+++ b/optics-core.cabal
@@ -1,5 +1,5 @@
name: optics-core
-version: 0.1
+version: 0.2
license: BSD3
license-file: LICENSE
build-type: Simple
@@ -14,11 +14,12 @@ description:
and other optics, using an abstract interface.
.
This variant provides core definitions with a minimal dependency footprint.
- See the @optics@ package (and its dependencies) for documentation and the
- "batteries-included" variant.
+ See the @<https://hackage.haskell.org/package/optics optics>@ package (and its
+ dependencies) for documentation and the "batteries-included" variant.
extra-doc-files:
diagrams/*.png
+ CHANGELOG.md
bug-reports: https://github.com/well-typed/optics/issues
source-repository head
@@ -34,6 +35,7 @@ library
build-depends: base >= 4.9 && <5
, array >= 0.5.1.1 && <0.6
, containers >= 0.5.7.1 && <0.7
+ , indexed-profunctors >= 0.1 && <0.2
, transformers >= 0.5 && <0.6
exposed-modules: Optics.Core
@@ -92,7 +94,6 @@ library
-- internal modules
Optics.Internal.Bi
- Optics.Internal.Concrete
Optics.Internal.Fold
Optics.Internal.Indexed
Optics.Internal.IxFold
@@ -102,9 +103,7 @@ library
Optics.Internal.Optic.Subtyping
Optics.Internal.Optic.TypeLevel
Optics.Internal.Optic.Types
- Optics.Internal.Profunctor
Optics.Internal.Setter
- Optics.Internal.Tagged
Optics.Internal.Traversal
Optics.Internal.Utils
diff --git a/src/Data/IntMap/Optics.hs b/src/Data/IntMap/Optics.hs
index c1f4132..dc8c61f 100644
--- a/src/Data/IntMap/Optics.hs
+++ b/src/Data/IntMap/Optics.hs
@@ -11,7 +11,7 @@
-- >>> IntMap.empty & at 0 .~ Just "hello"
-- fromList [(0,"hello")]
--
--- We can traverse, fold over, and map over key-value pairs in a 'IntMap',
+-- We can traverse, fold over, and map over key-value pairs in an 'IntMap',
-- thanks to indexed traversals, folds and setters.
--
-- >>> iover imapped const $ IntMap.fromList [(1, "Venus")]
diff --git a/src/GHC/Generics/Optics.hs b/src/GHC/Generics/Optics.hs
index 0e2b7df..8851a6d 100644
--- a/src/GHC/Generics/Optics.hs
+++ b/src/GHC/Generics/Optics.hs
@@ -49,7 +49,7 @@ generic = iso GHC.from GHC.to
{-# INLINE generic #-}
-- | Convert from the data type to its representation (or back)
-generic1 :: Generic1 f => Iso (f a) (f b) (Rep1 f a) (Rep1 f b)
+generic1 :: (Generic1 f, Generic1 g) => Iso (f a) (g b) (Rep1 f a) (Rep1 g b)
generic1 = iso GHC.from1 GHC.to1
{-# INLINE generic1 #-}
diff --git a/src/Optics/AffineFold.hs b/src/Optics/AffineFold.hs
index 2ac0630..599b9d7 100644
--- a/src/Optics/AffineFold.hs
+++ b/src/Optics/AffineFold.hs
@@ -41,8 +41,9 @@ module Optics.AffineFold
import Data.Maybe
+import Data.Profunctor.Indexed
+
import Optics.Internal.Bi
-import Optics.Internal.Profunctor
import Optics.Internal.Optic
-- | Type synonym for an affine fold.
diff --git a/src/Optics/AffineTraversal.hs b/src/Optics/AffineTraversal.hs
index 16998e7..d24590d 100644
--- a/src/Optics/AffineTraversal.hs
+++ b/src/Optics/AffineTraversal.hs
@@ -60,9 +60,9 @@ module Optics.AffineTraversal
)
where
-import Optics.Internal.Concrete
+import Data.Profunctor.Indexed
+
import Optics.Internal.Optic
-import Optics.Internal.Profunctor
-- | Type synonym for a type-modifying affine traversal.
type AffineTraversal s t a b = Optic An_AffineTraversal NoIx s t a b
diff --git a/src/Optics/Arrow.hs b/src/Optics/Arrow.hs
index 141a196..6a42ead 100644
--- a/src/Optics/Arrow.hs
+++ b/src/Optics/Arrow.hs
@@ -10,12 +10,12 @@ import Control.Arrow
import Data.Coerce
import qualified Control.Category as C
+import Data.Profunctor.Indexed
+
import Optics.AffineTraversal
import Optics.Prism
import Optics.Setter
import Optics.Internal.Optic
-import Optics.Internal.Profunctor
-import Optics.Internal.Utils
newtype WrappedArrow p i a b = WrapArrow { unwrapArrow :: p a b }
diff --git a/src/Optics/At/Core.hs b/src/Optics/At/Core.hs
index 6cac7b1..b076b40 100644
--- a/src/Optics/At/Core.hs
+++ b/src/Optics/At/Core.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeInType #-}
-- |
-- Module: Optics.At.Core
-- Description: Optics for 'Map' and 'Set'-like containers.
@@ -47,6 +48,7 @@ import Data.Complex
import Data.Functor.Identity
import Data.IntMap as IntMap
import Data.IntSet as IntSet
+import Data.Kind (Type)
import Data.List.NonEmpty as NonEmpty
import Data.Map as Map
import Data.Sequence as Seq
@@ -63,7 +65,7 @@ import Optics.Setter
-- | 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'.
-type family Index (s :: *) :: *
+type family Index (s :: Type) :: Type
type instance Index (e -> a) = e
type instance Index IntSet = Int
type instance Index (Set a) = a
@@ -115,11 +117,19 @@ instance Ord a => Contains (Set a) where
-- | Type family that takes a key-value container type and returns the type of
-- values stored in the container, for example @'IxValue' ('Map' k a) ~ a@. This
-- is shared by both 'Ixed' and 'At'.
-type family IxValue (m :: *) :: *
+type family IxValue (m :: Type) :: Type
+
-- | Provides a simple 'AffineTraversal' lets you traverse the value at a given
-- key in a 'Map' or element at an ordinal position in a list or 'Seq'.
class Ixed m where
+ -- | Type family that takes a key-value container type and returns the kind
+ -- of optic to index into it. For most containers, it's 'An_AffineTraversal',
+ -- @Representable@ (Naperian) containers it is 'A_Lens', and multi-maps would
+ -- have 'A_Traversal'.
+ type IxKind (m :: Type) :: OpticKind
+ type IxKind m = An_AffineTraversal
+
-- | /NB:/ Setting the value of this 'AffineTraversal' will only set the value
-- in 'at' if it is already present.
--
@@ -136,8 +146,8 @@ class Ixed m where
--
-- >>> [] ^? ix 2
-- Nothing
- ix :: Index m -> AffineTraversal' m (IxValue m)
- default ix :: At m => Index m -> AffineTraversal' m (IxValue m)
+ ix :: Index m -> Optic' (IxKind m) NoIx m (IxValue m)
+ default ix :: (At m, IxKind m ~ An_AffineTraversal) => Index m -> Optic' (IxKind m) NoIx m (IxValue m)
ix = ixAt
{-# INLINE ix #-}
@@ -149,7 +159,8 @@ ixAt = \i -> at i % _Just
type instance IxValue (e -> a) = a
instance Eq e => Ixed (e -> a) where
- ix e = atraversalVL $ \_ p f -> p (f e) <&> \a e' -> if e == e' then a else f e'
+ type IxKind (e -> a) = A_Lens
+ ix e = lensVL $ \p f -> p (f e) <&> \a e' -> if e == e' then a else f e'
{-# INLINE ix #-}
type instance IxValue (Maybe a) = a
@@ -174,7 +185,8 @@ instance Ixed (NonEmpty a) where
type instance IxValue (Identity a) = a
instance Ixed (Identity a) where
- ix () = atraversalVL $ \_ f (Identity a) -> Identity <$> f a
+ type IxKind (Identity a) = An_Iso
+ ix () = coerced
{-# INLINE ix #-}
type instance IxValue (Tree a) = a
@@ -361,7 +373,7 @@ instance
-- @
-- 'ix' k ≡ 'at' k '%' '_Just'
-- @
-class Ixed m => At m where
+class (Ixed m, IxKind m ~ An_AffineTraversal) => At m where
-- |
-- >>> Map.fromList [(1,"world")] ^. at 1
-- Just "world"
diff --git a/src/Optics/Coerce.hs b/src/Optics/Coerce.hs
index 572d37d..d9d07e7 100644
--- a/src/Optics/Coerce.hs
+++ b/src/Optics/Coerce.hs
@@ -24,8 +24,9 @@ module Optics.Coerce
import Data.Coerce
+import Data.Profunctor.Indexed
+
import Optics.Internal.Optic
-import Optics.Internal.Profunctor
-- | Lift 'coerce' to the @s@ parameter of an optic.
coerceS
diff --git a/src/Optics/Empty/Core.hs b/src/Optics/Empty/Core.hs
index 2e73a62..1dc5496 100644
--- a/src/Optics/Empty/Core.hs
+++ b/src/Optics/Empty/Core.hs
@@ -32,11 +32,12 @@ import Data.Monoid
import Data.Set as Set
import qualified Data.Sequence as Seq
+import Data.Profunctor.Indexed
+
import Data.Maybe.Optics
import Optics.AffineTraversal
-import Optics.Internal.Utils
-import Optics.Iso
import Optics.Fold
+import Optics.Iso
import Optics.Optic
import Optics.Prism
import Optics.Review
diff --git a/src/Optics/Fold.hs b/src/Optics/Fold.hs
index 3b7a977..bd7a1d4 100644
--- a/src/Optics/Fold.hs
+++ b/src/Optics/Fold.hs
@@ -92,12 +92,13 @@ import Data.Foldable
import Data.Function
import Data.Monoid
+import Data.Profunctor.Indexed
+
+import Optics.AffineFold
import Optics.Internal.Bi
import Optics.Internal.Fold
import Optics.Internal.Optic
-import Optics.Internal.Profunctor
import Optics.Internal.Utils
-import Optics.AffineFold
-- | Type synonym for a fold.
type Fold s a = Optic' A_Fold NoIx s a
@@ -168,7 +169,7 @@ forOf_
forOf_ = flip . traverseOf_
{-# INLINE forOf_ #-}
--- | Evaluate each action in observed by a 'Fold' on a structure from left to
+-- | Evaluate each action in a structure observed by a 'Fold' from left to
-- right, ignoring the results.
--
-- @
diff --git a/src/Optics/Getter.hs b/src/Optics/Getter.hs
index 5c1ce8d..ef05f1b 100644
--- a/src/Optics/Getter.hs
+++ b/src/Optics/Getter.hs
@@ -39,14 +39,19 @@ module Optics.Getter
)
where
+import Data.Profunctor.Indexed
+
import Optics.Internal.Bi
import Optics.Internal.Optic
-import Optics.Internal.Profunctor
-- | Type synonym for a getter.
type Getter s a = Optic' A_Getter NoIx s a
-- | View the value pointed to by a getter.
+--
+-- If you want to 'view' a type-modifying optic that is insufficiently
+-- polymorphic to be type-preserving, use 'Optics.ReadOnly.getting'.
+--
view :: Is k A_Getter => Optic' k is s a -> s -> a
view o = views o id
{-# INLINE view #-}
diff --git a/src/Optics/Indexed/Core.hs b/src/Optics/Indexed/Core.hs
index 3f0c9d2..48adee6 100644
--- a/src/Optics/Indexed/Core.hs
+++ b/src/Optics/Indexed/Core.hs
@@ -46,9 +46,10 @@ module Optics.Indexed.Core
, ifor
) where
+import Data.Profunctor.Indexed
+
import Optics.Internal.Indexed
import Optics.Internal.Optic
-import Optics.Internal.Profunctor
import Optics.AffineFold
import Optics.AffineTraversal
diff --git a/src/Optics/Internal/Bi.hs b/src/Optics/Internal/Bi.hs
index 0127e7b..9bcfe9c 100644
--- a/src/Optics/Internal/Bi.hs
+++ b/src/Optics/Internal/Bi.hs
@@ -6,9 +6,10 @@
-- in subsequent releases.
module Optics.Internal.Bi where
+import Data.Coerce
import Data.Void
-import Optics.Internal.Profunctor
+import Data.Profunctor.Indexed
-- | Class for (covariant) bifunctors.
class Bifunctor p where
@@ -16,6 +17,14 @@ class Bifunctor p where
first :: (a -> b) -> p i a c -> p i b c
second :: (c -> d) -> p i a c -> p i a d
+instance Bifunctor Tagged where
+ bimap _f g = Tagged #. g .# unTagged
+ first _f = coerce
+ second g = Tagged #. g .# unTagged
+ {-# INLINE bimap #-}
+ {-# INLINE first #-}
+ {-# INLINE second #-}
+
-- | Class for contravariant bifunctors.
class Bicontravariant p where
contrabimap :: (b -> a) -> (d -> c) -> p i a c -> p i b d
diff --git a/src/Optics/Internal/Concrete.hs b/src/Optics/Internal/Concrete.hs
deleted file mode 100644
index a1b16b3..0000000
--- a/src/Optics/Internal/Concrete.hs
+++ /dev/null
@@ -1,117 +0,0 @@
-{-# OPTIONS_HADDOCK not-home #-}
-
--- | Concrete representation types for certain optics.
---
--- This module is intended for internal use only, and may change without warning
--- in subsequent releases.
-module Optics.Internal.Concrete
- ( Exchange(..)
- , Store(..)
- , Market(..)
- , AffineMarket(..)
- ) where
-
-import Data.Bifunctor
-
-import Optics.Internal.Profunctor
-
--- | Type to represent the components of an isomorphism.
-data Exchange a b i s t =
- Exchange (s -> a) (b -> t)
-
-instance Profunctor (Exchange a b) where
- dimap ss tt (Exchange sa bt) = Exchange (sa . ss) (tt . bt)
- lmap ss (Exchange sa bt) = Exchange (sa . ss) bt
- rmap tt (Exchange sa bt) = Exchange sa (tt . bt)
- {-# INLINE dimap #-}
- {-# INLINE lmap #-}
- {-# INLINE rmap #-}
-
--- | Type to represent the components of a lens.
-data Store a b i s t = Store (s -> a) (s -> b -> t)
-
-instance Profunctor (Store a b) where
- dimap f g (Store get set) = Store (get . f) (\s -> g . set (f s))
- lmap f (Store get set) = Store (get . f) (\s -> set (f s))
- rmap g (Store get set) = Store get (\s -> g . set s)
- {-# INLINE dimap #-}
- {-# INLINE lmap #-}
- {-# INLINE rmap #-}
-
-instance Strong (Store a b) where
- first' (Store get set) = Store (get . fst) (\(s, c) b -> (set s b, c))
- second' (Store get set) = Store (get . snd) (\(c, s) b -> (c, set s b))
- {-# INLINE first' #-}
- {-# INLINE second' #-}
-
--- | Type to represent the components of a prism.
-data Market a b i s t = Market (b -> t) (s -> Either t a)
-
-instance Functor (Market a b i s) where
- fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)
- {-# INLINE fmap #-}
-
-instance Profunctor (Market a b) where
- dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f)
- lmap f (Market bt seta) = Market bt (seta . f)
- rmap g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta)
- {-# INLINE dimap #-}
- {-# INLINE lmap #-}
- {-# INLINE rmap #-}
-
-instance Choice (Market a b) where
- left' (Market bt seta) = Market (Left . bt) $ \sc -> case sc of
- Left s -> case seta s of
- Left t -> Left (Left t)
- Right a -> Right a
- Right c -> Left (Right c)
- right' (Market bt seta) = Market (Right . bt) $ \cs -> case cs of
- Left c -> Left (Left c)
- Right s -> case seta s of
- Left t -> Left (Right t)
- Right a -> Right a
- {-# INLINE left' #-}
- {-# INLINE right' #-}
-
--- | Type to represent the components of an affine traversal.
-data AffineMarket a b i s t = AffineMarket (s -> b -> t) (s -> Either t a)
-
-instance Profunctor (AffineMarket a b) where
- dimap f g (AffineMarket sbt seta) = AffineMarket
- (\s b -> g (sbt (f s) b))
- (either (Left . g) Right . seta . f)
- lmap f (AffineMarket sbt seta) = AffineMarket
- (\s b -> sbt (f s) b)
- (seta . f)
- rmap g (AffineMarket sbt seta) = AffineMarket
- (\s b -> g (sbt s b))
- (either (Left . g) Right . seta)
- {-# INLINE dimap #-}
- {-# INLINE lmap #-}
- {-# INLINE rmap #-}
-
-instance Choice (AffineMarket a b) where
- left' (AffineMarket sbt seta) = AffineMarket
- (\e b -> bimap (flip sbt b) id e)
- (\sc -> case sc of
- Left s -> bimap Left id (seta s)
- Right c -> Left (Right c))
- right' (AffineMarket sbt seta) = AffineMarket
- (\e b -> bimap id (flip sbt b) e)
- (\sc -> case sc of
- Left c -> Left (Left c)
- Right s -> bimap Right id (seta s))
- {-# INLINE left' #-}
- {-# INLINE right' #-}
-
-instance Strong (AffineMarket a b) where
- first' (AffineMarket sbt seta) = AffineMarket
- (\(a, c) b -> (sbt a b, c))
- (\(a, c) -> bimap (,c) id (seta a))
- second' (AffineMarket sbt seta) = AffineMarket
- (\(c, a) b -> (c, sbt a b))
- (\(c, a) -> bimap (c,) id (seta a))
- {-# INLINE first' #-}
- {-# INLINE second' #-}
-
-instance Visiting (AffineMarket a b)
diff --git a/src/Optics/Internal/Fold.hs b/src/Optics/Internal/Fold.hs
index 01e4af9..2a89500 100644
--- a/src/Optics/Internal/Fold.hs
+++ b/src/Optics/Internal/Fold.hs
@@ -11,9 +11,10 @@ import Data.Foldable
import Data.Maybe
import qualified Data.Semigroup as SG
+import Data.Profunctor.Indexed
+
import Optics.Internal.Bi
import Optics.Internal.Optic
-import Optics.Internal.Profunctor
-- | Internal implementation of 'Optics.Fold.foldVL'.
foldVL__
diff --git a/src/Optics/Internal/Indexed.hs b/src/Optics/Internal/Indexed.hs
index 650ea91..28e918f 100644
--- a/src/Optics/Internal/Indexed.hs
+++ b/src/Optics/Internal/Indexed.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeInType #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-}
@@ -19,6 +20,7 @@ import Data.Functor.Product
import Data.Functor.Reverse
import Data.Functor.Sum
import Data.Ix
+import Data.Kind (Type)
import Data.List.NonEmpty
import Data.Monoid hiding (Product, Sum)
import Data.Proxy
@@ -31,12 +33,13 @@ import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import qualified Data.Sequence as Seq
+import Data.Profunctor.Indexed
+
import Optics.Internal.Optic
-import Optics.Internal.Profunctor
import Optics.Internal.Utils
-- | Show useful error message when a function expects optics without indices.
-class is ~ NoIx => AcceptsEmptyIndices (f :: Symbol) (is :: [*])
+class is ~ NoIx => AcceptsEmptyIndices (f :: Symbol) (is :: IxList)
instance
( TypeError
@@ -48,7 +51,7 @@ instance AcceptsEmptyIndices f '[]
-- | Check whether a list of indices is not empty and generate sensible error
-- message if it's not.
-class NonEmptyIndices (is :: [*])
+class NonEmptyIndices (is :: IxList)
instance
( TypeError
@@ -60,7 +63,7 @@ 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
-- with a single index is expected.
-class is ~ '[i] => HasSingleIndex (is :: [*]) (i :: *)
+class is ~ '[i] => HasSingleIndex (is :: IxList) (i :: Type)
instance HasSingleIndex '[i] i
@@ -113,7 +116,7 @@ instance
----------------------------------------
-- Helpers for HasSingleIndex
-type family ShowTypes (types :: [*]) :: ErrorMessage where
+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
@@ -304,8 +307,13 @@ instance FoldableWithIndex Int Seq.Seq where
{-# INLINE ifoldr #-}
instance TraversableWithIndex Int Seq.Seq where
- -- This is much faster than Seq.traverseWithIndex. wut?
+#if MIN_VERSION_containers(0,6,0)
+ itraverse = Seq.traverseWithIndex
+#else
+ -- Much faster than Seq.traverseWithIndex for containers < 0.6.0, see
+ -- https://github.com/haskell/containers/issues/603.
itraverse f = sequenceA . Seq.mapWithIndex f
+#endif
{-# INLINE itraverse #-}
-- IntMap
diff --git a/src/Optics/Internal/IxFold.hs b/src/Optics/Internal/IxFold.hs
index e59ffdd..34fecd7 100644
--- a/src/Optics/Internal/IxFold.hs
+++ b/src/Optics/Internal/IxFold.hs
@@ -9,9 +9,10 @@ module Optics.Internal.IxFold where
import Data.Functor
import Data.Foldable
+import Data.Profunctor.Indexed
+
import Optics.Internal.Bi
import Optics.Internal.Indexed
-import Optics.Internal.Profunctor
import Optics.Internal.Optic
import Optics.Internal.Fold
diff --git a/src/Optics/Internal/IxSetter.hs b/src/Optics/Internal/IxSetter.hs
index 8bb3318..fff6e4f 100644
--- a/src/Optics/Internal/IxSetter.hs
+++ b/src/Optics/Internal/IxSetter.hs
@@ -6,9 +6,10 @@
-- in subsequent releases.
module Optics.Internal.IxSetter where
+import Data.Profunctor.Indexed
+
import Optics.Internal.Indexed
import Optics.Internal.Optic
-import Optics.Internal.Profunctor
-- | Internal implementation of 'Optics.IxSetter.imapped'.
imapped__
diff --git a/src/Optics/Internal/IxTraversal.hs b/src/Optics/Internal/IxTraversal.hs
index e759373..bf8c373 100644
--- a/src/Optics/Internal/IxTraversal.hs
+++ b/src/Optics/Internal/IxTraversal.hs
@@ -6,12 +6,13 @@
-- in subsequent releases.
module Optics.Internal.IxTraversal where
+import Data.Profunctor.Indexed
+
import Optics.Internal.Fold
import Optics.Internal.Indexed
import Optics.Internal.IxFold
import Optics.Internal.IxSetter
import Optics.Internal.Optic
-import Optics.Internal.Profunctor
import Optics.Internal.Setter
-- | Internal implementation of 'Optics.IxTraversal.itraversed'.
diff --git a/src/Optics/Internal/Optic.hs b/src/Optics/Internal/Optic.hs
index 2ce40f8..a928504 100644
--- a/src/Optics/Internal/Optic.hs
+++ b/src/Optics/Internal/Optic.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeInType #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-}
@@ -21,8 +22,6 @@ module Optics.Internal.Optic
, Optic'
, Optic_
, Optic__
- , NoIx
- , WithIx
, castOptic
, (%)
, (%%)
@@ -38,25 +37,21 @@ module Optics.Internal.Optic
) where
import Data.Function ((&))
+import Data.Kind (Type)
import Data.Proxy (Proxy (..))
import Data.Type.Equality
import GHC.OverloadedLabels
import GHC.TypeLits
+import Data.Profunctor.Indexed
+
import Optics.Internal.Optic.Subtyping
import Optics.Internal.Optic.TypeLevel
import Optics.Internal.Optic.Types
-import Optics.Internal.Profunctor
-- to make %% simpler
import Unsafe.Coerce (unsafeCoerce)
--- | An alias for an empty index-list
-type NoIx = '[]
-
--- | Singleton index list
-type WithIx i = '[i]
-
-- | Wrapper newtype for the whole family of optics.
--
-- The first parameter @k@ identifies the particular optic kind (e.g. 'A_Lens'
@@ -70,7 +65,7 @@ type WithIx i = '[i]
-- The parameters @s@ and @t@ represent the "big" structure,
-- whereas @a@ and @b@ represent the "small" structure.
--
-newtype Optic (k :: *) (is :: [*]) s t a b = Optic
+newtype Optic (k :: OpticKind) (is :: IxList) s t a b = Optic
{ getOptic :: forall p i. Profunctor p
=> Optic_ k p i (Curry is i) s t a b
}
@@ -94,7 +89,7 @@ type Optic__ p i j s t a b = p i a b -> p j s t
-- | Proxy type for use as an argument to 'implies'.
--
-data IsProxy (k :: *) (l :: *) (p :: * -> * -> * -> *) =
+data IsProxy (k :: Type) (l :: Type) (p :: Type -> Type -> Type -> Type) =
IsProxy
-- | Explicit cast from one optic flavour to another.
@@ -183,7 +178,7 @@ infixl 9 %&
--
-- It shows that usage of 'unsafeCoerce' in '(%%)' is, in fact, safe.
--
-class Append xs ys ~ zs => AppendProof (xs :: [*]) (ys :: [*]) (zs :: [*])
+class Append xs ys ~ zs => AppendProof (xs :: [Type]) (ys :: [Type]) (zs :: [Type])
| xs ys -> zs, zs xs -> ys {- , zs ys -> xs -} where
appendProof :: Proxy i -> Curry xs (Curry ys i) :~: Curry zs i
diff --git a/src/Optics/Internal/Optic/Subtyping.hs b/src/Optics/Internal/Optic/Subtyping.hs
index bc83c88..c0c8648 100644
--- a/src/Optics/Internal/Optic/Subtyping.hs
+++ b/src/Optics/Internal/Optic/Subtyping.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeInType #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-}
@@ -96,7 +97,7 @@ instance Is A_Traversal A_Setter where implies _ = id
-- l@. This means in particular that composition of an @Optic k@ and an @Optic
-- k@ will yield an @Optic (Join k l)@.
--
-type family Join (k :: *) (l :: *) where
+type family Join (k :: OpticKind) (l :: OpticKind) where
-- BEGIN GENERATED CONTENT
-- An_Iso-----
Join An_Iso A_ReversedLens = A_ReversedLens
diff --git a/src/Optics/Internal/Optic/TypeLevel.hs b/src/Optics/Internal/Optic/TypeLevel.hs
index 9c47125..346ed36 100644
--- a/src/Optics/Internal/Optic/TypeLevel.hs
+++ b/src/Optics/Internal/Optic/TypeLevel.hs
@@ -1,15 +1,28 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeInType #-}
{-# OPTIONS_HADDOCK not-home #-}
-- | This module is intended for internal use only, and may change without
-- warning in subsequent releases.
module Optics.Internal.Optic.TypeLevel where
+import Data.Kind (Type)
import GHC.TypeLits
+-- | A list of index types, used for indexed optics.
+--
+-- @since 0.2
+type IxList = [Type]
+
+-- | An alias for an empty index-list
+type NoIx = ('[] :: IxList)
+
+-- | Singleton index list
+type WithIx i = ('[i] :: IxList)
+
-- | Show a type surrounded by quote marks.
-type family QuoteType (x :: *) :: ErrorMessage where
+type family QuoteType (x :: Type) :: ErrorMessage where
QuoteType x = 'Text "‘" ':<>: 'ShowType x ':<>: 'Text "’"
-- | Curry a type-level list.
@@ -19,12 +32,12 @@ type family QuoteType (x :: *) :: ErrorMessage where
-- @
-- 'Curry' xs y = 'foldr' (->) y xs
-- @
-type family Curry (xs :: [*]) (y :: *) :: * where
+type family Curry (xs :: IxList) (y :: Type) :: Type where
Curry '[] y = y
Curry (x ': xs) y = x -> Curry xs y
-- | Append two type-level lists together.
-type family Append (xs :: [*]) (ys :: [*]) :: [*] where
+type family Append (xs :: IxList) (ys :: IxList) :: IxList where
Append '[] ys = ys -- needed for (<%>) and (%>)
Append xs '[] = xs -- needed for (<%)
Append (x ': xs) ys = x ': Append xs ys
diff --git a/src/Optics/Internal/Optic/Types.hs b/src/Optics/Internal/Optic/Types.hs
index 55dac49..b086a4e 100644
--- a/src/Optics/Internal/Optic/Types.hs
+++ b/src/Optics/Internal/Optic/Types.hs
@@ -1,45 +1,53 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeInType #-}
{-# OPTIONS_HADDOCK not-home #-}
-- | This module is intended for internal use only, and may change without
-- warning in subsequent releases.
module Optics.Internal.Optic.Types where
-import GHC.Exts (Constraint)
+import Data.Kind (Constraint, Type)
+
+import Data.Profunctor.Indexed
import Optics.Internal.Bi
-import Optics.Internal.Profunctor
+
+-- | Kind for types used as optic tags, such as 'A_Lens'.
+--
+-- @since 0.2
+type OpticKind = Type
-- | Tag for an iso.
-data An_Iso
+data An_Iso :: OpticKind
-- | Tag for a lens.
-data A_Lens
+data A_Lens :: OpticKind
-- | Tag for a prism.
-data A_Prism
+data A_Prism :: OpticKind
-- | Tag for an affine traversal.
-data An_AffineTraversal
+data An_AffineTraversal :: OpticKind
-- | Tag for a traversal.
-data A_Traversal
+data A_Traversal :: OpticKind
-- | Tag for a setter.
-data A_Setter
+data A_Setter :: OpticKind
-- | Tag for a reversed prism.
-data A_ReversedPrism
+data A_ReversedPrism :: OpticKind
-- | Tag for a getter.
-data A_Getter
+data A_Getter :: OpticKind
-- | Tag for an affine fold.
-data An_AffineFold
+data An_AffineFold :: OpticKind
-- | Tag for a fold.
-data A_Fold
+data A_Fold :: OpticKind
-- | Tag for a reversed lens.
-data A_ReversedLens
+data A_ReversedLens :: OpticKind
-- | Tag for a review.
-data A_Review
+data A_Review :: OpticKind
-- | Mapping tag types @k@ to constraints on @p@.
--
-- Using this type family we define the constraints that the various flavours of
-- optics have to fulfill.
--
-type family Constraints (k :: *) (p :: * -> * -> * -> *) :: Constraint where
+type family Constraints (k :: OpticKind) (p :: Type -> Type -> Type -> Type) :: Constraint where
Constraints An_Iso p = Profunctor p
Constraints A_Lens p = Strong p
Constraints A_ReversedLens p = Costrong p
diff --git a/src/Optics/Internal/Profunctor.hs b/src/Optics/Internal/Profunctor.hs
deleted file mode 100644
index 7382331..0000000
--- a/src/Optics/Internal/Profunctor.hs
+++ /dev/null
@@ -1,705 +0,0 @@
-{-# OPTIONS_HADDOCK not-home #-}
-
--- | Definitions of concrete profunctors and profunctor classes.
---
--- This module is intended for internal use only, and may change without warning
--- in subsequent releases.
-module Optics.Internal.Profunctor where
-
-import Data.Coerce (Coercible, coerce)
-import Data.Functor.Const
-import Data.Functor.Identity
-
-import Optics.Internal.Utils
-
-----------------------------------------
--- Concrete profunctors
-
--- | Needed for traversals.
-newtype Star f i a b = Star { runStar :: a -> f b }
-
--- | Needed for getters and folds.
-newtype Forget r i a b = Forget { runForget :: a -> r }
-
--- | Needed for affine folds.
-newtype ForgetM r i a b = ForgetM { runForgetM :: a -> Maybe r }
-
--- | Needed for setters.
-newtype FunArrow i a b = FunArrow { runFunArrow :: a -> b }
-
--- | Needed for indexed traversals.
-newtype IxStar f i a b = IxStar { runIxStar :: i -> a -> f b }
-
--- | Needed for indexed folds.
-newtype IxForget r i a b = IxForget { runIxForget :: i -> a -> r }
-
--- | Needed for indexed affine folds.
-newtype IxForgetM r i a b = IxForgetM { runIxForgetM :: i -> a -> Maybe r }
-
--- | Needed for indexed setters.
-newtype IxFunArrow i a b = IxFunArrow { runIxFunArrow :: i -> a -> b }
-
-----------------------------------------
--- Utils
-
--- Needed for strict application of (indexed) setters.
---
--- Credit for this goes to Eric Mertens, see
--- <https://github.com/glguy/irc-core/commit/2d5fc45b05f1>.
-data Identity' a = Identity' {-# UNPACK #-} !() a
- deriving Functor
-
-instance Applicative Identity' where
- pure a = Identity' () a
- {-# INLINE pure #-}
- Identity' () f <*> Identity' () x = Identity' () (f x)
- {-# INLINE (<*>) #-}
-
--- | Mark a value for evaluation to whnf.
---
--- This allows us to, when applying a setter to a structure, evaluate only the
--- parts that we modify. If an optic focuses on multiple targets, Applicative
--- instance of Identity' makes sure that we force evaluation of all of them, but
--- we leave anything else alone.
---
-wrapIdentity' :: a -> Identity' a
-wrapIdentity' a = Identity' (a `seq` ()) a
-{-# INLINE wrapIdentity' #-}
-
-unwrapIdentity' :: Identity' a -> a
-unwrapIdentity' (Identity' () a) = a
-{-# INLINE unwrapIdentity' #-}
-
-----------------------------------------
-
--- | Needed for conversion of affine traversal back to its VL representation.
-data StarA f i a b = StarA (forall r. r -> f r) (a -> f b)
-
--- | Unwrap 'StarA'.
-runStarA :: StarA f i a b -> a -> f b
-runStarA (StarA _ k) = k
-{-# INLINE runStarA #-}
-
--- | Needed for conversion of indexed affine traversal back to its VL
--- representation.
-data IxStarA f i a b = IxStarA (forall r. r -> f r) (i -> a -> f b)
-
--- | Unwrap 'StarA'.
-runIxStarA :: IxStarA f i a b -> i -> a -> f b
-runIxStarA (IxStarA _ k) = k
-{-# INLINE runIxStarA #-}
-
-----------------------------------------
-
--- | Repack 'Star' to change its index type.
-reStar :: Star f i a b -> Star f j a b
-reStar (Star k) = Star k
-{-# INLINE reStar #-}
-
--- | Repack 'Forget' to change its index type.
-reForget :: Forget r i a b -> Forget r j a b
-reForget (Forget k) = Forget k
-{-# INLINE reForget #-}
-
--- | Repack 'FunArrow' to change its index type.
-reFunArrow :: FunArrow i a b -> FunArrow j a b
-reFunArrow (FunArrow k) = FunArrow k
-{-# INLINE reFunArrow #-}
-
-----------------------------------------
--- Classes and instances
-
-class Profunctor p where
- dimap :: (a -> b) -> (c -> d) -> p i b c -> p i a d
- lmap :: (a -> b) -> p i b c -> p i a c
- rmap :: (c -> d) -> p i b c -> p i b d
-
- lcoerce' :: Coercible a b => p i a c -> p i b c
- default lcoerce'
- :: Coercible (p i a c) (p i b c)
- => p i a c
- -> p i b c
- lcoerce' = coerce
- {-# INLINE lcoerce' #-}
-
- rcoerce' :: Coercible a b => p i c a -> p i c b
- default rcoerce'
- :: Coercible (p i c a) (p i c b)
- => p i c a
- -> p i c b
- rcoerce' = coerce
- {-# INLINE rcoerce' #-}
-
- conjoined__
- :: (p i a b -> p i s t)
- -> (p i a b -> p j s t)
- -> (p i a b -> p j s t)
- default conjoined__
- :: Coercible (p i s t) (p j s t)
- => (p i a b -> p i s t)
- -> (p i a b -> p j s t)
- -> (p i a b -> p j s t)
- conjoined__ f _ = coerce . f
- {-# INLINE conjoined__ #-}
-
- ixcontramap :: (j -> i) -> p i a b -> p j a b
- default ixcontramap
- :: Coercible (p i a b) (p j a b)
- => (j -> i)
- -> p i a b
- -> p j a b
- ixcontramap _ = coerce
- {-# INLINE ixcontramap #-}
-
--- | 'rcoerce'' with type arguments rearranged for TypeApplications.
-rcoerce :: (Coercible a b, Profunctor p) => p i c a -> p i c b
-rcoerce = rcoerce'
-{-# INLINE rcoerce #-}
-
--- | 'lcoerce'' with type arguments rearranged for TypeApplications.
-lcoerce :: (Coercible a b, Profunctor p) => p i a c -> p i b c
-lcoerce = lcoerce'
-{-# INLINE lcoerce #-}
-
-instance Functor f => Profunctor (StarA f) where
- dimap f g (StarA point k) = StarA point (fmap g . k . f)
- lmap f (StarA point k) = StarA point (k . f)
- rmap g (StarA point k) = StarA point (fmap g . k)
- {-# INLINE dimap #-}
- {-# INLINE lmap #-}
- {-# INLINE rmap #-}
-
- rcoerce' = rmap coerce
- {-# INLINE rcoerce' #-}
-
-instance Functor f => Profunctor (Star f) where
- dimap f g (Star k) = Star (fmap g . k . f)
- lmap f (Star k) = Star (k . f)
- rmap g (Star k) = Star (fmap g . k)
- {-# INLINE dimap #-}
- {-# INLINE lmap #-}
- {-# INLINE rmap #-}
-
- rcoerce' = rmap coerce
- {-# INLINE rcoerce' #-}
-
-instance Profunctor (Forget r) where
- dimap f _ (Forget k) = Forget (k . f)
- lmap f (Forget k) = Forget (k . f)
- rmap _g (Forget k) = Forget k
- {-# INLINE dimap #-}
- {-# INLINE lmap #-}
- {-# INLINE rmap #-}
-
-instance Profunctor (ForgetM r) where
- dimap f _ (ForgetM k) = ForgetM (k . f)
- lmap f (ForgetM k) = ForgetM (k . f)
- rmap _g (ForgetM k) = ForgetM k
- {-# INLINE dimap #-}
- {-# INLINE lmap #-}
- {-# INLINE rmap #-}
-
-instance Profunctor FunArrow where
- dimap f g (FunArrow k) = FunArrow (g . k . f)
- lmap f (FunArrow k) = FunArrow (k . f)
- rmap g (FunArrow k) = FunArrow (g . k)
- {-# INLINE dimap #-}
- {-# INLINE lmap #-}
- {-# INLINE rmap #-}
-
-instance Functor f => Profunctor (IxStarA f) where
- dimap f g (IxStarA point k) = IxStarA point (\i -> fmap g . k i . f)
- lmap f (IxStarA point k) = IxStarA point (\i -> k i . f)
- rmap g (IxStarA point k) = IxStarA point (\i -> fmap g . k i)
- {-# INLINE dimap #-}
- {-# INLINE lmap #-}
- {-# INLINE rmap #-}
-
- rcoerce' = rmap coerce
- {-# INLINE rcoerce' #-}
-
- conjoined__ _ f = f
- ixcontramap ij (IxStarA point k) = IxStarA point $ \i -> k (ij i)
- {-# INLINE conjoined__ #-}
- {-# INLINE ixcontramap #-}
-
-instance Functor f => Profunctor (IxStar f) where
- dimap f g (IxStar k) = IxStar (\i -> fmap g . k i . f)
- lmap f (IxStar k) = IxStar (\i -> k i . f)
- rmap g (IxStar k) = IxStar (\i -> fmap g . k i)
- {-# INLINE dimap #-}
- {-# INLINE lmap #-}
- {-# INLINE rmap #-}
-
- rcoerce' = rmap coerce
- {-# INLINE rcoerce' #-}
-
- conjoined__ _ f = f
- ixcontramap ij (IxStar k) = IxStar $ \i -> k (ij i)
- {-# INLINE conjoined__ #-}
- {-# INLINE ixcontramap #-}
-
-instance Profunctor (IxForget r) where
- dimap f _ (IxForget k) = IxForget (\i -> k i . f)
- lmap f (IxForget k) = IxForget (\i -> k i . f)
- rmap _g (IxForget k) = IxForget k
- {-# INLINE dimap #-}
- {-# INLINE lmap #-}
- {-# INLINE rmap #-}
-
- conjoined__ _ f = f
- ixcontramap ij (IxForget k) = IxForget $ \i -> k (ij i)
- {-# INLINE conjoined__ #-}
- {-# INLINE ixcontramap #-}
-
-instance Profunctor (IxForgetM r) where
- dimap f _ (IxForgetM k) = IxForgetM (\i -> k i . f)
- lmap f (IxForgetM k) = IxForgetM (\i -> k i . f)
- rmap _g (IxForgetM k) = IxForgetM k
- {-# INLINE dimap #-}
- {-# INLINE lmap #-}
- {-# INLINE rmap #-}
-
- conjoined__ _ f = f
- ixcontramap ij (IxForgetM k) = IxForgetM $ \i -> k (ij i)
- {-# INLINE conjoined__ #-}
- {-# INLINE ixcontramap #-}
-
-instance Profunctor IxFunArrow where
- dimap f g (IxFunArrow k) = IxFunArrow (\i -> g . k i . f)
- lmap f (IxFunArrow k) = IxFunArrow (\i -> k i . f)
- rmap g (IxFunArrow k) = IxFunArrow (\i -> g . k i)
- {-# INLINE dimap #-}
- {-# INLINE lmap #-}
- {-# INLINE rmap #-}
-
- conjoined__ _ f = f
- ixcontramap ij (IxFunArrow k) = IxFunArrow $ \i -> k (ij i)
- {-# INLINE conjoined__ #-}
- {-# INLINE ixcontramap #-}
-
-----------------------------------------
-
-class Profunctor p => Strong p where
- first' :: p i a b -> p i (a, c) (b, c)
- second' :: p i a b -> p i (c, a) (c, b)
-
- -- There are a few places where default implementation is good enough.
- linear
- :: (forall f. Functor f => (a -> f b) -> s -> f t)
- -> p i a b
- -> p i s t
- linear f = dimap
- ((\(Context bt a) -> (a, bt)) . f (Context id))
- (\(b, bt) -> bt b)
- . first'
- {-# INLINE linear #-}
-
- -- There are a few places where default implementation is good enough.
- ilinear
- :: (forall f. Functor f => (i -> a -> f b) -> s -> f t)
- -> p j a b
- -> p (i -> j) s t
- default ilinear
- :: Coercible (p j s t) (p (i -> j) s t)
- => (forall f. Functor f => (i -> a -> f b) -> s -> f t)
- -> p j a b
- -> p (i -> j) s t
- ilinear f = coerce . linear (\afb -> f $ \_ -> afb)
- {-# INLINE ilinear #-}
-
-instance Functor f => Strong (StarA f) where
- first' (StarA point k) = StarA point $ \ ~(a, c) -> (\b' -> (b', c)) <$> k a
- second' (StarA point k) = StarA point $ \ ~(c, a) -> (,) c <$> k a
- {-# INLINE first' #-}
- {-# INLINE second' #-}
-
- linear f (StarA point k) = StarA point (f k)
- {-# INLINE linear #-}
-
-instance Functor f => Strong (Star f) where
- first' (Star k) = Star $ \ ~(a, c) -> (\b' -> (b', c)) <$> k a
- second' (Star k) = Star $ \ ~(c, a) -> (,) c <$> k a
- {-# INLINE first' #-}
- {-# INLINE second' #-}
-
- linear f (Star k) = Star (f k)
- {-# INLINE linear #-}
-
-instance Strong (Forget r) where
- first' (Forget k) = Forget (k . fst)
- second' (Forget k) = Forget (k . snd)
- {-# INLINE first' #-}
- {-# INLINE second' #-}
-
- linear f (Forget k) = Forget (getConst #. f (Const #. k))
- {-# INLINE linear #-}
-
-instance Strong (ForgetM r) where
- first' (ForgetM k) = ForgetM (k . fst)
- second' (ForgetM k) = ForgetM (k . snd)
- {-# INLINE first' #-}
- {-# INLINE second' #-}
-
- linear f (ForgetM k) = ForgetM (getConst #. f (Const #. k))
- {-# INLINE linear #-}
-
-instance Strong FunArrow where
- first' (FunArrow k) = FunArrow $ \ ~(a, c) -> (k a, c)
- second' (FunArrow k) = FunArrow $ \ ~(c, a) -> (c, k a)
- {-# INLINE first' #-}
- {-# INLINE second' #-}
-
- linear f (FunArrow k) = FunArrow $ runIdentity #. f (Identity #. k)
- {-# INLINE linear #-}
-
-instance Functor f => Strong (IxStarA f) where
- first' (IxStarA point k) = IxStarA point $ \i ~(a, c) -> (\b' -> (b', c)) <$> k i a
- second' (IxStarA point k) = IxStarA point $ \i ~(c, a) -> (,) c <$> k i a
- {-# INLINE first' #-}
- {-# INLINE second' #-}
-
- linear f (IxStarA point k) = IxStarA point $ \i -> f (k i)
- ilinear f (IxStarA point k) = IxStarA point $ \ij -> f $ \i -> k (ij i)
- {-# INLINE linear #-}
- {-# INLINE ilinear #-}
-
-instance Functor f => Strong (IxStar f) where
- first' (IxStar k) = IxStar $ \i ~(a, c) -> (\b' -> (b', c)) <$> k i a
- second' (IxStar k) = IxStar $ \i ~(c, a) -> (,) c <$> k i a
- {-# INLINE first' #-}
- {-# INLINE second' #-}
-
- linear f (IxStar k) = IxStar $ \i -> f (k i)
- ilinear f (IxStar k) = IxStar $ \ij -> f $ \i -> k (ij i)
- {-# INLINE linear #-}
- {-# INLINE ilinear #-}
-
-instance Strong (IxForget r) where
- first' (IxForget k) = IxForget $ \i -> k i . fst
- second' (IxForget k) = IxForget $ \i -> k i . snd
- {-# INLINE first' #-}
- {-# INLINE second' #-}
-
- linear f (IxForget k) = IxForget $ \i -> getConst #. f (Const #. k i)
- ilinear f (IxForget k) = IxForget $ \ij -> getConst #. f (\i -> Const #. k (ij i))
- {-# INLINE linear #-}
- {-# INLINE ilinear #-}
-
-instance Strong (IxForgetM r) where
- first' (IxForgetM k) = IxForgetM $ \i -> k i . fst
- second' (IxForgetM k) = IxForgetM $ \i -> k i . snd
- {-# INLINE first' #-}
- {-# INLINE second' #-}
-
- linear f (IxForgetM k) = IxForgetM $ \i -> getConst #. f (Const #. k i)
- ilinear f (IxForgetM k) = IxForgetM $ \ij -> getConst #. f (\i -> Const #. k (ij i))
- {-# INLINE linear #-}
- {-# INLINE ilinear #-}
-
-instance Strong IxFunArrow where
- first' (IxFunArrow k) = IxFunArrow $ \i ~(a, c) -> (k i a, c)
- second' (IxFunArrow k) = IxFunArrow $ \i ~(c, a) -> (c, k i a)
- {-# INLINE first' #-}
- {-# INLINE second' #-}
-
- linear f (IxFunArrow k) = IxFunArrow $ \i ->
- runIdentity #. f (Identity #. k i)
- ilinear f (IxFunArrow k) = IxFunArrow $ \ij ->
- runIdentity #. f (\i -> Identity #. k (ij i))
- {-# INLINE linear #-}
- {-# INLINE ilinear #-}
-
-----------------------------------------
-
-class Profunctor p => Costrong p where
- unfirst :: p i (a, d) (b, d) -> p i a b
- unsecond :: p i (d, a) (d, b) -> p i a b
-
-----------------------------------------
-
-class Profunctor p => Choice p where
- left' :: p i a b -> p i (Either a c) (Either b c)
- right' :: p i a b -> p i (Either c a) (Either c b)
-
-instance Functor f => Choice (StarA f) where
- left' (StarA point k) = StarA point $ either (fmap Left . k) (point . Right)
- right' (StarA point k) = StarA point $ either (point . Left) (fmap Right . k)
- {-# INLINE left' #-}
- {-# INLINE right' #-}
-
-instance Applicative f => Choice (Star f) where
- left' (Star k) = Star $ either (fmap Left . k) (pure . Right)
- right' (Star k) = Star $ either (pure . Left) (fmap Right . k)
- {-# INLINE left' #-}
- {-# INLINE right' #-}
-
-instance Monoid r => Choice (Forget r) where
- left' (Forget k) = Forget $ either k (const mempty)
- right' (Forget k) = Forget $ either (const mempty) k
- {-# INLINE left' #-}
- {-# INLINE right' #-}
-
-instance Choice (ForgetM r) where
- left' (ForgetM k) = ForgetM $ either k (const Nothing)
- right' (ForgetM k) = ForgetM $ either (const Nothing) k
- {-# INLINE left' #-}
- {-# INLINE right' #-}
-
-instance Choice FunArrow where
- left' (FunArrow k) = FunArrow $ either (Left . k) Right
- right' (FunArrow k) = FunArrow $ either Left (Right . k)
- {-# INLINE left' #-}
- {-# INLINE right' #-}
-
-instance Functor f => Choice (IxStarA f) where
- left' (IxStarA point k) =
- IxStarA point $ \i -> either (fmap Left . k i) (point . Right)
- right' (IxStarA point k) =
- IxStarA point $ \i -> either (point . Left) (fmap Right . k i)
- {-# INLINE left' #-}
- {-# INLINE right' #-}
-
-instance Applicative f => Choice (IxStar f) where
- left' (IxStar k) = IxStar $ \i -> either (fmap Left . k i) (pure . Right)
- right' (IxStar k) = IxStar $ \i -> either (pure . Left) (fmap Right . k i)
- {-# INLINE left' #-}
- {-# INLINE right' #-}
-
-instance Monoid r => Choice (IxForget r) where
- left' (IxForget k) = IxForget $ \i -> either (k i) (const mempty)
- right' (IxForget k) = IxForget $ \i -> either (const mempty) (k i)
- {-# INLINE left' #-}
- {-# INLINE right' #-}
-
-instance Choice (IxForgetM r) where
- left' (IxForgetM k) = IxForgetM $ \i -> either (k i) (const Nothing)
- right' (IxForgetM k) = IxForgetM $ \i -> either (const Nothing) (k i)
- {-# INLINE left' #-}
- {-# INLINE right' #-}
-
-instance Choice IxFunArrow where
- left' (IxFunArrow k) = IxFunArrow $ \i -> either (Left . k i) Right
- right' (IxFunArrow k) = IxFunArrow $ \i -> either Left (Right . k i)
- {-# INLINE left' #-}
- {-# INLINE right' #-}
-
-----------------------------------------
-
-class Profunctor p => Cochoice p where
- unleft :: p i (Either a d) (Either b d) -> p i a b
- unright :: p i (Either d a) (Either d b) -> p i a b
-
-instance Cochoice (Forget r) where
- unleft (Forget k) = Forget (k . Left)
- unright (Forget k) = Forget (k . Right)
- {-# INLINE unleft #-}
- {-# INLINE unright #-}
-
-instance Cochoice (ForgetM r) where
- unleft (ForgetM k) = ForgetM (k . Left)
- unright (ForgetM k) = ForgetM (k . Right)
- {-# INLINE unleft #-}
- {-# INLINE unright #-}
-
-instance Cochoice (IxForget r) where
- unleft (IxForget k) = IxForget $ \i -> k i . Left
- unright (IxForget k) = IxForget $ \i -> k i . Right
- {-# INLINE unleft #-}
- {-# INLINE unright #-}
-
-instance Cochoice (IxForgetM r) where
- unleft (IxForgetM k) = IxForgetM (\i -> k i . Left)
- unright (IxForgetM k) = IxForgetM (\i -> k i . Right)
- {-# INLINE unleft #-}
- {-# INLINE unright #-}
-
-----------------------------------------
-
-class (Choice p, Strong p) => Visiting p where
- visit
- :: forall i s t a b
- . (forall f. Functor f => (forall r. r -> f r) -> (a -> f b) -> s -> f t)
- -> p i a b
- -> p i s t
- visit f =
- let match :: s -> Either a t
- match s = f Right Left s
- update :: s -> b -> t
- update s b = runIdentity $ f Identity (\_ -> Identity b) s
- in dimap (\s -> (match s, s))
- (\(ebt, s) -> either (update s) id ebt)
- . first'
- . left'
- {-# INLINE visit #-}
-
- ivisit
- :: (forall f. Functor f => (forall r. r -> f r) -> (i -> a -> f b) -> s -> f t)
- -> p j a b
- -> p (i -> j) s t
- default ivisit
- :: Coercible (p j s t) (p (i -> j) s t)
- => (forall f. Functor f => (forall r. r -> f r) -> (i -> a -> f b) -> s -> f t)
- -> p j a b
- -> p (i -> j) s t
- ivisit f = coerce . visit (\point afb -> f point $ \_ -> afb)
- {-# INLINE ivisit #-}
-
-
-instance Functor f => Visiting (StarA f) where
- visit f (StarA point k) = StarA point $ f point k
- ivisit f (StarA point k) = StarA point $ f point (\_ -> k)
- {-# INLINE visit #-}
- {-# INLINE ivisit #-}
-
-instance Applicative f => Visiting (Star f) where
- visit f (Star k) = Star $ f pure k
- ivisit f (Star k) = Star $ f pure (\_ -> k)
- {-# INLINE visit #-}
- {-# INLINE ivisit #-}
-
-instance Monoid r => Visiting (Forget r) where
- visit f (Forget k) = Forget $ getConst #. f pure (Const #. k)
- ivisit f (Forget k) = Forget $ getConst #. f pure (\_ -> Const #. k)
- {-# INLINE visit #-}
- {-# INLINE ivisit #-}
-
-instance Visiting (ForgetM r) where
- visit f (ForgetM k) =
- ForgetM $ getConst #. f (\_ -> Const Nothing) (Const #. k)
- ivisit f (ForgetM k) =
- ForgetM $ getConst #. f (\_ -> Const Nothing) (\_ -> Const #. k)
- {-# INLINE visit #-}
- {-# INLINE ivisit #-}
-
-instance Visiting FunArrow where
- visit f (FunArrow k) = FunArrow $ runIdentity #. f pure (Identity #. k)
- ivisit f (FunArrow k) = FunArrow $ runIdentity #. f pure (\_ -> Identity #. k)
- {-# INLINE visit #-}
- {-# INLINE ivisit #-}
-
-instance Functor f => Visiting (IxStarA f) where
- visit f (IxStarA point k) = IxStarA point $ \i -> f point (k i)
- ivisit f (IxStarA point k) = IxStarA point $ \ij -> f point $ \i -> k (ij i)
- {-# INLINE visit #-}
- {-# INLINE ivisit #-}
-
-instance Applicative f => Visiting (IxStar f) where
- visit f (IxStar k) = IxStar $ \i -> f pure (k i)
- ivisit f (IxStar k) = IxStar $ \ij -> f pure $ \i -> k (ij i)
- {-# INLINE visit #-}
- {-# INLINE ivisit #-}
-
-instance Monoid r => Visiting (IxForget r) where
- visit f (IxForget k) =
- IxForget $ \i -> getConst #. f pure (Const #. k i)
- ivisit f (IxForget k) =
- IxForget $ \ij -> getConst #. f pure (\i -> Const #. k (ij i))
- {-# INLINE visit #-}
- {-# INLINE ivisit #-}
-
-instance Visiting (IxForgetM r) where
- visit f (IxForgetM k) =
- IxForgetM $ \i -> getConst #. f (\_ -> Const Nothing) (Const #. k i)
- ivisit f (IxForgetM k) =
- IxForgetM $ \ij -> getConst #. f (\_ -> Const Nothing) (\i -> Const #. k (ij i))
- {-# INLINE visit #-}
- {-# INLINE ivisit #-}
-
-instance Visiting IxFunArrow where
- visit f (IxFunArrow k) =
- IxFunArrow $ \i -> runIdentity #. f pure (Identity #. k i)
- ivisit f (IxFunArrow k) =
- IxFunArrow $ \ij -> runIdentity #. f pure (\i -> Identity #. k (ij i))
- {-# INLINE visit #-}
- {-# INLINE ivisit #-}
-
-----------------------------------------
-
-class Visiting p => Traversing p where
- wander
- :: (forall f. Applicative f => (a -> f b) -> s -> f t)
- -> p i a b
- -> p i s t
- iwander
- :: (forall f. Applicative f => (i -> a -> f b) -> s -> f t)
- -> p j a b
- -> p (i -> j) s t
-
-instance Applicative f => Traversing (Star f) where
- wander f (Star k) = Star $ f k
- iwander f (Star k) = Star $ f (\_ -> k)
- {-# INLINE wander #-}
- {-# INLINE iwander #-}
-
-instance Monoid r => Traversing (Forget r) where
- wander f (Forget k) = Forget $ getConst #. f (Const #. k)
- iwander f (Forget k) = Forget $ getConst #. f (\_ -> Const #. k)
- {-# INLINE wander #-}
- {-# INLINE iwander #-}
-
-instance Traversing FunArrow where
- wander f (FunArrow k) = FunArrow $ runIdentity #. f (Identity #. k)
- iwander f (FunArrow k) = FunArrow $ runIdentity #. f (\_ -> Identity #. k)
- {-# INLINE wander #-}
- {-# INLINE iwander #-}
-
-instance Applicative f => Traversing (IxStar f) where
- wander f (IxStar k) = IxStar $ \i -> f (k i)
- iwander f (IxStar k) = IxStar $ \ij -> f $ \i -> k (ij i)
- {-# INLINE wander #-}
- {-# INLINE iwander #-}
-
-instance Monoid r => Traversing (IxForget r) where
- wander f (IxForget k) =
- IxForget $ \i -> getConst #. f (Const #. k i)
- iwander f (IxForget k) =
- IxForget $ \ij -> getConst #. f (\i -> Const #. k (ij i))
- {-# INLINE wander #-}
- {-# INLINE iwander #-}
-
-instance Traversing IxFunArrow where
- wander f (IxFunArrow k) =
- IxFunArrow $ \i -> runIdentity #. f (Identity #. k i)
- iwander f (IxFunArrow k) =
- IxFunArrow $ \ij -> runIdentity #. f (\i -> Identity #. k (ij i))
- {-# INLINE wander #-}
- {-# INLINE iwander #-}
-
-----------------------------------------
-
-class Traversing p => Mapping p where
- roam
- :: ((a -> b) -> s -> t)
- -> p i a b
- -> p i s t
- iroam
- :: ((i -> a -> b) -> s -> t)
- -> p j a b
- -> p (i -> j) s t
-
-instance Mapping (Star Identity') where
- roam f (Star k) = Star $ wrapIdentity' . f (unwrapIdentity' . k)
- iroam f (Star k) = Star $ wrapIdentity' . f (\_ -> unwrapIdentity' . k)
- {-# INLINE roam #-}
- {-# INLINE iroam #-}
-
-instance Mapping FunArrow where
- roam f (FunArrow k) = FunArrow $ f k
- iroam f (FunArrow k) = FunArrow $ f (const k)
- {-# INLINE roam #-}
- {-# INLINE iroam #-}
-
-instance Mapping (IxStar Identity') where
- roam f (IxStar k) =
- IxStar $ \i -> wrapIdentity' . f (unwrapIdentity' . k i)
- iroam f (IxStar k) =
- IxStar $ \ij -> wrapIdentity' . f (\i -> unwrapIdentity' . k (ij i))
- {-# INLINE roam #-}
- {-# INLINE iroam #-}
-
-instance Mapping IxFunArrow where
- roam f (IxFunArrow k) = IxFunArrow $ \i -> f (k i)
- iroam f (IxFunArrow k) = IxFunArrow $ \ij -> f $ \i -> k (ij i)
- {-# INLINE roam #-}
- {-# INLINE iroam #-}
diff --git a/src/Optics/Internal/Setter.hs b/src/Optics/Internal/Setter.hs
index 0b793f5..534723a 100644
--- a/src/Optics/Internal/Setter.hs
+++ b/src/Optics/Internal/Setter.hs
@@ -6,7 +6,8 @@
-- in subsequent releases.
module Optics.Internal.Setter where
-import Optics.Internal.Profunctor
+import Data.Profunctor.Indexed
+
import Optics.Internal.Optic
-- | Internal implementation of 'Optics.Setter.mapped'.
diff --git a/src/Optics/Internal/Tagged.hs b/src/Optics/Internal/Tagged.hs
deleted file mode 100644
index f2b9d91..0000000
--- a/src/Optics/Internal/Tagged.hs
+++ /dev/null
@@ -1,50 +0,0 @@
-{-# OPTIONS_HADDOCK not-home #-}
-
--- | Based on the @tagged@ package.
---
--- This module is intended for internal use only, and may change without warning
--- in subsequent releases.
---
-module Optics.Internal.Tagged where
-
-import Data.Coerce
-
-import Optics.Internal.Bi
-import Optics.Internal.Profunctor
-import Optics.Internal.Utils
-
--- | Tag a value with not one but two phantom type parameters (so that 'Tagged'
--- can be used as an indexed profunctor).
-newtype Tagged i a b = Tagged { unTagged :: b }
-
-instance Functor (Tagged i a) where
- fmap f = Tagged #. f .# unTagged
- {-# INLINE fmap #-}
-
-instance Bifunctor Tagged where
- bimap _f g = Tagged #. g .# unTagged
- first _f = coerce
- second g = Tagged #. g .# unTagged
- {-# INLINE bimap #-}
- {-# INLINE first #-}
- {-# INLINE second #-}
-
-instance Profunctor Tagged where
- dimap _f g = Tagged #. g .# unTagged
- lmap _f = coerce
- rmap g = Tagged #. g .# unTagged
- {-# INLINE dimap #-}
- {-# INLINE lmap #-}
- {-# INLINE rmap #-}
-
-instance Choice Tagged where
- left' = Tagged #. Left .# unTagged
- right' = Tagged #. Right .# unTagged
- {-# INLINE left' #-}
- {-# INLINE right' #-}
-
-instance Costrong Tagged where
- unfirst (Tagged bd) = Tagged (fst bd)
- unsecond (Tagged db) = Tagged (snd db)
- {-# INLINE unfirst #-}
- {-# INLINE unsecond #-}
diff --git a/src/Optics/Internal/Traversal.hs b/src/Optics/Internal/Traversal.hs
index 0d843a9..2a379af 100644
--- a/src/Optics/Internal/Traversal.hs
+++ b/src/Optics/Internal/Traversal.hs
@@ -6,8 +6,9 @@
-- in subsequent releases.
module Optics.Internal.Traversal where
+import Data.Profunctor.Indexed
+
import Optics.Internal.Optic
-import Optics.Internal.Profunctor
import Optics.Internal.Fold
import Optics.Internal.Setter
diff --git a/src/Optics/Internal/Utils.hs b/src/Optics/Internal/Utils.hs
index a73f4ca..cb5c72d 100644
--- a/src/Optics/Internal/Utils.hs
+++ b/src/Optics/Internal/Utils.hs
@@ -2,29 +2,67 @@
-- | This module is intended for internal use only, and may change without warning
-- in subsequent releases.
-module Optics.Internal.Utils where
+module Optics.Internal.Utils
+ ( Identity'(..)
+ , wrapIdentity'
+ , unwrapIdentity'
+
+ , Traversed(..)
+ , runTraversed
+
+ , OrT(..)
+ , wrapOrT
+
+ , (#.)
+ , (.#)
+ ) where
-import Data.Coerce
import qualified Data.Semigroup as SG
-data Context a b t = Context (b -> t) a
+import Data.Profunctor.Indexed
+
+-- Needed for strict application of (indexed) setters.
+--
+-- Credit for this goes to Eric Mertens, see
+-- <https://github.com/glguy/irc-core/commit/2d5fc45b05f1>.
+data Identity' a = Identity' {-# UNPACK #-} !() a
deriving Functor
--- | Composition operator where the first argument must be an identity
--- function up to representational equivalence (e.g. a newtype wrapper
--- or unwrapper), and will be ignored at runtime.
-(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c)
-(#.) _f = coerce
-infixl 8 .#
-{-# INLINE (#.) #-}
-
--- | Composition operator where the second argument must be an
--- identity function up to representational equivalence (e.g. a
--- newtype wrapper or unwrapper), and will be ignored at runtime.
-(.#) :: Coercible a b => (b -> c) -> (a -> b) -> (a -> c)
-(.#) f _g = coerce f
-infixr 9 #.
-{-# INLINE (.#) #-}
+instance Applicative Identity' where
+ pure a = Identity' () a
+ {-# INLINE pure #-}
+ Identity' () f <*> Identity' () x = Identity' () (f x)
+ {-# INLINE (<*>) #-}
+
+instance Mapping (Star Identity') where
+ roam f (Star k) = Star $ wrapIdentity' . f (unwrapIdentity' . k)
+ iroam f (Star k) = Star $ wrapIdentity' . f (\_ -> unwrapIdentity' . k)
+ {-# INLINE roam #-}
+ {-# INLINE iroam #-}
+
+instance Mapping (IxStar Identity') where
+ roam f (IxStar k) =
+ IxStar $ \i -> wrapIdentity' . f (unwrapIdentity' . k i)
+ iroam f (IxStar k) =
+ IxStar $ \ij -> wrapIdentity' . f (\i -> unwrapIdentity' . k (ij i))
+ {-# INLINE roam #-}
+ {-# INLINE iroam #-}
+
+
+-- | Mark a value for evaluation to whnf.
+--
+-- This allows us to, when applying a setter to a structure, evaluate only the
+-- parts that we modify. If an optic focuses on multiple targets, Applicative
+-- instance of Identity' makes sure that we force evaluation of all of them, but
+-- we leave anything else alone.
+--
+wrapIdentity' :: a -> Identity' a
+wrapIdentity' a = Identity' (a `seq` ()) a
+{-# INLINE wrapIdentity' #-}
+
+unwrapIdentity' :: Identity' a -> a
+unwrapIdentity' (Identity' () a) = a
+{-# INLINE unwrapIdentity' #-}
----------------------------------------
diff --git a/src/Optics/Iso.hs b/src/Optics/Iso.hs
index 48647ac..cf53f7c 100644
--- a/src/Optics/Iso.hs
+++ b/src/Optics/Iso.hs
@@ -21,14 +21,22 @@ module Optics.Iso
-- specialise types to obtain:
--
-- @
- -- 'Optics.Getter.view' :: 'Iso' s t a b -> s -> a
- -- 'Optics.Review.review' :: 'Iso' s t a b -> b -> t
+ -- 'Optics.Getter.view' :: 'Iso'' s a -> s -> a
+ -- 'Optics.Review.review' :: 'Iso'' s a -> a -> s
-- @
--
-- @
-- 'Optics.Setter.over' :: 'Iso' s t a b -> (a -> b) -> s -> t
-- 'Optics.Setter.set' :: 'Iso' s t a b -> b -> s -> t
-- @
+ --
+ -- If you want to 'Optics.Getter.view' a type-modifying 'Iso' that is
+ -- insufficiently polymorphic to be used as a type-preserving 'Iso'', use
+ -- 'Optics.ReadOnly.getting':
+ --
+ -- @
+ -- 'Optics.Getter.view' . 'Optics.ReadOnly.getting' :: 'Iso' s t a b -> s -> a
+ -- @
-- * Computation
-- |
@@ -52,6 +60,9 @@ module Optics.Iso
, coerced
, coercedTo
, coerced1
+ , non
+ , non'
+ , anon
, curried
, uncurried
, flipped
@@ -80,10 +91,14 @@ module Optics.Iso
import Data.Tuple
import Data.Bifunctor
import Data.Coerce
+import Data.Maybe
+
+import Data.Profunctor.Indexed
-import Optics.Internal.Concrete
+import Optics.AffineFold
+import Optics.Prism
+import Optics.Review
import Optics.Internal.Optic
-import Optics.Internal.Profunctor
-- | Type synonym for a type-modifying iso.
type Iso s t a b = Optic An_Iso NoIx s t a b
@@ -190,6 +205,96 @@ coerced1
coerced1 = Optic (lcoerce' . rcoerce')
{-# INLINE coerced1 #-}
+-- | If @v@ is an element of a type @a@, and @a'@ is @a@ sans the element @v@,
+-- then @'non' v@ is an isomorphism from @'Maybe' a'@ to @a@.
+--
+-- @
+-- 'non' ≡ 'non'' '.' 'only'
+-- @
+--
+-- Keep in mind this is only a real isomorphism if you treat the domain as being
+-- @'Maybe' (a sans v)@.
+--
+-- This is practically quite useful when you want to have a 'Data.Map.Map' where
+-- all the entries should have non-zero values.
+--
+-- >>> Map.fromList [("hello",1)] & at "hello" % non 0 %~ (+2)
+-- fromList [("hello",3)]
+--
+-- >>> Map.fromList [("hello",1)] & at "hello" % non 0 %~ (subtract 1)
+-- fromList []
+--
+-- >>> Map.fromList [("hello",1)] ^. at "hello" % non 0
+-- 1
+--
+-- >>> Map.fromList [] ^. at "hello" % non 0
+-- 0
+--
+-- This combinator is also particularly useful when working with nested maps.
+--
+-- /e.g./ When you want to create the nested 'Data.Map.Map' when it is missing:
+--
+-- >>> Map.empty & at "hello" % non Map.empty % at "world" ?~ "!!!"
+-- fromList [("hello",fromList [("world","!!!")])]
+--
+-- and when have deleting the last entry from the nested 'Data.Map.Map' mean
+-- that we should delete its entry from the surrounding one:
+--
+-- >>> Map.fromList [("hello", Map.fromList [("world","!!!")])] & at "hello" % non Map.empty % at "world" .~ Nothing
+-- fromList []
+--
+-- It can also be used in reverse to exclude a given value:
+--
+-- >>> non 0 # rem 10 4
+-- Just 2
+--
+-- >>> non 0 # rem 10 5
+-- Nothing
+--
+-- @since 0.2
+non :: Eq a => a -> Iso' (Maybe a) a
+non = non' . only
+{-# INLINE non #-}
+
+-- | @'non'' p@ generalizes @'non' (p # ())@ to take any unit 'Prism'
+--
+-- This function generates an isomorphism between @'Maybe' (a | 'isn't' p a)@
+-- and @a@.
+--
+-- >>> Map.singleton "hello" Map.empty & at "hello" % non' _Empty % at "world" ?~ "!!!"
+-- fromList [("hello",fromList [("world","!!!")])]
+--
+-- >>> Map.fromList [("hello", Map.fromList [("world","!!!")])] & at "hello" % non' _Empty % at "world" .~ Nothing
+-- fromList []
+--
+-- @since 0.2
+non' :: Prism' a () -> Iso' (Maybe a) a
+non' p = iso (fromMaybe def) go where
+ def = review p ()
+ go b | p `isn't` b = Just b
+ | otherwise = Nothing
+{-# INLINE non' #-}
+
+-- | @'anon' a p@ generalizes @'non' a@ to take any value and a predicate.
+--
+-- @
+-- 'anon' a ≡ 'non'' '.' 'nearly' a
+-- @
+--
+-- This function assumes that @p a@ holds @'True'@ and generates an isomorphism
+-- between @'Maybe' (a | 'not' (p a))@ and @a@.
+--
+-- >>> Map.empty & at "hello" % anon Map.empty Map.null % at "world" ?~ "!!!"
+-- fromList [("hello",fromList [("world","!!!")])]
+--
+-- >>> Map.fromList [("hello", Map.fromList [("world","!!!")])] & at "hello" % anon Map.empty Map.null % at "world" .~ Nothing
+-- fromList []
+--
+-- @since 0.2
+anon :: a -> (a -> Bool) -> Iso' (Maybe a) a
+anon a = non' . nearly a
+{-# INLINE anon #-}
+
-- | The canonical isomorphism for currying and uncurrying a function.
--
-- @
@@ -269,6 +374,7 @@ instance Swapped Either where
{-# INLINE swapped #-}
-- $setup
+-- >>> import qualified Data.Map as Map
-- >>> import Data.Functor.Identity
-- >>> import Data.Monoid
-- >>> import Optics.Core
diff --git a/src/Optics/IxAffineFold.hs b/src/Optics/IxAffineFold.hs
index 1deb79f..1b8f17c 100644
--- a/src/Optics/IxAffineFold.hs
+++ b/src/Optics/IxAffineFold.hs
@@ -33,10 +33,11 @@ module Optics.IxAffineFold
, An_AffineFold
) where
+import Data.Profunctor.Indexed
+
import Optics.AffineFold
import Optics.Internal.Bi
import Optics.Internal.Indexed
-import Optics.Internal.Profunctor
import Optics.Internal.Optic
-- | Type synonym for an indexed affine fold.
diff --git a/src/Optics/IxAffineTraversal.hs b/src/Optics/IxAffineTraversal.hs
index 22a3ba9..f20deb2 100644
--- a/src/Optics/IxAffineTraversal.hs
+++ b/src/Optics/IxAffineTraversal.hs
@@ -40,9 +40,10 @@ module Optics.IxAffineTraversal
, toIxAtraversalVL
) where
+import Data.Profunctor.Indexed
+
import Optics.Internal.Indexed
import Optics.Internal.Optic
-import Optics.Internal.Profunctor
-- | Type synonym for a type-modifying indexed affine traversal.
type IxAffineTraversal i s t a b = Optic An_AffineTraversal (WithIx i) s t a b
diff --git a/src/Optics/IxFold.hs b/src/Optics/IxFold.hs
index 8e3b872..44fec9e 100644
--- a/src/Optics/IxFold.hs
+++ b/src/Optics/IxFold.hs
@@ -2,9 +2,9 @@
{-# LANGUAGE DataKinds #-}
-- |
-- Module: Optics.IxFold
--- Description: An indexed version of an 'Optics.Fold.Fold'.
+-- Description: An indexed version of a 'Optics.Fold.Fold'.
--
--- An 'IxFold' is an indexed version of an 'Optics.Fold.Fold'. See the "Indexed
+-- An 'IxFold' is an indexed version of a 'Optics.Fold.Fold'. See the "Indexed
-- optics" section of the overview documentation in the @Optics@ module of the
-- main @optics@ package for more details on indexed optics.
--
@@ -58,12 +58,13 @@ module Optics.IxFold
import Control.Applicative.Backwards
import Data.Monoid
+import Data.Profunctor.Indexed
+
import Optics.Internal.Bi
import Optics.Internal.Indexed
import Optics.Internal.Fold
import Optics.Internal.IxFold
import Optics.Internal.Optic
-import Optics.Internal.Profunctor
import Optics.Internal.Utils
import Optics.IxAffineFold
import Optics.Fold
diff --git a/src/Optics/IxGetter.hs b/src/Optics/IxGetter.hs
index 8e45386..d76844a 100644
--- a/src/Optics/IxGetter.hs
+++ b/src/Optics/IxGetter.hs
@@ -1,8 +1,8 @@
-- |
-- Module: Optics.IxGetter
--- Description: An indexed version of an 'Optics.Getter.Getter'.
+-- Description: An indexed version of a 'Optics.Getter.Getter'.
--
--- An 'IxGetter' is an indexed version of an 'Optics.Getter.Getter'. See the
+-- An 'IxGetter' is an indexed version of a 'Optics.Getter.Getter'. See the
-- "Indexed optics" section of the overview documentation in the @Optics@ module
-- of the main @optics@ package for more details on indexed optics.
--
@@ -23,10 +23,11 @@ module Optics.IxGetter
, A_Getter
) where
+import Data.Profunctor.Indexed
+
import Optics.Internal.Bi
import Optics.Internal.Indexed
import Optics.Internal.Optic
-import Optics.Internal.Profunctor
-- | Type synonym for an indexed getter.
type IxGetter i s a = Optic' A_Getter (WithIx i) s a
diff --git a/src/Optics/IxLens.hs b/src/Optics/IxLens.hs
index f862138..5b55ee1 100644
--- a/src/Optics/IxLens.hs
+++ b/src/Optics/IxLens.hs
@@ -1,8 +1,8 @@
-- |
-- Module: Optics.IxLens
--- Description: An indexed version of an 'Optics.Lens.Lens'.
+-- Description: An indexed version of a 'Optics.Lens.Lens'.
--
--- An 'IxLens' is an indexed version of an 'Optics.Lens.Lens'. See the "Indexed
+-- An 'IxLens' is an indexed version of a 'Optics.Lens.Lens'. See the "Indexed
-- optics" section of the overview documentation in the @Optics@ module of the
-- main @optics@ package for more details on indexed optics.
--
@@ -44,9 +44,10 @@ module Optics.IxLens
import Data.Void
+import Data.Profunctor.Indexed
+
import Optics.Internal.Indexed
import Optics.Internal.Optic
-import Optics.Internal.Profunctor
-- | Type synonym for a type-modifying indexed lens.
type IxLens i s t a b = Optic A_Lens (WithIx i) s t a b
diff --git a/src/Optics/IxSetter.hs b/src/Optics/IxSetter.hs
index f99392c..4e9fc65 100644
--- a/src/Optics/IxSetter.hs
+++ b/src/Optics/IxSetter.hs
@@ -1,9 +1,9 @@
{-# LANGUAGE DataKinds #-}
-- |
-- Module: Optics.IxSetter
--- Description: An indexed version of an 'Optics.Setter.Setter'.
+-- Description: An indexed version of a 'Optics.Setter.Setter'.
--
--- An 'IxSetter' is an indexed version of an 'Optics.Setter.Setter'. See the
+-- An 'IxSetter' is an indexed version of a 'Optics.Setter.Setter'. See the
-- "Indexed optics" section of the overview documentation in the @Optics@ module
-- of the main @optics@ package for more details on indexed optics.
--
@@ -57,10 +57,12 @@ module Optics.IxSetter
, FunctorWithIndex(..)
) where
+import Data.Profunctor.Indexed
+
import Optics.Internal.Indexed
import Optics.Internal.IxSetter
import Optics.Internal.Optic
-import Optics.Internal.Profunctor
+import Optics.Internal.Utils
-- | Type synonym for a type-modifying indexed setter.
type IxSetter i s t a b = Optic A_Setter (WithIx i) s t a b
diff --git a/src/Optics/IxTraversal.hs b/src/Optics/IxTraversal.hs
index 44a96b8..8f2caa6 100644
--- a/src/Optics/IxTraversal.hs
+++ b/src/Optics/IxTraversal.hs
@@ -1,9 +1,9 @@
{-# LANGUAGE DataKinds #-}
-- |
-- Module: Optics.IxTraversal
--- Description: An indexed version of an 'Optics.Traversal.Traversal'.
+-- Description: An indexed version of a 'Optics.Traversal.Traversal'.
--
--- An 'IxTraversal' is an indexed version of an 'Optics.Traversal.Traversal'.
+-- An 'IxTraversal' is an indexed version of a 'Optics.Traversal.Traversal'.
-- See the "Indexed optics" section of the overview documentation in the
-- @Optics@ module of the main @optics@ package for more details on indexed
-- optics.
@@ -66,7 +66,7 @@ module Optics.IxTraversal
-- | The van Laarhoven representation of an 'IxTraversal' directly expresses
-- how it lifts an effectful operation @I -> A -> F B@ on elements and their
-- indices to act on structures @S -> F T@. Thus 'itraverseOf' converts an
- -- 'IxTraversal' to a 'IxTraversalVL'.
+ -- 'IxTraversal' to an 'IxTraversalVL'.
, IxTraversalVL
, IxTraversalVL'
@@ -78,9 +78,10 @@ import Control.Applicative.Backwards
import Control.Monad.Trans.State
import Data.Functor.Identity
+import Data.Profunctor.Indexed
+
import Optics.Internal.Indexed
import Optics.Internal.IxTraversal
-import Optics.Internal.Profunctor
import Optics.Internal.Optic
import Optics.Internal.Utils
import Optics.IxLens
@@ -113,7 +114,7 @@ itraversalVL t = Optic (iwander t)
----------------------------------------
--- | Map each element of a structure targeted by a 'IxTraversal' (supplying the
+-- | Map each element of a structure targeted by an 'IxTraversal' (supplying the
-- index), evaluate these actions from left to right, and collect the results.
--
-- This yields the van Laarhoven representation of an indexed traversal.
diff --git a/src/Optics/Lens.hs b/src/Optics/Lens.hs
index 9ac09a2..f244ef1 100644
--- a/src/Optics/Lens.hs
+++ b/src/Optics/Lens.hs
@@ -42,7 +42,7 @@ module Optics.Lens
-- 'Optics.Setter.Setter', therefore you can specialise types to obtain:
--
-- @
- -- 'Optics.Getter.view' :: 'Lens' s t a b -> s -> a
+ -- 'Optics.Getter.view' :: 'Lens'' s a -> s -> a
-- @
--
-- @
@@ -50,6 +50,13 @@ module Optics.Lens
-- 'Optics.Setter.set' :: 'Lens' s t a b -> b -> s -> t
-- @
--
+ -- If you want to 'Optics.Getter.view' a type-modifying 'Lens' that is
+ -- insufficiently polymorphic to be used as a type-preserving 'Lens'', use
+ -- 'Optics.ReadOnly.getting':
+ --
+ -- @
+ -- 'Optics.Getter.view' . 'Optics.ReadOnly.getting' :: 'Lens' s t a b -> s -> a
+ -- @
-- * Computation
-- |
@@ -107,10 +114,9 @@ module Optics.Lens
)
where
-import Optics.Internal.Concrete
+import Data.Profunctor.Indexed
+
import Optics.Internal.Optic
-import Optics.Internal.Profunctor
-import Optics.Internal.Utils
-- | Type synonym for a type-modifying lens.
type Lens s t a b = Optic A_Lens NoIx s t a b
diff --git a/src/Optics/Optic.hs b/src/Optics/Optic.hs
index 7d2f92c..8ed30c2 100644
--- a/src/Optics/Optic.hs
+++ b/src/Optics/Optic.hs
@@ -24,7 +24,8 @@
-- documentation.
--
module Optics.Optic
- ( Optic
+ ( OpticKind
+ , Optic
, Optic'
-- * Subtyping
@@ -38,6 +39,10 @@ module Optics.Optic
, (%&)
-- * Indexed optics
+ -- | See the "Indexed optics" section of the overview documentation in the
+ -- @Optics@ module of the main @optics@ package for more details on indexed
+ -- optics.
+ , IxList
, NoIx
, WithIx
, Append
diff --git a/src/Optics/Prism.hs b/src/Optics/Prism.hs
index 38a831f..5f84051 100644
--- a/src/Optics/Prism.hs
+++ b/src/Optics/Prism.hs
@@ -20,14 +20,22 @@ module Optics.Prism
-- specialise types to obtain:
--
-- @
- -- 'Optics.AffineFold.preview' :: 'Prism' s t a b -> s -> Maybe a
- -- 'Optics.Review.review' :: 'Prism' s t a b -> b -> t
+ -- '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
-- @
+ --
+ -- If you want to 'Optics.AffineFold.preview' a type-modifying 'Prism' that is
+ -- insufficiently polymorphic to be used as a type-preserving 'Prism'', use
+ -- 'Optics.ReadOnly.getting':
+ --
+ -- @
+ -- 'Optics.AffineFold.preview' . 'Optics.ReadOnly.getting' :: 'Prism' s t a b -> s -> 'Maybe' a
+ -- @
-- * Computation
-- |
@@ -70,9 +78,9 @@ module Optics.Prism
import Control.Monad
import Data.Bifunctor
-import Optics.Internal.Concrete
+import Data.Profunctor.Indexed
+
import Optics.Internal.Optic
-import Optics.Internal.Profunctor
-- | Type synonym for a type-modifying prism.
type Prism s t a b = Optic A_Prism NoIx s t a b
diff --git a/src/Optics/Re.hs b/src/Optics/Re.hs
index bc1de1e..860837e 100644
--- a/src/Optics/Re.hs
+++ b/src/Optics/Re.hs
@@ -30,10 +30,11 @@ module Optics.Re
import Data.Coerce
+import Data.Profunctor.Indexed
+
import Optics.Internal.Bi
import Optics.Internal.Indexed
import Optics.Internal.Optic
-import Optics.Internal.Profunctor
-- | Class for optics that can be 're'versed.
class ReversibleOptic k where
diff --git a/src/Optics/ReadOnly.hs b/src/Optics/ReadOnly.hs
index 67738f2..b37258b 100644
--- a/src/Optics/ReadOnly.hs
+++ b/src/Optics/ReadOnly.hs
@@ -9,9 +9,10 @@ module Optics.ReadOnly
( ToReadOnly(..)
) where
+import Data.Profunctor.Indexed
+
import Optics.Internal.Bi
import Optics.Internal.Optic
-import Optics.Internal.Profunctor
-- | Class for read-write optics that have their read-only counterparts.
class ToReadOnly k s t a b where
diff --git a/src/Optics/Review.hs b/src/Optics/Review.hs
index 4ef85f7..e288643 100644
--- a/src/Optics/Review.hs
+++ b/src/Optics/Review.hs
@@ -29,11 +29,10 @@ module Optics.Review
)
where
+import Data.Profunctor.Indexed
+
import Optics.Internal.Bi
import Optics.Internal.Optic
-import Optics.Internal.Profunctor
-import Optics.Internal.Tagged
-import Optics.Internal.Utils
-- | Type synonym for a review.
type Review t b = Optic' A_Review NoIx t b
diff --git a/src/Optics/Setter.hs b/src/Optics/Setter.hs
index dde9c13..cee69d6 100644
--- a/src/Optics/Setter.hs
+++ b/src/Optics/Setter.hs
@@ -60,9 +60,11 @@ module Optics.Setter
-- | <<diagrams/Setter.png Setter in the optics hierarchy>>
) where
+import Data.Profunctor.Indexed
+
import Optics.Internal.Optic
-import Optics.Internal.Profunctor
import Optics.Internal.Setter
+import Optics.Internal.Utils
-- | Type synonym for a type-modifying setter.
type Setter s t a b = Optic A_Setter NoIx s t a b
diff --git a/src/Optics/Traversal.hs b/src/Optics/Traversal.hs
index 042a497..84e46c3 100644
--- a/src/Optics/Traversal.hs
+++ b/src/Optics/Traversal.hs
@@ -80,12 +80,13 @@ import Control.Applicative.Backwards
import Control.Monad.Trans.State
import Data.Functor.Identity
+import Data.Profunctor.Indexed
+
+import Optics.Fold
import Optics.Internal.Optic
-import Optics.Internal.Profunctor
import Optics.Internal.Traversal
import Optics.Internal.Utils
import Optics.Lens
-import Optics.Fold
import Optics.ReadOnly
-- | Type synonym for a type-modifying traversal.