profunctor-optics 0.0.1 → 0.0.2

raw patch · 25 files changed

+1940/−3766 lines, 25 filesdep +coapplicativedep +lawzdep −connectionsdep −containersdep −hedgehogdep ~adjunctionsdep ~basedep ~ringsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: coapplicative, lawz

Dependencies removed: connections, containers, hedgehog, ilist, keys, magmas, profunctor-arrows, unliftio-core

Dependency ranges changed: adjunctions, base, rings

API changes (from Hackage documentation)

Files

• profunctor-optics.cabal +10/−45
• src/Control/Exception/Optic.hs +0/−418
• src/Data/Profunctor/Optic.hs +7/−17
• src/Data/Profunctor/Optic/Affine.hs +0/−138
• src/Data/Profunctor/Optic/Carrier.hs +474/−224
• src/Data/Profunctor/Optic/Combinator.hs +345/−0
• src/Data/Profunctor/Optic/Cotraversal.hs +0/−143
• src/Data/Profunctor/Optic/Fold.hs +238/−281
• src/Data/Profunctor/Optic/Grate.hs +0/−343
• src/Data/Profunctor/Optic/Import.hs +9/−3
• src/Data/Profunctor/Optic/Index.hs +0/−379
• src/Data/Profunctor/Optic/Iso.hs +18/−85
• src/Data/Profunctor/Optic/Lens.hs +274/−99
• src/Data/Profunctor/Optic/Operator.hs +0/−152
• src/Data/Profunctor/Optic/Option.hs +0/−293
• src/Data/Profunctor/Optic/Prelude.hs +0/−266
• src/Data/Profunctor/Optic/Prism.hs +51/−46
• src/Data/Profunctor/Optic/Property.hs +26/−36
• src/Data/Profunctor/Optic/Setter.hs +29/−171
• src/Data/Profunctor/Optic/Traversal.hs +280/−150
• src/Data/Profunctor/Optic/Types.hs +137/−249
• src/Data/Profunctor/Optic/View.hs +40/−158
• test/Test/Data/Connection/Optic/Int.hs +0/−49
• test/doctest.hs +2/−6
• test/test.hs +0/−15

@@ -1,18 +1,16 @@ cabal-version: >= 1.10  name:           profunctor-optics-version:        0.0.1-synopsis:       An optics library compatible with the typeclasses in 'profunctors'.+version:        0.0.2+synopsis:       A compact 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, affines, traversals, cotraversals, views, setters, folds, and more.-  .-  Composable indexed or co-indexed variants of most of the above.+  Full complement of isos, prisms, lenses, grates, traversals, cotraversals, views, setters, folds, and more.   .-  Compact & straight-forward implementation. No inscrutable internal modules, lawless or otherwise ancillary typeclasses, or heavy type-level machinery.+  Compact & straight-forward implementation.   .-  Fully interoperable. All that is required to create optics (standard, indexable, or co-indexable) is the `profunctors` package. 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.+  Fully interoperable. All that is required to create optics is the `profunctors` package. Optics compose with (.) from `Prelude` as is typical. Conversions to & from the Van Laarhoven representations are provided for each optic type.   .   Well-documented properties and exportable predicates for testing your own optics.   .@@ -37,33 +35,24 @@  library   exposed-modules:-      Control.Exception.Optic--      Data.Either.Optic       Data.Tuple.Optic+      Data.Either.Optic        Data.Profunctor.Optic       Data.Profunctor.Optic.Types       Data.Profunctor.Optic.Property       Data.Profunctor.Optic.Carrier-      Data.Profunctor.Optic.Operator-      Data.Profunctor.Optic.Index+      Data.Profunctor.Optic.Combinator        Data.Profunctor.Optic.Iso       Data.Profunctor.Optic.Prism       Data.Profunctor.Optic.Lens-      Data.Profunctor.Optic.Grate-      Data.Profunctor.Optic.Affine-      Data.Profunctor.Optic.Option       Data.Profunctor.Optic.Traversal       Data.Profunctor.Optic.Fold-      Data.Profunctor.Optic.Cotraversal       Data.Profunctor.Optic.Setter       Data.Profunctor.Optic.View       Data.Profunctor.Optic.Zoom -      Data.Profunctor.Optic.Prelude-   other-modules: Data.Profunctor.Optic.Import    default-language: Haskell2010@@ -90,37 +79,17 @@   build-depends:       base              >= 4.9      && < 5.0     , adjunctions       >= 4.4      && < 5.0-    , connections       >= 0.0.3    && < 0.1+    , coapplicative     >= 0.0.1    && < 0.2     , distributive      >= 0.3      && < 1-    , keys              >= 3.12     && < 3.13+    , lawz              >= 0.1.1    && < 0.2     , mtl               >= 2.0.1    && < 2.3     , newtype-generics  >= 0.5.3    && < 0.6-    , profunctor-arrows >= 0.0.0.3  && < 0.0.1     , profunctors       >= 5.4      && < 6-    , rings             >= 0.0.3.1  && < 0.0.4-    , magmas            >= 0.0.1    && < 0.1+    , rings             >= 0.1.3    && < 0.1.4     , semigroupoids     >= 5        && < 6     , tagged            >= 0.4.4    && < 1     , transformers      >= 0.5      && < 0.6-    , unliftio-core     >= 0.1.2    && < 0.2 -test-suite test-  type:              exitcode-stdio-1.0-  main-is:           test.hs-  ghc-options:       -Wall -threaded-  hs-source-dirs:    test-  default-language:  Haskell2010-  other-modules:     Test.Data.Connection.Optic.Int-  build-depends:       -      base == 4.*-    , connections-    , profunctor-optics -    , hedgehog-  default-extensions:-      ScopedTypeVariables,-      TypeApplications-  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall- executable doctest   main-is:           doctest.hs   ghc-options:       -Wall -threaded@@ -130,11 +99,7 @@    build-depends:       base-    , adjunctions-    , containers-    , connections     , doctest >= 0.8-    , ilist     , mtl     , profunctor-optics 

