summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorcmk <>2019-12-02 17:48:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-12-02 17:48:00 (GMT)
commitaf0eeb0a03948a6a0670a1b96a158ef77943c1a8 (patch)
tree741fd5092653da27a8aa22bfede431fd92ea4c9a
parent46cc0f7ba79150e494b6d7ca91f03f3f0900a252 (diff)
version 0.0.0.2HEAD0.0.0.2master
-rw-r--r--profunctor-optics.cabal103
-rw-r--r--src/Control/Exception/Optic.hs417
-rw-r--r--src/Data/Connection/Optic.hs25
-rw-r--r--src/Data/Connection/Optic/Float.hs38
-rw-r--r--src/Data/Connection/Optic/Int.hs78
-rw-r--r--src/Data/Connection/Optic/Word.hs78
-rw-r--r--src/Data/Profunctor/Optic.hs36
-rw-r--r--src/Data/Profunctor/Optic/Cofold.hs75
-rw-r--r--src/Data/Profunctor/Optic/Cotraversal.hs29
-rw-r--r--src/Data/Profunctor/Optic/Fold.hs717
-rw-r--r--src/Data/Profunctor/Optic/Fold0.hs351
-rw-r--r--src/Data/Profunctor/Optic/Fold1.hs335
-rw-r--r--src/Data/Profunctor/Optic/Grate.hs252
-rw-r--r--src/Data/Profunctor/Optic/Import.hs (renamed from src/Data/Profunctor/Optic/Prelude.hs)23
-rw-r--r--src/Data/Profunctor/Optic/Index.hs287
-rw-r--r--src/Data/Profunctor/Optic/Iso.hs662
-rw-r--r--src/Data/Profunctor/Optic/Lens.hs413
-rw-r--r--src/Data/Profunctor/Optic/Operator.hs58
-rw-r--r--src/Data/Profunctor/Optic/Prism.hs695
-rw-r--r--src/Data/Profunctor/Optic/Property.hs287
-rw-r--r--src/Data/Profunctor/Optic/Setter.hs882
-rw-r--r--src/Data/Profunctor/Optic/Traversal.hs249
-rw-r--r--src/Data/Profunctor/Optic/Traversal0.hs315
-rw-r--r--src/Data/Profunctor/Optic/Traversal1.hs326
-rw-r--r--src/Data/Profunctor/Optic/Type.hs415
-rw-r--r--src/Data/Profunctor/Optic/View.hs615
-rw-r--r--src/Data/Profunctor/Orphan.hs61
-rw-r--r--src/Data/Tuple/Optic.hs97
-rw-r--r--test/doctests.hs14
29 files changed, 5846 insertions, 2087 deletions
diff --git a/profunctor-optics.cabal b/profunctor-optics.cabal
index dc72d12..f188bf0 100644
--- a/profunctor-optics.cabal
+++ b/profunctor-optics.cabal
@@ -1,10 +1,25 @@
cabal-version: >= 1.10
name: profunctor-optics
-version: 0.0.0.1
-synopsis: Profunctor optics
-description: A profunctor optics library compatible with the typeclasses in 'profunctors'.
-category: Data, Lenses
+version: 0.0.0.2
+synopsis: An optics library compatible with the typeclasses in 'profunctors'.
+description:
+ This package provides utilities for creating and manipulating profunctor-based optics. Some highlights:
+ .
+ Full complement of isos, prisms, lenses, grates, traversals (affine, regular, and non-empty), folds (affine, regular, and non-empty), views, and setters. Many of these have categorical duals.
+ .
+ Composable indexed and co-indexed variants of all of the above.
+ .
+ Compact & straight-forward implementation. No inscrutable internal modules, lawless or otherwise ancillary typeclasses, or heavy type-level machinery.
+ .
+ Fully interoperable. All that is required to create optics (standard, idexable, or co-indexable) is the `profunctors` package, which is heavily used and seems likely to end up in `base` at some point. Optics compose with (.) from `Prelude` as is typical. If you want to provide profunctor optics for your own types in your own libraries, you can do so without incurring a dependency on this package. Conversions to & from the Van Laarhoven representations are provided for each optic type.
+ .
+ Well-documented properties and exportable predicates for testing your own optics.
+ .
+ See the <https://github.com/cmk/profunctor-extras/blob/master/profunctor-optics/README.md Readme> file for more information.
+
+category: Data, Lenses, Profunctors
+stability: Experimental
homepage: https://github.com/cmk/profunctor-extras
bug-reports: https://github.com/cmk/profunctor-extras/issues
author: Chris McKinlay
@@ -13,6 +28,7 @@ copyright: 2019 Chris McKinlay
license: BSD3
license-file: LICENSE
build-type: Simple
+tested-with: GHC == 8.6.3
extra-source-files: ChangeLog.md
source-repository head
@@ -21,9 +37,17 @@ source-repository head
library
exposed-modules:
+ Control.Exception.Optic
+
+ Data.Tuple.Optic
+
+ Data.Connection.Optic
+ Data.Connection.Optic.Int
+ Data.Connection.Optic.Word
+ Data.Connection.Optic.Float
+
Data.Profunctor.Optic
Data.Profunctor.Optic.Type
- Data.Profunctor.Optic.Operator
Data.Profunctor.Optic.Iso
Data.Profunctor.Optic.View
Data.Profunctor.Optic.Setter
@@ -32,13 +56,15 @@ library
Data.Profunctor.Optic.Grate
Data.Profunctor.Optic.Fold
Data.Profunctor.Optic.Fold0
- Data.Profunctor.Optic.Cofold
+ Data.Profunctor.Optic.Fold1
Data.Profunctor.Optic.Traversal
Data.Profunctor.Optic.Traversal0
- Data.Profunctor.Optic.Cotraversal
- Data.Profunctor.Optic.Prelude
+ Data.Profunctor.Optic.Traversal1
+ Data.Profunctor.Optic.Operator
Data.Profunctor.Optic.Property
- Data.Profunctor.Orphan
+ Data.Profunctor.Optic.Index
+
+ other-modules: Data.Profunctor.Optic.Import
default-language: Haskell2010
@@ -49,7 +75,6 @@ library
RankNTypes
MultiParamTypeClasses
OverloadedStrings
- TupleSections
FlexibleContexts
FlexibleInstances
ExistentialQuantification
@@ -63,18 +88,48 @@ library
ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates
build-depends:
- base >=4.9 && <5.0
- , adjunctions
- , bifunctors
- , comonad
- , connections
- , contravariant
- , distributive
- , foldl
+ base >= 4.9 && < 5.0
+ , comonad >= 4 && < 6
+ , connections >= 0.0.2 && < 0.1
+ , containers >= 0.4.0 && < 0.7
+ , distributive >= 0.3 && < 1
+ , ilist >= 0.3.1.0 && < 0.4
+ , mtl >= 2.0.1 && < 2.3
+ , newtype-generics >= 0.5.3 && < 0.6
+ , profunctor-arrows >= 0.0.0.2 && < 0.0.1
+ , profunctors >= 5.2.1 && < 6
+ , rings >= 0.0.2 && < 0.1
+ , semigroupoids >= 5 && < 6
+ , tagged >= 0.4.4 && < 1
+ , transformers >= 0.2 && < 0.6
+ , unliftio-core >= 0.1.2 && < 0.2
+
+test-suite doctests
+ type: exitcode-stdio-1.0
+ main-is: doctests.hs
+ ghc-options: -Wall -threaded
+ hs-source-dirs: test
+ default-language: Haskell2010
+ x-doctest-options: --fast
+
+ build-depends:
+ base
+ , containers
+ , doctest >= 0.8
, mtl
- , profunctor-misc
- , profunctors
- , recursion-schemes
- , rings
- , semigroupoids
- , unliftio-core
+ , profunctor-optics
+
+ default-extensions:
+ ConstraintKinds
+ RankNTypes
+ MultiParamTypeClasses
+ OverloadedStrings
+ FlexibleContexts
+ FlexibleInstances
+ ExistentialQuantification
+ QuantifiedConstraints
+ ScopedTypeVariables
+ TupleSections
+ TypeOperators
+ TypeApplications
+ TypeFamilies
diff --git a/src/Control/Exception/Optic.hs b/src/Control/Exception/Optic.hs
new file mode 100644
index 0000000..d79912c
--- /dev/null
+++ b/src/Control/Exception/Optic.hs
@@ -0,0 +1,417 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
+module Control.Exception.Optic (
+ -- * Common optics
+ non'
+ , unlifted
+ , exmapped
+ , exception
+ , pattern Exception
+ -- * Derived operators
+ , throws
+ , throws_
+ , throwsTo
+ , tries
+ , tries_
+ , catches
+ , catches_
+ , handles
+ , handles_
+ , ioException
+ -- * IO Error Fields
+ , ioeLocation
+ , ioeDescription
+ , ioeHandle
+ , ioeFileName
+ , ioeErrno
+ , ioeErrorType
+ -- * IO Error Types
+ , alreadyExists
+ , noSuchThing
+ , resourceBusy
+ , resourceExhausted
+ , eof
+ , illegalOperation
+ , permissionDenied
+ , userError
+ , unsatisfiedConstraints
+ , systemError
+ , protocolError
+ , otherError
+ , invalidArgument
+ , inappropriateType
+ , hardwareFault
+ , unsupportedOperation
+ -- * Async Exceptions
+ , sync
+ , async
+ , asyncException
+ , pattern AsyncException
+ , timeExpired
+ , resourceVanished
+ , interrupted
+ , stackOverflow
+ , heapOverflow
+ , threadKilled
+ , userInterrupt
+ -- * Arithmetic exceptions
+ , overflow
+ , underflow
+ , lossOfPrecision
+ , divideByZero
+ , denormal
+ , ratioZeroDenominator
+ -- * Array Exceptions
+ , indexOutOfBounds
+ , undefinedElement
+ -- * Miscellaneous Exceptions
+ , illegal
+ , assertionFailed
+ , nonTermination
+ , nestedAtomically
+ , blockedIndefinitelyOnMVar
+ , blockedIndefinitelyOnSTM
+ , deadlock
+ , noMethodError
+ , patternMatchFail
+ , recConError
+ , recSelError
+ , recUpdError
+ , errorCall
+ , allocationLimitExceeded
+) where
+
+import Control.Exception (Exception(..), SomeException,
+ AsyncException(..), IOException, ArithException(..), ArrayException(..))
+import Data.Maybe (fromMaybe)
+import Data.Profunctor.Optic
+import Data.Profunctor.Optic.Import
+import Foreign.C.Types
+import GHC.IO.Exception (IOErrorType)
+import System.IO
+import qualified Control.Exception as Ex
+import qualified GHC.IO.Exception as Ghc
+
+pattern Exception :: forall a. Exception a => a -> SomeException
+pattern Exception e <- (preview exception -> Just e) where Exception e = review exception e
+
+pattern AsyncException :: forall a. Exception a => a -> SomeException
+pattern AsyncException e <- (preview asyncException -> Just e) where AsyncException e = review asyncException e
+
+-- | Generate an isomorphism between @'Maybe' (a | 'isnt' p a)@ and @a@.
+--
+-- @'non'' p@ generalizes @'non' (p # ())@ to take any unit 'Prism'
+--
+non' :: Prism' a () -> Iso' (Maybe a) a
+non' p = iso (fromMaybe def) go where
+ def = review p ()
+ go b | p `isnt` b = Just b
+ | otherwise = Nothing
+{-# INLINE non' #-}
+
+----------------------------------------------------------------------------------------------------
+-- IO Exceptions
+----------------------------------------------------------------------------------------------------
+
+-- | Exceptions that occur in the 'IO' 'Monad'.
+--
+-- An 'IOException' records a more specific error type, a descriptive string and possibly the handle
+-- that was used when the error was flagged.
+--
+ioException :: Prism' SomeException IOException
+ioException = exception
+
+-- | Where the error happened.
+--
+ioeLocation :: Lens' IOException String
+ioeLocation = lens Ghc.ioe_location $ \s e -> s { Ghc.ioe_location = e }
+
+-- | Error type specific information.
+--
+ioeDescription :: Lens' IOException String
+ioeDescription = lens Ghc.ioe_description $ \s e -> s { Ghc.ioe_description = e }
+
+-- | The handle used by the action flagging this error.
+--
+ioeHandle :: Lens' IOException (Maybe Handle)
+ioeHandle = lens Ghc.ioe_handle $ \s e -> s { Ghc.ioe_handle = e }
+
+-- | 'fileName' the error is related to.
+--
+ioeFileName :: Lens' IOException (Maybe FilePath)
+ioeFileName = lens Ghc.ioe_filename $ \s e -> s { Ghc.ioe_filename = e }
+
+-- | 'errno' leading to this error, if any.
+--
+ioeErrno :: Lens' IOException (Maybe CInt)
+ioeErrno = lens Ghc.ioe_errno $ \s e -> s { Ghc.ioe_errno = e }
+
+ioeErrorType :: Lens' IOException IOErrorType
+ioeErrorType = lens Ghc.ioe_type $ \s e -> s { Ghc.ioe_type = e }
+
+----------------------------------------------------------------------------------------------------
+-- IO Error Types
+----------------------------------------------------------------------------------------------------
+
+-- | TODO: Document
+--
+alreadyExists :: Prism' IOErrorType ()
+alreadyExists = only Ghc.AlreadyExists
+
+-- | TODO: Document
+--
+noSuchThing :: Prism' IOErrorType ()
+noSuchThing = only Ghc.NoSuchThing
+
+-- | TODO: Document
+--
+resourceBusy :: Prism' IOErrorType ()
+resourceBusy = only Ghc.ResourceBusy
+
+-- | TODO: Document
+--
+resourceExhausted :: Prism' IOErrorType ()
+resourceExhausted = only Ghc.ResourceExhausted
+
+-- | TODO: Document
+--
+eof :: Prism' IOErrorType ()
+eof = only Ghc.EOF
+
+-- | TODO: Document
+--
+illegalOperation :: Prism' IOErrorType ()
+illegalOperation = only Ghc.IllegalOperation
+
+-- | TODO: Document
+--
+permissionDenied :: Prism' IOErrorType ()
+permissionDenied = only Ghc.PermissionDenied
+
+-- | TODO: Document
+--
+userError :: Prism' IOErrorType ()
+userError = only Ghc.UserError
+
+-- | TODO: Document
+--
+unsatisfiedConstraints :: Prism' IOErrorType ()
+unsatisfiedConstraints = only Ghc.UnsatisfiedConstraints
+
+-- | TODO: Document
+--
+systemError :: Prism' IOErrorType ()
+systemError = only Ghc.SystemError
+
+-- | TODO: Document
+--
+protocolError :: Prism' IOErrorType ()
+protocolError = only Ghc.ProtocolError
+
+-- | TODO: Document
+--
+otherError :: Prism' IOErrorType ()
+otherError = only Ghc.OtherError
+
+-- | TODO: Document
+--
+invalidArgument :: Prism' IOErrorType ()
+invalidArgument = only Ghc.InvalidArgument
+
+-- | TODO: Document
+--
+inappropriateType :: Prism' IOErrorType ()
+inappropriateType = only Ghc.InappropriateType
+
+-- | TODO: Document
+--
+hardwareFault :: Prism' IOErrorType ()
+hardwareFault = only Ghc.HardwareFault
+
+-- | TODO: Document
+--
+unsupportedOperation :: Prism' IOErrorType ()
+unsupportedOperation = only Ghc.UnsupportedOperation
+
+-- | TODO: Document
+--
+timeExpired :: Prism' IOErrorType ()
+timeExpired = only Ghc.TimeExpired
+
+-- | TODO: Document
+--
+resourceVanished :: Prism' IOErrorType ()
+resourceVanished = only Ghc.ResourceVanished
+
+-- | TODO: Document
+--
+interrupted :: Prism' IOErrorType ()
+interrupted = only Ghc.Interrupted
+
+----------------------------------------------------------------------------------------------------
+-- Async Exceptions
+----------------------------------------------------------------------------------------------------
+
+-- | The current thread's stack exceeded its limit. Since an 'Exception' has
+-- been raised, the thread's stack will certainly be below its limit again,
+-- but the programmer should take remedial action immediately.
+--
+stackOverflow :: Prism' AsyncException ()
+stackOverflow = only Ex.StackOverflow
+
+-- | The program's heap usage has exceeded its limit.
+--
+-- See 'GHC.IO.Exception' for more information.
+--
+heapOverflow :: Prism' AsyncException ()
+heapOverflow = only Ex.HeapOverflow
+
+-- | This 'Exception' is raised by another thread calling
+-- 'Control.Concurrent.killThread', or by the system if it needs to terminate
+-- the thread for some reason.
+--
+threadKilled :: Prism' AsyncException ()
+threadKilled = only Ex.ThreadKilled
+
+-- | This 'Exception' is raised by default in the main thread of the program when
+-- the user requests to terminate the program via the usual mechanism(s)
+-- (/e.g./ Control-C in the console).
+--
+userInterrupt :: Prism' AsyncException ()
+userInterrupt = only Ex.UserInterrupt
+
+----------------------------------------------------------------------------------------------------
+-- Arithmetic exceptions
+----------------------------------------------------------------------------------------------------
+
+-- | Detect arithmetic overflow.
+--
+overflow :: Prism' ArithException ()
+overflow = only Ex.Overflow
+
+-- | Detect arithmetic underflow.
+--
+underflow :: Prism' ArithException ()
+underflow = only Ex.Underflow
+
+-- | Detect arithmetic loss of precision.
+--
+lossOfPrecision :: Prism' ArithException ()
+lossOfPrecision = only Ex.LossOfPrecision
+
+-- | Detect division by zero.
+--
+divideByZero :: Prism' ArithException ()
+divideByZero = only Ex.DivideByZero
+
+-- | Detect whether a FLOP was performed on a subnormal number.
+--
+denormal :: Prism' ArithException ()
+denormal = only Ex.Denormal
+
+-- | Detect zero denominators.
+--
+ratioZeroDenominator :: Prism' ArithException ()
+ratioZeroDenominator = only Ex.RatioZeroDenominator
+
+----------------------------------------------------------------------------------------------------
+-- Array Exceptions
+----------------------------------------------------------------------------------------------------
+
+-- | Detect attempts to index an array outside its declared bounds.
+--
+indexOutOfBounds :: Prism' ArrayException String
+indexOutOfBounds = dimap sta join . right' . rmap Ex.IndexOutOfBounds
+ where sta (Ex.IndexOutOfBounds r) = Right r
+ sta t = Left t
+
+-- | Detect attempts to evaluate an element of an array that has not been initialized.
+--
+undefinedElement :: Prism' ArrayException String
+undefinedElement = dimap sta join . right' . rmap Ex.UndefinedElement
+ where sta (Ex.UndefinedElement r) = Right r
+ sta t = Left t
+
+----------------------------------------------------------------------------------------------------
+-- Miscellaneous Exceptions
+----------------------------------------------------------------------------------------------------
+
+-- hack to get prisms for exceptions w/o an Eq instance
+illegal :: Profunctor p => t -> Optic' p t ()
+illegal t = const () `dimap` const t
+
+assertionFailed :: Prism' Ex.AssertionFailed String
+assertionFailed = iso (\(Ex.AssertionFailed a) -> a) Ex.AssertionFailed
+
+-- | Thrown when the runtime system detects that the computation is guaranteed
+-- not to terminate. Note that there is no guarantee that the runtime system
+-- will notice whether any given computation is guaranteed to terminate or not.
+--
+nonTermination :: Prism' Ex.NonTermination ()
+nonTermination = illegal Ex.NonTermination
+
+-- | Thrown when the program attempts to call atomically, from the
+-- 'Control.Monad.STM' package, inside another call to atomically.
+--
+nestedAtomically :: Prism' Ex.NestedAtomically ()
+nestedAtomically = illegal Ex.NestedAtomically
+
+-- | The thread is blocked on an 'Control.Concurrent.MVar.MVar', but there
+-- are no other references to the 'Control.Concurrent.MVar.MVar' so it can't
+-- ever continue.
+--
+blockedIndefinitelyOnMVar :: Prism' Ex.BlockedIndefinitelyOnMVar ()
+blockedIndefinitelyOnMVar = illegal Ex.BlockedIndefinitelyOnMVar
+
+-- | The thread is waiting to retry an 'Control.Monad.STM.STM' transaction,
+-- but there are no other references to any TVars involved, so it can't ever
+-- continue.
+--
+blockedIndefinitelyOnSTM :: Prism' Ex.BlockedIndefinitelyOnSTM ()
+blockedIndefinitelyOnSTM = illegal Ex.BlockedIndefinitelyOnSTM
+
+-- | There are no runnable threads, so the program is deadlocked. The
+-- 'Deadlock' 'Exception' is raised in the main thread only.
+--
+deadlock :: Prism' Ex.Deadlock ()
+deadlock = illegal Ex.Deadlock
+
+-- | A class method without a definition (neither a default definition,
+-- nor a definition in the appropriate instance) was called.
+--
+noMethodError :: Prism' Ex.NoMethodError String
+noMethodError = iso (\(Ex.NoMethodError a) -> a) Ex.NoMethodError
+
+-- | A pattern match failed.
+--
+patternMatchFail :: Prism' Ex.PatternMatchFail String
+patternMatchFail = iso (\(Ex.PatternMatchFail a) -> a) Ex.PatternMatchFail
+
+-- | An uninitialised record field was used.
+--
+recConError :: Prism' Ex.RecConError String
+recConError = iso (\(Ex.RecConError a) -> a) Ex.RecConError
+
+-- | A record selector was applied to a constructor without the appropriate
+-- field. This can only happen with a datatype with multiple constructors,
+-- where some fields are in one constructor but not another.
+--
+recSelError :: Prism' Ex.RecSelError String
+recSelError = iso (\(Ex.RecSelError a) -> a) Ex.RecSelError
+
+-- | A record update was performed on a constructor without the
+-- appropriate field. This can only happen with a datatype with multiple
+-- constructors, where some fields are in one constructor but not another.
+--
+recUpdError :: Prism' Ex.RecUpdError String
+recUpdError = iso (\(Ex.RecUpdError a) -> a) Ex.RecUpdError
+
+-- | Thrown when the user calls 'Prelude.error'.
+--
+errorCall :: Prism' Ex.ErrorCall String
+errorCall = iso (\(Ex.ErrorCall a) -> a) Ex.ErrorCall
+
+-- | This thread has exceeded its allocation limit.
+--
+allocationLimitExceeded :: Prism' Ex.AllocationLimitExceeded ()
+allocationLimitExceeded = illegal Ex.AllocationLimitExceeded
diff --git a/src/Data/Connection/Optic.hs b/src/Data/Connection/Optic.hs
new file mode 100644
index 0000000..73baee1
--- /dev/null
+++ b/src/Data/Connection/Optic.hs
@@ -0,0 +1,25 @@
+module Data.Connection.Optic (
+ dual
+ , just
+ , binord
+ , ordbin
+ , connected
+) where
+
+import Data.Connection (Conn)
+import Data.Prd
+import Data.Profunctor.Optic.Grate
+import Data.Profunctor.Optic.Import
+import qualified Data.Connection as C
+
+dual :: Prd a => Prd b => Conn a b -> Grate' (Down b) (Down a)
+dual = connected . C.dual
+
+just :: Prd a => Prd b => Conn a b -> Grate' (Maybe a) (Maybe b)
+just = connected . C.just
+
+ordbin :: Grate' Ordering Bool
+ordbin = connected C.ordbin
+
+binord :: Grate' Bool Ordering
+binord = connected C.binord
diff --git a/src/Data/Connection/Optic/Float.hs b/src/Data/Connection/Optic/Float.hs
new file mode 100644
index 0000000..b84e798
--- /dev/null
+++ b/src/Data/Connection/Optic/Float.hs
@@ -0,0 +1,38 @@
+module Data.Connection.Optic.Float (
+ f32u32
+ , u32f32
+ , u32w64
+ , f32i64
+ , i64f32
+) where
+
+import Data.Connection.Float (Ulp32)
+import Data.Int
+import Data.Prd.Nan (Nan)
+import Data.Profunctor.Optic.Grate
+import Data.Profunctor.Optic.Import
+import Data.Word
+import qualified Data.Connection.Float as F
+
+-- >>> constOf f32u32 (Ulp32 0)
+-- 0.0
+-- >>> constOf f32u32 (Ulp32 1)
+-- 1.0e-45
+f32u32 :: Grate' Float Ulp32
+f32u32 = connected F.f32u32
+
+u32f32 :: Grate' Ulp32 Float
+u32f32 = connected F.u32f32
+
+u32w64 :: Grate' Ulp32 (Nan Word64)
+u32w64 = connected F.u32w64
+
+-- >>> constOf f32i64 Nan
+-- NaN
+-- >>> zipWithOf i64f32 (/) (Def 0) (Def 0)
+-- Nan
+f32i64 :: Grate' Float (Nan Int64)
+f32i64 = connected F.f32i64
+
+i64f32 :: Grate' (Nan Int64) Float
+i64f32 = connected F.i64f32
diff --git a/src/Data/Connection/Optic/Int.hs b/src/Data/Connection/Optic/Int.hs
new file mode 100644
index 0000000..eee7579
--- /dev/null
+++ b/src/Data/Connection/Optic/Int.hs
@@ -0,0 +1,78 @@
+module Data.Connection.Optic.Int (
+ -- * Int8
+ i08w08
+ , i08w08'
+ , i08i16
+ , i08i32
+ , i08i64
+ -- * Int16
+ , i16w16
+ , i16w16'
+ , i16i32
+ , i16i64
+ -- * Int32
+ , i32w32
+ , i32w32'
+ , i32i64
+ -- * Int64
+ , i64w64
+ , i64w64'
+ -- * Integer
+ , intnat
+) where
+
+import Data.Int
+import Data.Word
+import Data.Profunctor.Optic.Import
+import Data.Profunctor.Optic.Grate
+import Numeric.Natural
+import qualified Data.Connection.Int as I
+
+i08w08 :: Grate' Int8 Word8
+i08w08 = connected I.i08w08
+
+i08w08' :: Grate' Int8 Word8
+i08w08' = connected I.i08w08'
+
+-- >>> (127 :: Int8) + 3
+-- -126
+-- >>> zipWithOf i08i16 (+) 127 3
+-- 127
+i08i16 :: Grate' Int8 Int16
+i08i16 = connected I.i08i16
+
+i08i32 :: Grate' Int8 Int32
+i08i32 = connected I.i08i32
+
+i08i64 :: Grate' Int8 Int64
+i08i64 = connected I.i08i64
+
+i16w16 :: Grate' Int16 Word16
+i16w16 = connected I.i16w16
+
+i16w16' :: Grate' Int16 Word16
+i16w16' = connected I.i16w16'
+
+i16i32 :: Grate' Int16 Int32
+i16i32 = connected I.i16i32
+
+i16i64 :: Grate' Int16 Int64
+i16i64 = connected I.i16i64
+
+i32w32 :: Grate' Int32 Word32
+i32w32 = connected I.i32w32
+
+i32w32' :: Grate' Int32 Word32
+i32w32' = connected I.i32w32'
+
+i32i64 :: Grate' Int32 Int64
+i32i64 = connected I.i32i64
+
+i64w64 :: Grate' Int64 Word64
+i64w64 = connected I.i64w64
+
+i64w64' :: Grate' Int64 Word64
+i64w64' = connected I.i64w64'
+
+intnat :: Grate' Integer Natural
+intnat = connected I.intnat
diff --git a/src/Data/Connection/Optic/Word.hs b/src/Data/Connection/Optic/Word.hs
new file mode 100644
index 0000000..e1201cb
--- /dev/null
+++ b/src/Data/Connection/Optic/Word.hs
@@ -0,0 +1,78 @@
+module Data.Connection.Optic.Word (
+ -- * Word8
+ w08i08
+ , w08w16
+ , w08w32
+ , w08w64
+ , w08nat
+ -- * Word16
+ , w16i16
+ , w16w32
+ , w16w64
+ , w16nat
+ -- * Word32
+ , w32i32
+ , w32w64
+ , w32nat
+ -- * Word64
+ , w64i64
+ , w64nat
+) where
+
+import Data.Int
+import Data.Word
+import Data.Profunctor.Optic.Grate
+import Numeric.Natural
+import qualified Data.Connection.Word as W
+
+-- >>> constOf w08i08 0
+-- 128
+-- >>> zipWithOf w08i08 (+) 0 0
+-- 128
+--
+w08i08 :: Grate' Word8 Int8
+w08i08 = connected W.w08i08
+
+-- >>> constOf w08w16 0
+-- 0
+-- >>> zipWithOf w08w16 (+) 16 7
+-- 23
+--
+w08w16 :: Grate' Word8 Word16
+w08w16 = connected W.w08w16
+
+w08w32 :: Grate' Word8 Word32
+w08w32 = connected W.w08w32
+
+w08w64 :: Grate' Word8 Word64
+w08w64 = connected W.w08w64
+
+w08nat :: Grate' Word8 Natural
+w08nat = connected W.w08nat
+
+w16i16 :: Grate' Word16 Int16
+w16i16 = connected W.w16i16
+
+w16w32 :: Grate' Word16 Word32
+w16w32 = connected W.w16w32
+
+w16w64 :: Grate' Word16 Word64
+w16w64 = connected W.w16w64
+
+w16nat :: Grate' Word16 Natural
+w16nat = connected W.w16nat
+
+w32i32 :: Grate' Word32 Int32
+w32i32 = connected W.w32i32
+
+w32w64 :: Grate' Word32 Word64
+w32w64 = connected W.w32w64
+
+w32nat :: Grate' Word32 Natural
+w32nat = connected W.w32nat
+
+w64i64 :: Grate' Word64 Int64
+w64i64 = connected W.w64i64
+
+w64nat :: Grate' Word64 Natural
+w64nat = connected W.w64nat
diff --git a/src/Data/Profunctor/Optic.hs b/src/Data/Profunctor/Optic.hs
index ae9dd1b..d537e24 100644
--- a/src/Data/Profunctor/Optic.hs
+++ b/src/Data/Profunctor/Optic.hs
@@ -1,33 +1,45 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
module Data.Profunctor.Optic (
module Type
, module Operator
, module Property
, module Iso
- , module View
- , module Setter
, module Lens
, module Prism
, module Grate
- , module Fold
- , module Fold0
- , module Cofold
, module Traversal
, module Traversal0
- , module Cotraversal
+ , module Traversal1
+ , module Fold
+ , module Fold0
+ , module Fold1
+ , module View
+ , module Setter
+ , module Indexed
+ , module Tuple
) where
import Data.Profunctor.Optic.Type as Type
import Data.Profunctor.Optic.Operator as Operator
import Data.Profunctor.Optic.Property as Property
import Data.Profunctor.Optic.Iso as Iso
-import Data.Profunctor.Optic.View as View
-import Data.Profunctor.Optic.Setter as Setter
import Data.Profunctor.Optic.Lens as Lens
import Data.Profunctor.Optic.Prism as Prism
import Data.Profunctor.Optic.Grate as Grate
-import Data.Profunctor.Optic.Fold as Fold
-import Data.Profunctor.Optic.Fold0 as Fold0
-import Data.Profunctor.Optic.Cofold as Cofold
import Data.Profunctor.Optic.Traversal as Traversal
import Data.Profunctor.Optic.Traversal0 as Traversal0
-import Data.Profunctor.Optic.Cotraversal as Cotraversal
+import Data.Profunctor.Optic.Traversal1 as Traversal1
+import Data.Profunctor.Optic.Fold as Fold
+import Data.Profunctor.Optic.Fold0 as Fold0
+import Data.Profunctor.Optic.Fold1 as Fold1
+import Data.Profunctor.Optic.View as View
+import Data.Profunctor.Optic.Setter as Setter
+import Data.Profunctor.Optic.Index as Indexed
+
+import Data.Tuple.Optic as Tuple
diff --git a/src/Data/Profunctor/Optic/Cofold.hs b/src/Data/Profunctor/Optic/Cofold.hs
deleted file mode 100644
index 035b907..0000000
--- a/src/Data/Profunctor/Optic/Cofold.hs
+++ /dev/null
@@ -1,75 +0,0 @@
-module Data.Profunctor.Optic.Cofold where
-
-import Data.Functor.Foldable (Corecursive, Base)
-import Data.Profunctor.Optic.Cotraversal
-import Data.Profunctor.Optic.Prelude
-import Data.Profunctor.Optic.View
-import Data.Profunctor.Optic.Type
-import qualified Data.List as L (unfoldr)
-import qualified Data.Functor.Foldable as F
-
----------------------------------------------------------------------
--- 'Cofold'
----------------------------------------------------------------------
-
--- | Transform a Van Laarhoven 'Cofold' into a profunctor 'Cofold'.
---
-cofoldVL :: (forall f. Functor f => (f a -> b) -> f s -> t) -> Cofold t b
-cofoldVL f = coercel . lower f . coercel
-{-# INLINE cofoldVL #-}
-
--- | TODO: Document
---
-cofolded :: Distributive f => (b -> t) -> Cofold (f t) b
-cofolded f = cotraversed . from f
-{-# INLINE cofolded #-}
-
--- | Build a 'Cofold' from a 'Review'.
---
-toCofold :: AReview t b -> Cofold t b
-toCofold = from . review
-{-# INLINE toCofold #-}
-
--- | Build a 'Review' from a 'Cofold'.
---
-fromCofold :: ACofold b t b -> Review t b
-fromCofold = cloneReview
-{-# INLINE fromCofold #-}
-
----------------------------------------------------------------------
--- 'CofoldRep'
----------------------------------------------------------------------
-
--- | TODO: Document
---
-acofold :: ((r -> b) -> r -> t) -> ACofold r t b
-acofold = between (Costar . (. getConst)) ((. Const) . runCostar)
-{-# INLINE acofold #-}
-
--- | TODO: Document
---
-acofold' :: ACofold b [t] (Maybe (t, b))
-acofold' = acofold L.unfoldr
-{-# INLINE acofold' #-}
-
--- | TODO: Document
---
-corecursing :: Corecursive t => ACofold b t (Base t b)
-corecursing = acofold F.unfold
-{-# INLINE corecursing #-}
-
----------------------------------------------------------------------
--- Primitive operators
----------------------------------------------------------------------
-
--- | TODO: Document
---
-cofoldMapOf :: ACofold r t b -> (r -> b) -> r -> t
-cofoldMapOf = between ((. Const) . runCostar) (Costar . (. getConst))
-{-# INLINE cofoldMapOf #-}
-
--- | TODO: Document
---
-cofoldOf :: AReview t b -> b -> t
-cofoldOf = flip cofoldMapOf id
-{-# INLINE cofoldOf #-}
diff --git a/src/Data/Profunctor/Optic/Cotraversal.hs b/src/Data/Profunctor/Optic/Cotraversal.hs
deleted file mode 100644
index 9bf087a..0000000
--- a/src/Data/Profunctor/Optic/Cotraversal.hs
+++ /dev/null
@@ -1,29 +0,0 @@
-module Data.Profunctor.Optic.Cotraversal where
-
-import Data.Profunctor.Optic.Type
-import Data.Profunctor.Optic.Prelude
-
----------------------------------------------------------------------
--- 'Cotraversal'
----------------------------------------------------------------------
-
--- | TODO: Document
---
-cotraversed :: Distributive f => Cotraversal (f a) (f b) a b
-cotraversed = lower cotraverse
-
--- | Transform a Van Laarhoven 'Cotraversal' into a profunctor 'Cotraversal'.
---
-cotraversalVL :: (forall f. Functor f => (f a -> b) -> f s -> t) -> Cotraversal s t a b
-cotraversalVL = lower
-
----------------------------------------------------------------------
--- Operators
----------------------------------------------------------------------
-
--- ^ @
--- 'cotraverseOf' $ 'Data.Profuncto.Optic.Grate.grate' (flip 'Data.Distributive.cotraverse' id) ≡ 'Data.Distributive.cotraverse'
--- @
---
-cotraverseOf :: Optic (Costar f) s t a b -> (f a -> b) -> (f s -> t)
-cotraverseOf = between runCostar Costar
diff --git a/src/Data/Profunctor/Optic/Fold.hs b/src/Data/Profunctor/Optic/Fold.hs
index ac4fe53..e3c5aac 100644
--- a/src/Data/Profunctor/Optic/Fold.hs
+++ b/src/Data/Profunctor/Optic/Fold.hs
@@ -1,232 +1,321 @@
-module Data.Profunctor.Optic.Fold where
-
-import Control.Foldl (EndoM(..))
-import Control.Monad ((<=<))
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+module Data.Profunctor.Optic.Fold (
+ -- * Fold & Ixfold
+ Fold
+ , Ixfold
+ , fold_
+ , folding
+ , foldVl
+ , toFold
+ , cloneFold
+ -- * Optics
+ , folded
+ , folded_
+ , unital
+ , summed
+ , multiplied
+ -- * Primitive operators
+ , withFold
+ , withIxfold
+ -- * Operators
+ , (^..)
+ , (^??)
+ , folds
+ , foldsa
+ , foldsp
+ , foldsr
+ , foldsl
+ , foldsl'
+ , lists
+ , traverses_
+ , concats
+ , finds
+ , has
+ , hasnt
+ , nulls
+ , asums
+ , joins
+ , joins'
+ , meets
+ , meets'
+ , pelem
+ -- * Indexed operators
+ , (^%%)
+ , ixfoldsr
+ , ixfoldsrFrom
+ , ixfoldsl
+ , ixfoldslFrom
+ , ixfoldsrM
+ , ixfoldsrMFrom
+ , ixfoldslM
+ , ixfoldslMFrom
+ , ixlists
+ , ixlistsFrom
+ , ixtraverses_
+ , ixconcats
+ , ixfinds
+ -- * Auxilliary Types
+ , All, Any
+ -- * Carriers
+ , FoldRep
+ , AFold
+ , AIxfold
+ , afold
+ , Star(..)
+ , Costar(..)
+ -- * Classes
+ , Representable(..)
+ , Corepresentable(..)
+ , Contravariant(..)
+ , Bifunctor(..)
+) where
+
+import Control.Applicative
+import Control.Monad (void)
+import Control.Monad.Reader as Reader hiding (lift)
+import Data.Bifunctor (Bifunctor(..))
+import Data.Bool.Instance () -- Semigroup / Monoid / Semiring instances
import Data.Foldable (Foldable, foldMap, traverse_)
-import Data.Functor.Foldable (Recursive, Base)
-import Data.Monoid
+import Data.Maybe
+import Data.Monoid hiding (All(..), Any(..))
import Data.Prd (Prd(..), Min(..), Max(..))
import Data.Prd.Lattice (Lattice(..))
-import Data.Semiring (Semiring(..))
-import Data.Profunctor.Optic.Prelude hiding (min, max, join)
-import Data.Profunctor.Optic.Traversal
+import Data.Profunctor.Optic.Import
import Data.Profunctor.Optic.Type
-import Data.Profunctor.Optic.View (to, view, cloneView)
-import qualified Control.Foldl as L
-import qualified Data.Functor.Foldable as F
+import Data.Profunctor.Optic.View (AView, to, withPrimView, view, cloneView)
+import Data.Semiring (Semiring(..), Prod(..))
import qualified Data.Prd as Prd
import qualified Data.Semiring as Rng
-import qualified Prelude as Pre
+
+-- $setup
+-- >>> :set -XNoOverloadedStrings
+-- >>> :set -XTypeApplications
+-- >>> :set -XFlexibleContexts
+-- >>> import Control.Exception hiding (catches)
+-- >>> import Data.Functor.Identity
+-- >>> import Data.List.Index
+-- >>> import Data.Int.Instance ()
+-- >>> import Data.Map as Map
+-- >>> import Data.Sequence as Seq hiding ((><))
+-- >>> import Data.Maybe
+-- >>> import Data.Monoid
+-- >>> import Data.Semiring hiding (unital,nonunital,presemiring)
+-- >>> :load Data.Profunctor.Optic
+-- >>> let ixtraversed :: Ixtraversal Int [a] [b] a b ; ixtraversed = ixtraversalVl itraverse
---------------------------------------------------------------------
--- 'Fold'
+-- 'Fold' & 'Ixfold'
---------------------------------------------------------------------
--- | Transform a Van Laarhoven 'Fold' into a profunctor 'Fold'.
---
-foldVL :: (forall f. Applicative f => (a -> f b) -> s -> f t) -> Fold s a
-foldVL f = coercer . lift f . coercer
-{-# INLINE foldVL #-}
+type FoldRep r = Star (Const r)
--- | Obtain a 'Fold' using a 'Traversable' functor.
---
--- @
--- 'folded' f ≡ 'lift' 'traverse' . 'to' f
--- @
---
-folded :: Traversable f => (s -> a) -> Fold (f s) a
-folded f = traversed . to f
-{-# INLINE folded #-}
+type AFold r s a = Optic' (FoldRep r) s a
+--type AFold s a = forall r. Monoid r => Optic' (FoldRep r) s a
+
+type AIxfold r i s a = IndexedOptic' (FoldRep r) i s a
--- | Obtain a 'Fold' by lifting an operation that returns a 'Foldable' result.
+-- | Obtain a 'Fold' directly.
--
-- @
--- 'folding' ('toListOf' o) ≡ o
+-- 'fold_' ('lists' o) ≡ o
+-- 'fold_' f ≡ 'to' f . 'foldVl' 'traverse_'
+-- 'fold_' f ≡ 'coercer' . 'lmap' f . 'lift' 'traverse_'
-- @
--
--- This can be useful to lift operations from @Data.List@ and elsewhere into a 'Fold'.
+-- See 'Data.Profunctor.Optic.Property'.
+--
+-- This can be useful to repn operations from @Data.List@ and elsewhere into a 'Fold'.
--
--- >>> [1,2,3,4] ^.. folding tail
+-- >>> [1,2,3,4] ^.. fold_ tail
-- [2,3,4]
--
+fold_ :: Foldable f => (s -> f a) -> Fold s a
+fold_ f = to f . foldVl traverse_
+{-# INLINE fold_ #-}
+
+-- | Obtain a 'Fold' from a 'Traversable' functor.
--
--- See 'Data.Profunctor.Optic.Property'.
+-- @
+-- 'folding' f ≡ 'traversed' . 'to' f
+-- 'folding' f ≡ 'foldVl' 'traverse' . 'to' f
+-- @
--
-folding :: Foldable f => (s -> f a) -> Fold s a
-folding f = coercer . lmap f . lift traverse_
+folding :: Traversable f => (s -> a) -> Fold (f s) a
+folding f = foldVl traverse . to f
{-# INLINE folding #-}
--- | TODO: Document
+-- | Obtain a 'Fold' from a Van Laarhoven 'Fold'.
--
-folding' :: Foldable f => Fold (f a) a
-folding' = folding id
-{-# INLINE folding' #-}
+foldVl :: (forall f. Applicative f => (a -> f b) -> s -> f t) -> Fold s a
+foldVl f = coercer . repn f . coercer
+{-# INLINE foldVl #-}
--- | Build a 'Fold' from a 'View'.
+-- | Obtain a 'Fold' from a 'View' or 'AFold'.
--
-toFold :: AView s a -> Fold0 s a
+toFold :: AView s a -> Fold s a
toFold = to . view
{-# INLINE toFold #-}
--- | Build a monoidal 'View' from a 'Fold'.
+-- | Obtain a 'Fold' from a 'AFold'.
--
-fromFold :: Monoid a => AFold a s a -> View s a
-fromFold = cloneView
-{-# INLINE fromFold #-}
+cloneFold :: Monoid a => AFold a s a -> View s a
+cloneFold = cloneView
+{-# INLINE cloneFold #-}
---------------------------------------------------------------------
--- 'FoldRep'
+-- Optics
---------------------------------------------------------------------
--- | TODO: Document
+-- | Obtain a 'Fold' from a 'Traversable' functor.
--
-afold :: Monoid r => ((a -> r) -> s -> r) -> AFold r s a
-afold = between (Star . (Const .)) ((getConst .) . runStar)
-
--- | TODO: Document
---
-afold' :: Foldable f => AFold r (f a) a
-afold' = afold foldMap
-
-{-
-import Data.Functor.Foldable (ListF(..))
-
-fromListF :: Num a => ListF a (Sum a) -> Sum a
-fromListF Nil = mempty
-fromListF (Cons a r) = Sum a <> r
-
-foldMapOf (recursing) fromListF $ [1..5]
-Sum {getSum = 15}
--}
-
--- | TODO: Document
---
-recursing :: Recursive s => AFold a s (Base s a)
-recursing = afold F.fold
-
----------------------------------------------------------------------
--- Primitive operators
----------------------------------------------------------------------
+folded :: Traversable f => Fold (f a) a
+folded = folding id
+{-# INLINE folded #-}
--- | Map parts of a structure to a monoid and combine the results.
---
--- @
--- 'Data.Foldable.foldMap' = 'foldMapOf' 'folding''
--- @
---
--- >>> foldMapOf both id (["foo"], ["bar", "baz"])
--- ["foo","bar","baz"]
+-- | The canonical 'Fold'.
--
-- @
--- 'foldMapOf' :: 'Iso'' s a -> (a -> r) -> s -> r
--- 'foldMapOf' :: 'Lens'' s a -> (a -> r) -> s -> r
--- 'foldMapOf' :: 'Monoid' r => 'Prism'' s a -> (a -> r) -> s -> r
--- 'foldMapOf' :: 'Monoid' r => 'Traversal'' s a -> (a -> r) -> s -> r
--- 'foldMapOf' :: 'Monoid' r => 'Traversal0'' s a -> (a -> r) -> s -> r
--- 'foldMapOf' :: 'Monoid' r => 'Fold' s a -> (a -> r) -> s -> r
--- 'foldMapOf' :: 'Semigroup' r => 'Fold1' s a -> (a -> r) -> s -> r
+-- 'Data.Foldable.foldMap' ≡ 'withFold' 'folded_''
-- @
--
-foldMapOf :: Monoid r => AFold r s a -> (a -> r) -> s -> r
-foldMapOf = between ((getConst .) . runStar) (Star . (Const .))
-
--- | Collect the foci of a `Fold` into a list.
---
-toListOf :: AFold (Endo [a]) s a -> s -> [a]
-toListOf o = foldsr o (:) []
+folded_ :: Foldable f => Fold (f a) a
+folded_ = fold_ id
+{-# INLINE folded_ #-}
--- | TODO: Document
---
-foldOf :: Monoid a => AFold a s a -> s -> a
-foldOf = flip foldMapOf id
-
--- ^ @
--- toPureOf :: Fold s a -> s -> [a]
--- toPureOf :: Applicative f => Setter s t a b -> s -> f a
--- @
-toPureOf :: Applicative f => Monoid (f a) => AFold (f a) s a -> s -> f a
-toPureOf o = foldMapOf o pure
-
----------------------------------------------------------------------
--- Common 'Fold's
----------------------------------------------------------------------
-
--- | Compute the result of an expression in a unital semiring.
+-- | Expression in a unital semiring
--
-- @
-- 'unital' ≡ 'summed' . 'multiplied'
-- @
--
--- >>> foldOf unital [[1, 2], [3, 4 :: Int]]
+-- >>> folds unital [[1,2], [3,4 :: Int]]
-- 14
--
+-- For semirings without a multiplicative unit this is
+-- equivalent to @const mempty@:
+--
+-- >>> folds unital $ (fmap . fmap) Just [[1,2], [3,4 :: Int]]
+-- Just 0
+--
+-- In this situation you most likely want to use 'nonunital'.
+--
unital :: Foldable f => Foldable g => Monoid r => Semiring r => AFold r (f (g a)) a
-unital = summed . multiplied -- afold Rng.unital
+unital = summed . multiplied
+{-# INLINE unital #-}
--- | Compute the monoidal summed of a 'Fold'.
+-- | Monoidal sum of a foldable collection.
--
-- >>> 1 <> 2 <> 3 <> 4 :: Int
-- 10
---
--- >>> foldOf summed [1,2,3,4 :: Int]
+-- >>> folds summed [1,2,3,4 :: Int]
-- 10
--
+-- 'summed' and 'multiplied' compose just as they do in arithmetic:
+--
+-- >>> 1 >< 2 <> 3 >< 4 :: Int
+-- 14
+-- >>> folds (summed . multiplied) [[1,2], [3,4 :: Int]]
+-- 14
+-- >>> (1 <> 2) >< (3 <> 4) :: Int
+-- 21
+-- >>> folds (multiplied . summed) [[1,2], [3,4 :: Int]]
+-- 21
+--
summed :: Foldable f => Monoid r => AFold r (f a) a
summed = afold foldMap
+{-# INLINE summed #-}
--- | Compute the multiplied of a 'Fold'.
+-- | Semiring product of a foldable collection.
--
-- >>> 1 >< 2 >< 3 >< 4 :: Int
-- 24
---
--- >>> foldOf multiplied [1,2,3,4 :: Int]
+-- >>> folds multiplied [1,2,3,4 :: Int]
-- 24
--
--- 'summed' and 'multiplied' compose just as they do in arithmetic:
+-- For semirings without a multiplicative unit this is
+-- equivalent to @const mempty@:
--
--- >>> 1 >< 2 <> 3 >< 4 :: Int
--- 14
+-- >>> folds multiplied $ fmap Just [1..(5 :: Int)]
+-- Just 0
--
--- >>> foldOf (summed . multiplied) [[1, 2], [3, (4 :: Int)]]
--- 14
---
--- >>> 1 <> 2 >< 3 <> 4 :: Int
--- 21
---
--- >>> foldOf (multiplied . summed) [[1, 2], [3, (4 :: Int)]]
--- 21
+-- In this situation you most likely want to use 'multiplied1'.
--
multiplied :: Foldable f => Monoid r => Semiring r => AFold r (f a) a
multiplied = afold Rng.product
+{-# INLINE multiplied #-}
--- | Precompose with a Moore machine.
+---------------------------------------------------------------------
+-- Primitive operators
+---------------------------------------------------------------------
+
+-- | Map an optic to a monoid and combine the results.
+--
+-- @
+-- 'Data.Foldable.foldMap' = 'withFold' 'folded_''
+-- @
+--
+-- >>> withFold both id (["foo"], ["bar", "baz"])
+-- ["foo","bar","baz"]
+--
+-- >>> :t withFold . fold_
+-- withFold . fold_
+-- :: (Monoid r, Foldable f) => (s -> f a) -> (a -> r) -> s -> r
+--
+-- >>> :t withFold traversed
+-- withFold traversed
+-- :: (Monoid r, Traversable f) => (a -> r) -> f a -> r
--
-premapped :: Handler b a -> L.Fold a c -> L.Fold b c
-premapped o (L.Fold h z k) = L.Fold (foldsl' o h) z k
+-- >>> :t withFold left
+-- withFold left :: Monoid r => (a -> r) -> (a + c) -> r
+--
+-- >>> :t withFold t21
+-- withFold t21 :: Monoid r => (a -> r) -> (a, b) -> r
+--
+-- >>> :t withFold $ selected even
+-- withFold $ selected even
+-- :: (Monoid r, Integral a) => (b -> r) -> (a, b) -> r
+--
+-- >>> :t flip withFold Seq.singleton
+-- flip withFold Seq.singleton :: AFold (Seq a) s a -> s -> Seq a
+--
+withFold :: Monoid r => AFold r s a -> (a -> r) -> s -> r
+withFold = withPrimView
+{-# INLINE withFold #-}
--- | Precompose with an effectful Moore machine.
+-- | TODO: Document
+--
+-- >>> :t flip withIxfold Map.singleton
+-- flip withIxfold Map.singleton
+-- :: AIxfold (Map i a) i s a -> i -> s -> Map i a
--
-premappedM :: Monad m => HandlerM m b a -> L.FoldM m a c -> L.FoldM m b c
-premappedM o (L.FoldM h z k) = L.FoldM (foldsM' o h) z k
+withIxfold :: AIxfold r i s a -> (i -> a -> r) -> i -> s -> r
+withIxfold o f = curry $ withPrimView o (uncurry f)
+{-# INLINE withIxfold #-}
---------------------------------------------------------------------
--- Derived operators
+-- Operators
---------------------------------------------------------------------
infixl 8 ^..
--- | Infix version of 'toListOf'.
+-- | Infix version of 'lists'.
--
-- @
--- 'Data.Foldable.toList' xs ≡ xs '^..' 'folded'
--- ('^..') ≡ 'flip' 'toListOf'
+-- 'Data.Foldable.toList' xs ≡ xs '^..' 'folding'
+-- ('^..') ≡ 'flip' 'lists'
-- @
--
--- >>> [[1,2],[3]] ^.. id
+-- >>> [[1,2], [3 :: Int]] ^.. id
-- [[[1,2],[3]]]
--- >>> [[1,2],[3]] ^.. traversed
+-- >>> [[1,2], [3 :: Int]] ^.. traversed
-- [[1,2],[3]]
--- >>> [[1,2],[3]] ^.. traversed . traversed
+-- >>> [[1,2], [3 :: Int]] ^.. traversed . traversed
-- [1,2,3]
--
-- >>> (1,2) ^.. bitraversed
@@ -239,30 +328,70 @@ infixl 8 ^..
-- ('^..') :: s -> 'Iso'' s a -> [a]
-- ('^..') :: s -> 'Traversal'' s a -> [a]
-- ('^..') :: s -> 'Prism'' s a -> [a]
--- ('^..') :: s -> 'Traversal0'' s a -> [a]
+-- ('^..') :: s -> 'Affine'' s a -> [a]
-- @
--
(^..) :: s -> AFold (Endo [a]) s a -> [a]
-(^..) = flip toListOf
+(^..) = flip lists
{-# INLINE (^..) #-}
--- | Right fold lift a 'Fold'.
+infixl 8 ^??
+
+-- | Return a semigroup aggregation of the foci, if they exist.
--
--- >>> foldsr'' folded (<>) (zero :: Int) [1..5]
+(^??) :: Semigroup a => s -> AFold (Maybe a) s a -> Maybe a
+s ^?? o = withFold o Just s
+{-# INLINE (^??) #-}
+
+-- | TODO: Document
+--
+folds :: Monoid a => AFold a s a -> s -> a
+folds = flip withFold id
+{-# INLINE folds #-}
+
+-- | TODO: Document
+--
+-- @
+-- foldsa :: Fold s a -> s -> [a]
+-- foldsa :: Applicative f => Setter s t a b -> s -> f a
+-- @
+--
+foldsa :: Applicative f => Monoid (f a) => AFold (f a) s a -> s -> f a
+foldsa = flip withFold pure
+{-# INLINE foldsa #-}
+
+-- | Compute the semiring product of the foci of an optic.
+--
+-- For semirings without a multiplicative unit this is equivalent to @const mempty@:
+--
+-- >>> foldsp folded Just [1..(5 :: Int)]
+-- Just 0
+--
+-- In this situation you most likely want to use 'folds1p'.
+--
+foldsp :: Monoid r => Semiring r => AFold (Prod r) s a -> (a -> r) -> s -> r
+foldsp o p = getProd . withFold o (Prod . p)
+{-# INLINE foldsp #-}
+
+-- | Right fold over an optic.
+--
+-- >>> foldsr folded (<>) 0 [1..5::Int]
-- 15
--
foldsr :: AFold (Endo r) s a -> (a -> r -> r) -> r -> s -> r
-foldsr p f r = (`appEndo` r) . foldMapOf p (Endo . f)
+foldsr o f r = (`appEndo` r) . withFold o (Endo . f)
+{-# INLINE foldsr #-}
--- | Left fold lift a 'Fold'.
+-- | Left fold over an optic.
--
-foldsl :: AFold (Dual (Endo c)) s a -> (c -> a -> c) -> c -> s -> c
-foldsl p f r = (`appEndo` r) . getDual . foldMapOf p (Dual . Endo . flip f)
+foldsl :: AFold (Dual (Endo r)) s a -> (r -> a -> r) -> r -> s -> r
+foldsl o f r = (`appEndo` r) . getDual . withFold o (Dual . Endo . flip f)
+{-# INLINE foldsl #-}
--- | Fold lift the elements of a structure, associating to the left, but strictly.
+-- | Fold repn the elements of a structure, associating to the left, but strictly.
--
-- @
--- 'Data.Foldable.foldl'' ≡ 'foldsl'' 'folded'
+-- 'Data.Foldable.foldl'' ≡ 'foldsl'' 'folding'
-- @
--
-- @
@@ -274,96 +403,262 @@ foldsl p f r = (`appEndo` r) . getDual . foldMapOf p (Dual . Endo . flip f)
-- 'foldsl'' :: 'Traversal0'' s a -> (c -> a -> c) -> c -> s -> c
-- @
--
-foldsl' :: AFold (Endo (Endo c)) s a -> (c -> a -> c) -> c -> s -> c
-foldsl' o f c s = foldsr o f' (Endo id) s `appEndo` c
+foldsl' :: AFold (Endo (Endo r)) s a -> (r -> a -> r) -> r -> s -> r
+foldsl' o f r s = foldsr o f' (Endo id) s `appEndo` r
where f' x (Endo k) = Endo $ \z -> k $! f z x
{-# INLINE foldsl' #-}
--- | A strict monadic left fold.
+-- | Collect an applicative over the foci of an optic.
--
-foldsM' :: Monad m => AFold (Endo (EndoM m r)) s a -> (r -> a -> m r) -> r -> s -> m r
-foldsM' o f c s = foldsr o f' mempty s `appEndoM` c
- where f' x (EndoM k) = EndoM $ \z -> (f $! z) x >>= k
+-- >>> traverses_ both putStrLn ("hello","world")
+-- hello
+-- world
+--
+-- @
+-- 'Data.Foldable.traverse_' ≡ 'traverses_' 'folded'
+-- @
+--
+traverses_ :: Applicative f => AFold (Endo (f ())) s a -> (a -> f r) -> s -> f ()
+traverses_ p f = foldsr p (\a fu -> void (f a) *> fu) (pure ())
+{-# INLINE traverses_ #-}
--- | TODO: Document
+-- | Collect the foci of an optic into a list.
--
-endo :: AFold (Endo (a -> a)) s (a -> a) -> s -> a -> a
-endo o = foldsr o (.) id
+lists :: AFold (Endo [a]) s a -> s -> [a]
+lists o = foldsr o (:) []
+{-# INLINE lists #-}
--- | TODO: Document
+-- | Map a function over all the foci of an optic and concatenate the resulting lists.
--
-endoM :: Monad m => AFold (Endo (a -> m a)) s (a -> m a) -> s -> a -> m a
-endoM o = foldsr o (<=<) pure
+-- >>> concats both (\x -> [x, x + 1]) (1,3)
+-- [1,2,3,4]
+--
+-- @
+-- 'concatMap' ≡ 'concats' 'folded'
+-- @
+--
+concats :: AFold [r] s a -> (a -> [r]) -> s -> [r]
+concats = withFold
+{-# INLINE concats #-}
--- | TODO: Document
+-- | Find the first focus of an optic that satisfies a predicate, if one exists.
--
-all :: AFold All s a -> (a -> Bool) -> s -> Bool
-all o p = getAll . foldMapOf o (All . p)
+-- >>> finds both even (1,4)
+-- Just 4
+--
+-- >>> finds folded even [1,3,5,7]
+-- Nothing
+--
+-- @
+-- 'Data.Foldable.find' ≡ 'finds' 'folded'
+-- @
+--
+finds :: AFold (Endo (Maybe a)) s a -> (a -> Bool) -> s -> Maybe a
+finds o f = foldsr o (\a y -> if f a then Just a else y) Nothing
+{-# INLINE finds #-}
+
+-- | Determine whether an optic has at least one focus.
+--
+has :: AFold Any s a -> s -> Bool
+has o = withFold o (const True)
+{-# INLINE has #-}
+
+-- | Determine whether an optic does not have a focus.
+--
+hasnt :: AFold All s a -> s -> Bool
+hasnt o = foldsp o (const False)
+{-# INLINE hasnt #-}
-- | TODO: Document
--
-any :: AFold Any s a -> (a -> Bool) -> s -> Bool
-any o p = getAny . foldMapOf o (Any . p)
+nulls :: AFold All s a -> s -> Bool
+nulls o = foldsp o (const False)
+{-# INLINE nulls #-}
--- | Determine whether a `Fold` contains a given element.
-elem :: Eq a => AFold Any s a -> a -> s -> Bool
-elem p a = any p (== a)
+-- | The sum of a collection of actions, generalizing 'concatOf'.
+--
+-- >>> asums both ("hello","world")
+-- "helloworld"
+--
+-- >>> asums both (Nothing, Just "hello")
+-- Just "hello"
+--
+-- @
+-- 'asum' ≡ 'asums' 'folded'
+-- @
+--
+asums :: Alternative f => AFold (Endo (Endo (f a))) s (f a) -> s -> f a
+asums o = foldsl' o (<|>) empty
+{-# INLINE asums #-}
--- | Determine whether a `Fold` not contains a given element.
-notElem :: Eq a => AFold All s a -> a -> s -> Bool
-notElem p a = all p (/= a)
+-- | Compute the join of the foci of an optic.
+--
+joins :: Lattice a => AFold (Endo (Endo a)) s a -> a -> s -> a
+joins o = foldsl' o (\/)
+{-# INLINE joins #-}
--- | Determine whether a `Fold` has at least one focus.
+-- | Compute the join of the foci of an optic including a least element.
--
-has :: AFold Any s a -> s -> Bool
-has p = getAny . foldMapOf p (const (Any True))
+joins' :: Lattice a => Min a => AFold (Endo (Endo a)) s a -> s -> a
+joins' o = joins o minimal
+{-# INLINE joins' #-}
--- | Determine whether a `Fold` does not have a focus.
+-- | Compute the meet of the foci of an optic .
--
-hasnt :: AFold All s a -> s -> Bool
-hasnt p = getAll . foldMapOf p (const (All False))
+meets :: Lattice a => AFold (Endo (Endo a)) s a -> a -> s -> a
+meets o = foldsl' o (/\)
+{-# INLINE meets #-}
--- | TODO: Document
+-- | Compute the meet of the foci of an optic including a greatest element.
+--
+meets' :: Lattice a => Max a => AFold (Endo (Endo a)) s a -> s -> a
+meets' o = meets o maximal
+{-# INLINE meets' #-}
+
+-- | Determine whether the foci of an optic contain an element equivalent to a given element.
+--
+pelem :: Prd a => AFold Any s a -> a -> s -> Bool
+pelem o a = withFold o (Prd.=~ a)
+{-# INLINE pelem #-}
+
+------------------------------------------------------------------------------
+-- Indexed operators
+------------------------------------------------------------------------------
+
+infixl 8 ^%%
+
+-- | Infix version of 'ixlists'.
+--
+(^%%) :: Monoid i => s -> AIxfold (Endo [(i, a)]) i s a -> [(i, a)]
+(^%%) = flip ixlists
+{-# INLINE (^%%) #-}
+
+-- | Indexed right fold over an indexed optic.
+--
+-- @
+-- 'foldsr' o ≡ 'ixfoldsr' o '.' 'const'
+-- @
+--
+-- >>> ixfoldsr ixtraversed (\i a -> ((show i ++ ":" ++ show a ++ ", ") ++)) [] [1,3,5,7,9]
+-- "0:1, 1:3, 2:5, 3:7, 4:9, "
+--
+ixfoldsr :: Monoid i => AIxfold (Endo r) i s a -> (i -> a -> r -> r) -> r -> s -> r
+ixfoldsr o f = ixfoldsrFrom o f mempty
+{-# INLINE ixfoldsr #-}
+
+-- | Indexed right fold over an indexed optic, using an initial index value.
+--
+ixfoldsrFrom :: AIxfold (Endo r) i s a -> (i -> a -> r -> r) -> i -> r -> s -> r
+ixfoldsrFrom o f i r = (`appEndo` r) . withIxfold o (\i -> Endo . f i) i
+{-# INLINE ixfoldsrFrom #-}
+
+-- | Indexed left fold over an indexed optic.
+--
+-- @
+-- 'foldsl' ≡ 'ixfoldsl' '.' 'const'
+-- @
+--
+ixfoldsl :: Monoid i => AIxfold (Dual (Endo r)) i s a -> (i -> r -> a -> r) -> r -> s -> r
+ixfoldsl o f = ixfoldslFrom o f mempty
+{-# INLINE ixfoldsl #-}
+
+-- | Indexed left fold over an indexed optic, using an initial index value.
+--
+ixfoldslFrom :: AIxfold (Dual (Endo r)) i s a -> (i -> r -> a -> r) -> i -> r -> s -> r
+ixfoldslFrom o f i r = (`appEndo` r) . getDual . withIxfold o (\i -> Dual . Endo . flip (f i)) i
+{-# INLINE ixfoldslFrom #-}
+
+-- | Indexed monadic right fold over an indexed optic.
--
-null :: AFold All s a -> s -> Bool
-null o = all o (const False)
+-- @
+-- 'foldsrM' ≡ 'ixfoldrM' '.' 'const'
+-- @
+--
+ixfoldsrM :: Monoid i => Monad m => AIxfold (Dual (Endo (r -> m r))) i s a -> (i -> a -> r -> m r) -> r -> s -> m r
+ixfoldsrM o f z0 xs = ixfoldsl o f' return xs z0
+ where f' i k x z = f i x z >>= k
+{-# INLINE ixfoldsrM #-}
--- | Find the minimum of a totally ordered set.
+-- | Indexed monadic right fold over an 'Ixfold', using an initial index value.
--
-min :: Ord a => AFold (Endo (Endo a)) s a -> a -> s -> a
-min o = foldsl' o Pre.min
+ixfoldsrMFrom :: Monad m => AIxfold (Dual (Endo (r -> m r))) i s a -> (i -> a -> r -> m r) -> i -> r -> s -> m r
+ixfoldsrMFrom o f i z0 xs = ixfoldslFrom o f' i return xs z0
+ where f' i k x z = f i x z >>= k
+{-# INLINE ixfoldsrMFrom #-}
--- | Find the maximum of a totally ordered set.
+-- | Indexed monadic left fold over an indexed optic.
+--
+-- @
+-- 'foldslM' ≡ 'ixfoldslM' '.' 'const'
+-- @
--
-max :: Ord a => AFold (Endo (Endo a)) s a -> a -> s -> a
-max o = foldsl' o Pre.max
+ixfoldslM :: Monoid i => Monad m => AIxfold (Endo (r -> m r)) i s a -> (i -> r -> a -> m r) -> r -> s -> m r
+ixfoldslM o f z0 xs = ixfoldsr o f' return xs z0
+ where f' i x k z = f i z x >>= k
+{-# INLINE ixfoldslM #-}
--- | Find the (partial) minimum of a partially ordered set.
+-- | Indexed monadic left fold over an indexed optic, using an initial index value.
+--
+ixfoldslMFrom :: Monad m => AIxfold (Endo (r -> m r)) i s a -> (i -> r -> a -> m r) -> i -> r -> s -> m r
+ixfoldslMFrom o f i z0 xs = ixfoldsrFrom o f' i return xs z0
+ where f' i x k z = f i z x >>= k
+{-# INLINE ixfoldslMFrom #-}
+
+-- | Extract the key-value pairs from the foci of an indexed optic.
+--
+-- @
+-- 'lists' l ≡ 'map' 'snd' '.' 'ixlists' l
+-- @
--
-pmin :: Eq a => Prd a => AFold (Endo (EndoM Maybe a)) s a -> a -> s -> Maybe a
-pmin o = foldsM' o Prd.pmin
+ixlists :: Monoid i => AIxfold (Endo [(i, a)]) i s a -> s -> [(i, a)]
+ixlists o = ixfoldsr o (\i a -> ((i,a):)) []
+{-# INLINE ixlists #-}
--- | Find the (partial) minimum of a partially ordered set.
+-- | Extract key-value pairs from the foci of an indexed optic, using an initial index value.
--
-pmax :: Eq a => Prd a => AFold (Endo (EndoM Maybe a)) s a -> a -> s -> Maybe a
-pmax o = foldsM' o Prd.pmax
+ixlistsFrom :: AIxfold (Endo [(i, a)]) i s a -> i -> s -> [(i, a)]
+ixlistsFrom o i = ixfoldsrFrom o (\i a -> ((i,a):)) i []
+{-# INLINE ixlistsFrom #-}
--- | Find the (partial) join of a sublattice.
+-- | Collect an applicative over the foci of an indexed optic.
--
-join :: Lattice a => AFold (Endo (Endo a)) s a -> a -> s -> a
-join o = foldsl' o (\/)
+ixtraverses_ :: Monoid i => Applicative f => AIxfold (Endo (f ())) i s a -> (i -> a -> f r) -> s -> f ()
+ixtraverses_ p f = ixfoldsr p (\i a fu -> void (f i a) *> fu) (pure ())
+{-# INLINE ixtraverses_ #-}
--- | Find the join of a sublattice or return the bottom element.
+-- | Concatenate the results of a function of the foci of an indexed optic.
--
-join' :: Lattice a => Min a => AFold (Endo (Endo a)) s a -> s -> a
-join' o = join o minimal
+-- @
+-- 'concats' o ≡ 'ixconcats' o '.' 'const'
+-- @
+--
+-- >>> ixconcats ixtraversed (\i x -> [i + x, i + x + 1]) [1,2,3,4]
+-- [1,2,3,4,5,6,7,8]
+--
+ixconcats :: Monoid i => AIxfold [r] i s a -> (i -> a -> [r]) -> s -> [r]
+ixconcats o f = withIxfold o f mempty
+{-# INLINE ixconcats #-}
--- | Find the (partial) meet of a sublattice.
+-- | Find the first focus of an indexed optic that satisfies a predicate, if one exists.
--
-meet :: Lattice a => AFold (Endo (Endo a)) s a -> a -> s -> a
-meet o = foldsl' o (/\)
+ixfinds :: Monoid i => AIxfold (Endo (Maybe (i, a))) i s a -> (i -> a -> Bool) -> s -> Maybe (i, a)
+ixfinds o f = ixfoldsr o (\i a y -> if f i a then Just (i,a) else y) Nothing
+{-# INLINE ixfinds #-}
+
+------------------------------------------------------------------------------
+-- Auxilliary Types
+------------------------------------------------------------------------------
+
+type All = Prod Bool
--- | Find the meet of a sublattice or return the top element.
+type Any = Bool
+
+---------------------------------------------------------------------
+-- Carriers
+---------------------------------------------------------------------
+
+-- | TODO: Document
--
-meet' :: Lattice a => Max a => AFold (Endo (Endo a)) s a -> s -> a
-meet' o = meet o maximal
+afold :: ((a -> r) -> s -> r) -> AFold r s a
+afold o = Star #. (Const #.) #. o .# (getConst #.) .# runStar
+{-# INLINE afold #-}
diff --git a/src/Data/Profunctor/Optic/Fold0.hs b/src/Data/Profunctor/Optic/Fold0.hs
index 403d9dd..39905f4 100644
--- a/src/Data/Profunctor/Optic/Fold0.hs
+++ b/src/Data/Profunctor/Optic/Fold0.hs
@@ -1,31 +1,119 @@
-module Data.Profunctor.Optic.Fold0 where
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+module Data.Profunctor.Optic.Fold0 (
+ -- * Fold0 & Ixfold0
+ Fold0
+ , fold0
+ , ixfold0
+ , failing
+ , toFold0
+ , fromFold0
+ -- * Optics
+ , folded0
+ -- * Primitive operators
+ , withFold0
+ , withIxfold0
+ -- * Operators
+ , (^?)
+ , preview
+ , preuse
+ -- * Indexed operators
+ , ixpreview
+ , ixpreviews
+ -- * MonadUnliftIO
+ , tries
+ , tries_
+ , catches
+ , catches_
+ , handles
+ , handles_
+ -- * Carriers
+ , Fold0Rep(..)
+ , AFold0
+ , AIxfold0
+ , Pre(..)
+ -- * Classes
+ , Strong(..)
+ , Choice(..)
+) where
-import Control.Monad.Reader as Reader
-import Control.Monad.State as State
+import Control.Applicative
+import Control.Exception (Exception)
+import Control.Monad ((<=<), void)
+import Control.Monad.IO.Unlift
+import Control.Monad.Reader as Reader hiding (lift)
+import Control.Monad.State as State hiding (lift)
+import Data.Foldable (Foldable, foldMap, traverse_)
import Data.Maybe
-import Data.Profunctor.Optic.Prelude
-import Data.Profunctor.Optic.Prism (_Just)
+import Data.Monoid hiding (All(..), Any(..))
+import Data.Prd (Prd(..), Min(..), Max(..))
+import Data.Prd.Lattice (Lattice(..))
+import Data.Profunctor.Optic.Import
+import Data.Profunctor.Optic.Prism (right, just, async)
+import Data.Profunctor.Optic.Traversal0 (ixtraversal0Vl, is)
import Data.Profunctor.Optic.Type
-import Data.Profunctor.Optic.View (to)
+import Data.Profunctor.Optic.View (AView, to, from, withPrimView, view, cloneView)
+import Data.Semiring (Semiring(..), Prod(..))
+import qualified Control.Exception as Ex
+import qualified Data.List.NonEmpty as NEL
+import qualified Data.Prd as Prd
+import qualified Data.Semiring as Rng
+
+-- $setup
+-- >>> :set -XNoOverloadedStrings
+-- >>> :set -XTypeApplications
+-- >>> :set -XFlexibleContexts
+-- >>> import Control.Exception hiding (catches)
+-- >>> import Data.Functor.Identity
+-- >>> import Data.List.Index
+-- >>> import Data.List.NonEmpty (NonEmpty(..))
+-- >>> import Data.Map as Map
+-- >>> import Data.Maybe
+-- >>> import Data.Monoid
+-- >>> import Data.Semiring hiding (unital,nonunital,presemiring)
+-- >>> import Data.Sequence as Seq
+-- >>> import qualified Data.List.NonEmpty as NE
+-- >>> :load Data.Profunctor.Optic
+-- >>> let ixtraversed :: Ixtraversal Int [a] [b] a b ; ixtraversed = ixtraversalVl itraverse
---------------------------------------------------------------------
--- 'Fold0'
+-- 'Fold0' & 'Ixfold0'
---------------------------------------------------------------------
--- | Build a 'Fold0' from an arbitrary function.
+type AFold0 r s a = Optic' (Fold0Rep r) s a
+
+type AIxfold0 r i s a = IndexedOptic' (Fold0Rep r) i s a
+
+-- | Obtain a 'Fold0' directly.
--
-- @
--- 'fold0' ('toMaybeOf' o) ≡ o
--- 'fold0' ('view' o) ≡ o . '_Just'
+-- 'fold0' . 'preview' ≡ id
+-- 'fold0' ('view' o) ≡ o . 'just'
-- @
--
--- >>> [Just 1, Nothing] ^.. folding id . fold0 id
--- [1]
+-- >>> preview (fold0 . preview $ selected even) (2, "yes")
+-- Just "yes"
+--
+-- >>> preview (fold0 . preview $ selected even) (3, "no")
+-- Nothing
+--
+-- >>> preview (fold0 listToMaybe) "foo"
+-- Just 'f'
--
fold0 :: (s -> Maybe a) -> Fold0 s a
-fold0 f = to (\s -> maybe (Left s) Right (f s)) . pright
+fold0 f = to (\s -> maybe (Left s) Right (f s)) . right'
{-# INLINE fold0 #-}
+-- | Create an 'Ixfold0' from a partial function.
+ixfold0 :: (s -> Maybe (i, a)) -> Ixfold0 i s a
+ixfold0 g = ixtraversal0Vl (\point f s -> maybe (point s) (uncurry f) $ g s) . coercer
+{-# INLINE ixfold0 #-}
+
infixl 3 `failing` -- Same as (<|>)
-- | Try the first 'Fold0'. If it returns no entry, try the second one.
@@ -34,67 +122,35 @@ failing :: AFold0 a s a -> AFold0 a s a -> Fold0 s a
failing a b = fold0 $ \s -> maybe (preview b s) Just (preview a s)
{-# INLINE failing #-}
--- | Build a 'Fold0' from a 'View'.
+-- | Obtain a 'Fold0' from a 'View'.
--
-- @
--- 'toFold0' o ≡ o . '_Just'
+-- 'toFold0' o ≡ o . 'just'
-- 'toFold0' o ≡ 'fold0' ('view' o)
-- @
--
toFold0 :: View s (Maybe a) -> Fold0 s a
-toFold0 = (. _Just)
+toFold0 = (. just)
{-# INLINE toFold0 #-}
--- | Build a 'View' from a 'Fold0'
+-- | Obtain a partial 'View' from a 'Fold0'
--
-fromFold0 :: Monoid a => AFold0 a s a -> View s (Maybe a)
+fromFold0 :: AFold0 a s a -> View s (Maybe a)
fromFold0 = to . preview
{-# INLINE fromFold0 #-}
---------------------------------------------------------------------
--- 'Fold0Rep'
+-- Optics
---------------------------------------------------------------------
-newtype Fold0Rep r a b = Fold0Rep { runFold0Rep :: a -> Maybe r }
-
-type AFold0 r s a = Optic' (Fold0Rep r) s a
-
-instance Functor (Fold0Rep r a) where
- fmap _ (Fold0Rep p) = Fold0Rep p
-
-instance Contravariant (Fold0Rep r a) where
- contramap _ (Fold0Rep p) = Fold0Rep p
-
-instance Profunctor (Fold0Rep r) where
- dimap f _ (Fold0Rep p) = Fold0Rep (p . f)
-
-instance Choice (Fold0Rep r) where
- left' (Fold0Rep p) = Fold0Rep (either p (const Nothing))
- right' (Fold0Rep p) = Fold0Rep (either (const Nothing) p)
-
-instance Cochoice (Fold0Rep r) where
- unleft (Fold0Rep k) = Fold0Rep (k . Left)
- unright (Fold0Rep k) = Fold0Rep (k . Right)
-
-instance Strong (Fold0Rep r) where
- first' (Fold0Rep p) = Fold0Rep (p . fst)
- second' (Fold0Rep p) = Fold0Rep (p . snd)
-
-instance Sieve (Fold0Rep r) (Pre r) where
- sieve = (Pre .) . runFold0Rep
-
-instance Representable (Fold0Rep r) where
- type Rep (Fold0Rep r) = Pre r
- tabulate = Fold0Rep . (getPre .)
- {-# INLINE tabulate #-}
-
--- | 'Pre' is 'Maybe' with a phantom type variable.
+-- | Obtain a 'Fold0' from a partial function.
--
-newtype Pre a b = Pre { getPre :: Maybe a } deriving (Eq, Ord, Show)
-
-instance Functor (Pre a) where fmap _ (Pre p) = Pre p
-
-instance Contravariant (Pre a) where contramap _ (Pre p) = Pre p
+-- >>> [Just 1, Nothing] ^.. folded . folded0
+-- [1]
+--
+folded0 :: Fold0 (Maybe a) a
+folded0 = fold0 id
+{-# INLINE folded0 #-}
---------------------------------------------------------------------
-- Primitive operators
@@ -102,28 +158,20 @@ instance Contravariant (Pre a) where contramap _ (Pre p) = Pre p
-- | TODO: Document
--
-previewOf :: Optic' (Fold0Rep r) s a -> (a -> Maybe r) -> s -> Maybe r
-previewOf = between runFold0Rep Fold0Rep
+withFold0 :: Optic (Fold0Rep r) s t a b -> (a -> Maybe r) -> s -> Maybe r
+withFold0 o = runFold0Rep #. o .# Fold0Rep
+{-# INLINE withFold0 #-}
-- | TODO: Document
--
-toMaybeOf :: AFold0 a s a -> s -> Maybe a
-toMaybeOf = flip previewOf Just
+withIxfold0 :: AIxfold0 r i s a -> (i -> a -> Maybe r) -> i -> s -> Maybe r
+withIxfold0 o f = curry $ withFold0 o (uncurry f)
+{-# INLINE withIxfold0 #-}
---------------------------------------------------------------------
--- Derived operators
+-- Operators
---------------------------------------------------------------------
--- | TODO: Document
---
-preview :: MonadReader s m => AFold0 a s a -> m (Maybe a)
-preview o = Reader.asks $ toMaybeOf o
-
--- | TODO: Document
---
-preuse :: MonadState s m => AFold0 a s a -> m (Maybe a)
-preuse o = State.gets $ preview o
-
infixl 8 ^?
-- | An infix variant of 'preview''.
@@ -138,29 +186,156 @@ infixl 8 ^?
-- When using a 'Traversal' as a partial 'Lens', or a 'Fold' as a partial
-- 'View' this can be a convenient way to extract the optional value.
--
--- >>> Left 4 ^? _L
+-- >>> Left 4 ^? left
-- Just 4
--
--- >>> Right 4 ^? _L
+-- >>> Right 4 ^? left
-- Nothing
--
(^?) :: s -> AFold0 a s a -> Maybe a
-s ^? o = toMaybeOf o s
+(^?) = flip preview
+{-# INLINE (^?) #-}
+
+-- | TODO: Document
+--
+preview :: MonadReader s m => AFold0 a s a -> m (Maybe a)
+preview o = Reader.asks $ withFold0 o Just
+{-# INLINE preview #-}
+
+-- | TODO: Document
+--
+preuse :: MonadState s m => AFold0 a s a -> m (Maybe a)
+preuse o = State.gets $ preview o
+{-# INLINE preuse #-}
+
+------------------------------------------------------------------------------
+-- Indexed operators
+------------------------------------------------------------------------------
+
+-- | TODO: Document
+--
+ixpreview :: Monoid i => AIxfold0 (i , a) i s a -> s -> Maybe (i , a)
+ixpreview o = ixpreviews o (,)
+{-# INLINE ixpreview #-}
+
+-- | TODO: Document
+--
+ixpreviews :: Monoid i => AIxfold0 r i s a -> (i -> a -> r) -> s -> Maybe r
+ixpreviews o f = withIxfold0 o (\i -> Just . f i) mempty
+{-# INLINE ixpreviews #-}
+
+------------------------------------------------------------------------------
+-- 'MonadUnliftIO'
+------------------------------------------------------------------------------
+
+-- | Test for synchronous exceptions that match a given optic.
+--
+-- In the style of 'safe-exceptions' this function rethrows async exceptions
+-- synchronously in order to preserve async behavior,
+--
+-- @
+-- 'tries' :: 'MonadUnliftIO' m => 'AFold0' e 'Ex.SomeException' e -> m a -> m ('Either' e a)
+-- 'tries' 'exception' :: 'MonadUnliftIO' m => 'Exception' e => m a -> m ('Either' e a)
+-- @
+--
+tries :: MonadUnliftIO m => Exception ex => AFold0 e ex e -> m a -> m (Either e a)
+tries o a = withRunInIO $ \run -> run (Right `liftM` a) `Ex.catch` \e ->
+ if is async e then throwM e else run $ maybe (throwM e) (return . Left) (preview o e)
+{-# INLINE tries #-}
+
+-- | A variant of 'tries' that returns synchronous exceptions.
+--
+tries_ :: MonadUnliftIO m => Exception ex => AFold0 e ex e -> m a -> m (Maybe a)
+tries_ o a = preview right `liftM` tries o a
+{-# INLINE tries_ #-}
+
+-- | Catch synchronous exceptions that match a given optic.
+--
+-- Rethrows async exceptions synchronously in order to preserve async behavior.
+--
+-- @
+-- 'catches' :: 'MonadUnliftIO' m => 'AFold0' e 'Ex.SomeException' e -> m a -> (e -> m a) -> m a
+-- 'catches' 'exception' :: 'MonadUnliftIO' m => Exception e => m a -> (e -> m a) -> m a
+-- @
+--
+-- >>> catches (only Overflow) (throwIO Overflow) (\_ -> return "caught")
+-- "caught"
+--
+catches :: MonadUnliftIO m => Exception ex => AFold0 e ex e -> m a -> (e -> m a) -> m a
+catches o a ea = withRunInIO $ \run -> run a `Ex.catch` \e ->
+ if is async e then throwM e else run $ maybe (throwM e) ea (preview o e)
+{-# INLINE catches #-}
--- | Check to see if this 'Fold0' doesn't match.
+-- | Catch synchronous exceptions that match a given optic, discarding the match.
--
--- >>> is _Just Nothing
--- False
+-- >>> catches_ (only Overflow) (throwIO Overflow) (return "caught")
+-- "caught"
--
-is :: AFold0 a s a -> s -> Bool
-is k s = isJust (preview k s)
-{-# INLINE is #-}
+catches_ :: MonadUnliftIO m => Exception ex => AFold0 e ex e -> m a -> m a -> m a
+catches_ o x y = catches o x $ const y
+{-# INLINE catches_ #-}
--- | Check to see if this 'Fold0' doesn't match.
+-- | Flipped variant of 'catches'.
+--
+-- >>> handles (only Overflow) (\_ -> return "caught") $ throwIO Overflow
+-- "caught"
--
--- >>> isnt _Just Nothing
--- True
+handles :: MonadUnliftIO m => Exception ex => AFold0 e ex e -> (e -> m a) -> m a -> m a
+handles o = flip $ catches o
+{-# INLINE handles #-}
+
+-- | Flipped variant of 'catches_'.
+--
+-- >>> handles_ (only Overflow) (return "caught") $ throwIO Overflow
+-- "caught"
+--
+handles_ :: MonadUnliftIO m => Exception ex => AFold0 e ex e -> m a -> m a -> m a
+handles_ o = flip $ catches_ o
+{-# INLINE handles_ #-}
+
+throwM :: MonadIO m => Exception e => e -> m a
+throwM = liftIO . Ex.throwIO
+{-# INLINE throwM #-}
+
+---------------------------------------------------------------------
+-- 'Fold0Rep'
+---------------------------------------------------------------------
+
+newtype Fold0Rep r a b = Fold0Rep { runFold0Rep :: a -> Maybe r }
+
+instance Functor (Fold0Rep r a) where
+ fmap _ (Fold0Rep p) = Fold0Rep p
+
+instance Contravariant (Fold0Rep r a) where
+ contramap _ (Fold0Rep p) = Fold0Rep p
+
+instance Profunctor (Fold0Rep r) where
+ dimap f _ (Fold0Rep p) = Fold0Rep (p . f)
+
+instance Choice (Fold0Rep r) where
+ left' (Fold0Rep p) = Fold0Rep (either p (const Nothing))
+ right' (Fold0Rep p) = Fold0Rep (either (const Nothing) p)
+
+instance Cochoice (Fold0Rep r) where
+ unleft (Fold0Rep k) = Fold0Rep (k . Left)
+ unright (Fold0Rep k) = Fold0Rep (k . Right)
+
+instance Strong (Fold0Rep r) where
+ first' (Fold0Rep p) = Fold0Rep (p . fst)
+ second' (Fold0Rep p) = Fold0Rep (p . snd)
+
+instance Sieve (Fold0Rep r) (Pre r) where
+ sieve = (Pre .) . runFold0Rep
+
+instance Representable (Fold0Rep r) where
+ type Rep (Fold0Rep r) = Pre r
+ tabulate = Fold0Rep . (getPre .)
+ {-# INLINE tabulate #-}
+
+-- | 'Pre' is 'Maybe' with a phantom type variable.
--
-isnt :: AFold0 a s a -> s -> Bool
-isnt k s = not (isJust (preview k s))
-{-# INLINE isnt #-}
+newtype Pre a b = Pre { getPre :: Maybe a } deriving (Eq, Ord, Show)
+
+instance Functor (Pre a) where fmap _ (Pre p) = Pre p
+
+instance Contravariant (Pre a) where contramap _ (Pre p) = Pre p
diff --git a/src/Data/Profunctor/Optic/Fold1.hs b/src/Data/Profunctor/Optic/Fold1.hs
new file mode 100644
index 0000000..7028bf4
--- /dev/null
+++ b/src/Data/Profunctor/Optic/Fold1.hs
@@ -0,0 +1,335 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+module Data.Profunctor.Optic.Fold1 (
+ -- * Fold1 & Ixfold1
+ Fold1
+ , fold1_
+ , folding1
+ , fold1Vl
+ , toFold1
+ , cloneFold1
+ -- * Cofold1 & Cxfold
+ , Cofold1
+ , cofold1Vl
+ , cofolding1
+ -- * Optics
+ , folded1
+ , cofolded1
+ , folded1_
+ , nonunital
+ , presemiring
+ , summed1
+ , multiplied1
+ -- * Primitive operators
+ , withFold1
+ , withCofold1
+ -- * Operators
+ , folds1
+ , cofolds1
+ , folds1p
+ , nelists
+ -- * Carriers
+ , FoldRep
+ , AFold1
+ , Cofold1Rep
+ , ACofold1
+ , afold1
+ , acofold1
+ , Star(..)
+ , Costar(..)
+ -- * Classes
+ , Representable(..)
+ , Corepresentable(..)
+ , Contravariant(..)
+ , Bifunctor(..)
+ -- * Auxilliary Types
+ , Nedl(..)
+) where
+
+import Control.Applicative
+import Control.Monad ((<=<), void)
+import Control.Monad.Reader as Reader hiding (lift)
+import Control.Monad.State as State hiding (lift)
+import Data.Foldable (Foldable, foldMap, traverse_)
+import Data.List.NonEmpty (NonEmpty(..))
+import Data.Maybe
+import Data.Monoid hiding (All(..), Any(..))
+import Data.Prd (Prd(..), Min(..), Max(..))
+import Data.Prd.Lattice (Lattice(..))
+import Data.Profunctor.Optic.Import
+import Data.Profunctor.Optic.Fold
+import Data.Profunctor.Optic.Prism (right, just, async)
+import Data.Profunctor.Optic.Traversal1
+import Data.Profunctor.Optic.Type
+import Data.Profunctor.Optic.View (AView, to, from, withPrimView, view, cloneView)
+import Data.Semiring (Semiring(..), Prod(..))
+import qualified Control.Exception as Ex
+import qualified Data.List.NonEmpty as NEL
+import qualified Data.Prd as Prd
+import qualified Data.Semiring as Rng
+
+-- $setup
+-- >>> :set -XNoOverloadedStrings
+-- >>> :set -XTypeApplications
+-- >>> :set -XFlexibleContexts
+-- >>> import Control.Exception hiding (catches)
+-- >>> import Data.Functor.Identity
+-- >>> import Data.List.Index
+-- >>> import Data.List.NonEmpty (NonEmpty(..))
+-- >>> import Data.Map as Map
+-- >>> import Data.Maybe
+-- >>> import Data.Monoid
+-- >>> import Data.Semiring hiding (unital,nonunital,presemiring)
+-- >>> import Data.Sequence as Seq
+-- >>> import qualified Data.List.NonEmpty as NE
+-- >>> :load Data.Profunctor.Optic
+-- >>> let ixtraversed :: Ixtraversal Int [a] [b] a b ; ixtraversed = ixtraversalVl itraverse
+
+---------------------------------------------------------------------
+-- 'Fold1' & 'Ixfold1'
+---------------------------------------------------------------------
+
+type AFold1 r s a = Optic' (FoldRep r) s a
+
+-- | Obtain a 'Fold1' directly.
+--
+-- @
+-- 'fold1_' ('nelists' o) ≡ o
+-- 'fold1_' f ≡ 'to' f . 'fold1Vl' 'traverse1_'
+-- 'fold1_' f ≡ 'coercer' . 'lmap' f . 'lift' 'traverse1_'
+-- @
+--
+-- See 'Data.Profunctor.Optic.Property'.
+--
+-- This can be useful to repn operations from @Data.List.NonEmpty@ and elsewhere into a 'Fold1'.
+--
+fold1_ :: Foldable1 f => (s -> f a) -> Fold1 s a
+fold1_ f = to f . fold1Vl traverse1_
+{-# INLINE fold1_ #-}
+
+-- | Obtain a 'Fold1' from a 'Traversable1' functor.
+--
+-- @
+-- 'folding1' f ≡ 'traversed1' . 'to' f
+-- 'folding1' f ≡ 'fold1Vl' 'traverse1' . 'to' f
+-- @
+--
+folding1 :: Traversable1 f => (s -> a) -> Fold1 (f s) a
+folding1 f = fold1Vl traverse1 . to f
+{-# INLINE folding1 #-}
+
+-- | Obtain a 'Fold1' from a Van Laarhoven 'Fold1'.
+--
+-- See 'Data.Profunctor.Optic.Property'.
+--
+fold1Vl :: (forall f. Apply f => (a -> f b) -> s -> f t) -> Fold1 s a
+fold1Vl f = coercer . repn f . coercer
+{-# INLINE fold1Vl #-}
+
+-- | Obtain a 'Fold1' from a 'View' or 'AFold1'.
+--
+toFold1 :: AView s a -> Fold1 s a
+toFold1 = to . view
+{-# INLINE toFold1 #-}
+
+-- | TODO: Document
+--
+afold1 :: Semigroup r => ((a -> r) -> s -> r) -> AFold1 r s a
+afold1 o = Star #. (Const #.) #. o .# (getConst #.) .# runStar
+{-# INLINE afold1 #-}
+
+-- | Obtain a 'Fold1' from a 'AFold1'.
+--
+cloneFold1 :: Semigroup a => AFold1 a s a -> View s a
+cloneFold1 = cloneView
+{-# INLINE cloneFold1 #-}
+
+---------------------------------------------------------------------
+-- 'Cofold1' & 'Cxfold'
+---------------------------------------------------------------------
+
+type Cofold1Rep r = Costar (Const r)
+
+type ACofold1 r t b = Optic' (Cofold1Rep r) t b
+
+-- | Obtain an 'Cofold1' from a 'Distributive' functor.
+--
+-- @
+-- 'cofolding1' f ≡ 'cotraversed1' . 'from' f
+-- 'cofolding1' f ≡ 'cofold1Vl' 'cotraverse' . 'from' f
+-- @
+--
+cofolding1 :: Distributive f => (b -> t) -> Cofold1 (f t) b
+cofolding1 f = cofold1Vl cotraverse . from f
+{-# INLINE cofolding1 #-}
+
+-- | Obtain a 'Cofold1' from a Van Laarhoven 'Cofold1'.
+--
+cofold1Vl :: (forall f. Apply f => (f a -> b) -> f s -> t) -> Cofold1 t b
+cofold1Vl f = coercel . corepn f . coercel
+{-# INLINE cofold1Vl #-}
+
+-- | TODO: Document
+--
+acofold1 :: ((r -> b) -> r -> t) -> ACofold1 r t b
+acofold1 o = Costar #. (.# getConst) #. o .# (.# Const) .# runCostar
+{-# INLINE acofold1 #-}
+
+---------------------------------------------------------------------
+-- Optics
+---------------------------------------------------------------------
+
+-- | Obtain a 'Fold1' from a 'Traversable1' functor.
+--
+folded1 :: Traversable1 f => Fold1 (f a) a
+folded1 = folding1 id
+{-# INLINE folded1 #-}
+
+-- | Obtain an 'Cofold1' from a 'Distributive' functor.
+--
+cofolded1 :: Distributive f => Cofold1 (f b) b
+cofolded1 = cofolding1 id
+{-# INLINE cofolded1 #-}
+
+-- | The canonical 'Fold1'.
+--
+-- @
+-- 'Data.Semigroup.Foldable.foldMap1' ≡ 'withFold1' 'folded1_''
+-- @
+--
+folded1_ :: Foldable1 f => Fold1 (f a) a
+folded1_ = fold1_ id
+{-# INLINE folded1_ #-}
+
+-- | Expression in a semiring expression with no multiplicative unit.
+--
+-- @
+-- 'nonunital' ≡ 'summed' . 'multiplied1'
+-- @
+--
+-- >>> foldOf nonunital $ (fmap . fmap) Just [1 :| [2], 3 :| [4 :: Int]]
+-- Just 14
+--
+nonunital :: Foldable f => Foldable1 g => Monoid r => Semiring r => AFold r (f (g a)) a
+nonunital = summed . multiplied1
+{-# INLINE nonunital #-}
+
+-- | Expression in a semiring with no additive or multiplicative unit.
+--
+-- @
+-- 'presemiring' ≡ 'summed1' . 'multiplied1'
+-- @
+--
+presemiring :: Foldable1 f => Foldable1 g => Semiring r => AFold1 r (f (g a)) a
+presemiring = summed1 . multiplied1
+{-# INLINE presemiring #-}
+
+-- | Semigroup sum of a non-empty foldable collection.
+--
+-- >>> 1 <> 2 <> 3 <> 4 :: Int
+-- 10
+-- >>> fold1Of summed1 $ 1 :| [2,3,4 :: Int]
+-- 10
+--
+summed1 :: Foldable1 f => Semigroup r => AFold1 r (f a) a
+summed1 = afold1 foldMap1
+{-# INLINE summed1 #-}
+
+-- | Semiring product of a non-empty foldable collection.
+--
+-- >>> fold1Of multiplied1 $ fmap Just (1 :| [2..(5 :: Int)])
+-- Just 120
+--
+multiplied1 :: Foldable1 f => Semiring r => AFold1 r (f a) a
+multiplied1 = afold1 Rng.product1
+{-# INLINE multiplied1 #-}
+
+---------------------------------------------------------------------
+-- Primitive operators
+---------------------------------------------------------------------
+
+-- | Map an optic to a semigroup and combine the results.
+--
+withFold1 :: Semigroup r => AFold1 r s a -> (a -> r) -> s -> r
+withFold1 = withPrimView
+{-# INLINE withFold1 #-}
+
+-- | TODO: Document
+--
+-- >>> withCofold1 (from succ) (*2) 3
+-- 7
+--
+-- Compare 'Data.Profunctor.Optic.View.withPrimReview'.
+--
+withCofold1 :: ACofold1 r t b -> (r -> b) -> r -> t
+withCofold1 o = (.# Const) #. runCostar #. o .# Costar .# (.# getConst)
+{-# INLINE withCofold1 #-}
+
+---------------------------------------------------------------------
+-- Operators
+---------------------------------------------------------------------
+
+-- | TODO: Document
+--
+folds1 :: Semigroup a => AFold1 a s a -> s -> a
+folds1 = flip withFold1 id
+{-# INLINE folds1 #-}
+
+-- | TODO: Document
+--
+cofolds1 :: ACofold1 b t b -> b -> t
+cofolds1 = flip withCofold1 id
+{-# INLINE cofolds1 #-}
+
+-- | Compute the semiring product of the foci of an optic.
+--
+-- For semirings without a multiplicative unit this is equivalent to @const mempty@:
+--
+-- >>> productOf folded Just [1..(5 :: Int)]
+-- Just 0
+--
+-- In this situation you most likely want to use 'folds1p'.
+--
+folds1p :: Semiring r => AFold (Prod r) s a -> (a -> r) -> s -> r
+folds1p o p = getProd . withFold1 o (Prod . p)
+{-# INLINE folds1p #-}
+
+{-
+>>> nelists bitraversed1 ('h' :| "ello", 'w' :| "orld")
+ "hello" :| ["world"]
+-}
+
+-- | Extract a 'NonEmpty' of the foci of an optic.
+--
+--
+-- @
+-- 'nelists' :: 'View' s a -> s -> NonEmpty a
+-- 'nelists' :: 'Fold1' s a -> s -> NonEmpty a
+-- 'nelists' :: 'Lens'' s a -> s -> NonEmpty a
+-- 'nelists' :: 'Iso'' s a -> s -> NonEmpty a
+-- 'nelists' :: 'Traversal1'' s a -> s -> NonEmpty a
+-- 'nelists' :: 'Prism'' s a -> s -> NonEmpty a
+-- @
+--
+nelists :: AFold1 (Nedl a) s a -> s -> NonEmpty a
+nelists l = flip getNedl [] . withFold1 l (Nedl #. (:|))
+{-# INLINE nelists #-}
+
+------------------------------------------------------------------------------
+-- Indexed operators
+------------------------------------------------------------------------------
+
+------------------------------------------------------------------------------
+-- Auxilliary Types
+------------------------------------------------------------------------------
+
+-- A non-empty difference list.
+newtype Nedl a = Nedl { getNedl :: [a] -> NEL.NonEmpty a }
+
+instance Semigroup (Nedl a) where
+ Nedl f <> Nedl g = Nedl (f . NEL.toList . g)
diff --git a/src/Data/Profunctor/Optic/Grate.hs b/src/Data/Profunctor/Optic/Grate.hs
index 3f486be..102c8ea 100644
--- a/src/Data/Profunctor/Optic/Grate.hs
+++ b/src/Data/Profunctor/Optic/Grate.hs
@@ -1,40 +1,130 @@
-
-module Data.Profunctor.Optic.Grate where
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+module Data.Profunctor.Optic.Grate (
+ -- * Types
+ Closed(..)
+ , Grate
+ , Grate'
+ , Cxgrate
+ , Cxgrate'
+ , AGrate
+ , AGrate'
+ -- * Constructors
+ , grate
+ , cxgrate
+ , grateVl
+ , cxgrateVl
+ , inverting
+ , cloneGrate
+ -- * Carriers
+ , GrateRep(..)
+ -- * Primitive operators
+ , withGrate
+ , constOf
+ , zipWithOf
+ , zipWith3Of
+ , zipWith4Of
+ , zipWithFOf
+ -- * Optics
+ --, closed
+ , cxclosed
+ , cxfirst
+ , cxsecond
+ , distributed
+ , connected
+ , forwarded
+ , continued
+ , unlifted
+ -- * Operators
+ , toEnvironment
+ , toClosure
+) where
import Control.Monad.Reader
import Control.Monad.Cont
import Control.Monad.IO.Unlift
import Data.Distributive
+import Data.Connection (Conn(..))
+import Data.Profunctor.Closed
import Data.Profunctor.Optic.Iso
import Data.Profunctor.Optic.Type
-import Data.Profunctor.Optic.Prelude
+import Data.Profunctor.Optic.Import
+import Data.Profunctor.Optic.Index
import Data.Profunctor.Rep (unfirstCorep)
-import qualified Data.Functor.Rep as F
-import qualified Control.Exception as Ex
+
+-- $setup
+-- >>> :set -XNoOverloadedStrings
+-- >>> :set -XTypeApplications
+-- >>> :set -XFlexibleContexts
+-- >>> :set -XTupleSections
+-- >>> import Control.Exception
+-- >>> import Control.Monad.Reader
+-- >>> import Data.Connection.Int
+-- >>> :load Data.Profunctor.Optic
---------------------------------------------------------------------
-- 'Grate'
---------------------------------------------------------------------
--- | Build a 'Grate' from a nested continuation.
+-- | Obtain a 'Grate' from a nested continuation.
+--
+-- The resulting optic is the corepresentable counterpart to 'Lens',
+-- and sits between 'Iso' and 'Setter'.
+--
+-- A 'Grate' lets you lift a profunctor through any representable
+-- functor (aka Naperian container). In the special case where the
+-- indexing type is finitary (e.g. 'Bool') then the tabulated type is
+-- isomorphic to a fixed length vector (e.g. 'V2 a').
+--
+-- The identity container is representable, and representable functors
+-- are closed under composition.
--
--- \( \quad \mathsf{Grate}\;S\;A = \exists I, S \cong I \to A \)
+-- See <https://www.cs.ox.ac.uk/jeremy.gibbons/publications/proyo.pdf>
+-- section 4.6 for more background on 'Grate's, and compare to the
+-- /lens-family/ <http://hackage.haskell.org/package/lens-family-2.0.0/docs/Lens-Family2.html#t:Grate version>.
--
--- The resulting optic is the corepresentable counterpart to 'Lens', and sits between 'Iso' and 'Setter'.
+-- /Caution/: In order for the generated optic to be well-defined,
+-- you must ensure that the input function satisfies the following
+-- properties:
--
--- See <https://www.cs.ox.ac.uk/jeremy.gibbons/publications/proyo.pdf> section 4.6
+-- * @sabt ($ s) ≡ s@
--
--- /Caution/: In order for the 'Grate' to be well-defined, you must ensure that the two grate laws hold:
+-- * @sabt (\k -> h (k . sabt)) ≡ sabt (\k -> h ($ k))@
--
--- * @grate ($ s) ≡ s@
+-- More generally, a profunctor optic must be monoidal as a natural
+-- transformation:
+--
+-- * @o id ≡ id@
--
--- * @grate (\k -> h (k . sabt)) ≡ sabt (\k -> h ($ k))@
+-- * @o ('Data.Profunctor.Composition.Procompose' p q) ≡ 'Data.Profunctor.Composition.Procompose' (o p) (o q)@
--
-- See 'Data.Profunctor.Optic.Property'.
--
grate :: (((s -> a) -> b) -> t) -> Grate s t a b
grate sabt = dimap (flip ($)) sabt . closed
+-- | TODO: Document
+--
+cxgrate :: (((s -> a) -> k -> b) -> t) -> Cxgrate k s t a b
+cxgrate f = grate $ \sakb _ -> f sakb
+
+-- | Transform a Van Laarhoven grate into a profunctor grate.
+--
+-- Compare 'Data.Profunctor.Optic.Lens.vlens' & 'Data.Profunctor.Optic.Traversal.cotraversalVl'.
+--
+grateVl :: (forall f. Functor f => (f a -> b) -> f s -> t) -> Grate s t a b
+grateVl o = dimap (curry eval) ((o trivial) . Coindex) . closed
+
+-- | TODO: Document
+--
+cxgrateVl :: (forall f. Functor f => (k -> f a -> b) -> f s -> t) -> Cxgrate k s t a b
+cxgrateVl f = grateVl $ \kab -> const . f (flip kab)
+
-- | Construct a 'Grate' from a pair of inverses.
--
inverting :: (s -> a) -> (b -> t) -> Grate s t a b
@@ -61,120 +151,144 @@ instance Profunctor (GrateRep a b) where
dimap f g (GrateRep z) = GrateRep $ \d -> g (z $ \k -> d (k . f))
instance Closed (GrateRep a b) where
- closed (GrateRep z) = GrateRep $ \f x -> z $ \k -> f $ \g -> k (g x)
+ closed (GrateRep sabt) = GrateRep $ \xsab x -> sabt $ \sa -> xsab $ \xs -> sa (xs x)
instance Costrong (GrateRep a b) where
unfirst = unfirstCorep
-instance Cosieve (GrateRep a b) (PCont a b) where
- cosieve (GrateRep f) (PCont g) = f g
+instance Cosieve (GrateRep a b) (Coindex a b) where
+ cosieve (GrateRep f) (Coindex g) = f g
instance Corepresentable (GrateRep a b) where
- type Corep (GrateRep a b) = PCont a b
+ type Corep (GrateRep a b) = Coindex a b
- cotabulate f = GrateRep $ f . PCont
-
-reviewGrate :: GrateRep a b s t -> b -> t
-reviewGrate (GrateRep e) b = e (const b)
+ cotabulate f = GrateRep $ f . Coindex
---------------------------------------------------------------------
-- Primitive operators
---------------------------------------------------------------------
--- | TODO: Document, replace with GrateLike
+-- | Extract the function that characterizes a 'Lens'.
--
withGrate :: AGrate s t a b -> ((((s -> a) -> b) -> t) -> r) -> r
-withGrate x k = case x (GrateRep $ \f -> f id) of GrateRep sabt -> k sabt
+withGrate o k = case o (GrateRep $ \f -> f id) of GrateRep sabt -> k sabt
-- | Set all fields to the given value.
--
constOf :: AGrate s t a b -> b -> t
-constOf x b = withGrate x $ \grt -> grt (const b)
+constOf o b = withGrate o $ \sabt -> sabt (const b)
-- | Zip over a 'Grate'.
--
--- @\f -> zipWithOf closed (zipWithOf closed f) === zipWithOf (closed . closed)@
+-- @\f -> 'zipWithOf' 'closed' ('zipWithOf' 'closed' f) ≡ 'zipWithOf' ('closed' . 'closed')@
--
zipWithOf :: AGrate s t a b -> (a -> a -> b) -> s -> s -> t
-zipWithOf x comb s1 s2 = withGrate x $ \grt -> grt $ \get -> comb (get s1) (get s2)
+zipWithOf o comb s1 s2 = withGrate o $ \sabt -> sabt $ \get -> comb (get s1) (get s2)
--- | Zip over a 'Grate'.
+-- | Zip over a 'Grate' with 3 arguments.
--
-zip3WithOf :: AGrate s t a b -> (a -> a -> a -> b) -> (s -> s -> s -> t)
-zip3WithOf x comb s1 s2 s3 = withGrate x $ \grt -> grt $ \get -> comb (get s1) (get s2) (get s3)
+zipWith3Of :: AGrate s t a b -> (a -> a -> a -> b) -> (s -> s -> s -> t)
+zipWith3Of o comb s1 s2 s3 = withGrate o $ \sabt -> sabt $ \get -> comb (get s1) (get s2) (get s3)
--- | Zip over a 'Grate'.
+-- | Zip over a 'Grate' with 4 arguments.
--
-zip4WithOf :: AGrate s t a b -> (a -> a -> a -> a -> b) -> (s -> s -> s -> s -> t)
-zip4WithOf x comb s1 s2 s3 s4 = withGrate x $ \grt -> grt $ \get -> comb (get s1) (get s2) (get s3) (get s4)
+zipWith4Of :: AGrate s t a b -> (a -> a -> a -> a -> b) -> (s -> s -> s -> s -> t)
+zipWith4Of o comb s1 s2 s3 s4 = withGrate o $ \sabt -> sabt $ \get -> comb (get s1) (get s2) (get s3) (get s4)
-- | Transform a profunctor grate into a Van Laarhoven grate.
--
--- This is a more restricted version of 'cotraverseOf'
+-- This is a more restricted version of 'Data.Profunctor.Optic.Repn.corepnOf'
--
-zipFWithOf :: Functor f => AGrate s t a b -> (f a -> b) -> f s -> t
-zipFWithOf x comb fs = withGrate x $ \grt -> grt $ \get -> comb (fmap get fs)
+zipWithFOf :: Functor f => AGrate s t a b -> (f a -> b) -> f s -> t
+zipWithFOf o comb fs = withGrate o $ \sabt -> sabt $ \get -> comb (fmap get fs)
---------------------------------------------------------------------
--- Common grates
+-- Optics
---------------------------------------------------------------------
-- | Access the contents of a distributive functor.
--
distributed :: Distributive f => Grate (f a) (f b) a b
-distributed = grate $ \f -> cotraverse f id
+distributed = grate (`cotraverse` id)
+{-# INLINE distributed #-}
--- | A 'Grate' accessing the contents of a representable functor.
+-- | Lift a Galois connection into a 'Grate'.
--
-represented :: F.Representable f => Grate (f a) (f b) a b
-represented = dimap F.index F.tabulate . closed
-
--- | TODO: Document
+-- Useful for giving precise semantics to numerical computations.
+--
+-- This is an example of a 'Grate' that would not be a legal 'Iso',
+-- as Galois connections are not in general inverses.
--
-applied :: Grate a (b -> c) (a , b) c
-applied = lmap (,) . closed
+-- >>> zipWithOf (connected i08i16) (+) 126 1
+-- 127
+-- >>> zipWithOf (connected i08i16) (+) 126 2
+-- 127
+--
+connected :: Conn s a -> Grate' s a
+connected (Conn f g) = inverting f g
+{-# INLINE connected #-}
--- | Provide an initial value to a 'Semigroup'.
+-- | Lift an action into a 'MonadReader'.
--
-pointed :: Semigroup a => a -> Grate' a a
-pointed = parametrized (<>)
+forwarded :: Distributive m => MonadReader r m => Grate (m a) (m b) a b
+forwarded = distributed
+{-# INLINE forwarded #-}
--- | Depend on a silent configuration parameter.
+-- | Lift an action into a continuation.
--
--- >>> zipWithOf (parametrized (+) 1) (*) 2 2
--- 9
+-- @
+-- 'zipWithOf' 'continued' :: (r -> r -> r) -> s -> s -> Cont r s
+-- @
--
-parametrized :: (x -> a -> a) -> x -> Grate' a a
-parametrized f x = dimap (flip f) ($ x) . closed
+continued :: Grate a (Cont r a) r r
+continued = grate cont
+{-# INLINE continued #-}
--- | TODO: Document
+-- | Unlift an action into an 'IO' context.
--
-masked :: MonadUnliftIO m => Grate (m a) (m b) (m a) (m b)
-masked = grate mask
- where
- mask f = withRunInIO $ \run -> Ex.mask $ \unmask -> run $ f $ liftIO . unmask . run
-
--- | TODO: Document
+-- @
+-- 'liftIO' ≡ 'constOf' 'unlifted'
+-- @
+--
+-- >>> let catchA = catch @ArithException
+-- >>> zipWithOf unlifted (flip catchA . const) (throwIO Overflow) (print "caught")
+-- "caught"
--
unlifted :: MonadUnliftIO m => Grate (m a) (m b) (IO a) (IO b)
unlifted = grate withRunInIO
+{-# INLINE unlifted #-}
--- | Access the range of a 'ReaderT'.
+-- >>> cxover cxclosed (,) (*2) 5
+-- ((),10)
--
-forwarded :: Distributive m => Grate (ReaderT r m a) (ReaderT r m b) a b
-forwarded = distributed
+cxclosed :: Cxgrate k (c -> a) (c -> b) a b
+cxclosed = rmap flip . closed
+{-# INLINE cxclosed #-}
-- | TODO: Document
--
-continued :: Grate a (Cont r a) r r
-continued = grate cont
+cxfirst :: Cxgrate k a b (a , c) (b , c)
+cxfirst = rmap (unfirst . uncurry . flip) . curry'
+{-# INLINE cxfirst #-}
+
+-- | TODO: Document
+--
+cxsecond :: Cxgrate k a b (c , a) (c , b)
+cxsecond = rmap (unsecond . uncurry) . curry' . lmap swap
+{-# INLINE cxsecond #-}
+
+---------------------------------------------------------------------
+-- Operators
+---------------------------------------------------------------------
--- | Translate between different 'Star's.
+-- | Use a 'Grate' to construct an 'Environment'.
--
-starred :: Grate (Star f a b) (Star g s t) (a -> f b) (s -> g t)
-starred = grate $ \o -> Star $ o runStar
+toEnvironment :: Closed p => AGrate s t a b -> p a b -> Environment p s t
+toEnvironment o p = withGrate o $ \sabt -> Environment sabt p (curry eval)
+{-# INLINE toEnvironment #-}
--- | Translate between different 'Costar's.
+-- | Use a 'Grate' to construct a 'Closure'.
--
-costarred :: Grate (Costar f a b) (Costar g s t) (f a -> b) (g s -> t)
-costarred = grate $ \o -> Costar $ o runCostar
+toClosure :: Closed p => AGrate s t a b -> p a b -> Closure p s t
+toClosure o p = withGrate o $ \sabt -> Closure (closed . grate sabt $ p)
+{-# INLINE toClosure #-}
diff --git a/src/Data/Profunctor/Optic/Prelude.hs b/src/Data/Profunctor/Optic/Import.hs
index c551276..5b1cde2 100644
--- a/src/Data/Profunctor/Optic/Prelude.hs
+++ b/src/Data/Profunctor/Optic/Import.hs
@@ -4,26 +4,27 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
-module Data.Profunctor.Optic.Prelude (
+module Data.Profunctor.Optic.Import (
module Export
) where
-import Control.Arrow as Export ((|||),(&&&),(+++),(***))
-import Control.Comonad as Export (Cokleisli(..))
import Control.Applicative as Export (liftA2, Alternative(..))
-import Control.Category as Export
-import Control.Monad as Export hiding (void)
+import Control.Category as Export hiding ((.), id)
+import Control.Monad as Export hiding (void, join)
import Control.Comonad as Export
-import Data.Bifunctor as Export (Bifunctor (..))
import Data.Distributive as Export
import Data.Function as Export ((&))
import Data.Functor as Export hiding (void)
-import Data.Functor.Const as Export
+import Data.Functor.Apply as Export
+import Data.Semigroup.Foldable as Export
+import Data.Semigroup.Traversable as Export
import Data.Functor.Compose as Export
+import Data.Functor.Const as Export
import Data.Functor.Contravariant as Export
-import Data.Functor.Contravariant.Divisible as Export
import Data.Functor.Identity as Export
-import Data.Profunctor.Types as Export
-import Data.Profunctor.Misc as Export
+import Data.Profunctor.Arrow as Export ((|||),(&&&),(+++),(***))
+import Data.Profunctor.Extra as Export
+import Data.Profunctor.Unsafe as Export
+import Data.Tagged as Export
import Data.Void as Export
-import Prelude as Export hiding (Foldable(..), (.), id, all, any, min, max, head, tail)
+import Prelude as Export hiding (Num(..), Foldable(..), all, any, min, max, head, tail, elem, notElem, userError)
diff --git a/src/Data/Profunctor/Optic/Index.hs b/src/Data/Profunctor/Optic/Index.hs
new file mode 100644
index 0000000..a12632d
--- /dev/null
+++ b/src/Data/Profunctor/Optic/Index.hs
@@ -0,0 +1,287 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DeriveGeneric #-}
+module Data.Profunctor.Optic.Index (
+ -- * Indexing
+ (%)
+ , ixinit
+ , ixlast
+ , reix
+ , ixmap
+ , withIxrepn
+ -- * Coindexing
+ , (#)
+ , cxinit
+ , cxlast
+ , recx
+ , cxmap
+ , cxed
+ , cxjoin
+ , cxreturn
+ , type Cx'
+ , cxunit
+ , cxpastro
+ , cxfirst'
+ , withCxrepn
+ -- * Index
+ , Index(..)
+ , values
+ , info
+ -- * Coindex
+ , Coindex(..)
+ , trivial
+ , noindex
+ , coindex
+ , (##)
+) where
+
+import Data.Bifunctor as B
+import Data.Foldable
+import Data.Semigroup
+import Data.Profunctor.Optic.Import
+import Data.Profunctor.Optic.Type
+import Data.Profunctor.Strong
+import GHC.Generics (Generic)
+
+-- $setup
+-- >>> :set -XNoOverloadedStrings
+-- >>> :set -XTypeApplications
+-- >>> :set -XFlexibleContexts
+-- >>> :set -XTupleSections
+-- >>> import Data.Semigroup
+-- >>> import Data.Semiring
+-- >>> import Data.Int.Instance ()
+-- >>> import Data.Map
+-- >>> :load Data.Profunctor.Optic
+-- >>> let ixtraversed :: Ord k => Ixtraversal k (Map k a) (Map k b) a b ; ixtraversed = ixtraversalVl traverseWithKey
+-- >>> let foobar = fromList [(0::Int, fromList [(0,"foo"), (1,"bar")]), (1, fromList [(0,"baz"), (1,"bip")])]
+-- >>> let exercises :: Map String (Map String Int); exercises = fromList [("Monday", fromList [("pushups", 10), ("crunches", 20)]), ("Wednesday", fromList [("pushups", 15), ("handstands", 3)]), ("Friday", fromList [("crunches", 25), ("handstands", 5)])]
+
+---------------------------------------------------------------------
+-- Indexing
+---------------------------------------------------------------------
+
+infixr 8 %
+
+-- | Compose two indexed traversals, combining indices.
+--
+-- Its precedence is one lower than that of function composition, which allows /./ to be nested in /%/.
+--
+-- If you only need the final index then use /./:
+--
+-- >>> ixlists (ixtraversed . ixtraversed) foobar
+-- [(0,"foo"),(1,"bar"),(0,"baz"),(1,"bip")]
+--
+-- >>> ixlistsFrom (ixlast ixtraversed % ixlast ixtraversed) (Last 0) foobar & fmapped . t21 ..~ getLast
+-- [(0,"foo"),(1,"bar"),(0,"baz"),(1,"bip")]
+--
+-- >>> ixlists (ixtraversed . ixtraversed) exercises
+-- [("crunches",25),("handstands",5),("crunches",20),("pushups",10),("handstands",3),("pushups",15)]
+--
+-- >>> ixlists (ixtraversed % ixtraversed) exercises
+-- [("Fridaycrunches",25),("Fridayhandstands",5),("Mondaycrunches",20),("Mondaypushups",10),("Wednesdayhandstands",3),("Wednesdaypushups",15)]
+--
+(%) :: Semigroup i => Representable p => IndexedOptic p i b1 b2 a1 a2 -> IndexedOptic p i c1 c2 b1 b2 -> IndexedOptic p i c1 c2 a1 a2
+f % g = repn $ \ia1a2 (ic,c1) ->
+ withIxrepn g ic c1 $ \ib b1 ->
+ withIxrepn f ib b1 $ \ia a1 -> ia1a2 (ib <> ia, a1)
+{-# INLINE (%) #-}
+
+ixinit :: Profunctor p => IndexedOptic p i s t a b -> IndexedOptic p (First i) s t a b
+ixinit = reix First getFirst
+
+ixlast :: Profunctor p => IndexedOptic p i s t a b -> IndexedOptic p (Last i) s t a b
+ixlast = reix Last getLast
+
+-- | Map over the indices of an indexed optic.
+--
+-- >>> ixlists (ixtraversed . reix (<>10) id ixtraversed) foobar
+-- [(10,"foo"),(11,"bar"),(10,"baz"),(11,"bip")]
+--
+-- See also 'Data.Profunctor.Optic.Iso.reixed'.
+--
+reix :: Profunctor p => (i -> j) -> (j -> i) -> IndexedOptic p i s t a b -> IndexedOptic p j s t a b
+reix ij ji = (. lmap (first' ij)) . (lmap (first' ji) .)
+
+-- >>> ixlists (ixtraversed . ixmap head pure) [[1,2,3],[4,5,6]]
+-- [(0,1),(1,4)]
+ixmap :: Profunctor p => (s -> a) -> (b -> t) -> IndexedOptic p i s t a b
+ixmap sa bt = dimap (fmap sa) bt
+
+withIxrepn :: Representable p => IndexedOptic p i s t a b -> i -> s -> (i -> a -> Rep p b) -> Rep p t
+withIxrepn abst i s iab = (sieve . abst . tabulate $ uncurry iab) (i, s)
+
+---------------------------------------------------------------------
+-- Coindexing
+---------------------------------------------------------------------
+
+infixr 8 #
+
+-- | Compose two coindexed traversals, combining indices.
+--
+-- Its precedence is one lower than that of function composition, which allows /./ to be nested in /#/.
+--
+-- If you only need the final index then use /./
+--
+(#) :: Semigroup k => Corepresentable p => CoindexedOptic p k b1 b2 a1 a2 -> CoindexedOptic p k c1 c2 b1 b2 -> CoindexedOptic p k c1 c2 a1 a2
+f # g = corepn $ \a1ka2 c1 kc ->
+ withCxrepn g c1 kc $ \b1 kb ->
+ withCxrepn f b1 kb $ \a1 ka -> a1ka2 a1 (kb <> ka)
+{-# INLINE (#) #-}
+
+cxinit :: Profunctor p => CoindexedOptic p k s t a b -> CoindexedOptic p (First k) s t a b
+cxinit = recx First getFirst
+
+cxlast :: Profunctor p => CoindexedOptic p k s t a b -> CoindexedOptic p (Last k) s t a b
+cxlast = recx Last getLast
+
+-- | Map over the indices of a coindexed optic.
+--
+-- See also 'Data.Profunctor.Optic.Iso.recxed'.
+--
+recx :: Profunctor p => (k -> l) -> (l -> k) -> CoindexedOptic p k s t a b -> CoindexedOptic p l s t a b
+recx kl lk = (. rmap (. kl)) . (rmap (. lk) .)
+
+cxmap :: Profunctor p => (s -> a) -> (b -> t) -> CoindexedOptic p k s t a b
+cxmap sa bt = dimap sa (fmap bt)
+
+-- | Generic type for a co-indexed optic.
+type Cx p k a b = p a (k -> b)
+
+type Cx' p a b = Cx p a a b
+
+cxed :: Strong p => Iso (Cx p s s t) (Cx p k a b) (p s t) (p a b)
+cxed = dimap cxjoin cxreturn
+
+cxjoin :: Strong p => Cx p a a b -> p a b
+cxjoin = peval
+
+cxreturn :: Profunctor p => p a b -> Cx p k a b
+cxreturn = rmap const
+
+cxunit :: Strong p => Cx' p :-> p
+cxunit p = dimap fork apply (first' p)
+
+cxpastro :: Profunctor p => Iso (Cx' p a b) (Cx' p c d) (Pastro p a b) (Pastro p c d)
+cxpastro = dimap (\p -> Pastro apply p fork) (\(Pastro l m r) -> dimap (fst . r) (\y a -> l (y, (snd (r a)))) m)
+
+-- | 'Cx'' is freely strong.
+--
+-- See <https://r6research.livejournal.com/27858.html>.
+--
+cxfirst' :: Profunctor p => Cx' p a b -> Cx' p (a, c) (b, c)
+cxfirst' = dimap fst (B.first @(,))
+
+withCxrepn :: Corepresentable p => CoindexedOptic p k s t a b -> Corep p s -> k -> (Corep p a -> k -> b) -> t
+withCxrepn abst s k akb = (cosieve . abst $ cotabulate akb) s k
+
+---------------------------------------------------------------------
+-- Index
+---------------------------------------------------------------------
+
+-- | An indexed store that characterizes a 'Data.Profunctor.Optic.Lens.Lens'
+--
+-- @'Index' a b r ≡ forall f. 'Functor' f => (a -> f b) -> f r@,
+--
+data Index a b r = Index a (b -> r)
+
+values :: Index a b r -> b -> r
+values (Index _ br) = br
+{-# INLINE values #-}
+
+info :: Index a b r -> a
+info (Index a _) = a
+{-# INLINE info #-}
+
+instance Functor (Index a b) where
+ fmap f (Index a br) = Index a (f . br)
+ {-# INLINE fmap #-}
+
+instance Profunctor (Index a) where
+ dimap f g (Index a br) = Index a (g . br . f)
+ {-# INLINE dimap #-}
+
+instance a ~ b => Foldable (Index a b) where
+ foldMap f (Index b br) = f . br $ b
+
+---------------------------------------------------------------------
+-- Coindex
+---------------------------------------------------------------------
+
+-- | An indexed continuation that characterizes a 'Data.Profunctor.Optic.Grate.Grate'
+--
+-- @'Coindex' a b k ≡ forall f. 'Functor' f => (f a -> b) -> f k@,
+--
+-- See also 'Data.Profunctor.Optic.Grate.zipWithFOf'.
+--
+-- 'Coindex' can also be used to compose indexed maps, folds, or traversals directly.
+--
+-- For example, using the @containers@ library:
+--
+-- @
+-- Coindex mapWithKey :: Coindex (a -> b) (Map k a -> Map k b) k
+-- Coindex foldMapWithKey :: Monoid m => Coindex (a -> m) (Map k a -> m) k
+-- Coindex traverseWithKey :: Applicative t => Coindex (a -> t b) (Map k a -> t (Map k b)) k
+-- @
+--
+newtype Coindex a b k = Coindex { runCoindex :: (k -> a) -> b } deriving Generic
+
+-- | Change the @Monoid@ used to combine indices.
+--
+instance Functor (Coindex a b) where
+ fmap kl (Coindex abk) = Coindex $ \la -> abk (la . kl)
+
+instance a ~ b => Apply (Coindex a b) where
+ (Coindex klab) <.> (Coindex abk) = Coindex $ \la -> klab $ \kl -> abk (la . kl)
+
+instance a ~ b => Applicative (Coindex a b) where
+ pure k = Coindex ($k)
+ (<*>) = (<.>)
+
+trivial :: Coindex a b a -> b
+trivial (Coindex f) = f id
+{-# INLINE trivial #-}
+
+-- | Lift a regular function into a coindexed function.
+--
+-- For example, to traverse two layers, keeping only the first index:
+--
+-- @
+-- Coindex 'Data.Map.mapWithKey' ## noindex 'Data.Map.map'
+-- :: Monoid k =>
+-- Coindex (a -> b) (Map k (Map j a) -> Map k (Map j b)) k
+-- @
+--
+noindex :: Monoid k => (a -> b) -> Coindex a b k
+noindex f = Coindex $ \a -> f (a mempty)
+
+coindex :: Functor f => k -> (a -> b) -> Coindex (f a) (f b) k
+coindex k ab = Coindex $ \kfa -> fmap ab (kfa k)
+{-# INLINE coindex #-}
+
+infixr 9 ##
+
+-- | Compose two coindexes.
+--
+-- When /k/ is a 'Monoid', 'Coindex' can be used to compose indexed traversals, folds, etc.
+--
+-- For example, to keep track of only the first index seen, use @Data.Monoid.First@:
+--
+-- @
+-- fmap (First . pure) :: Coindex a b c -> Coindex a b (First c)
+-- @
+--
+-- or keep track of all indices using a list:
+--
+-- @
+-- fmap (:[]) :: Coindex a b c -> Coindex a b [c]
+-- @
+--
+(##) :: Semigroup k => Coindex b c k -> Coindex a b k -> Coindex a c k
+Coindex f ## Coindex g = Coindex $ \b -> f $ \k1 -> g $ \k2 -> b (k1 <> k2)
diff --git a/src/Data/Profunctor/Optic/Iso.hs b/src/Data/Profunctor/Optic/Iso.hs
index 2001ac5..c97c09a 100644
--- a/src/Data/Profunctor/Optic/Iso.hs
+++ b/src/Data/Profunctor/Optic/Iso.hs
@@ -1,144 +1,315 @@
-module Data.Profunctor.Optic.Iso where
-
-import Control.Monad (join)
-import Data.Foldable
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+module Data.Profunctor.Optic.Iso (
+ -- * Types
+ Equality
+ , Equality'
+ , As
+ , Iso
+ , Iso'
+ -- * Constructors
+ , iso
+ , isoVl
+ , ixmapping
+ , cxmapping
+ , fmapping
+ , contramapping
+ , dimapping
+ , toYoneda
+ , toCoyoneda
+ , cloneIso
+ -- * Optics
+ , equaled
+ , coerced
+ , wrapped
+ , rewrapped
+ , rewrapping
+ , generic
+ , generic1
+ , flipped
+ , curried
+ , swapped
+ , eswapped
+ , associated
+ , eassociated
+ , involuted
+ , added
+ , subtracted
+ , viewedl
+ , viewedr
+ , non
+ , anon
+ , u1
+ , par1
+ , rec1
+ , k1
+ , m1
+ -- * Primitive operators
+ , withIso
+ , invert
+ , reover
+ , reixed
+ , recxed
+ , op
+ , au
+ , aup
+ , ala
+ -- * Auxilliary Types
+ , Re(..)
+ -- * Carriers
+ , AIso
+ , AIso'
+ , IsoRep(..)
+) where
+
+import Control.Newtype.Generics (Newtype(..), op)
+import Data.Coerce
+import Data.Group
import Data.Maybe (fromMaybe)
-import Data.Profunctor.Optic.Prelude
-import Data.Profunctor.Optic.Type
-
----------------------------------------------------------------------
--- 'Equality'
----------------------------------------------------------------------
-
--- | Constrain excessive polymorphism.
---
--- e.g turn an 'Optic' into an 'Optic'':
---
--- @
--- foo . (simple :: As Int) . bar
--- @
---
-simple :: As a
-simple = id
+import Data.Profunctor.Optic.Import
+import Data.Profunctor.Optic.Index
+import Data.Profunctor.Optic.Type hiding (Rep)
+import Data.Profunctor.Yoneda (Coyoneda(..), Yoneda(..))
+import Data.Sequence as Seq
+import GHC.Generics hiding (from, to)
+import qualified Control.Monad as M (join)
+import qualified GHC.Generics as GHC (to, from, to1, from1)
+
+-- $setup
+-- >>> :set -XNoOverloadedStrings
+-- >>> :set -XTypeApplications
+-- >>> :set -XAllowAmbiguousTypes
+-- >>> import Data.Monoid
+-- >>> import Data.Int.Instance ()
+-- >>> import Data.List.Index
+-- >>> import Data.Semiring
+-- >>> import Data.Sequence as Seq hiding (reverse)
+-- >>> import Data.Functor.Identity
+-- >>> import Data.Functor.Const
+-- >>> :load Data.Profunctor.Optic
+-- >>> let ixtraversed :: Ixtraversal Int [a] [b] a b ; ixtraversed = ixtraversalVl itraverse
---------------------------------------------------------------------
-- 'Iso'
---------------------------------------------------------------------
--- | Build an 'Iso' invert two inverses.
+-- | Obtain an 'Iso' from two inverses.
--
--- /Caution/: In order for the generated iso family to be well-defined,
--- you must ensure that the two isomorphism laws hold:
+-- /Caution/: In order for the generated optic to be well-defined,
+-- you must ensure that the input functions satisfy the following
+-- properties:
--
-- * @sa . bt ≡ id@
--
-- * @bt . sa ≡ id@
--
+-- More generally, a profunctor optic must be monoidal as a natural
+-- transformation:
+--
+-- * @o id ≡ id@
+--
+-- * @o ('Data.Profunctor.Composition.Procompose' p q) ≡ 'Data.Profunctor.Composition.Procompose' (o p) (o q)@
+--
+-- See 'Data.Profunctor.Optic.Property'.
+--
iso :: (s -> a) -> (b -> t) -> Iso s t a b
iso = dimap
+{-# INLINE iso #-}
--- | Invert an isomorphism.
+-- | Transform a Van Laarhoven 'Iso' into a profunctor 'Iso'.
+--
+isoVl :: (forall f g. Functor f => Functor g => (g a -> f b) -> g s -> f t) -> Iso s t a b
+isoVl abst = iso f g
+ where f = getConst . (abst (Const . runIdentity)) . Identity
+ g = runIdentity . (abst (Identity . getConst)) . Const
+{-# INLINE isoVl #-}
+
+-- | Lift an 'Iso' into an indexed version.
+--
+-- >>> ixlists (ixtraversed . ixmapping swapped) [(40,'f'),(41,'o'),(42,'o')]
+-- [(0,('f',40)),(1,('o',41)),(2,('o',42))]
+--
+ixmapping :: Profunctor p => AIso s t a b -> IndexedOptic p i s t a b
+ixmapping o = withIso o ixmap
+{-# INLINE ixmapping #-}
+
+-- | Lift an 'Iso' into a coindexed version.
+--
+cxmapping :: Profunctor p => AIso s t a b -> CoindexedOptic p k s t a b
+cxmapping o = withIso o cxmap
+{-# INLINE cxmapping #-}
+
+-- | TODO: Document
+--
+fmapping
+ :: Functor f
+ => Functor g
+ => AIso s t a b
+ -> Iso (f s) (g t) (f a) (g b)
+fmapping l = withIso l $ \sa bt -> iso (fmap sa) (fmap bt)
+{-# INLINE fmapping #-}
+
+-- | Lift an 'Iso' into a 'Contravariant' functor.
--
-- @
--- 'invert' ('invert' l) ≡ l
+-- contramapping :: 'Contravariant' f => 'Iso' s t a b -> 'Iso' (f a) (f b) (f s) (f t)
-- @
--
-invert :: AIso s t a b -> Iso b a t s
-invert l = withIso l $ \sa bt -> iso bt sa
-{-# INLINE invert #-}
+contramapping :: Contravariant f => Contravariant g => AIso s t a b -> Iso (f a) (g b) (f s) (g t)
+contramapping f = withIso f $ \sa bt -> iso (contramap sa) (contramap bt)
+{-# INLINE contramapping #-}
+
+-- | TODO: Document
+--
+dimapping
+ :: Profunctor p
+ => Profunctor q
+ => AIso s1 t1 a1 b1
+ -> AIso s2 t2 a2 b2
+ -> Iso (p a1 s2) (q b1 t2) (p s1 a2) (q t1 b2)
+dimapping f g = withIso f $ \sa1 bt1 ->
+ withIso g $ \sa2 bt2 -> iso (dimap sa1 sa2) (dimap bt1 bt2)
+{-# INLINE dimapping #-}
+
+-- | Lift an 'Iso' into a 'Yoneda'.
+--
+toYoneda :: Profunctor p => Iso s t a b -> p a b -> Yoneda p s t
+toYoneda o p = withIso o $ \sa bt -> Yoneda $ \f g -> dimap (sa . f) (g . bt) p
+{-# INLINE toYoneda #-}
+
+-- | Lift an 'Iso' into a 'Coyoneda'.
+--
+toCoyoneda :: Iso s t a b -> p a b -> Coyoneda p s t
+toCoyoneda o p = withIso o $ \sa bt -> Coyoneda sa bt p
+{-# INLINE toCoyoneda #-}
--- | Convert invert 'AIso' back to any 'Iso'.
+-- | Convert from 'AIso' back to any 'Iso'.
+--
cloneIso :: AIso s t a b -> Iso s t a b
cloneIso k = withIso k iso
{-# INLINE cloneIso #-}
---------------------------------------------------------------------
--- 'IsoRep'
+-- Optics
---------------------------------------------------------------------
--- | The 'IsoRep' profunctor precisely characterizes an 'Iso'.
-data IsoRep a b s t = IsoRep (s -> a) (b -> t)
-
--- | When you see this as an argument to a function, it expects an 'Iso'.
-type AIso s t a b = Optic (IsoRep a b) s t a b
-
-type AIso' s a = AIso s s a a
-
-instance Functor (IsoRep a b s) where
- fmap f (IsoRep sa bt) = IsoRep sa (f . bt)
- {-# INLINE fmap #-}
-
-instance Profunctor (IsoRep a b) where
- dimap f g (IsoRep sa bt) = IsoRep (sa . f) (g . bt)
- {-# INLINE dimap #-}
- lmap f (IsoRep sa bt) = IsoRep (sa . f) bt
- {-# INLINE lmap #-}
- rmap f (IsoRep sa bt) = IsoRep sa (f . bt)
- {-# INLINE rmap #-}
-
-instance Sieve (IsoRep a b) (PStore a b) where
- sieve (IsoRep sa bt) s = PStore (sa s) bt
-
-instance Cosieve (IsoRep a b) (PCont a b) where
- cosieve (IsoRep sa bt) (PCont sab) = bt (sab sa)
-
-data PStore a b t = PStore a (b -> t)
-
-values :: PStore a b t -> b -> t
-values (PStore _ bt) = bt
-
-info :: PStore a b t -> a
-info (PStore a _) = a
-
-instance Functor (PStore a b) where
- fmap f (PStore a bt) = PStore a (f . bt)
- {-# INLINE fmap #-}
-
-instance Profunctor (PStore a) where
- dimap f g (PStore a bt) = PStore a (g . bt . f)
- {-# INLINE dimap #-}
-
-instance a ~ b => Foldable (PStore a b) where
- foldMap f (PStore b bt) = f . bt $ b
-
-newtype PCont a b s = PCont { runPCont :: (s -> a) -> b }
-
-instance Functor (PCont a b) where
- fmap st (PCont sab) = PCont $ \ta -> sab (ta . st)
-
-runPCont' :: PCont a b a -> b
-runPCont' (PCont f) = f id
+-- | Capture type constraints as an 'Iso''.
+--
+-- >>> :t (^. equaled)
+-- (^. equaled) :: b -> b
+--
+equaled :: s ~ a => t ~ b => Iso s t a b
+equaled = id
+{-# INLINE equaled #-}
----------------------------------------------------------------------
--- Primitive operators
----------------------------------------------------------------------
+-- | Data types that are representationally equal.
+--
+-- >>> view coerced 'x' :: Identity Char
+-- Identity 'x'
+--
+coerced :: Coercible s a => Coercible t b => Iso s t a b
+coerced = dimap coerce coerce
+{-# INLINE coerced #-}
--- | Extract the two functions, one invert @s -> a@ and
--- one invert @b -> t@ that characterize an 'Iso'.
-withIso :: AIso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
-withIso x k = case x (IsoRep id id) of IsoRep sa bt -> k sa bt
-{-# INLINE withIso #-}
+-- | Work under a newtype wrapper.
+--
+-- @
+-- 'view wrapped' f '.' f ≡ 'id'
+-- f '.' 'view wrapped' f ≡ 'id'
+-- @
+--
+-- >>> view wrapped $ Identity 'x'
+-- 'x'
+--
+-- >>> view wrapped (Const "hello")
+-- "hello"
+--
+wrapped :: Newtype s => Iso' s (O s)
+wrapped = dimap unpack pack
+{-# INLINE wrapped #-}
-cycleOf :: AIso s t a b -> (t -> s) -> b -> a
-cycleOf x = withIso x $ \sa bt ts -> sa . ts . bt
+-- | Work between newtype wrappers.
+--
+-- >>> Const "hello" & rewrapped ..~ Prelude.length & getConst
+-- 5
+--
+rewrapped :: Newtype s => Newtype t => Iso s t (O s) (O t)
+rewrapped = withIso wrapped $ \ sa _ -> withIso wrapped $ \ _ bt -> iso sa bt
+{-# INLINE rewrapped #-}
-au :: AIso s t a b -> ((b -> t) -> e -> s) -> e -> a
-au l = withIso l $ \sa bt f e -> sa (f bt e)
+-- | Variant of 'rewrapped' that ignores its argument.
+--
+rewrapping :: Newtype s => Newtype t => (O s -> s) -> Iso s t (O s) (O t)
+rewrapping _ = rewrapped
+{-# INLINE rewrapping #-}
-auf :: Profunctor p => AIso s t a b -> (p r a -> e -> b) -> p r s -> e -> t
-auf l = withIso l $ \sa bt f g e -> bt (f (rmap sa g) e)
+-- | Convert between a data type and its 'Generic' representation.
+--
+-- >>> view (generic . re generic) "hello" :: String
+-- "hello"
+--
+generic :: Generic a => Generic b => Iso a b (Rep a c) (Rep b c)
+generic = iso GHC.from GHC.to
+{-# INLINE generic #-}
----------------------------------------------------------------------
--- Common isos
----------------------------------------------------------------------
+-- | Convert between a data type and its 'Generic1' representation.
+--
+generic1 :: Generic1 f => Generic1 g => Iso (f a) (g b) (Rep1 f a) (Rep1 g b)
+generic1 = iso GHC.from1 GHC.to1
+{-# INLINE generic1 #-}
+-- | Flip two arguments of a function.
+--
+-- >>> (view flipped (,)) 1 2
+-- (2,1)
+--
flipped :: Iso (a -> b -> c) (d -> e -> f) (b -> a -> c) (e -> d -> f)
flipped = iso flip flip
+{-# INLINE flipped #-}
+-- | TODO: Document
+--
+-- >>> (fst ^. curried) 3 4
+-- 3
+--
+-- >>> view curried fst 3 4
+-- 3
+--
curried :: Iso ((a , b) -> c) ((d , e) -> f) (a -> b -> c) (d -> e -> f)
curried = iso curry uncurry
+{-# INLINE curried #-}
--- | Given a function that is its own inverse, this gives you an 'Iso' using it in both directions.
+-- | TODO: Document
+--
+swapped :: Iso (a , b) (c , d) (b , a) (d , c)
+swapped = iso swap swap
+{-# INLINE swapped #-}
+
+-- | TODO: Document
+--
+eswapped :: Iso (a + b) (c + d) (b + a) (d + c)
+eswapped = iso eswap eswap
+{-# INLINE eswapped #-}
+
+-- | 'Iso' defined by left-association of nested tuples.
+--
+associated :: Iso (a , (b , c)) (d , (e , f)) ((a , b) , c) ((d , e) , f)
+associated = iso assocl assocr
+{-# INLINE associated #-}
+
+-- | 'Iso' defined by left-association of nested tuples.
+--
+eassociated :: Iso (a + (b + c)) (d + (e + f)) ((a + b) + c) ((d + e) + f)
+eassociated = iso eassocl eassocr
+{-# INLINE eassociated #-}
+
+-- | Obtain an 'Iso' from a function that is its own inverse.
--
-- @
-- 'involuted' ≡ 'Control.Monad.join' 'iso'
@@ -147,45 +318,94 @@ curried = iso curry uncurry
-- >>> "live" ^. involuted reverse
-- "evil"
--
--- >>> involuted reverse %~ ('d':) $ "live"
+-- >>> involuted reverse ..~ ('d':) $ "live"
-- "lived"
--
involuted :: (s -> a) -> Iso s a a s
-involuted = join iso
+involuted = M.join iso
{-# INLINE involuted #-}
-hushed :: Iso (Maybe a) (Maybe b) (() + a) (() + b)
-hushed = iso (maybe (Left ()) Right) (const Nothing ||| Just)
+-- | The group isomorphism defined by an element's action.
+--
+added :: Group a => a -> Iso' a a
+added n = iso (<> n) (<< n)
+{-# INLINE added #-}
+
+-- | The group isomorphism defined by an element's inverse action.
+--
+-- @
+-- 'subtracted' n = 're' ('added' n)
+-- @
+--
+subtracted :: Group a => a -> Iso' a a
+subtracted n = iso (<< n) (<> n)
+{-# INLINE subtracted #-}
-duped :: Iso (Bool -> a) (Bool -> b) (a , a) (b , b)
-duped = iso to fro
- where
- to f = (f False, f True)
- fro p True = fst p
- fro p False = snd p
+-- | A 'Seq' is isomorphic to a 'ViewL'
+--
+-- @'viewl' m ≡ m 'Data.Profunctor.Optic.Operator.^.' 'viewedl'@
+--
+-- >>> Seq.fromList [1,2,3] ^. viewedl
+-- 1 :< fromList [2,3]
+--
+-- >>> Seq.empty ^. viewedl
+-- EmptyL
+--
+-- >>> EmptyL ^. re viewedl
+-- fromList []
+--
+-- >>> review viewedl $ 1 Seq.:< fromList [2,3]
+-- fromList [1,2,3]
+--
+viewedl :: Iso (Seq a) (Seq b) (ViewL a) (ViewL b)
+viewedl = iso viewl $ \xs -> case xs of
+ EmptyL -> mempty
+ a Seq.:< as -> a Seq.<| as
+{-# INLINE viewedl #-}
-coduped :: Iso (Bool , a) (Bool , b) (a + a) (b + b)
-coduped = iso f ((,) False ||| (,) True)
- where
- f (False,a) = Left a
- f (True,a) = Right a
+-- | A 'Seq' is isomorphic to a 'ViewR'
+--
+-- @'viewr' m ≡ m 'Data.Profunctor.Optic.Operator.^.' 'viewedr'@
+--
+-- >>> Seq.fromList [1,2,3] ^. viewedr
+-- fromList [1,2] :> 3
+--
+-- >>> Seq.empty ^. viewedr
+-- EmptyR
+--
+-- >>> EmptyR ^. re viewedr
+-- fromList []
+--
+-- >>> review viewedr $ fromList [1,2] Seq.:> 3
+-- fromList [1,2,3]
+--
+viewedr :: Iso (Seq a) (Seq b) (ViewR a) (ViewR b)
+viewedr = iso viewr $ \xs -> case xs of
+ EmptyR -> mempty
+ as Seq.:> a -> as Seq.|> a
+{-# INLINE viewedr #-}
--- | Remove a single value invert a type.
+-- | Remove a single value from a type.
+--
+-- @
+-- 'non' ≡ 'non'' '.' 'only'
+-- @
+--
+-- >>> non 0 #^ rem 10 4
+-- Just 2
+--
+-- >>> non 0 #^ rem 10 5
+-- Nothing
--
non :: Eq a => a -> Iso' (Maybe a) a
non def = iso (fromMaybe def) g
where g a | a == def = Nothing
| otherwise = Just a
+{-# INLINE non #-}
--- | @'anon' a p@ generalizes @'non' a@ to take any value and a predicate.
+-- | Generalize @'non' a@ to take any value and a predicate.
--
--- 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" ?~ "!!!"
--- invertList [("hello",invertList [("world","!!!")])]
---
--- >>> invertList [("hello",invertList [("world","!!!")])] & at "hello" . anon Map.empty Map.null . at "world" .~ Nothing
--- invertList []
+-- Assumes that @p a@ holds @'True'@ and generates an isomorphism between @'Maybe' (a | 'not' (p a))@ and @a@.
--
anon :: a -> (a -> Bool) -> Iso' (Maybe a) a
anon a p = iso (fromMaybe a) go where
@@ -193,86 +413,154 @@ anon a p = iso (fromMaybe a) go where
| otherwise = Just b
{-# INLINE anon #-}
-liftF
- :: Functor f
- => Functor g
- => AIso s t a b
- -> Iso (f s) (g t) (f a) (g b)
-liftF l = withIso l $ \sa bt -> iso (fmap sa) (fmap bt)
+u1 :: Iso (U1 p) (U1 q) () ()
+u1 = iso (const ()) (const U1)
+{-# INLINE u1 #-}
-liftP
- :: Profunctor p
- => Profunctor q
- => AIso s1 t1 a1 b1
- -> AIso s2 t2 a2 b2
- -> Iso (p a1 s2) (q b1 t2) (p s1 a2) (q t1 b2)
-liftP f g =
- withIso f $ \sa1 bt1 ->
- withIso g $ \sa2 bt2 ->
- iso (dimap sa1 sa2) (dimap bt1 bt2)
+k1 :: Iso (K1 i c p) (K1 j d q) c d
+k1 = iso unK1 K1
+{-# INLINE k1 #-}
+
+m1 :: Iso (M1 i c f p) (M1 j d g q) (f p) (g q)
+m1 = iso unM1 M1
+{-# INLINE m1 #-}
-lift2 :: AIso s t a b -> Iso (c , s) (d , t) (c , a) (d , b)
-lift2 x = withIso x $ \sa bt -> between runPaired Paired (dimap sa bt)
+par1 :: Iso (Par1 p) (Par1 q) p q
+par1 = iso unPar1 Par1
+{-# INLINE par1 #-}
-liftR :: AIso s t a b -> Iso (c + s) (d + t) (c + a) (d + b)
-liftR x = withIso x $ \sa bt -> between runSplit Split (dimap sa bt)
+rec1 :: Iso (Rec1 f p) (Rec1 g q) (f p) (g q)
+rec1 = iso unRec1 Rec1
+{-# INLINE rec1 #-}
---------------------------------------------------------------------
--- 'Paired'
+-- Primitive operators
---------------------------------------------------------------------
-newtype Paired p c d a b = Paired { runPaired :: p (c , a) (d , b) }
+-- | Extract the two functions that characterize an 'Iso'.
+--
+withIso :: AIso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
+withIso x k = case x (IsoRep id id) of IsoRep sa bt -> k sa bt
+{-# INLINE withIso #-}
+
+-- | Invert an isomorphism.
+--
+-- @
+-- 'invert' ('invert' o) ≡ o
+-- @
+--
+invert :: AIso s t a b -> Iso b a t s
+invert o = withIso o $ \sa bt -> iso bt sa
+{-# INLINE invert #-}
+
+-- | Given a conversion on one side of an 'Iso', reover the other.
+--
+-- @
+-- 'reover' ≡ 'over' '.' 're'
+-- @
+--
+-- Compare 'Data.Profunctor.Optic.Setter.reover'.
+--
+reover :: AIso s t a b -> (t -> s) -> b -> a
+reover o = withIso o $ \sa bt ts -> sa . ts . bt
+{-# INLINE reover #-}
---fromTambara :: Profunctor p => Tambara p a b -> Paired p d d a b
---fromTambara = Paired . swapped . runTambara
+-- | Remap the indices of an indexed optic.
+--
+reixed :: Profunctor p => AIso' i j -> IndexedOptic p i s t a b -> IndexedOptic p j s t a b
+reixed o = withIso o reix
+{-# INLINE reixed #-}
+
+-- | Remap the indices of a coindexed optic.
+--
+recxed :: Profunctor p => AIso' k l -> CoindexedOptic p k s t a b -> CoindexedOptic p l s t a b
+recxed o = withIso o recx
+{-# INLINE recxed #-}
-instance Profunctor p => Profunctor (Paired p c d) where
- dimap f g (Paired pab) = Paired $ dimap (fmap f) (fmap g) pab
+-- | Based on /ala/ from Conor McBride's work on Epigram.
+--
+-- This version is generalized to accept any 'Iso', not just a @newtype@.
+--
+-- >>> au (rewrapping Sum) foldMap [1,2,3,4]
+-- 10
+--
+-- You may want to think of this combinator as having the following, simpler type:
+--
+-- @
+-- au :: AnIso s t a b -> ((b -> t) -> e -> s) -> e -> a
+-- @
+--
+au :: Functor f => AIso s t a b -> ((b -> t) -> f s) -> f a
+au k = withIso k $ \ sa bt f -> fmap sa (f bt)
+{-# INLINE au #-}
-instance Strong p => Strong (Paired p c d) where
- second' (Paired pab) = Paired . dimap shuffle shuffle . second' $ pab
- where
- shuffle (x,(y,z)) = (y,(x,z))
+-- | Variant of 'au' for profunctors.
+--
+-- >>> :t flip aup runStar
+-- flip aup runStar
+-- :: Functor f => AIso s t a (f a) -> Star f c s -> c -> t
+--
+aup :: Profunctor p => Functor f => AIso s t a b -> (p c a -> f b) -> p c s -> f t
+aup o = withIso o $ \sa bt f g -> fmap bt (f (rmap sa g))
+{-# INLINE aup #-}
--- ^ @
--- paired :: Iso s t a b -> Iso s' t' a' b' -> Iso (s, s') (t, t') (a, a') (b, b')
--- paired :: Lens s t a b -> Lens s' t' a' b' -> Lens (s, s') (t, t') (a, a') (b, b')
+-- | This combinator is based on @ala@ from Conor McBride's work on Epigram.
+--
+-- As with '_Wrapping', the user supplied function for the newtype is /ignored/.
+--
+-- >>> ala Sum foldMap [1,2,3,4]
+-- 10
+--
+-- >>> ala All foldMap [True,True]
+-- True
+--
+-- >>> ala All foldMap [True,False]
+-- False
+--
+-- >>> ala Any foldMap [False,False]
+-- False
+--
+-- >>> ala Any foldMap [True,False]
+-- True
+--
+-- >>> ala Product foldMap [1,2,3,4]
+-- 24
+--
+-- @
+-- ala :: Newtype s => Newtype t => (O s -> s) -> ((O t -> t) -> e -> s) -> e -> O s
-- @
--
-paired
- :: Profunctor p
- => Optic (Paired p s2 t2) s1 t1 a1 b1
- -> Optic (Paired p a1 b1) s2 t2 a2 b2
- -> Optic p (s1 , s2) (t1 , t2) (a1 , a2) (b1 , b2)
-paired x y =
- dimap swp swp . runPaired . x . Paired . dimap swp swp . runPaired . y . Paired
+ala :: Newtype s => Newtype t => Functor f => (O s -> s) -> ((O t -> t) -> f s) -> f (O s)
+ala = au . rewrapping
+{-# INLINE ala #-}
---------------------------------------------------------------------
--- 'Split'
+-- Carriers
---------------------------------------------------------------------
-newtype Split p c d a b = Split { runSplit :: p (Either c a) (Either d b) }
+-- | The 'IsoRep' profunctor precisely characterizes an 'Iso'.
+data IsoRep a b s t = IsoRep (s -> a) (b -> t)
---fromTambaraSum :: Profunctor p => TambaraSum p a b -> Split p d d a b
---fromTambaraSum = Split . swapped . runTambaraSum
+-- | When you see this as an argument to a function, it expects an 'Iso'.
+type AIso s t a b = Optic (IsoRep a b) s t a b
-instance Profunctor p => Profunctor (Split p c d) where
- dimap f g (Split pab) = Split $ dimap (fmap f) (fmap g) pab
+type AIso' s a = AIso s s a a
-instance Choice p => Choice (Split p c d) where
- right' (Split pab) = Split . dimap shuffle shuffle . right' $ pab
- where
- shuffle = Right . Left ||| (Left ||| Right . Right)
+instance Functor (IsoRep a b s) where
+ fmap f (IsoRep sa bt) = IsoRep sa (f . bt)
+ {-# INLINE fmap #-}
+
+instance Profunctor (IsoRep a b) where
+ dimap f g (IsoRep sa bt) = IsoRep (sa . f) (g . bt)
+ {-# INLINE dimap #-}
+ lmap f (IsoRep sa bt) = IsoRep (sa . f) bt
+ {-# INLINE lmap #-}
+ rmap f (IsoRep sa bt) = IsoRep sa (f . bt)
+ {-# INLINE rmap #-}
+
+instance Sieve (IsoRep a b) (Index a b) where
+ sieve (IsoRep sa bt) s = Index (sa s) bt
+
+instance Cosieve (IsoRep a b) (Coindex a b) where
+ cosieve (IsoRep sa bt) (Coindex sab) = bt (sab sa)
--- ^ @
--- split :: Iso s t a b -> Iso s' t' a' b' -> Iso (Either s s') (Either t t') (Either a a') (Either b b')
--- split :: Prism s t a b -> Prism s' t' a' b' -> Lens (Either s s') (Either t t') (Either a a') (Either b b')
--- split :: View s t a b -> View s' t' a' b' -> Review (Either s s') (Either t t') (Either a a') (Either b b')
--- @
-split
- :: Profunctor p
- => Optic (Split p s2 t2) s1 t1 a1 b1
- -> Optic (Split p a1 b1) s2 t2 a2 b2
- -> Optic p (s1 + s2) (t1 + t2) (a1 + a2) (b1 + b2)
-split x y =
- dimap swp' swp' . runSplit . x . Split . dimap swp' swp' . runSplit . y . Split
diff --git a/src/Data/Profunctor/Optic/Lens.hs b/src/Data/Profunctor/Optic/Lens.hs
index f83678c..a42ea79 100644
--- a/src/Data/Profunctor/Optic/Lens.hs
+++ b/src/Data/Profunctor/Optic/Lens.hs
@@ -1,29 +1,91 @@
-module Data.Profunctor.Optic.Lens where
-
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+module Data.Profunctor.Optic.Lens (
+ -- * Lens & Ixlens
+ Lens
+ , Ixlens
+ , Lens'
+ , Ixlens'
+ , lens
+ , ixlens
+ , lensVl
+ , ixlensVl
+ , matching
+ , cloneLens
+ -- * Colens & Cxlens
+ , Colens
+ , Cxlens
+ , Colens'
+ , Cxlens'
+ , colens
+ --, cxlens
+ , colensVl
+ , comatching
+ --, cloneColens
+ -- * Optics
+ , ixfirst
+ , cofirst
+ , ixsecond
+ , cosecond
+ , united
+ , voided
+ , valued
+ , root
+ , branches
+ -- * Primitive operators
+ , withLens
+ , withIxlens
+ --, withColens
+ -- * Operators
+ , toPastro
+ , toTambara
+ -- * Carriers
+ , ALens
+ , ALens'
+ , AIxlens
+ , AIxlens'
+ , LensRep(..)
+ , IxlensRep(..)
+ -- , AColens
+ -- , AColens'
+ --, ColensRep(..)
+ -- * Classes
+ , Strong(..)
+ , Costrong(..)
+) where
+
+import Data.Profunctor.Strong
import Data.Profunctor.Optic.Iso
-import Data.Profunctor.Optic.Prelude
+import Data.Profunctor.Optic.Import
+import Data.Profunctor.Optic.Index
import Data.Profunctor.Optic.Type
+import Data.Tree
import Data.Void (Void, absurd)
-import Foreign.C.Types
-import GHC.IO.Exception
-import System.IO
-import qualified Control.Foldl as F
+import GHC.Generics hiding (from, to)
+import qualified Data.Bifunctor as B
-- $setup
-- >>> :set -XNoOverloadedStrings
--- >>> :m + Control.Exception
--- >>> :m + Data.Profunctor.Optic
+-- >>> :set -XTypeApplications
+-- >>> :set -XFlexibleContexts
+-- >>> import Data.Tree
+-- >>> import Data.Int.Instance
+-- >>> :load Data.Profunctor.Optic
---------------------------------------------------------------------
--- 'Lens'
+-- 'Lens' & 'Ixlens'
---------------------------------------------------------------------
--- | Build a 'Strong' optic from a getter and setter.
---
--- \( \quad \mathsf{Lens}\;S\;A = \exists C, S \cong C \times A \)
+-- | Obtain a 'Lens' from a getter and setter.
--
--- /Caution/: In order for the generated lens family to be well-defined,
--- you must ensure that the three lens laws hold:
+-- /Caution/: In order for the generated optic to be well-defined,
+-- you must ensure that the input functions satisfy the following
+-- properties:
--
-- * @sa (sbt s a) ≡ a@
--
@@ -34,32 +96,81 @@ import qualified Control.Foldl as F
-- See 'Data.Profunctor.Optic.Property'.
--
lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
-lens sa sbt = dimap (id &&& sa) (uncurry sbt) . psecond
+lens sa sbt = dimap (id &&& sa) (uncurry sbt) . second'
+{-# INLINE lens #-}
--- | Build a 'Lens' from its free tensor representation.
+-- | Obtain an indexed 'Lens' from an indexed getter and a setter.
+--
+-- Compare 'lens' and 'Data.Profunctor.Optic.Traversal.ixtraversal'.
+--
+-- /Caution/: In order for the generated optic to be well-defined,
+-- you must ensure that the input functions constitute a legal
+-- indexed lens:
+--
+-- * @snd . sia (sbt s a) ≡ a@
+--
+-- * @sbt s (snd $ sia s) ≡ s@
+--
+-- * @sbt (sbt s a1) a2 ≡ sbt s a2@
+--
+-- See 'Data.Profunctor.Optic.Property'.
--
-matching :: (s -> (x , a)) -> ((x , b) -> t) -> Lens s t a b
-matching f g = dimap f g . psecond
+ixlens :: (s -> (i , a)) -> (s -> b -> t) -> Ixlens i s t a b
+ixlens sia sbt = ixlensVl $ \iab s -> sbt s <$> uncurry iab (sia s)
+{-# INLINE ixlens #-}
-- | Transform a Van Laarhoven lens into a profunctor lens.
--
-vllens :: (forall f. Functor f => (a -> f b) -> s -> f t) -> Lens s t a b
-vllens o = dimap ((info &&& values) . o (flip PStore id)) (uncurry id . swp) . pfirst
+-- Compare 'Data.Profunctor.Optic.Grate.grateVl' and 'Data.Profunctor.Optic.Traversal.traversalVl'.
+--
+-- /Caution/: In order for the generated optic to be well-defined,
+-- you must ensure that the input satisfies the following properties:
+--
+-- * @abst Identity ≡ Identity@
+--
+-- * @fmap (abst f) . (abst g) ≡ getCompose . abst (Compose . fmap f . g)@
+--
+-- More generally, a profunctor optic must be monoidal as a natural
+-- transformation:
+--
+-- * @o id ≡ id@
+--
+-- * @o ('Data.Profunctor.Composition.Procompose' p q) ≡ 'Data.Profunctor.Composition.Procompose' (o p) (o q)@
+--
+lensVl :: (forall f. Functor f => (a -> f b) -> s -> f t) -> Lens s t a b
+lensVl o = dimap ((info &&& values) . o (flip Index id)) (uncurry id . swap) . first'
+{-# INLINE lensVl #-}
--- | Build a 'Costrong' optic from a getter and setter.
+-- | Transform an indexed Van Laarhoven lens into an indexed profunctor 'Lens'.
+--
+-- An 'Ixlens' is a valid 'Lens' and a valid 'IxTraversal'.
+--
+-- Compare 'lensVl' & 'Data.Profunctor.Optic.Traversal.ixtraversalVl'.
+--
+-- /Caution/: In order for the generated optic to be well-defined,
+-- you must ensure that the input satisfies the following properties:
+--
+-- * @iabst (const Identity) ≡ Identity@
--
--- * @relens f g ≡ \f g -> re (lens f g)@
+-- * @fmap (iabst $ const f) . (iabst $ const g) ≡ getCompose . iabst (const $ Compose . fmap f . g)@
--
--- * @review $ relens f g ≡ f@
+-- More generally, a profunctor optic must be monoidal as a natural
+-- transformation:
+--
+-- * @o id ≡ id@
--
--- * @set . re $ re (lens f g) ≡ g@
+-- * @o ('Data.Profunctor.Composition.Procompose' p q) ≡ 'Data.Profunctor.Composition.Procompose' (o p) (o q)@
--
--- A 'Relens' is a 'Review', so you can specialise types to obtain:
+-- See 'Data.Profunctor.Optic.Property'.
--
--- @ 'review' :: 'Relens'' s a -> a -> s @
+ixlensVl :: (forall f. Functor f => (i -> a -> f b) -> s -> f t) -> Ixlens i s t a b
+ixlensVl f = lensVl $ \iab -> f (curry iab) . snd
+{-# INLINE ixlensVl #-}
+
+-- | Obtain a 'Lens' from its free tensor representation.
--
-relens :: (b -> t) -> (b -> s -> a) -> Relens s t a b
-relens sa sbt = unsecond . dimap (uncurry sbt) (id &&& sa)
+matching :: (s -> (c , a)) -> ((c , b) -> t) -> Lens s t a b
+matching sca cbt = dimap sca cbt . second'
-- | TODO: Document
--
@@ -67,132 +178,216 @@ cloneLens :: ALens s t a b -> Lens s t a b
cloneLens o = withLens o lens
---------------------------------------------------------------------
--- 'LensRep'
+-- 'Colens' & 'Cxlens'
---------------------------------------------------------------------
--- | The `LensRep` profunctor precisely characterizes a 'Lens'.
-data LensRep a b s t = LensRep (s -> a) (s -> b -> t)
-
-type ALens s t a b = Optic (LensRep a b) s t a b
-
-type ALens' s a = ALens s s a a
-
-instance Profunctor (LensRep a b) where
-
- dimap f g (LensRep sa sbt) = LensRep (sa . f) (\s -> g . sbt (f s))
-
-instance Strong (LensRep a b) where
-
- first' (LensRep sa sbt) =
- LensRep (\(a, _) -> sa a) (\(s, c) b -> ((sbt s b), c))
-
- second' (LensRep sa sbt) =
- LensRep (\(_, a) -> sa a) (\(c, s) b -> (c, (sbt s b)))
-
-instance Sieve (LensRep a b) (PStore a b) where
- sieve (LensRep sa sbt) s = PStore (sa s) (sbt s)
+-- | Obtain a 'Colens' from a getter and setter.
+--
+-- @
+-- 'colens' f g ≡ \\f g -> 're' ('lens' f g)
+-- 'colens' bsia bt ≡ 'colensVl' '$' \\ts b -> bsia b '<$>' (ts . bt '$' b)
+-- 'review' $ 'colens' f g ≡ f
+-- 'set' . 're' $ 're' ('lens' f g) ≡ g
+-- @
+--
+-- A 'Colens' is a 'Review', so you can specialise types to obtain:
+--
+-- @ 'review' :: 'Colens'' s a -> a -> s @
+--
+-- /Caution/: In addition to the normal optic laws, the input functions
+-- must have the correct < https://wiki.haskell.org/Lazy_pattern_match laziness > annotations.
+--
+-- For example, this is a perfectly valid 'Colens':
+--
+-- @
+-- co1 :: Colens a b (a, c) (b, c)
+-- co1 = flip colens fst $ \ ~(_,y) b -> (b,y)
+-- @
+--
+-- However removing the annotation will result in a faulty optic.
+--
+-- See 'Data.Profunctor.Optic.Property'.
+--
+colens :: (b -> s -> a) -> (b -> t) -> Colens s t a b
+colens bsa bt = unsecond . dimap (uncurry bsa) (id &&& bt)
-instance Representable (LensRep a b) where
- type Rep (LensRep a b) = PStore a b
+-- | Transform a Van Laarhoven colens into a profunctor colens.
+--
+-- Compare 'Data.Profunctor.Optic.Grate.grateVl'.
+--
+-- /Caution/: In addition to the normal optic laws, the input functions
+-- must have the correct laziness annotations.
+--
+-- For example, this is a perfectly valid 'Colens':
+--
+-- @
+-- co1 = colensVl $ \f ~(a,b) -> (,b) <$> f a
+-- @
+--
+-- However removing the annotation will result in a faulty optic.
+--
+colensVl :: (forall f. Functor f => (t -> f s) -> b -> f a) -> Colens s t a b
+colensVl o = unfirst . dimap (uncurry id . swap) ((info &&& values) . o (flip Index id))
- tabulate f = LensRep (\s -> info (f s)) (\s -> values (f s))
+-- | Obtain a 'Colens' from its free tensor representation.
+--
+comatching :: ((c , s) -> a) -> (b -> (c , t)) -> Colens s t a b
+comatching csa bct = unsecond . dimap csa bct
---------------------------------------------------------------------
-- Primitive operators
---------------------------------------------------------------------
--- | TODO: Document
+-- | Extract the two functions that characterize a 'Lens'.
--
withLens :: ALens s t a b -> ((s -> a) -> (s -> b -> t) -> r) -> r
-withLens l f = case l (LensRep id $ \_ b -> b) of LensRep x y -> f x y
-
--- | Analogous to @(***)@ from 'Control.Arrow'
---
-pairing :: Lens s1 t1 a1 b1 -> Lens s2 t2 a2 b2 -> Lens (s1 , s2) (t1 , t2) (a1 , a2) (b1 , b2)
-pairing = paired
-
--- | TODO: Document
---
-lens2 :: (s -> a) -> (s -> b -> t) -> Lens (c, s) (d, t) (c, a) (d, b)
-lens2 f g = between runPaired Paired (lens f g)
+withLens o f = case o (LensRep id (flip const)) of LensRep x y -> f x y
---------------------------------------------------------------------
--- Common lenses
+-- Optics
---------------------------------------------------------------------
-- | TODO: Document
--
-_1 :: Lens (a , c) (b , c) a b
-_1 = pfirst
+cofirst :: Colens a b (a , c) (b , c)
+cofirst = unfirst
-- | TODO: Document
--
-_2 :: Lens (c , a) (c , b) a b
-_2 = psecond
+cosecond :: Colens a b (c , a) (c , b)
+cosecond = unsecond
-- | TODO: Document
--
-lower1 :: Iso s t (a , x) (b , x) -> Lens s t a b
-lower1 = (. _1)
+-- >>> ixlists (ix @Int traversed . ix first' . ix traversed) [("foo",1), ("bar",2)]
+-- [(0,'f'),(1,'o'),(2,'o'),(0,'b'),(1,'a'),(2,'r')]
+--
+-- >>> ixlists (ix @Int traversed . ixfirst . ix traversed) [("foo",1), ("bar",2)]
+-- [(0,'f'),(1,'o'),(2,'o'),(0,'b'),(1,'a'),(2,'r')]
+--
+-- >>> ixlists (ix @Int traversed % ix first' % ix traversed) [("foo",1), ("bar",2)]
+-- [(0,'f'),(1,'o'),(2,'o'),(1,'b'),(2,'a'),(3,'r')]
+--
+-- >>> ixlists (ix @Int traversed % ixfirst % ix traversed) [("foo",1), ("bar",2)]
+-- [(0,'f'),(1,'o'),(2,'o'),(2,'b'),(3,'a'),(4,'r')]
+--
+ixfirst :: Ixlens i (a , c) (b , c) a b
+ixfirst = lmap assocl . first'
-- | TODO: Document
--
-lower2 :: Iso s t (x , a) (x , b) -> Lens s t a b
-lower2 = (. _2)
+ixsecond :: Ixlens i (c , a) (c , b) a b
+ixsecond = lmap (\(i, (c, a)) -> (c, (i, a))) . second'
-- | There is a `Unit` in everything.
--
-unit :: Lens' a ()
-unit = lens (const ()) const
+-- >>> "hello" ^. united
+-- ()
+-- >>> "hello" & united .~ ()
+-- "hello"
+--
+united :: Lens' a ()
+united = lens (const ()) const
-- | There is everything in a `Void`.
--
-void :: Lens' Void a
-void = lens absurd const
+-- >>> [] & fmapped . voided <>~ "Void"
+-- []
+-- >>> Nothing & fmapped . voided ..~ abs
+-- Nothing
+--
+voided :: Lens' Void a
+voided = lens absurd const
-- | TODO: Document
--
-ix :: Eq k => k -> Lens' (k -> v) v
-ix k = lens ($ k) (\g v' x -> if (k == x) then v' else g x)
+-- Compare 'Data.Profunctor.Optic.Prism.keyed'.
+--
+valued :: Eq k => k -> Lens' (k -> v) v
+valued k = lens ($ k) (\g v' x -> if (k == x) then v' else g x)
--- | TODO: Document
+-- | A 'Lens' that focuses on the root of a 'Tree'.
--
-foldedl :: Lens s s a b -> s -> F.Fold b a
-foldedl o x = withLens o $ \sa sbt -> F.Fold sbt x sa
+-- >>> view root $ Node 42 []
+-- 42
+--
+root :: Lens' (Tree a) a
+root = lensVl $ \f (Node a as) -> (`Node` as) <$> f a
+{-# INLINE root #-}
--- | TODO: Document
+-- | A 'Lens' returning the direct descendants of the root of a 'Tree'
+--
+-- @'Data.Profunctor.Optic.View.view' 'branches' ≡ 'subForest'@
--
-uncurried :: Lens (a , b) c a (b -> c)
-uncurried = rmap apply . pfirst
+branches :: Lens' (Tree a) [Tree a]
+branches = lensVl $ \f (Node a as) -> Node a <$> f as
+{-# INLINE branches #-}
-----------------------------------------------------------------------------------------------------
--- IO Exceptions
-----------------------------------------------------------------------------------------------------
+---------------------------------------------------------------------
+-- Operators
+---------------------------------------------------------------------
--- | Where the error happened.
+-- | Use a 'Lens' to construct a 'Pastro'.
--
-location :: Lens' IOException String
-location = lens ioe_location $ \s e -> s { ioe_location = e }
+toPastro :: ALens s t a b -> p a b -> Pastro p s t
+toPastro o p = withLens o $ \sa sbt -> Pastro (uncurry sbt . swap) p (\s -> (sa s, s))
--- | Error type specific information.
+-- | Use a 'Lens' to construct a 'Tambara'.
--
-description :: Lens' IOException String
-description = lens ioe_description $ \s e -> s { ioe_description = e }
+toTambara :: Strong p => ALens s t a b -> p a b -> Tambara p s t
+toTambara o p = withLens o $ \sa sbt -> Tambara (first' . lens sa sbt $ p)
--- | The handle used by the action flagging this error.
---
-handle :: Lens' IOException (Maybe Handle)
-handle = lens ioe_handle $ \s e -> s { ioe_handle = e }
+---------------------------------------------------------------------
+-- LensRep
+---------------------------------------------------------------------
--- | 'fileName' the error is related to.
+-- | The `LensRep` profunctor precisely characterizes a 'Lens'.
--
-fileName :: Lens' IOException (Maybe FilePath)
-fileName = lens ioe_filename $ \s e -> s { ioe_filename = e }
+data LensRep a b s t = LensRep (s -> a) (s -> b -> t)
--- | 'errno' leading to this error, if any.
---
-errno :: Lens' IOException (Maybe CInt)
-errno = lens ioe_errno $ \s e -> s { ioe_errno = e }
+type ALens s t a b = Optic (LensRep a b) s t a b
+
+type ALens' s a = ALens s s a a
+
+instance Profunctor (LensRep a b) where
+ dimap f g (LensRep sa sbt) = LensRep (sa . f) (\s -> g . sbt (f s))
-errorType :: Lens' IOException IOErrorType
-errorType = lens ioe_type $ \s e -> s { ioe_type = e }
+instance Strong (LensRep a b) where
+ first' (LensRep sa sbt) =
+ LensRep (\(a, _) -> sa a) (\(s, c) b -> (sbt s b, c))
+
+ second' (LensRep sa sbt) =
+ LensRep (\(_, a) -> sa a) (\(c, s) b -> (c, sbt s b))
+
+instance Sieve (LensRep a b) (Index a b) where
+ sieve (LensRep sa sbt) s = Index (sa s) (sbt s)
+
+instance Representable (LensRep a b) where
+ type Rep (LensRep a b) = Index a b
+
+ tabulate f = LensRep (\s -> info (f s)) (\s -> values (f s))
+
+---------------------------------------------------------------------
+-- IxlensRep
+---------------------------------------------------------------------
+
+data IxlensRep i a b s t = IxlensRep (s -> (i , a)) (s -> b -> t)
+
+type AIxlens i s t a b = IndexedOptic (IxlensRep i a b) i s t a b
+
+type AIxlens' i s a = AIxlens i s s a a
+
+instance Profunctor (IxlensRep i a b) where
+ dimap f g (IxlensRep sia sbt) = IxlensRep (sia . f) (\s -> g . sbt (f s))
+
+instance Strong (IxlensRep i a b) where
+ first' (IxlensRep sia sbt) =
+ IxlensRep (\(a, _) -> sia a) (\(s, c) b -> (sbt s b, c))
+
+ second' (IxlensRep sia sbt) =
+ IxlensRep (\(_, a) -> sia a) (\(c, s) b -> (c, sbt s b))
+
+-- | Extract the two functions that characterize a 'Lens'.
+--
+withIxlens :: Monoid i => AIxlens i s t a b -> ((s -> (i , a)) -> (s -> b -> t) -> r) -> r
+withIxlens o f = case o (IxlensRep id $ flip const) of IxlensRep x y -> f (x . (mempty,)) (\s b -> y (mempty, s) b)
diff --git a/src/Data/Profunctor/Optic/Operator.hs b/src/Data/Profunctor/Optic/Operator.hs
index 5afea04..f4e424a 100644
--- a/src/Data/Profunctor/Optic/Operator.hs
+++ b/src/Data/Profunctor/Optic/Operator.hs
@@ -1,18 +1,46 @@
module Data.Profunctor.Optic.Operator (
- module Ops
- , module Misc
+ re
+ , invert
+ , view
+ , review
+ , preview
+ , over
+ , under
+ , set
+ , reset
+ , is
+ , matches
+ , (&)
+ , (%)
+ , (#)
+ , (^.)
+ , (^%)
+ , (#^)
+ , (^?)
+ , (^..)
+ , (^%%)
+ , (.~)
+ , (%~)
+ , (..~)
+ , (%%~)
+ , (/~)
+ , (#~)
+ , (//~)
+ , (##~)
+ , (?~)
+ , (<>~)
+ , (><~)
+ , module Extra
) where
-import Data.Function as Ops ((&))
-import Data.Profunctor.Optic.Type as Ops (re)
-import Data.Profunctor.Optic.Iso as Ops (simple, paired, split)
-import Data.Profunctor.Optic.View as Ops ((#), (^.), view, review)
-import Data.Profunctor.Optic.Setter as Ops ((%), (.~), (%~), set, sets, over)
-import Data.Profunctor.Optic.Grate as Ops (constOf, zipWithOf)
-import Data.Profunctor.Optic.Traversal0 as Ops (matchOf, isMatched)
-import Data.Profunctor.Optic.Fold as Ops ((^..), foldMapOf)
-import Data.Profunctor.Optic.Fold0 as Ops ((^?), preview, preuse)
-import Data.Profunctor.Optic.Cofold as Ops (cofoldMapOf)
-import Data.Profunctor.Optic.Traversal as Ops (traverseOf, sequenceOf)
-import Data.Profunctor.Optic.Cotraversal as Ops (cotraverseOf)
-import Data.Profunctor.Misc as Misc
+import Data.Function
+import Data.Profunctor.Optic.Type
+import Data.Profunctor.Optic.Iso
+import Data.Profunctor.Optic.View
+import Data.Profunctor.Optic.Index
+import Data.Profunctor.Optic.Setter
+import Data.Profunctor.Optic.Fold
+import Data.Profunctor.Optic.Fold0
+import Data.Profunctor.Optic.Traversal
+import Data.Profunctor.Optic.Traversal0
+import Data.Profunctor.Extra as Extra
diff --git a/src/Data/Profunctor/Optic/Prism.hs b/src/Data/Profunctor/Optic/Prism.hs
index 5d55302..a6d796b 100644
--- a/src/Data/Profunctor/Optic/Prism.hs
+++ b/src/Data/Profunctor/Optic/Prism.hs
@@ -1,61 +1,139 @@
-module Data.Profunctor.Optic.Prism where
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+module Data.Profunctor.Optic.Prism (
+ -- * Prism & Cxprism
+ Prism
+ , Prism'
+ , Cxprism
+ , Cxprism'
+ , APrism
+ , APrism'
+ , prism
+ , prism'
+ , cxprism
+ , handling
+ , clonePrism
+ -- * Coprism & Ixprism
+ , Coprism
+ , Coprism'
+ , Ixprism
+ , Ixprism'
+ , ACoprism
+ , ACoprism'
+ , coprism
+ , coprism'
+ , rehandling
+ , cloneCoprism
+ -- * Optics
+ , l1
+ , r1
+ , left
+ , right
+ , cxright
+ , just
+ , nothing
+ , cxjust
+ , keyed
+ , filtered
+ , compared
+ , prefixed
+ , only
+ , nearly
+ , nthbit
+ , sync
+ , async
+ , exception
+ , asyncException
+ -- * Primitive operators
+ , withPrism
+ , withCoprism
+ -- * Operators
+ , aside
+ , without
+ , below
+ , toPastroSum
+ , toTambaraSum
+ -- * Carriers
+ , PrismRep(..)
+ , CoprismRep(..)
+ -- * Classes
+ , Choice(..)
+ , Cochoice(..)
+) where
import Control.Exception
import Control.Monad (guard)
+import Data.Bifunctor as B
+import Data.Bits (Bits, bit, testBit)
+import Data.List (stripPrefix)
+import Data.Prd
+import Data.Profunctor.Choice
import Data.Profunctor.Optic.Iso
-import Data.Profunctor.Optic.Prelude
+import Data.Profunctor.Optic.Import
import Data.Profunctor.Optic.Type
-import GHC.IO.Exception
-import qualified Control.Exception as Ex
+
+import GHC.Generics hiding (from, to)
+
+-- $setup
+-- >>> :set -XNoOverloadedStrings
+-- >>> :set -XTypeApplications
+-- >>> :set -XFlexibleContexts
+-- >>> :set -XTypeOperators
+-- >>> :set -XRankNTypes
+-- >>> import Data.Int.Instance ()
+-- >>> :load Data.Profunctor.Optic
+-- >>> let catchOn :: Int -> Cxprism' Int (Maybe String) String ; catchOn n = cxjust $ \k -> if k==n then Just "caught" else Nothing
+-- >>> let catchFoo :: b -> Cxprism String (String + a) (String + b) a b; catchFoo b = cxright $ \e k -> if e == "fooError" && k == mempty then Right b else Left e
---------------------------------------------------------------------
--- 'Prism'
+-- 'Prism' & 'Cxprism'
---------------------------------------------------------------------
--- | Build a 'Choice' optic from a constructor and a matcher function.
+-- | Obtain a 'Prism' from a constructor and a matcher function.
--
--- \( \quad \mathsf{Prism}\;S\;A = \exists D, S \cong D + A \)
+-- /Caution/: In order for the generated optic to be well-defined,
+-- you must ensure that the input functions satisfy the following
+-- properties:
--
--- /Caution/: In order for the generated prism family to be well-defined,
--- you must ensure that the three prism laws hold:
+-- * @sta (bt b) ≡ Right b@
--
--- * @seta (bt b) ≡ Right b@
+-- * @(id ||| bt) (sta s) ≡ s@
--
--- * @(id ||| bt) (seta s) ≡ s@
+-- * @left sta (sta s) ≡ left Left (sta s)@
+--
+-- More generally, a profunctor optic must be monoidal as a natural
+-- transformation:
+--
+-- * @o id ≡ id@
--
--- * @left seta (seta s) ≡ left Left (seta s)@
+-- * @o ('Data.Profunctor.Composition.Procompose' p q) ≡ 'Data.Profunctor.Composition.Procompose' (o p) (o q)@
--
-- See 'Data.Profunctor.Optic.Property'.
--
prism :: (s -> t + a) -> (b -> t) -> Prism s t a b
-prism seta bt = dimap seta (id ||| bt) . pright
+prism sta bt = dimap sta (id ||| bt) . right'
--- | Create a 'Prism' from a reviewer and a matcher function that produces a 'Maybe'.
+-- | Obtain a 'Prism'' from a reviewer and a matcher function that produces a 'Maybe'.
--
prism' :: (s -> Maybe a) -> (a -> s) -> Prism' s a
-prism' sma as = flip prism as $ \s -> maybe (Left s) Right (sma s)
+prism' sa as = flip prism as $ \s -> maybe (Left s) Right (sa s)
--- | Build a 'Prism' from its free tensor representation.
+-- | Obtain a 'Cxprism'' from a reviewer and a matcher function that returns either a match or a failure handler.
--
--- Useful for constructing prisms from try and handle functions.
---
-handling :: (s -> e + a) -> (e + b -> t) -> Prism s t a b
-handling sea ebt = dimap sea ebt . pright
+cxprism :: (s -> (k -> t) + a) -> (b -> t) -> Cxprism k s t a b
+cxprism skta bt = prism skta (bt .)
--- | Build a 'Cochoice' optic from a constructor and a matcher function.
+-- | Obtain a 'Prism' from its free tensor representation.
--
--- * @reprism f g ≡ \f g -> re (prism f g)@
---
--- * @view . re $ prism bat _ ≡ bat@
---
--- * @matchOf . re . re $ prism _ sa ≡ sa@
---
--- A 'Reprism' is a 'View', so you can specialise types to obtain:
---
--- @ view :: 'Reprism'' s a -> s -> a @
+-- Useful for constructing prisms from try and handle functions.
--
-reprism :: (b -> a + t) -> (s -> a) -> Reprism s t a b
-reprism beat sa = unright . dimap (id ||| sa) beat
+handling :: (s -> c + a) -> (c + b -> t) -> Prism s t a b
+handling sca cbt = dimap sca cbt . right'
-- | TODO: Document
--
@@ -63,461 +141,290 @@ clonePrism :: APrism s t a b -> Prism s t a b
clonePrism o = withPrism o prism
---------------------------------------------------------------------
--- 'PrismRep'
----------------------------------------------------------------------
-
-type APrism s t a b = Optic (PrismRep a b) s t a b
-
-type APrism' s a = APrism s s a a
-
--- | The 'PrismRep' profunctor precisely characterizes a 'Prism'.
-data PrismRep a b s t = PrismRep (s -> t + a) (b -> t)
-
-instance Functor (PrismRep a b s) where
-
- fmap f (PrismRep seta bt) = PrismRep (either (Left . f) Right . seta) (f . bt)
- {-# INLINE fmap #-}
-
-instance Profunctor (PrismRep a b) where
-
- dimap f g (PrismRep seta bt) = PrismRep (either (Left . g) Right . seta . f) (g . bt)
- {-# INLINE dimap #-}
-
- lmap f (PrismRep seta bt) = PrismRep (seta . f) bt
- {-# INLINE lmap #-}
-
- rmap f (PrismRep seta bt) = PrismRep (either (Left . f) Right . seta) (f . bt)
- {-# INLINE rmap #-}
-
-instance Choice (PrismRep a b) where
-
- left' (PrismRep seta bt) = PrismRep (either (either (Left . Left) Right . seta) (Left . Right)) (Left . bt)
- {-# INLINE left' #-}
-
- right' (PrismRep seta bt) = PrismRep (either (Left . Left) (either (Left . Right) Right . seta)) (Right . bt)
- {-# INLINE right' #-}
-
----------------------------------------------------------------------
--- Primitive operators
+-- 'Coprism' & 'Ixprism'
---------------------------------------------------------------------
--- | TODO: Document
+-- | Obtain a 'Cochoice' optic from a constructor and a matcher function.
--
-withPrism :: APrism s t a b -> ((s -> t + a) -> (b -> t) -> r) -> r
-withPrism o f = case o (PrismRep Right id) of PrismRep g h -> f g h
-
--- | Analogous to @(+++)@ from 'Control.Arrow'
+-- @
+-- coprism f g ≡ \f g -> re (prism f g)
+-- @
--
-splitting :: Prism s1 t1 a1 b1 -> Prism s2 t2 a2 b2 -> Prism (s1 + s2) (t1 + t2) (a1 + a2) (b1 + b2)
-splitting = split
-
--- | TODO: Document
+-- /Caution/: In order for the generated optic to be well-defined,
+-- you must ensure that the input functions satisfy the following
+-- properties:
--
-prismr :: (s -> t + a) -> (b -> t) -> Prism (c + s) (d + t) (c + a) (d + b)
-prismr f g = between runSplit Split (prism f g)
-
--- | Use a 'Prism' to lift part of a structure.
+-- * @bat (bt b) ≡ Right b@
--
-aside :: APrism s t a b -> Prism (e , s) (e , t) (e , a) (e , b)
-aside k =
- withPrism k $ \seta bt ->
- flip prism (fmap bt) $ \(e,s) ->
- case seta s of
- Left t -> Left (e,t)
- Right a -> Right (e,a)
-{-# INLINE aside #-}
-
--- | Given a pair of prisms, project sums.
-without :: APrism s t a b -> APrism u v c d -> Prism (s + u) (t + v) (a + c) (b + d)
-without k =
- withPrism k $ \seta bt k' ->
- withPrism k' $ \uevc dv ->
- flip prism (bimap bt dv) $ \su ->
- case su of
- Left s -> bimap Left Left (seta s)
- Right u -> bimap Right Right (uevc u)
-{-# INLINE without #-}
-
--- | 'lift' a 'Prism' through a 'Traversable' functor,
--- giving a 'Prism' that matches only if all the elements of the container
--- match the 'Prism'.
+-- * @(id ||| bt) (bat b) ≡ b@
--
--- >>> [Left 1, Right "foo", Left 4, Right "woot"] ^.. below _R
--- []
+-- * @left bat (bat b) ≡ left Left (bat b)@
--
--- >>> [Right "hail hydra!", Right "foo", Right "blah", Right "woot"] ^.. below _R
--- [["hail hydra!","foo","blah","woot"]]
+-- A 'Coprism' is a 'View', so you can specialise types to obtain:
--
-below :: Traversable f => APrism' s a -> Prism' (f s) (f a)
-below k =
- withPrism k $ \seta bt ->
- flip prism (fmap bt) $ \s ->
- case traverse seta s of
- Left _ -> Left s
- Right t -> Right t
-{-# INLINE below #-}
-
----------------------------------------------------------------------
--- Common prisms
----------------------------------------------------------------------
-
--- | TODO: Document
+-- @ view :: 'Coprism'' s a -> s -> a @
--
-_L :: Prism (a + c) (b + c) a b
-_L = pleft
+coprism :: (s -> a) -> (b -> a + t) -> Coprism s t a b
+coprism sa bat = unright . dimap (id ||| sa) bat
--- | TODO: Document
+-- | Create a 'Coprism' from a reviewer and a matcher function that produces a 'Maybe'.
--
-_R :: Prism (c + a) (c + b) a b
-_R = pright
+coprism' :: (s -> a) -> (a -> Maybe s) -> Coprism' s a
+coprism' tb bt = coprism tb $ \b -> maybe (Left b) Right (bt b)
--- | Prism for the `Just` constructor of `Maybe`.
+-- | Obtain a 'Coprism' from its free tensor representation.
--
-_Just :: Prism (Maybe a) (Maybe b) a b
-_Just = flip prism Just $ maybe (Left Nothing) Right
-
--- | Prism for the `Nothing` constructor of `Maybe`.
---
-_Nothing :: Prism (Maybe a) (Maybe b) () ()
-_Nothing = flip prism (const Nothing) $ maybe (Right ()) (const $ Left Nothing)
+rehandling :: (c + s -> a) -> (b -> c + t) -> Coprism s t a b
+rehandling csa bct = unright . dimap csa bct
-- | TODO: Document
--
-lowerL :: Iso s t (a + c) (b + c) -> Prism s t a b
-lowerL = (. _L)
+cloneCoprism :: ACoprism s t a b -> Coprism s t a b
+cloneCoprism o = withCoprism o coprism
--- | TODO: Document
---
-lowerR :: Iso s t (c + a) (c + b) -> Prism s t a b
-lowerR = (. _R)
+---------------------------------------------------------------------
+-- Common 'Prism's and 'Coprism's
+---------------------------------------------------------------------
--- | Obtain a 'Prism' that can be composed with to filter another 'Lens', 'Iso', 'View', 'Fold' (or 'Traversal').
---
--- >>> [1..10] ^.. folded . filtered even
--- [2,4,6,8,10]
---
-filtered :: (a -> Bool) -> Prism' a a
-filtered f = iso (branch' f) dedup . _R
+l1 :: Prism ((a :+: c) t) ((b :+: c) t) (a t) (b t)
+l1 = prism sta L1
+ where
+ sta (L1 v) = Right v
+ sta (R1 v) = Left (R1 v)
+{-# INLINE l1 #-}
--- | TODO: Document
---
-selected :: Eq a => a -> Prism' (a , b) b
-selected x = flip prism ((,) x) $ \kv@(k,v) -> branch (==x) kv v k
+r1 :: Prism ((c :+: a) t) ((c :+: b) t) (a t) (b t)
+r1 = prism sta R1
+ where
+ sta (R1 v) = Right v
+ sta (L1 v) = Left (L1 v)
+{-# INLINE r1 #-}
--- | Create a 'Prism' from a value and a predicate.
+-- | 'Prism' into the `Left` constructor of `Either`.
--
-nearly :: a -> (a -> Bool) -> Prism' a ()
-nearly x f = prism' (guard . f) (const x)
+left :: Prism (a + c) (b + c) a b
+left = left'
--- | Focus not just on a case, but a specific value of that case.
+-- | 'Prism' into the `Right` constructor of `Either`.
--
-only :: Eq a => a -> Prism' a ()
-only x = nearly x (x==)
+right :: Prism (c + a) (c + b) a b
+right = right'
--- | TODO: Document
+-- | Coindexed prism into the `Right` constructor of `Either`.
--
-lessThan :: Bounded a => Ord a => a -> Prism' a Ordering
-lessThan x = flip prism' (const x) $ \x' -> if x' < x then Just LT else Nothing
-
--- | TODO: Document
+-- >>> cxset (catchFoo "Caught foo") id $ Left "fooError"
+-- Right "Caught foo"
+-- >>> cxset (catchFoo "Caught foo") id $ Left "barError"
+-- Left "barError"
--
-excepted :: Exception a => Prism' SomeException a
-excepted = prism' fromException toException
+cxright :: (e -> k -> e + b) -> Cxprism k (e + a) (e + b) a b
+cxright ekeb = flip cxprism Right $ either (Left . ekeb) Right
--- | Exceptions that occur in the 'IO' 'Monad'.
---
--- An 'IOException' records a more specific error type, a descriptive string and possibly the handle
--- that was used when the error was flagged.
+-- | 'Prism' into the `Just` constructor of `Maybe`.
--
-_IOException :: Prism' SomeException IOException
-_IOException = excepted
+just :: Prism (Maybe a) (Maybe b) a b
+just = flip prism Just $ maybe (Left Nothing) Right
-----------------------------------------------------------------------------------------------------
--- IO Error Types
-----------------------------------------------------------------------------------------------------
-
--- | TODO: Document
+-- | 'Prism' into the `Nothing` constructor of `Maybe`.
--
-_AlreadyExists :: Prism' IOErrorType ()
-_AlreadyExists = only AlreadyExists
+nothing :: Prism (Maybe a) (Maybe b) () ()
+nothing = flip prism (const Nothing) $ maybe (Right ()) (const $ Left Nothing)
--- | TODO: Document
+-- | Coindexed prism into the `Just` constructor of `Maybe`.
--
-_NoSuchThing :: Prism' IOErrorType ()
-_NoSuchThing = only NoSuchThing
-
--- | TODO: Document
+-- >>> Just "foo" & catchOn 1 ##~ (\k msg -> show k ++ ": " ++ msg)
+-- Just "0: foo"
--
-_ResourceBusy :: Prism' IOErrorType ()
-_ResourceBusy = only ResourceBusy
-
--- | TODO: Document
+-- >>> Nothing & catchOn 1 ##~ (\k msg -> show k ++ ": " ++ msg)
+-- Nothing
--
-_ResourceExhausted :: Prism' IOErrorType ()
-_ResourceExhausted = only ResourceExhausted
-
--- | TODO: Document
+-- >>> Nothing & catchOn 0 ##~ (\k msg -> show k ++ ": " ++ msg)
+-- Just "caught"
--
-_EOF :: Prism' IOErrorType ()
-_EOF = only EOF
+cxjust :: (k -> Maybe b) -> Cxprism k (Maybe a) (Maybe b) a b
+cxjust kb = flip cxprism Just $ maybe (Left kb) Right
--- | TODO: Document
---
-_IllegalOperation :: Prism' IOErrorType ()
-_IllegalOperation = only IllegalOperation
-
--- | TODO: Document
---
-_PermissionDenied :: Prism' IOErrorType ()
-_PermissionDenied = only PermissionDenied
-
--- | TODO: Document
+-- | Match a given key to obtain the associated value.
--
-_UserError :: Prism' IOErrorType ()
-_UserError = only UserError
+keyed :: Eq a => a -> Prism' (a , b) b
+keyed x = flip prism ((,) x) $ \kv@(k,v) -> branch (==x) kv v k
--- | TODO: Document
+-- | Filter another optic.
--
-_UnsatisfiedConstraints :: Prism' IOErrorType ()
-_UnsatisfiedConstraints = only UnsatisfiedConstraints
-
--- | TODO: Document
+-- >>> [1..10] ^.. folded . filtered even
+-- [2,4,6,8,10]
--
-_SystemError :: Prism' IOErrorType ()
-_SystemError = only SystemError
+filtered :: (a -> Bool) -> Prism' a a
+filtered f = iso (branch' f) join . right
--- | TODO: Document
+-- | Focus on comparability to a given element of a partial order.
--
-_ProtocolError :: Prism' IOErrorType ()
-_ProtocolError = only ProtocolError
+compared :: Eq a => Prd a => a -> Prism' a Ordering
+compared x = flip prism' (const x) (pcompare x)
--- | TODO: Document
+-- | 'Prism' into the remainder of a list with a given prefix.
--
-_OtherError :: Prism' IOErrorType ()
-_OtherError = only OtherError
+prefixed :: Eq a => [a] -> Prism' [a] [a]
+prefixed ps = prism' (stripPrefix ps) (ps ++)
--- | TODO: Document
+-- | Focus not just on a case, but a specific value of that case.
--
-_InvalidArgument :: Prism' IOErrorType ()
-_InvalidArgument = only InvalidArgument
+only :: Eq a => a -> Prism' a ()
+only x = nearly x (x==)
--- | TODO: Document
+-- | Create a 'Prism' from a value and a predicate.
--
-_InappropriateType :: Prism' IOErrorType ()
-_InappropriateType = only InappropriateType
+nearly :: a -> (a -> Bool) -> Prism' a ()
+nearly x f = prism' (guard . f) (const x)
--- | TODO: Document
+-- | Focus on the truth value of the nth bit in a bit array.
--
-_HardwareFault :: Prism' IOErrorType ()
-_HardwareFault = only HardwareFault
+nthbit :: Bits s => Int -> Prism' s ()
+nthbit n = prism' (guard . (flip testBit n)) (const $ bit n)
--- | TODO: Document
+-- | Check whether an exception is synchronous.
--
-_UnsupportedOperation :: Prism' IOErrorType ()
-_UnsupportedOperation = only UnsupportedOperation
+sync :: Exception e => Prism' e e
+sync = filtered $ \e -> case fromException (toException e) of
+ Just (SomeAsyncException _) -> False
+ Nothing -> True
--- | TODO: Document
+-- | Check whether an exception is asynchronous.
--
-_TimeExpired :: Prism' IOErrorType ()
-_TimeExpired = only TimeExpired
+async :: Exception e => Prism' e e
+async = filtered $ \e -> case fromException (toException e) of
+ Just (SomeAsyncException _) -> True
+ Nothing -> False
-- | TODO: Document
--
-_ResourceVanished :: Prism' IOErrorType ()
-_ResourceVanished = only ResourceVanished
+exception :: Exception e => Prism' SomeException e
+exception = prism' fromException toException
-- | TODO: Document
--
-_Interrupted :: Prism' IOErrorType ()
-_Interrupted = only Interrupted
+asyncException :: Exception e => Prism' SomeException e
+asyncException = prism' asyncExceptionFromException asyncExceptionToException
-----------------------------------------------------------------------------------------------------
--- Async Exceptions
-----------------------------------------------------------------------------------------------------
+---------------------------------------------------------------------
+-- Primitive operators
+---------------------------------------------------------------------
--- | The current thread's stack exceeded its limit. Since an 'Exception' has
--- been raised, the thread's stack will certainly be below its limit again,
--- but the programmer should take remedial action immediately.
+-- | Extract the two functions that characterize a 'Prism'.
--
-_StackOverflow :: Prism' AsyncException ()
-_StackOverflow = dimap seta (either id id) . right' . rmap (const Ex.StackOverflow)
- where seta Ex.StackOverflow = Right ()
- seta t = Left t
+withPrism :: APrism s t a b -> ((s -> t + a) -> (b -> t) -> r) -> r
+withPrism o f = case o (PrismRep Right id) of PrismRep g h -> f g h
--- | The program's heap usage has exceeded its limit.
+-- | Extract the two functions that characterize a 'Coprism'.
--
--- See 'GHC.IO.Exception' for more information.
---
-_HeapOverflow :: Prism' AsyncException ()
-_HeapOverflow = dimap seta (either id id) . right' . rmap (const Ex.HeapOverflow)
- where seta Ex.HeapOverflow = Right ()
- seta t = Left t
+withCoprism :: ACoprism s t a b -> ((s -> a) -> (b -> a + t) -> r) -> r
+withCoprism o f = case o (CoprismRep id Right) of CoprismRep g h -> f g h
--- | This 'Exception' is raised by another thread calling
--- 'Control.Concurrent.killThread', or by the system if it needs to terminate
--- the thread for some reason.
---
-_ThreadKilled :: Prism' AsyncException ()
-_ThreadKilled = dimap seta (either id id) . right' . rmap (const Ex.ThreadKilled)
- where seta Ex.ThreadKilled = Right ()
- seta t = Left t
+---------------------------------------------------------------------
+-- Operators
+---------------------------------------------------------------------
--- | This 'Exception' is raised by default in the main thread of the program when
--- the user requests to terminate the program via the usual mechanism(s)
--- (/e.g./ Control-C in the console).
+-- | Use a 'Prism' to lift part of a structure.
--
-_UserInterrupt :: Prism' AsyncException ()
-_UserInterrupt = dimap seta (either id id) . right' . rmap (const Ex.UserInterrupt)
- where seta Ex.UserInterrupt = Right ()
- seta t = Left t
+aside :: APrism s t a b -> Prism (e , s) (e , t) (e , a) (e , b)
+aside k =
+ withPrism k $ \sta bt ->
+ flip prism (fmap bt) $ \(e,s) ->
+ case sta s of
+ Left t -> Left (e,t)
+ Right a -> Right (e,a)
+{-# INLINE aside #-}
-----------------------------------------------------------------------------------------------------
--- Arithmetic exceptions
-----------------------------------------------------------------------------------------------------
+-- | Given a pair of prisms, project sums.
+without :: APrism s t a b -> APrism u v c d -> Prism (s + u) (t + v) (a + c) (b + d)
+without k =
+ withPrism k $ \sta bt k' ->
+ withPrism k' $ \uevc dv ->
+ flip prism (bimap bt dv) $ \su ->
+ case su of
+ Left s -> bimap Left Left (sta s)
+ Right u -> bimap Right Right (uevc u)
+{-# INLINE without #-}
--- | Detect arithmetic overflow.
+-- | Lift a 'Prism' through a 'Traversable' functor.
+--
+-- Returns a 'Prism' that matches only if each element matches the original 'Prism'.
--
-_Overflow :: Prism' ArithException ()
-_Overflow = dimap seta (either id id) . right' . rmap (const Ex.Overflow)
- where seta Ex.Overflow = Right ()
- seta t = Left t
-
--- | Detect arithmetic underflow.
+-- >>> [Left 1, Right "foo", Left 4, Right "woot"] ^.. below right
+-- []
--
-_Underflow :: Prism' ArithException ()
-_Underflow = dimap seta (either id id) . right' . rmap (const Ex.Underflow)
- where seta Ex.Underflow = Right ()
- seta t = Left t
-
--- | Detect arithmetic loss of precision.
+-- >>> [Right "hail hydra!", Right "foo", Right "blah", Right "woot"] ^.. below right
+-- [["hail hydra!","foo","blah","woot"]]
--
-_LossOfPrecision :: Prism' ArithException ()
-_LossOfPrecision = dimap seta (either id id) . right' . rmap (const Ex.LossOfPrecision)
- where seta Ex.LossOfPrecision = Right ()
- seta t = Left t
+below :: Traversable f => APrism' s a -> Prism' (f s) (f a)
+below k =
+ withPrism k $ \sta bt ->
+ flip prism (fmap bt) $ \s ->
+ case traverse sta s of
+ Left _ -> Left s
+ Right t -> Right t
+{-# INLINE below #-}
--- | Detect division by zero.
+-- | Use a 'Prism' to construct a 'PastroSum'.
--
-_DivideByZero :: Prism' ArithException ()
-_DivideByZero = dimap seta (either id id) . right' . rmap (const Ex.DivideByZero)
- where seta Ex.DivideByZero = Right ()
- seta t = Left t
+toPastroSum :: APrism s t a b -> p a b -> PastroSum p s t
+toPastroSum o p = withPrism o $ \sta bt -> PastroSum (join . B.first bt) p (eswap . sta)
--- | Detect exceptional denormalized floating pure.
+-- | Use a 'Prism' to construct a 'TambaraSum'.
--
-_Denormal :: Prism' ArithException ()
-_Denormal = dimap seta (either id id) . right' . rmap (const Ex.Denormal)
- where seta Ex.Denormal = Right ()
- seta t = Left t
+toTambaraSum :: Choice p => APrism s t a b -> p a b -> TambaraSum p s t
+toTambaraSum o p = withPrism o $ \sta bt -> TambaraSum (left . prism sta bt $ p)
--- | Detect zero denominators.
---
--- Added in @base@ 4.6 in response to this libraries discussion:
---
--- <http://haskell.1045720.n5.nabble.com/Data-Ratio-and-exceptions-td5711246.html>
---
-_RatioZeroDenominator :: Prism' ArithException ()
-_RatioZeroDenominator = dimap seta (either id id) . right' . rmap (const Ex.RatioZeroDenominator)
- where seta Ex.RatioZeroDenominator = Right ()
- seta t = Left t
+---------------------------------------------------------------------
+-- 'PrismRep' & 'CoprismRep'
+---------------------------------------------------------------------
-----------------------------------------------------------------------------------------------------
--- Array Exceptions
-----------------------------------------------------------------------------------------------------
+type APrism s t a b = Optic (PrismRep a b) s t a b
--- | Detect attempts to index an array outside its declared bounds.
---
-_IndexOutOfBounds :: Prism' ArrayException String
-_IndexOutOfBounds = dimap seta (either id id) . right' . rmap Ex.IndexOutOfBounds
- where seta (Ex.IndexOutOfBounds r) = Right r
- seta t = Left t
+type APrism' s a = APrism s s a a
--- | Detect attempts to evaluate an element of an array that has not been initialized.
+-- | The 'PrismRep' profunctor precisely characterizes a 'Prism'.
--
-_UndefinedElement :: Prism' ArrayException String
-_UndefinedElement = dimap seta (either id id) . right' . rmap Ex.UndefinedElement
- where seta (Ex.UndefinedElement r) = Right r
- seta t = Left t
-
-----------------------------------------------------------------------------------------------------
--- Miscellaneous Exceptions
-----------------------------------------------------------------------------------------------------
-
-trivial :: Profunctor p => t -> Optic' p t ()
-trivial t = const () `dimap` const t
+data PrismRep a b s t = PrismRep (s -> t + a) (b -> t)
-_AssertionFailed :: Prism' Ex.AssertionFailed String
-_AssertionFailed = iso (\(Ex.AssertionFailed a) -> a) Ex.AssertionFailed
+instance Functor (PrismRep a b s) where
+ fmap f (PrismRep sta bt) = PrismRep (first f . sta) (f . bt)
+ {-# INLINE fmap #-}
--- | Thrown when the runtime system detects that the computation is guaranteed
--- not to terminate. Note that there is no guarantee that the runtime system
--- will notice whether any given computation is guaranteed to terminate or not.
---
-_NonTermination :: Prism' Ex.NonTermination ()
-_NonTermination = trivial Ex.NonTermination
+instance Profunctor (PrismRep a b) where
+ dimap f g (PrismRep sta bt) = PrismRep (first g . sta . f) (g . bt)
+ {-# INLINE dimap #-}
--- | Thrown when the program attempts to call atomically, from the
--- 'Control.Monad.STM' package, inside another call to atomically.
---
-_NestedAtomically :: Prism' Ex.NestedAtomically ()
-_NestedAtomically = trivial Ex.NestedAtomically
+ lmap f (PrismRep sta bt) = PrismRep (sta . f) bt
+ {-# INLINE lmap #-}
--- | The thread is blocked on an 'Control.Concurrent.MVar.MVar', but there
--- are no other references to the 'Control.Concurrent.MVar.MVar' so it can't
--- ever continue.
---
-_BlockedIndefinitelyOnMVar :: Prism' Ex.BlockedIndefinitelyOnMVar ()
-_BlockedIndefinitelyOnMVar = trivial Ex.BlockedIndefinitelyOnMVar
+ rmap = fmap
+ {-# INLINE rmap #-}
--- | The thread is waiting to retry an 'Control.Monad.STM.STM' transaction,
--- but there are no other references to any TVars involved, so it can't ever
--- continue.
---
-_BlockedIndefinitelyOnSTM :: Prism' Ex.BlockedIndefinitelyOnSTM ()
-_BlockedIndefinitelyOnSTM = trivial Ex.BlockedIndefinitelyOnSTM
+instance Choice (PrismRep a b) where
+ left' (PrismRep sta bt) = PrismRep (either (first Left . sta) (Left . Right)) (Left . bt)
+ {-# INLINE left' #-}
--- | There are no runnable threads, so the program is deadlocked. The
--- 'Deadlock' 'Exception' is raised in the main thread only.
---
-_Deadlock :: Prism' Ex.Deadlock ()
-_Deadlock = trivial Ex.Deadlock
+ right' (PrismRep sta bt) = PrismRep (either (Left . Left) (first Right . sta)) (Right . bt)
+ {-# INLINE right' #-}
--- | A class method without a definition (neither a default definition,
--- nor a definition in the appropriate instance) was called.
---
-_NoMethodError :: Prism' Ex.NoMethodError String
-_NoMethodError = iso (\(Ex.NoMethodError a) -> a) Ex.NoMethodError
+type ACoprism s t a b = Optic (CoprismRep a b) s t a b
--- | A pattern match failed.
---
-_PatternMatchFail :: Prism' Ex.PatternMatchFail String
-_PatternMatchFail = iso (\(Ex.PatternMatchFail a) -> a) Ex.PatternMatchFail
+type ACoprism' s a = ACoprism s s a a
--- | An uninitialised record field was used.
---
-_RecConError :: Prism' Ex.RecConError String
-_RecConError = iso (\(Ex.RecConError a) -> a) Ex.RecConError
+data CoprismRep a b s t = CoprismRep (s -> a) (b -> a + t)
--- | A record selector was applied to a constructor without the appropriate
--- field. This can only happen with a datatype with multiple constructors,
--- where some fields are in one constructor but not another.
---
-_RecSelError :: Prism' Ex.RecSelError String
-_RecSelError = iso (\(Ex.RecSelError a) -> a) Ex.RecSelError
+instance Functor (CoprismRep a b s) where
+ fmap f (CoprismRep sa bat) = CoprismRep sa (second f . bat)
+ {-# INLINE fmap #-}
--- | A record update was performed on a constructor without the
--- appropriate field. This can only happen with a datatype with multiple
--- constructors, where some fields are in one constructor but not another.
---
-_RecUpdError :: Prism' Ex.RecUpdError String
-_RecUpdError = iso (\(Ex.RecUpdError a) -> a) Ex.RecUpdError
+instance Profunctor (CoprismRep a b) where
+ lmap f (CoprismRep sa bat) = CoprismRep (sa . f) bat
+ {-# INLINE lmap #-}
--- | Thrown when the user calls 'Prelude.error'.
---
-_ErrorCall :: Prism' Ex.ErrorCall String
-_ErrorCall = iso (\(Ex.ErrorCall a) -> a) Ex.ErrorCall
+ rmap = fmap
+ {-# INLINE rmap #-}
--- | This thread has exceeded its allocation limit.
---
-_AllocationLimitExceeded :: Prism' Ex.AllocationLimitExceeded ()
-_AllocationLimitExceeded = trivial AllocationLimitExceeded
+instance Cochoice (CoprismRep a b) where
+ unleft (CoprismRep sca batc) = CoprismRep (sca . Left) (forgetr $ either (eassocl . batc) Right)
+ {-# INLINE unleft #-}
diff --git a/src/Data/Profunctor/Optic/Property.hs b/src/Data/Profunctor/Optic/Property.hs
index 98eb0aa..b88b8db 100644
--- a/src/Data/Profunctor/Optic/Property.hs
+++ b/src/Data/Profunctor/Optic/Property.hs
@@ -1,172 +1,263 @@
-module Data.Profunctor.Optic.Property where
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+module Data.Profunctor.Optic.Property (
+ -- * Iso
+ Iso
+ , fromto_iso
+ , tofrom_iso
+ -- * Prism
+ , Prism
+ , tofrom_prism
+ , fromto_prism
+ , idempotent_prism
+ -- * Lens
+ , Lens
+ , tofrom_lens
+ , fromto_lens
+ , idempotent_lens
+ -- * Grate
+ , Grate
+ , pure_grate
+ , compose_grate
+ -- * Traversal0
+ , Traversal0
+ , tofrom_traversal0
+ , fromto_traversal0
+ , idempotent_traversal0
+ -- * Traversal & Traversal1
+ , Traversal
+ , pure_traversal
+ , compose_traversal
+ , compose_traversal1
+ -- * Cotraversal1
+ , Cotraversal1
+ , compose_cotraversal1
+ -- * Setter
+ , Setter
+ , pure_setter
+ , compose_setter
+ , idempotent_setter
+) where
import Control.Applicative
-import Data.Profunctor.Optic.Prelude
+import Data.Profunctor.Optic.Import
import Data.Profunctor.Optic.Type
import Data.Profunctor.Optic.Iso
--import Data.Profunctor.Optic.View
import Data.Profunctor.Optic.Setter
import Data.Profunctor.Optic.Lens
import Data.Profunctor.Optic.Prism
---import Data.Profunctor.Optic.Grate
+import Data.Profunctor.Optic.Grate
--import Data.Profunctor.Optic.Fold
---import Data.Profunctor.Optic.Fold0
---import Data.Profunctor.Optic.Cofold
---import Data.Profunctor.Optic.Traversal
+import Data.Profunctor.Optic.Traversal
import Data.Profunctor.Optic.Traversal0
---import Data.Profunctor.Optic.Cotraversal
---------------------------------------------------------------------
-- 'Iso'
---------------------------------------------------------------------
-iso_fromto' :: Eq s => Iso' s a -> s -> Bool
-iso_fromto' o = withIso o iso_fromto
-
-iso_tofrom' :: Eq a => Iso' s a -> a -> Bool
-iso_tofrom' o = withIso o iso_tofrom
-
-iso_fromto :: Eq s => (s -> a) -> (a -> s) -> s -> Bool
-iso_fromto sa as s = as (sa s) == s
+-- | Going back and forth doesn't change anything.
+--
+fromto_iso :: Eq s => Iso' s a -> s -> Bool
+fromto_iso o s = withIso o $ \sa as -> as (sa s) == s
-iso_tofrom :: Eq a => (s -> a) -> (a -> s) -> a -> Bool
-iso_tofrom sa as a = sa (as a) == a
+-- | Going back and forth doesn't change anything.
+--
+tofrom_iso :: Eq a => Iso' s a -> a -> Bool
+tofrom_iso o a = withIso o $ \sa as -> sa (as a) == a
---------------------------------------------------------------------
-- 'Prism'
---------------------------------------------------------------------
--- If we are able to view an existing focus, then building it will return the original structure.
-prism_tofrom :: Eq s => (s -> s + a) -> (a -> s) -> s -> Bool
-prism_tofrom seta bt s = either id bt (seta s) == s
+-- | If we are able to view an existing focus, then building it will return the original structure.
+--
+-- * @(id ||| bt) (sta s) ≡ s@
+--
+tofrom_prism :: Eq s => Prism' s a -> s -> Bool
+tofrom_prism o s = withPrism o $ \sta bt -> either id bt (sta s) == s
--- If we build a whole from any focus, that whole must contain a focus.
-prism_fromto :: Eq s => Eq a => (s -> s + a) -> (a -> s) -> a -> Bool
-prism_fromto seta bt a = seta (bt a) == Right a
-prism_tofrom' :: Eq s => Prism' s a -> s -> Bool
-prism_tofrom' o = withPrism o prism_tofrom
+-- | If we build a whole from a focus, that whole must contain the focus.
+--
+-- * @sta (bt b) ≡ Right b@
+--
+fromto_prism :: Eq s => Eq a => Prism' s a -> a -> Bool
+fromto_prism o a = withPrism o $ \sta bt -> sta (bt a) == Right a
--- Reviewing a value with a 'Prism' and then previewing returns the value.
-prism_fromto' :: Eq s => Eq a => Prism' s a -> a -> Bool
-prism_fromto' o = withPrism o prism_fromto
+-- |
+--
+-- * @left sta (sta s) ≡ left Left (sta s)@
+--
+idempotent_prism :: Eq s => Eq a => Prism' s a -> s -> Bool
+idempotent_prism o s = withPrism o $ \sta _ -> left sta (sta s) == left Left (sta s)
---------------------------------------------------------------------
-- 'Lens'
---------------------------------------------------------------------
+-- A 'Lens' is a valid 'Traversal' with the following additional laws:
--- | A 'Lens' is a valid 'Traversal' with the following additional laws:
---
--- * @view o (set o b a) ≡ b@
---
--- * @set o (view o a) a ≡ a@
+-- | You get back what you put in.
--
--- * @set o c (set o b a) ≡ set o c a@
+-- * @view o (set o b a) ≡ b@
--
-
-lens_tofrom :: Eq s => (s -> a) -> (s -> a -> s) -> s -> Bool
-lens_tofrom sa sas s = sas s (sa s) == s
-
-lens_fromto :: Eq a => (s -> a) -> (s -> a -> s) -> s -> a -> Bool
-lens_fromto sa sas s a = sa (sas s a) == a
-
-lens_idempotent :: Eq s => (s -> a -> s) -> s -> a -> a -> Bool
-lens_idempotent sas s a1 a2 = sas (sas s a1) a2 == sas s a2
+tofrom_lens :: Eq s => Lens' s a -> s -> Bool
+tofrom_lens o s = withLens o $ \sa sas -> sas s (sa s) == s
-- | Putting back what you got doesn't change anything.
-lens_tofrom' :: Eq s => Lens' s a -> s -> Bool
-lens_tofrom' o = withLens o lens_tofrom
-
--- | You get back what you put in.
-lens_fromto' :: Eq a => Lens' s a -> s -> a -> Bool
-lens_fromto' o = withLens o lens_fromto
+--
+-- * @set o (view o a) a ≡ a@
+--
+fromto_lens :: Eq a => Lens' s a -> s -> a -> Bool
+fromto_lens o s a = withLens o $ \sa sas -> sa (sas s a) == a
-- | Setting twice is the same as setting once.
-lens_idempotent' :: Eq s => Lens' s a -> s -> a -> a -> Bool
-lens_idempotent' o = withLens o $ const lens_idempotent
+--
+-- * @set o c (set o b a) ≡ set o c a@
+--
+idempotent_lens :: Eq s => Lens' s a -> s -> a -> a -> Bool
+idempotent_lens o s a1 a2 = withLens o $ \_ sas -> sas (sas s a1) a2 == sas s a2
---------------------------------------------------------------------
-- 'Grate'
---------------------------------------------------------------------
--- | The 'Grate' laws are that of an algebra for a parameterised continuation monad.
---
--- * @grate ($ s) ≡ s@
+-- The 'Grate' laws are that of an algebra for the parameterised continuation 'Coindex'.
+
+-- |
--
--- * @grate (\k -> h (k . sabt)) ≡ sabt (\k -> h ($ k))@
+-- * @sabt ($ s) ≡ s@
--
-grate_pure :: Eq s => (((s -> a) -> a) -> s) -> s -> Bool
-grate_pure sabt s = sabt ($ s) == s
+pure_grate :: Eq s => Grate' s a -> s -> Bool
+pure_grate o s = withGrate o $ \sabt -> sabt ($ s) == s
-grate_pure' :: Eq s => (((s -> a) -> a) -> s) -> s -> a -> Bool
-grate_pure' sabt s a = sabt (const a) == s
+-- |
+--
+-- * @sabt (\k -> h (k . sabt)) ≡ sabt (\k -> h ($ k))@
+--
+compose_grate :: Eq s => Grate' s a -> ((((s -> a) -> a) -> a) -> a) -> Bool
+compose_grate o f = withGrate o $ \sabt -> sabt (\k -> f (k . sabt)) == sabt (\k -> f ($ k))
---------------------------------------------------------------------
-- 'Traversal0'
---------------------------------------------------------------------
-atraversal_tofrom :: Eq a => Eq s => (s -> s + a) -> (s -> a -> s) -> s -> a -> Bool
-atraversal_tofrom seta sbt s a = seta (sbt s a) == either (Left . flip const a) Right (seta s)
-
-atraversal_fromto :: Eq s => (s -> s + a) -> (s -> a -> s) -> s -> Bool
-atraversal_fromto seta sbt s = either id (sbt s) (seta s) == s
-
-atraversal_idempotent :: Eq s => (s -> a -> s) -> s -> a -> a -> Bool
-atraversal_idempotent sbt s a1 a2 = sbt (sbt s a1) a2 == sbt s a2
-
-atraversal_tofrom' :: Eq a => Eq s => Traversal0' s a -> s -> a -> Bool
-atraversal_tofrom' o = withTraversal0 o atraversal_tofrom
+-- | You get back what you put in.
+--
+-- * @sta (sbt a s) ≡ either (Left . const a) Right (sta s)@
+--
+tofrom_traversal0 :: Eq a => Eq s => Traversal0' s a -> s -> a -> Bool
+tofrom_traversal0 o s a = withTraversal0 o $ \sta sbt -> sta (sbt s a) == either (Left . flip const a) Right (sta s)
-atraversal_fromto' :: Eq s => Traversal0' s a -> s -> Bool
-atraversal_fromto' o = withTraversal0 o atraversal_fromto
+-- | Putting back what you got doesn't change anything.
+--
+-- * @either id (sbt s) (sta s) ≡ s@
+--
+fromto_traversal0 :: Eq s => Traversal0' s a -> s -> Bool
+fromto_traversal0 o s = withTraversal0 o $ \sta sbt -> either id (sbt s) (sta s) == s
-atraversal_idempotent' :: Eq s => Traversal0' s a -> s -> a -> a -> Bool
-atraversal_idempotent' o = withTraversal0 o $ const atraversal_idempotent
+-- | Setting twice is the same as setting once.
+--
+-- * @sbt (sbt s a1) a2 ≡ sbt s a2@
+--
+idempotent_traversal0 :: Eq s => Traversal0' s a -> s -> a -> a -> Bool
+idempotent_traversal0 o s a1 a2 = withTraversal0 o $ \_ sbt -> sbt (sbt s a1) a2 == sbt s a2
---------------------------------------------------------------------
--- 'Traversal'
+-- 'Traversal' & 'Traversal1'
---------------------------------------------------------------------
-
--- | 'Traversal' is a valid 'Setter' with the following additional laws:
+-- | A 'Traversal' is a valid 'Setter' with the following additional laws:
--
--- * @t pure ≡ pure@
+-- * @abst pure ≡ pure@
--
--- * @fmap (t f) . t g ≡ getCompose . t (Compose . fmap f . g)@
+-- * @fmap (abst f) . abst g ≡ getCompose . abst (Compose . fmap f . g)@
--
--- These can be restated in terms of 'traverseOf':
+-- These can be restated in terms of 'withTraversal':
--
--- * @traverseOf t (Identity . f) ≡ Identity (fmap f)@
+-- * @withTraversal abst (Identity . f) ≡ Identity . fmap f@
--
--- * @Compose . fmap (traverseOf t f) . traverseOf t g == traverseOf t (Compose . fmap f . g)@
+-- * @Compose . fmap (withTraversal abst f) . withTraversal abst g == withTraversal abst (Compose . fmap f . g)@
--
-- See also < https://www.cs.ox.ac.uk/jeremy.gibbons/publications/iterator.pdf >
--
+pure_traversal
+ :: Eq (f s)
+ => Applicative f
+ => ((a -> f a) -> s -> f s)
+ -> s -> Bool
+pure_traversal abst = liftA2 (==) (abst pure) pure
+
+compose_traversal
+ :: Eq (f (g s))
+ => Applicative f
+ => Applicative g
+ => (forall f. Applicative f => (a -> f a) -> s -> f s)
+ -> (a -> g a) -> (a -> f a) -> s -> Bool
+compose_traversal abst f g = liftA2 (==) (fmap (abst f) . abst g)
+ (getCompose . abst (Compose . fmap f . g))
+
+compose_traversal1
+ :: Eq (f (g s))
+ => Apply f
+ => Apply g
+ => (forall f. Apply f => (a -> f a) -> s -> f s)
+ -> (a -> g a) -> (a -> f a) -> s -> Bool
+compose_traversal1 abst f g = liftF2 (==) (fmap (abst f) . abst g)
+ (getCompose . abst (Compose . fmap f . g))
-traverse_pure :: forall f s a. (Applicative f, Eq (f s)) => ((a -> f a) -> s -> f s) -> s -> Bool
-traverse_pure o s = o pure s == (pure s :: f s)
+---------------------------------------------------------------------
+-- 'Cotraversal1'
+---------------------------------------------------------------------
---traverse_compose :: (Applicative f, Applicative g, Eq (f (g s))) => Traversal' s a -> (a -> g a) -> (a -> f a) -> s -> Bool
---traverse_compose t f g s = (fmap (t f) . t g) s == (getCompose . t (Compose . fmap f . g)) s
+-- | A 'Cotraversal1' is a valid 'Resetter' with the following additional law:
+--
+-- * @abst f . fmap (abst g) ≡ abst (f . fmap g . getCompose) . Compose @
+--
+-- These can be restated in terms of 'cowithTraversal1':
+--
+-- * @cowithTraversal1 abst (f . runIdentity) ≡ fmap f . runIdentity @
+--
+-- * @cowithTraversal1 abst f . fmap (cowithTraversal1 abst g) . getCompose == cowithTraversal1 abst (f . fmap g . getCompose)@
+--
+-- See also < https://www.cs.ox.ac.uk/jeremy.gibbons/publications/iterator.pdf >
+--
+compose_cotraversal1
+ :: Eq s
+ => Apply f
+ => Apply g
+ => (forall f. Apply f => (f a -> a) -> f s -> s)
+ -> (g a -> a) -> (f a -> a) -> g (f s) -> Bool
+compose_cotraversal1 abst f g = liftF2 (==) (abst f . fmap (abst g))
+ (abst (f . fmap g . getCompose) . Compose)
---------------------------------------------------------------------
-- 'Setter'
---------------------------------------------------------------------
--- | A 'Setter' is only legal if the following 3 laws hold:
---
--- 1. @set o y (set o x a) ≡ set o y a@
+-- |
--
--- 2. @over o id ≡ id@
+-- * @over o id ≡ id@
--
--- 3. @over o f . over o g ≡ over o (f . g)@
+pure_setter :: Eq s => Setter' s a -> s -> Bool
+pure_setter o s = over o id s == s
-setter_id :: Eq s => Setter' s a -> s -> Bool
-setter_id o s = over o id s == s
-
-setter_compose :: Eq s => Setter' s a -> (a -> a) -> (a -> a) -> s -> Bool
-setter_compose o f g s = (over o f . over o g) s == over o (f . g) s
+-- |
+--
+-- * @over o f . over o g ≡ over o (f . g)@
+--
+compose_setter :: Eq s => Setter' s a -> (a -> a) -> (a -> a) -> s -> Bool
+compose_setter o f g s = (over o f . over o g) s == over o (f . g) s
-setter_idempotent :: Eq s => Setter' s a -> s -> a -> a -> Bool
-setter_idempotent o s a b = set o b (set o a s) == set o b s
+-- |
+--
+-- * @set o y (set o x a) ≡ set o y a@
+--
+idempotent_setter :: Eq s => Setter' s a -> s -> a -> a -> Bool
+idempotent_setter o s a b = set o b (set o a s) == set o b s
diff --git a/src/Data/Profunctor/Optic/Setter.hs b/src/Data/Profunctor/Optic/Setter.hs
index b864e57..84ace9b 100644
--- a/src/Data/Profunctor/Optic/Setter.hs
+++ b/src/Data/Profunctor/Optic/Setter.hs
@@ -1,197 +1,412 @@
-{-# LANGUAGE DeriveFunctor #-}
-
-module Data.Profunctor.Optic.Setter where
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+module Data.Profunctor.Optic.Setter (
+ -- * Setter
+ Setter
+ , Setter'
+ , setter
+ , ixsetter
+ , closing
+ -- * Resetter
+ , Resetter
+ , Resetter'
+ , resetter
+ , cxsetter
+ -- * Optics
+ , cod
+ , dom
+ , bound
+ , fmapped
+ , contramapped
+ , setmapped
+ , isetmapped
+ , foldmapped
+ , liftedA
+ , liftedM
+ , locally
+ , zipped
+ , cond
+ , modded
+ , reviewed
+ , composed
+ , exmapped
+ -- * Primitive operators
+ , over
+ , ixover
+ , under
+ , cxover
+ , through
+ -- * Operators
+ , assignA
+ , set
+ , ixset
+ , reset
+ , cxset
+ , (.~)
+ , (..~)
+ , (/~)
+ , (//~)
+ , (?~)
+ , (<>~)
+ , (><~)
+ -- * Indexed Operators
+ , (%~)
+ , (%%~)
+ , (#~)
+ , (##~)
+ -- * MonadState
+ , assigns
+ , modifies
+ , (.=)
+ , (..=)
+ , (%=)
+ , (%%=)
+ , (//=)
+ , (#=)
+ , (##=)
+ , (?=)
+ , (<>=)
+ , (><=)
+ , zoom
+ -- * Carriers
+ , ASetter
+ , ASetter'
+ , Star(..)
+ , AResetter
+ , AResetter'
+ , Costar(..)
+ -- * Classes
+ , Representable(..)
+ , Corepresentable(..)
+) where
import Control.Applicative (liftA)
-import Control.Exception (Exception(..), SomeException)
-import Control.Monad.Reader as Reader hiding (lift)
-import Control.Monad.Writer as Writer hiding (lift)
+import Control.Exception (Exception(..))
+import Control.Monad.Reader as Reader
+import Control.Monad.State as State
+import Control.Monad.Writer as Writer
import Data.Foldable (Foldable, foldMap)
-import Data.Profunctor.Optic.Iso (PStore(..))
-import Data.Profunctor.Optic.Prelude hiding (Bifunctor(..))
+import Data.Profunctor.Arrow
+import Data.Profunctor.Optic.Import hiding ((&&&))
+import Data.Profunctor.Optic.Index (Index(..), Coindex(..), trivial)
import Data.Profunctor.Optic.Type
import Data.Semiring
+
+import Data.IntSet as IntSet
+import Data.Set as Set
+import Prelude (Num(..))
import qualified Control.Exception as Ex
+-- $setup
+-- >>> :set -XNoOverloadedStrings
+-- >>> :set -XTypeApplications
+-- >>> :set -XFlexibleContexts
+-- >>> :set -XRankNTypes
+-- >>> import Control.Category ((>>>))
+-- >>> import Control.Arrow (Kleisli(..))
+-- >>> import Control.Exception
+-- >>> import Control.Monad.State
+-- >>> import Control.Monad.Reader
+-- >>> import Control.Monad.Writer
+-- >>> import Data.Functor.Identity
+-- >>> import Data.Functor.Contravariant
+-- >>> import Data.Int.Instance ()
+-- >>> import Data.List.Index as LI
+-- >>> import Data.IntSet as IntSet
+-- >>> import Data.Set as Set
+-- >>> :load Data.Profunctor.Optic
+-- >>> let catchOn :: Int -> Cxprism' Int (Maybe String) String ; catchOn n = cxjust $ \k -> if k==n then Just "caught" else Nothing
+-- >>> let ixtraversed :: Ixtraversal Int [a] [b] a b ; ixtraversed = ixtraversalVl itraverse
+-- >>> let ixat :: Int -> Ixtraversal0' Int [a] a; ixat = inserted (\i s -> flip LI.ifind s $ \n _ -> n == i) (\i a s -> LI.modifyAt i (const a) s)
+
+type ASetter s t a b = ARepn Identity s t a b
+
+type ASetter' s a = ASetter s s a a
+
+type AIxsetter i s t a b = AIxrepn Identity i s t a b
+
+type AResetter s t a b = ACorepn Identity s t a b
+
+type AResetter' s a = AResetter s s a a
+
+type ACxsetter k s t a b = ACxrepn Identity k s t a b
+
---------------------------------------------------------------------
-- Setter
---------------------------------------------------------------------
--- | Promote a <http://conal.net/blog/posts/semantic-editor-combinators semantic editor combinator> to a modify-only optic.
+-- | Obtain a 'Setter' from a <http://conal.net/blog/posts/semantic-editor-combinators SEC>.
--
--- To demote an optic to a semantic edit combinator, use the section @(l %~)@ or @over l@.
+-- To demote an optic to a semantic edit combinator, use the section @(l ..~)@ or @over l@.
--
--- >>> [("The",0),("quick",1),("brown",1),("fox",2)] & setter map . _1 %~ length
+-- >>> [("The",0),("quick",1),("brown",1),("fox",2)] & setter fmap . t21 ..~ Prelude.length
-- [(3,0),(5,1),(5,1),(3,2)]
--
--- /Caution/: In order for the generated family to be well-defined, you must ensure that the two functor laws hold:
+-- /Caution/: In order for the generated optic to be well-defined,
+-- you must ensure that the input function satisfies the following
+-- properties:
+--
+-- * @abst id ≡ id@
--
--- * @sec id ≡ id@
+-- * @abst f . abst g ≡ abst (f . g)@
+--
+-- More generally, a profunctor optic must be monoidal as a natural
+-- transformation:
+--
+-- * @o id ≡ id@
--
--- * @sec f . sec g ≡ sec (f . g)@
+-- * @o ('Data.Profunctor.Composition.Procompose' p q) ≡ 'Data.Profunctor.Composition.Procompose' (o p) (o q)@
--
-- See 'Data.Profunctor.Optic.Property'.
--
setter :: ((a -> b) -> s -> t) -> Setter s t a b
-setter sec = dimap (flip PStore id) (\(PStore s ab) -> sec ab s) . lift collect
+setter abst = dimap (flip Index id) (\(Index s ab) -> abst ab s) . repn collect
+{-# INLINE setter #-}
--- | Every 'Grate' is a 'Setter'.
+-- | Build an 'Ixsetter' from an indexed function.
--
-closing :: (((s -> a) -> b) -> t) -> Setter s t a b
-closing sabt = setter $ \ab s -> sabt $ \sa -> ab (sa s)
-
-infixl 6 %
+-- @
+-- 'ixsetter' '.' 'ixover' ≡ 'id'
+-- 'ixover' '.' 'ixsetter' ≡ 'id'
+-- @
+--
+-- /Caution/: In order for the generated optic to be well-defined,
+-- you must ensure that the input satisfies the following properties:
+--
+-- * @iabst (const id) ≡ id@
+--
+-- * @fmap (iabst $ const f) . (iabst $ const g) ≡ iabst (const $ f . g)@
+--
+-- See 'Data.Profunctor.Optic.Property'.
+--
+ixsetter :: ((i -> a -> b) -> s -> t) -> Ixsetter i s t a b
+ixsetter f = setter $ \iab -> f (curry iab) . snd
+{-# INLINE ixsetter #-}
--- | Sum two SECs
+-- | Obtain a 'Resetter' from a <http://conal.net/blog/posts/semantic-editor-combinators SEC>.
+--
+-- /Caution/: In order for the generated optic to be well-defined,
+-- you must ensure that the input function satisfies the following
+-- properties:
--
-(%) :: Setter' a a -> Setter' a a -> Setter' a a
-(%) f g = setter $ \h -> (f %~ h) . (g %~ h)
+-- * @abst id ≡ id@
+--
+-- * @abst f . abst g ≡ abst (f . g)@
+--
+resetter :: ((a -> t) -> s -> t) -> Resetter s t a t
+resetter abst = dimap (\s -> Coindex $ \ab -> abst ab s) trivial . corepn (\f -> fmap f . sequenceA)
+{-# INLINE resetter #-}
--- >>> toSemiring $ zero % one :: Int
--- 1
--- >>> toSemiring $ zero . one :: Int
--- 0
-toSemiring :: Monoid a => Semiring a => Setter' a a -> a
-toSemiring a = over a (unit <>) mempty
+-- | TODO: Document
+--
+-- /Caution/: In order for the generated optic to be well-defined,
+-- you must ensure that the input satisfies the following properties:
+--
+-- * @kabst (const id) ≡ id@
+--
+-- * @fmap (kabst $ const f) . (kabst $ const g) ≡ kabst (const $ f . g)@
+--
+-- See 'Data.Profunctor.Optic.Property'.
+--
+cxsetter :: ((k -> a -> t) -> s -> t) -> Cxsetter k s t a t
+cxsetter f = resetter $ \kab -> const . f (flip kab)
+{-# INLINE cxsetter #-}
-fromSemiring :: Monoid a => Semiring a => a -> Setter' a a
-fromSemiring a = setter $ \ f y -> a >< f mempty <> y
+-- | Every valid 'Grate' is a 'Setter'.
+--
+closing :: (((s -> a) -> b) -> t) -> Setter s t a b
+closing sabt = setter $ \ab s -> sabt $ \sa -> ab (sa s)
+{-# INLINE closing #-}
---------------------------------------------------------------------
-- Primitive operators
---------------------------------------------------------------------
--- | Modify the target of a 'Lens' or all the targets of a 'Setter' or 'Traversal'.
+-- | Extract a SEC from a 'Setter'.
--
--- @ 'over' l 'id' ≡ 'id' @
+-- Used to modify the target of a 'Lens' or all the targets of a 'Setter'
+-- or 'Traversal'.
--
-- @
--- 'over' l f '.' 'over' l g ≡ 'over' l (f '.' g)
+-- 'over' o 'id' ≡ 'id'
+-- 'over' o f '.' 'over' o g ≡ 'over' o (f '.' g)
+-- 'setter' '.' 'over' ≡ 'id'
+-- 'over' '.' 'setter' ≡ 'id'
-- @
--
--- >>> over mapped f (over mapped g [a,b,c]) == over mapped (f . g) [a,b,c]
--- True
---
--- >>> over mapped f (Just a)
--- Just (f a)
+-- >>> over fmapped (+1) (Just 1)
+-- Just 2
--
--- >>> over mapped (*10) [1,2,3]
+-- >>> over fmapped (*10) [1,2,3]
-- [10,20,30]
--
--- >>> over _1 f (a,b)
--- (f a,b)
+-- >>> over t21 (+1) (1,2)
+-- (2,2)
--
--- >>> over _1 show (10,20)
+-- >>> over t21 show (10,20)
-- ("10",20)
--
-- @
--- 'fmap' ≡ 'over' 'mapped'
--- 'setter' '.' 'over' ≡ 'id'
--- 'over' '.' 'setter' ≡ 'id'
--- @
---
--- @ 'over' ('cayley' a) ('Data.Semiring.unit' <>) 'Data.Monoid.mempty' ≡ a @
---
--- @
-- over :: Setter s t a b -> (a -> r) -> s -> r
-- over :: Monoid r => Fold s t a b -> (a -> r) -> s -> r
-- @
--
-over :: Optic (->) s t a b -> (a -> b) -> s -> t
-over = id
+over :: ASetter s t a b -> (a -> b) -> s -> t
+over o = (runIdentity #.) #. runStar #. o .# Star .# (Identity #. )
+{-# INLINE over #-}
--- | TODO: Document
+-- |
--
-reover :: Optic (Re (->) a b) s t a b -> (t -> s) -> (b -> a)
-reover = re
-
----------------------------------------------------------------------
--- Derived operators
----------------------------------------------------------------------
-
-infixr 4 %~
-
--- | TODO: Document
+-- >>> ixover (ixat 1) (+) [1,2,3 :: Int]
+-- [1,3,3]
--
-(%~) :: Optic (->) s t a b -> (a -> b) -> s -> t
-(%~) = id
-{-# INLINE (%~) #-}
-
-infixr 4 .~
+-- >>> ixover (ixat 5) (+) [1,2,3 :: Int]
+-- [1,2,3]
+--
+ixover :: Monoid i => AIxsetter i s t a b -> (i -> a -> b) -> s -> t
+ixover o f = curry (over o (uncurry f)) mempty
+{-# INLINE ixover #-}
--- | TODO: Document
+-- | Extract a SEC from a 'Resetter'.
--
-(.~) :: Optic (->) s t a b -> b -> s -> t
-(.~) = set
-{-# INLINE (.~) #-}
+-- @
+-- 'under' o 'id' ≡ 'id'
+-- 'under' o f '.' 'under' o g ≡ 'under' o (f '.' g)
+-- 'resetter' '.' 'under' ≡ 'id'
+-- 'under' '.' 'resetter' ≡ 'id'
+-- @
+--
+-- Note that 'under' (more properly co-/over/) is distinct from 'Data.Profunctor.Optic.Iso.reover':
+--
+-- >>> :t under $ wrapped @(Identity Int)
+-- under $ wrapped @(Identity Int)
+-- :: (Int -> Int) -> Identity Int -> Identity Int
+-- >>> :t over $ wrapped @(Identity Int)
+-- over $ wrapped @(Identity Int)
+-- :: (Int -> Int) -> Identity Int -> Identity Int
+-- >>> :t over . re $ wrapped @(Identity Int)
+-- over . re $ wrapped @(Identity Int)
+-- :: (Identity Int -> Identity Int) -> Int -> Int
+-- >>> :t reover $ wrapped @(Identity Int)
+-- reover $ wrapped @(Identity Int)
+-- :: (Identity Int -> Identity Int) -> Int -> Int
+--
+-- Compare to the /lens-family/ <http://hackage.haskell.org/package/lens-family-2.0.0/docs/Lens-Family2.html#v:under version>.
+--
+under :: AResetter s t a b -> (a -> b) -> s -> t
+under o = (.# Identity) #. runCostar #. o .# Costar .# (.# runIdentity)
+{-# INLINE under #-}
--- | Set all referenced fields to the given value.
+-- |
+--
+-- >>> cxover (catchOn 42) (\k msg -> show k ++ ": " ++ msg) $ Just "foo"
+-- Just "0: foo"
--
--- @ set l y (set l x a) ≡ set l y a @
+-- >>> cxover (catchOn 42) (\k msg -> show k ++ ": " ++ msg) Nothing
+-- Nothing
--
-set :: Optic (->) s t a b -> b -> s -> t
-set o b = o (const b)
+-- >>> cxover (catchOn 0) (\k msg -> show k ++ ": " ++ msg) Nothing
+-- Just "caught"
+--
+cxover :: Monoid k => ACxsetter k s t a b -> (k -> a -> b) -> s -> t
+cxover o f = flip (under o (flip f)) mempty
+{-# INLINE cxover #-}
+
+-- | The join of 'under' and 'over'.
+--
+through :: Optic (->) s t a b -> (a -> b) -> s -> t
+through = id
+{-# INLINE through #-}
---------------------------------------------------------------------
--- Common setters
+-- Optics
---------------------------------------------------------------------
--- | The unit SEC
+-- | Map covariantly over the output of a 'Profunctor'.
--
-one :: Monoid a => Semiring a => Setter' a a
-one = setter id
-
--- | The zero SEC
+-- The most common profunctor to use this with is @(->)@.
--
-zero :: Monoid a => Semiring a => Setter' a a
-zero = setter $ const id
-
--- | Map contravariantly by setter the input of a 'Profunctor'.
+-- @
+-- (dom ..~ f) g x ≡ f (g x)
+-- cod @(->) ≡ 'Data.Profunctor.Optic.Grate.withGrate' 'Data.Profunctor.Closed.closed' 'Data.Profunctor.Optic.Setter.closing'
+-- @
--
+-- >>> (cod ..~ show) length [1,2,3]
+-- "3"
+--
+cod :: Profunctor p => Setter (p r a) (p r b) a b
+cod = setter rmap
+{-# INLINE cod #-}
+
+-- | Map contravariantly over the input of a 'Profunctor'.
--
-- The most common profunctor to use this with is @(->)@.
--
--- >>> (dom %~ f) g x
--- g (f x)
+-- @
+-- (dom ..~ f) g x ≡ g (f x)
+-- @
--
--- >>> (dom %~ show) length [1,2,3]
+-- >>> (dom ..~ show) length [1,2,3]
-- 7
--
--- >>> (dom %~ f) h x y
--- h (f x) y
---
--- Map setter the second arg of a function:
---
--- >>> (mapped . dom %~ f) h x y
--- h x (f y)
---
dom :: Profunctor p => Setter (p b r) (p a r) a b
dom = setter lmap
{-# INLINE dom #-}
--- | A grate accessing the codomain of a function.
+-- | 'Setter' for monadically transforming a monadic value.
+--
+bound :: Monad m => Setter (m a) (m b) a (m b)
+bound = setter (=<<)
+{-# INLINE bound #-}
+
+-- | 'Setter' on each value of a functor.
+--
+fmapped :: Functor f => Setter (f a) (f b) a b
+fmapped = setter fmap
+{-# INLINE fmapped #-}
+
+-- | This 'Setter' can be used to map over all of the inputs to a 'Contravariant'.
--
-- @
--- cod @(->) == lowerGrate range
+-- 'contramap' ≡ 'over' 'contramapped'
-- @
--
-cod :: Profunctor p => Setter (p r a) (p r b) a b
-cod = setter rmap
+-- >>> getPredicate (over contramapped (*2) (Predicate even)) 5
+-- True
+--
+-- >>> getOp (over contramapped (*5) (Op show)) 100
+-- "500"
+--
+contramapped :: Contravariant f => Setter (f b) (f a) a b
+contramapped = setter contramap
+{-# INLINE contramapped #-}
--- | SEC for monadically transforming a monadic value.
+-- |
--
-bound :: Monad m => Setter (m a) (m b) a (m b)
-bound = setter (=<<)
+-- >>> over setmapped (+1) (Set.fromList [1,2,3,4])
+-- fromList [2,3,4,5]
+setmapped :: Ord b => Setter (Set a) (Set b) a b
+setmapped = setter Set.map
+{-# INLINE setmapped #-}
--- | SEC on each value of a functor.
+-- |
--
-fmapped :: Functor f => Setter (f a) (f b) a b
-fmapped = setter fmap
+-- >>> over isetmapped (+1) (IntSet.fromList [1,2,3,4])
+-- fromList [2,3,4,5]
+isetmapped :: Setter' IntSet Int
+isetmapped = setter IntSet.map
+{-# INLINE isetmapped #-}
-- | TODO: Document
--
-foldMapped :: Foldable f => Monoid m => Setter (f a) m a m
-foldMapped = setter foldMap
+foldmapped :: Foldable f => Monoid m => Setter (f a) m a m
+foldmapped = setter foldMap
+{-# INLINE foldmapped #-}
-- | This 'setter' can be used to modify all of the values in an 'Applicative'.
--
@@ -199,75 +414,454 @@ foldMapped = setter foldMap
-- 'liftA' ≡ 'setter' 'liftedA'
-- @
--
--- >>> setter liftedA f [a,b,c]
--- [f a,f b,f c]
+-- >>> setter liftedA Identity [1,2,3]
+-- [Identity 1,Identity 2,Identity 3]
+--
+-- >>> set liftedA 2 (Just 1)
+-- Just 2
--
--- >>> set liftedA b (Just a)
--- Just b
liftedA :: Applicative f => Setter (f a) (f b) a b
liftedA = setter liftA
+{-# INLINE liftedA #-}
-- | TODO: Document
--
liftedM :: Monad m => Setter (m a) (m b) a b
liftedM = setter liftM
+{-# INLINE liftedM #-}
--- | Set a value using an SEC.
+-- | Modify the local environment of a 'Reader'.
+--
+-- Use to lift reader actions into a larger environment:
--
-sets :: Setter b (a -> c) a c
-sets = setter const
+-- >>> runReader ( ask & locally ..~ fst ) (1,2)
+-- 1
+--
+locally :: Setter (ReaderT r2 m a) (ReaderT r1 m a) r1 r2
+locally = setter withReaderT
+{-# INLINE locally #-}
-- | TODO: Document
--
zipped :: Setter (u -> v -> a) (u -> v -> b) a b
zipped = setter ((.)(.)(.))
+{-# INLINE zipped #-}
+
+-- | Apply a function only when the given condition holds.
+--
+-- See also 'Data.Profunctor.Optic.Affine.predicated' & 'Data.Profunctor.Optic.Prism.filtered'.
+--
+cond :: (a -> Bool) -> Setter' a a
+cond p = setter $ \f a -> if p a then f a else a
+{-# INLINE cond #-}
+
+-- | TODO: Document
+--
+modded :: (a -> Bool) -> Setter' (a -> b) b
+modded p = setter $ \mods f a -> if p a then mods (f a) else f a
+{-# INLINE modded #-}
-- | TODO: Document
--
-modded :: Setter (b -> t) (((s -> a) -> b) -> t) s a
-modded = setter $ \sa bt sab -> bt (sab sa)
+reviewed :: Setter (b -> t) (((s -> a) -> b) -> t) s a
+reviewed = setter $ \sa bt sab -> bt (sab sa)
+{-# INLINE reviewed #-}
-- | TODO: Document
--
composed :: Setter (s -> a) ((a -> b) -> s -> t) b t
composed = setter between
+{-# INLINE composed #-}
--- | Apply a function only when the given predicate holds.
+-- | Map one exception into another as proposed in the paper "A semantics for imprecise exceptions".
--
-branched :: (a -> Bool) -> Setter' a a
-branched p = setter $ \f a -> if p a then f a else a
+-- >>> handles (only Overflow) (\_ -> return "caught") $ assert False (return "uncaught") & (exmapped ..~ \ (AssertionFailed _) -> Overflow)
+-- "caught"
+--
+-- @
+-- exmapped :: Exception e => Setter s s SomeException e
+-- @
+--
+exmapped :: Exception e1 => Exception e2 => Setter s s e1 e2
+exmapped = setter Ex.mapException
+{-# INLINE exmapped #-}
--- | TODO: Document
+---------------------------------------------------------------------
+-- Operators
+---------------------------------------------------------------------
+
+infixr 4 .~, ..~, %~, %%~, /~, //~, #~, ##~, ?~, <>~, ><~
+
+-- | Run a profunctor arrow command and set the optic targets to the result.
+--
+-- Similar to 'assign', except that the type of the object being modified can change.
+--
+-- >>> getVal1 = Right 3
+-- >>> getVal2 = Right False
+-- >>> action = assignA t21 (Kleisli (const getVal1)) >>> assignA t22 (Kleisli (const getVal2))
+-- >>> runKleisli action ((), ())
+-- Right (3,False)
+--
+-- @
+-- 'assignA' :: 'Category' p => 'Iso' s t a b -> 'Lenslike' p s t s b
+-- 'assignA' :: 'Category' p => 'Lens' s t a b -> 'Lenslike' p s t s b
+-- 'assignA' :: 'Category' p => 'Grate' s t a b -> 'Lenslike' p s t s b
+-- 'assignA' :: 'Category' p => 'Setter' s t a b -> 'Lenslike' p s t s b
+-- 'assignA' :: 'Category' p => 'Traversal' s t a b -> 'Lenslike' p s t s b
+-- @
--
-branched' :: (k -> Bool) -> Setter' (k -> v) v
-branched' p = setter $ \md f a -> if p a then md (f a) else f a
+assignA :: Category p => Strong p => ASetter s t a b -> Optic p s t s b
+assignA o p = arr (flip $ set o) &&& p >>> arr (uncurry id)
+{-# INLINE assignA #-}
--- | This 'Setter' can be used to purely map over the 'Exception's an
--- arbitrary expression might throw; it is a variant of 'mapException' in
--- the same way that 'mapped' is a variant of 'fmap'.
+-- | Set all referenced fields to the given value.
--
--- > 'mapException' ≡ 'over' 'excepted'
+-- @ 'set' l y ('set' l x a) ≡ 'set' l y a @
--
--- This view that every Haskell expression can be regarded as carrying a bag
--- of 'Exception's is detailed in “A Semantics for Imprecise Exceptions” by
--- Peyton Jones & al. at PLDI ’99.
+set :: ASetter s t a b -> b -> s -> t
+set o b = over o (const b)
+{-# INLINE set #-}
+
+-- | Set with index. Equivalent to 'ixover' with the current value ignored.
--
--- The following maps failed assertions to arithmetic overflow:
+-- When you do not need access to the index, then 'set' is more liberal in what it can accept.
--
--- >>> handleOf _Overflow (\_ -> return "caught") $ assert False (return "uncaught") & (exmapped %~ \ (AssertionFailed _) -> Overflow)
--- "caught"
+-- @
+-- 'set' o ≡ 'ixset' o '.' 'const'
+-- @
+--
+-- >>> ixset (ixat 2) (2-) [1,2,3 :: Int]
+-- [1,2,0]
+--
+-- >>> ixset (ixat 5) (const 0) [1,2,3 :: Int]
+-- [1,2,3]
+--
+ixset :: Monoid i => AIxsetter i s t a b -> (i -> b) -> s -> t
+ixset o = ixover o . (const .)
+{-# INLINE ixset #-}
+
+-- | Set all referenced fields to the given value.
+--
+-- @
+-- 'reset' ≡ 'set' '.' 're'
+-- @
--
-exmapped :: Exception e0 => Exception e1 => Setter s s e0 e1
-exmapped = setter Ex.mapException
+reset :: AResetter s t a b -> b -> s -> t
+reset o b = under o (const b)
+{-# INLINE reset #-}
--- | A type restricted version of 'mappedException'.
+-- | Dual set with index. Equivalent to 'cxover' with the current value ignored.
--
--- This function avoids the type ambiguity in the input 'Exception' when using 'set'.
+-- >>> cxset (catchOn 42) show $ Just "foo"
+-- Just "0"
--
--- The following maps any exception to arithmetic overflow:
+-- >>> cxset (catchOn 42) show Nothing
+-- Nothing
--
--- >>> handleOf _Overflow (\_ -> return "caught") $ assert False (return "uncaught") & (exmapped' .~ Overflow)
--- "caught"
+-- >>> cxset (catchOn 0) show Nothing
+-- Just "caught"
+--
+cxset :: Monoid k => ACxsetter k s t a b -> (k -> b) -> s -> t
+cxset o kb = cxover o $ flip (const kb)
+{-# INLINE cxset #-}
+
+-- | TODO: Document
+--
+(.~) :: ASetter s t a b -> b -> s -> t
+(.~) = set
+{-# INLINE (.~) #-}
+
+-- | TODO: Document
+--
+-- >>> Nothing & just ..~ (+1)
+-- Nothing
+--
+(..~) :: ASetter s t a b -> (a -> b) -> s -> t
+(..~) = over
+{-# INLINE (..~) #-}
+
+-- | An infix variant of 'ixset'. Dual to '#~'.
+--
+(%~) :: Monoid i => AIxsetter i s t a b -> (i -> b) -> s -> t
+(%~) = ixset
+{-# INLINE (%~) #-}
+
+-- | An infix variant of 'ixover'. Dual to '##~'.
+--
+(%%~) :: Monoid i => AIxsetter i s t a b -> (i -> a -> b) -> s -> t
+(%%~) = ixover
+{-# INLINE (%%~) #-}
+
+-- | An infix variant of 'reset'. Dual to '.~'.
+--
+(/~) :: AResetter s t a b -> b -> s -> t
+(/~) = reset
+{-# INLINE (/~) #-}
+
+-- | An infix variant of 'under'. Dual to '..~'.
+--
+(//~) :: AResetter s t a b -> (a -> b) -> s -> t
+(//~) = under
+{-# INLINE (//~) #-}
+
+-- | An infix variant of 'cxset'. Dual to '%~'.
+--
+(#~) :: Monoid k => ACxsetter k s t a b -> (k -> b) -> s -> t
+(#~) = cxset
+{-# INLINE (#~) #-}
+
+-- | An infix variant of 'cxover'. Dual to '%%~'.
+--
+-- >>> Just "foo" & catchOn 0 ##~ (\k msg -> show k ++ ": " ++ msg)
+-- Just "0: foo"
+--
+-- >>> Nothing & catchOn 0 ##~ (\k msg -> show k ++ ": " ++ msg)
+-- Just "caught"
+--
+(##~) :: Monoid k => ACxsetter k s t a b -> (k -> a -> b) -> s -> t
+(##~) = cxover
+{-# INLINE (##~) #-}
+
+-- | Set the target of a settable optic to 'Just' a value.
+--
+-- @
+-- l '?~' t ≡ 'set' l ('Just' t)
+-- @
+--
+-- >>> Nothing & id ?~ 1
+-- Just 1
+--
+-- '?~' can be used type-changily:
+--
+-- >>> ('a', ('b', 'c')) & t22 . both ?~ 'x'
+-- ('a',(Just 'x',Just 'x'))
+--
+-- @
+-- ('?~') :: 'Iso' s t a ('Maybe' b) -> b -> s -> t
+-- ('?~') :: 'Lens' s t a ('Maybe' b) -> b -> s -> t
+-- ('?~') :: 'Grate' s t a ('Maybe' b) -> b -> s -> t
+-- ('?~') :: 'Setter' s t a ('Maybe' b) -> b -> s -> t
+-- ('?~') :: 'Traversal' s t a ('Maybe' b) -> b -> s -> t
+-- @
+--
+(?~) :: ASetter s t a (Maybe b) -> b -> s -> t
+o ?~ b = set o (Just b)
+{-# INLINE (?~) #-}
+
+-- | Modify the target by adding another value.
+--
+-- >>> both <>~ False $ (False,True)
+-- (False,True)
+--
+-- >>> both <>~ "!!!" $ ("hello","world")
+-- ("hello!!!","world!!!")
+--
+-- @
+-- ('<>~') :: 'Semigroup' a => 'Iso' s t a a -> a -> s -> t
+-- ('<>~') :: 'Semigroup' a => 'Lens' s t a a -> a -> s -> t
+-- ('<>~') :: 'Semigroup' a => 'Grate' s t a a -> a -> s -> t
+-- ('<>~') :: 'Semigroup' a => 'Setter' s t a a -> a -> s -> t
+-- ('<>~') :: 'Semigroup' a => 'Traversal' s t a a -> a -> s -> t
+-- @
+--
+(<>~) :: Semigroup a => ASetter s t a a -> a -> s -> t
+l <>~ n = over l (<> n)
+{-# INLINE (<>~) #-}
+
+-- | Modify the target by multiplying by another value.
+--
+-- >>> both ><~ False $ (False,True)
+-- (False,False)
+--
+-- @
+-- ('><~') :: 'Semiring' a => 'Iso' s t a a -> a -> s -> t
+-- ('><~') :: 'Semiring' a => 'Lens' s t a a -> a -> s -> t
+-- ('><~') :: 'Semiring' a => 'Grate' s t a a -> a -> s -> t
+-- ('><~') :: 'Semiring' a => 'Setter' s t a a -> a -> s -> t
+-- ('><~') :: 'Semiring' a => 'Traversal' s t a a -> a -> s -> t
+-- @
--
-exmapped' :: Exception e => Setter s s SomeException e
-exmapped' = exmapped
+(><~) :: Semiring a => ASetter s t a a -> a -> s -> t
+l ><~ n = over l (>< n)
+{-# INLINE (><~) #-}
+
+---------------------------------------------------------------------
+-- MonadState
+---------------------------------------------------------------------
+
+infix 4 .=, ..=, %=, %%=, //=, #=, ##=, ?=, <>=, ><=
+
+-- | Replace the target(s) of a settable in a monadic state.
+--
+-- @
+-- 'assigns' :: 'MonadState' s m => 'Iso'' s a -> a -> m ()
+-- 'assigns' :: 'MonadState' s m => 'Lens'' s a -> a -> m ()
+-- 'assigns' :: 'MonadState' s m => 'Grate'' s a -> a -> m ()
+-- 'assigns' :: 'MonadState' s m => 'Prism'' s a -> a -> m ()
+-- 'assigns' :: 'MonadState' s m => 'Setter'' s a -> a -> m ()
+-- 'assigns' :: 'MonadState' s m => 'Traversal'' s a -> a -> m ()
+-- @
+--
+assigns :: MonadState s m => ASetter s s a b -> b -> m ()
+assigns o b = State.modify (set o b)
+{-# INLINE assigns #-}
+
+-- | Map over the target(s) of a 'Setter' in a monadic state.
+--
+-- @
+-- 'modifies' :: 'MonadState' s m => 'Iso'' s a -> (a -> a) -> m ()
+-- 'modifies' :: 'MonadState' s m => 'Lens'' s a -> (a -> a) -> m ()
+-- 'modifies' :: 'MonadState' s m => 'Grate'' s a -> (a -> a) -> m ()
+-- 'modifies' :: 'MonadState' s m => 'Prism'' s a -> (a -> a) -> m ()
+-- 'modifies' :: 'MonadState' s m => 'Setter'' s a -> (a -> a) -> m ()
+-- 'modifies' :: 'MonadState' s m => 'Traversal'' s a -> (a -> a) -> m ()
+-- @
+--
+modifies :: MonadState s m => ASetter s s a b -> (a -> b) -> m ()
+modifies o f = State.modify (over o f)
+{-# INLINE modifies #-}
+
+-- | Replace the target(s) of a settable in a monadic state.
+--
+-- This is an infix version of 'assigns'.
+--
+-- >>> execState (do t21 .= 1; t22 .= 2) (3,4)
+-- (1,2)
+--
+-- >>> execState (both .= 3) (1,2)
+-- (3,3)
+--
+-- @
+-- ('.=') :: 'MonadState' s m => 'Iso'' s a -> a -> m ()
+-- ('.=') :: 'MonadState' s m => 'Lens'' s a -> a -> m ()
+-- ('.=') :: 'MonadState' s m => 'Grate'' s a -> a -> m ()
+-- ('.=') :: 'MonadState' s m => 'Prism'' s a -> a -> m ()
+-- ('.=') :: 'MonadState' s m => 'Setter'' s a -> a -> m ()
+-- ('.=') :: 'MonadState' s m => 'Traversal'' s a -> a -> m ()
+-- @
+--
+(.=) :: MonadState s m => ASetter s s a b -> b -> m ()
+o .= b = State.modify (o .~ b)
+{-# INLINE (.=) #-}
+
+-- | Map over the target(s) of a 'Setter' in a monadic state.
+--
+-- This is an infix version of 'modifies'.
+--
+-- >>> execState (do just ..= (+1) ) Nothing
+-- Nothing
+--
+-- >>> execState (do t21 ..= (+1) ;t22 ..= (+2)) (1,2)
+-- (2,4)
+--
+-- >>> execState (do both ..= (+1)) (1,2)
+-- (2,3)
+--
+-- @
+-- ('..=') :: 'MonadState' s m => 'Iso'' s a -> (a -> a) -> m ()
+-- ('..=') :: 'MonadState' s m => 'Lens'' s a -> (a -> a) -> m ()
+-- ('..=') :: 'MonadState' s m => 'Grate'' s a -> (a -> a) -> m ()
+-- ('..=') :: 'MonadState' s m => 'Prism'' s a -> (a -> a) -> m ()
+-- ('..=') :: 'MonadState' s m => 'Setter'' s a -> (a -> a) -> m ()
+-- ('..=') :: 'MonadState' s m => 'Traversal'' s a -> (a -> a) -> m ()
+-- @
+--
+(..=) :: MonadState s m => ASetter s s a b -> (a -> b) -> m ()
+o ..= f = State.modify (o ..~ f)
+{-# INLINE (..=) #-}
+
+-- | TODO: Document
+--
+(%=) :: MonadState s m => Monoid i => AIxsetter i s s a b -> (i -> b) -> m ()
+o %= b = State.modify (o %~ b)
+
+-- | TODO: Document
+--
+(%%=) :: MonadState s m => Monoid i => AIxsetter i s s a b -> (i -> a -> b) -> m ()
+o %%= f = State.modify (o %%~ f)
+{-# INLINE (%%=) #-}
+
+-- | TODO: Document
+--
+(//=) :: MonadState s m => AResetter s s a b -> (a -> b) -> m ()
+o //= f = State.modify (o //~ f)
+{-# INLINE (//=) #-}
+
+-- | TODO: Document
+--
+(#=) :: MonadState s m => Monoid k => ACxsetter k s s a b -> (k -> b) -> m ()
+o #= f = State.modify (o #~ f)
+{-# INLINE (#=) #-}
+
+-- | TODO: Document
+--
+(##=) :: MonadState s m => Monoid k => ACxsetter k s s a b -> (k -> a -> b) -> m ()
+o ##= f = State.modify (o ##~ f)
+{-# INLINE (##=) #-}
+
+-- | Replace the target(s) of a settable optic with 'Just' a new value.
+--
+-- >>> execState (do t21 ?= 1; t22 ?= 2) (Just 1, Nothing)
+-- (Just 1,Just 2)
+--
+-- @
+-- ('?=') :: 'MonadState' s m => 'Iso'' s ('Maybe' a) -> a -> m ()
+-- ('?=') :: 'MonadState' s m => 'Lens'' s ('Maybe' a) -> a -> m ()
+-- ('?=') :: 'MonadState' s m => 'Grate'' s ('Maybe' a) -> a -> m ()
+-- ('?=') :: 'MonadState' s m => 'Prism'' s ('Maybe' a) -> a -> m ()
+-- ('?=') :: 'MonadState' s m => 'Setter'' s ('Maybe' a) -> a -> m ()
+-- ('?=') :: 'MonadState' s m => 'Traversal'' s ('Maybe' a) -> a -> m ()
+-- @
+--
+(?=) :: MonadState s m => ASetter s s a (Maybe b) -> b -> m ()
+o ?= b = State.modify (o ?~ b)
+{-# INLINE (?=) #-}
+
+-- | Modify the target(s) of a settable optic by adding a value.
+--
+-- >>> execState (both <>= False) (False,True)
+-- (False,True)
+--
+-- >>> execState (both <>= "!!!") ("hello","world")
+-- ("hello!!!","world!!!")
+--
+-- @
+-- ('<>=') :: 'MonadState' s m => 'Semigroup' a => 'Iso'' s a -> a -> m ()
+-- ('<>=') :: 'MonadState' s m => 'Semigroup' a => 'Lens'' s a -> a -> m ()
+-- ('<>=') :: 'MonadState' s m => 'Semigroup' a => 'Grate'' s a -> a -> m ()
+-- ('<>=') :: 'MonadState' s m => 'Semigroup' a => 'Prism'' s a -> a -> m ()
+-- ('<>=') :: 'MonadState' s m => 'Semigroup' a => 'Setter'' s a -> a -> m ()
+-- ('<>=') :: 'MonadState' s m => 'Semigroup' a => 'Traversal'' s a -> a -> m ()
+-- @
+--
+(<>=) :: MonadState s m => Semigroup a => ASetter' s a -> a -> m ()
+o <>= a = State.modify (o <>~ a)
+{-# INLINE (<>=) #-}
+
+-- | Modify the target(s) of a settable optic by mulitiplying by a value.
+--
+-- >>> execState (both ><= False) (False,True)
+-- (False,False)
+--
+-- @
+-- ('><=') :: 'MonadState' s m => 'Semiring' a => 'Iso'' s a -> a -> m ()
+-- ('><=') :: 'MonadState' s m => 'Semiring' a => 'Lens'' s a -> a -> m ()
+-- ('><=') :: 'MonadState' s m => 'Semiring' a => 'Grate'' s a -> a -> m ()
+-- ('><=') :: 'MonadState' s m => 'Semiring' a => 'Prism'' s a -> a -> m ()
+-- ('><=') :: 'MonadState' s m => 'Semiring' a => 'Setter'' s a -> a -> m ()
+-- ('><=') :: 'MonadState' s m => 'Semiring' a => 'Traversal'' s a -> a -> m ()
+-- @
+--
+(><=) :: MonadState s m => Semiring a => ASetter' s a -> a -> m ()
+o ><= a = State.modify (o ><~ a)
+{-# INLINE (><=) #-}
+
+-- @
+-- zoom :: Functor m => Lens' ta a -> StateT a m c -> StateT ta m c
+-- zoom :: (Monoid c, Applicative m) => Traversal' ta a -> StateT a m c -> StateT ta m c
+-- @
+zoom :: Functor m => Optic' (Star (Compose m ((,) c))) ta a -> StateT a m c -> StateT ta m c
+zoom o (StateT m) = StateT . out . o . into $ m
+ where
+ into f = Star (Compose . f)
+ out (Star f) = getCompose . f
diff --git a/src/Data/Profunctor/Optic/Traversal.hs b/src/Data/Profunctor/Optic/Traversal.hs
index 86a1f69..def7f45 100644
--- a/src/Data/Profunctor/Optic/Traversal.hs
+++ b/src/Data/Profunctor/Optic/Traversal.hs
@@ -1,55 +1,240 @@
-module Data.Profunctor.Optic.Traversal where
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+module Data.Profunctor.Optic.Traversal (
+ -- * Traversal & Ixtraversal
+ Traversal
+ , Traversal'
+ , Ixtraversal
+ , Ixtraversal'
+ , ATraversal
+ , ATraversal'
+ , traversing
+ , ixtraversing
+ , traversalVl
+ , ixtraversalVl
+ , noix
+ , ix
+ -- * Primitive operators
+ , withTraversal
+ -- * Optics
+ , traversed
+ , both
+ , duplicated
+ , bitraversed
+ -- * Operators
+ , sequences
+ -- * Carriers
+ , Star(..)
+ , Costar(..)
+ -- * Classes
+ , Representable(..)
+ , Corepresentable(..)
+) where
import Data.Bitraversable
-import Data.Profunctor.Optic.Prelude
+import Data.Profunctor.Optic.Lens
+import Data.Profunctor.Optic.Import
import Data.Profunctor.Optic.Type
+import Data.Semiring
+import Control.Monad.Trans.State
+
+-- $setup
+-- >>> :set -XNoOverloadedStrings
+-- >>> :set -XFlexibleContexts
+-- >>> :set -XTypeApplications
+-- >>> :set -XTupleSections
+-- >>> :set -XRankNTypes
+-- >>> import Data.Maybe
+-- >>> import Data.Int.Instance ()
+-- >>> import Data.List.NonEmpty (NonEmpty(..))
+-- >>> import qualified Data.List.NonEmpty as NE
+-- >>> import Data.Functor.Identity
+-- >>> import Data.List.Index
+-- >>> :load Data.Profunctor.Optic
+-- >>> let catchOn :: Int -> Cxprism' Int (Maybe String) String ; catchOn n = cxjust $ \k -> if k==n then Just "caught" else Nothing
+-- >>> let ixtraversed :: Ixtraversal Int [a] [b] a b ; ixtraversed = ixtraversalVl itraverse
---------------------------------------------------------------------
--- 'Traversal'
+-- 'Traversal' & 'Ixtraversal'
---------------------------------------------------------------------
--- | TODO: Document
+type ATraversal f s t a b = Applicative f => ARepn f s t a b
+
+type ATraversal' f s a = ATraversal f s s a a
+
+-- | Obtain a 'Traversal' by lifting a lens getter and setter into a 'Traversable' functor.
+--
+-- @
+-- 'withLens' o 'traversing' ≡ 'traversed' . o
+-- @
+--
+-- Compare 'Data.Profunctor.Optic.Fold.folding'.
+--
+-- /Caution/: In order for the generated optic to be well-defined,
+-- you must ensure that the input functions constitute a legal lens:
+--
+-- * @sa (sbt s a) ≡ a@
+--
+-- * @sbt s (sa s) ≡ s@
+--
+-- * @sbt (sbt s a1) a2 ≡ sbt s a2@
+--
+-- See 'Data.Profunctor.Optic.Property'.
+--
+-- The resulting optic can detect copies of the lens stucture inside
+-- any 'Traversable' container. For example:
+--
+-- >>> lists (traversing snd $ \(s,_) b -> (s,b)) [(0,'f'),(1,'o'),(2,'o'),(3,'b'),(4,'a'),(5,'r')]
+-- "foobar"
+--
+traversing :: Traversable f => (s -> a) -> (s -> b -> t) -> Traversal (f s) (f t) a b
+traversing sa sbt = repn traverse . lens sa sbt
+
+-- | Obtain a 'Ixtraversal' by lifting an indexed lens getter and setter into a 'Traversable' functor.
+--
+-- @
+-- 'withIxlens' o 'ixtraversing' ≡ 'ixtraversed' . o
+-- @
+--
+-- /Caution/: In order for the generated optic to be well-defined,
+-- you must ensure that the input functions constitute a legal
+-- indexed lens:
+--
+-- * @snd . sia (sbt s a) ≡ a@
+--
+-- * @sbt s (snd $ sia s) ≡ s@
--
-traversal :: Traversable f => (s -> f a) -> (s -> f b -> t) -> Traversal s t a b
-traversal sa sbt = dimap dup (uncurry sbt) . psecond . lmap sa . lift traverse
+-- * @sbt (sbt s a1) a2 ≡ sbt s a2@
+--
+-- See 'Data.Profunctor.Optic.Property'.
+--
+ixtraversing :: Monoid i => Traversable f => (s -> (i , a)) -> (s -> b -> t) -> Ixtraversal i (f s) (f t) a b
+ixtraversing sia sbt = repn (\iab -> traverse (curry iab mempty) . snd) . ixlens sia sbt
--- | Transform a Van Laarhoven 'Traversal' into a profunctor 'Traversal'.
+-- | Obtain a profunctor 'Traversal' from a Van Laarhoven 'Traversal'.
+--
+-- /Caution/: In order for the generated optic to be well-defined,
+-- you must ensure that the input satisfies the following properties:
+--
+-- * @abst pure ≡ pure@
--
-traversalVL :: (forall f. Applicative f => (a -> f b) -> s -> f t) -> Traversal s t a b
-traversalVL = lift
+-- * @fmap (abst f) . abst g ≡ getCompose . abst (Compose . fmap f . g)@
+--
+-- See 'Data.Profunctor.Optic.Property'.
+--
+traversalVl :: (forall f. Applicative f => (a -> f b) -> s -> f t) -> Traversal s t a b
+traversalVl abst = tabulate . abst . sieve
--- | TODO: Document
+-- | Lift an indexed VL traversal into an indexed profunctor traversal.
--
-traversed :: Traversable f => Traversal (f a) (f b) a b
-traversed = lift traverse
+-- /Caution/: In order for the generated optic to be well-defined,
+-- you must ensure that the input satisfies the following properties:
+--
+-- * @iabst (const pure) ≡ pure@
+--
+-- * @fmap (iabst $ const f) . (iabst $ const g) ≡ getCompose . iabst (const $ Compose . fmap f . g)@
+--
+-- See 'Data.Profunctor.Optic.Property'.
+--
+ixtraversalVl :: (forall f. Applicative f => (i -> a -> f b) -> s -> f t) -> Ixtraversal i s t a b
+ixtraversalVl f = traversalVl $ \iab -> f (curry iab) . snd
+
+-- | Lift a VL traversal into an indexed profunctor traversal that ignores its input.
+--
+-- Useful as the first optic in a chain when no indexed equivalent is at hand.
+--
+-- >>> ixlists (noix traversed . ixtraversed) ["foo", "bar"]
+-- [(0,'f'),(1,'o'),(2,'o'),(0,'b'),(1,'a'),(2,'r')]
+--
+-- >>> ixlists (ixtraversed . noix traversed) ["foo", "bar"]
+-- [(0,'f'),(0,'o'),(0,'o'),(0,'b'),(0,'a'),(0,'r')]
+--
+noix :: Monoid i => Traversal s t a b -> Ixtraversal i s t a b
+noix o = ixtraversalVl $ \iab s -> flip runStar s . o . Star $ iab mempty
+
+-- | Index a traversal with a 'Data.Semiring'.
+--
+-- >>> ixlists (ix traversed . ix traversed) ["foo", "bar"]
+-- [((),'f'),((),'o'),((),'o'),((),'b'),((),'a'),((),'r')]
+--
+-- >>> ixlists (ix @Int traversed . ix traversed) ["foo", "bar"]
+-- [(0,'f'),(1,'o'),(2,'o'),(0,'b'),(1,'a'),(2,'r')]
+--
+-- >>> ixlists (ix @[()] traversed . ix traversed) ["foo", "bar"]
+-- [([],'f'),([()],'o'),([(),()],'o'),([],'b'),([()],'a'),([(),()],'r')]
+--
+-- >>> ixlists (ix @[()] traversed % ix traversed) ["foo", "bar"]
+-- [([],'f'),([()],'o'),([(),()],'o'),([()],'b'),([(),()],'a'),([(),(),()],'r')]
+--
+ix :: Monoid i => Semiring i => Traversal s t a b -> Ixtraversal i s t a b
+ix o = ixtraversalVl $ \f s ->
+ flip evalState mempty . getCompose . flip runStar s . o . Star $ \a ->
+ Compose $ (f <$> get <*> pure a) <* modify (<> sunit)
---------------------------------------------------------------------
--- Primitive Operators
+-- Primitive operators
---------------------------------------------------------------------
--- ^ @
--- traverseOf :: Functor f => Lens s t a b -> (a -> f b) -> s -> f t
--- traverseOf :: Applicative f => Traversal s t a b -> (a -> f b) -> s -> f t
+-- |
+--
+-- The traversal laws can be stated in terms of 'withTraversal':
+--
+-- Identity:
+--
+-- @
+-- withTraversal t (Identity . f) ≡ Identity (fmap f)
+-- @
+--
+-- Composition:
+--
+-- @
+-- Compose . fmap (withTraversal t f) . withTraversal t g ≡ withTraversal t (Compose . fmap f . g)
-- @
--
-traverseOf :: Applicative f => ATraversal f s t a b -> (a -> f b) -> s -> f t
-traverseOf = between runStar Star
-
--- | TODO: Document
+-- @
+-- withTraversal :: Functor f => Lens s t a b -> (a -> f b) -> s -> f t
+-- withTraversal :: Applicative f => Traversal s t a b -> (a -> f b) -> s -> f t
+-- @
--
-sequenceOf :: Applicative f => ATraversal f s t (f a) a -> s -> f t
-sequenceOf t = traverseOf t id
+withTraversal :: Applicative f => ATraversal f s t a b -> (a -> f b) -> s -> f t
+withTraversal o = runStar #. o .# Star
---------------------------------------------------------------------
--- Common 'Traversal's
+-- Common 'Traversal0's, 'Traversal's, 'Traversal1's, & 'Cotraversal1's
---------------------------------------------------------------------
--- | Traverse bitraversed parts of a 'Bitraversable' container with matching types.
+-- | TODO: Document
--
--- >>> traverseOf bitraversed (pure . length) (Right "hello")
+traversed :: Traversable f => Traversal (f a) (f b) a b
+traversed = traversalVl traverse
+
+-- | TODO: Document
+--
+-- >>> withTraversal both (pure . length) ("hello","world")
+-- (5,5)
+--
+both :: Traversal (a , a) (b , b) a b
+both p = p **** p
+
+-- | Duplicate the results of any 'Fold'.
+--
+-- >>> lists (both . duplicated) ("hello","world")
+-- ["hello","hello","world","world"]
+--
+duplicated :: Traversal a b a b
+duplicated p = pappend p p
+
+-- | Traverse both parts of a 'Bitraversable' container with matching types.
+--
+-- >>> withTraversal bitraversed (pure . length) (Right "hello")
-- Right 5
--
--- >>> traverseOf bitraversed (pure . length) ("hello","world")
+-- >>> withTraversal bitraversed (pure . length) ("hello","world")
-- (5,5)
--
-- >>> ("hello","world") ^. bitraversed
@@ -61,5 +246,15 @@ sequenceOf t = traverseOf t id
-- @
--
bitraversed :: Bitraversable f => Traversal (f a a) (f b b) a b
-bitraversed = lift $ \f -> bitraverse f f
+bitraversed = repn $ \f -> bitraverse f f
{-# INLINE bitraversed #-}
+
+---------------------------------------------------------------------
+-- Operators
+---------------------------------------------------------------------
+
+-- | TODO: Document
+--
+sequences :: Applicative f => ATraversal f s t (f a) a -> s -> f t
+sequences o = withTraversal o id
+{-# INLINE sequences #-}
diff --git a/src/Data/Profunctor/Optic/Traversal0.hs b/src/Data/Profunctor/Optic/Traversal0.hs
index 0b5a733..ec22afd 100644
--- a/src/Data/Profunctor/Optic/Traversal0.hs
+++ b/src/Data/Profunctor/Optic/Traversal0.hs
@@ -1,93 +1,128 @@
-{-# LANGUAGE TupleSections #-}
-module Data.Profunctor.Optic.Traversal0 where
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+module Data.Profunctor.Optic.Traversal0 (
+ -- * Traversal0 & Ixtraversal0
+ Traversal0
+ , Traversal0'
+ , Ixtraversal0
+ , Ixtraversal0'
+ , ATraversal0
+ , ATraversal0'
+ , traversal0
+ , traversal0'
+ , ixtraversal0
+ , ixtraversal0'
+ , traversal0Vl
+ , ixtraversal0Vl
+ -- * Carriers
+ , Traversal0Rep(..)
+ -- * Primitive operators
+ , withTraversal0
+ -- * Optics
+ , nulled
+ , inserted
+ , selected
+ , predicated
+ -- * Operators
+ , is
+ , isnt
+ , matches
+) where
+import Data.Bifunctor (first, second)
+import Data.Bitraversable
+import Data.List.Index
+import Data.Map as Map
+import Data.Semigroup.Bitraversable
+import Data.Profunctor.Optic.Lens hiding (first, second, unit)
+import Data.Profunctor.Optic.Import
+import Data.Profunctor.Optic.Prism (prism)
+import Data.Profunctor.Optic.Grate
import Data.Profunctor.Optic.Type
-import Data.Profunctor.Optic.Prelude
+import Data.Semiring
+import Control.Monad.Trans.State
+import Data.Profunctor.Optic.Iso
+import qualified Data.Bifunctor as B
+
+-- $setup
+-- >>> :set -XNoOverloadedStrings
+-- >>> :set -XFlexibleContexts
+-- >>> :set -XTypeApplications
+-- >>> :set -XTupleSections
+-- >>> :set -XRankNTypes
+-- >>> import Data.Maybe
+-- >>> import Data.List.NonEmpty (NonEmpty(..))
+-- >>> import qualified Data.List.NonEmpty as NE
+-- >>> import Data.Functor.Identity
+-- >>> import Data.List.Index
+-- >>> :load Data.Profunctor.Optic
+-- >>> let catchOn :: Int -> Cxprism' Int (Maybe String) String ; catchOn n = cxjust $ \k -> if k==n then Just "caught" else Nothing
+-- >>> let ixtraversed :: Ixtraversal Int [a] [b] a b ; ixtraversed = ixtraversalVl itraverse
---------------------------------------------------------------------
--- 'Traversal0'
+-- 'Traversal0' & 'Ixtraversal0'
---------------------------------------------------------------------
--- | Create a 'Traversal0' from a constructor and a matcher.
---
--- \( \quad \mathsf{Traversal0}\;S\;A =\exists C, D, S \cong D + C \times A \)
+type ATraversal0 s t a b = Optic (Traversal0Rep a b) s t a b
+
+type ATraversal0' s a = ATraversal0 s s a a
+
+-- | Create a 'Traversal0' from a constructor and a matcheser.
--
-- /Caution/: In order for the 'Traversal0' to be well-defined,
--- you must ensure that the three affine traversal laws hold:
+-- you must ensure that the input functions satisfy the following
+-- properties:
+--
+-- * @sta (sbt a s) ≡ either (Left . const a) Right (sta s)@
+--
+-- * @either id (sbt s) (sta s) ≡ s@
--
--- * @sta (sbt (a, s)) ≡ either (Left . const a) Right (sta s)@
+-- * @sbt (sbt s a1) a2 ≡ sbt s a2@
--
--- * @either (\a -> sbt (a, s)) id (sta s) ≡ s@
+-- More generally, a profunctor optic must be monoidal as a natural
+-- transformation:
+--
+-- * @o id ≡ id@
--
--- * @sbt (a2, (sbt (a1, s))) ≡ sbt (a2, s)@
+-- * @o ('Data.Profunctor.Composition.Procompose' p q) ≡ 'Data.Profunctor.Composition.Procompose' (o p) (o q)@
--
-- See 'Data.Profunctor.Optic.Property'.
--
traversal0 :: (s -> t + a) -> (s -> b -> t) -> Traversal0 s t a b
-traversal0 sta sbt = dimap f g . pright . pfirst
- where f s = (,s) <$> sta s
- g = id ||| (uncurry . flip $ sbt)
+traversal0 sta sbt = dimap (\s -> (s,) <$> sta s) (id ||| uncurry sbt) . right' . second'
--- | Create a 'Traversal0'' from a constructor and a matcher function.
+-- | Obtain a 'Traversal0'' from a constructor and a matcheser function.
--
traversal0' :: (s -> Maybe a) -> (s -> a -> s) -> Traversal0' s a
traversal0' sa sas = flip traversal0 sas $ \s -> maybe (Left s) Right (sa s)
--- | Transform a Van Laarhoven 'Traversal0' into a profunctor 'Traversal0'.
+-- | TODO: Document
--
-traversal0VL :: (forall f. Functor f => (forall r. r -> f r) -> (a -> f b) -> s -> f t) -> Traversal0 s t a b
-traversal0VL f = dimap (\s -> (match s, s)) (\(ebt, s) -> either (update s) id ebt) . pfirst . pleft
- where
- match s = f Right Left s
- update s b = runIdentity $ f Identity (\_ -> Identity b) s
-
----------------------------------------------------------------------
--- 'Traversal0Rep'
----------------------------------------------------------------------
+ixtraversal0 :: (s -> t + (i , a)) -> (s -> b -> t) -> Ixtraversal0 i s t a b
+ixtraversal0 stia sbt = ixtraversal0Vl $ \point f s -> either point (fmap (sbt s) . uncurry f) (stia s)
--- | The `Traversal0Rep` profunctor precisely characterizes an 'Traversal0'.
-data Traversal0Rep a b s t = Traversal0Rep (s -> t + a) (s -> b -> t)
-
-type ATraversal0 s t a b = Optic (Traversal0Rep a b) s t a b
-
-type ATraversal0' s a = ATraversal0 s s a a
-
-type ARetraversal0 s t a b = Optic (Re (Traversal0Rep t s) a b) s t a b
-
-instance Profunctor (Traversal0Rep u v) where
- dimap f g (Traversal0Rep getter setter) = Traversal0Rep
- (\a -> first g $ getter (f a))
- (\a v -> g (setter (f a) v))
-
-instance Strong (Traversal0Rep u v) where
- first' (Traversal0Rep getter setter) = Traversal0Rep
- (\(a, c) -> first (,c) $ getter a)
- (\(a, c) v -> (setter a v, c))
-
-instance Choice (Traversal0Rep u v) where
- right' (Traversal0Rep getter setter) = Traversal0Rep
- (\eca -> assocl' (second getter eca))
- (\eca v -> second (`setter` v) eca)
-
-instance Sieve (Traversal0Rep a b) (PStore0 a b) where
- sieve (Traversal0Rep sta sbt) s = PStore0 (sbt s) (sta s)
-
-instance Representable (Traversal0Rep a b) where
- type Rep (Traversal0Rep a b) = PStore0 a b
-
- tabulate f = Traversal0Rep (\s -> info0 (f s)) (\s -> values0 (f s))
-
-data PStore0 a b t = PStore0 (b -> t) (t + a)
-
-values0 :: PStore0 a b t -> b -> t
-values0 (PStore0 bt _) = bt
+-- | TODO: Document
+--
+ixtraversal0' :: (s -> Maybe (i , a)) -> (s -> a -> s) -> Ixtraversal0' i s a
+ixtraversal0' sia = ixtraversal0 $ \s -> maybe (Left s) Right (sia s)
-info0 :: PStore0 a b t -> t + a
-info0 (PStore0 _ a) = a
+-- | Transform a Van Laarhoven 'Traversal0' into a profunctor 'Traversal0'.
+--
+traversal0Vl :: (forall f. Functor f => (forall c. c -> f c) -> (a -> f b) -> s -> f t) -> Traversal0 s t a b
+traversal0Vl f = dimap (\s -> (s,) <$> eswap (sat s)) (id ||| uncurry sbt) . right' . second'
+ where
+ sat = f Right Left
+ sbt s b = runIdentity $ f Identity (\_ -> Identity b) s
-instance Functor (PStore0 a b) where
- fmap f (PStore0 bt ta) = PStore0 (f . bt) (first f ta)
- {-# INLINE fmap #-}
+-- | Transform an indexed Van Laarhoven 'Traversal0' into an indexed profunctor 'Traversal0'.
+--
+ixtraversal0Vl :: (forall f. Functor f => (forall c. c -> f c) -> (i -> a -> f b) -> s -> f t) -> Ixtraversal0 i s t a b
+ixtraversal0Vl f = traversal0Vl $ \cc iab -> f cc (curry iab) . snd
---------------------------------------------------------------------
-- Primitive operators
@@ -96,68 +131,136 @@ instance Functor (PStore0 a b) where
-- | TODO: Document
--
withTraversal0 :: ATraversal0 s t a b -> ((s -> t + a) -> (s -> b -> t) -> r) -> r
-withTraversal0 o f = case o (Traversal0Rep Right $ const id) of Traversal0Rep x y -> f x y
+withTraversal0 o k = case o (Traversal0Rep Right $ const id) of Traversal0Rep x y -> k x y
--- | Retrieve the value targeted by a 'Traversal0' or return the original.
---
+---------------------------------------------------------------------
+-- Common 'Traversal0's, 'Traversal's, 'Traversal1's, & 'Cotraversal1's
+---------------------------------------------------------------------
+
+-- | TODO: Document
--
--- Allows the type to change if the optic does not match.
+nulled :: Traversal0' s a
+nulled = traversal0 Left const
+{-# INLINE nulled #-}
+
+-- | Obtain a 'Ixtraversal0'' from a pair of lookup and insert functions.
--
-- @
--- 'preview' o ≡ 'either' ('const' 'Nothing') 'id' . 'matchOf' o
+-- inserted (\i s -> flip 'Data.List.Index.ifind' s $ \n _ -> n == i) (\i a s -> 'Data.List.Index.modifyAt' i (const a) s) :: Int -> Ixtraversal0' Int [a] a
+-- inserted 'Data.Map.lookupGT' 'Data.Map.insert' :: Ord i => i -> Ixtraversal0' i (Map i a) a
+-- inserted 'Data.IntMap.lookupGT' 'Data.IntMap.insert' :: Int -> Ixtraversal0' Int (IntMap a) a
-- @
--
-matchOf :: ATraversal0 s t a b -> s -> t + a
-matchOf o = withTraversal0 o $ \match _ -> match
+inserted :: (i -> s -> Maybe (i, a)) -> (i -> a -> s -> s) -> i -> Ixtraversal0' i s a
+inserted isia iasa i = ixtraversal0Vl $ \point f s ->
+ case isia i s of
+ Nothing -> point s
+ Just (i', a) -> f i' a <&> \a -> iasa i' a s
+{-# INLINE inserted #-}
--- | Reverse match on a 'Reprism' or similar.
+-- | TODO: Document
+--
+-- See also 'Data.Profunctor.Optic.Prism.keyed'.
--
--- * @rematching . re $ prism _ sa ≡ sa@
+-- >>> preview (selected even) (2, "hi")
+-- Just "hi"
+-- >>> preview (selected even) (3, "hi")
+-- Nothing
--
-rematchOf :: ARetraversal0 s t a b -> b -> a + t
-rematchOf o = matchOf (re o)
+selected :: (a -> Bool) -> Traversal0' (a, b) b
+selected p = traversal0 (\kv@(k,v) -> branch p kv v k) (\kv@(k,_) v' -> if p k then (k,v') else kv)
+{-# INLINE selected #-}
--- | Test whether the optic matches or not.
+-- | Filter result(s) that don't satisfy a predicate.
--
--- >>> isMatched _Just Nothing
--- False
+-- /Caution/: While this is a valid 'Traversal0', it is only a valid 'Traversal'
+-- if the predicate always evaluates to 'True' on the targets of the 'Traversal'.
--
-isMatched :: ATraversal0 s t a b -> s -> Bool
-isMatched o = either (const False) (const True) . matchOf o
-
--- | Test whether the optic matches or not.
+-- @
+-- 'predicated' p ≡ 'traversal0Vl' $ \point f a -> if p a then f a else point a
+-- @
--
--- >>> isntMatched _Just Nothing
--- True
+-- >>> [1..10] ^.. folded . predicated even
+-- [2,4,6,8,10]
+--
+-- See also 'Data.Profunctor.Optic.Prism.filtered'.
--
-isntMatched :: ATraversal0 s t a b -> s -> Bool
-isntMatched o = either (const True) (const False) . matchOf o
+predicated :: (a -> Bool) -> Traversal0' a a
+predicated p = traversal0 (branch' p) (flip const)
+{-# INLINE predicated #-}
---------------------------------------------------------------------
--- Common affine traversals
+-- Operators
---------------------------------------------------------------------
--- | TODO: Document
+-- | Check whether the optic is matchesed.
--
-nulled :: Traversal0' s a
-nulled = traversal0 Left const
+-- >>> is just Nothing
+-- False
+--
+is :: ATraversal0 s t a b -> s -> Bool
+is o = either (const False) (const True) . matches o
+{-# INLINE is #-}
--- | Filter result(s) that don't satisfy a predicate.
+-- | Check whether the optic isn't matchesed.
--
--- /Caution/: While this is a valid 'Traversal0', it is only a valid 'Traversal'
--- if the predicate always evaluates to 'True' on the targets of the 'Traversal'.
+-- >>> isnt just Nothing
+-- True
--
--- @
--- 'filtered0' p ≡ 'vltraversal0' $ \point f a -> if p a then f a else point a
--- @
+isnt :: ATraversal0 s t a b -> s -> Bool
+isnt o = either (const True) (const False) . matches o
+{-# INLINE isnt #-}
+
+-- | Test whether the optic matches or not.
--
--- >>> [1..10] ^.. fold id . filtered0 even
--- [2,4,6,8,10]
+-- >>> matches just (Just 2)
+-- Right 2
--
-filtered0 :: (a -> Bool) -> Traversal0' a a
-filtered0 p = traversal0 (branch' p) (flip const)
-
--- | TODO: Document
+-- >>> matches just (Nothing :: Maybe Int) :: Either (Maybe Bool) Int
+-- Left Nothing
--
-selected0 :: (a -> Bool) -> Traversal0' (a, b) b
-selected0 p = traversal0 (\kv@(k,v) -> branch p kv v k) (\kv@(k,_) v' -> if p k then (k,v') else kv)
+matches :: ATraversal0 s t a b -> s -> t + a
+matches o = withTraversal0 o $ \sta _ -> sta
+{-# INLINE matches #-}
+
+---------------------------------------------------------------------
+-- 'Traversal0Rep'
+---------------------------------------------------------------------
+
+-- | The `Traversal0Rep` profunctor precisely characterizes an 'Traversal0'.
+data Traversal0Rep a b s t = Traversal0Rep (s -> t + a) (s -> b -> t)
+
+instance Profunctor (Traversal0Rep u v) where
+ dimap f g (Traversal0Rep getter setter) = Traversal0Rep
+ (\a -> first g $ getter (f a))
+ (\a v -> g (setter (f a) v))
+
+instance Strong (Traversal0Rep u v) where
+ first' (Traversal0Rep getter setter) = Traversal0Rep
+ (\(a, c) -> first (,c) $ getter a)
+ (\(a, c) v -> (setter a v, c))
+
+instance Choice (Traversal0Rep u v) where
+ right' (Traversal0Rep getter setter) = Traversal0Rep
+ (\eca -> eassocl (second getter eca))
+ (\eca v -> second (`setter` v) eca)
+
+instance Sieve (Traversal0Rep a b) (Index0 a b) where
+ sieve (Traversal0Rep sta sbt) s = Index0 (sta s) (sbt s)
+
+instance Representable (Traversal0Rep a b) where
+ type Rep (Traversal0Rep a b) = Index0 a b
+
+ tabulate f = Traversal0Rep (info0 . f) (values0 . f)
+
+data Index0 a b r = Index0 (r + a) (b -> r)
+
+values0 :: Index0 a b r -> b -> r
+values0 (Index0 _ br) = br
+
+info0 :: Index0 a b r -> r + a
+info0 (Index0 a _) = a
+
+instance Functor (Index0 a b) where
+ fmap f (Index0 ra br) = Index0 (first f ra) (f . br)
+ {-# INLINE fmap #-}
diff --git a/src/Data/Profunctor/Optic/Traversal1.hs b/src/Data/Profunctor/Optic/Traversal1.hs
new file mode 100644
index 0000000..8405c4e
--- /dev/null
+++ b/src/Data/Profunctor/Optic/Traversal1.hs
@@ -0,0 +1,326 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+module Data.Profunctor.Optic.Traversal1 (
+ -- * Traversal1
+ Traversal1
+ , Traversal1'
+ , ATraversal1
+ , ATraversal1'
+ , traversal1
+ , traversal1Vl
+ -- * Cotraversal1 & Cxtraversal1
+ , Cotraversal1
+ , Cotraversal1'
+ , Cxtraversal1
+ , Cxtraversal1'
+ , ACotraversal1
+ , ACotraversal1'
+ , cotraversal1
+ , cotraversing1
+ , retraversing1
+ , cotraversal1Vl
+ , cxtraversal1Vl
+ , nocx1
+ -- * Optics
+ , traversed1
+ , cotraversed1
+ , both1
+ , bitraversed1
+ , repeated
+ , iterated
+ , cycled
+ -- * Primitive operators
+ , withTraversal1
+ , withCotraversal1
+ -- * Operators
+ , sequences1
+ , distributes1
+ -- * Carriers
+ , Star(..)
+ , Costar(..)
+ -- * Classes
+ , Representable(..)
+ , Corepresentable(..)
+) where
+
+import Data.Bifunctor (first, second)
+import Data.List.Index
+import Data.Map as Map
+import Data.Semigroup.Bitraversable
+import Data.Profunctor.Optic.Lens hiding (first, second, unit)
+import Data.Profunctor.Optic.Import
+import Data.Profunctor.Optic.Prism (prism)
+import Data.Profunctor.Optic.Grate
+import Data.Profunctor.Optic.Type
+import Data.Semiring
+import Control.Monad.Trans.State
+import Data.Profunctor.Optic.Iso
+import qualified Data.Bifunctor as B
+
+-- $setup
+-- >>> :set -XNoOverloadedStrings
+-- >>> :set -XFlexibleContexts
+-- >>> :set -XTypeApplications
+-- >>> :set -XTupleSections
+-- >>> :set -XRankNTypes
+-- >>> import Data.Maybe
+-- >>> import Data.List.NonEmpty (NonEmpty(..))
+-- >>> import qualified Data.List.NonEmpty as NE
+-- >>> import Data.Functor.Identity
+-- >>> import Data.List.Index
+-- >>> :load Data.Profunctor.Optic
+-- >>> let catchOn :: Int -> Cxprism' Int (Maybe String) String ; catchOn n = cxjust $ \k -> if k==n then Just "caught" else Nothing
+-- >>> let ixtraversed :: Ixtraversal Int [a] [b] a b ; ixtraversed = ixtraversalVl itraverse
+
+---------------------------------------------------------------------
+-- 'Traversal1'
+---------------------------------------------------------------------
+
+type ATraversal1 f s t a b = Apply f => ARepn f s t a b
+
+type ATraversal1' f s a = ATraversal1 f s s a a
+
+-- | Obtain a 'Traversal1' optic from a getter and setter.
+--
+-- \( \mathsf{Traversal1}\;S\;A = \exists F : \mathsf{Traversable1}, S \equiv F\,A \)
+--
+traversal1 :: Traversable1 f => (s -> f a) -> (s -> f b -> t) -> Traversal1 s t a b
+traversal1 sa sbt = lens sa sbt . repn traverse1
+
+-- | Obtain a 'Traversal' by lifting a lens getter and setter into a 'Traversable' functor.
+--
+-- @
+-- 'withLens' o 'traversing' ≡ 'traversed' . o
+-- @
+--
+-- /Caution/: In order for the generated optic to be well-defined,
+-- you must ensure that the input functions constitute a legal lens:
+--
+-- * @sa (sbt s a) ≡ a@
+--
+-- * @sbt s (sa s) ≡ s@
+--
+-- * @sbt (sbt s a1) a2 ≡ sbt s a2@
+--
+-- See 'Data.Profunctor.Optic.Property'.
+--
+-- The resulting optic can detect copies of the lens stucture inside
+-- any 'Traversable' container. For example:
+--
+-- >>> lists (traversing snd $ \(s,_) b -> (s,b)) [(0,'f'),(1,'o'),(2,'o'),(3,'b'),(4,'a'),(5,'r')]
+-- "foobar"
+--
+-- Compare 'Data.Profunctor.Optic.Fold.folding'.
+--
+traversing1 :: Traversable1 f => (s -> a) -> (s -> b -> t) -> Traversal1 (f s) (f t) a b
+traversing1 sa sbt = repn traverse1 . lens sa sbt
+
+-- | Obtain a profunctor 'Traversal1' from a Van Laarhoven 'Traversal1'.
+--
+-- /Caution/: In order for the generated family to be well-defined,
+-- you must ensure that the traversal1 law holds for the input function:
+--
+-- * @fmap (abst f) . abst g ≡ getCompose . abst (Compose . fmap f . g)@
+--
+-- See 'Data.Profunctor.Optic.Property'.
+--
+traversal1Vl :: (forall f. Apply f => (a -> f b) -> s -> f t) -> Traversal1 s t a b
+traversal1Vl abst = tabulate . abst . sieve
+
+---------------------------------------------------------------------
+-- 'Cotraversal1' & 'Cxtraversal11'
+---------------------------------------------------------------------
+
+type ACotraversal1 f s t a b = Apply f => ACorepn f s t a b
+
+type ACotraversal1' f s a = ACotraversal1 f s s a a
+
+-- | Obtain a 'Cotraversal1' directly.
+--
+cotraversal1 :: Distributive g => (g b -> s -> g a) -> (g b -> t) -> Cotraversal1 s t a b
+cotraversal1 bsa bt = colens bsa bt . corepn cotraverse
+
+-- | Obtain a 'Cotraversal1' by embedding a reversed lens getter and setter into a 'Distributive' functor.
+--
+-- @
+-- 'withColens' o 'cotraversing' ≡ 'cotraversed' . o
+-- @
+--
+cotraversing1 :: Distributive g => (b -> s -> a) -> (b -> t) -> Cotraversal1 (g s) (g t) a b
+cotraversing1 bsa bt = corepn cotraverse . colens bsa bt
+
+-- | Obtain a 'Cotraversal1' by embedding a grate continuation into a 'Distributive' functor.
+--
+-- @
+-- 'withGrate' o 'retraversing' ≡ 'cotraversed' . o
+-- @
+--
+retraversing1 :: Distributive g => (((s -> a) -> b) -> t) -> Cotraversal1 (g s) (g t) a b
+retraversing1 sabt = corepn cotraverse . grate sabt
+
+-- | Obtain a profunctor 'Cotraversal1' from a Van Laarhoven 'Cotraversal1'.
+--
+-- /Caution/: In order for the generated optic to be well-defined,
+-- you must ensure that the input satisfies the following properties:
+--
+-- * @abst f . fmap (abst g) ≡ abst (f . fmap g . getCompose) . Compose@
+--
+-- See 'Data.Profunctor.Optic.Property'.
+--
+cotraversal1Vl :: (forall f. Apply f => (f a -> b) -> f s -> t) -> Cotraversal1 s t a b
+cotraversal1Vl abst = cotabulate . abst . cosieve
+
+-- | Lift an indexed VL cotraversal into a (co-)indexed profunctor cotraversal.
+--
+-- /Caution/: In order for the generated optic to be well-defined,
+-- you must ensure that the input satisfies the following properties:
+--
+-- * @kabst (const extract) ≡ extract@
+--
+-- * @kabst (const f) . fmap (kabst $ const g) ≡ kabst ((const f) . fmap (const g) . getCompose) . Compose@
+--
+-- See 'Data.Profunctor.Optic.Property'.
+--
+cxtraversal1Vl :: (forall f. Apply f => (k -> f a -> b) -> f s -> t) -> Cxtraversal1 k s t a b
+cxtraversal1Vl kabst = cotraversal1Vl $ \kab -> const . kabst (flip kab)
+
+-- | Lift a VL cotraversal into an (co-)indexed profunctor cotraversal that ignores its input.
+--
+-- Useful as the first optic in a chain when no indexed equivalent is at hand.
+--
+nocx1 :: Monoid k => Cotraversal1 s t a b -> Cxtraversal1 k s t a b
+nocx1 o = cxtraversal1Vl $ \kab s -> flip runCostar s . o . Costar $ kab mempty
+
+---------------------------------------------------------------------
+-- Primitive operators
+---------------------------------------------------------------------
+
+-- |
+--
+-- The traversal laws can be stated in terms or 'withTraversal1':
+--
+-- Identity:
+--
+-- @
+-- withTraversal1 t (Identity . f) ≡ Identity (fmap f)
+-- @
+--
+-- Composition:
+--
+-- @
+-- Compose . fmap (withTraversal1 t f) . withTraversal1 t g ≡ withTraversal1 t (Compose . fmap f . g)
+-- @
+--
+-- @
+-- withTraversal1 :: Functor f => Lens s t a b -> (a -> f b) -> s -> f t
+-- withTraversal1 :: Apply f => Traversal1 s t a b -> (a -> f b) -> s -> f t
+-- @
+--
+withTraversal1 :: Apply f => ATraversal1 f s t a b -> (a -> f b) -> s -> f t
+withTraversal1 o = runStar #. o .# Star
+
+-- | TODO: Document
+--
+-- @
+-- 'withCotraversal1' $ 'Data.Profuncto.Optic.Grate.grate' (flip 'Data.Distributive.cotraverse' id) ≡ 'Data.Distributive.cotraverse'
+-- @
+--
+withCotraversal1 :: Functor f => Optic (Costar f) s t a b -> (f a -> b) -> (f s -> t)
+withCotraversal1 o = runCostar #. o .# Costar
+
+---------------------------------------------------------------------
+-- Optics
+---------------------------------------------------------------------
+
+
+-- | Obtain a 'Traversal1' from a 'Traversable1' functor.
+--
+traversed1 :: Traversable1 t => Traversal1 (t a) (t b) a b
+traversed1 = traversal1Vl traverse1
+
+-- | TODO: Document
+--
+cotraversed1 :: Distributive f => Cotraversal1 (f a) (f b) a b
+cotraversed1 = cotraversal1Vl cotraverse
+
+-- | TODO: Document
+--
+-- >>> withTraversal1 both1 (pure . NE.length) ('h' :| "ello", 'w' :| "orld")
+-- (5,5)
+--
+both1 :: Traversal1 (a , a) (b , b) a b
+both1 p = tabulate $ \s -> liftF2 ($) (flip sieve s $ dimap fst (,) p) (flip sieve s $ lmap snd p)
+
+-- | Traverse both parts of a 'Bitraversable1' container with matching types.
+--
+-- >>> withTraversal1 bitraversed1 (pure . NE.length) ('h' :| "ello", 'w' :| "orld")
+-- (5,5)
+--
+bitraversed1 :: Bitraversable1 r => Traversal1 (r a a) (r b b) a b
+bitraversed1 = repn $ \f -> bitraverse1 f f
+{-# INLINE bitraversed1 #-}
+
+-- | Obtain a 'Traversal1'' by repeating the input forever.
+--
+-- @
+-- 'repeat' ≡ 'lists' 'repeated'
+-- @
+--
+-- >>> take 5 $ 5 ^.. repeated
+-- [5,5,5,5,5]
+--
+-- @
+-- repeated :: Fold1 a a
+-- @
+--
+repeated :: Traversal1' a a
+repeated = repn $ \g a -> go g a where go g a = g a .> go g a
+{-# INLINE repeated #-}
+
+-- | @x '^.' 'iterated' f@ returns an infinite 'Traversal1'' of repeated applications of @f@ to @x@.
+--
+-- @
+-- 'lists' ('iterated' f) a ≡ 'iterate' f a
+-- @
+--
+-- >>> take 3 $ (1 :: Int) ^.. iterated (+1)
+-- [1,2,3]
+--
+-- @
+-- iterated :: (a -> a) -> 'Fold1' a a
+-- @
+iterated :: (a -> a) -> Traversal1' a a
+iterated f = repn $ \g a0 -> go g a0 where go g a = g a .> go g (f a)
+{-# INLINE iterated #-}
+
+-- | Transform a 'Traversal1'' into a 'Traversal1'' that loops repn its elements repeatedly.
+--
+-- >>> take 7 $ (1 :| [2,3]) ^.. cycled traversed1
+-- [1,2,3,1,2,3,1]
+--
+-- @
+-- cycled :: 'Fold1' s a -> 'Fold1' s a
+-- @
+--
+cycled :: Apply f => ATraversal1' f s a -> ATraversal1' f s a
+cycled o = repn $ \g a -> go g a where go g a = (withTraversal1 o g) a .> go g a
+{-# INLINE cycled #-}
+
+---------------------------------------------------------------------
+-- Operators
+---------------------------------------------------------------------
+
+-- | TODO: Document
+--
+sequences1 :: Apply f => ATraversal1 f s t (f a) a -> s -> f t
+sequences1 o = withTraversal1 o id
+
+-- | TODO: Document
+--
+distributes1 :: Apply f => ACotraversal1 f s t a (f a) -> f s -> t
+distributes1 o = withCotraversal1 o id
diff --git a/src/Data/Profunctor/Optic/Type.hs b/src/Data/Profunctor/Optic/Type.hs
index 017c65d..08a5525 100644
--- a/src/Data/Profunctor/Optic/Type.hs
+++ b/src/Data/Profunctor/Optic/Type.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
@@ -8,63 +10,52 @@
module Data.Profunctor.Optic.Type (
-- * Optics
Optic, Optic', between
+ , IndexedOptic, IndexedOptic'
+ , CoindexedOptic, CoindexedOptic'
-- * Equality
, Equality, Equality', As
-- * Isos
, Iso, Iso'
+ -- * Lenses & Colenses
+ , Lens, Lens', Ixlens, Ixlens', Colens, Colens', Cxlens, Cxlens'
+ -- * Prisms & Coprisms
+ , Prism, Prism', Cxprism, Cxprism', Coprism, Coprism', Ixprism, Ixprism'
+ -- * Grates
+ , Grate, Grate', Cxgrate, Cxgrate'
+ -- * Traversals
+ , Traversal , Traversal' , Ixtraversal , Ixtraversal'
+ -- * Affine traversals & cotraversals
+ , Traversal0 , Traversal0' , Ixtraversal0, Ixtraversal0'
+ -- * Non-empty traversals & cotraversals
+ , Traversal1 , Traversal1'
+ , Cotraversal1 , Cotraversal1', Cxtraversal1, Cxtraversal1'
+ -- * Affine folds, general & non-empty folds, & cofolds
+ , Fold0, Ixfold0, Fold, Ixfold, Fold1, Cofold1
-- * Views & Reviews
- , View, AView, PrimView, PrimViewLike, Review, AReview, PrimReview, PrimReviewLike
+ , PrimView, View, Ixview, PrimReview, Review, Cxview
-- * Setters & Resetters
- , Setter, Setter', SetterLike, ASetter , Resetter, Resetter', ResetterLike, AResetter
- -- * Lenses & Relenses
- , Lens, Lens', LensLike, LensLike', Relens, Relens', RelensLike, RelensLike'
- -- * Prisms & Reprisms
- , Prism, Prism', PrismLike, PrismLike', Reprism, Reprism', ReprismLike, ReprismLike'
- -- * Grates
- , Grate, Grate', GrateLike, GrateLike'
- -- * Grids
- , Grid, Grid', GridLike, GridLike'
- -- * Affine traversals and retraversals
- , Affine, Traversal0, Traversal0', Traversal0Like, Traversal0Like', Retraversal0, Retraversal0', Retraversal0Like, Retraversal0Like'
- -- * Non-empty traversals
- , Traversal1, Traversal1', Traversal1Like, Traversal1Like'
- -- * General traversals
- , Traversal, Traversal', TraversalLike, TraversalLike', ATraversal, ATraversal'
- -- * Affine cotraversals
- , Coaffine, Cotraversal0, Cotraversal0', Cotraversal0Like, Cotraversal0Like'
- -- * Cotraversals
- , Cotraversal, Cotraversal', CotraversalLike, CotraversalLike'
- -- * Affine folds
- , Fold0, Fold0Like
- -- * Non-empty folds
- , Fold1, Fold1Like, AFold1
- -- * General folds
- , Fold, FoldLike, FoldRep, AFold, Handler, HandlerM
- -- * Co-affine Cofolds (a.k.a. Glasses)
- , Cofold0, Cofold0Like
- -- * Cofolds
- , Cofold, CofoldRep, ACofold
- -- * Repns
- , Repn, Repn', RepnLike, RepnLike', ARepn
- -- * Corepns
- , Corepn, Corepn', CorepnLike, CorepnLike', ACorepn
+ , Setter, Setter', Ixsetter, Resetter, Resetter', Cxsetter
+ -- * Common represenable and corepresentable carriers
+ , ARepn, ARepn', AIxrepn, AIxrepn', ACorepn, ACorepn', ACxrepn, ACxrepn'
-- * 'Re'
, Re(..), re
, module Export
) where
-import Control.Foldl (EndoM)
+import Data.Bifunctor (Bifunctor(..))
import Data.Functor.Apply (Apply(..))
-import Data.Monoid (Endo)
-import Data.Profunctor.Optic.Prelude
+import Data.Profunctor.Optic.Import
import Data.Profunctor.Types as Export
-import Data.Profunctor.Orphan as Export ()
import Data.Profunctor.Strong as Export (Strong(..), Costrong(..))
import Data.Profunctor.Choice as Export (Choice(..), Cochoice(..))
import Data.Profunctor.Closed as Export (Closed(..))
import Data.Profunctor.Sieve as Export (Sieve(..), Cosieve(..))
import Data.Profunctor.Rep as Export (Representable(..), Corepresentable(..))
+-- $setup
+-- >>> :set -XNoOverloadedStrings
+-- >>> :load Data.Profunctor.Optic
+
---------------------------------------------------------------------
-- 'Optic'
---------------------------------------------------------------------
@@ -73,6 +64,14 @@ type Optic p s t a b = p a b -> p s t
type Optic' p s a = Optic p s s a a
+type IndexedOptic p i s t a b = p (i , a) b -> p (i , s) t
+
+type IndexedOptic' p i s a = IndexedOptic p i s s a a
+
+type CoindexedOptic p k s t a b = p a (k -> b) -> p s (k -> t)
+
+type CoindexedOptic' p k t b = CoindexedOptic p k t t b b
+
-- | Can be used to rewrite
--
-- > \g -> f . g . h
@@ -103,353 +102,234 @@ type As a = Equality' a a
--
-- \( \mathsf{Iso}\;S\;A = S \cong A \)
--
+-- For any valid 'Iso' /o/ we have:
+-- @
+-- o . re o ≡ id
+-- re o . o ≡ id
+-- view o (review o b) ≡ b
+-- review o (view o s) ≡ s
+-- @
+--
type Iso s t a b = forall p. Profunctor p => Optic p s t a b
type Iso' s a = Iso s s a a
---------------------------------------------------------------------
--- 'View'
+-- 'Lens' & 'Colens'
---------------------------------------------------------------------
--- | A 'View' extracts a result.
---
-type View s a = forall p. Strong p => PrimViewLike p s s a a
-
-type PrimView s t a b = forall p. PrimViewLike p s t a b
-
-type PrimViewLike p s t a b = Profunctor p => (forall x. Contravariant (p x)) => Optic p s t a b
-
-type AView s a = Optic' (FoldRep a) s a
-
----------------------------------------------------------------------
--- 'Review'
----------------------------------------------------------------------
-
--- | A 'Review' produces a result.
---
-type Review t b = forall p. Choice p => PrimReviewLike p t t b b
-
-type PrimReview s t a b = forall p. PrimReviewLike p s t a b
-
-type PrimReviewLike p s t a b = Profunctor p => Bifunctor p => Optic p s t a b
-
-type AReview t b = Optic' (CofoldRep b) t b
-
----------------------------------------------------------------------
--- 'Setter'
----------------------------------------------------------------------
-
--- | A 'Setter' modifies part of a structure.
---
--- \( \mathsf{Setter}\;S\;A = \exists F : \mathsf{Functor}, S \equiv F\,A \)
---
-type Setter s t a b = forall p. SetterLike p s t a b
-
-type Setter' s a = Setter s s a a
-
-type SetterLike p s t a b = Closed p => Distributive (Rep p) => TraversalLike p s t a b
-
-type ASetter s t a b = Optic (->) s t a b
-
----------------------------------------------------------------------
--- 'Resetter'
----------------------------------------------------------------------
-
-type Resetter s t a b = forall p. ResetterLike p s t a b
-
-type Resetter' s a = Resetter s s a a
-
-type ResetterLike p s t a b = Strong p => Traversable (Corep p) => Cotraversal1Like p s t a b
-
-type AResetter s t a b = Optic (->) s t a b
-
----------------------------------------------------------------------
--- 'Lens'
----------------------------------------------------------------------
-
--- | Lenses access one piece of a product structure.
+-- | Lenses access one piece of a product.
--
-- \( \mathsf{Lens}\;S\;A = \exists C, S \cong C \times A \)
--
-type Lens s t a b = forall p. LensLike p s t a b
+type Lens s t a b = forall p. Strong p => Optic p s t a b
type Lens' s a = Lens s s a a
-type LensLike p s t a b = Strong p => Optic p s t a b
+type Ixlens i s t a b = forall p. Strong p => IndexedOptic p i s t a b
-type LensLike' p s a = LensLike p s s a a
+type Ixlens' i s a = Ixlens i s s a a
-type Relens s t a b = forall p. RelensLike p s t a b
+type Colens s t a b = forall p. Costrong p => Optic p s t a b
-type Relens' s a = Relens s s a a
+type Colens' s a = Colens s s a a
-type RelensLike p s t a b = Costrong p => Optic p s t a b
+type Cxlens k s t a b = forall p. Costrong p => CoindexedOptic p k s t a b
-type RelensLike' p s a = RelensLike p s s a a
+type Cxlens' k s a = Cxlens k s s a a
---------------------------------------------------------------------
--- 'Prism'
+-- 'Prism' & 'Coprism'
---------------------------------------------------------------------
--- | Prisms access one piece of a sum structure.
+-- | Prisms access one piece of a sum.
--
-- \( \mathsf{Prism}\;S\;A = \exists D, S \cong D + A \)
--
-type Prism s t a b = forall p. PrismLike p s t a b
+type Prism s t a b = forall p. Choice p => Optic p s t a b
type Prism' s a = Prism s s a a
-type PrismLike p s t a b = Choice p => Optic p s t a b
+type Cxprism k s t a b = forall p. Choice p => CoindexedOptic p k s t a b
-type PrismLike' p s a = PrismLike p s s a a
+type Cxprism' k s a = Cxprism k s s a a
-type Reprism s t a b = forall p. ReprismLike p s t a b
+type Coprism s t a b = forall p. Cochoice p => Optic p s t a b
-type Reprism' s a = Reprism s s a a
+type Coprism' t b = Coprism t t b b
-type ReprismLike p s t a b = Cochoice p => Optic p s t a b
+type Ixprism i s t a b = forall p. Cochoice p => IndexedOptic p i s t a b
-type ReprismLike' p s a = ReprismLike p s s a a
+type Ixprism' i s a = Coprism s s a a
---------------------------------------------------------------------
-- 'Grate'
---------------------------------------------------------------------
--- | Grates access the codomain of an indexed structure.
+-- | Grates access the codomain of a function.
--
-- \( \mathsf{Grate}\;S\;A = \exists I, S \cong I \to A \)
--
-type Grate s t a b = forall p. GrateLike p s t a b
+type Grate s t a b = forall p. Closed p => Optic p s t a b
type Grate' s a = Grate s s a a
-type GrateLike p s t a b = Closed p => Optic p s t a b
+type Cxgrate k s t a b = forall p. Closed p => CoindexedOptic p k s t a b
-type GrateLike' p s a = GrateLike p s s a a
+type Cxgrate' k s a = Cxgrate k s s a a
---------------------------------------------------------------------
--- 'Grid'
+-- 'Traversal' & 'Cotraversal'
---------------------------------------------------------------------
--- | Grids arise from the combination of lenses and grates.
+-- | A 'Traversal' processes 0 or more parts of the whole, with 'Applicative' interactions.
--
--- \( \mathsf{Grid}\;S\;A = \exists C,I, S \cong C \times (I \to A) \)
+-- \( \mathsf{Traversal}\;S\;A = \exists F : \mathsf{Traversable}, S \equiv F\,A \)
--
-type Grid s t a b = forall p. GridLike p s t a b
+type Traversal s t a b = forall p. (Choice p, Representable p, Applicative (Rep p)) => Optic p s t a b
-type Grid' s a = Grid s s a a
+type Traversal' s a = Traversal s s a a
-type GridLike p s t a b = Closed p => LensLike p s t a b
+type Ixtraversal i s t a b = forall p. (Choice p, Representable p, Applicative (Rep p)) => IndexedOptic p i s t a b
-type GridLike' p s a = GridLike p s s a a
+type Ixtraversal' i s a = Ixtraversal i s s a a
---------------------------------------------------------------------
--- 'Traversal0'
+-- 'Traversal0' & 'Cotraversal0'
---------------------------------------------------------------------
-type Affine p = (Strong p, Choice p)
-
--- | A 'Traversal0' processes at most one element, with no interactions.
+-- | A 'Traversal0' processes at most one part of the whole, with no interactions.
--
-- \( \mathsf{Traversal0}\;S\;A = \exists C, D, S \cong D + C \times A \)
--
-type Traversal0 s t a b = forall p. Traversal0Like p s t a b
+type Traversal0 s t a b = forall p. (Strong p, Choice p) => Optic p s t a b
type Traversal0' s a = Traversal0 s s a a
-type Traversal0Like p s t a b = Affine p => Optic p s t a b
-
-type Traversal0Like' p s a = Traversal0Like p s s a a
-
-type Retraversal0 s t a b = forall p. Retraversal0Like p s t a b
+type Ixtraversal0 i s t a b = forall p. (Strong p, Choice p) => IndexedOptic p i s t a b
-type Retraversal0' s a = Retraversal0 s s a a
-
-type Retraversal0Like p s t a b = Costrong p => Cochoice p => Optic p s t a b
-
-type Retraversal0Like' p s a = ReprismLike p s s a a
+type Ixtraversal0' i s a = Ixtraversal0 i s s a a
---------------------------------------------------------------------
--- 'Traversal1'
+-- 'Traversal1' & 'Cotraversal1'
---------------------------------------------------------------------
--- | A 'Traversal1' processes 1 or more elements, with non-empty applicative interactions.
+-- | A 'Traversal1' processes 1 or more parts of the whole, with 'Apply' interactions.
--
-type Traversal1 s t a b = forall p. Traversal1Like p s t a b
-
-type Traversal1' s a = Traversal1 s s a a
-
-type Traversal1Like p s t a b = Choice p => Apply (Rep p) => RepnLike p s t a b
-
-type Traversal1Like' p s a = Traversal1Like p s s a a
-
----------------------------------------------------------------------
--- 'Traversal'
----------------------------------------------------------------------
-
--- | A 'Traversal' processes 0 or more elements, with applicative interactions.
+-- \( \mathsf{Traversal1}\;S\;A = \exists F : \mathsf{Traversable1}, S \equiv F\,A \)
--
-type Traversal s t a b = forall p. TraversalLike p s t a b
+type Traversal1 s t a b = forall p. (Choice p, Representable p, Apply (Rep p)) => Optic p s t a b
-type Traversal' s a = Traversal s s a a
+type Traversal1' s a = Traversal1 s s a a
-type TraversalLike p s t a b = Affine p => Applicative (Rep p) => RepnLike p s t a b
+type Cotraversal1 s t a b = forall p. (Closed p, Corepresentable p, Apply (Corep p)) => Optic p s t a b
-type TraversalLike' p s a = TraversalLike p s s a a
+type Cotraversal1' s a = Cotraversal1 s s a a
-type ATraversal f s t a b = Applicative f => Optic (Star f) s t a b
+type Cxtraversal1 k s t a b = forall p. (Closed p, Corepresentable p, Apply (Corep p)) => CoindexedOptic p k s t a b
-type ATraversal' f s a = ATraversal f s s a a
+type Cxtraversal1' k s a = Cxtraversal1 k s s a a
---------------------------------------------------------------------
--- 'Cotraversal0'
+-- 'Fold0', 'Fold', 'Fold1' & 'Cofold1'
---------------------------------------------------------------------
-type Coaffine p = (Closed p, Choice p)
-
--- | A 'Cotraversal0' arises from the combination of prisms and grates.
---
--- \( \mathsf{Cotraversal0}\;S\;A = \exists D,I, S \cong D + (I \to A) \)
+-- | A 'Fold0' combines at most one element, with no interactions.
--
-type Cotraversal0 s t a b = forall p. Cotraversal0Like p s t a b
-
-type Cotraversal0' s a = Cotraversal0 s s a a
-
-type Cotraversal0Like p s t a b = Coaffine p => Optic p s t a b
-
-type Cotraversal0Like' p s a = Cotraversal0Like p s s a a
-
----------------------------------------------------------------------
--- 'Cotraversal'
----------------------------------------------------------------------
-
-type Cotraversal s t a b = forall p. CotraversalLike p s t a b
+type Fold0 s a = forall p. (Choice p, Representable p, Applicative (Rep p), forall x. Contravariant (p x)) => Optic' p s a
-type Cotraversal' s a = Cotraversal s s a a
+type Ixfold0 i s a = forall p. (Choice p, Strong p, forall x. Contravariant (p x)) => IndexedOptic' p i s a
-type CotraversalLike p s t a b = Coaffine p => CorepnLike p s t a b
-
-type CotraversalLike' p s a = CotraversalLike p s s a a
-
-type Cotraversal1Like p s t a b = Coaffine p => Comonad (Corep p) => CorepnLike p s t a b
-
----------------------------------------------------------------------
--- 'Fold0'
----------------------------------------------------------------------
-
--- | A 'Fold0' extracts at most one non-summary result from a container.
+-- | A 'Fold' combines 0 or more elements, with 'Monoid' interactions.
--
-type Fold0 s a = forall p. Fold0Like p s a
-
-type Fold0Like p s a = (forall x. Contravariant (p x)) => Traversal0Like p s s a a
+type Fold s a = forall p. (Choice p, Representable p, Applicative (Rep p), forall x. Contravariant (p x)) => Optic' p s a
----------------------------------------------------------------------
--- 'Fold1'
----------------------------------------------------------------------
+type Ixfold i s a = forall p. (Choice p, Representable p, Applicative (Rep p), forall x. Contravariant (p x)) => IndexedOptic' p i s a
--- | A 'Fold1' extracts a semigroupal summary from a non-empty container
+-- | A 'Fold1' combines 1 or more elements, with 'Semigroup' interactions.
--
-type Fold1 s a = forall p. Fold1Like p s a
+type Fold1 s a = forall p. (Choice p, Representable p, Apply (Rep p), forall x. Contravariant (p x)) => Optic p s s a a
-type Fold1Like p s a = (forall x. Contravariant (p x)) => Traversal1Like p s s a a
-
-type AFold1 r s a = Semigroup r => Optic' (FoldRep r) s a
+type Cofold1 t b = forall p. (Cochoice p, Corepresentable p, Apply (Corep p), Bifunctor p) => Optic p t t b b
---------------------------------------------------------------------
--- 'Fold'
+-- 'View' & 'Review'
---------------------------------------------------------------------
--- | A 'Fold' extracts a monoidal summary from a container.
---
--- A 'Fold' can interpret 'a' in a monoid so long as 's' can also be interpreted that way.
---
-type Fold s a = forall p. FoldLike p s a
+type PrimView s t a b = forall p. (Profunctor p, forall x. Contravariant (p x)) => Optic p s t a b
-type FoldLike p s a = (forall x. Contravariant (p x)) => TraversalLike p s s a a
+type View s a = forall p. (Strong p, forall x. Contravariant (p x)) => Optic' p s a
-type FoldRep r = Star (Const r)
+type Ixview i s a = forall p. (Strong p, forall x. Contravariant (p x)) => IndexedOptic' p i s a
-type AFold r s a = Monoid r => Optic' (FoldRep r) s a
+type PrimReview s t a b = forall p. (Profunctor p, Bifunctor p) => Optic p s t a b
--- | Any lens, traversal, or prism will type-check as a `Handler`
---
-type Handler s a = forall r. AFold (Endo (Endo r)) s a
+type Review t b = forall p. (Costrong p, Bifunctor p) => Optic' p t b
-type HandlerM m s a = forall r. AFold (Endo (EndoM m r)) s a
+type Cxview k t b = forall p. (Costrong p, Bifunctor p) => CoindexedOptic' p k t b
---------------------------------------------------------------------
--- 'Cofold0'
+-- 'Setter' & 'Resetter'
---------------------------------------------------------------------
-type Cofold0 s a = forall p. Cofold0Like p s a
+-- | A 'Setter' modifies part of a structure.
+--
+-- \( \mathsf{Setter}\;S\;A = \exists F : \mathsf{Functor}, S \equiv F\,A \)
+--
+type Setter s t a b = forall p. (Closed p, Choice p, Representable p, Applicative (Rep p), Distributive (Rep p)) => Optic p s t a b
-type Cofold0Like p s a = Bifunctor p => Cotraversal0Like p s s a a
+type Setter' s a = Setter s s a a
----------------------------------------------------------------------
--- 'Cofold'
----------------------------------------------------------------------
+type Ixsetter i s t a b = forall p. (Closed p, Choice p, Representable p, Applicative (Rep p), Distributive (Rep p)) => IndexedOptic p i s t a b
-type Cofold t b = forall p. CofoldLike p t b
+type Ixsetter' i s a = Ixsetter i s s a a
-type CofoldLike p t b = Bifunctor p => CotraversalLike p t t b b
+type Resetter s t a b = forall p. (Closed p, Cochoice p, Corepresentable p, Apply (Corep p), Traversable (Corep p)) => Optic p s t a b
-type CofoldRep r = Costar (Const r)
+type Resetter' s a = Resetter s s a a
-type ACofold r t b = Optic' (CofoldRep r) t b
+type Cxsetter k s t a b = forall p. (Closed p, Cochoice p, Corepresentable p, Apply (Corep p), Traversable (Corep p)) => CoindexedOptic p k s t a b
---------------------------------------------------------------------
--- 'Repn'
+-- Common 'Representable' and 'Corepresentable' carriers
---------------------------------------------------------------------
-type Repn s t a b = forall p. RepnLike p s t a b
-
-type Repn' s a = Repn s s a a
-
-type RepnLike p s t a b = Representable p => Optic p s t a b
-
-type RepnLike' p s a = RepnLike p s s a a
-
type ARepn f s t a b = Optic (Star f) s t a b
----------------------------------------------------------------------
--- 'Corepn'
----------------------------------------------------------------------
+type ARepn' f s a = ARepn f s s a a
+
+type AIxrepn f i s t a b = IndexedOptic (Star f) i s t a b
-type Corepn s t a b = forall p. CorepnLike p s t a b
+type AIxrepn' f i s a = AIxrepn f i s s a a
-type Corepn' s a = Corepn s s a a
+type ACorepn f s t a b = Optic (Costar f) s t a b
-type CorepnLike p s t a b = Corepresentable p => Optic p s t a b
+type ACorepn' f t b = ACorepn f t t b b
-type CorepnLike' p s a = CorepnLike p s s a a
+type ACxrepn f k s t a b = CoindexedOptic (Costar f) k s t a b
-type ACorepn f s t a b = Optic (Costar f) s t a b
+type ACxrepn' f k t b = ACxrepn f k t t b b
---------------------------------------------------------------------
-- 'Re'
---------------------------------------------------------------------
--- | Turn a 'Lens', 'Prism' or 'Iso' around to build its dual.
+-- | Reverse an optic to obtain its dual.
--
--- If you have an 'Iso', 'from' is a more powerful version of this function
--- that will return an 'Iso' instead of a mere 'View'.
---
--- >>> 5 ^. re _L
+-- >>> 5 ^. re left
-- Left 5
--
--- >>> 6 ^. re (_L . from succ)
+-- >>> 6 ^. re (left . from succ)
-- Left 7
--
-- @
--- 'review' ≡ 'view' '.' 're'
--- 'reviews' ≡ 'views' '.' 're'
--- 'reuse' ≡ 'use' '.' 're'
--- 'reuses' ≡ 'uses' '.' 're'
+-- 're' . 're' ≡ id
-- @
--
-- @
--- 're' :: 'Prism' s t a b -> 'Reprism' b t
--- 're' :: 'Iso' s t a b -> 'View' b t
+-- 're' :: 'Iso' s t a b -> 'Iso' b a t s
+-- 're' :: 'Lens' s t a b -> 'Colens' b a t s
+-- 're' :: 'Prism' s t a b -> 'Coprism' b a t s
-- @
--
re :: Optic (Re p a b) s t a b -> Optic p b a t s
@@ -464,13 +344,13 @@ instance Profunctor p => Profunctor (Re p s t) where
dimap f g (Re p) = Re (p . dimap g f)
instance Strong p => Costrong (Re p s t) where
- unfirst (Re p) = Re (p . pfirst)
+ unfirst (Re p) = Re (p . first')
instance Costrong p => Strong (Re p s t) where
first' (Re p) = Re (p . unfirst)
instance Choice p => Cochoice (Re p s t) where
- unright (Re p) = Re (p . pright)
+ unright (Re p) = Re (p . right')
instance Cochoice p => Choice (Re p s t) where
right' (Re p) = Re (p . unright)
@@ -482,3 +362,28 @@ instance (Profunctor p, forall x. Contravariant (p x)) => Bifunctor (Re p s t) w
instance Bifunctor p => Contravariant (Re p s t a) where
contramap f (Re p) = Re (p . first f)
+
+---------------------------------------------------------------------
+-- Orphan instances
+---------------------------------------------------------------------
+
+instance Apply f => Apply (Star f a) where
+ Star ff <.> Star fx = Star $ \a -> ff a <.> fx a
+
+instance Contravariant f => Contravariant (Star f a) where
+ contramap f (Star g) = Star $ contramap f . g
+
+instance Contravariant f => Bifunctor (Costar f) where
+ first f (Costar g) = Costar $ g . contramap f
+
+ second f (Costar g) = Costar $ f . g
+
+instance Cochoice (Forget r) where
+ unleft (Forget f) = Forget $ f . Left
+
+ unright (Forget f) = Forget $ f . Right
+
+instance Comonad f => Strong (Costar f) where
+ first' (Costar f) = Costar $ \x -> (f (fmap fst x), snd (extract x))
+
+ second' (Costar f) = Costar $ \x -> (fst (extract x), f (fmap snd x))
diff --git a/src/Data/Profunctor/Optic/View.hs b/src/Data/Profunctor/Optic/View.hs
index f37c72f..98a5a28 100644
--- a/src/Data/Profunctor/Optic/View.hs
+++ b/src/Data/Profunctor/Optic/View.hs
@@ -1,16 +1,110 @@
-module Data.Profunctor.Optic.View where
-
-import Data.Profunctor.Optic.Type
-import Data.Profunctor.Optic.Prelude
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TupleSections #-}
+module Data.Profunctor.Optic.View (
+ -- * Types
+ View
+ , AView
+ , Ixview
+ , AIxview
+ , PrimView
+ , Review
+ , AReview
+ , Cxview
+ , ACxview
+ , PrimReview
+ -- * Constructors
+ , to
+ , ixto
+ , from
+ , cxfrom
+ , cloneView
+ , cloneReview
+ -- * Optics
+ , like
+ , ixlike
+ , relike
+ , cxlike
+ , toProduct
+ , fromSum
+ -- * Primitive operators
+ , withPrimView
+ , withPrimReview
+ -- * Operators
+ , (^.)
+ , (^%)
+ , view
+ , ixview
+ , views
+ , ixviews
+ , use
+ , ixuse
+ , uses
+ , ixuses
+ , (#^)
+ , review
+ , cxview
+ , reviews
+ , cxviews
+ , reuse
+ , reuses
+ , cxuse
+ , cxuses
+ -- * MonadIO
+ , throws
+ , throws_
+ , throwsTo
+ -- * Carriers
+ , Star(..)
+ , Tagged(..)
+) where
+
+import Control.Exception (Exception)
+import Control.Monad.IO.Class
import Control.Monad.Reader as Reader
import Control.Monad.Writer as Writer hiding (Sum(..))
-import Control.Monad.State as State hiding (StateT(..))
+import Control.Monad.State as State
+import Data.Profunctor.Optic.Type
+import Data.Profunctor.Optic.Import
+import Data.Profunctor.Optic.Index
+import GHC.Conc (ThreadId)
+import qualified Control.Exception as Ex
+import qualified Data.Bifunctor as B
+
+-- $setup
+-- >>> :set -XNoOverloadedStrings
+-- >>> :set -XTypeApplications
+-- >>> :set -XFlexibleContexts
+-- >>> :set -XRank2Types
+-- >>> import Data.Either
+-- >>> import Control.Monad.State
+-- >>> import Control.Monad.Writer
+-- >>> import Data.Int.Instance ()
+-- >>> import Data.List.Index as LI
+-- >>> :load Data.Profunctor.Optic
+-- >>> let catchOn :: Int -> Cxprism' Int (Maybe String) String ; catchOn n = cxjust $ \k -> if k==n then Just "caught" else Nothing
+-- >>> let ixtraversed :: Ixtraversal Int [a] [b] a b ; ixtraversed = ixtraversalVl LI.itraverse
+-- >>> let ixat :: Int -> Ixtraversal0' Int [a] a; ixat = inserted (\i s -> flip LI.ifind s $ \n _ -> n == i) (\i a s -> LI.modifyAt i (const a) s)
+
+type APrimView r s t a b = Optic (Star (Const r)) s t a b
+
+type AView s a = Optic' (Star (Const a)) s a
+
+type AIxview r i s a = IndexedOptic' (Star (Const (Maybe i , r))) i s a
+
+type APrimReview s t a b = Optic Tagged s t a b
+
+type AReview t b = Optic' Tagged t b
+
+type ACxview k t b = CoindexedOptic' Tagged k t b
---------------------------------------------------------------------
-- 'View' & 'Review'
---------------------------------------------------------------------
--- | Build a 'View' from an arbitrary function.
+
+-- | Obtain a 'View' from an arbitrary function.
--
-- @
-- 'to' f '.' 'to' g ≡ 'to' (g '.' f)
@@ -23,7 +117,7 @@ import Control.Monad.State as State hiding (StateT(..))
-- >>> 5 ^. to succ
-- 6
--
--- >>> (0, -5) ^. _2 . to abs
+-- >>> (0, -5) ^. t22 . to abs
-- 5
--
-- @
@@ -34,13 +128,19 @@ to :: (s -> a) -> PrimView s t a b
to f = coercer . lmap f
{-# INLINE to #-}
--- | Build a 'Review' from an arbitrary function.
+-- | TODO: Document
+--
+ixto :: (s -> (i , a)) -> Ixview i s a
+ixto f = to $ f . snd
+{-# INLINE ixto #-}
+
+-- | Obtain a 'Review' from an arbitrary function.
--
-- @
-- 'from' ≡ 're' . 'to'
-- @
--
--- >>> (from Prelude.length) # [1,2,3]
+-- >>> (from Prelude.length) #^ [1,2,3]
-- 3
--
-- @
@@ -51,34 +151,16 @@ from :: (b -> t) -> PrimReview s t a b
from f = coercel . rmap f
{-# INLINE from #-}
--- ^ @
--- 'toBoth' :: 'View' s a -> 'View' s b -> 'View' s (a, b)
--- @
---
-toBoth :: AView s a1 -> AView s a2 -> PrimView s t (a1 , a2) b
-toBoth l r = to (view l &&& view r)
-{-# INLINE toBoth #-}
-
--- | TODO: Document
---
-fromBoth :: AReview t1 b -> AReview t2 b -> PrimReview s (t1 , t2) a b
-fromBoth l r = from (review l &&& review r)
-{-# INLINE fromBoth #-}
-
-- | TODO: Document
--
-toEither :: AView s1 a -> AView s2 a -> PrimView (s1 + s2) t a b
-toEither l r = to (view l ||| view r)
-{-# INLINE toEither #-}
+cxfrom :: ((k -> b) -> t) -> Cxview k t b
+cxfrom f = from $ \kb _ -> f kb
+{-# INLINE cxfrom #-}
-- | TODO: Document
--
-fromEither :: AReview t b1 -> AReview t b2 -> PrimReview s t a (b1 + b2)
-fromEither l r = from (review l ||| review r)
-{-# INLINE fromEither #-}
-
--- ^ @
--- 'cloneView' :: 'AView' s a -> 'View' s a
+-- @
+-- 'cloneView' :: 'AView' s a -> 'View' s a
-- 'cloneView' :: 'Monoid' a => 'AView' s a -> 'Fold' s a
-- @
--
@@ -96,75 +178,26 @@ cloneReview = from . review
-- Primitive operators
---------------------------------------------------------------------
--- | Map each part of a structure viewed to a SEC.
---
--- @
--- 'Data.Foldable.foldMap' = 'viewOf' 'folding''
--- 'viewOf' ≡ 'views'
--- @
---
--- >>> viewOf both id (["foo"], ["bar", "baz"])
--- ["foo","bar","baz"]
---
--- @
--- 'viewOf' :: 'Iso'' s a -> (a -> r) -> s -> r
--- 'viewOf' :: 'Lens'' s a -> (a -> r) -> s -> r
--- 'viewOf' :: 'Monoid' r => 'Prism'' s a -> (a -> r) -> s -> r
--- 'viewOf' :: 'Monoid' r => 'Traversal'' s a -> (a -> r) -> s -> r
--- 'viewOf' :: 'Monoid' r => 'Traversal0'' s a -> (a -> r) -> s -> r
--- 'viewOf' :: 'Semigroup' r => 'Traversal1'' s a -> (a -> r) -> s -> r
--- 'viewOf' :: 'Monoid' r => 'Fold' s a -> (a -> r) -> s -> r
--- 'viewOf' :: 'Semigroup' r => 'Fold1' s a -> (a -> r) -> s -> r
--- 'viewOf' :: 'AView' s a -> (a -> r) -> s -> r
--- @
+-- | TODO: Document
--
-viewOf :: Optic' (FoldRep r) s a -> (a -> r) -> s -> r
-viewOf = between ((getConst .) . runStar) (Star . (Const . ))
-{-# INLINE viewOf #-}
+withPrimView :: APrimView r s t a b -> (a -> r) -> s -> r
+withPrimView o = (getConst #.) #. runStar #. o .# Star .# (Const #.)
+{-# INLINE withPrimView #-}
-- | TODO: Document
--
-reviewOf :: Optic' (CofoldRep r) t b -> (r -> b) -> r -> t
-reviewOf = between ((. Const) . runCostar) (Costar . (. getConst))
-{-# INLINE reviewOf #-}
+withPrimReview :: APrimReview s t a b -> (t -> r) -> b -> r
+withPrimReview o f = f . unTagged #. o .# Tagged
+{-# INLINE withPrimReview #-}
---------------------------------------------------------------------
--- Common 'View's and 'Review's
+-- Optics
---------------------------------------------------------------------
--- | TODO: Document
---
-coercedr :: PrimView a x a y
-coercedr = coercer
-{-# INLINE coercedr #-}
-
--- | TODO: Document
---
-coercedl :: PrimReview x b y b
-coercedl = coercel
-{-# INLINE coercedl #-}
-
--- | TODO: Document
---
-_1' :: PrimView (a , c) (b , c) a b
-_1' = to fst
-
--- | TODO: Document
---
-_2' :: PrimView (c , a) (c , b) a b
-_2' = to snd
-
--- | TODO: Document
---
-_L' :: PrimReview (a + c) (b + c) a b
-_L' = from Left
-
--- | TODO: Document
+-- | Obtain a constant-valued (index-preserving) 'View' from an arbitrary value.
--
-_R' :: PrimReview (c + a) (c + b) a b
-_R' = from Right
-
--- | Build a constant-valued (index-preserving) 'PrimView' from an arbitrary value.
+-- This can be useful as a second case 'failing' a 'Fold'
+-- e.g. @foo `failing` 'like' 0@
--
-- @
-- 'like' a '.' 'like' b ≡ 'like' b
@@ -172,14 +205,22 @@ _R' = from Right
-- a '^.' 'like' b ≡ a '^.' 'to' ('const' b)
-- @
--
--- This can be useful as a second case 'failing' a 'Fold'
--- e.g. @foo `failing` 'like' 0@
+--
+-- @
+-- 'like' :: a -> 'View' s a
+-- @
--
like :: a -> PrimView s t a b
like = to . const
{-# INLINE like #-}
--- | Build a constant-valued (index-preserving) 'PrimReview' from an arbitrary value.
+-- | TODO: Document
+--
+ixlike :: i -> a -> Ixview i s a
+ixlike i a = ixto (const (i, a))
+{-# INLINE ixlike #-}
+
+-- | Obtain a constant-valued (index-preserving) 'Review' from an arbitrary value.
--
-- @
-- 'relike' a '.' 'relike' b ≡ 'relike' a
@@ -191,143 +232,373 @@ relike :: t -> PrimReview s t a b
relike = from . const
{-# INLINE relike #-}
+-- | Obtain a constant-valued 'Cxview' from an arbitrary value.
+--
+cxlike :: t -> Cxview k t b
+cxlike = cxfrom . const
+{-# INLINE cxlike #-}
+
+-- | Combine two 'View's into a 'View' to a product.
+--
+-- @
+-- 'toProduct' :: 'View' s a1 -> 'View' s a2 -> 'View' s (a1 , a2)
+-- @
+--
+toProduct :: AView s a1 -> AView s a2 -> PrimView s t (a1 , a2) b
+toProduct l r = to (view l &&& view r)
+{-# INLINE toProduct #-}
+
+-- | Combine two 'Review's into a 'Review' from a sum.
+--
+-- @
+-- 'fromSum' :: 'Review' t b1 -> 'Review' t b2 -> 'Review' t (b1 + b2)
+-- @
+--
+fromSum :: AReview t b1 -> AReview t b2 -> PrimReview s t a (b1 + b2)
+fromSum l r = from (review l ||| review r)
+{-# INLINE fromSum #-}
+
---------------------------------------------------------------------
--- Derived operators
+-- Operators
---------------------------------------------------------------------
infixl 8 ^.
--- | TODO: Document
+-- | An infix alias for 'view'. Dual to '#'.
+--
+-- Fixity and semantics are such that subsequent field accesses can be
+-- performed with ('Prelude..').
+--
+-- >>> ("hello","world") ^. t22
+-- "world"
+--
+-- >>> import Data.Complex
+-- >>> ((0, 1 :+ 2), 3) ^. t21 . t22 . to magnitude
+-- 2.23606797749979
+--
+-- @
+-- ('^.') :: s -> 'View' s a -> a
+-- ('^.') :: 'Data.Monoid.Monoid' m => s -> 'Data.Profunctor.Optic.Fold.Fold' s m -> m
+-- ('^.') :: s -> 'Data.Profunctor.Optic.Iso.Iso'' s a -> a
+-- ('^.') :: s -> 'Data.Profunctor.Optic.Lens.Lens'' s a -> a
+-- ('^.') :: s -> 'Data.Profunctor.Optic.Prism.Coprism'' s a -> a
+-- ('^.') :: 'Data.Monoid.Monoid' m => s -> 'Data.Profunctor.Optic.Traversal.Traversal'' s m -> m
+-- @
--
(^.) :: s -> AView s a -> a
(^.) = flip view
{-# INLINE ( ^. ) #-}
-infixr 8 #
+infixl 8 ^%
--- | An infix alias for 'review'. Dual to '^.'.
+-- | Bring the index and value of a indexed optic into the current environment as a pair.
+--
+-- This a flipped, infix variant of 'ixview' and an indexed variant of '^.'.
+--
+-- The fixity and semantics are such that subsequent field accesses can be
+-- performed with ('Prelude..').
+--
+-- The result probably doesn't have much meaning when applied to an 'Ixfold'.
+--
+(^%) :: Monoid i => s -> AIxview a i s a -> (Maybe i , a)
+(^%) = flip ixview
+{-# INLINE (^%) #-}
+
+-- | View the value pointed to by a 'View', 'Data.Profunctor.Optic.Iso.Iso' or
+-- 'Lens' or the result of folding over all the results of a
+-- 'Data.Profunctor.Optic.Fold.Fold' or 'Data.Profunctor.Optic.Traversal.Traversal' that points
+-- at a monoidal value.
--
-- @
--- 'from' f # x ≡ f x
--- l # x ≡ x '^.' 're' l
+-- 'view' '.' 'to' ≡ 'id'
-- @
--
--- This is commonly used when using a 'Prism' as a smart constructor.
+-- >>> view t22 (1, "hello")
+-- "hello"
--
--- >>> _Left # 4
--- Left 4
+-- >>> view (to succ) 5
+-- 6
+--
+-- >>> view (t22 . t21) ("hello",("world","!!!"))
+-- "world"
+--
+view :: MonadReader s m => AView s a -> m a
+view o = views o id
+{-# INLINE view #-}
+
+-- | Bring the index and value of a indexed optic into the current environment as a pair.
+--
+-- >>> ixview ixfirst ("foo", 42)
+-- (Just (),"foo")
+--
+-- >>> ixview (ixat 3 . ixfirst) [(0,'f'),(1,'o'),(2,'o'),(3,'b'),(4,'a'),(5,'r') :: (Int, Char)]
+-- (Just 3,3)
+--
+-- In order to 'ixview' a 'Choice' optic (e.g. 'Ixtraversal0', 'Ixtraversal', 'Ixfold', etc),
+-- /a/ must have a 'Monoid' instance:
--
--- But it can be used for any 'Prism'
+-- >>> ixview (ixat 0) ([] :: [Int])
+-- (Nothing,0)
+-- >>> ixview (ixat 0) ([1] :: [Int])
+-- (Just 0,1)
--
--- >>> base 16 # 123
--- "7b"
+-- /Note/ when applied to a 'Ixtraversal' or 'Ixfold', then 'ixview' will return a monoidal
+-- summary of the indices tupled with a monoidal summary of the values:
+--
+-- >>> (ixview @_ @_ @Int @Int) ixtraversed [1,2,3,4]
+-- (Just 6,10)
+--
+ixview :: MonadReader s m => Monoid i => AIxview a i s a -> m (Maybe i , a)
+ixview o = asks $ withPrimView o (B.first Just) . (mempty,)
+{-# INLINE ixview #-}
+
+-- | Map each part of a structure viewed to a semantic edixtor combinator.
+--
+-- @
+-- 'views o f ≡ withFold o f'
+-- 'Data.Foldable.foldMap' = 'views' 'folding''
+-- @
+--
+-- >>> views both id (["foo"], ["bar", "baz"])
+-- ["foo","bar","baz"]
--
-- @
--- (#) :: 'Iso'' s a -> a -> s
--- (#) :: 'Prism'' s a -> a -> s
--- (#) :: 'Review' s a -> a -> s
--- (#) :: 'Equality'' s a -> a -> s
+-- 'views' :: 'AView' s a -> (a -> r) -> s -> r
+-- 'views' :: 'Iso'' s a -> (a -> r) -> s -> r
+-- 'views' :: 'Lens'' s a -> (a -> r) -> s -> r
+-- 'views' :: 'Coprism'' s a -> (a -> r) -> s -> r
+-- 'views' :: 'Monoid' r => 'Traversal'' s a -> (a -> r) -> s -> r
+-- 'views' :: 'Semigroup' r => 'Traversal1'' s a -> (a -> r) -> s -> r
+-- 'views' :: 'Monoid' r => 'Fold' s a -> (a -> r) -> s -> r
+-- 'views' :: 'Semigroup' r => 'Fold1' s a -> (a -> r) -> s -> r
-- @
--
-(#) :: AReview t b -> b -> t
-o # b = review o b
-{-# INLINE ( # ) #-}
+views :: MonadReader s m => Optic' (Star (Const r)) s a -> (a -> r) -> m r
+views o f = asks $ withPrimView o f
+{-# INLINE views #-}
--- ^ @
--- 'view o ≡ foldMapOf o id'
--- 'review' ≡ 'view' '.' 're'
--- 'reviews' ≡ 'views' '.' 're'
+-- | Bring a function of the index and value of an indexed optic into the current environment.
+--
+-- 'ixviews' ≡ 'iwithFold'
+--
+-- >>> ixviews (ixat 2) (-) ([0,1,2] :: [Int])
+-- 0
+--
+-- In order to 'ixviews' a 'Choice' optic (e.g. 'Ixtraversal0', 'Ixtraversal', 'Ixfold', etc),
+-- /a/ must have a 'Monoid' instance (here from the 'rings' package):
+--
+-- >>> ixviews (ixat 3) (flip const) ([1] :: [Int])
+-- 0
+--
+-- Use 'ixview' if there is a need to disambiguate between 'mempty' as a miss vs. as a return value.
+--
+ixviews :: MonadReader s m => Monoid i => IndexedOptic' (Star (Const r)) i s a -> (i -> a -> r) -> m r
+ixviews o f = asks $ withPrimView o (uncurry f) . (mempty,)
+
+-- | TODO: Document
+--
+use :: MonadState s m => AView s a -> m a
+use o = gets (view o)
+{-# INLINE use #-}
+
+-- | Bring the index and value of an indexed optic into the current environment as a pair.
+--
+ixuse :: MonadState s m => Monoid i => AIxview a i s a -> m (Maybe i , a)
+ixuse o = gets (ixview o)
+
+-- | Use the target of a 'Lens', 'Data.Profunctor.Optic.Iso.Iso' or
+-- 'View' in the current state, or use a summary of a
+-- 'Data.Profunctor.Optic.Fold.Fold' or 'Data.Profunctor.Optic.Traversal.Traversal' that
+-- points to a monoidal value.
+--
+-- >>> evalState (uses t21 length) ("hello","world!")
+-- 5
+--
+-- @
+-- 'uses' :: 'MonadState' s m => 'Data.Profunctor.Optic.Iso.Iso'' s a -> (a -> r) -> m r
+-- 'uses' :: 'MonadState' s m => 'Data.Profunctor.Optic.View.View' s a -> (a -> r) -> m r
+-- 'uses' :: 'MonadState' s m => 'Data.Profunctor.Optic.Lens.Lens'' s a -> (a -> r) -> m r
+-- 'uses' :: 'MonadState' s m => 'Data.Profunctor.Optic.Prism.Coprism'' s a -> (a -> r) -> m r
+-- 'uses' :: 'MonadState' s m => 'Data.Monoid.Monoid' r => 'Data.Profunctor.Optic.Traversal.Traversal'' s a -> (a -> r) -> m r
+-- 'uses' :: 'MonadState' s m => 'Data.Monoid.Monoid' r => 'Data.Profunctor.Optic.Fold.Fold' s a -> (a -> r) -> m r
-- @
--
-view :: MonadReader s m => AView s a -> m a
-view = (`views` id)
-{-# INLINE view #-}
+-- @
+-- 'uses' :: 'MonadState' s m => 'Getting' r s t a b -> (a -> r) -> m r
+-- @
+--
+uses :: MonadState s m => Optic' (Star (Const r)) s a -> (a -> r) -> m r
+uses l f = gets (views l f)
+{-# INLINE uses #-}
+
+-- | Bring a function of the index and value of an indexed optic into the current environment.
+--
+ixuses :: MonadState s m => Monoid i => IndexedOptic' (Star (Const r)) i s a -> (i -> a -> r) -> m r
+ixuses o f = gets $ withPrimView o (uncurry f) . (mempty,)
+
+infixr 8 #^
+
+-- | An infix variant of 'review'. Dual to '^.'.
+--
+-- @
+-- 'from' f #^ x ≡ f x
+-- o #^ x ≡ x '^.' 're' o
+-- @
+--
+-- This is commonly used when using a 'Prism' as a smart constructor.
+--
+-- >>> left #^ 4
+-- Left 4
+--
+-- @
+-- (#^) :: 'Iso'' s a -> a -> s
+-- (#^) :: 'Prism'' s a -> a -> s
+-- (#^) :: 'Colens'' s a -> a -> s
+-- (#^) :: 'Review' s a -> a -> s
+-- (#^) :: 'Equality'' s a -> a -> s
+-- @
+--
+(#^) :: AReview t b -> b -> t
+o #^ b = review o b
+{-# INLINE (#^) #-}
--- ^ @
--- 'review o ≡ cofoldMapOf o id'
+-- | Turn an optic around and look through the other end.
+--
+-- @
+-- 'review' ≡ 'view' '.' 're'
+-- 'review' . 'from' ≡ 'id'
+-- @
+--
+-- >>> review (from succ) 5
+-- 6
+--
+-- @
+-- 'review' :: 'Iso'' s a -> a -> s
+-- 'review' :: 'Prism'' s a -> a -> s
+-- 'review' :: 'Colens'' s a -> a -> s
-- @
--
review :: MonadReader b m => AReview t b -> m t
-review = (`reviews` id)
+review o = reviews o id
{-# INLINE review #-}
--- ^ @
--- 'views o f ≡ foldMapOf o f'
--- @
-views :: MonadReader s m => Optic' (FoldRep r) s a -> (a -> r) -> m r
-views o f = Reader.asks $ viewOf o f
-{-# INLINE views #-}
+-- | Bring a function of the index of a co-indexed optic into the current environment.
+--
+cxview :: MonadReader b m => ACxview k t b -> m (k -> t)
+cxview o = cxviews o id
+{-# INLINE cxview #-}
--- | This can be used to turn an 'Iso' or 'Prism' around and 'view' a value (or the current environment) through it the other way,
--- applying a function.
+-- | Turn an optic around and look through the other end, applying a function.
--
-- @
-- 'reviews' ≡ 'views' '.' 're'
-- 'reviews' ('from' f) g ≡ g '.' f
-- @
--
--- >>> reviews _Left isRight "mustard"
+-- >>> reviews left isRight "mustard"
-- False
--
-- >>> reviews (from succ) (*2) 3
-- 8
--
--- Usually this function is used in the @(->)@ 'Monad' with a 'Prism' or 'Iso', in which case it may be useful to think of
--- it as having one of these more restricted type signatures:
+-- @
+-- 'reviews' :: 'Iso'' t b -> (t -> r) -> b -> r
+-- 'reviews' :: 'Prism'' t b -> (t -> r) -> b -> r
+-- 'reviews' :: 'Colens'' t b -> (t -> r) -> b -> r
+-- @
+--
+reviews :: MonadReader b m => AReview t b -> (t -> r) -> m r
+reviews o f = asks $ withPrimReview o f
+{-# INLINE reviews #-}
+
+-- | Bring a continuation of the index of a co-indexed optic into the current environment.
--
-- @
--- 'reviews' :: 'Iso'' s a -> (s -> r) -> a -> r
--- 'reviews' :: 'Prism'' s a -> (s -> r) -> a -> r
+-- cxviews :: ACxview k t b -> ((k -> t) -> r) -> b -> r
-- @
--
--- However, when working with a 'Monad' transformer stack, it is sometimes useful to be able to 'review' the current environment, in which case
--- it may be beneficial to think of it as having one of these slightly more liberal type signatures:
+cxviews :: MonadReader b m => ACxview k t b -> ((k -> t) -> r) -> m r
+cxviews o f = asks $ withPrimReview o f . const
+
+-- | Turn an optic around and 'use' a value (or the current environment) through it the other way.
--
-- @
--- 'reviews' :: 'MonadReader' a m => 'Iso'' s a -> (s -> r) -> m r
--- 'reviews' :: 'MonadReader' a m => 'Prism'' s a -> (s -> r) -> m r
+-- 'reuse' ≡ 'use' '.' 're'
+-- 'reuse' '.' 'from' ≡ 'gets'
+-- @
+--
+-- >>> evalState (reuse left) 5
+-- Left 5
+--
+-- >>> evalState (reuse (from succ)) 5
+-- 6
+--
-- @
--- ^ @
--- 'reviews o f ≡ cofoldMapOf o f'
+-- 'reuse' :: 'MonadState' a m => 'Iso'' s a -> m s
+-- 'reuse' :: 'MonadState' a m => 'Prism'' s a -> m s
+-- 'reuse' :: 'MonadState' a m => 'Colens'' s a -> m s
-- @
--
-reviews :: MonadReader r m => ACofold r t b -> (r -> b) -> m t
-reviews o f = Reader.asks $ reviewOf o f
-{-# INLINE reviews #-}
-
----------------------------------------------------------------------
--- 'MonadState' and 'MonadWriter'
----------------------------------------------------------------------
+reuse :: MonadState b m => AReview t b -> m t
+reuse o = gets (unTagged #. o .# Tagged)
+{-# INLINE reuse #-}
-- | TODO: Document
--
-use :: MonadState s m => AView s a -> m a
-use o = State.gets (view o)
-{-# INLINE use #-}
+cxuse :: MonadState b m => ACxview k t b -> m (k -> t)
+cxuse o = gets (cxview o)
+{-# INLINE cxuse #-}
--- | Extracts the portion of a log that is focused on by a 'View'.
+-- | Turn an optic around and 'use' the current state through it the other way, applying a function.
+--
+-- @
+-- 'reuses' ≡ 'uses' '.' 're'
+-- 'reuses' ('from' f) g ≡ 'gets' (g '.' f)
+-- @
--
--- Given a 'Fold' or a 'Traversal', then a monoidal summary of the parts
--- of the log that are visited will be returned.
+-- >>> evalState (reuses left isLeft) (5 :: Int)
+-- True
--
-- @
--- 'listening' :: 'MonadWriter' w m => 'View' w u -> m a -> m (a, u)
--- 'listening' :: 'MonadWriter' w m => 'Lens'' w u -> m a -> m (a, u)
--- 'listening' :: 'MonadWriter' w m => 'Iso'' w u -> m a -> m (a, u)
--- 'listening' :: ('MonadWriter' w m, 'Monoid' u) => 'Fold' w u -> m a -> m (a, u)
--- 'listening' :: ('MonadWriter' w m, 'Monoid' u) => 'Traversal'' w u -> m a -> m (a, u)
--- 'listening' :: ('MonadWriter' w m, 'Monoid' u) => 'Prism'' w u -> m a -> m (a, u)
+-- 'reuses' :: 'MonadState' a m => 'Iso'' s a -> (s -> r) -> m r
+-- 'reuses' :: 'MonadState' a m => 'Prism'' s a -> (s -> r) -> m r
+-- 'reuses' :: 'MonadState' a m => 'Prism'' s a -> (s -> r) -> m r
-- @
-listening :: MonadWriter w m => AView w u -> m a -> m (a, u)
-listening l m = do
- (a, w) <- Writer.listen m
- return (a, view l w)
-{-# INLINE listening #-}
+--
+reuses :: MonadState b m => AReview t b -> (t -> r) -> m r
+reuses o tr = gets (tr . unTagged #. o .# Tagged)
+{-# INLINE reuses #-}
-- | TODO: Document
--
-listenings :: MonadWriter w m => Optic' (FoldRep v) w u -> (u -> v) -> m a -> m (a, v)
-listenings l uv m = do
- (a, w) <- listen m
- return (a, views l uv w)
-{-# INLINE listenings #-}
+cxuses :: MonadState b m => ACxview k t b -> ((k -> t) -> r) -> m r
+cxuses o f = gets (cxviews o f)
+{-# INLINE cxuses #-}
+
+---------------------------------------------------------------------
+-- 'MonadIO'
+---------------------------------------------------------------------
+
+-- | Throw an exception described by an optic.
+--
+-- @
+-- 'throws' o e \`seq\` x ≡ 'throws' o e
+-- @
+--
+throws :: MonadIO m => Exception e => AReview e b -> b -> m r
+throws o = reviews o $ liftIO . Ex.throwIO
+{-# INLINE throws #-}
+
+-- | Variant of 'throws' for error constructors with no arguments.
+--
+throws_ :: MonadIO m => Exception e => AReview e () -> m r
+throws_ o = throws o ()
+
+-- | Raise an 'Exception' specified by an optic in the target thread.
+--
+-- @
+-- 'throwsTo' thread o ≡ 'throwTo' thread . 'review' o
+-- @
+--
+throwsTo :: MonadIO m => Exception e => ThreadId -> AReview e b -> b -> m ()
+throwsTo tid o = reviews o (liftIO . Ex.throwTo tid)
diff --git a/src/Data/Profunctor/Orphan.hs b/src/Data/Profunctor/Orphan.hs
deleted file mode 100644
index 42645c7..0000000
--- a/src/Data/Profunctor/Orphan.hs
+++ /dev/null
@@ -1,61 +0,0 @@
-module Data.Profunctor.Orphan where
-
-import Control.Applicative
-import Control.Comonad
-import Control.Foldl
-import Data.Distributive
-import Data.Bifunctor
-import Data.Functor.Contravariant
-import Data.Functor.Rep as Functor
-import Data.Profunctor
-import Data.Profunctor.Rep as Profunctor
-import Data.Profunctor.Sieve
-
-import Prelude
-
-instance Contravariant f => Contravariant (Star f a) where
- contramap f (Star g) = Star $ contramap f . g
-
-instance Contravariant f => Bifunctor (Costar f) where
- first f (Costar g) = Costar $ g . contramap f
-
- second f (Costar g) = Costar $ f . g
-
-instance Cochoice (Forget r) where
- unleft (Forget f) = Forget $ f . Left
-
- unright (Forget f) = Forget $ f . Right
-
-instance Comonad f => Strong (Costar f) where
- first' (Costar f) = Costar $ \x -> (f (fmap fst x), snd (extract x))
-
- second' (Costar f) = Costar $ \x -> (fst (extract x), f (fmap snd x))
-
-instance Distributive (Fold a) where
- distribute = distributeRep
- {-# INLINE distribute #-}
-
-instance Functor.Representable (Fold a) where
- type Rep (Fold a) = [a]
- index = cosieve
- tabulate = cotabulate
-
-instance Costrong Fold where
- unfirst = unfirstCorep
- unsecond = unsecondCorep
-
-instance Closed Fold where
- closed (Fold h z k) = Fold (liftA2 h) (pure z) (\f x -> k (f x))
-
--- | >>> cosieve (Fold (+) 0 id) [1,2,3]
--- 6
-instance Cosieve Fold [] where
- cosieve (Fold h0 z0 k0) as0 = go k0 h0 z0 as0 where
- go k _ z [] = k z
- go k h z (a:as) = go k h (h z a) as
- {-# INLINE cosieve #-}
-
-instance Corepresentable Fold where
- type Corep Fold = []
- cotabulate f = Fold (flip (:)) [] (f . reverse)
- {-# INLINE cotabulate #-}
diff --git a/src/Data/Tuple/Optic.hs b/src/Data/Tuple/Optic.hs
new file mode 100644
index 0000000..7a790b7
--- /dev/null
+++ b/src/Data/Tuple/Optic.hs
@@ -0,0 +1,97 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+module Data.Tuple.Optic (
+ curried
+ , swapped
+ , associated
+ , t21
+ , t22
+ , t31
+ , t32
+ , t33
+ , t41
+ , t42
+ , t43
+ , t44
+ , t51
+ , t52
+ , t53
+ , t54
+ , t55
+) where
+
+import Data.Profunctor.Optic.Import
+import Data.Profunctor.Optic.Iso
+import Data.Profunctor.Optic.Lens
+import Data.Profunctor.Optic.Type
+
+---------------------------------------------------------------------
+-- Optics
+---------------------------------------------------------------------
+
+t21 :: Lens (a,b) (a',b) a a'
+t21 = lensVl $ \f ~(a,b) -> (\a' -> (a',b)) <$> f a
+{-# INLINE t21 #-}
+
+t22 :: Lens (a,b) (a,b') b b'
+t22 = lensVl $ \f ~(a,b) -> (\b' -> (a,b')) <$> f b
+{-# INLINE t22 #-}
+
+t31 :: Lens (a,b,c) (a',b,c) a a'
+t31 = lensVl $ \f ~(a,b,c) -> (\a' -> (a',b,c)) <$> f a
+{-# INLINE t31 #-}
+
+t32 :: Lens (a,b,c) (a,b',c) b b'
+t32 = lensVl $ \f ~(a,b,c) -> (\b' -> (a,b',c)) <$> f b
+{-# INLINE t32 #-}
+
+t33 :: Lens (a,b,c) (a,b,c') c c'
+t33 = lensVl $ \f ~(a,b,c) -> (\c' -> (a,b,c')) <$> f c
+{-# INLINE t33 #-}
+
+t41 :: Lens (a,b,c,d) (a',b,c,d) a a'
+t41 = lensVl $ \f ~(a,b,c,d) -> (\a' -> (a',b,c,d)) <$> f a
+{-# INLINE t41 #-}
+
+t42 :: Lens (a,b,c,d) (a,b',c,d) b b'
+t42 = lensVl $ \f ~(a,b,c,d) -> (\b' -> (a,b',c,d)) <$> f b
+{-# INLINE t42 #-}
+
+t43 :: Lens (a,b,c,d) (a,b,c',d) c c'
+t43 = lensVl $ \f ~(a,b,c,d) -> (\c' -> (a,b,c',d)) <$> f c
+{-# INLINE t43 #-}
+
+t44 :: Lens (a,b,c,d) (a,b,c,d') d d'
+t44 = lensVl $ \f ~(a,b,c,d) -> (\d' -> (a,b,c,d')) <$> f d
+{-# INLINE t44 #-}
+
+t51 :: Lens (a,b,c,d,e) (a',b,c,d,e) a a'
+t51 = lensVl $ \f ~(a,b,c,d,e) -> (\a' -> (a',b,c,d,e)) <$> f a
+{-# INLINE t51 #-}
+
+t52 :: Lens (a,b,c,d,e) (a,b',c,d,e) b b'
+t52 = lensVl $ \f ~(a,b,c,d,e) -> (\b' -> (a,b',c,d,e)) <$> f b
+{-# INLINE t52 #-}
+
+t53 :: Lens (a,b,c,d,e) (a,b,c',d,e) c c'
+t53 = lensVl $ \f ~(a,b,c,d,e) -> (\c' -> (a,b,c',d,e)) <$> f c
+{-# INLINE t53 #-}
+
+t54 :: Lens (a,b,c,d,e) (a,b,c,d',e) d d'
+t54 = lensVl $ \f ~(a,b,c,d,e) -> (\d' -> (a,b,c,d',e)) <$> f d
+{-# INLINE t54 #-}
+
+t55 :: Lens (a,b,c,d,e) (a,b,c,d,e') e e'
+t55 = lensVl $ \f ~(a,b,c,d,e) -> (\e' -> (a,b,c,d,e')) <$> f e
+{-# INLINE t55 #-}
+
+---------------------------------------------------------------------
+-- Optics
+---------------------------------------------------------------------
+
+
diff --git a/test/doctests.hs b/test/doctests.hs
new file mode 100644
index 0000000..0f15912
--- /dev/null
+++ b/test/doctests.hs
@@ -0,0 +1,14 @@
+import Test.DocTest
+
+main :: IO ()
+main = doctest
+ [ "-isrc"
+ , "src/Data/Profunctor/Optic/Fold.hs"
+ , "src/Data/Profunctor/Optic/Grate.hs"
+ , "src/Data/Profunctor/Optic/Iso.hs"
+ , "src/Data/Profunctor/Optic/Lens.hs"
+ , "src/Data/Profunctor/Optic/Prism.hs"
+ , "src/Data/Profunctor/Optic/Setter.hs"
+ , "src/Data/Profunctor/Optic/Traversal.hs"
+ , "src/Data/Profunctor/Optic/View.hs"
+ ]