@@ -1,418 +0,0 @@-{-# 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 Prelude (String)-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

@@ -6,39 +6,29 @@ {-# LANGUAGE TypeOperators         #-} {-# LANGUAGE TypeFamilies          #-} module Data.Profunctor.Optic (-    module Type-  , module Property+    module Types   , module Carrier   , module Operator-  , module Index   , module Iso-  , module Lens   , module Prism-  , module Grate-  , module Affine-  , module Option+  , module Lens   , module Traversal   , module Fold-  , module Cotraversal   , module View   , module Setter+  , module Tuple   , module Zoom ) where -import Data.Profunctor.Optic.Types            as Type-import Data.Profunctor.Optic.Property         as Property+import Data.Profunctor.Optic.Types            as Types import Data.Profunctor.Optic.Carrier          as Carrier-import Data.Profunctor.Optic.Operator         as Operator-import Data.Profunctor.Optic.Index            as Index+import Data.Profunctor.Optic.Combinator       as Operator import Data.Profunctor.Optic.Iso              as Iso-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.Affine           as Affine-import Data.Profunctor.Optic.Option           as Option+import Data.Profunctor.Optic.Lens             as Lens import Data.Profunctor.Optic.Traversal        as Traversal import Data.Profunctor.Optic.Fold             as Fold-import Data.Profunctor.Optic.Cotraversal      as Cotraversal import Data.Profunctor.Optic.View             as View import Data.Profunctor.Optic.Setter           as Setter import Data.Profunctor.Optic.Zoom             as Zoom+import Data.Tuple.Optic                       as Tuple

@@ -1,138 +0,0 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TupleSections         #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE TypeFamilies          #-}-module Data.Profunctor.Optic.Affine (-    -- * Affine & Ixaffine-    Affine-  , Affine'-  , Ixaffine-  , Ixaffine'-  , affine-  , affine'-  , iaffine-  , iaffine'-  , affineVl-  , iaffineVl-    -- * Optics-  , nulled-  , selected-    -- * Primitive operators-  , withAffine-    -- * Operators-  , matches-    -- * Classes-  , Strong(..)-  , Choice(..)-) where--import Data.Bifunctor (first, second)-import Data.Profunctor.Optic.Carrier-import Data.Profunctor.Optic.Lens-import Data.Profunctor.Optic.Prism-import Data.Profunctor.Optic.Import-import Data.Profunctor.Optic.Types hiding (branch)---- $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-------------------------------------------------------------------------- 'Affine' & 'Ixaffine'-------------------------------------------------------------------------- | Create a 'Affine' from match and constructor functions.------ /Caution/: In order for the 'Affine' to be well-defined,--- 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@------ * @sbt (sbt s a1) a2 ≡ sbt s a2@------ 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'.----affine :: (s -> t + a) -> (s -> b -> t) -> Affine s t a b-affine sta sbt = dimap (\s -> (s,) <$> sta s) (id ||| uncurry sbt) . right' . second'---- | Obtain a 'Affine'' from match and constructor functions.----affine' :: (s -> Maybe a) -> (s -> a -> s) -> Affine' s a-affine' sa sas = flip affine sas $ \s -> maybe (Left s) Right (sa s)---- | TODO: Document----iaffine :: (s -> t + (i , a)) -> (s -> b -> t) -> Ixaffine i s t a b-iaffine stia sbt = iaffineVl $ \point f s -> either point (fmap (sbt s) . uncurry f) (stia s)---- | TODO: Document----iaffine' :: (s -> Maybe (i , a)) -> (s -> a -> s) -> Ixaffine' i s a-iaffine' sia = iaffine $ \s -> maybe (Left s) Right (sia s) ---- | Transform a Van Laarhoven 'Affine' into a profunctor 'Affine'.----affineVl :: (forall f. Functor f => (forall c. c -> f c) -> (a -> f b) -> s -> f t) -> Affine s t a b-affineVl 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---- | Transform an indexed Van Laarhoven 'Affine' into an indexed profunctor 'Affine'.----iaffineVl :: (forall f. Functor f => (forall c. c -> f c) -> (i -> a -> f b) -> s -> f t) -> Ixaffine i s t a b-iaffineVl f = affineVl $ \cc iab -> f cc (curry iab) . snd-------------------------------------------------------------------------- Optics -------------------------------------------------------------------------- | TODO: Document----nulled :: Affine' s a-nulled = affine Left const -{-# INLINE nulled #-}---- | TODO: Document----selected :: (a -> Bool) -> Affine' (a, b) b-selected p = affine (\kv@(k,v) -> branch p kv v k) (\kv@(k,_) v' -> if p k then (k,v') else kv)-{-# INLINE selected #-}-------------------------------------------------------------------------- Operators-------------------------------------------------------------------------- | Test whether the optic matches or not.------ >>> matches just (Just 2)--- Right 2------ >>> matches just (Nothing :: Maybe Int) :: Either (Maybe Bool) Int--- Left Nothing----matches :: AAffine s t a b -> s -> t + a-matches o = withAffine o $ \sta _ -> sta-{-# INLINE matches #-}

@@ -5,52 +5,37 @@ {-# LANGUAGE TupleSections         #-} {-# LANGUAGE TypeOperators         #-} {-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE DeriveGeneric         #-} module Data.Profunctor.Optic.Carrier (     -- * Carrier types     AIso   , AIso'   , APrism   , APrism'+  , ACoprism+  , ACoprism'   , ALens   , ALens'-  , AIxlens-  , AIxlens'-  , AGrate-  , AGrate'-  , ACxgrate-  , ACxgrate'-  , AAffine-  , AAffine'-  , AOption-  , AIxoption-  , AGrism-  , AGrism'+  , AColens+  , AColens'   , ARepn   , ARepn'-  , AIxrepn-  , AIxrepn'+  , AGrate+  , AGrate'+  , ACorepn+  , ACorepn'+  , ATraversal0+  , ATraversal0'   , ATraversal   , ATraversal'-  , AIxtraversal-  , AIxtraversal'   , ATraversal1   , ATraversal1'-  , AIxtraversal1-  , AIxtraversal1'-  , AFold-  , AIxfold-  , AFold1-  , AIxfold1-  , APrimView-  , AView-  , AIxview-  , AIxsetter-  , AIxsetter'-  , ACorepn-  , ACorepn'-  , ACxrepn'+  , ACotraversal0+  , ACotraversal0'   , ACotraversal   , ACotraversal'+  , ACotraversal1+  , ACotraversal1'   , AList   , AList'   , AList1@@ -59,65 +44,81 @@   , AScope'   , AScope1   , AScope1'-  , APrimReview+  , AFold0+  , AFold+  , AFold1+  , ACofold+  , AView   , AReview-  , ACxview-  , ACxsetter-  , ACxsetter'     -- * Primitive operators   , withIso   , withPrism+  , withCoprism   , withLens-  , withIxlens+  , withColens+  , withLensVl   , withGrate-  , withCxgrate+  , withGrateVl   , withAffine-  , withGrism-  , withOption-  , withIxoption   , withStar+  , withCoaffine   , withCostar-  , withPrimView-  , withPrimReview-  , withIxsetter-  , withCxsetter+  , withFold0+  , withFold+  , withFold1+  , withCofold+  , withView+  , withReview     -- * Carrier profunctors   , IsoRep(..)   , PrismRep(..)+  , CoprismRep(..)+  , Cotraversal0Rep(..)   , LensRep(..)-  , IxlensRep(..)+  , ColensRep(..)   , GrateRep(..)-  , CxgrateRep(..)-  , AffineRep(..)-  , GrismRep(..)-  , OptionRep(..)+  , Traversal0Rep(..)+  , Fold0Rep(..)   , Star(..)   , Costar(..)   , Tagged(..)+    -- * Index+  , Index(..)+  , vals+  , info+    -- * Coindex+  , Coindex(..)+  , trivial+  , noindex+  , coindex+  , (.#.)+    -- * Conjoin+  , Conjoin(..) ) where +import Control.Category (Category)+import Control.Monad.Fix (MonadFix(..)) import Data.Profunctor.Types as Export (Star(..), Costar(..)) import Data.Bifunctor as B import Data.Function import Data.Profunctor.Optic.Types import Data.Profunctor.Optic.Import-import Data.Profunctor.Optic.Index-import Data.Profunctor.Extra as Extra+import Data.Profunctor.Optic.Combinator import Data.Profunctor.Rep (unfirstCorep)+import GHC.Generics (Generic) -import qualified Data.Bifunctor as B+import qualified Control.Arrow as A+import qualified Control.Category as C+ -- $setup -- >>> :set -XNoOverloadedStrings -- >>> :set -XTypeApplications -- >>> :set -XFlexibleContexts -- >>> :set -XRankNTypes--- >>> import Control.Exception hiding (catches) -- >>> import Data.Functor.Identity--- >>> import Data.List.Index as LI -- >>> import Data.Map as Map -- >>> import Data.Maybe -- >>> import Data.Monoid--- >>> import Data.Semiring hiding (unital,nonunital,presemiring) -- >>> :load Data.Profunctor.Optic  ---------------------------------------------------------------------@@ -132,87 +133,61 @@  type APrism' s a = APrism s s a a +type ACoprism s t a b = Optic (CoprismRep a b) s t a b++type ACoprism' s a = ACoprism s s a a+ type ALens s t a b = Optic (LensRep a b) s t a b  type ALens' s a = ALens s s a a -type AIxlens i s t a b = IndexedOptic (IxlensRep i a b) i s t a b+type AColens s t a b = Optic (ColensRep a b) s t a b -type AIxlens' i s a = AIxlens i s s a a+type AColens' s a = AColens s s a a   type AGrate s t a b = Optic (GrateRep a b) s t a b  type AGrate' s a = AGrate s s a a -type ACxgrate k s t a b = CoindexedOptic (CxgrateRep k a b) k s t a b--type ACxgrate' k s a = ACxgrate k s s a a--type AAffine s t a b = Optic (AffineRep a b) s t a b--type AAffine' s a = AAffine s s a a--type AOption r s a = Optic' (OptionRep r) s a--type AIxoption r i s a = IndexedOptic' (OptionRep r) i s a--type AGrism s t a b = Optic (GrismRep a b) s t a b--type AGrism' s a = AGrism s s a a- type ARepn f s t a b = Optic (Star f) s t a b  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 ACorepn f s t a b = Optic (Costar f) s t a b -type AIxrepn' f i s a = AIxrepn f i s s a a+type ACorepn' f t b = ACorepn f t t b b -type ATraversal f s t a b = Applicative f => ARepn f s t a b+type ATraversal0 s t a b = Optic (Traversal0Rep a b) s t a b -type ATraversal' f s a = ATraversal f s s a a+type ATraversal0' s a = ATraversal0 s s a a -type AIxtraversal f i s t a b = Applicative f => AIxrepn f i s t a b+type ATraversal f s t a b = Applicative f => ARepn f s t a b -type AIxtraversal' f i s a = AIxtraversal f i s s a a+type ATraversal' f s a = ATraversal f s s a a  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 -type AIxtraversal1 f i s t a b = Apply f => AIxrepn f i s t a b--type AIxtraversal1' f i s a = AIxtraversal1 f i s s a a--type AFold r s a = ARepn' (Const r) s a--type AIxfold r i s a = AIxrepn' (Const r) i s a--type AFold1 r s a = ARepn' (Const r) s a--type AIxfold1 r i s a = AIxrepn' (Const r) i s a--type APrimView r s t a b = ARepn (Const r) s t a b--type AView s a = ARepn' (Const a) s a+type ACotraversal0 s t a b = Optic (Cotraversal0Rep a b) s t a b -type AIxview i s a = AIxrepn' (Const (Maybe i , a)) i s a+type ACotraversal0' s a = ACotraversal0 s s a a -type AIxsetter i s t a b = IndexedOptic (->) i s t a b+type ACotraversal f s t a b = Coapplicative f => ACorepn f s t a b -type AIxsetter' i s a = AIxsetter i s s a a+type ACotraversal' f s a = ACotraversal f s s a a -type ACorepn f s t a b = Optic (Costar f) s t a b+type ACotraversal1 f s t a b = Coapply f => ACorepn f s t a b -type ACorepn' f t b = ACorepn f t t b b+type ACotraversal1' f s a = ACotraversal1 f s s a a -type ACxrepn f k s t a b = CoindexedOptic (Costar f) k s t a b+type AFold0 r s a = Optic' (Fold0Rep r) s a -type ACxrepn' f k t b = ACxrepn f k t t b b+type AFold r s a = Monoid r => ARepn' (Const r) s a -type ACotraversal f s t a b = Coapplicative f => ACorepn f s t a b+type AFold1 r s a = Semigroup r => ARepn' (Const r) s a -type ACotraversal' f s a = ACotraversal f s s a a+type ACofold r t b = ACorepn' (Const r) t b  type AList f s t a b = Foldable f => ACorepn f s t a b @@ -230,16 +205,10 @@  type AScope1' f s a = AScope1 f s s a a -type APrimReview s t a b = Optic Tagged s t a b+type AView r s a = ARepn' (Const r) s a  type AReview t b = Optic' Tagged t b -type ACxview k t b = CoindexedOptic' Tagged k t b--type ACxsetter k s t a b = CoindexedOptic (->) k s t a b--type ACxsetter' k t b = ACxsetter k t t b b- -- | Extract the two functions that characterize an 'Iso'. -- withIso :: AIso s t a b -> ((s -> a) -> (b -> t) -> r) -> r@@ -250,47 +219,76 @@ -- 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+{-# INLINE withPrism #-} +-- | Extract the two functions that characterize a 'Coprism'.+--+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+ -- | Extract the two functions that characterize a 'Lens'. -- withLens :: ALens s t a b -> ((s -> a) -> (s -> b -> t) -> r) -> r withLens o f = case o (LensRep id (flip const)) of LensRep x y -> f x y+{-# INLINE withLens #-} --- | Extract the two functions that characterize a 'Lens'.+-- | Extract the two functions that characterize a 'Colens'. ---withIxlens :: (Additive-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 . (zero,)) (\s b -> y (zero, s) b)+withColens :: AColens s t a b -> ((b -> s -> a) -> (b -> t) -> r) -> r+withColens l f = case l (ColensRep (flip const) id) of ColensRep x y -> f x y +-- | Extract the higher order function that characterizes a 'Lens'.+--+-- The lens laws can be stated in terms of 'withLens':+-- +-- Identity:+-- +-- @+-- withLensVl o Identity ≡ Identity+-- @+-- +-- Composition:+-- +-- @ +-- Compose . fmap (withLensVl o f) . withLensVl o g ≡ withLensVl o (Compose . fmap f . g)+-- @+--+-- See 'Data.Profunctor.Optic.Property'.+--+withLensVl :: Functor f => ALens s t a b -> (a -> f b) -> s -> f t+withLensVl o ab s = withLens o $ \sa sbt -> sbt s <$> ab (sa s)+ -- | Extract the function that characterizes a 'Grate'. -- withGrate :: AGrate s t a b -> ((((s -> a) -> b) -> t) -> r) -> r withGrate o f = case o (GrateRep $ \k -> k id) of GrateRep sabt -> f sabt {-# INLINE withGrate #-} -withCxgrate :: (Additive-Monoid) k => ACxgrate k s t a b -> ((((s -> a) -> k -> b) -> t) -> r) -> r-withCxgrate o sakbtr = case o (CxgrateRep $ \f -> f id) of CxgrateRep sakbt -> sakbtr $ flip sakbt zero---- | TODO: Document----withAffine :: AAffine s t a b -> ((s -> t + a) -> (s -> b -> t) -> r) -> r-withAffine o k = case o (AffineRep Right $ const id) of AffineRep x y -> k x y---- | TODO: Document+-- | Extract the higher order function that characterizes a 'Grate'. ---withGrism :: AGrism s t a b -> ((((s -> t + a) -> b) -> t) -> r) -> r-withGrism o k = case o (GrismRep $ \f -> f Right) of GrismRep g -> k g---- | TODO: Document+-- The grate laws can be stated in terms or 'withGrate':+-- +-- Identity:+-- +-- @+-- withGrateVl o runIdentity ≡ runIdentity+-- @+-- +-- Composition:+-- +-- @ +-- withGrateVl o f . fmap (withGrateVl o g) ≡ withGrateVl o (f . fmap g . getCompose) . Compose+-- @ ---withOption :: Optic (OptionRep r) s t a b -> (a -> Maybe r) -> s -> Maybe r-withOption o = runOptionRep #. o .# OptionRep-{-# INLINE withOption #-}+withGrateVl :: Functor f => AGrate s t a b -> (f a -> b) -> f s -> t+withGrateVl o ab s = withGrate o $ \sabt -> sabt $ \get -> ab (fmap get s)+{-# INLINE withGrateVl #-}  -- | TODO: Document ---withIxoption :: (Additive-Monoid) i => AIxoption r i s a -> (i -> a -> Maybe r) -> s -> Maybe r-withIxoption o f = flip curry zero $ withOption o (uncurry f)-{-# INLINE withIxoption #-}+withAffine :: ATraversal0 s t a b -> ((s -> t + a) -> (s -> b -> t) -> r) -> r+withAffine o k = case o (Traversal0Rep Right $ const id) of Traversal0Rep x y -> k x y+{-# INLINE withAffine #-}  -- | TODO: Document --@@ -300,33 +298,66 @@  -- | TODO: Document --+withCoaffine :: ACotraversal0 s t a b -> ((((s -> t + a) -> b) -> t) -> r) -> r+withCoaffine o k = case o (Cotraversal0Rep $ \f -> f Right) of Cotraversal0Rep g -> k g+{-# INLINE withCoaffine #-}++-- | TODO: Document+-- withCostar :: ACorepn f s t a b -> (f a -> b) -> (f s -> t) withCostar o = runCostar #. o .# Costar {-# INLINE withCostar #-}  -- | TODO: Document ---withPrimView :: APrimView r s t a b -> (a -> r) -> s -> r-withPrimView o = (getConst #.) #. withStar o .# (Const #.)-{-# INLINE withPrimView #-}+withFold0 :: Optic (Fold0Rep r) s t a b -> (a -> Maybe r) -> s -> Maybe r+withFold0 o = runFold0Rep #. o .# Fold0Rep+{-# INLINE withFold0 #-} +-- | 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 traversed+-- withFold traversed+--   :: (Monoid r, Traversable f) => (a -> r) -> f a -> r+--+withFold :: Monoid r => AFold r s a -> (a -> r) -> s -> r+withFold o = (getConst #.) #. withStar o .# (Const #.)+{-# INLINE withFold #-}++-- | Map an optic to a semigroup and combine the results.+--+withFold1 :: Semigroup r => AFold1 r s a -> (a -> r) -> s -> r+withFold1 o = (getConst #.) #. withStar o .# (Const #.)+{-# INLINE withFold1 #-}+ -- | TODO: Document ---withPrimReview :: APrimReview s t a b -> (t -> r) -> b -> r-withPrimReview o f = f . unTagged #. o .# Tagged-{-# INLINE withPrimReview #-}+-- >>> withCofold (from succ) (*2) 3+-- 7+--+-- Compare 'Data.Profunctor.Optic.View.withReview'.+--+withCofold :: ACofold r t b -> (r -> b) -> r -> t+withCofold o = (.# Const) #. withCostar o .# (.# getConst) +{-# INLINE withCofold #-}  -- | TODO: Document ---withIxsetter :: IndexedOptic (->) i s t a b -> (i -> a -> b) -> i -> s -> t-withIxsetter o = unConjoin #. corepn o .# Conjoin-{-# INLINE withIxsetter #-}+withView :: AView r s a -> (a -> r) -> s -> r+withView o = (getConst #.) #. withStar o .# (Const #.)+{-# INLINE withView #-}  -- | TODO: Document ---withCxsetter :: CoindexedOptic (->) k s t a b -> (k -> a -> b) -> k -> s -> t-withCxsetter o = unConjoin #. repn o .# Conjoin-{-# INLINE withCxsetter #-}+withReview :: AReview t b -> (t -> r) -> b -> r+withReview o f = f . unTagged #. o .# Tagged+{-# INLINE withReview #-}  --------------------------------------------------------------------- -- IsoRep@@ -374,6 +405,23 @@   right' (PrismRep sta bt) = PrismRep (either (Left . Left) (first Right . sta)) (Right . bt)   {-# INLINE right' #-} +data CoprismRep a b s t = CoprismRep (s -> a) (b -> a + t) ++instance Functor (CoprismRep a b s) where+  fmap f (CoprismRep sa bat) = CoprismRep sa (second f . bat)+  {-# INLINE fmap #-}++instance Profunctor (CoprismRep a b) where+  lmap f (CoprismRep sa bat) = CoprismRep (sa . f) bat+  {-# INLINE lmap #-}++  rmap = fmap+  {-# INLINE rmap #-}++instance Cochoice (CoprismRep a b) where+  unleft (CoprismRep sca batc) = CoprismRep (sca . Left) (forgetr $ either (eassocl . batc) Right)+  {-# INLINE unleft #-}+ --------------------------------------------------------------------- -- LensRep ---------------------------------------------------------------------@@ -401,20 +449,20 @@   tabulate f = LensRep (\s -> info (f s)) (\s -> vals (f s))  ------------------------------------------------------------------------ IxlensRep+-- ColensRep --------------------------------------------------------------------- -data IxlensRep i a b s t = IxlensRep (s -> (i , a)) (s -> b -> t)--instance Profunctor (IxlensRep i a b) where-  dimap f g (IxlensRep sia sbt) = IxlensRep (sia . f) (\s -> g . sbt (f s))+data ColensRep a b s t = ColensRep (b -> s -> a) (b -> t) -instance Strong (IxlensRep i a b) where-  first' (IxlensRep sia sbt) =-    IxlensRep (\(a, _) -> sia a) (\(s, c) b -> (sbt s b, c))+instance Profunctor (ColensRep a b) where+  dimap f g (ColensRep bsa bt) = ColensRep (\b s -> bsa b (f s)) (g . bt) -  second' (IxlensRep sia sbt) =-    IxlensRep (\(_, a) -> sia a) (\(c, s) b -> (c, sbt s b))+{-+instance Costrong (ColensRep a b) where+  unfirst (ColensRep baca bbc) = ColensRep (curry foo) (forget2 $ bbc . fst)+    where foo = uncurry baca . shuffle . B.second bbc --_ . swap --TODO: B.second bbc+          shuffle (x,(y,z)) = (y,(x,z))+-}  --------------------------------------------------------------------- -- GrateRep@@ -442,118 +490,105 @@   cotabulate f = GrateRep $ f . Coindex  ------------------------------------------------------------------------ CxgrateRep------------------------------------------------------------------------newtype CxgrateRep k a b s t = CxgrateRep { unCxgrateRep :: ((s -> a) -> k -> b) -> t }--instance Profunctor (CxgrateRep k a b) where-  dimap f g (CxgrateRep z) = CxgrateRep $ \d -> g (z $ \k -> d (k . f))--instance Closed (CxgrateRep k a b) where-  closed (CxgrateRep sabt) = CxgrateRep $ \xsab x -> sabt $ \sa -> xsab $ \xs -> sa (xs x)-------------------------------------------------------------------------- AffineRep+-- Traversal0Rep --------------------------------------------------------------------- --- | The `AffineRep` profunctor precisely characterizes an 'Affine'.-data AffineRep a b s t = AffineRep (s -> t + a) (s -> b -> t)+-- | The `Traversal0Rep` profunctor precisely characterizes an 'Traversal0'.+data Traversal0Rep a b s t = Traversal0Rep (s -> t + a) (s -> b -> t) -instance Profunctor (AffineRep a b) where-  dimap f g (AffineRep sta sbt) = AffineRep+instance Profunctor (Traversal0Rep a b) where+  dimap f g (Traversal0Rep sta sbt) = Traversal0Rep       (\a -> first g $ sta (f a))       (\a v -> g (sbt (f a) v)) -instance Strong (AffineRep a b) where-  first' (AffineRep sta sbt) = AffineRep+instance Strong (Traversal0Rep a b) where+  first' (Traversal0Rep sta sbt) = Traversal0Rep       (\(a, c) -> first (,c) $ sta a)       (\(a, c) v -> (sbt a v, c)) -instance Choice (AffineRep a b) where-  right' (AffineRep sta sbt) = AffineRep+instance Choice (Traversal0Rep a b) where+  right' (Traversal0Rep sta sbt) = Traversal0Rep       (\eca -> eassocl (second sta eca))       (\eca v -> second (`sbt` v) eca) -instance Sieve (AffineRep a b) (IndexA a b) where-  sieve (AffineRep sta sbt) s = IndexA (sta s) (sbt s)+instance Sieve (Traversal0Rep a b) (Index0 a b) where+  sieve (Traversal0Rep sta sbt) s = Index0 (sta s) (sbt s) -instance Representable (AffineRep a b) where-  type Rep (AffineRep a b) = IndexA a b+instance Representable (Traversal0Rep a b) where+  type Rep (Traversal0Rep a b) = Index0 a b -  tabulate f = AffineRep (info0 . f) (values0 . f)+  tabulate f = Traversal0Rep (info0 . f) (values0 . f) -data IndexA a b r = IndexA (r + a) (b -> r)+data Index0 a b r = Index0 (r + a) (b -> r) -values0 :: IndexA a b r -> b -> r-values0 (IndexA _ br) = br+values0 :: Index0 a b r -> b -> r+values0 (Index0 _ br) = br -info0 :: IndexA a b r -> r + a-info0 (IndexA a _) = a+info0 :: Index0 a b r -> r + a+info0 (Index0 a _) = a -instance Functor (IndexA a b) where-  fmap f (IndexA ra br) = IndexA (first f ra) (f . br)+instance Functor (Index0 a b) where+  fmap f (Index0 ra br) = Index0 (first f ra) (f . br) -instance Applicative (IndexA a b) where-  pure r = IndexA (Left r) (const r)-  liftA2 f (IndexA ra1 br1) (IndexA ra2 br2) = IndexA (eswap $ liftA2 f (eswap ra1) (eswap ra2)) (liftA2 f br1 br2)+instance Applicative (Index0 a b) where+  pure r = Index0 (Left r) (const r)+  liftA2 f (Index0 ra1 br1) (Index0 ra2 br2) = Index0 (eswap $ liftA2 f (eswap ra1) (eswap ra2)) (liftA2 f br1 br2)  ------------------------------------------------------------------------ 'GrismRep'+-- Cotraversal0Rep ---------------------------------------------------------------------  --TODO: Corepresentable, Coapplicative (Corep) --- | The 'GrismRep' profunctor precisely characterizes 'Grism'.+-- | The 'Cotraversal0Rep' profunctor precisely characterizes 'Cotraversal0'. ---newtype GrismRep a b s t = GrismRep { unGrismRep :: ((s -> t + a) -> b) -> t }+newtype Cotraversal0Rep a b s t = Cotraversal0Rep { unCotraversal0Rep :: ((s -> t + a) -> b) -> t } -instance Profunctor (GrismRep a b) where-  dimap us tv (GrismRep stabt) =-    GrismRep $ \f -> tv (stabt $ \sta -> f (first tv . sta . us))+instance Profunctor (Cotraversal0Rep a b) where+  dimap us tv (Cotraversal0Rep stabt) =+    Cotraversal0Rep $ \f -> tv (stabt $ \sta -> f (first tv . sta . us)) -instance Closed (GrismRep a b) where-  closed (GrismRep stabt) =-    GrismRep $ \f x -> stabt $ \sta -> f $ \xs -> first const $ sta (xs x)+instance Closed (Cotraversal0Rep a b) where+  closed (Cotraversal0Rep stabt) =+    Cotraversal0Rep $ \f x -> stabt $ \sta -> f $ \xs -> first const $ sta (xs x) -instance Choice (GrismRep a b) where-  left' (GrismRep stabt) =-    GrismRep $ \f -> Left $ stabt $ \sta -> f $ eassocl . fmap eswap . eassocr . first sta+instance Choice (Cotraversal0Rep a b) where+  left' (Cotraversal0Rep stabt) =+    Cotraversal0Rep $ \f -> Left $ stabt $ \sta -> f $ eassocl . fmap eswap . eassocr . first sta  ------------------------------------------------------------------------ OptionRep+-- Fold0Rep --------------------------------------------------------------------- -newtype OptionRep r a b = OptionRep { runOptionRep :: a -> Maybe r }+newtype Fold0Rep r a b = Fold0Rep { runFold0Rep :: a -> Maybe r } ---todo coerce-instance Functor (OptionRep r a) where-  fmap _ (OptionRep p) = OptionRep p+instance Functor (Fold0Rep r a) where+  fmap _ (Fold0Rep p) = Fold0Rep p -instance Contravariant (OptionRep r a) where-  contramap _ (OptionRep p) = OptionRep p+instance Contravariant (Fold0Rep r a) where+  contramap _ (Fold0Rep p) = Fold0Rep p -instance Profunctor (OptionRep r) where-  dimap f _ (OptionRep p) = OptionRep (p . f)+instance Profunctor (Fold0Rep r) where+  dimap f _ (Fold0Rep p) = Fold0Rep (p . f) -instance Choice (OptionRep r) where-  left' (OptionRep p) = OptionRep (either p (const Nothing))-  right' (OptionRep p) = OptionRep (either (const Nothing) p)+instance Choice (Fold0Rep r) where+  left' (Fold0Rep p) = Fold0Rep (either p (const Nothing))+  right' (Fold0Rep p) = Fold0Rep (either (const Nothing) p) -instance Cochoice (OptionRep r) where-  unleft  (OptionRep k) = OptionRep (k . Left)-  unright (OptionRep k) = OptionRep (k . Right)+instance Cochoice (Fold0Rep r) where+  unleft  (Fold0Rep k) = Fold0Rep (k . Left)+  unright (Fold0Rep k) = Fold0Rep (k . Right) -instance Strong (OptionRep r) where-  first' (OptionRep p) = OptionRep (p . fst)-  second' (OptionRep p) = OptionRep (p . snd)+instance Strong (Fold0Rep r) where+  first' (Fold0Rep p) = Fold0Rep (p . fst)+  second' (Fold0Rep p) = Fold0Rep (p . snd) -instance Sieve (OptionRep r) (Pre r) where-  sieve = (Pre .) . runOptionRep+instance Sieve (Fold0Rep r) (Pre r) where+  sieve = (Pre .) . runFold0Rep -instance Representable (OptionRep r) where-  type Rep (OptionRep r) = Pre r-  tabulate = OptionRep . (getPre .)+instance Representable (Fold0Rep r) where+  type Rep (Fold0Rep r) = Pre r+  tabulate = Fold0Rep . (getPre .)   {-# INLINE tabulate #-}  -- | 'Pre' is 'Maybe' with a phantom type variable.@@ -563,3 +598,218 @@ instance Functor (Pre a) where fmap _ (Pre p) = Pre p  instance Contravariant (Pre a) where contramap _ (Pre p) = Pre p+++---------------------------------------------------------------------+-- Index+---------------------------------------------------------------------++-- | An indexed store that characterizes a 'Data.Profunctor.Optic.Lens.Lens'+--+-- @'Index' a b s ≡ forall f. 'Functor' f => (a -> f b) -> f s@,+--+-- See also 'Data.Profunctor.Optic.Lens.withLensVl'.+--+data Index a b s = Index a (b -> s) deriving Generic++vals :: Index a b s -> b -> s+vals (Index _ bs) = bs+{-# INLINE vals #-}++info :: Index a b s -> a+info (Index a _) = a+{-# INLINE info #-}++instance Functor (Index a b) where+  fmap f (Index a bs) = Index a (f . bs)+  {-# INLINE fmap #-}++instance Profunctor (Index a) where+  dimap f g (Index a bs) = Index a (g . bs . f)+  {-# INLINE dimap #-}++instance a ~ b => Foldable (Index a b) where+  foldMap f (Index b bs) = f . bs $ b++---------------------------------------------------------------------+-- Coindex+---------------------------------------------------------------------++-- | An indexed continuation that characterizes a 'Data.Profunctor.Optic.Grate.Grate'+--+-- @'Coindex' a b s ≡ forall f. 'Functor' f => (f a -> b) -> f s@,+--+-- See also 'Data.Profunctor.Optic.Grate.withGrateVl'.+--+-- '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 s = Coindex { runCoindex :: (s -> a) -> b } deriving Generic++instance Functor (Coindex a b) where+  fmap sl (Coindex ab) = Coindex $ \la -> ab (la . sl)++instance a ~ b => Apply (Coindex a b) where+  (Coindex slab) <.> (Coindex ab) = Coindex $ \la -> slab $ \sl -> ab (la . sl) ++instance a ~ b => Applicative (Coindex a b) where+  pure s = Coindex ($s)+  (<*>) = (<.>)++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 s => (a -> b) -> Coindex a b s+noindex f = Coindex $ \a -> f (a mempty)++coindex :: Functor f => s -> (a -> b) -> Coindex (f a) (f b) s+coindex s ab = Coindex $ \sfa -> fmap ab (sfa s)+{-# INLINE coindex #-}++infixr 9 .#.++-- | Compose two coindexes.+--+-- When /s/ 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 s => Coindex b c s -> Coindex a b s -> Coindex a c s+Coindex f .#. Coindex g = Coindex $ \b -> f $ \s1 -> g $ \s2 -> b (s1 <> s2)++---------------------------------------------------------------------+-- Conjoin+---------------------------------------------------------------------++-- '(->)' is simultaneously both indexed and co-indexed.+newtype Conjoin j a b = Conjoin { unConjoin :: j -> a -> b }++instance Functor (Conjoin j a) where+  fmap g (Conjoin f) = Conjoin $ \j a -> g (f j a)+  {-# INLINE fmap #-}++instance Apply (Conjoin j a) where+  Conjoin f <.> Conjoin g = Conjoin $ \j a -> f j a (g j a)+  {-# INLINE (<.>) #-}++instance Applicative (Conjoin j a) where+  pure b = Conjoin $ \_ _ -> b+  {-# INLINE pure #-}+  Conjoin f <*> Conjoin g = Conjoin $ \j a -> f j a (g j a)+  {-# INLINE (<*>) #-}++instance Monad (Conjoin j a) where+  return = pure+  {-# INLINE return #-}+  Conjoin f >>= k = Conjoin $ \j a -> unConjoin (k (f j a)) j a+  {-# INLINE (>>=) #-}++instance MonadFix (Conjoin j a) where+  mfix f = Conjoin $ \ j a -> let o = unConjoin (f o) j a in o+  {-# INLINE mfix #-}++instance Profunctor (Conjoin j) where+  dimap ab cd jbc = Conjoin $ \j -> cd . unConjoin jbc j . ab+  {-# INLINE dimap #-}+  lmap ab jbc = Conjoin $ \j -> unConjoin jbc j . ab+  {-# INLINE lmap #-}+  rmap bc jab = Conjoin $ \j -> bc . unConjoin jab j+  {-# INLINE rmap #-}++instance Closed (Conjoin j) where+  closed (Conjoin jab) = Conjoin $ \j xa x -> jab j (xa x)++instance Costrong (Conjoin j) where+  unfirst (Conjoin jadbd) = Conjoin $ \j a -> let+      (b, d) = jadbd j (a, d)+    in b++instance Sieve (Conjoin j) ((->) j) where+  sieve = flip . unConjoin+  {-# INLINE sieve #-}++instance Representable (Conjoin j) where+  type Rep (Conjoin j) = (->) j+  tabulate = Conjoin . flip+  {-# INLINE tabulate #-}++instance Cosieve (Conjoin j) ((,) j) where+  cosieve = uncurry . unConjoin+  {-# INLINE cosieve #-}++instance Corepresentable (Conjoin j) where+  type Corep (Conjoin j) = (,) j+  cotabulate = Conjoin . curry+  {-# INLINE cotabulate #-}++instance Choice (Conjoin j) where+  right' = A.right+  {-# INLINE right' #-}++instance Strong (Conjoin j) where+  second' = A.second+  {-# INLINE second' #-}++instance Category (Conjoin j) where+  id = Conjoin (const id)+  {-# INLINE id #-}+  Conjoin f . Conjoin g = Conjoin $ \j -> f j . g j+  {-# INLINE (.) #-}++instance A.Arrow (Conjoin j) where+  arr f = Conjoin (\_ -> f)+  {-# INLINE arr #-}+  first f = Conjoin (A.first . unConjoin f)+  {-# INLINE first #-}+  second f = Conjoin (A.second . unConjoin f)+  {-# INLINE second #-}+  Conjoin f *** Conjoin g = Conjoin $ \j -> f j A.*** g j+  {-# INLINE (***) #-}+  Conjoin f &&& Conjoin g = Conjoin $ \j -> f j A.&&& g j+  {-# INLINE (&&&) #-}++instance A.ArrowChoice (Conjoin j) where+  left f = Conjoin (A.left . unConjoin f)+  {-# INLINE left #-}+  right f = Conjoin (A.right . unConjoin f)+  {-# INLINE right #-}+  Conjoin f +++ Conjoin g = Conjoin $ \j -> f j A.+++ g j+  {-# INLINE (+++)  #-}+  Conjoin f ||| Conjoin g = Conjoin $ \j -> f j A.||| g j+  {-# INLINE (|||) #-}++instance A.ArrowApply (Conjoin j) where+  app = Conjoin $ \i (f, b) -> unConjoin f i b+  {-# INLINE app #-}++instance A.ArrowLoop (Conjoin j) where+  loop (Conjoin f) = Conjoin $ \j b -> let (c,d) = f j (b, d) in c+  {-# INLINE loop #-}

@@ -0,0 +1,345 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TupleSections         #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeFamilies          #-}+module Data.Profunctor.Optic.Combinator (+    type (+)+  , (&)+    -- * Operations on (->) profunctors+  , rgt+  , rgt'+  , lft+  , lft'+  , swap+  , eswap+  , fork+  , join+  , eval+  , apply+  , branch+  , branch'+  , assocl+  , assocr+  , assocl' +  , assocr'+  , eassocl+  , eassocr+  , forget1+  , forget2+  , forgetl+  , forgetr+    -- * Operations on arbitrary profunctors+  , constl+  , constr+  , shiftl+  , shiftr+  , coercel +  , coercer+    -- * Operations on (co)-strong profunctors+  , strong +  , costrong+  , choice+  , cochoice+  , pull+  , peval +  , pushl+  , pushr +    -- * Operations on (co)-representable profunctors+  , star+  , costar+  , unstar+  , uncostar+  , sieve'+  , cosieve'+  , tabulate' +  , cotabulate'+  , repn+  , corepn+  , pure'+  , copure'+  , pappend+  , liftR2+    -- * Arrow-style combinators+  , (<<*>>)+  , (****)+  , (++++)+  , (&&&&)+  , (||||)+    -- * Divisible-style combinators+  , divide+  , divide'+  , codivide+  , codivide'+  , choose+  , choose'+  , cochoose+  , cochoose'+) where++import Data.Function+import Data.Profunctor.Closed+import Data.Profunctor.Optic.Types+import Data.Profunctor.Optic.Import++branch :: (a -> Bool) -> b -> c -> a -> b + c+branch f y z x = if f x then Right z else Left y+{-# INLINE branch #-}++branch' :: (a -> Bool) -> a -> a + a+branch' f x = branch f x x x+{-# INLINE branch' #-}++assocl :: (a , (b , c)) -> ((a , b) , c)+assocl (a, (b, c)) = ((a, b), c)+{-# INLINE assocl #-}++assocr :: ((a , b) , c) -> (a , (b , c))+assocr ((a, b), c) = (a, (b, c))+{-# INLINE assocr #-}++assocl' :: (a , b + c) -> (a , b) + c+assocl' = eswap . traverse eswap+{-# INLINE assocl' #-}++assocr' :: (a + b , c) -> a + (b , c)+assocr' (f, b) = fmap (,b) f+{-# INLINE assocr' #-}++eassocl :: a + (b + c) -> (a + b) + c+eassocl (Left a)          = Left (Left a)+eassocl (Right (Left b))  = Left (Right b)+eassocl (Right (Right c)) = Right c+{-# INLINE eassocl #-}++eassocr :: (a + b) + c -> a + (b + c)+eassocr (Left (Left a))  = Left a+eassocr (Left (Right b)) = Right (Left b)+eassocr (Right c)        = Right (Right c)+{-# INLINE eassocr #-}++forget1 :: ((c, a) -> (c, b)) -> a -> b+forget1 f a = b where (c, b) = f (c, a)+{-# INLINE forget1 #-}++forget2 :: ((a, c) -> (b, c)) -> a -> b+forget2 f a = b where (b, c) = f (a, c)+{-# INLINE forget2 #-}++forgetl :: (c + a -> c + b) -> a -> b+forgetl f = go . Right where go = either (go . Left) id . f+{-# INLINE forgetl #-}++forgetr :: (a + c -> b + c) -> a -> b+forgetr f = go . Left where go = either id (go . Right) . f+{-# INLINE forgetr #-}++---------------------------------------------------------------------+-- Operations on arbitrary profunctors+---------------------------------------------------------------------++constl :: Profunctor p => b -> p b c -> p a c+constl = lmap . const+{-# INLINE constl #-}++constr :: Profunctor p => c -> p a b -> p a c+constr = rmap . const+{-# INLINE constr #-}++shiftl :: Profunctor p => p (a + b) c -> p b (c + d)+shiftl = dimap Right Left+{-# INLINE shiftl #-}++shiftr :: Profunctor p => p b (c , d) -> p (a , b) c+shiftr = dimap snd fst+{-# INLINE shiftr #-}++coercel :: Profunctor p => CoerceL p => p a b -> p c b+coercel = first absurd . lmap absurd+{-# INLINE coercel #-}++coercer :: Profunctor p => CoerceR p => p a b -> p a c+coercer = rmap absurd . contramap absurd+{-# INLINE coercer #-}++---------------------------------------------------------------------+-- Operations on (co)-strong profunctors+---------------------------------------------------------------------++strong :: Strong p => ((a , b) -> c) -> p a b -> p a c+strong f = dimap fork f . second'+{-# INLINE strong #-}++costrong :: Costrong p => ((a , b) -> c) -> p c a -> p b a+costrong f = unsecond . dimap f fork+{-# INLINE costrong #-}++choice :: Choice p => (c -> (a + b)) -> p b a -> p c a+choice f = dimap f join . right'+{-# INLINE choice #-}++cochoice :: Cochoice p => (c -> (a + b)) -> p a c -> p a b+cochoice f = unright . dimap join f+{-# INLINE cochoice #-}++pull :: Strong p => p a b -> p a (a , b)+pull = lmap fork . second'+{-# INLINE pull #-}++peval :: Strong p => p a (a -> b) -> p a b+peval = rmap eval . pull+{-# INLINE peval #-}++pushl :: Closed p => Traversing1 p => p a c -> p b c -> p a (b -> c)+pushl p q = curry' $ divide id p q+{-# INLINE pushl #-}++pushr :: Closed p => Traversing1 p => p (a , b) c -> p a b -> p a c+pushr = (<<*>>) . curry' +{-# INLINE pushr #-}++---------------------------------------------------------------------+-- Operations on (co)-representable profunctors+---------------------------------------------------------------------++star :: Applicative f => Star f a a+star = Star pure+{-# INLINE star #-}++costar :: Coapplicative f => Costar f a a+costar = Costar copure+{-# INLINE costar #-}++unstar :: Coapplicative f => Star f a b -> a -> b+unstar f = copure . runStar f+{-# INLINE unstar #-}++uncostar :: Applicative f => Costar f a b -> a -> b+uncostar f = runCostar f . pure+{-# INLINE uncostar #-}++sieve' :: Sieve p f => p d c -> Star f d c+sieve' = Star . sieve+{-# INLINE sieve' #-}++cosieve' :: Cosieve p f => p a b -> Costar f a b+cosieve' = Costar . cosieve+{-# INLINE cosieve' #-}++tabulate' :: Representable p => Star (Rep p) a b -> p a b+tabulate' = tabulate . runStar+{-# INLINE tabulate' #-}++cotabulate' :: Corepresentable p => Costar (Corep p) a b -> p a b+cotabulate' = cotabulate . runCostar+{-# INLINE cotabulate' #-}++repn :: Representable p => ((a -> Rep p b) -> s -> Rep p t) -> p a b -> p s t+repn f = tabulate . f . sieve+{-# INLINE repn #-}++corepn :: Corepresentable p => ((Corep p a -> b) -> Corep p s -> t) -> p a b -> p s t+corepn f = cotabulate . f . cosieve+{-# INLINE corepn #-}++pure' :: Traversing p => (a -> b) -> p a b +pure' = tabulate . (pure .)+{-# INLINE pure' #-}++copure' :: Cotraversing p => (a -> b) -> p a b+copure' = cotabulate . (. copure)+{-# INLINE copure' #-}++pappend :: Traversing1 p => p a b -> p a b -> p a b+pappend = divide fork+{-# INLINE pappend #-}++liftR2 :: Traversing1 p => (b -> c -> d) -> p a b -> p a c -> p a d+liftR2 f x y = tabulate $ \s -> liftF2 f (sieve x s) (sieve y s)+{-# INLINE liftR2 #-}++---------------------------------------------------------------------+-- Arrow-style combinators+---------------------------------------------------------------------++infixl 4 <<*>>++-- | Profunctor version of '<*>'.+--+(<<*>>) :: Traversing1 p => p a (b -> c) -> p a b -> p a c+(<<*>>) = liftR2 ($)+{-# INLINE (<<*>>) #-}++infixr 3 ****++-- | Profunctor version of '***'.+--+(****) :: Traversing1 p => p a1 b1 -> p a2 b2 -> p (a1 , a2) (b1 , b2)+p **** q = dimap fst (,) p <<*>> lmap snd q+{-# INLINE (****) #-}++infixr 2 ++++++-- | Profunctor version of '+++'.+--+(++++) :: Cotraversing1 p => p a1 b1 -> p a2 b2 -> p (a1 + a2) (b1 + b2)+p ++++ q = cotabulate $ bimap (cosieve p) (cosieve q) . coapply+{-# INLINE (++++) #-}++infixr 3 &&&&++-- | Profunctor version of '&&&'.+--+(&&&&) ::  Traversing1 p => p a b1 -> p a b2 -> p a (b1 , b2)+p &&&& q = liftR2 (,) p q+{-# INLINE (&&&&) #-}++infixr 2 ||||++-- | Profunctor version of '|||'.+--+(||||) :: Cotraversing1 p => p a1 b -> p a2 b -> p (a1 + a2) b+p |||| q = cotabulate $ either (cosieve p) (cosieve q) . coapply+{-# INLINE (||||) #-}++---------------------------------------------------------------------+-- Divisible-style combinators+---------------------------------------------------------------------++-- | Profunctor version of < hackage.haskell.org/package/contravariant/docs/Data-Functor-Contravariant-Divisible.html#v:divide divide >.+--+divide :: Traversing1 p => (a -> (a1 , a2)) -> p a1 b -> p a2 b -> p a b+divide f p q = dimap f fst $ p **** q+{-# INLINE divide #-}++divide' :: Traversing1 p => p a1 b -> p a2 b -> p (a1 , a2) b+divide' = divide id+{-# INLINE divide' #-}++codivide :: Cotraversing1 p => ((b1 + b2) -> b) -> p a b1 -> p a b2 -> p a b+codivide f p q = dimap Left f $ p ++++ q+{-# INLINE codivide #-}++codivide' :: Cotraversing1 p => p a b1 -> p a b2 -> p a (b1 + b2)+codivide' = codivide id+{-# INLINE codivide' #-}++-- | Profunctor version of < hackage.haskell.org/package/contravariant/docs/Data-Functor-Contravariant-Divisible.html#v:choose choose >.+--+choose :: Cotraversing1 p => (a -> (a1 + a2)) -> p a1 b -> p a2 b -> p a b +choose f p q = dimap f join $ p ++++ q+{-# INLINE choose #-}++choose' :: Cotraversing1 p => p a1 b -> p a2 b -> p (a1 + a2) b +choose' = choose id+{-# INLINE choose' #-}++cochoose :: Traversing1 p => ((b1 , b2) -> b) -> p a b1 -> p a b2 -> p a b+cochoose f p q = dimap fork f $ p **** q+{-# INLINE cochoose #-}++cochoose' :: Traversing1 p => p a b1 -> p a b2 -> p a (b1, b2)+cochoose' = cochoose id+{-# INLINE cochoose' #-}

@@ -1,143 +0,0 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TupleSections         #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE TypeFamilies          #-}-module Data.Profunctor.Optic.Cotraversal (-    -- * Cotraversal & Cxtraversal-    Cotraversal-  , Cotraversal'-  , cotraversing-  , retraversing-  , cotraversalVl-    -- * Optics-  , cotraversed-    -- * Operators-  , withCotraversal-  , distributes -) where--import Data.Bitraversable-import Data.List.NonEmpty as NonEmpty-import Data.Profunctor.Optic.Carrier-import Data.Profunctor.Optic.Grate-import Data.Profunctor.Optic.Lens-import Data.Profunctor.Optic.Import hiding (id,(.))-import Data.Profunctor.Optic.Types-import Data.Profunctor.Optic.Operator-import Data.Semigroupoid-import Data.Semiring-import Control.Monad.Trans.State-import Prelude (Foldable(..), reverse)-import qualified Data.Functor.Rep as F--import Control.Applicative-import Data.Ord-import Data.Function-import Prelude-import Data.Semigroup.Foldable as F1-import Data.Foldable as F-import Data.List as L-import Data.List.NonEmpty as L1---- $setup--- >>> :set -XNoOverloadedStrings--- >>> :set -XFlexibleContexts--- >>> :set -XTypeApplications--- >>> :set -XTupleSections--- >>> :set -XRankNTypes--- >>> import Data.Maybe--- >>> import Data.List.NonEmpty (NonEmpty(..))--- >>> import Data.Functor.Identity--- >>> import Data.List.Index--- >>> :load Data.Profunctor.Optic-------------------------------------------------------------------------- 'Cotraversal'-------------------------------------------------------------------------- | Obtain a 'Cotraversal' by embedding a continuation into a 'Distributive' functor. ------ @---  'withGrate' o 'cotraversing' ≡ 'cotraversed' . o--- @------ /Caution/: In order for the generated optic to be well-defined,--- you must ensure that the input function satisfies the following--- properties:------ * @sabt ($ s) ≡ s@------ * @sabt (\k -> f (k . sabt)) ≡ sabt (\k -> f ($ k))@----cotraversing :: Distributive g => (((s -> a) -> b) -> t) -> Cotraversal (g s) (g t) a b-cotraversing sabt = corepn cotraverse . grate sabt---- | Obtain a 'Cotraversal' by embedding a reversed lens getter and setter into a 'Distributive' functor.------ @---  'withLens' ('re' o) 'cotraversing' ≡ 'cotraversed' . o--- @----retraversing :: Distributive g => (b -> t) -> (b -> s -> a) -> Cotraversal (g s) (g t) a b-retraversing bsa bt = corepn cotraverse . (re $ lens bsa bt)---- | Obtain a profunctor 'Cotraversal' from a Van Laarhoven 'Cotraversal'.------ /Caution/: In order for the generated optic to be well-defined,--- you must ensure that the input satisfies the following properties:------ * @abst runIdentity ≡ runIdentity@------ * @abst f . fmap (abst g) ≡ abst (f . fmap g . getCompose) . Compose@------ See 'Data.Profunctor.Optic.Property'.----cotraversalVl :: (forall f. Coapplicative f => (f a -> b) -> f s -> t) -> Cotraversal s t a b-cotraversalVl abst = cotabulate . abst . cosieve -------------------------------------------------------------------------- Optics-------------------------------------------------------------------------- | TODO: Document----cotraversed :: Distributive f => Cotraversal (f a) (f b) a b -cotraversed = cotraversalVl cotraverse-{-# INLINE cotraversed #-}-------------------------------------------------------------------------- Operators-------------------------------------------------------------------------- |------ @--- 'withCotraversal' $ 'Data.Profuncto.Optic.Grate.grate' (flip 'Data.Distributive.cotraverse' id) ≡ 'Data.Distributive.cotraverse'--- @------ The cotraversal laws can be restated in terms of 'withCotraversal':------ * @withCotraversal o (f . runIdentity) ≡  fmap f . runIdentity@------ * @withCotraversal o f . fmap (withCotraversal o g) == withCotraversal o (f . fmap g . getCompose) . Compose@------ See also < https://www.cs.ox.ac.uk/jeremy.gibbons/publications/iterator.pdf >----withCotraversal :: Coapplicative f => ACotraversal f s t a b -> (f a -> b) -> (f s -> t)-withCotraversal = withCostar-{-# INLINE withCotraversal #-}---- | TODO: Document------ >>> distributes left' (1, Left "foo")--- Left (1,"foo")------ >>> distributes left' (1, Right "foo")--- Right "foo"----distributes :: Coapplicative f => ACotraversal f s t a (f a) -> f s -> t-distributes o = withCotraversal o id-{-# INLINE distributes #-}

@@ -7,85 +7,84 @@ {-# LANGUAGE TypeFamilies          #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Data.Profunctor.Optic.Fold (-    -- * Fold & Ixfold-    Fold-  , Ixfold+    -- * Fold0+    Fold0+  , fold0+  , failing+  , toFold0+  , fromFold0 +    -- * Fold+  , Fold   , fold_   , folding    , foldVl-  , ifoldVl   , afold-  , aifold-    -- * Fold1 & Ixfold1+    -- * Fold1   , Fold1-  , Ixfold1   , fold1_   , folding1   , fold1Vl-  , ifold1Vl   , afold1-  , aifold1     -- * Optics+  , folded0+  , filtered   , folded   , folded_   , folded1    , folded1_-    -- * Indexed optics-  , ifolded-  , ifoldedRep-  , ifolded1-  , aifolded-  , aifolded1-    -- * Primitive operators-  , withFold-  , withIxfold-  , withFold1-  , withIxfold1     -- * Operators+  , (^?)+  , preview +  , preuse+  , is+  , isnt   , lists   , (^..)-  , ilists-  , ilistsFrom-  , (^%%)   , nelists   , folds-  , ifolds   , folds1   , foldsa   , foldsr-  , ifoldsr-  , ifoldsrFrom   , foldsl-  , ifoldsl-  , ifoldslFrom   , foldsr'-  , ifoldsr'   , foldsl'-  , ifoldsl'   , foldsrM-  , ifoldsrM   , foldslM-  , ifoldslM   , traverses_-  , itraverses_+  , concats+  , aconcats+  , mins +  , maxes+  , sums+  , multiplies+  , endo+  , endoM+  , finds+  , has+  , hasnt +  , contains     -- * Auxilliary Types   , Nedl(..) ) where +import Control.Applicative as A import Control.Monad (void) import Control.Monad.Reader as Reader hiding (lift)-import Data.Foldable (Foldable, foldMap, traverse_)+import Control.Monad.State as State hiding (lift)+import Data.Foldable (Foldable, traverse_) import Data.List.NonEmpty (NonEmpty(..))-import Data.Key as K+import Data.Maybe import Data.Monoid import Data.Semiring as Rng import Data.Profunctor.Optic.Carrier+import Data.Profunctor.Optic.Combinator import Data.Profunctor.Optic.Import import Data.Profunctor.Optic.Traversal import Data.Profunctor.Optic.Types+import Data.Profunctor.Optic.Prism import Data.Profunctor.Optic.View -import qualified Data.Functor.Rep as F+import Prelude (Ord,min,max) import qualified Data.List.NonEmpty as NEL  -- $setup@@ -95,7 +94,6 @@ -- >>> :set -XRankNTypes -- >>> import Control.Exception hiding (catches) -- >>> import Data.Functor.Identity--- >>> import Data.List.Index as LI -- >>> import Data.List.NonEmpty (NonEmpty(..)) -- >>> import qualified Data.List.NonEmpty as NE -- >>> import Data.Int@@ -103,12 +101,60 @@ -- >>> import Data.Maybe -- >>> import Data.Monoid -- >>> :load Data.Profunctor.Optic--- >>> let itraversed :: Ixtraversal Int [a] [b] a b ; itraversed = itraversalVl itraverse  ------------------------------------------------------------------------ 'Fold' & 'Ixfold'+-- 'Fold0' --------------------------------------------------------------------- +-- | Obtain a 'Fold0' directly.+--+-- @+-- 'fold0' . 'preview' ≡ id+-- 'fold0' ('view' o) ≡ o . 'just'+-- @+--+-- >>> 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)) . right'+{-# INLINE fold0 #-}++infixl 3 `failing`++-- | If the first 'Fold0' has no focus then try the second one.+--+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 #-}++-- | Obtain a 'Fold0' from a 'View'.+--+-- @+-- 'toFold0' o ≡ o . 'just'+-- 'toFold0' o ≡ 'fold0' ('view' o)+-- @+--+toFold0 :: View s (Maybe a) -> Fold0 s a+toFold0 = (. just)+{-# INLINE toFold0 #-}++-- | Obtain a 'View' from a 'Fold0' +--+fromFold0 ::  AFold0 a s a -> View s (Maybe a)+fromFold0 = to . preview+{-# INLINE fromFold0 #-}++---------------------------------------------------------------------+-- 'Fold'+---------------------------------------------------------------------+ -- | Obtain a 'Fold' directly. -- -- @ @@ -145,30 +191,14 @@ foldVl f = coercer . traversalVl f . coercer {-# INLINE foldVl #-} --- | Obtain a 'Ixfold' from a Van Laarhoven 'Fold'.----ifoldVl :: (forall f. Applicative f => (i -> a -> f b) -> s -> f t) -> Ixfold i s a-ifoldVl f = coercer . itraversalVl f . coercer-{-# INLINE ifoldVl #-}- -- | TODO: Document ----- @--- afold :: Monoid r => ((a -> r) -> s -> r) -> AFold r s a--- @----afold :: Monoid r => ((a -> r) -> s -> r) -> APrimView r s t a b-afold f = Star #. (Const #.) #. f .# (getConst #.) .# runStar+afold :: Monoid r => ((a -> r) -> s -> r) -> AFold r s a+afold = afold1 {-# INLINE afold #-} --- | TODO: Document----aifold :: Monoid r => ((i -> a -> r) -> s -> r) -> AIxfold r i s a-aifold f = afold $ \iar s -> f (curry iar) $ snd s-{-# INLINE aifold #-}- ------------------------------------------------------------------------ 'Fold1' & 'Ixfold1'+-- 'Fold1' ---------------------------------------------------------------------  -- | Obtain a 'Fold1' directly.@@ -206,32 +236,34 @@ fold1Vl f = coercer . repn f . coercer {-# INLINE fold1Vl #-} --- | Obtain a 'Ixfold1' from a Van Laarhoven 'Fold1'.----ifold1Vl :: (forall f. Apply f => (i -> a -> f b) -> s -> f t) -> Ixfold1 i s a-ifold1Vl f = coercer . itraversal1Vl f . coercer-{-# INLINE ifold1Vl #-}- -- | TODO: Document ----- @--- afold1 :: ((a -> r) -> s -> r) -> AFold1 r s a--- @----afold1 :: ((a -> r) -> s -> r) -> APrimView r s t a b+afold1 :: Semigroup r => ((a -> r) -> s -> r) -> AFold1 r s a afold1 f = Star #. (Const #.) #. f .# (getConst #.) .# runStar {-# INLINE afold1 #-} --- | TODO: Document----aifold1 :: ((i -> a -> r) -> s -> r) -> AIxfold1 r i s a-aifold1 f = afold1 $ \iar s -> f (curry iar) $ snd s-{-# INLINE aifold1 #-}- --------------------------------------------------------------------- -- Optics  --------------------------------------------------------------------- +-- | The canonical 'Fold0'. +--+-- >>> [Just 1, Nothing] ^.. folded . folded0+-- [1]+--+folded0 :: Fold0 (Maybe a) a+folded0 = fold0 id+{-# INLINE folded0 #-}++-- | Filter another optic.+--+-- >>> [1..10] ^.. folded . filtered even+-- [2,4,6,8,10]+--+filtered :: (a -> Bool) -> Fold0 a a+filtered p = traversal0Vl (\point f a -> if p a then f a else point a) . coercer+{-# INLINE filtered #-}+ -- | Obtain a 'Fold' from a 'Traversable' functor. -- folded :: Traversable f => Fold (f a) a@@ -265,104 +297,61 @@ {-# INLINE folded1_ #-}  ------------------------------------------------------------------------ Indexed optics +-- Operators --------------------------------------------------------------------- --- | Obtain an 'AIxfold' from a 'FoldableWithKey'.------ @--- f '^%%' 'ifolded' ≡ 'toKeyedList' f--- @----ifolded :: FoldableWithKey f => Ixfold (Key f) (f a) a-ifolded = ifoldVl K.traverseWithKey_-{-# INLINE ifolded #-}---- | Obtain an 'Ixfold' from a 'F.Representable' functor.----ifoldedRep :: F.Representable f => Traversable f => Ixfold (F.Rep f) (f a) a-ifoldedRep = ifoldVl F.itraverseRep-{-# INLINE ifoldedRep #-}---- | Obtain an 'Ixfold1' from a 'FoldableWithKey1'.----ifolded1 :: FoldableWithKey1 f => Ixfold1 (Key f) (f a) a-ifolded1 = ifold1Vl K.traverseWithKey1_-{-# INLINE ifolded1 #-}---- | Obtain an 'AIxfold' from a 'FoldableWithKey'.----aifolded :: FoldableWithKey f => Monoid r => AIxfold r (Key f) (f a) a-aifolded = aifold K.foldMapWithKey-{-# INLINE aifolded #-}---- | Obtain an 'AIxfold1' from a 'FoldableWithKey1'.----aifolded1 :: FoldableWithKey1 f => Semigroup r => AIxfold1 r (Key f) (f a) a-aifolded1 = aifold1 K.foldMapWithKey1-{-# INLINE aifolded1 #-}-------------------------------------------------------------------------- Primitive operators----------------------------------------------------------------------+infixl 8 ^? --- | Map an optic to a monoid and combine the results.+-- | An infix alias for 'preview''. -- -- @--- 'Data.Foldable.foldMap' = 'withFold' 'folded_'+-- ('^?') ≡ 'flip' 'preview'' -- @ ----- >>> withFold both id (["foo"], ["bar", "baz"])--- ["foo","bar","baz"]+-- Perform a safe 'head' of a 'Fold' or 'Traversal' or retrieve 'Just'+-- the result from a 'View' or 'Lens'. ----- >>> :t withFold traversed--- withFold traversed---   :: (Monoid r, Traversable f) => (a -> r) -> f a -> r+-- 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. ----- @--- 'withFold' :: 'Monoid' r => 'AFold' r s a -> (a -> r) -> s -> r--- @+-- >>> Left 4 ^? left'+-- Just 4+-- >>> Right 4 ^? left'+-- Nothing ---withFold :: Monoid r => APrimView r s t a b -> (a -> r) -> s -> r-withFold = withPrimView-{-# INLINE withFold #-}+(^?) :: s -> AFold0 a s a -> Maybe a+(^?) = flip preview+{-# INLINE (^?) #-} --- | Map an indexed optic to a monoid and combine the results.------ Note that most indexed optics do not use their output index:+-- | TODO: Document --+preview :: MonadReader s m => AFold0 a s a -> m (Maybe a)+preview o = Reader.asks $ withFold0 o Just+{-# INLINE preview #-}++-- | TODO: Document ---withIxfold :: Monoid r => AIxfold r i s a -> (i -> a -> r) -> i -> s -> r-withIxfold o f = curry $ withFold o (uncurry f)-{-# INLINE withIxfold #-}+preuse :: MonadState s m => AFold0 a s a -> m (Maybe a)+preuse o = State.gets $ preview o+{-# INLINE preuse #-} --- | Map an optic to a semigroup and combine the results.+-- | Check whether the optic is matched. ----- @--- 'withFold1' :: 'Semigroup' r => 'AFold1' r s a -> (a -> r) -> s -> r--- @+-- >>> is just Nothing+-- False ---withFold1 :: Semigroup r => APrimView r s t a b -> (a -> r) -> s -> r-withFold1 = withPrimView-{-# INLINE withFold1 #-}+is :: AFold0 a s a -> s -> Bool+is o s = isJust (preview o s)+{-# INLINE is #-} --- | Map an indexed optic to a semigroup and combine the results.------ >>> :t flip withIxfold1 Map.singleton--- flip withIxfold1 Map.singleton---   :: Ord i => AIxfold1 (Map i a) i s a -> i -> s -> Map i a+-- | Check whether the optic isn't matched. ----- @--- 'withIxfold1' :: 'Semigroup' r => 'AIxfold1' r s a -> (i -> a -> r) -> i -> s -> r--- @+-- >>> isnt just Nothing+-- True ---withIxfold1 :: Semigroup r => AIxfold1 r i s a -> (i -> a -> r) -> i -> s -> r-withIxfold1 o f = curry $ withFold1 o (uncurry f)-{-# INLINE withIxfold1 #-}-------------------------------------------------------------------------- Operators----------------------------------------------------------------------+isnt :: AFold0 a s a -> s -> Bool+isnt o s = not (isJust (preview o s))+{-# INLINE isnt #-}  -- | Collect the foci of an optic into a list. --@@ -396,43 +385,13 @@ -- ('^..') :: s -> 'Iso'' s a       -> [a] -- ('^..') :: s -> 'Traversal'' s a -> [a] -- ('^..') :: s -> 'Prism'' s a     -> [a]--- ('^..') :: s -> 'Affine'' s a    -> [a]+-- ('^..') :: s -> 'Traversal0'' s a    -> [a] -- @ -- (^..) :: s -> AFold (Endo [a]) s a -> [a] (^..) = flip lists {-# INLINE (^..) #-} --- | Collect the foci of an indexed optic into a list of index-value pairs.------ This is only for use with the few indexed optics that don't ignore their --- output index. You most likely want to use 'ilists'.----ilistsFrom :: AIxfold (Endo [(i, a)]) i s a -> i -> s -> [(i, a)]-ilistsFrom o i = ifoldsrFrom o (\i a -> ((i,a):)) i []-{-# INLINE ilistsFrom #-}---- | Collect the foci of an indexed optic into a list of index-value pairs.------ @--- 'lists' l ≡ 'map' 'snd' '.' 'ilists' l--- @------ >>> ilists (itraversed . imapping swapped) [(40,'f'),(41,'o'),(42,'o')]--- [(0,('f',40)),(1,('o',41)),(2,('o',42))]----ilists :: (Additive-Monoid) i => AIxfold (Endo [(i, a)]) i s a -> s -> [(i, a)]-ilists o = ifoldsr o (\i a -> ((i,a):)) []-{-# INLINE ilists #-}--infixl 8 ^%%---- | Infix version of 'ilists'.----(^%%) :: (Additive-Monoid) i => s -> AIxfold (Endo [(i, a)]) i s a -> [(i, a)]-(^%%) = flip ilists-{-# INLINE (^%%) #-}- -- | Extract a 'NonEmpty' of the foci of an optic. -- -- >>> nelists bitraversed1 ('h' :| "ello", 'w' :| "orld")@@ -450,12 +409,6 @@  -- | TODO: Document ---ifolds :: (Additive-Monoid) i => Monoid a => AIxfold (Additive i, a) i s a -> s -> (i, a)-ifolds o = first unAdditive . withIxfold o (\i a -> (Additive i, a)) zero-{-# INLINE ifolds #-}---- | TODO: Document--- folds1 :: Semigroup a => AFold1 a s a -> s -> a folds1 = flip withFold1 id {-# INLINE folds1 #-}@@ -480,72 +433,18 @@ foldsr o f r = (`appEndo` r) . withFold o (Endo . f) {-# INLINE foldsr #-} --- | Indexed right fold over an indexed optic.------ @--- 'foldsr' o ≡ 'ifoldsr' o '.' 'const'--- 'foldrWithKey' f ≡ 'ifoldsr' 'ifolded' f--- @------ >>> ifoldsr itraversed (\i a -> ((show i ++ ":" ++ show a ++ ", ") ++)) [] [1,3,5,7,9]--- "0:1, 1:3, 2:5, 3:7, 4:9, "----ifoldsr :: (Additive-Monoid) i => AIxfold (Endo r) i s a -> (i -> a -> r -> r) -> r -> s -> r-ifoldsr o f = ifoldsrFrom o f zero-{-# INLINE ifoldsr #-}---- | Indexed right fold over an indexed optic, using an initial index value.------ This is only for use with the few indexed optics that don't ignore their --- output index. You most likely want to use 'ifoldsr'.----ifoldsrFrom :: AIxfold (Endo r) i s a -> (i -> a -> r -> r) -> i -> r -> s -> r-ifoldsrFrom o f i r = (`appEndo` r) . withIxfold o (\j -> Endo . f j) i-{-# INLINE ifoldsrFrom #-}- -- | Left fold over an optic. -- foldsl :: AFold ((Endo-Dual) r) s a -> (r -> a -> r) -> r -> s -> r foldsl o f r = (`appEndo` r) . getDual . withFold o (Dual . Endo . flip f) {-# INLINE foldsl #-} --- | Left fold over an indexed optic.------ @--- 'foldsl' o ≡ 'ifoldsl' o '.' 'const'--- 'foldlWithKey' f ≡ 'ifoldsl' 'ifolded' f--- @----ifoldsl :: (Additive-Monoid) i => AIxfold ((Endo-Dual) r) i s a -> (i -> r -> a -> r) -> r -> s -> r-ifoldsl o f = ifoldslFrom o f zero-{-# INLINE ifoldsl #-}---- | Left fold over an indexed optic, using an initial index value.------ This is only for use with the few indexed optics that don't ignore their --- output index. You most likely want to use 'ifoldsl'.----ifoldslFrom :: AIxfold ((Endo-Dual) r) i s a -> (i -> r -> a -> r) -> i -> r -> s -> r-ifoldslFrom o f i r = (`appEndo` r) . getDual . withIxfold o (\i -> Dual . Endo . flip (f i)) i-{-# INLINE ifoldslFrom #-}- -- | Strict right fold over an optic. -- foldsr' :: AFold ((Endo-Dual) (Endo r)) s a -> (a -> r -> r) -> r -> s -> r foldsr' l f z0 xs = foldsl l f' (Endo id) xs `appEndo` z0 where f' (Endo k) x = Endo $ \ z -> k $! f x z {-# INLINE foldsr' #-} --- | Strict right fold over an indexed optic.------ @--- 'foldsr'' o ≡ 'ifoldsr'' o '.' 'const'--- 'foldrWithKey'' f ≡ 'ifoldsr'' 'ifolded' f--- @----ifoldsr' :: (Additive-Monoid) i => AIxfold ((Endo-Dual) (r -> r)) i s a -> (i -> a -> r -> r) -> r -> s -> r-ifoldsr' l f z0 xs = ifoldsl l f' id xs z0 where f' i k x z = k $! f i x z-{-# INLINE ifoldsr' #-}- -- | Strict left fold over an optic. -- -- @@@ -558,56 +457,25 @@ -- 'foldsl'' :: 'View' s a        -> (c -> a -> c) -> c -> s -> c -- 'foldsl'' :: 'Fold' s a        -> (c -> a -> c) -> c -> s -> c -- 'foldsl'' :: 'Traversal'' s a  -> (c -> a -> c) -> c -> s -> c--- 'foldsl'' :: 'Affine'' s a -> (c -> a -> c) -> c -> s -> c+-- 'foldsl'' :: 'Traversal0'' s a -> (c -> a -> c) -> c -> s -> 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' #-} --- | Strict left fold over an indexed optic.------ @--- 'foldsl'' o ≡ 'ifoldsl'' o '.' 'const'--- 'foldlWithKey'' f ≡ 'ifoldsl'' 'ifolded' f--- @----ifoldsl' :: (Additive-Monoid) i => AIxfold (Endo (r -> r)) i s a -> (i -> r -> a -> r) -> r -> s -> r-ifoldsl' l f z0 xs = ifoldsr l f' id xs z0 where f' i x k z = k $! f i z x-{-# INLINE ifoldsl' #-}- -- | Monadic right fold over an optic. -- foldsrM :: Monad m => AFold ((Endo-Dual) (r -> m r)) s a -> (a -> r -> m r) -> r -> s -> m r foldsrM l f z0 xs = foldsl l f' return xs z0 where f' k x z = f x z >>= k {-# INLINE foldsrM #-} --- | Monadic right fold over an indexed optic.------ @--- 'foldsrM' ≡ 'ifoldrM' '.' 'const'--- @----ifoldsrM :: (Additive-Monoid) i => Monad m => AIxfold ((Endo-Dual) (r -> m r)) i s a -> (i -> a -> r -> m r) -> r -> s -> m r-ifoldsrM o f z0 xs = ifoldsl o f' return xs z0 where f' i k x z = f i x z >>= k-{-# INLINE ifoldsrM #-}- -- | Monadic left fold over an optic. -- foldslM :: Monad m => AFold (Endo (r -> m r)) s a -> (r -> a -> m r) -> r -> s -> m r foldslM o f z0 xs = foldsr o f' return xs z0 where f' x k z = f z x >>= k {-# INLINE foldslM #-} --- | Monadic left fold over an indexed optic.------ @--- 'foldslM' ≡ 'ifoldslM' '.' 'const'--- @----ifoldslM :: (Additive-Monoid) i => Monad m => AIxfold (Endo (r -> m r)) i s a -> (i -> r -> a -> m r) -> r -> s -> m r-ifoldslM o f z0 xs = ifoldsr o f' return xs z0 where f' i x k z = f i z x >>= k-{-# INLINE ifoldslM #-}- -- | Applicative fold over an optic. -- -- >>> traverses_ both putStrLn ("hello","world")@@ -622,11 +490,100 @@ traverses_ p f = foldsr p (\a fu -> void (f a) *> fu) (pure ()) {-# INLINE traverses_ #-} --- | Applicative fold over an indexed optic.+-- | Map a function over the foci of an optic and concatenate the resulting lists. ---itraverses_ :: (Additive-Monoid) i => Applicative f => AIxfold (Endo (f ())) i s a -> (i -> a -> f r) -> s -> f ()-itraverses_ p f = ifoldsr p (\i a fu -> void (f i a) *> fu) (pure ())-{-# INLINE itraverses_ #-}+-- >>> 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 #-}++-- | The sum of a collection of actions, generalizing 'concats'.+--+-- >>> aconcats both ("hello","world")+-- "helloworld"+--+-- >>> aconcats both (Nothing, Just "hello")+-- Just "hello"+--+-- @+-- 'asum' ≡ 'aconcats' 'folded'+-- @+--+aconcats :: Alternative f => AFold ((Endo-Endo) (f a)) s (f a) -> s -> f a+aconcats o = foldsl' o (<|>) A.empty+{-# INLINE aconcats #-}++-- | Compute the minimum of the targets of a totally ordered fold. +--+mins :: Ord a => AFold ((Endo-Endo) a) s a -> a -> s -> a+mins o = foldsl' o min++-- | Compute the maximum of the targets of a totally ordered fold.+--+maxes :: Ord a => AFold ((Endo-Endo) a) s a -> a -> s -> a+maxes o = foldsl' o max++-- | The sum of a collection.+--+sums :: (Additive-Monoid) a => AFold ((Endo-Endo) a) s a -> s -> a+sums o = foldsl' o (+) zero++-- | The product of a collection.+--+multiplies :: (Multiplicative-Monoid) a => AFold ((Endo-Endo) a) s a -> s -> a+multiplies o = foldsl' o (*) one+++-- | TODO: Document+--+endo :: AFold (Endo (a -> a)) s (a -> a) -> s -> a -> a+endo o = foldsr o (.) id++-- | TODO: Document+--+endoM :: Monad m => AFold (Endo (a -> m a)) s (a -> m a) -> s -> a -> m a+endoM o = foldsr o (<=<) pure++-- | Find the first focus of an optic that satisfies a predicate, if one exists.+--+-- >>> finds both even (1,4)+-- Just 4+--+-- >>> finds folded even [1,3,5,7]+-- Nothing+--+-- @+-- 'Data.Foldable.find' ≡ 'finds' 'folded'+-- @+--+finds :: AFold ((Maybe-Endo) 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 (Additive Bool) s a -> s -> Bool+has o s = unAdditive $ withFold o (const $ Additive True) s+{-# INLINE has #-}++-- | Determine whether an optic does not have a focus.+--+hasnt :: AFold (Multiplicative Bool) s a -> s -> Bool+hasnt o s = unMultiplicative $ withFold o (const $ Multiplicative False) s+{-# INLINE hasnt #-}++-- | Determine whether the targets of a `Fold` contain a given element.+--+contains :: Eq a => AFold (Additive Bool) s a -> a -> s -> Bool+contains o a s = unAdditive $ withFold o (\x -> Additive $ x == a) s+{-# INLINE contains #-}+  ------------------------------------------------------------------------------ -- Auxilliary Types

@@ -1,343 +0,0 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TupleSections         #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE TypeFamilies          #-}-module Data.Profunctor.Optic.Grate  (-    -- * Grate & Cxgrate-    Grate-  , Grate'-  , Cxgrate-  , Cxgrate'-  , grate-  , grateVl-  , kgrateVl-  , inverting-  , cloneGrate-    -- * Optics-  , represented-  , distributed-  , endomorphed-  , connected-  , continued-  , continuedT-  , calledCC-  , unlifted-    -- * Indexed optics-  , kclosed-  , kfirst-  , ksecond-  , coindexed-    -- * Primitive operators-  , withGrate -  , withGrateVl-    -- * Operators-  , coview-  , zipsWith-  , kzipsWith-  , zipsWith3-  , zipsWith4 -  , toClosure-  , toEnvironment-    -- * Classes-  , Closed(..)-  , Costrong(..)-) where--import Control.Monad.Reader-import Control.Monad.Cont-import Control.Monad.IO.Unlift-import Data.Distributive-import Data.Connection (Conn(..))-import Data.Monoid (Endo(..))-import Data.Profunctor.Closed-import Data.Profunctor.Optic.Carrier-import Data.Profunctor.Optic.Types-import Data.Profunctor.Optic.Import-import Data.Profunctor.Optic.Index-import Data.Profunctor.Optic.Iso (tabulated)--import Prelude (IO)-import qualified Data.Functor.Rep as F---- $setup--- >>> :set -XNoOverloadedStrings--- >>> :set -XTypeApplications--- >>> :set -XFlexibleContexts--- >>> :set -XTupleSections--- >>> import Control.Exception--- >>> import Control.Monad.Reader--- >>> import Data.Complex--- >>> import Data.Connection.Int--- >>> import Data.List as L--- >>> import Data.Monoid (Endo(..))--- >>> :load Data.Profunctor.Optic-------------------------------------------------------------------------- 'Grate'-------------------------------------------------------------------------- | 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 fied length vector (e.g. 'V2 a').------ The identity container is representable, and representable functors --- are closed under composition.------ 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>.------ /Caution/: In order for the generated optic to be well-defined,--- you must ensure that the input function satisfies the following--- properties:------ * @sabt ($ s) ≡ s@------ * @sabt (\k -> f (k . sabt)) ≡ sabt (\k -> f ($ k))@------ 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'.----grate :: (((s -> a) -> b) -> t) -> Grate s t a b-grate sabt = dimap (flip ($)) sabt . closed---- | Transform a Van Laarhoven grate into a profunctor grate.------ Compare 'Data.Profunctor.Optic.Lens.lensVl' & 'Data.Profunctor.Optic.Traversal.cotraversalVl'.------ /Caution/: In order for the generated family to be well-defined,--- you must ensure that the traversal1 law holds for the input function:------ * @abst runIdentity ≡ runIdentity@------ * @abst f . fmap (abst g) ≡ abst (f . fmap g . getCompose) . Compose@------ See 'Data.Profunctor.Optic.Property'.----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----kgrateVl :: (forall f. Functor f => (k -> f a -> b) -> f s -> t) -> Cxgrate k s t a b-kgrateVl 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-inverting sa bt = grate $ \sab -> bt (sab sa)---- | TODO: Document----cloneGrate :: AGrate s t a b -> Grate s t a b-cloneGrate k = withGrate k grate-------------------------------------------------------------------------- Optics -------------------------------------------------------------------------- | Obtain a 'Grate' from a 'F.Representable' functor.----represented :: F.Representable f => Grate (f a) (f b) a b-represented = tabulated . closed-{-# INLINE represented #-}---- | Obtain a 'Grate' from a distributive functor.----distributed :: Distributive f => Grate (f a) (f b) a b-distributed = grate (`cotraverse` id)-{-# INLINE distributed #-}---- | Obtain a 'Grate' from an endomorphism. ------ >>> flip appEndo 2 $ zipsWith endomorphed (+) (Endo (*3)) (Endo (*4))--- 14----endomorphed :: Grate' (Endo a) a-endomorphed = dimap appEndo Endo . closed-{-# INLINE endomorphed #-}---- | Obtain a 'Grate' from a Galois connection.------ 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.------ >>> zipsWith (connected i08i16) (+) 126 1--- 127--- >>> zipsWith (connected i08i16) (+) 126 2--- 127----connected :: Conn s a -> Grate' s a-connected (Conn f g) = inverting f g-{-# INLINE connected #-}---- | Obtain a 'Grate' from a continuation.------ @--- 'zipsWith' 'continued' :: (r -> r -> r) -> s -> s -> 'Cont' r s--- @----continued :: Grate a (Cont r a) r r-continued = grate cont-{-# INLINE continued #-}---- | Obtain a 'Grate' from a continuation.------ @--- 'zipsWith' 'continued' :: (m r -> m r -> m r) -> s -> s -> 'ContT' r m s --- @----continuedT :: Grate a (ContT r m a) (m r) (m r)-continuedT = grate ContT-{-# INLINE continuedT #-}---- | Lift the current continuation into the calling context.------ @--- 'zipsWith' 'calledCC' :: 'MonadCont' m => (m b -> m b -> m s) -> s -> s -> m s--- @----calledCC :: MonadCont m => Grate a (m a) (m b) (m a)-calledCC = grate callCC-{-# INLINE calledCC #-}---- | Unlift an action into an 'IO' context.------ @--- 'liftIO' ≡ 'coview' 'unlifted'--- @------ >>> let catchA = catch @ArithException--- >>> zipsWith 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 #-}-------------------------------------------------------------------------- Indexed optics-------------------------------------------------------------------------- >>> kover kclosed (,) (*2) 5--- ((),10)----kclosed :: Cxgrate k (c -> a) (c -> b) a b-kclosed = rmap flip . closed-{-# INLINE kclosed #-}---- | TODO: Document----kfirst :: Cxgrate k a b (a , c) (b , c)-kfirst = rmap (unfirst . uncurry . flip) . curry'-{-# INLINE kfirst #-}---- | TODO: Document----ksecond :: Cxgrate k a b (c , a) (c , b)-ksecond = rmap (unsecond . uncurry) . curry' . lmap swap-{-# INLINE ksecond #-}---- | Obtain a 'Cxgrate' from a representable functor.------ >>> kzipsWith (coindexed @Complex) (\t -> if t then (+) else (*)) (2 :+ 2) (3 :+ 4)--- 6 :+ 6------ See also 'Data.Profunctor.Optic.Lens.indexed'.----coindexed :: F.Representable f => (Additive-Monoid) (F.Rep f) => Cxgrate (F.Rep f) (f a) (f b) a b-coindexed = kgrateVl grateRep-{-# INLINE coindexed #-}--grateRep :: F.Representable f => forall g. Functor g => (F.Rep f -> g a1 -> a2) -> g (f a1) -> f a2-grateRep iab s = F.tabulate $ \i -> iab i (fmap (`F.index` i) s)-{-# INLINE grateRep #-}-------------------------------------------------------------------------- Primitive operators-------------------------------------------------------------------------- | Extract the higher order function that characterizes a 'Grate'.------ The grate laws can be stated in terms or 'withGrate':--- --- Identity:--- --- @--- withGrateVl o runIdentity ≡ runIdentity--- @--- --- Composition:--- --- @ --- withGrateVl o f . fmap (withGrateVl o g) ≡ withGrateVl o (f . fmap g . getCompose) . Compose--- @----withGrateVl :: Functor f => AGrate s t a b -> (f a -> b) -> f s -> t-withGrateVl o ab s = withGrate o $ \sabt -> sabt $ \get -> ab (fmap get s)-{-# INLINE withGrateVl #-}-------------------------------------------------------------------------- Operators-------------------------------------------------------------------------- | Set all fields to the given value.------ This is essentially a restricted variant of 'Data.Profunctor.Optic.View.review'.----coview :: AGrate s t a b -> b -> t-coview o b = withGrate o $ \sabt -> sabt (const b)-{-# INLINE coview #-}---- | Zip over a 'Grate'. ------ @\\f -> 'zipsWith' 'closed' ('zipsWith' 'closed' f) ≡ 'zipsWith' ('closed' . 'closed')@----zipsWith :: AGrate s t a b -> (a -> a -> b) -> s -> s -> t-zipsWith o aab s1 s2 = withGrate o $ \sabt -> sabt $ \get -> aab (get s1) (get s2)-{-# INLINE zipsWith #-}--kzipsWith :: (Additive-Monoid) k => ACxgrate k s t a b -> (k -> a -> a -> b) -> s -> s -> t-kzipsWith o kaab s1 s2 = withCxgrate o $ \sakbt -> sakbt $ \sa k -> kaab k (sa s1) (sa s2)-{-# INLINE kzipsWith #-}---- | Zip over a 'Grate' with 3 arguments.----zipsWith3 :: AGrate s t a b -> (a -> a -> a -> b) -> (s -> s -> s -> t)-zipsWith3 o aaab s1 s2 s3 = withGrate o $ \sabt -> sabt $ \sa -> aaab (sa s1) (sa s2) (sa s3)-{-# INLINE zipsWith3 #-}---- | Zip over a 'Grate' with 4 arguments.----zipsWith4 :: AGrate s t a b -> (a -> a -> a -> a -> b) -> (s -> s -> s -> s -> t)-zipsWith4 o aaaab s1 s2 s3 s4 = withGrate o $ \sabt -> sabt $ \sa -> aaaab (sa s1) (sa s2) (sa s3) (sa s4)-{-# INLINE zipsWith4 #-}---- | Use a 'Grate' to construct a 'Closure'.----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 #-}---- | Use a 'Grate' to construct an 'Environment'.----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 #-}

@@ -10,21 +10,25 @@  import Control.Arrow as Export ((|||),(&&&),(+++),(***)) import Control.Applicative as Export (liftA2, Alternative(..))+import Control.Coapplicative as Export hiding (apply, branch) import Control.Category as Export hiding ((.), id) import Control.Monad as Export hiding (void, join)+import Data.Bifunctor as Export+import Data.Bool as Export import Data.Distributive as Export+import Data.Foldable as Export (foldr') import Data.Function as Export ((&)) import Data.Functor as Export hiding (void) import Data.Functor.Apply as Export+import Data.Functor.Coapply as Export hiding (apply, branch) import Data.Semigroup.Foldable as Export import Data.Semigroup.Traversable as Export-import Data.Semiring as Export (type (-), Additive(..), Multiplicative(..))+import Data.Semiring as Export hiding (eval) import Data.Foldable as Export (foldr) import Data.Functor.Compose as Export import Data.Functor.Const as Export import Data.Functor.Contravariant as Export import Data.Functor.Identity as Export-import Data.Profunctor.Extra as Export import Data.Profunctor.Unsafe as Export import Data.Profunctor.Types as Export import Data.Profunctor.Strong as Export (Strong(..), Costrong(..))@@ -32,6 +36,8 @@ import Data.Profunctor.Closed as Export (Closed(..)) import Data.Profunctor.Sieve as Export (Sieve(..), Cosieve(..)) import Data.Profunctor.Rep as Export (Representable(..), Corepresentable(..))+import Data.Tuple as Export import Data.Tagged as Export import Data.Void as Export-import Numeric.Prelude as Export+import Test.Logic as Export+import Prelude as Export hiding (Num(..),subtract,sum,product,(^))

@@ -1,379 +0,0 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TupleSections         #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeApplications      #-}-{-# LANGUAGE DeriveGeneric         #-}-module Data.Profunctor.Optic.Index ( -    -- * Indexing-    (%)-  , iinit-  , ilast-  , reix-  , imap-  , withIxrepn-    -- * Coindexing-  , (#)-  , kinit-  , klast-  , recx-  , kmap-  , cxed-  , kjoin-  , kreturn-  , type Cx'-  , kunit-  , kpastro-  , kfirst'-  , withCxrepn-    -- * Index-  , Index(..)-  , vals-  , info-    -- * Coindex-  , Coindex(..)-  , trivial-  , noindex-  , coindex-  , (.#.)-    -- * Coindex-  , Conjoin(..)-) where--import Control.Arrow as Arrow-import Control.Category (Category)-import Control.Monad-import Control.Monad.Fix-import Data.Profunctor.Closed-import Data.Profunctor.Rep-import Data.Profunctor.Sieve--import Data.Bifunctor as B-import Data.Foldable-import Data.Semigroup-import Data.Profunctor.Optic.Import as I-import Data.Profunctor.Optic.Types-import Data.Profunctor.Strong-import GHC.Generics (Generic)--import qualified Control.Category as C-------------------------------------------------------------------------- Indexing------------------------------------------------------------------------infixr 8 %--(%) :: (Additive-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 I.+ ia, a1)-{-# INLINE (%) #-}--{--iadd :: Profunctor p => IndexedOptic p i s t a b -> IndexedOptic p (Additive i) s t a b-iadd = reix Additive unAdditive--imul :: Profunctor p => IndexedOptic p i s t a b -> IndexedOptic p (Multiplicative i) s t a b-imul = reix Multiplicative unMultiplicative--}-iinit :: Profunctor p => IndexedOptic p i s t a b -> IndexedOptic p (First i) s t a b-iinit = reix First getFirst--ilast :: Profunctor p => IndexedOptic p i s t a b -> IndexedOptic p (Last i) s t a b-ilast = reix Last getLast----- | Map over the indices of an indexed optic.------ 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) .)--imap :: Profunctor p => (s -> a) -> (b -> t) -> IndexedOptic p i s t a b-imap 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 /./.----(#) :: (Additive-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 I.+ ka)-{-# INLINE (#) #-}--kinit :: Profunctor p => CoindexedOptic p k s t a b -> CoindexedOptic p (First k) s t a b-kinit = recx First getFirst--klast :: Profunctor p => CoindexedOptic p k s t a b -> CoindexedOptic p (Last k) s t a b-klast = 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) .)--kmap :: Profunctor p => (s -> a) -> (b -> t) -> CoindexedOptic p k s t a b -kmap 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 kjoin kreturn--kjoin :: Strong p => Cx p a a b -> p a b-kjoin = peval--kreturn :: Profunctor p => p a b -> Cx p k a b-kreturn = rmap const--kunit :: Strong p => Cx' p :-> p-kunit p = dimap fork apply (first' p)--kpastro :: Profunctor p => Iso (Cx' p a b) (Cx' p c d) (Pastro p a b) (Pastro p c d)-kpastro = 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>.----kfirst' :: Profunctor p => Cx' p a b -> Cx' p (a, c) (b, c)-kfirst' = 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 s ≡ forall f. 'Functor' f => (a -> f b) -> f s@,------ See also 'Data.Profunctor.Optic.Lens.withLensVl'.----data Index a b s = Index a (b -> s) deriving Generic--vals :: Index a b s -> b -> s-vals (Index _ bs) = bs-{-# INLINE vals #-}--info :: Index a b s -> a-info (Index a _) = a-{-# INLINE info #-}--instance Functor (Index a b) where-  fmap f (Index a bs) = Index a (f . bs)-  {-# INLINE fmap #-}--instance Profunctor (Index a) where-  dimap f g (Index a bs) = Index a (g . bs . f)-  {-# INLINE dimap #-}--instance a ~ b => Foldable (Index a b) where-  foldMap f (Index b bs) = f . bs $ b-------------------------------------------------------------------------- Coindex-------------------------------------------------------------------------- | An indexed continuation that characterizes a 'Data.Profunctor.Optic.Grate.Grate'------ @'Coindex' a b s ≡ forall f. 'Functor' f => (f a -> b) -> f s@,------ See also 'Data.Profunctor.Optic.Grate.withGrateVl'.------ '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 s = Coindex { runCoindex :: (s -> a) -> b } deriving Generic--instance Functor (Coindex a b) where-  fmap sl (Coindex abs) = Coindex $ \la -> abs (la . sl)--instance a ~ b => Apply (Coindex a b) where-  (Coindex slab) <.> (Coindex abs) = Coindex $ \la -> slab $ \sl -> abs (la . sl) --instance a ~ b => Applicative (Coindex a b) where-  pure s = Coindex ($s)-  (<*>) = (<.>)--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 s => (a -> b) -> Coindex a b s-noindex f = Coindex $ \a -> f (a mempty)--coindex :: Functor f => s -> (a -> b) -> Coindex (f a) (f b) s-coindex s ab = Coindex $ \sfa -> fmap ab (sfa s)-{-# INLINE coindex #-}--infixr 9 .#.---- | Compose two coindexes.------ When /s/ 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 s => Coindex b c s -> Coindex a b s -> Coindex a c s-Coindex f .#. Coindex g = Coindex $ \b -> f $ \s1 -> g $ \s2 -> b (s1 <> s2)-------------------------------------------------------------------------- Conjoin-------------------------------------------------------------------------- '(->)' is simultaneously both indexed and co-indexed.-newtype Conjoin j a b = Conjoin { unConjoin :: j -> a -> b }--instance Functor (Conjoin j a) where-  fmap g (Conjoin f) = Conjoin $ \j a -> g (f j a)-  {-# INLINE fmap #-}--instance Apply (Conjoin j a) where-  Conjoin f <.> Conjoin g = Conjoin $ \j a -> f j a (g j a)-  {-# INLINE (<.>) #-}--instance Applicative (Conjoin j a) where-  pure b = Conjoin $ \_ _ -> b-  {-# INLINE pure #-}-  Conjoin f <*> Conjoin g = Conjoin $ \j a -> f j a (g j a)-  {-# INLINE (<*>) #-}--instance Monad (Conjoin j a) where-  return = pure-  {-# INLINE return #-}-  Conjoin f >>= k = Conjoin $ \j a -> unConjoin (k (f j a)) j a-  {-# INLINE (>>=) #-}--instance MonadFix (Conjoin j a) where-  mfix f = Conjoin $ \ j a -> let o = unConjoin (f o) j a in o-  {-# INLINE mfix #-}--instance Profunctor (Conjoin j) where-  dimap ab cd jbc = Conjoin $ \j -> cd . unConjoin jbc j . ab-  {-# INLINE dimap #-}-  lmap ab jbc = Conjoin $ \j -> unConjoin jbc j . ab-  {-# INLINE lmap #-}-  rmap bc jab = Conjoin $ \j -> bc . unConjoin jab j-  {-# INLINE rmap #-}--instance Closed (Conjoin j) where-  closed (Conjoin jab) = Conjoin $ \j xa x -> jab j (xa x)--instance Costrong (Conjoin j) where-  unfirst (Conjoin jadbd) = Conjoin $ \j a -> let-      (b, d) = jadbd j (a, d)-    in b--instance Sieve (Conjoin j) ((->) j) where-  sieve = flip . unConjoin-  {-# INLINE sieve #-}--instance Representable (Conjoin j) where-  type Rep (Conjoin j) = (->) j-  tabulate = Conjoin . flip-  {-# INLINE tabulate #-}--instance Cosieve (Conjoin j) ((,) j) where-  cosieve = uncurry . unConjoin-  {-# INLINE cosieve #-}--instance Corepresentable (Conjoin j) where-  type Corep (Conjoin j) = (,) j-  cotabulate = Conjoin . curry-  {-# INLINE cotabulate #-}--instance Choice (Conjoin j) where-  right' = right-  {-# INLINE right' #-}--instance Strong (Conjoin j) where-  second' = Arrow.second-  {-# INLINE second' #-}--instance Category (Conjoin j) where-  id = Conjoin (const id)-  {-# INLINE id #-}-  Conjoin f . Conjoin g = Conjoin $ \j -> f j . g j-  {-# INLINE (.) #-}--instance Arrow (Conjoin j) where-  arr f = Conjoin (\_ -> f)-  {-# INLINE arr #-}-  first f = Conjoin (Arrow.first . unConjoin f)-  {-# INLINE first #-}-  second f = Conjoin (Arrow.second . unConjoin f)-  {-# INLINE second #-}-  Conjoin f *** Conjoin g = Conjoin $ \j -> f j *** g j-  {-# INLINE (***) #-}-  Conjoin f &&& Conjoin g = Conjoin $ \j -> f j &&& g j-  {-# INLINE (&&&) #-}--instance ArrowChoice (Conjoin j) where-  left f = Conjoin (left . unConjoin f)-  {-# INLINE left #-}-  right f = Conjoin (right . unConjoin f)-  {-# INLINE right #-}-  Conjoin f +++ Conjoin g = Conjoin $ \j -> f j +++ g j-  {-# INLINE (+++)  #-}-  Conjoin f ||| Conjoin g = Conjoin $ \j -> f j ||| g j-  {-# INLINE (|||) #-}--instance ArrowApply (Conjoin j) where-  app = Conjoin $ \i (f, b) -> unConjoin f i b-  {-# INLINE app #-}--instance ArrowLoop (Conjoin j) where-  loop (Conjoin f) = Conjoin $ \j b -> let (c,d) = f j (b, d) in c-  {-# INLINE loop #-}

@@ -14,8 +14,6 @@   , Iso'   , iso   , isoVl-  , imapping-  , kmapping   , fmapping   , contramapping   , dimapping@@ -41,18 +39,14 @@   , coswapped    , associated    , coassociated-  , involuted -  , added -  , subtracted-  , non +  , involuted   , anon+  , non      -- * Primitive operators   , withIso     -- * Operators   , invert   , reover-  , reixed-  , recxed   , op   , au    , aup@@ -64,11 +58,10 @@ import Control.Newtype.Generics (Newtype(..), op) import Data.Coerce import Data.Functor.Adjunction hiding (adjuncted)-import Data.Group import Data.Maybe (fromMaybe) import Data.Profunctor.Optic.Carrier import Data.Profunctor.Optic.Import-import Data.Profunctor.Optic.Index+import Data.Profunctor.Optic.Combinator import Data.Profunctor.Optic.Types import Data.Profunctor.Yoneda (Coyoneda(..), Yoneda(..)) @@ -130,18 +123,6 @@         g = runIdentity . (abst (Identity . getConst)) . Const {-# INLINE isoVl #-} --- | Lift an 'Iso' into an indexed version. ----imapping :: Profunctor p => AIso s t a b -> IndexedOptic p i s t a b-imapping o = withIso o imap-{-# INLINE imapping #-}---- | Lift an 'Iso' into a coindexed version. ----kmapping :: Profunctor p => AIso s t a b -> CoindexedOptic p k s t a b-kmapping o = withIso o kmap-{-# INLINE kmapping #-}- -- | Lift an 'Iso' into a pair of functors. -- fmapping :: Functor f => Functor g => AIso s t a b -> Iso (f s) (g t) (f a) (g b)@@ -345,33 +326,22 @@ involuted = M.join iso {-# INLINE involuted #-} --- | 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.+-- | Generalize @'non' a@ to take any value and a predicate. ----- @--- 'subtracted' n = 're' ('added' n)--- @+-- Assumes that @p a@ holds @'True'@ and generates an isomorphism between @'Maybe' (a | 'not' (p a))@ and @a@. ---subtracted :: Group a => a -> Iso' a a-subtracted n = iso (<< n) (<> n)-{-# INLINE subtracted #-}+anon :: a -> (a -> Bool) -> Iso' (Maybe a) a+anon a p = iso (fromMaybe a) go where+  go b | p b       = Nothing+       | otherwise = Just b+{-# INLINE anon #-}  -- | Remove a single value from a type. ----- @--- 'non' ≡ 'non'' '.' 'only'--- @------ >>> non 0 #^ rem 10 4--- Just 2------ >>> non 0 #^ rem 10 5+-- >>> review (non "foo") "foo" -- Nothing+-- >>> review (non "foo") "foobar"+-- Just "foobar" -- non :: Eq a => a -> Iso' (Maybe a) a non def = iso (fromMaybe def) g@@ -379,30 +349,10 @@             | otherwise = Just a {-# INLINE non #-} --- | Generalize @'non' a@ to take any value and a predicate.------ 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-  go b | p b       = Nothing-       | otherwise = Just b-{-# INLINE anon #-}- ------------------------------------------------------------------------ Primitive operators--------------------------------------------------------------------------withIsoVl----------------------------------------------------------------------- -- Operators --------------------------------------------------------------------- ------------------------------------------------------------------------- Operators----------------------------------------------------------------------- -- | Invert an isomorphism. -- -- @@@ -425,18 +375,6 @@ reover o = withIso o $ \sa bt ts -> sa . ts . bt {-# INLINE reover #-} --- | 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 #-}- -- | Based on /ala/ from Conor McBride's work on Epigram. -- -- This version is generalized to accept any 'Iso', not just a @newtype@.@@ -447,7 +385,7 @@ -- 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' :: 'AIso' s t a b -> ((b -> t) -> e -> s) -> e -> a -- @ -- au :: Functor f => AIso s t a b -> ((b -> t) -> f s) -> f a@@ -456,9 +394,9 @@  -- | 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+-- @+-- '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))@@ -470,24 +408,19 @@ -- -- >>> 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+-- 'ala' :: 'Newtype' s => 'Newtype' t => ('O' s -> s) -> (('O' t -> t) -> e -> s) -> e -> O s -- @ -- ala :: Newtype s => Newtype t => Functor f => (O s -> s) -> ((O t -> t) -> f s) -> f (O s) 

@@ -6,53 +6,82 @@ {-# LANGUAGE TypeOperators         #-} {-# LANGUAGE TypeFamilies          #-} module Data.Profunctor.Optic.Lens (-    -- * Lens & Ixlens+    -- * Lens     Lens   , Lens'-  , Ixlens-  , Ixlens'+  , Colens+  , Colens'   , lens-  , ilens   , lensVl-  , ilensVl   , matching   , cloneLens+  , colens+  , colensVl+  , comatching+  , cloneColens+    -- * Grate+  , Grate+  , Grate'+  , grate+  , grateVl+  , inverting+  , cloneGrate     -- * Optics   , united   , voided-  , indexed-    -- * Indexed optics-  , ifirst-  , isecond-    -- * Primitive operators-  , withLens-  , withLensVl-  , withIxlens+  , represented+  , distributed+  , endomorphed+  , precomposed+  , dotted+  , continued+  , continuedT+  , calledCC     -- * Operators+  , zipsWith0+  , zipsWith2+  , zipsWith3+  , zipsWith4 +  , zipsWithF   , toPastro   , toTambara+  , toClosure+  , toEnvironment     -- * Classes   , Strong(..)+  , Costrong(..)+  , Closed(..) ) where -import Data.Profunctor.Strong+import Control.Monad.Cont+import Data.Distributive+import Data.Monoid (Endo(..))+import Data.Profunctor.Closed import Data.Profunctor.Optic.Carrier+import Data.Profunctor.Optic.Combinator import Data.Profunctor.Optic.Import-import Data.Profunctor.Optic.Index+import Data.Profunctor.Optic.Iso import Data.Profunctor.Optic.Types-+import Data.Profunctor.Strong+import Data.Semimodule.Free import qualified Data.Functor.Rep as F  -- $setup -- >>> :set -XNoOverloadedStrings -- >>> :set -XTypeApplications+-- >>> :set -XTypeFamilies -- >>> :set -XFlexibleContexts--- >>> import Data.Semimodule.Free--- >>> import Data.Semimodule.Basis+-- >>> :set -XTupleSections+-- >>> import Control.Arrow+-- >>> import Control.Monad.Reader+-- >>> import Data.Int+-- >>> import Data.Complex+-- >>> import Data.List as L+-- >>> import Data.Monoid (Endo(..)) -- >>> :load Data.Profunctor.Optic  ------------------------------------------------------------------------ 'Lens' & 'Ixlens'+-- 'Lens' ---------------------------------------------------------------------  -- | Obtain a 'Lens' from a getter and setter.@@ -73,26 +102,6 @@ lens sa sbt = dimap (id &&& sa) (uncurry sbt) . second' {-# INLINE lens #-} --- | Obtain an indexed 'Lens' from an indexed getter and a setter.------ Compare 'lens' and 'Data.Profunctor.Optic.Traversal.itraversal'.------ /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'.----ilens :: (s -> (i , a)) -> (s -> b -> t) -> Ixlens i s t a b-ilens sia sbt = ilensVl $ \iab s -> sbt s <$> uncurry iab (sia s)-{-# INLINE ilens #-}- -- | Transform a Van Laarhoven lens into a profunctor lens. -- -- Compare 'Data.Profunctor.Optic.Grate.grateVl' and 'Data.Profunctor.Optic.Traversal.traversalVl'.@@ -115,65 +124,143 @@ lensVl abst = dimap ((info &&& vals) . abst (flip Index id)) (uncurry id . swap) . first' {-# INLINE lensVl #-} --- | Transform an indexed Van Laarhoven lens into an indexed profunctor 'Lens'.+-- | Obtain a 'Lens' from its free tensor representation. ----- An 'Ixlens' is a valid 'Ixtraversal'. Compare 'Data.Profunctor.Optic.Traversal.itraversalVl'.+matching :: (s -> (c , a)) -> ((c , b) -> t) -> Lens s t a b+matching sca cbt = dimap sca cbt . second'++-- | TODO: Document ----- /Caution/: In order for the generated optic to be well-defined,--- you must ensure that the input satisfies the following properties:+cloneLens :: ALens s t a b -> Lens s t a b+cloneLens o = withLens o lens ++-- | Obtain a 'Colens' from a getter and setter.  ----- * @iabst (const Identity) ≡ Identity@+-- @+-- '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+-- @ ----- * @fmap (iabst $ const f) . (iabst $ const g) ≡ getCompose . iabst (const $ Compose . fmap f . g)@+-- /Caution/: Colenses are recursive, similar to < http://hackage.haskell.org/package/base-4.12.0.0/docs/Control-Arrow.html#t:ArrowLoop ArrowLoop >. +-- In addition to the normal optic laws, the input functions must have +-- the correct < https://wiki.haskell.org/Lazy_pattern_match laziness > annotations. ----- More generally, a profunctor optic must be monoidal as a natural --- transformation:--- --- * @o id ≡ id@+-- For example, this is a perfectly valid 'Colens': ----- * @o ('Data.Profunctor.Composition.Procompose' p q) ≡ 'Data.Profunctor.Composition.Procompose' (o p) (o q)@+-- @+-- ct21 :: Colens a b (a, c) (b, c)+-- ct21 = flip colens fst $ \ ~(_,c) b -> (b,c)+-- @ --+-- However removing the annotation will result in a faulty optic.+--  -- See 'Data.Profunctor.Optic.Property'. ---ilensVl :: (forall f. Functor f => (i -> a -> f b) -> s -> f t) -> Ixlens i s t a b-ilensVl f = lensVl $ \iab -> f (curry iab) . snd-{-# INLINE ilensVl #-}+colens :: (b -> s -> a) -> (b -> t) -> Colens s t a b+colens bsa bt = unsecond . dimap (uncurry bsa) (id &&& bt) --- | Obtain a 'Lens' from its free tensor representation.+-- | Transform a Van Laarhoven colens into a profunctor colens. ---matching :: (s -> (c , a)) -> ((c , b) -> t) -> Lens s t a b-matching sca cbt = dimap sca cbt . second'+-- Compare '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':+--+-- @+-- ct21 :: Colens a b (a, c) (b, c)+-- ct21 = 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 &&& vals) . o (flip Index id)) +-- | Obtain a 'Colens' from its free tensor representation.+--+-- >>> fib = comatching (uncurry L.take . swap) (id &&& L.reverse) --fib :: Colens Int [Int] [Int] [Int]+-- >>> 10 & fib ..~ \xs -> 1 : 1 : Prelude.zipWith (+) xs (Prelude.tail xs)+-- [89,55,34,21,13,8,5,3,2,1,1]+--+comatching :: ((c , s) -> a) -> (b -> (c , t)) -> Colens s t a b+comatching csa bct = unsecond . dimap csa bct+ -- | TODO: Document ---cloneLens :: ALens s t a b -> Lens s t a b-cloneLens o = withLens o lens +cloneColens :: AColens s t a b -> Colens s t a b+cloneColens o = withColens o colens   ------------------------------------------------------------------------ Primitive operators+-- 'Grate' --------------------------------------------------------------------- --- | Extract the higher order function that characterizes a 'Lens'.+-- | Obtain a 'Grate' from a nested continuation. ----- The lens laws can be stated in terms of 'withLens':--- --- Identity:--- --- @--- withLensVl o Identity ≡ Identity--- @--- --- Composition:+-- 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 fied length vector (e.g. 'V2 a').+--+-- The identity container is representable, and representable functors +-- are closed under composition.+--+-- 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>.+--+-- /Caution/: In order for the generated optic to be well-defined,+-- you must ensure that the input function satisfies the following+-- properties:+--+-- * @sabt ($ s) ≡ s@+--+-- * @sabt (\k -> f (k . sabt)) ≡ sabt (\k -> f ($ k))@+--+-- More generally, a profunctor optic must be monoidal as a natural +-- transformation: -- --- @ --- Compose . fmap (withLensVl o f) . withLensVl o g ≡ withLensVl o (Compose . fmap f . g)--- @+-- * @o id ≡ id@ --+-- * @o ('Data.Profunctor.Composition.Procompose' p q) ≡ 'Data.Profunctor.Composition.Procompose' (o p) (o q)@+-- -- See 'Data.Profunctor.Optic.Property'. ---withLensVl :: Functor f => ALens s t a b -> (a -> f b) -> s -> f t-withLensVl o ab s = withLens o $ \sa sbt -> sbt s <$> ab (sa s)+grate :: (((s -> a) -> b) -> t) -> Grate s t a b+grate sabt = dimap (flip ($)) sabt . closed +-- | Transform a Van Laarhoven grate into a profunctor grate.+--+-- Compare 'Data.Profunctor.Optic.Lens.lensVl' & 'Data.Profunctor.Optic.Traversal.cotraversalVl'.+--+-- /Caution/: In order for the generated family to be well-defined,+-- you must ensure that the traversal1 law holds for the input function:+--+-- * @abst runIdentity ≡ runIdentity@+--+-- * @abst f . fmap (abst g) ≡ abst (f . fmap g . getCompose) . Compose@+--+-- See 'Data.Profunctor.Optic.Property'.+--+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++-- | Construct a 'Grate' from a pair of inverses.+--+inverting :: (s -> a) -> (b -> t) -> Grate s t a b+inverting sa bt = grate $ \sab -> bt (sab sa)++-- | TODO: Document+--+cloneGrate :: AGrate s t a b -> Grate s t a b+cloneGrate k = withGrate k grate+ --------------------------------------------------------------------- -- Optics  ---------------------------------------------------------------------@@ -198,45 +285,121 @@ voided :: Lens' Void a voided = lens absurd const --- | Obtain a 'Lens' from a representable functor.+-- | Obtain a 'Grate' from a 'F.Representable' functor. ----- >>> V2 3 1 ^. indexed E21--- 3--- >>> V3 "foo" "bar" "baz" & indexed E32 .~ "bip"--- V3 "foo" "bip" "baz"+represented :: F.Representable f => Grate (f a) (f b) a b+represented = tabulated . closed+{-# INLINE represented #-}++-- | Obtain a 'Grate' from a distributive functor. ---indexed :: F.Representable f => Eq (F.Rep f) => F.Rep f -> Lens' (f a) a-indexed i = lensVl $ lensRep i +distributed :: Distributive f => Grate (f a) (f b) a b+distributed = grate (`cotraverse` id)+{-# INLINE distributed #-} -lensRep :: F.Representable f => Eq (F.Rep f) => F.Rep f -> forall g. Functor g => (a -> g a) -> f a -> g (f a) -lensRep i f s = setter s <$> f (getter s)-  where getter = flip F.index i-        setter s' b = F.tabulate $ \j -> bool (F.index s' j) b (i == j)-{-# INLINE lensRep #-}+-- | Obtain a 'Grate' from an endomorphism. +--+-- >>> flip appEndo 2 $ zipsWith2 endomorphed (+) (Endo (*3)) (Endo (*4))+-- 14+--+endomorphed :: Grate' (Endo a) a+endomorphed = dimap appEndo Endo . closed+{-# INLINE endomorphed #-} ------------------------------------------------------------------------- Indexed optics ----------------------------------------------------------------------+-- | Obtain a 'Grate' from a linear map.+--+precomposed :: Grate (Lin a b1 c) (Lin a b2 c) (Vec a b1) (Vec a b2)+precomposed = dimap runLin Lin . closed . dimap Vec runVec+{-# INLINE precomposed #-} --- | TODO: Document+-- | Obtain a 'Grate' from a linear functional. ----- >>> ilists (ix @Int traversed . ifirst . ix traversed) [("foo",1), ("bar",2)]--- [(0,'f'),(1,'o'),(2,'o'),(0,'b'),(1,'a'),(2,'r')]--- >>> ilists (ix @Int traversed % ifirst % ix traversed) [("foo",1), ("bar",2)]--- [(0,'f'),(1,'o'),(2,'o'),(2,'b'),(3,'a'),(4,'r')]+dotted :: Grate c (Cov a c) a a+dotted = grate Cov+{-# INLINE dotted #-}++-- | Obtain a 'Grate' from a continuation. ---ifirst :: Ixlens i (a , c) (b , c) a b-ifirst = lmap assocl . first'+-- @+-- 'zipsWith2' 'continued' :: (a -> a -> a) -> c -> c -> 'Cont' a c+-- @+--+continued :: Grate c (Cont a c) a a+continued = grate cont+{-# INLINE continued #-} --- | TODO: Document+-- | Obtain a 'Grate' from a continuation. ---isecond :: Ixlens i (c , a) (c , b) a b-isecond = lmap (\(i, (c, a)) -> (c, (i, a))) . second'+-- @+-- 'zipsWith2' 'continued' :: (m a -> m a -> m a) -> c -> c -> 'ContT' a m c +-- @+--+continuedT :: Grate c (ContT a m c) (m a) (m a)+continuedT = grate ContT+{-# INLINE continuedT #-} +-- | Lift the current continuation into the calling context.+--+-- @+-- 'zipsWith2' 'calledCC' :: 'MonadCont' m => (m b -> m b -> m s) -> s -> s -> m s+-- @+--+calledCC :: MonadCont m => Grate a (m a) (m b) (m a)+calledCC = grate callCC+{-# INLINE calledCC #-}+ --------------------------------------------------------------------- -- Operators --------------------------------------------------------------------- +-- | Set all fields to the given value.+--+-- This is essentially a restricted variant of 'Data.Profunctor.Optic.View.review'.+--+zipsWith0 :: AGrate s t a b -> b -> t+zipsWith0 o b = withGrate o $ \sabt -> sabt (const b)+{-# INLINE zipsWith0 #-}++-- | Zip over a 'Grate'. +--+-- @\\f -> 'zipsWith2' 'closed' ('zipsWith2' 'closed' f) ≡ 'zipsWith2' ('closed' . 'closed')@+--+zipsWith2 :: AGrate s t a b -> (a -> a -> b) -> s -> s -> t+zipsWith2 o aab s1 s2 = withGrate o $ \sabt -> sabt $ \get -> aab (get s1) (get s2)+{-# INLINE zipsWith2 #-}++-- | Zip over a 'Grate' with 3 arguments.+--+zipsWith3 :: AGrate s t a b -> (a -> a -> a -> b) -> (s -> s -> s -> t)+zipsWith3 o aaab s1 s2 s3 = withGrate o $ \sabt -> sabt $ \sa -> aaab (sa s1) (sa s2) (sa s3)+{-# INLINE zipsWith3 #-}++-- | Zip over a 'Grate' with 4 arguments.+--+zipsWith4 :: AGrate s t a b -> (a -> a -> a -> a -> b) -> (s -> s -> s -> s -> t)+zipsWith4 o aaaab s1 s2 s3 s4 = withGrate o $ \sabt -> sabt $ \sa -> aaaab (sa s1) (sa s2) (sa s3) (sa s4)+{-# INLINE zipsWith4 #-}++-- | Extract the higher order function that characterizes a 'Grate'.+--+-- The grate laws can be stated in terms or 'withGrate':+-- +-- Identity:+-- +-- @+-- zipsWithF o runIdentity ≡ runIdentity+-- @+-- +-- Composition:+-- +-- @ +-- zipsWithF o f . fmap (zipsWithF o g) ≡ zipsWithF o (f . fmap g . getCompose) . Compose+-- @+--+zipsWithF :: Functor f => AGrate s t a b -> (f a -> b) -> f s -> t+zipsWithF = withGrateVl+{-# INLINE zipsWithF #-}+ -- | Use a 'Lens' to construct a 'Pastro'. -- toPastro :: ALens s t a b -> p a b -> Pastro p s t@@ -246,3 +409,15 @@ -- 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)++-- | Use a 'Grate' to construct a 'Closure'.+--+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 #-}++-- | Use a 'Grate' to construct an 'Environment'.+--+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 #-}

@@ -1,152 +0,0 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TupleSections         #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE TypeFamilies          #-}-module Data.Profunctor.Optic.Operator (-    (&)-  , (%)-  , (#)-  , (^.)-  , (^%)-  , (#^)-  , (..~)-  , (.~)-  , (%%~)-  , (%~)-  , (##~)-  , (#~)-) where--import Data.Function-import Data.Profunctor.Optic.Carrier-import Data.Profunctor.Optic.Types-import Data.Profunctor.Optic.Import-import Data.Profunctor.Optic.Index--import qualified Data.Bifunctor as B---- $setup--- >>> :set -XNoOverloadedStrings--- >>> :set -XTypeApplications--- >>> :set -XFlexibleContexts--- >>> :set -XRankNTypes--- >>> import Data.List.Index as LI--- >>> import Data.Maybe--- >>> import Data.Monoid--- >>> :load Data.Profunctor.Optic--infixr 4 .~, ..~, %~, %%~, #~, ##~--infixl 8 ^., ^%--infixr 8 #^---- | View the focus of an optic.------ Fixity and semantics are such that subsequent field accesses can be--- performed with ('Prelude..').------ >>> ("hello","world") ^. second'--- "world"------ >>> 5 ^. to succ--- 6------ >>> import Data.Complex--- >>> ((0, 1 :+ 2), 3) ^. first' . second' . to magnitude--- 2.23606797749979----(^.) :: s -> AView s a -> a-(^.) s o = withPrimView o id s-{-# INLINE ( ^. ) #-}---- | View the focus of an indexed optic along with its index.------ >>> ("foo", 42) ^% ifirst--- (Just (),"foo")----(^%) :: (Additive-Monoid) i => s -> AIxview i s a -> (Maybe i, a)-(^%) s o = withPrimView o (B.first Just) . (zero,) $ s-{-# INLINE (^%) #-}---- | 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----(#^) :: AReview t b -> b -> t-o #^ b = withPrimReview o id b-{-# INLINE (#^) #-}---- | Map over an optic.------ >>> Just 1 & just ..~ (+1)--- Just 2------ >>> Nothing & just ..~ (+1)--- Nothing------ >>> [1,2,3] & fmapped ..~ (*10)--- [10,20,30]------ >>> (1,2) & first' ..~ (+1) --- (2,2)------ >>> (10,20) & first' ..~ show --- ("10",20)----(..~) :: Optic (->) s t a b -> (a -> b) -> s -> t-(..~) = id-{-# INLINE (..~) #-}---- | Set all referenced fields to the given value.----(.~) :: Optic (->) s t a b -> b -> s -> t-(.~) o b = o (const b)-{-# INLINE (.~) #-}---- | Map over an indexed optic.------ See also '##~'.----(%%~) :: (Additive-Monoid) i => AIxsetter i s t a b -> (i -> a -> b) -> s -> t-(%%~) o f = withIxsetter o f zero-{-# INLINE (%%~) #-}---- | Set the focus of an indexed optic.------  See also '#~'.------ /Note/ if you're looking for the infix 'over' it is '..~'.----(%~) :: (Additive-Monoid) i => AIxsetter i s t a b -> (i -> b) -> s -> t-(%~) o = (%%~) o . (const .)-{-# INLINE (%~) #-}---- | Map over a coindexed optic.--- --- Infix variant of 'kover'.------  See also '%%~'.----(##~) :: (Additive-Monoid) k => ACxsetter k s t a b -> (k -> a -> b) -> s -> t -(##~) o f = withCxsetter o f zero-{-# INLINE (##~) #-}---- | Set the focus of a coindexed optic.------  See also '%~'.----(#~) :: (Additive-Monoid) k => ACxsetter k s t a b -> (k -> b) -> s -> t -(#~) o kb = o ##~ flip (const kb) -{-# INLINE (#~) #-}

@@ -1,293 +0,0 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TupleSections         #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE TypeFamilies          #-}-module Data.Profunctor.Optic.Option (-    -- * Option & Ixoption-    Option-  , option-  , ioption-  , failing-  , toOption-  , fromOption -    -- * Optics-  , optioned-  , filtered-    -- * Primitive operators-  , withOption-  , withIxoption-    -- * Operators-  , (^?)-  , preview -  , preuse-  , is-  , isnt-    -- * Indexed operators-  , ipreview-  , ipreviews-    -- * MonadUnliftIO -  , tries-  , tries_ -  , catches-  , catches_-  , handles-  , handles_-) where--import Control.Exception (Exception)-import Control.Monad.IO.Unlift-import Control.Monad.Reader as Reader hiding (lift)-import Control.Monad.State as State hiding (lift)-import Data.Maybe-import Data.Monoid hiding (All(..), Any(..))-import Data.Profunctor.Optic.Carrier-import Data.Profunctor.Optic.Import-import Data.Profunctor.Optic.Prism (just, async)-import Data.Profunctor.Optic.Affine-import Data.Profunctor.Optic.Types-import Data.Profunctor.Optic.View-import qualified Control.Exception as Ex---- $setup--- >>> :set -XNoOverloadedStrings--- >>> :set -XTypeApplications--- >>> :set -XFlexibleContexts--- >>> :set -XRankNTypes--- >>> import Control.Exception hiding (catches)--- >>> import Data.Functor.Identity--- >>> import Data.List.Index as LI--- >>> 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 itraversed :: Ixtraversal Int [a] [b] a b ; itraversed = itraversalVl itraverse--- >>> let iat :: Int -> Ixaffine' Int [a] a; iat i = iaffine' (\s -> flip LI.ifind s $ \n _ -> n==i) (\s a -> LI.modifyAt i (const a) s) -------------------------------------------------------------------------- 'Option' & 'Ixoption'-------------------------------------------------------------------------- | Obtain a 'Option' directly.------ @--- 'option' . 'preview' ≡ id--- 'option' ('view' o) ≡ o . 'just'--- @------ >>> preview (option . preview $ selected even) (2, "yes")--- Just "yes"------ >>> preview (option . preview $ selected even) (3, "no")--- Nothing------ >>> preview (option listToMaybe) "foo"--- Just 'f'----option :: (s -> Maybe a) -> Option s a-option f = to (\s -> maybe (Left s) Right (f s)) . right'-{-# INLINE option #-}---- | Obtain an 'Ixoption' directly.----ioption :: (s -> Maybe (i, a)) -> Ixoption i s a-ioption g = iaffineVl (\point f s -> maybe (point s) (uncurry f) $ g s) . coercer-{-# INLINE ioption #-}--infixl 3 `failing` -- Same as (<|>)---- | If the first 'Option' has no focus then try the second one.----failing :: AOption a s a -> AOption a s a -> Option s a-failing a b = option $ \s -> maybe (preview b s) Just (preview a s)-{-# INLINE failing #-}---- | Obtain a 'Option' from a 'View'.------ @--- 'toOption' o ≡ o . 'just'--- 'toOption' o ≡ 'option' ('view' o)--- @----toOption :: View s (Maybe a) -> Option s a-toOption = (. just)-{-# INLINE toOption #-}---- | Obtain a 'View' from a 'Option' ----fromOption ::  AOption a s a -> View s (Maybe a)-fromOption = to . preview-{-# INLINE fromOption #-}-------------------------------------------------------------------------- Optics -------------------------------------------------------------------------- | The canonical 'Option'. ------ >>> [Just 1, Nothing] ^.. folded . optioned--- [1]----optioned :: Option (Maybe a) a-optioned = option id-{-# INLINE optioned #-}---- | Filter another optic.------ >>> [1..10] ^.. folded . filtered even--- [2,4,6,8,10]----filtered :: (a -> Bool) -> Option a a-filtered p = affineVl (\point f a -> if p a then f a else point a) . coercer-{-# INLINE filtered #-}-------------------------------------------------------------------------- Operators------------------------------------------------------------------------infixl 8 ^?---- | An infix alias for 'preview''.------ @--- ('^?') ≡ 'flip' 'preview''--- @------ Perform a safe 'head' of a 'Fold' or 'Traversal' or retrieve 'Just'--- the result from a 'View' or 'Lens'.------ 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 ^? left'--- Just 4--- >>> Right 4 ^? left'--- Nothing----(^?) :: s -> AOption a s a -> Maybe a-(^?) = flip preview-{-# INLINE (^?) #-}---- | TODO: Document----preview :: MonadReader s m => AOption a s a -> m (Maybe a)-preview o = Reader.asks $ withOption o Just-{-# INLINE preview #-}---- | TODO: Document----preuse :: MonadState s m => AOption a s a -> m (Maybe a)-preuse o = State.gets $ preview o-{-# INLINE preuse #-}---- | Check whether the optic is matched.------ >>> is just Nothing--- False----is :: AOption a s a -> s -> Bool-is o s = isJust (preview o s)-{-# INLINE is #-}---- | Check whether the optic isn't matched.------ >>> isnt just Nothing--- True----isnt :: AOption a s a -> s -> Bool-isnt o s = not (isJust (preview o s))-{-# INLINE isnt #-}----------------------------------------------------------------------------------- Indexed operators----------------------------------------------------------------------------------- | TODO: Document ----ipreview :: (Additive-Monoid) i => AIxoption (i , a) i s a -> s -> Maybe (i , a)-ipreview o = ipreviews o (,)-{-# INLINE ipreview #-}---- | TODO: Document ----ipreviews :: (Additive-Monoid) i => AIxoption r i s a -> (i -> a -> r) -> s -> Maybe r-ipreviews o f = withIxoption o (\i -> Just . f i)-{-# INLINE ipreviews #-}----------------------------------------------------------------------------------- '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 => 'AOption' 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 => AOption 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 => AOption 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 => 'AOption' 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 => AOption 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 #-}---- | Catch synchronous exceptions that match a given optic, discarding the match.------ >>> catches_ (only Overflow) (throwIO Overflow) (return "caught")--- "caught"----catches_ :: MonadUnliftIO m => Exception ex => AOption e ex e -> m a -> m a -> m a-catches_ o x y = catches o x $ const y-{-# INLINE catches_ #-}---- | Flipped variant of 'catches'.------ >>> handles (only Overflow) (\_ -> return "caught") $ throwIO Overflow--- "caught"----handles :: MonadUnliftIO m => Exception ex => AOption 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 => AOption 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 #-}

@@ -1,266 +0,0 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TupleSections         #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE TypeFamilies          #-}-module Data.Profunctor.Optic.Prelude (-    re-  , invert-  , (&)-    -- * Composition-  , (.) -  , (%)-  , (#)-    -- * View operators-  , view-  , (^.)-  , iview-  , (^%)-  , review-  , (#^)-    -- * Setter operators-  , set-  , (.~)-  , iset-  , (%~)-  , kset-  , (#~)-  , over-  , (..~)-  , iover-  , (%%~)-  , kover-  , (##~)-  , (<>~)-    -- * Fold operators-  , preview-  , (^?)-  , is-  , isnt-  , matches-  , lists-  , (^..)-  , ilists-  , ilistsFrom-  , (^%%)-  , folds-  , foldsa-  , foldsr-  , ifoldsr-  , ifoldsrFrom-  , foldsl-  , ifoldsl-  , ifoldslFrom-  , foldsr'-  , ifoldsr'-  , foldsl'-  , ifoldsl'-  , foldsrM-  , ifoldsrM-  , foldslM-  , ifoldslM-  , traverses_-  , itraverses_-  , sums-  , multiplies-  , asums-  , concats-  , iconcats-  , endo-  , endoM-  , finds-  , ifinds-  , has-  , hasnt -  , elem-  , pelem-  , joins-  , joins'-  , meets-  , meets'-  , mins -  , maxes -) where--import Control.Monad.Reader as Reader hiding (lift)-import Data.Function-import Data.Maybe-import Data.Monoid-import Data.Profunctor.Optic.Carrier-import Data.Profunctor.Optic.Types-import Data.Profunctor.Optic.Iso-import Data.Profunctor.Optic.View-import Data.Profunctor.Optic.Import-import Data.Profunctor.Optic.Index-import Data.Profunctor.Optic.Setter-import Data.Profunctor.Optic.Fold-import Data.Profunctor.Optic.Option-import Data.Profunctor.Optic.Affine-import Data.Prd (Prd, Minimal(..), Maximal(..))-import Data.Semilattice--import qualified Control.Applicative as A-import 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.Optic--- >>> import Data.Map as Map--- >>> import Data.Maybe--- >>> import Data.Monoid--- >>> import Data.Semiring hiding (unital,nonunital,presemiring)--- >>> import Data.Sequence as Seq hiding ((*))--- >>> :load Data.Profunctor.Optic--------------------------------------------------------------------------- Fold operators-------------------------------------------------------------------------- | The sum of a collection.----sums :: (Additive-Monoid) a => AFold ((Endo-Endo) a) s a -> s -> a-sums o = foldsl' o (+) zero---- | The product of a collection.----multiplies :: (Multiplicative-Monoid) a => AFold ((Endo-Endo) a) s a -> s -> a-multiplies o = foldsl' o (*) one---- | The sum of a collection of actions, generalizing 'concats'.------ >>> 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 (<|>) A.empty-{-# INLINE asums #-}---- | Map a function over the foci of an optic and concatenate the resulting lists.------ >>> 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 #-}---- | Concatenate the results of a function of the foci of an indexed optic.------ @--- 'concats' o ≡ 'iconcats' o '.' 'const'--- @------ >>> iconcats itraversed (\i x -> [i + x, i + x + 1]) [1,2,3,4]--- [1,2,3,4,5,6,7,8]----iconcats :: (Additive-Monoid) i => AIxfold [r] i s a -> (i -> a -> [r]) -> s -> [r]-iconcats o f = withIxfold o f zero-{-# INLINE iconcats #-}---- | TODO: Document----endo :: AFold (Endo (a -> a)) s (a -> a) -> s -> a -> a-endo o = foldsr o (.) id---- | TODO: Document----endoM :: Monad m => AFold (Endo (a -> m a)) s (a -> m a) -> s -> a -> m a-endoM o = foldsr o (<=<) pure---- | Find the first focus of an optic that satisfies a predicate, if one exists.------ >>> finds both even (1,4)--- Just 4------ >>> finds folded even [1,3,5,7]--- Nothing------ @--- 'Data.Foldable.find' ≡ 'finds' 'folded'--- @----finds :: AFold ((Maybe-Endo) 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 #-}---- | Find the first focus of an indexed optic that satisfies a predicate, if one exists.----ifinds :: (Additive-Monoid) i => AIxfold ((Maybe-Endo) (i, a)) i s a -> (i -> a -> Bool) -> s -> Maybe (i, a)-ifinds o f = ifoldsr o (\i a y -> if f i a then Just (i,a) else y) Nothing-{-# INLINE ifinds #-}---- | Determine whether an optic has at least one focus.----has :: AFold (Additive Bool) s a -> s -> Bool-has o s = unAdditive $ withFold o (const $ Additive True) s-{-# INLINE has #-}---- | Determine whether an optic does not have a focus.----hasnt :: AFold (Multiplicative Bool) s a -> s -> Bool-hasnt o s = unMultiplicative $ withFold o (const $ Multiplicative False) s-{-# INLINE hasnt #-}---- | Determine whether the targets of a `Fold` contain a given element.----elem :: Eq a => AFold (Additive Bool) s a -> a -> s -> Bool-elem o a s = unAdditive $ withFold o (\x -> Additive $ x == a) s---- | Determine whether the foci of an optic contain an element equivalent to a given element.----pelem :: Prd a => AFold (Additive Bool) s a -> a -> s -> Bool-pelem o a s = unAdditive $ withFold o (\x -> Additive $ x =~ a) s-{-# INLINE pelem #-}---- | Compute the minimum of the targets of a totally ordered fold. ----mins :: Pre.Ord a => AFold ((Endo-Endo) a) s a -> a -> s -> a-mins o = foldsl' o Pre.min---- | Compute the maximum of the targets of a totally ordered fold.----maxes :: Pre.Ord a => AFold ((Endo-Endo) a) s a -> a -> s -> a-maxes o = foldsl' o Pre.max---- | 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 #-}---- | Compute the join of the foci of an optic including a least element.----joins' :: Lattice a => Minimal a => AFold ((Endo-Endo) a) s a -> s -> a-joins' o = joins o minimal-{-# INLINE joins' #-}---- | Compute the meet of the foci of an optic .----meets :: Lattice a => AFold ((Endo-Endo) a) s a -> a -> s -> a-meets o = foldsl' o (∧)-{-# INLINE meets #-}---- | Compute the meet of the foci of an optic including a greatest element.----meets' :: Lattice a => Maximal a => AFold ((Endo-Endo) a) s a -> s -> a-meets' o = meets o maximal-{-# INLINE meets' #-}

@@ -9,24 +9,24 @@     -- * Prism & Cxprism     Prism   , Prism'-  , Cxprism-  , Cxprism'+  , Coprism+  , Coprism'   , prism   , prism'   , handling   , clonePrism+  , coprism+  , coprism'+  , rehandling+  , cloneCoprism     -- * Optics   , just+  , cojust   , nothing-  , compared   , prefixed   , only   , nearly   , nthbit-  , sync-  , async-  , exception-  , asyncException     -- * Primitive operators   , withPrism     -- * Operators@@ -39,15 +39,12 @@   , Choice(..) ) 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.Carrier-import Data.Profunctor.Optic.Iso import Data.Profunctor.Optic.Import  import Data.Profunctor.Optic.Types @@ -105,6 +102,44 @@ clonePrism :: APrism s t a b -> Prism s t a b clonePrism o = withPrism o prism +-- | Obtain a 'Cochoice' optic from a constructor and a matcher function.+--+-- @+-- coprism f g ≡ \f g -> re (prism f g)+-- @+--+-- /Caution/: In order for the generated optic to be well-defined,+-- you must ensure that the input functions satisfy the following+-- properties:+--+-- * @bat (bt b) ≡ Right b@+--+-- * @(id ||| bt) (bat b) ≡ b@+--+-- * @left bat (bat b) ≡ left Left (bat b)@+--+-- A 'Coprism' is a 'View', so you can specialise types to obtain:+--+-- @ view :: 'Coprism'' s a -> s -> a @+--+coprism :: (s -> a) -> (b -> a + t) -> Coprism s t a b+coprism sa bat = unright . dimap (id ||| sa) bat++-- | Create a 'Coprism' from a reviewer and a matcher function that produces a 'Maybe'.+--+coprism' :: (s -> a) -> (a -> Maybe s) -> Coprism' s a+coprism' tb bt = coprism tb $ \b -> maybe (Left b) Right (bt b)++-- | Obtain a 'Coprism' from its free tensor representation.+--+rehandling :: (c + s -> a) -> (b -> c + t) -> Coprism s t a b+rehandling csa bct = unright . dimap csa bct++-- | TODO: Document+--+cloneCoprism :: ACoprism s t a b -> Coprism s t a b+cloneCoprism o = withCoprism o coprism+ --------------------------------------------------------------------- -- Common 'Prism's and 'Coprism's ---------------------------------------------------------------------@@ -113,23 +148,22 @@ -- -- >>> Just 1 :| [Just 2, Just 3] & withCostar just sum -- Just 6--- -- >>> Nothing :| [Just 2, Just 3] & withCostar just sum -- Nothing -- just :: Prism (Maybe a) (Maybe b) a b just = flip prism Just $ maybe (Left Nothing) Right +-- | Unfocus on the `Just` constructor of `Maybe`.+--+cojust :: Coprism a b (Maybe a) (Maybe b)+cojust = coprism Just $ maybe (Left Nothing) Right+ -- | Focus on the `Nothing` constructor of `Maybe`. -- nothing :: Prism (Maybe a) (Maybe b) () () nothing = flip prism (const Nothing) $ maybe (Right ()) (const $ Left Nothing) --- | Focus on comparability to a given element of a partial order.----compared :: Prd a => a -> Prism' a Ordering-compared x = flip prism' (const x) (pcompare x)- -- | Focus on the remainder of a list with a given prefix. -- prefixed :: Eq a => [a] -> Prism' [a] [a]@@ -142,9 +176,8 @@  -- | Create a 'Prism' from a value and a predicate. ----- >>> nearly [] null #^ ()+-- >>> review (nearly [] null) () -- []--- -- >>> [1,2,3,4] ^? nearly [] null -- Nothing --@@ -161,33 +194,6 @@ nthbit :: Bits s => Int -> Prism' s () nthbit n = prism' (guard . (flip testBit n)) (const $ bit n) --- | Focus on whether an exception is synchronous.----sync :: Exception e => Prism' e e -sync = filterOn $ \e -> case fromException (toException e) of-  Just (SomeAsyncException _) -> False-  Nothing -> True-  where filterOn f = iso (branch' f) join . right'---- | Focus on whether an exception is asynchronous.----async :: Exception e => Prism' e e -async = filterOn $ \e -> case fromException (toException e) of-  Just (SomeAsyncException _) -> True-  Nothing -> False-  where filterOn f = iso (branch' f) join . right'---- | Focus on whether a given exception has occurred.----exception :: Exception e => Prism' SomeException e-exception = prism' fromException toException---- | Focus on whether a given asynchronous exception has occurred.----asyncException :: Exception e => Prism' SomeException e-asyncException = prism' asyncExceptionFromException asyncExceptionToException-- --------------------------------------------------------------------- -- Operators ---------------------------------------------------------------------@@ -220,7 +226,6 @@ -- -- >>> [Left 1, Right "foo", Left 4, Right "woot"] ^.. below right' -- []--- -- >>> [Right "hail hydra!", Right "foo", Right "blah", Right "woot"] ^.. below right' -- [["hail hydra!","foo","blah","woot"]] --

@@ -26,11 +26,11 @@   , id_grate   , const_grate   , compose_grate-    -- * Affine-  , Affine-  , tofrom_affine-  , fromto_affine-  , idempotent_affine+    -- * Traversal0+  , Traversal0+  , tofrom_traversal0+  , fromto_traversal0+  , idempotent_traversal0     -- * Traversal   , Traversal   , id_traversal@@ -53,16 +53,8 @@ import Data.Profunctor.Optic.Carrier import Data.Profunctor.Optic.Import import Data.Profunctor.Optic.Types-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.Fold-import Data.Profunctor.Optic.Traversal-import Data.Profunctor.Optic.Cotraversal-import Data.Profunctor.Optic.Affine+import Test.Function.Invertible  --------------------------------------------------------------------- -- 'Iso'@@ -107,8 +99,6 @@ -- 'Lens' --------------------------------------------------------------------- -invertible f g a = g (f a) == a- -- A 'Lens' is a valid 'Traversal' with the following additional laws:  id_lens :: Eq s => Lens' s a -> s -> Bool@@ -157,29 +147,29 @@         rhs = withGrateVl o (f . fmap g . getCompose) . Compose  ------------------------------------------------------------------------ 'Affine'+-- 'Traversal0' ---------------------------------------------------------------------  -- | You get back what you put in. -- -- * @sta (sbt a s) ≡ either (Left . const a) Right (sta s)@ ---tofrom_affine :: Eq a => Eq s => Affine' s a -> s -> a -> Bool-tofrom_affine o s a = withAffine o $ \sta sbt -> sta (sbt s a) == either (Left . flip const a) Right (sta s)+tofrom_traversal0 :: Eq a => Eq s => Traversal0' s a -> s -> a -> Bool+tofrom_traversal0 o s a = withAffine o $ \sta sbt -> sta (sbt s a) == either (Left . flip const a) Right (sta s)  -- | Putting back what you got doesn't change anything. -- -- * @either id (sbt s) (sta s) ≡ s@ ---fromto_affine :: Eq s => Affine' s a -> s -> Bool-fromto_affine o s = withAffine o $ \sta sbt -> either id (sbt s) (sta s) == s+fromto_traversal0 :: Eq s => Traversal0' s a -> s -> Bool+fromto_traversal0 o s = withAffine o $ \sta sbt -> either id (sbt s) (sta s) == s  -- | Setting twice is the same as setting once. -- -- * @sbt (sbt s a1) a2 ≡ sbt s a2@ ---idempotent_affine :: Eq s => Affine' s a -> s -> a -> a -> Bool-idempotent_affine o s a1 a2 = withAffine o $ \_ sbt -> 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 = withAffine o $ \_ sbt -> sbt (sbt s a1) a2 == sbt s a2  --------------------------------------------------------------------- -- 'Traversal'@@ -188,23 +178,23 @@ -- A 'Traversal' is a valid 'Setter' with the following additional laws:  id_traversal :: Eq s => Traversal' s a -> s -> Bool-id_traversal o = M.join invertible $ runIdentity . withTraversal o Identity +id_traversal o = M.join invertible $ runIdentity . withStar o Identity   id_traversal1 :: Eq s => Traversal1' s a -> s -> Bool-id_traversal1 o = M.join invertible $ runIdentity . withTraversal1 o Identity +id_traversal1 o = M.join invertible $ runIdentity . withStar o Identity   pure_traversal :: Eq (f s) => Applicative f => ATraversal' f s a -> s -> Bool-pure_traversal o = liftA2 (==) (withTraversal o pure) pure+pure_traversal o = liftA2 (==) (withStar o pure) pure -compose_traversal :: Eq (f (g s)) => Applicative f => Applicative g => Traversal' s a -> (a -> g a) -> (a -> f a) -> s -> Bool+compose_traversal :: Eq (f (g s)) => Applicative' f => Applicative' g => Traversal' s a -> (a -> g a) -> (a -> f a) -> s -> Bool compose_traversal o f g = liftA2 (==) lhs rhs-  where lhs = fmap (withTraversal o f) . withTraversal o g-        rhs = getCompose . withTraversal o (Compose . fmap f . g)+  where lhs = fmap (withStar o f) . withStar o g+        rhs = getCompose . withStar o (Compose . fmap f . g)  compose_traversal1 :: Eq (f (g s)) => Apply f => Apply g => Traversal1' s a -> (a -> g a) -> (a -> f a) -> s -> Bool compose_traversal1 o f g s = lhs s == rhs s-  where lhs = fmap (withTraversal1 o f) . withTraversal1 o g-        rhs = getCompose . withTraversal1 o (Compose . fmap f . g)+  where lhs = fmap (withStar o f) . withStar o g+        rhs = getCompose . withStar o (Compose . fmap f . g)  --------------------------------------------------------------------- -- 'Cotraversal'@@ -214,18 +204,18 @@ -- -- * @abst f . fmap (abst g) ≡ abst (f . fmap g . getCompose) . Compose @ ----- The cotraversal laws can be restated in terms of 'cowithTraversal1':+-- The cotraversal laws can be restated in terms of 'cowithStar1': ----- * @withCotraversal o (f . runIdentity) ≡  fmap f . runIdentity @+-- * @withCostar o (f . runIdentity) ≡  fmap f . runIdentity @ ----- * @withCotraversal o f . fmap (withCotraversal o g) == withCotraversal o (f . fmap g . getCompose) . Compose@+-- * @withCostar o f . fmap (withCostar o g) == withCostar o (f . fmap g . getCompose) . Compose@ -- -- See also < https://www.cs.ox.ac.uk/jeremy.gibbons/publications/iterator.pdf > -- compose_cotraversal :: Eq s => Coapplicative f => Coapplicative g => Cotraversal' s a -> (f a -> a) -> (g a -> a) -> f (g s) -> Bool compose_cotraversal o f g = liftF2 (==) lhs rhs-  where lhs = withCotraversal o f . fmap (withCotraversal o g) -        rhs = withCotraversal o (f . fmap g . getCompose) . Compose+  where lhs = withCostar o f . fmap (withCostar o g) +        rhs = withCostar o (f . fmap g . getCompose) . Compose -} --------------------------------------------------------------------- -- 'Setter'

@@ -10,21 +10,17 @@     Setter   , Setter'   , setter-  , isetter   , closing     -- * Resetter   , Resetter   , Resetter'   , resetter-  , ksetter     -- * Optics   , cod   , dom   , bound    , fmapped   , contramapped-  , exmapped-  , adjusted   , liftedA   , liftedM   , forwarded@@ -32,25 +28,11 @@   , zipped   , modded   , cond-    -- * Indexed optics-  , imapped-  , imappedRep-    -- * Primitive operators-  , withIxsetter-  , withCxsetter     -- * Operators   , set-  , iset-  , kset-  , (.~)-  , (%~)-  , (#~)   , over-  , iover-  , kover+  , (.~)   , (..~)-  , (%%~)-  , (##~)   , (<>~)     -- * mtl   , locally@@ -58,29 +40,19 @@   , assigns   , modifies   , (.=)-  , (%=)-  , (#=)   , (..=)-  , (%%=)-  , (##=)   , (<>=) ) where  import Control.Applicative (liftA)-import Control.Exception (Exception(..)) import Control.Monad.Reader as Reader import Control.Monad.State as State import Control.Monad.Writer as Writer-import Data.Key as K import Data.Profunctor.Optic.Carrier import Data.Profunctor.Optic.Import hiding ((&&&))-import Data.Profunctor.Optic.Index-import Data.Profunctor.Optic.Operator+import Data.Profunctor.Optic.Combinator import Data.Profunctor.Optic.Types -import qualified Control.Exception as Ex-import qualified Data.Functor.Rep as F- -- $setup -- >>> :set -XNoOverloadedStrings -- >>> :set -XTypeApplications@@ -88,7 +60,6 @@ -- >>> :set -XRankNTypes -- >>> import Control.Category ((>>>)) -- >>> import Control.Arrow (Kleisli(..))--- >>> import Control.Exception -- >>> import Control.Monad.State -- >>> import Control.Monad.Reader -- >>> import Control.Monad.Writer@@ -97,14 +68,11 @@ -- >>> import Data.Functor.Rep -- >>> import Data.Functor.Identity -- >>> import Data.Functor.Contravariant--- >>> import Data.List.Index as LI -- >>> import Data.IntSet as IntSet -- >>> import Data.Set as Set -- >>> import Data.Tuple (swap) -- >>> :load Data.Profunctor.Optic--- >>> let iat :: Int -> Ixaffine' Int [a] a; iat i = iaffine' (\s -> flip LI.ifind s $ \n _ -> n==i) (\s a -> LI.modifyAt i (const a) s)  - --------------------------------------------------------------------- -- Setter ---------------------------------------------------------------------@@ -137,26 +105,6 @@ setter abst = dimap (flip Index id) (\(Index s ab) -> abst ab s) . repn collect {-# INLINE setter #-} --- | Build an 'Ixsetter' from an indexed function.------ @--- 'isetter' '.' 'iover' ≡ 'id'--- 'iover' '.' 'isetter' ≡ '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'.----isetter :: ((i -> a -> b) -> s -> t) -> Ixsetter i s t a b-isetter f = setter $ \iab -> f (curry iab) . snd -{-# INLINE isetter #-}- -- | Every valid 'Grate' is a 'Setter'. -- closing :: (((s -> a) -> b) -> t) -> Setter s t a b@@ -181,21 +129,6 @@ resetter abst = dimap (\s -> Coindex $ \ab -> abst ab s) trivial . corepn (\f -> fmap f . sequenceA) {-# INLINE resetter #-} --- | 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'.----ksetter :: ((k -> a -> t) -> s -> t) -> Cxsetter k s t a t-ksetter f = resetter $ \kab -> const . f (flip kab)-{-# INLINE ksetter #-}- --------------------------------------------------------------------- -- Optics  ---------------------------------------------------------------------@@ -259,25 +192,6 @@ contramapped = setter contramap {-# INLINE contramapped #-} --- | Map one exception into another as proposed in the paper "A semantics for imprecise exceptions".------ >>> 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 #-}---- | 'Setter' on a particular value of an 'Adjustable' container.----adjusted :: Adjustable f => Key f -> Setter' (f a) a -adjusted i = setter $ \f -> K.adjust f i-{-# INLINE adjusted #-}- -- | 'Setter' on each value of an applicative. -- -- @@@ -334,32 +248,13 @@  -- | Apply a function only when the given condition holds. ----- See also 'Data.Profunctor.Optic.Affine.predicated' & 'Data.Profunctor.Optic.Prism.filtered'.+-- See also 'Data.Profunctor.Optic.Traversal0.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 #-}  ------------------------------------------------------------------------ Indexed optics -------------------------------------------------------------------------- | 'Ixsetter' on each value of a 'Keyed' container.----imapped :: Keyed f => Ixsetter (Key f) (f a) (f b) a b-imapped = isetter K.mapWithKey-{-# INLINE imapped #-}---- | 'Ixsetter' on each value of a representable functor.------ >>> 1 :+ 2 & imappedRep %~ bool 20 10--- 20 :+ 10----imappedRep :: F.Representable f => Ixsetter (F.Rep f) (f a) (f b) a b-imappedRep = isetter F.imapRep-{-# INLINE imappedRep #-}----------------------------------------------------------------------- -- Operators --------------------------------------------------------------------- @@ -373,31 +268,6 @@ set = (.~) {-# INLINE set #-} --- | Prefix alias of '%~'.------ Equivalent to 'iover' with the current value ignored.------ @--- 'set' o ≡ 'iset' o '.' 'const'--- @------ >>> iset (iat 2) (2-) [1,2,3 :: Int]--- [1,2,0]--- >>> iset (iat 5) (const 0) [1,2,3 :: Int]--- [1,2,3]----iset :: (Additive-Monoid) i => AIxsetter i s t a b -> (i -> b) -> s -> t-iset o = iover o . (const .)-{-# INLINE iset #-}---- | Prefix alias of '#~'.------ Equivalent to 'kover' with the current value ignored.----kset :: (Additive-Monoid) k => ACxsetter k s t a b -> (k -> b) -> s -> t -kset o kb = kover o $ flip (const kb)-{-# INLINE kset #-}- -- | Prefix alias of '..~'. -- -- @@@ -420,22 +290,34 @@ over = id {-# INLINE over #-} --- | Prefix alias of '%%~'.------ >>> iover (iat 1) (+) [1,2,3 :: Int]--- [1,3,3]--- >>> iover (iat 5) (+) [1,2,3 :: Int]--- [1,2,3]+infixr 4 .~, ..~++-- | Set all referenced fields to the given value. ---iover :: (Additive-Monoid) i => AIxsetter i s t a b -> (i -> a -> b) -> s -> t-iover = (%%~)-{-# INLINE iover #-}+(.~) :: Optic (->) s t a b -> b -> s -> t+(.~) o b = o (const b)+{-# INLINE (.~) #-} --- | Prefix alias of '##~'.+-- | Map over an optic. ---kover :: (Additive-Monoid) k => ACxsetter k s t a b -> (k -> a -> b) -> s -> t -kover = (##~)-{-# INLINE kover #-}+-- >>> Just 1 & just ..~ (+1)+-- Just 2+--+-- >>> Nothing & just ..~ (+1)+-- Nothing+--+-- >>> [1,2,3] & fmapped ..~ (*10)+-- [10,20,30]+--+-- >>> (1,2) & first' ..~ (+1) +-- (2,2)+--+-- >>> (10,20) & first' ..~ show +-- ("10",20)+--+(..~) :: Optic (->) s t a b -> (a -> b) -> s -> t+(..~) = id+{-# INLINE (..~) #-}  -- | Modify the target by adding another value. --@@ -474,7 +356,7 @@ scribe o s = Writer.tell $ set o mempty s {-# INLINE scribe #-} -infix 4 .=, ..=, %=, %%=, #=, ##=, <>=+infix 4 .=, ..=, <>=  -- | Replace the target(s) of a settable in a monadic state. --@@ -501,18 +383,6 @@ o .= b = State.modify (o .~ b) {-# INLINE (.=) #-} --- | TODO: Document ----(%=) :: MonadState s m => (Additive-Monoid) i => AIxsetter i s s a b -> (i -> b) -> m ()-o %= b = State.modify (o %~ b)-{-# INLINE (%=) #-}---- | TODO: Document ----(#=) :: MonadState s m => (Additive-Monoid) k => ACxsetter k s s a b -> (k -> b) -> m ()-o #= f = State.modify (o #~ f)-{-# INLINE (#=) #-}- -- | Map over the target(s) of a 'Setter' in a monadic state. -- -- This is an infixversion of 'modifies'.@@ -527,18 +397,6 @@ (..=) :: MonadState s m => Optic (->) s s a b -> (a -> b) -> m () o ..= f = State.modify (o ..~ f) {-# INLINE (..=) #-}---- | TODO: Document ----(%%=) :: MonadState s m => (Additive-Monoid) i => AIxsetter i s s a b -> (i -> a -> b) -> m () -o %%= f = State.modify (o %%~ f)-{-# INLINE (%%=) #-}---- | TODO: Document ----(##=) :: MonadState s m => (Additive-Monoid) k => ACxsetter k s s a b -> (k -> a -> b) -> m () -o ##= f = State.modify (o ##~ f)-{-# INLINE (##=) #-}  -- | Modify the target(s) of a settable optic by adding a value. --

@@ -6,30 +6,57 @@ {-# LANGUAGE TypeOperators         #-} {-# LANGUAGE TypeFamilies          #-} module Data.Profunctor.Optic.Traversal (-    -- * Traversal & Ixtraversal-    Traversal+    -- * Traversal0+    Traversal0+  , Traversal0'+  , traversal0+  , traversal0'+  , traversal0Vl+    -- * Traversal+  , Traversal   , Traversal'-  , Ixtraversal-  , Ixtraversal'+  , Cotraversal+  , Cotraversal'   , traversing-  , itraversing   , traversalVl-  , itraversalVl-  , noix-  , ix+  , cotraversing+  , retraversing+  , cotraversalVl     -- * Traversal1   , Traversal1   , Traversal1'-  , Ixtraversal1-  , Ixtraversal1'+  , Cotraversal1+  , Cotraversal1'   , traversing1   , traversal1Vl-  , itraversal1Vl+  , pappend+  , (<<*>>)+  , (****)+  , (&&&&)+  , divide+  , divide'+  , cochoose+  , cochoose'+  , cotraversing1+  , retraversing1+  , cotraversal1Vl+  , (++++)+  , (||||)+  , codivide+  , codivide'+  , choose+  , choose'     -- * Optics+  , nulled+  , selected   , traversed+  , cotraversed   , traversed1+  , cotraversed1   , both+  , coboth   , both1+  , coboth1   , duplicated   , beside   , bitraversed@@ -37,35 +64,33 @@   , repeated    , iterated   , cycled-    -- * Indexed optics-  , itraversed-  , itraversed1-  , itraversedRep-    -- * Primitive operators-  , withTraversal-  , withIxtraversal-  , withTraversal1-  , withIxtraversal1     -- * Operators+  , matches+  , traverses+  , cotraverses+  , cotraverses1+  , traverses1   , sequences+  , collects    , sequences1+  , collects1+    -- * Classes+  , Strong(..)+  , Choice(..)+  , Closed(..)+  , Representable(..)+  , Corepresentable(..) ) where -import Control.Category-import Control.Arrow+import Data.Function import Data.Bitraversable-import Data.Key as K-import Data.List.NonEmpty as NonEmpty import Data.Profunctor.Optic.Carrier+import Data.Profunctor.Optic.Prism import Data.Profunctor.Optic.Lens-import Data.Profunctor.Optic.Import hiding (id,(.))+import Data.Profunctor.Optic.Import import Data.Profunctor.Optic.Types-import Data.Profunctor.Optic.Operator+import Data.Profunctor.Optic.Combinator import Data.Semigroup.Bitraversable-import Data.Semiring-import Control.Monad.Trans.State-import Prelude (Foldable(..), reverse)-import qualified Data.Functor.Rep as F  -- $setup -- >>> :set -XNoOverloadedStrings@@ -73,18 +98,62 @@ -- >>> :set -XTypeApplications -- >>> :set -XTupleSections -- >>> :set -XRankNTypes+-- >>> import Data.Int+-- >>> import Data.String -- >>> 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 itraversed :: Ixtraversal Int Int [a] [b] a b ; itraversed = itraversalVl itraverse  ------------------------------------------------------------------------ 'Traversal' & 'Ixtraversal'+-- 'Traversal0' --------------------------------------------------------------------- +-- | Create a 'Traversal0' from match and constructor functions.+--+-- /Caution/: In order for the 'Traversal0' to be well-defined,+-- 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@+--+-- * @sbt (sbt s a1) a2 ≡ sbt s a2@+--+-- 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'.+--+traversal0 :: (s -> t + a) -> (s -> b -> t) -> Traversal0 s t a b+traversal0 sta sbt = dimap (\s -> (s,) <$> sta s) (id ||| uncurry sbt) . right' . second'+{-# INLINE traversal0 #-}++-- | Obtain a 'Traversal0'' from match and constructor functions.+--+traversal0' :: (s -> Maybe a) -> (s -> a -> s) -> Traversal0' s a+traversal0' sa sas = flip traversal0 sas $ \s -> maybe (Left s) Right (sa s)+{-# INLINE traversal0' #-}++-- | 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+{-# INLINE traversal0Vl #-}++---------------------------------------------------------------------+-- 'Traversal'+---------------------------------------------------------------------+ -- | Obtain a 'Traversal' by lifting a lens getter and setter into a 'Traversable' functor. -- -- @@@ -112,27 +181,7 @@ -- 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 'itraversing' ≡ 'itraversed' . 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@------ * @sbt (sbt s a1) a2 ≡ sbt s a2@------ See 'Data.Profunctor.Optic.Property'.----itraversing :: (Additive-Monoid) i => Traversable f => (s -> (i , a)) -> (s -> b -> t) -> Ixtraversal i (f s) (f t) a b-itraversing sia sbt = repn (\iab -> traverse (curry iab zero) . snd) . ilens sia sbt +{-# INLINE traversing #-}  -- | Obtain a profunctor 'Traversal' from a Van Laarhoven 'Traversal'. --@@ -143,52 +192,63 @@ -- -- * @fmap (abst f) . abst g ≡ getCompose . abst (Compose . fmap f . g)@ --+-- The traversal laws can be stated in terms of 'withStar':+-- +-- * @withStar t (pure . f) ≡ pure (fmap f)@+--+-- * @Compose . fmap (withStar t f) . withStar t g ≡ withStar t (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+{-# INLINE traversalVl #-} --- | Lift an indexed VL traversal into an indexed profunctor traversal.+-- | Obtain a 'Cotraversal' by embedding a continuation into a 'Distributive' functor.  --+-- @+--  'withGrate' o 'cotraversing' ≡ 'cotraversed' . o+-- @+-- -- /Caution/: In order for the generated optic to be well-defined,--- you must ensure that the input satisfies the following properties:+-- you must ensure that the input function satisfies the following+-- properties: ----- * @iabst (const pure) ≡ pure@+-- * @sabt ($ s) ≡ s@ ----- * @fmap (iabst $ const f) . (iabst $ const g) ≡ getCompose . iabst (const $ Compose . fmap f . g)@+-- * @sabt (\k -> f (k . sabt)) ≡ sabt (\k -> f ($ k))@ ----- See 'Data.Profunctor.Optic.Property'.+cotraversing :: Distributive g => (((s -> a) -> b) -> t) -> Cotraversal (g s) (g t) a b+cotraversing sabt = corepn cotraverse . grate sabt++-- | Obtain a 'Cotraversal' by embedding a reversed lens getter and setter into a 'Distributive' functor. ---itraversalVl :: (forall f. Applicative f => (i -> a -> f b) -> s -> f t) -> Ixtraversal i s t a b-itraversalVl f = traversalVl $ \iab -> f (curry iab) . snd+-- @+--  'withLens' ('re' o) 'cotraversing' ≡ 'cotraversed' . o+-- @+--+retraversing :: Distributive g => (b -> t) -> (b -> s -> a) -> Cotraversal (g s) (g t) a b+retraversing bsa bt = corepn cotraverse . (re $ lens bsa bt) --- | Lift a VL traversal into an indexed profunctor traversal that ignores its input.+-- | Obtain a profunctor 'Cotraversal' from a Van Laarhoven 'Cotraversal'. ----- Useful as the first optic in a chain when no indexed equivalent is at hand.+-- /Caution/: In order for the generated optic to be well-defined,+-- you must ensure that the input satisfies the following properties: ----- >>> ilists (noix traversed . itraversed) ["foo", "bar"]--- [(0,'f'),(1,'o'),(2,'o'),(0,'b'),(1,'a'),(2,'r')]--- >>> ilists (itraversed . noix traversed) ["foo", "bar"]--- [(0,'f'),(0,'o'),(0,'o'),(0,'b'),(0,'a'),(0,'r')]+-- * @abst copure ≡ copure@ ---noix :: (Additive-Monoid) i => Traversal s t a b -> Ixtraversal i s t a b-noix o = itraversalVl $ \iab s -> flip runStar s . o . Star $ iab zero---- | Index a traversal with a 'Data.Semiring'.+-- * @abst f . fmap (abst g) ≡ abst (f . fmap g . getCompose) . Compose@ ----- >>> ilists (ix traversed . ix traversed) ["foo", "bar"]--- [((),'f'),((),'o'),((),'o'),((),'b'),((),'a'),((),'r')]--- >>> ilists (ix @Int traversed . ix traversed) ["foo", "bar"]--- [(0,'f'),(1,'o'),(2,'o'),(0,'b'),(1,'a'),(2,'r')]--- >>> ilists (ix @[()] traversed . ix traversed) ["foo", "bar"]--- [([],'f'),([()],'o'),([(),()],'o'),([],'b'),([()],'a'),([(),()],'r')]--- >>> ilists (ix @[()] traversed % ix traversed) ["foo", "bar"]--- [([],'f'),([()],'o'),([(),()],'o'),([()],'b'),([(),()],'a'),([(),(),()],'r')]+-- The cotraversal laws can be restated in terms of 'withCostar': ---ix :: Semiring i => Traversal s t a b -> Ixtraversal i s t a b-ix o = itraversalVl $ \f s ->-  flip evalState zero . getCompose . flip runStar s . o . Star $ \a ->-    Compose $ (f <$> get <*> pure a) <* modify (+ one) +-- * @withCostar o (f . copure) ≡  fmap f . copure@+--+-- * @withCostar o f . fmap (withCostar o g) == withCostar o (f . fmap g . getCompose) . Compose@+--+-- See 'Data.Profunctor.Optic.Property'.+--+cotraversalVl :: (forall f. Coapplicative f => (f a -> b) -> f s -> t) -> Cotraversal s t a b+cotraversalVl abst = cotabulate . abst . cosieve   --------------------------------------------------------------------- -- 'Traversal1'@@ -221,6 +281,7 @@ -- traversing1 :: Traversable1 f => (s -> a) -> (s -> b -> t) -> Traversal1 (f s) (f t) a b traversing1 sa sbt = repn traverse1 . lens sa sbt+{-# INLINE traversing1 #-}  -- | Obtain a profunctor 'Traversal1' from a Van Laarhoven 'Traversal1'. --@@ -233,20 +294,53 @@ -- traversal1Vl :: (forall f. Apply f => (a -> f b) -> s -> f t) -> Traversal1 s t a b traversal1Vl abst = tabulate . abst . sieve +{-# INLINE traversal1Vl #-} --- | Lift an indexed VL traversal into an indexed profunctor traversal.+-- | Obtain a 'Cotraversal1' by embedding a continuation into a 'Distributive1' functor.  --+-- @+--  'withGrate' o 'cotraversing1' ≡ 'cotraversed1' . o+-- @+-- -- /Caution/: In order for the generated optic to be well-defined,+-- you must ensure that the input function satisfies the following+-- properties:+--+-- * @sabt ($ s) ≡ s@+--+-- * @sabt (\k -> f (k . sabt)) ≡ sabt (\k -> f ($ k))@+--+cotraversing1 :: Distributive1 g => (((s -> a) -> b) -> t) -> Cotraversal1 (g s) (g t) a b+cotraversing1 sabt = corepn cotraverse1 . grate sabt++-- | Obtain a 'Cotraversal1' by embedding a reversed lens getter and setter into a 'Distributive1' functor.+--+-- @+--  'withLens' ('re' o) 'cotraversing' ≡ 'cotraversed' . o+-- @+--+retraversing1 :: Distributive1 g => (b -> t) -> (b -> s -> a) -> Cotraversal1 (g s) (g t) a b+retraversing1 bsa bt = corepn cotraverse1 . (re $ lens bsa bt)++-- | 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: ----- * @iabst (const pure) ≡ pure@+-- * @abst runIdentity ≡ runIdentity@ ----- * @fmap (iabst $ const f) . (iabst $ const g) ≡ getCompose . iabst (const $ Compose . fmap f . g)@+-- * @abst f . fmap (abst g) ≡ abst (f . fmap g . getCompose) . Compose@ --+-- The cotraversal1 laws can be restated in terms of 'withCostar':+--+-- * @withCostar o (f . runIdentity) ≡  fmap f . runIdentity@+--+-- * @withCostar o f . fmap (withCostar o g) == withCostar o (f . fmap g . getCompose) . Compose@+-- -- See 'Data.Profunctor.Optic.Property'. ---itraversal1Vl :: (forall f. Apply f => (i -> a -> f b) -> s -> f t) -> Ixtraversal1 i s t a b-itraversal1Vl f = traversal1Vl $ \iab -> f (curry iab) . snd+cotraversal1Vl :: (forall f. Coapply f => (f a -> b) -> f s -> t) -> Cotraversal1 s t a b+cotraversal1Vl abst = cotabulate . abst . cosieve   --------------------------------------------------------------------- -- Optics@@ -254,9 +348,29 @@  -- | TODO: Document --+nulled :: Traversal0' s a+nulled = traversal0 Left const +{-# INLINE nulled #-}++-- | TODO: Document+--+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 #-}++-- | TODO: Document+-- traversed :: Traversable f => Traversal (f a) (f b) a b traversed = traversalVl traverse+{-# INLINE traversed #-} +-- | TODO: Document+--+cotraversed :: Distributive f => Cotraversal (f a) (f b) a b +cotraversed = cotraversalVl cotraverse+{-# INLINE cotraversed #-}++ -- | Obtain a 'Traversal1' from a 'Traversable1' functor. -- traversed1 :: Traversable1 t => Traversal1 (t a) (t b) a b@@ -265,42 +379,66 @@  -- | TODO: Document ----- >>> withTraversal both (pure . length) ("hello","world")+cotraversed1 :: Distributive1 f => Cotraversal1 (f a) (f b) a b +cotraversed1 = cotraversal1Vl cotraverse1+{-# INLINE cotraversed1 #-}++-- | TODO: Document+--+-- >>> traverses both (pure . length) ("hello","world") -- (5,5) -- both :: Traversal (a , a) (b , b) a b both p = p **** p+{-# INLINE both #-}  -- | TODO: Document ----- >>> withTraversal1 both1 (pure . NE.length) ('h' :| "ello", 'w' :| "orld")+coboth :: Cotraversal (a + a) (b + b) a b+coboth p = p ++++ p+{-# INLINE coboth #-}++-- | TODO: Document+--+-- >>> traverses 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)+both1 p = p **** p {-# INLINE both1 #-} --- | Duplicate the results of any 'Moore'. +-- | TODO: Document --+-- >>> cotraverses1 coboth1 (foldMap id) $ Left "foo" :| [Right "bar"]+-- Left "foo"+-- >>> cotraverses1 coboth1 (foldMap id) $ Right "foo" :| [Right "bar"]+-- Right "foobar"+-- +coboth1 :: Cotraversal1 (a + a) (b + b) a b+coboth1 p = p ++++ p+{-# INLINE coboth1 #-}++-- | Duplicate the results of a 'Traversal'. +-- -- >>> lists (both . duplicated) ("hello","world") -- ["hello","hello","world","world"] -- duplicated :: Traversal a b a b duplicated p = pappend p p+{-# INLINE duplicated #-}  -- | TODO: Document -- beside :: Bitraversable r => Traversal s1 t1 a b -> Traversal s2 t2 a b -> Traversal (r s1 s2) (r t1 t2) a b beside x y p = tabulate go where go rss = bitraverse (sieve $ x p) (sieve $ y p) rss+{-# INLINE beside #-}  -- | Traverse both parts of a 'Bitraversable' container with matching types. ----- >>> withTraversal bitraversed (pure . length) (Right "hello")+-- >>> traverses bitraversed (pure . length) (Right "hello") -- Right 5------ >>> withTraversal bitraversed (pure . length) ("hello","world")+-- >>> traverses bitraversed (pure . length) ("hello","world") -- (5,5)--- -- >>> ("hello","world") ^. bitraversed -- "helloworld" --@@ -315,7 +453,7 @@  -- | Traverse both parts of a 'Bitraversable1' container with matching types. ----- >>> withTraversal1 bitraversed1 (pure . NE.length) ('h' :| "ello", 'w' :| "orld")+-- >>> traverses bitraversed1 (pure . NE.length) ('h' :| "ello", 'w' :| "orld") -- (5,5) -- bitraversed1 :: Bitraversable1 r => Traversal1 (r a a) (r b b) a b@@ -366,85 +504,77 @@ -- @ -- 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+cycled o = repn $ \g a -> go g a where go g a = (withStar o g) a .> go g a {-# INLINE cycled #-}  ------------------------------------------------------------------------ Indexed optics +-- Operators --------------------------------------------------------------------- --- | TODO: Document+-- | Test whether the optic matches or not. ---itraversed :: TraversableWithKey f => Traversable f => Ixtraversal (Key f) (f a) (f b) a b-itraversed = itraversalVl K.traverseWithKey---- | TODO: Document+-- >>> matches just (Just 2)+-- Right 2+-- >>> matches just (Nothing :: Maybe Int) :: Either (Maybe Bool) Int+-- Left Nothing ---itraversed1 :: TraversableWithKey1 f => Traversable1 f => Ixtraversal1 (Key f) (f a) (f b) a b-itraversed1 = itraversal1Vl K.traverseWithKey1+matches :: ATraversal0 s t a b -> s -> t + a+matches o = withAffine o $ \sta _ -> sta+{-# INLINE matches #-}  -- | TODO: Document ---itraversedRep :: F.Representable f => Traversable f => Ixtraversal (F.Rep f) (f a) (f b) a b-itraversedRep = itraversalVl F.itraverseRep-------------------------------------------------------------------------- Primitive operators----------------------------------------------------------------------+traverses :: Applicative f => ATraversal f s t a b -> (a -> f b) -> s -> f t+traverses = withStar+{-# INLINE traverses #-} --- | ------ The traversal laws can be stated in terms of 'withTraversal':--- --- * @withTraversal t (Identity . f) ≡ Identity (fmap f)@------ * @Compose . fmap (withTraversal t f) . withTraversal t g ≡ withTraversal t (Compose . fmap f . g)@+-- | TODO: Document ---withTraversal :: Applicative f => ATraversal f s t a b -> (a -> f b) -> s -> f t-withTraversal = withStar-{-# INLINE withTraversal #-}+cotraverses :: Coapplicative f => ACotraversal f s t a b -> (f a -> b) -> f s -> t +cotraverses = withCostar+{-# INLINE cotraverses #-}  -- | TODO: Document ---withIxtraversal :: Applicative f => AIxtraversal f i s t a b -> (i -> a -> f b) -> i -> s -> f t-withIxtraversal o f = curry $ withTraversal o (uncurry f)-{-# INLINE withIxtraversal #-}+traverses1 :: Apply f => ATraversal1 f s t a b -> (a -> f b) -> s -> f t+traverses1 = withStar+{-# INLINE traverses1 #-} --- |------ The traversal laws can be stated in terms of 'withTraversal1':--- --- * @withTraversal1 t (Identity . f) ≡  Identity (fmap f)@------ * @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 = withStar-{-# INLINE withTraversal1 #-}  -- | TODO: Document ---withIxtraversal1 :: Apply f => AIxtraversal1 f i s t a b -> (i -> a -> f b) -> i -> s -> f t-withIxtraversal1 o f = curry $ withTraversal1 o (uncurry f)-{-# INLINE withIxtraversal1 #-}-------------------------------------------------------------------------- Operators----------------------------------------------------------------------+cotraverses1 :: Coapply f => ACotraversal1 f s t a b -> (f a -> b) -> f s -> t+cotraverses1 = withCostar+{-# INLINE cotraverses1 #-}  -- | TODO: Document -- sequences :: Applicative f => ATraversal f s t (f a) a -> s -> f t-sequences o = withTraversal o id+sequences o = traverses o id {-# INLINE sequences #-}  -- | TODO: Document --+-- >>> collects left' (1, Left "foo") :: Either (Int8, String) String+-- Left (1,"foo")+-- >>> collects left' (1, Right "foo")+-- Right "foo"+--+collects :: Coapplicative f => ACotraversal f s t a (f a) -> f s -> t+collects o = cotraverses o id+{-# INLINE collects #-}++-- | TODO: Document+-- sequences1 :: Apply f => ATraversal1 f s t (f a) a -> s -> f t-sequences1 o = withTraversal1 o id+sequences1 o = traverses1 o id {-# INLINE sequences1 #-}++-- | TODO: Document+--+-- >>> collects1 cotraversed1 ["xxx","ooo"] :: [String]+-- ["xo","xo","xo"]+--+collects1 :: Coapply f => ACotraversal1 f s t a (f a) -> f s -> t+collects1 o = cotraverses1 o id+{-# INLINE collects1 #-}

@@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}@@ -9,353 +10,244 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE QuantifiedConstraints #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  #ifndef MIN_VERSION_profunctors #define MIN_VERSION_profunctors(x,y,z) 1 #endif  module Data.Profunctor.Optic.Types (-    -- * Optic, IndexedOptic, & CoindexedOptic+    -- * Optic     Optic, Optic'-  , IndexedOptic, IndexedOptic'-  , CoindexedOptic, CoindexedOptic'-    -- * Iso & Equality-  , Iso, Iso', Equality, Equality'-    -- * Lens-  , Lens, Lens', Ixlens, Ixlens'+    -- * Constraints+  , Affine, Coaffine+  , Traversing, Cotraversing+  , Traversing1, Cotraversing1+  , CoerceL, CoerceR+  , Mapping, Comapping+  , Mapping1, Comapping1+    -- * Equality+  , Equality, Equality'+    -- * Iso+  , Iso, Iso'     -- * Prism-  , Prism, Prism', Cxprism, Cxprism'+  , Prism, Coprism+  , Prism', Coprism'+    -- * Lens+  , Lens, Colens+  , Lens', Colens'     -- * Grate-  , Grate, Grate', Cxgrate, Cxgrate'-    -- * Affine & Option-  , Affine, Affine', Ixaffine, Ixaffine'-  , Option, Ixoption-    -- * Grism-  , Grism , Grism'-    -- * Traversal, Traversal1, Fold & Fold1-  , Traversal    , Traversal'   , Ixtraversal , Ixtraversal'-  , Traversal1   , Traversal1'  , Ixtraversal1, Ixtraversal1'-  , Fold, Ixfold , Fold1, Ixfold1-    -- * Cotraversal-  , Cotraversal  , Cotraversal'-    -- * View & Review-  , PrimView, View, Ixview, PrimReview, Review, Cxview-    -- * Setter & Resetter-  , Setter, Setter', Ixsetter, Ixsetter'-  , Resetter, Resetter', Cxsetter, Cxsetter'-    -- * Coapplicative-  , Coapplicative(..), Branch(..)-  , between+  , Grate, Grate'+    -- * Traversal+  , Traversal0, Cotraversal0+  , Traversal, Cotraversal+  , Traversal1, Cotraversal1+  , Traversal0', Cotraversal0'+  , Traversal', Cotraversal'+  , Traversal1', Cotraversal1'+    -- * Fold+  , Fold0, Fold, Fold1+    -- * Setter+  , Setter, Resetter+  , Setter', Resetter'+    -- * View+  , View, Review     -- * 'Re'   , Re(..), re+  , between   , module Export ) where  import Data.Bifunctor (Bifunctor(..)) import Data.Functor.Apply (Apply(..))-import Data.Profunctor.Optic.Import hiding (branch)-import Data.Profunctor.Extra as Export (type (+))+import Data.Profunctor.Optic.Import import Data.Profunctor.Types as Export-import qualified Control.Arrow as A -import Data.List.NonEmpty as L1-import qualified Data.Bifunctor as B- -- $setup -- >>> :set -XCPP -- >>> :set -XNoOverloadedStrings -- >>> :load Data.Profunctor.Optic  ------------------------------------------------------------------------ Optic+-- Constraints --------------------------------------------------------------------- -type Optic p s t a b = p a b -> p s t+type Affine p = (Choice p, Strong p) -type Optic' p s a = Optic p s s a a+type Coaffine p = (Choice p, Closed p) -type IndexedOptic p i s t a b = p (i , a) b -> p (i , s) t+type Traversing p = (Representable p, Applicative' (Rep p)) -type IndexedOptic' p i s a = IndexedOptic p i s s a a+type Cotraversing p = (Corepresentable p, Coapplicative (Corep p)) -type CoindexedOptic p k s t a b = p a (k -> b) -> p s (k -> t)+type Traversing1 p = (Representable p, Apply (Rep p)) -type CoindexedOptic' p k t b = CoindexedOptic p k t t b b+type Cotraversing1 p = (Corepresentable p, Coapply (Corep p)) +type CoerceL p = (Bifunctor p)++type CoerceR p = (forall x. Contravariant (p x))++type Mapping p = (Representable p, Distributive (Rep p))++type Mapping1 p = (Representable p, Distributive1 (Rep p))++type Comapping p = (Corepresentable p, Traversable (Corep p))++type Comapping1 p = (Corepresentable p, Traversable1 (Corep p))+ ------------------------------------------------------------------------ Iso & Equality+-- Optic --------------------------------------------------------------------- --- | 'Iso'------ \( \mathsf{Iso}\;S\;A = S \cong A \)----type Iso s t a b = forall p. Profunctor p => Optic p s t a b+type Optic p s t a b = p a b -> p s t -type Iso' s a = Iso s s a a+type Optic' p s a = Optic p s s a a +---------------------------------------------------------------------+-- Equality+---------------------------------------------------------------------++-- | \( \mathsf{Equality}\;A = A \cong A \)+-- type Equality s t a b = forall p. Optic p s t a b  type Equality' s a = Equality s s a a  ------------------------------------------------------------------------ Lens+-- Iso --------------------------------------------------------------------- --- | Lenses access one piece of a product.------ \( \mathsf{Lens}\;S\;A  = \exists C, S \cong C \times A \)+-- | \( \mathsf{Iso}\;S\;A = S \cong A \) ---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 Ixlens i s t a b = forall p. Strong p => IndexedOptic p i s t a b +type Iso s t a b = forall p. Profunctor p => Optic p s t a b -type Ixlens' i s a = Ixlens i s s a a +type Iso' s a = Iso s s a a  --------------------------------------------------------------------- -- Prism --------------------------------------------------------------------- --- | Prisms access one piece of a sum.------ \( \mathsf{Prism}\;S\;A = \exists D, S \cong D + A \)+-- | \( \mathsf{Prism}\;S\;A = \exists D, S \cong D + A \) -- 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+-- | \( \mathsf{Prism}\;S\;A = \exists D, S + D \cong A \)+--+type Coprism s t a b = forall p. Cochoice 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 Prism' s a = Prism s s a a -type Cxprism' k s a = Cxprism k s s a a+type Coprism' t b = Coprism t t b b  ------------------------------------------------------------------------ Grate+-- Lens --------------------------------------------------------------------- --- | Grates access the codomain of a function.------  \( \mathsf{Grate}\;S\;A = \exists I, S \cong I \to A \)+-- | \( \mathsf{Lens}\;S\;A  = \exists C, S \cong C \times A \) ---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 Cxgrate k s t a b = forall p. Closed p => CoindexedOptic p k s t a b --type Cxgrate' k s a = Cxgrate k s s a a--type Colens s t a b = forall p. Costrong p => Optic p s t a b +type Lens s t a b = forall p. Strong p => Optic p s t a b -type Colens' s a = Colens s s a a+-- | \( \mathsf{Lens}\;S\;A  = \exists C, S \times C \cong A \)+--+type Colens s t a b = forall p. 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+-- | \( \mathsf{Grate}\;S\;A = \exists I, S \cong I \to A \)+--+type Grate s t a b = forall p. Closed p => Optic p s t a b  -type Cxlens' k s a = Cxlens k s s a a+type Lens' s a = Lens s s a a -type Cotraversal0 s t a b = forall p. (Choice p, Closed p) => Optic p s t a b+type Colens' t b = Lens t t b b -type Cotraversal0' t b = Cotraversal0 t t b b+type Grate' s a = Grate s s a a  ------------------------------------------------------------------------ Affine & Option+-- Traversal0 --------------------------------------------------------------------- --- | A 'Affine' processes 0 or more parts of the whole, with no interactions.------ \( \mathsf{Affine}\;S\;A = \exists C, D, S \cong D + C \times A \)+-- | \( \mathsf{Traversal0}\;S\;A = \exists C, D, S \cong D + C \times A \) ---type Affine s t a b = forall p. (Choice p, Strong p) => Optic p s t a b --type Affine' s a = Affine s s a a--type Ixaffine i s t a b = forall p. (Choice p, Strong p) => IndexedOptic p i s t a b --type Ixaffine' i s a = Ixaffine i s s a a +type Traversal0 s t a b = forall p. Affine p => Optic p s t a b  --- | A 'Option' combines at most one element, with no interactions.+-- | \( \mathsf{Cotraversal0}\;S\;A = \exists D, I, S \cong I \to D + A \) ---type Option s a = forall p. (Choice p, Strong p, forall x. Contravariant (p x)) => Optic' p s a --type Ixoption i s a = forall p. (Choice p, Strong p, forall x. Contravariant (p x)) => IndexedOptic' p i s a -------------------------------------------------------------------------- Grism----------------------------------------------------------------------+type Cotraversal0 s t a b = forall p. Coaffine p => Optic p s t a b --- | https://en.wikipedia.org/wiki/Grism----type Grism s t a b = forall p. (Choice p, Closed p) => Optic p s t a b+type Traversal0' s a = Traversal0 s s a a -type Grism' t b = Grism t t b b+type Cotraversal0' t b = Cotraversal0 t t b b  ------------------------------------------------------------------------ Traversal, Traversal1, Fold, & Fold1+-- Traversal --------------------------------------------------------------------- --- | A 'Traversal' processes 0 or more parts of the whole, with 'Applicative' interactions.------ \( \mathsf{Traversal}\;S\;A = \exists F : \mathsf{Traversable}, S \equiv F\,A \)+-- | \( \mathsf{Traversal}\;S\;A = \exists F : \mathsf{Traversable}, S \equiv F\,A \) ---type Traversal s t a b = forall p. (Choice p, Strong p, Representable p, Applicative (Rep p)) => Optic p s t a b--type Traversal' s a = Traversal s s a a--type Ixtraversal i s t a b = forall p. (Choice p, Strong p, Representable p, Applicative (Rep p)) => IndexedOptic p i s t a b --type Ixtraversal' i s a = Ixtraversal i s s a a+type Traversal s t a b = forall p. (Affine p, Traversing p) => Optic p s t a b --- | A 'Traversal1' processes 1 or more parts of the whole, with 'Apply' interactions.------ \( \mathsf{Traversal1}\;S\;A = \exists F : \mathsf{Traversable1}, S \equiv F\,A \)+-- | \( \mathsf{Cotraversal}\;S\;A = \exists F : \mathsf{Distributive}, S \equiv F\,A \) ---type Traversal1 s t a b = forall p. (Strong p, Representable p, Apply (Rep p)) => Optic p s t a b --type Traversal1' s a = Traversal1 s s a a+type Cotraversal s t a b = forall p. (Coaffine p, Cotraversing p) => Optic p s t a b -type Ixtraversal1 i s t a b = forall p. (Strong p, Representable p, Apply (Rep p)) => IndexedOptic p i s t a b +type Traversal' s a = Traversal s s a a -type Ixtraversal1' i s a = Ixtraversal1 i s s a a+type Cotraversal' t b = Cotraversal t t b b -type Cofold0 t b = forall p. (Choice p, Closed p, Strong p, forall x. Contravariant (p x)) => Optic' p t b +---------------------------------------------------------------------+-- Traversal1+--------------------------------------------------------------------- --- | A 'Fold1' combines 1 or more elements, with 'Semigroup' interactions.+-- | \( \mathsf{Traversal1}\;S\;A = \exists F : \mathsf{Traversable1}, S \equiv F\,A \) ---type Fold1 s a = forall p. (Strong p, Representable p, Apply (Rep p), forall x. Contravariant (p x)) => Optic' p s a --type Ixfold1 i s a = forall p. (Strong p, Representable p, Apply (Rep p), forall x. Contravariant (p x)) => IndexedOptic' p i s a+type Traversal1 s t a b = forall p. (Strong p, Traversing1 p) => Optic p s t a b  --- | A 'Fold' combines 0 or more elements, with 'Monoid' interactions.+-- | \( \mathsf{Cotraversal1}\;S\;A = \exists F : \mathsf{Distributive1}, S \equiv F\,A \) ---type Fold s a = forall p. (Choice p, Representable p, Applicative (Rep p), forall x. Contravariant (p x)) => Optic' p s a+type Cotraversal1 s t a b = forall p. (Closed p, Cotraversing1 p) => Optic p s t a b -type Ixfold i s a = forall p. (Choice p, Representable p, Applicative (Rep p), forall x. Contravariant (p x)) => IndexedOptic' p i s a+type Traversal1' s a = Traversal1 s s a a --- type Cofold t b = forall p. (Closed p, Corepresentable p, Coapplicative (Corep p), Bifunctor p) => Optic' p t b+type Cotraversal1' t b = Cotraversal1 t t b b  ------------------------------------------------------------------------ Cotraversal+-- Fold --------------------------------------------------------------------- -type Cotraversal s t a b = forall p. (Choice p, Closed p, Coapplicative (Corep p), Corepresentable p) => Optic p s t a b+type Fold0 s a = forall p. (Affine p, CoerceR p) => Optic' p s a  -type Cotraversal' t b = Cotraversal t t b b+type Fold s a = forall p. (Affine p, Traversing p, CoerceR p) => Optic' p s a +type Fold1 s a = forall p. (Strong p, Traversing1 p, CoerceR p) => Optic' p s a + ------------------------------------------------------------------------ View & Review+-- View --------------------------------------------------------------------- -type PrimView s t a b = forall p. (Profunctor p, forall x. Contravariant (p x)) => Optic p s t a b--type View s a = forall p. (Strong p, forall x. Contravariant (p x)) => Optic' p s a --type Ixview i s a = forall p. (Strong p, forall x. Contravariant (p x)) => IndexedOptic' p i s a--type PrimReview s t a b = forall p. (Profunctor p, Bifunctor p) => Optic p s t a b--type Review t b = forall p. (Closed p, Bifunctor p) => Optic' p t b+type View s a = forall p. (Strong p, CoerceR p) => Optic' p s a  -type Cxview k t b = forall p. (Closed p, Bifunctor p) => CoindexedOptic' p k t b+type Review t b = forall p. (Closed p, CoerceL p) => Optic' p t b  ------------------------------------------------------------------------ Setter & Resetter+-- Setter --------------------------------------------------------------------- --- | A 'Setter' modifies part of a structure.+-- | \( \mathsf{Setter}\;S\;A = \exists F : \mathsf{Functor}, S \equiv F\,A \) ----- \( \mathsf{Setter}\;S\;A = \exists F : \mathsf{Functor}, S \equiv F\,A \)+type Setter s t a b = forall p. (Affine p, Traversing p, Mapping p) => Optic p s t a b++-- | \( \mathsf{Setter}\;S\;A = \exists F : \mathsf{Functor}, F\,S \equiv A \) ---type Setter s t a b = forall p. (Choice p, Strong p, Representable p, Applicative (Rep p), Distributive (Rep p)) => Optic p s t a b+type Resetter s t a b = forall p. (Coaffine p, Cotraversing p, Comapping p) => Optic p s t a b   type Setter' s a = Setter s s a a -type Ixsetter i s t a b = forall p. (Choice p, Strong p, Representable p, Applicative (Rep p), Distributive (Rep p)) => IndexedOptic p i s t a b--type Ixsetter' i s a = Ixsetter i s s a a --type Resetter s t a b = forall p. (Choice p, Closed p, Corepresentable p, Coapplicative (Corep p), Traversable (Corep p)) => Optic p s t a b - type Resetter' s a = Resetter s s a a -type Cxsetter k s t a b = forall p. (Choice p, Closed p, Corepresentable p, Coapplicative (Corep p), Traversable (Corep p)) => CoindexedOptic p k s t a b--type Cxsetter' k t b = Cxsetter k t t b b -- ------------------------------------------------------------------------ Branch & Coapplicative+-- 'Re'  --------------------------------------------------------------------- --- branch . fmap Left == Left --- branch . fmap Right == Right--- (fmap Left ||| fmap Right) . branch == id---- >>> (fmap Left ||| fmap Right) . branch $ (Left 1) :| [Right 2]--- Left 1 :| []----class Functor f => Branch f where-  branch :: f (Either a b) -> Either (f a) (f b)--cobranch :: Apply f => (f a, f b) -> f (a, b)-cobranch = uncurry $ liftF2 (,)--instance Branch Identity where-  branch (Identity ab) = either (Left . Identity) (Right . Identity) ab--{--instance Branch (Const r) where branch (Const r) = Right (Const r)--}--instance Branch (Tagged k) where-  branch (Tagged ab) = either (Left . Tagged) (Right . Tagged) ab--instance Branch ((,) r) where-  branch (r, a) = either (Left . (r,)) (Right . (r,)) a--instance Monoid m => Branch ((->) m) where-  branch f = either (Left . const) (Right . const) $ f mempty--instance Branch NonEmpty where-  branch (Left x :| zs) = Left $ x :| foldr (either (:) (const id)) [] zs-  branch (Right y :| zs) = Right $ y :| foldr (either (const id) (:)) [] zs--instance (Branch f, Branch g) => Branch (Compose f g) where-  branch (Compose ab) = B.bimap Compose Compose . branch . fmap branch $ ab--class Branch f => Coapplicative f where-  -- either (f . copure) (g . copure) . branch == either f g . copure-  copure :: f a -> a--instance Coapplicative Identity where-  copure (Identity a) = a--instance Coapplicative (Tagged k) where-  copure (Tagged a) = a--instance Coapplicative ((,) r) where-  copure (_, a) = a--instance Monoid m => Coapplicative ((->) m) where-  copure f = f mempty--instance Coapplicative NonEmpty where-  copure = L1.head--catLefts :: [Either a b] -> [a]-catLefts = foldr (either (:) (const id)) []--catRights :: [Either a b] -> [b]-catRights = foldr (either (const id) (:)) []--instance (Coapplicative f, Coapplicative g) => Coapplicative (Compose f g) where-  copure (Compose a) = copure . fmap copure $ a--#if MIN_VERSION_profunctors(5,4,0)-instance Coapplicative f => Choice (Costar f) where-  left' (Costar f) = Costar $ either (Left . f) (Right . copure) . branch-#endif- -- | Can be used to rewrite -- -- > \g -> f . g . h@@ -368,18 +260,8 @@ between f g = (f .) . (. g) {-# INLINE between #-} ------------------------------------------------------------------------- 'Re' ----------------------------------------------------------------------- -- | Reverse an optic to obtain its dual. ----- >>> 5 ^. re left'--- Left 5------ >>> 6 ^. re (left' . from succ)--- Left 7--- -- @ -- 're' . 're'  ≡ id -- @@@ -388,8 +270,13 @@ -- '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' :: 'Traversal' s t a b  -> 'Cotraversal' b a t s+-- 're' :: 'View' s t a b  -> 'Review' b a t s -- @ --+-- >>> 5 ^. re left'+-- Left 5+-- re :: Optic (Re p a b) s t a b -> Optic p b a t s re o = (between runRe Re) o id {-# INLINE re #-}@@ -398,6 +285,7 @@ -- newtype Re p s t a b = Re { runRe :: p b a -> p t s } +-- TODO: Closed, Representable, Corepresentable instances instance Profunctor p => Profunctor (Re p s t) where   dimap f g (Re p) = Re (p . dimap g f) @@ -441,6 +329,13 @@    second f (Costar g) = Costar $ f . g +#if MIN_VERSION_profunctors(5,4,0)+-- used for Choice operations (e.g. preview) on Cotraversals & Cofolds+-- e.g. +-- distributes left' (1, Left "foo")+instance Coapplicative f => Choice (Costar f) where+  left' (Costar f) = Costar $ either (Left . f) (Right . copure) . coapply+#endif  {- #if !(MIN_VERSION_profunctors(5,5,0))@@ -448,12 +343,5 @@   unleft (Forget f) = Forget $ f . Left    unright (Forget f) = Forget $ f . Right-#endif--#if MIN_VERSION_profunctors(5,4,0)-instance Comonad f => Choice (Costar f) where-  left' (Costar f) = Costar . runCostar . A.left . Costar $ f--  right' (Costar f) = Costar . runCostar . A.right . Costar $ f #endif -}

@@ -6,66 +6,35 @@ module Data.Profunctor.Optic.View (     -- * Types     View-  , Ixview-  , PrimView   , Review-  , Cxview-  , PrimReview     -- * Constructors   , to-  , ito   , from-  , kfrom   , cloneView   , cloneReview     -- * Optics   , like-  , ilike   , relike-  , klike   , toProduct   , fromSum-    -- * Primitive operators-  , withPrimView-  , withPrimReview     -- * Operators   , (^.)-  , (^%)   , view-  , iview   , views-  , iviews   , use-  , iuse   , uses-  , iuses-  , (#^)   , review-  , kview   , reviews-  , kviews   , reuse   , reuses-  , kuse-  , kuses-    -- * MonadIO-  , throws-  , throws_-  , throwsTo ) 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 import Data.Profunctor.Optic.Carrier import Data.Profunctor.Optic.Types-import Data.Profunctor.Optic.Operator+import Data.Profunctor.Optic.Combinator import Data.Profunctor.Optic.Import-import GHC.Conc (ThreadId)-import qualified Control.Exception as Ex-import qualified Data.Bifunctor as B  -- $setup -- >>> :set -XNoOverloadedStrings@@ -75,9 +44,7 @@ -- >>> import Data.Either -- >>> import Control.Monad.State -- >>> import Control.Monad.Writer--- >>> import Data.List.Index as LI -- >>> :load Data.Profunctor.Optic Data.Either.Optic Data.Tuple.Optic--- >>> let itraversed :: Ixtraversal Int [a] [b] a b ; itraversed = itraversalVl itraverse  --------------------------------------------------------------------- -- 'View' & 'Review'@@ -103,53 +70,40 @@ -- 'to' :: (s -> a) -> 'View' s a -- @ ---to :: (s -> a) -> PrimView s t a b+to :: (s -> a) -> View s a to f = coercer . lmap f {-# INLINE to #-} --- | TODO: Document----ito :: (s -> (i , a)) -> Ixview i s a-ito f = to $ f . snd-{-# INLINE ito #-}- -- | Obtain a 'Review' from an arbitrary function. -- -- @ -- 'from' ≡ 're' . 'to' -- @ ----- >>> (from Prelude.length) #^ [1,2,3]+-- >>> review (from Prelude.length) [1,2,3] -- 3 -- -- @ -- 'from' :: (b -> t) -> 'Review' t b -- @ ---from :: (b -> t) -> PrimReview s t a b +from :: (b -> t) -> Review t b  from f = coercel . rmap f {-# INLINE from #-}  -- | TODO: Document ---kfrom :: ((k -> b) -> t) -> Cxview k t b-kfrom f = from $ \kb _ -> f kb-{-# INLINE kfrom #-}---- | TODO: Document--- -- @--- 'cloneView' ::             'AView' s a -> 'View' s a--- 'cloneView' :: 'Monoid' a => 'AView' s a -> 'Fold' s a+-- 'cloneView' :: 'Monoid' a => 'AView' a s a -> 'Fold' s a -- @ ---cloneView :: AView s a -> PrimView s s a a+cloneView :: AView a s a -> View s a cloneView = to . view {-# INLINE cloneView #-}  -- | TODO: Document ---cloneReview :: AReview t b -> PrimReview t t b b+cloneReview :: AReview t b -> Review t b cloneReview = from . review {-# INLINE cloneReview #-} @@ -173,16 +127,10 @@ -- 'like' :: a -> 'View' s a -- @ ---like :: a -> PrimView s t a b+like :: a -> View s a like = to . const {-# INLINE like #-} --- | TODO: Document----ilike :: i -> a -> Ixview i s a-ilike i a = ito (const (i, a))-{-# INLINE ilike #-}- -- | Obtain a constant-valued (index-preserving) 'Review' from an arbitrary value. -- -- @@@ -191,23 +139,17 @@ -- 'relike' a '#' b ≡ 'from' ('const' a) '#' b -- @ ---relike :: t -> PrimReview s t a b+relike :: t -> Review t b relike = from . const {-# INLINE relike #-} --- | Obtain a constant-valued 'Cxview' from an arbitrary value. ----klike :: t -> Cxview k t b-klike = kfrom . const-{-# INLINE klike #-}- -- | 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 :: AView a1 s a1 -> AView a2 s a2 -> View s (a1 , a2) toProduct l r = to (view l &&& view r) {-# INLINE toProduct #-} @@ -217,7 +159,7 @@ -- '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 :: AReview t b1 -> AReview t b2 -> Review t (b1 + b2) fromSum l r = from (review l ||| review r) {-# INLINE fromSum #-} @@ -225,6 +167,27 @@ -- Operators --------------------------------------------------------------------- +infixl 8 ^.++-- | View the focus of an optic.+--+-- Fixity and semantics are such that subsequent field accesses can be+-- performed with ('Prelude..').+--+-- >>> ("hello","world") ^. second'+-- "world"+--+-- >>> 5 ^. to succ+-- 6+--+-- >>> import Data.Complex+-- >>> ((0, 1 :+ 2), 3) ^. first' . second' . to magnitude+-- 2.23606797749979+--+(^.) :: s -> AView a s a -> a+(^.) s o = withView o id s+{-# INLINE ( ^. ) #-}+ -- | A prefix alias for '^.'. -- -- @@@ -240,19 +203,10 @@ -- >>> view (second' . first') ("hello",("world","!!!")) -- "world" ---view :: MonadReader s m => AView s a -> m a+view :: MonadReader s m => AView a s a -> m a view o = views o id {-# INLINE view #-} --- | A prefix alias for '^%'.------ >>> iview ifirst ("foo", 42)--- (Just (),"foo")----iview :: MonadReader s m => (Additive-Monoid) i => AIxview i s a -> m (Maybe i , a)-iview o = asks $ withPrimView o (B.first Just) . (zero,)-{-# INLINE iview #-}- -- | Map each part of a structure viewed to a semantic editor combinator. -- -- @@@ -263,30 +217,16 @@ -- >>> views both id (["foo"], ["bar", "baz"]) -- ["foo","bar","baz"] ---views :: MonadReader s m => Optic' (Star (Const r)) s a -> (a -> r) -> m r-views o f = asks $ withPrimView o f+views :: MonadReader s m => AView r s a -> (a -> r) -> m r+views o f = asks $ withView o f {-# INLINE views #-} --- | Bring a function of the index and value of an indexed optic into the current environment.------ 'iviews' ≡ 'iwithFold'------ Use 'iview' if there is a need to disambiguate between 'zero' as a miss vs. as a return value.----iviews :: MonadReader s m => (Additive-Monoid) i => IndexedOptic' (Star (Const r)) i s a -> (i -> a -> r) -> m r-iviews o f = asks $ withPrimView o (uncurry f) . (zero,) - -- | TODO: Document ---use :: MonadState s m => AView s a -> m a+use :: MonadState s m => AView a 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.----iuse :: MonadState s m => (Additive-Monoid) i => AIxview i s a -> m (Maybe i , a)-iuse o = gets (iview 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@@ -299,18 +239,15 @@ 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.----iuses :: MonadState s m => (Additive-Monoid) i => IndexedOptic' (Star (Const r)) i s a -> (i -> a -> r) -> m r-iuses o f = gets $ withPrimView o (uncurry f) . (zero,)---- | A prefix alias of '#^'.+-- | A prefix alias of '.^'. -- -- @ -- 'review' ≡ 'view' '.' 're' -- 'review' . 'from' ≡ 'id' -- @ --+-- >>> review left' 4+-- Left 4 -- >>> review (from succ) 5 -- 6 --@@ -318,12 +255,6 @@ review o = reviews o id {-# INLINE review #-} --- | Bring a function of the index of a co-indexed optic into the current environment.----kview :: MonadReader b m => ACxview k t b -> m (k -> t)-kview o = kviews o id-{-# INLINE kview #-}- -- | Turn an optic around and look through the other end, applying a function. -- -- @@@ -338,18 +269,9 @@ -- 8 -- reviews :: MonadReader b m => AReview t b -> (t -> r) -> m r-reviews o f = asks $ withPrimReview o f+reviews o f = asks $ withReview o f {-# INLINE reviews #-} --- | Bring a continuation of the index of a co-indexed optic into the current environment.------ @--- kviews :: ACxview k t b -> ((k -> t) -> r) -> b -> r--- @----kviews :: MonadReader b m => ACxview k t b -> ((k -> t) -> r) -> m r-kviews o f = asks $ withPrimReview o f . const- -- | Turn an optic around and 'use' a value (or the current environment) through it the other way. -- -- @@@ -367,12 +289,6 @@ reuse o = gets (unTagged #. o .# Tagged) {-# INLINE reuse #-} --- | TODO: Document----kuse :: MonadState b m => ACxview k t b -> m (k -> t)-kuse o = gets (kview o)-{-# INLINE kuse #-}- -- | Turn an optic around and 'use' the current state through it the other way, applying a function. -- -- @@@ -386,37 +302,3 @@ reuses :: MonadState b m => AReview t b -> (t -> r) -> m r reuses o tr = gets (tr . unTagged #. o .# Tagged) {-# INLINE reuses #-}---- | TODO: Document----kuses :: MonadState b m => ACxview k t b -> ((k -> t) -> r) -> m r-kuses o f = gets (kviews o f)-{-# INLINE kuses #-}-------------------------------------------------------------------------- '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)