profunctor-optics 0.0.0.2 → 0.0.0.3

raw patch · 33 files changed

+3926/−3686 lines, 33 filesdep +adjunctionsdep +hedgehogdep ~basedep ~connectionsdep ~containersnew-component:exe:doctestPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: adjunctions, hedgehog

Dependency ranges changed: base, connections, containers, ilist, profunctors, rings, transformers

API changes (from Hackage documentation)

Files

• profunctor-optics.cabal +50/−28
• src/Data/Connection/Optic/Float.hs +10/−14
• src/Data/Either/Optic.hs +27/−0
• src/Data/Profunctor/Optic.hs +16/−16
• src/Data/Profunctor/Optic/Affine.hs +160/−0
• src/Data/Profunctor/Optic/Carrier.hs +552/−0
• src/Data/Profunctor/Optic/Cotraversal.hs +147/−0
• src/Data/Profunctor/Optic/Fold.hs +379/−313
• src/Data/Profunctor/Optic/Fold0.hs +0/−341
• src/Data/Profunctor/Optic/Fold1.hs +0/−335
• src/Data/Profunctor/Optic/Grate.hs +163/−129
• src/Data/Profunctor/Optic/Import.hs +8/−2
• src/Data/Profunctor/Optic/Index.hs +199/−74
• src/Data/Profunctor/Optic/Iso.hs +117/−178
• src/Data/Profunctor/Optic/Lens.hs +47/−206
• src/Data/Profunctor/Optic/Operator.hs +181/−33
• src/Data/Profunctor/Optic/Option.hs +274/−0
• src/Data/Profunctor/Optic/Prelude.hs +263/−0
• src/Data/Profunctor/Optic/Prism.hs +61/−208
• src/Data/Profunctor/Optic/Property.hs +74/−84
• src/Data/Profunctor/Optic/Setter.hs +206/−493
• src/Data/Profunctor/Optic/Traversal.hs +222/−55
• src/Data/Profunctor/Optic/Traversal0.hs +0/−266
• src/Data/Profunctor/Optic/Traversal1.hs +0/−326
• src/Data/Profunctor/Optic/Type.hs +0/−389
• src/Data/Profunctor/Optic/Types.hs +457/−0
• src/Data/Profunctor/Optic/View.hs +75/−181
• src/Data/Profunctor/Optic/Zoom.hs +147/−0
• src/Data/Tuple/Optic.hs +8/−1
• test/Test/Data/Connection/Optic/Int.hs +49/−0
• test/doctest.hs +19/−0
• test/doctests.hs +0/−14
• test/test.hs +15/−0

@@ -1,27 +1,27 @@ cabal-version: >= 1.10  name:           profunctor-optics-version:        0.0.0.2+version:        0.0.0.3 synopsis:       An optics library compatible with the typeclasses in 'profunctors'. description:     This package provides utilities for creating and manipulating profunctor-based optics. Some highlights:   .-  Full complement of isos, prisms, lenses, grates, traversals (affine, regular, and non-empty), folds (affine, regular, and non-empty), views, and setters. Many of these have categorical duals.+  Full complement of isos, prisms, lenses, grates, affines, traversals, cotraversals, views, setters, folds, and more.   .-  Composable indexed and co-indexed variants of all of the above.+  Composable indexed or co-indexed variants of most of the above.   .   Compact & straight-forward implementation. No inscrutable internal modules, lawless or otherwise ancillary typeclasses, or heavy type-level machinery.   .-  Fully interoperable. All that is required to create optics (standard, idexable, or co-indexable) is the `profunctors` package, which is heavily used and seems likely to end up in `base` at some point. Optics compose with (.) from `Prelude` as is typical. If you want to provide profunctor optics for your own types in your own libraries, you can do so without incurring a dependency on this package. Conversions to & from the Van Laarhoven representations are provided for each optic type.+  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.   .   Well-documented properties and exportable predicates for testing your own optics.   .-  See the <https://github.com/cmk/profunctor-extras/blob/master/profunctor-optics/README.md Readme> file for more information. +  See the <https://github.com/cmk/profunctor-optics/blob/master/profunctor-optics/README.md Readme> file for more information.   category:       Data, Lenses, Profunctors stability:      Experimental-homepage:       https://github.com/cmk/profunctor-extras-bug-reports:    https://github.com/cmk/profunctor-extras/issues+homepage:       https://github.com/cmk/profunctor-optics+bug-reports:    https://github.com/cmk/profunctor-optics/issues author:         Chris McKinlay maintainer:     Chris McKinlay copyright:      2019 Chris McKinlay@@ -33,12 +33,13 @@  source-repository head   type: git-  location: https://github.com/cmk/profunctor-extras+  location: https://github.com/cmk/profunctor-optics  library   exposed-modules:       Control.Exception.Optic +      Data.Either.Optic       Data.Tuple.Optic        Data.Connection.Optic@@ -47,23 +48,27 @@       Data.Connection.Optic.Float        Data.Profunctor.Optic-      Data.Profunctor.Optic.Type+      Data.Profunctor.Optic.Types+      Data.Profunctor.Optic.Property+      Data.Profunctor.Optic.Carrier+      Data.Profunctor.Optic.Operator+      Data.Profunctor.Optic.Index+       Data.Profunctor.Optic.Iso-      Data.Profunctor.Optic.View-      Data.Profunctor.Optic.Setter-      Data.Profunctor.Optic.Lens       Data.Profunctor.Optic.Prism+      Data.Profunctor.Optic.Lens       Data.Profunctor.Optic.Grate-      Data.Profunctor.Optic.Fold-      Data.Profunctor.Optic.Fold0-      Data.Profunctor.Optic.Fold1+      Data.Profunctor.Optic.Affine+      Data.Profunctor.Optic.Option       Data.Profunctor.Optic.Traversal-      Data.Profunctor.Optic.Traversal0-      Data.Profunctor.Optic.Traversal1-      Data.Profunctor.Optic.Operator-      Data.Profunctor.Optic.Property-      Data.Profunctor.Optic.Index+      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,32 +95,49 @@   build-depends:       base              >= 4.9      && < 5.0     , comonad           >= 4        && < 6-    , connections       >= 0.0.2    && < 0.1-    , containers        >= 0.4.0    && < 0.7+    , connections       >= 0.0.2.1  && < 0.1     , distributive      >= 0.3      && < 1-    , ilist             >= 0.3.1.0  && < 0.4     , mtl               >= 2.0.1    && < 2.3     , newtype-generics  >= 0.5.3    && < 0.6     , profunctor-arrows >= 0.0.0.2  && < 0.0.1-    , profunctors       >= 5.2.1    && < 6-    , rings             >= 0.0.2    && < 0.1+    , profunctors       >= 5.3      && < 6+    , rings             >= 0.0.2.1  && < 0.1     , semigroupoids     >= 5        && < 6     , tagged            >= 0.4.4    && < 1-    , transformers      >= 0.2      && < 0.6+    , transformers      >= 0.5.6.0  && < 0.6     , unliftio-core     >= 0.1.2    && < 0.2+    , adjunctions       >= 4.4      && < 5.0 -test-suite doctests+test-suite test   type:              exitcode-stdio-1.0-  main-is:           doctests.hs+  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+  hs-source-dirs:    test+  default-language:  Haskell2010   x-doctest-options: --fast    build-depends:       base+    , adjunctions     , containers     , doctest >= 0.8+    , ilist     , mtl     , profunctor-optics 

@@ -1,9 +1,6 @@ module Data.Connection.Optic.Float (     f32u32   , u32f32-  , u32w64-  , f32i64-  , i64f32 ) where  import Data.Connection.Float (Ulp32)@@ -14,9 +11,9 @@ import Data.Word import qualified Data.Connection.Float as F --- >>> constOf f32u32 (Ulp32 0)+-- >>> coview f32u32 (Ulp32 0) -- 0.0--- >>> constOf f32u32 (Ulp32 1)+-- >>> coview f32u32 (Ulp32 1) -- 1.0e-45 f32u32 :: Grate' Float Ulp32 f32u32 = connected F.f32u32@@ -24,15 +21,14 @@ u32f32 :: Grate' Ulp32 Float u32f32 = connected F.u32f32 -u32w64 :: Grate' Ulp32 (Nan Word64)-u32w64 = connected F.u32w64---- >>> constOf f32i64 Nan+{-+-- >>> coview f32i32 Nan -- NaN--- >>> zipWithOf i64f32 (/) (Def 0) (Def 0)+-- >>> zipsWith i32f32 (/) (Def 0) (Def 0) -- Nan-f32i64 :: Grate' Float (Nan Int64)-f32i64 = connected F.f32i64+f32i32 :: Grate' Float (Nan Int64)+f32i32 = connected F.f32i32   -i64f32 :: Grate' (Nan Int64) Float-i64f32 = connected F.i64f32+i32f32 :: Grate' (Nan Int64) Float+i32f32 = connected F.i32f32+-}

@@ -0,0 +1,27 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TupleSections         #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeFamilies          #-}+module Data.Either.Optic (+    coswapped+  , coassociated+  , left+  , right+) where++import Data.Profunctor.Optic.Import+import Data.Profunctor.Optic.Iso+import Data.Profunctor.Optic.Prism++-- | 'Prism' into the `Left` constructor of `Either`.+--+left :: Prism (a + c) (b + c) a b+left = left'++-- | 'Prism' into the `Right` constructor of `Either`.+--+right :: Prism (c + a) (c + b) a b+right = right'

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

@@ -0,0 +1,160 @@+{-# 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+  , is+  , isnt+  , 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+-- >>> let catchOn :: Int -> Cxprism' Int (Maybe String) String ; catchOn n = kjust $ \k -> if k==n then Just "caught" else Nothing+-- >>> let itraversed :: Ixtraversal Int [a] [b] a b ; itraversed = itraversalVl itraverse++---------------------------------------------------------------------+-- '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+---------------------------------------------------------------------++-- | Check whether the optic is matched.+--+-- >>> is just Nothing+-- False+--+is :: AAffine s t a b -> s -> Bool+is o = either (const False) (const True) . matches o+{-# INLINE is #-}++-- | Check whether the optic isn't matched.+--+-- >>> isnt just Nothing+-- True+--+isnt :: AAffine s t a b -> s -> Bool+isnt o = either (const True) (const False) . matches o+{-# INLINE isnt #-}++-- | 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 #-}

@@ -0,0 +1,552 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TupleSections         #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeFamilies          #-}+module Data.Profunctor.Optic.Carrier (+    -- * Carrier types+    AIso+  , AIso'+  , APrism+  , APrism'+  , ALens+  , ALens'+  , AIxlens+  , AIxlens'+  , AGrate+  , AGrate'+  , ACxgrate+  , ACxgrate'+  , AAffine+  , AAffine'+  , AOption+  , AIxoption+  , AGrism+  , AGrism'+  , ARepn+  , ARepn'+  , AIxrepn+  , AIxrepn'+  , ATraversal+  , ATraversal'+  , ATraversal1+  , ATraversal1'+  , AFold+  , AIxfold+  , AFold1+  , AIxfold1+  , APrimView+  , AView+  , AIxview+  , AIxsetter+  , AIxsetter'+  , ACorepn+  , ACorepn'+  , ACxrepn'+  , ACotraversal+  , ACotraversal'+  , AList+  , AList'+  , AList1+  , AList1'+  , AScope+  , AScope'+  , AScope1+  , AScope1'+  , APrimReview+  , AReview+  , ACxview+  , ACxsetter+  , ACxsetter'+    -- * Primitive operators+  , withIso+  , withPrism+  , withLens+  , withIxlens+  , withGrate+  , withCxgrate+  , withAffine+  , withGrism+  , withOption+  , withIxoption+  , withStar+  , withCostar+  , withPrimView+  , withPrimReview+  , withIxsetter+  , withCxsetter+    -- * Carrier profunctors+  , IsoRep(..)+  , PrismRep(..)+  , LensRep(..)+  , IxlensRep(..)+  , GrateRep(..)+  , CxgrateRep(..)+  , AffineRep(..)+  , GrismRep(..)+  , OptionRep(..)+  , Star(..)+  , Costar(..)+  , Tagged(..)+) where++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.Rep (unfirstCorep)++import qualified Data.Bifunctor as B+-- $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.Int.Instance ()+-- >>> import Data.Map as Map+-- >>> import Data.Maybe+-- >>> import Data.Monoid+-- >>> import Data.Semiring hiding (unital,nonunital,presemiring)+-- >>> :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) ++---------------------------------------------------------------------+-- Carriers+---------------------------------------------------------------------++type AIso s t a b = Optic (IsoRep a b) s t a b++type AIso' s a = AIso s s a a++type APrism s t a b = Optic (PrismRep a b) s t a b++type APrism' s a = APrism 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 AIxlens' i s a = AIxlens i 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 AIxrepn' f i s a = AIxrepn f i s s a a++type ATraversal f s t a b = Applicative f => ARepn f s t a b++type ATraversal' f s a = ATraversal f s s a a++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 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 AIxview i s a = AIxrepn' (Const (Maybe i , a)) i s a++type AIxsetter i s t a b = IndexedOptic (->) i s t a b++type AIxsetter' i s a = AIxsetter i s s a a++type ACorepn f s t a b = Optic (Costar f) s t a b++type ACorepn' f t b = ACorepn f t t b b++type ACxrepn f k s t a b = CoindexedOptic (Costar f) k s t a b++type ACxrepn' f k t b = ACxrepn f k t t b b++type ACotraversal f s t a b = Coapplicative f => ACorepn f s t a b++type ACotraversal' f s a = ACotraversal f s s a a++type AList f s t a b = Foldable f => ACorepn f s t a b++type AList' f s a = AList f s s a a++type AList1 f s t a b = Foldable1 f => ACorepn f s t a b++type AList1' f s a = AList1 f s s a a++type AScope f s t a b = Traversable f => ACorepn f s t a b++type AScope' f s a = AScope f s s a a++type AScope1 f s t a b = Traversable1 f => ACorepn f s t a b++type AScope1' f s a = AScope1 f s s a a++type APrimReview s t a b = Optic Tagged s t a b++type AReview t b = Optic' Tagged t b++type ACxview k t b = CoindexedOptic' Tagged k t b++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+withIso x k = case x (IsoRep id id) of IsoRep sa bt -> k sa bt+{-# INLINE withIso #-}++-- | Extract the two functions that characterize a 'Prism'.+--+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++-- | 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++-- | Extract the two functions that characterize a 'Lens'.+--+withIxlens :: Monoid i => AIxlens i s t a b -> ((s -> (i , a)) -> (s -> b -> t) -> r) -> r+withIxlens o f = case o (IxlensRep id $ flip const) of IxlensRep x y -> f (x . (mempty,)) (\s b -> y (mempty, s) b)++-- | 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 :: 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 mempty++-- | 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+--+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+--+withOption :: Optic (OptionRep r) s t a b -> (a -> Maybe r) -> s -> Maybe r+withOption o = runOptionRep #. o .# OptionRep+{-# INLINE withOption #-}++-- | TODO: Document+--+withIxoption :: Monoid i => AIxoption r i s a -> (i -> a -> Maybe r) -> s -> Maybe r+withIxoption o f = flip curry mempty $ withOption o (uncurry f)+{-# INLINE withIxoption #-}++-- | TODO: Document+--+withStar :: ARepn f s t a b -> (a -> f b) -> s -> f t+withStar o = runStar #. o .# Star+{-# INLINE withStar #-}++-- | 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 #-}++-- | TODO: Document+--+withPrimReview :: APrimReview s t a b -> (t -> r) -> b -> r+withPrimReview o f = f . unTagged #. o .# Tagged+{-# INLINE withPrimReview #-}++-- | TODO: Document+--+withIxsetter :: IndexedOptic (->) i s t a b -> (i -> a -> b) -> i -> s -> t+withIxsetter o = unConjoin #. corepn o .# Conjoin+{-# INLINE withIxsetter #-}++-- | TODO: Document+--+withCxsetter :: CoindexedOptic (->) k s t a b -> (k -> a -> b) -> k -> s -> t+withCxsetter o = unConjoin #. repn o .# Conjoin+{-# INLINE withCxsetter #-}++---------------------------------------------------------------------+-- IsoRep+---------------------------------------------------------------------++-- | The 'IsoRep' profunctor precisely characterizes an 'Iso'.+data IsoRep a b s t = IsoRep (s -> a) (b -> t)++instance Profunctor (IsoRep a b) where+  dimap f g (IsoRep sa bt) = IsoRep (sa . f) (g . bt)+  {-# INLINE dimap #-}+  lmap f (IsoRep sa bt) = IsoRep (sa . f) bt+  {-# INLINE lmap #-}+  rmap f (IsoRep sa bt) = IsoRep sa (f . bt)+  {-# INLINE rmap #-}++instance Sieve (IsoRep a b) (Index a b) where+  sieve (IsoRep sa bt) s = Index (sa s) bt++instance Cosieve (IsoRep a b) (Coindex a b) where+  cosieve (IsoRep sa bt) (Coindex sab) = bt (sab sa)++---------------------------------------------------------------------+-- PrismRep+---------------------------------------------------------------------++-- | The 'PrismRep' profunctor precisely characterizes a 'Prism'.+--+data PrismRep a b s t = PrismRep (s -> t + a) (b -> t)++instance Profunctor (PrismRep a b) where+  dimap f g (PrismRep sta bt) = PrismRep (first g . sta . f) (g . bt)+  {-# INLINE dimap #-}++  lmap f (PrismRep sta bt) = PrismRep (sta . f) bt+  {-# INLINE lmap #-}++  rmap f (PrismRep sta bt) = PrismRep (first f . sta) (f . bt)+  {-# INLINE rmap #-}++instance Choice (PrismRep a b) where+  left' (PrismRep sta bt) = PrismRep (either (first Left . sta) (Left . Right)) (Left . bt)+  {-# INLINE left' #-}++  right' (PrismRep sta bt) = PrismRep (either (Left . Left) (first Right . sta)) (Right . bt)+  {-# INLINE right' #-}++---------------------------------------------------------------------+-- LensRep+---------------------------------------------------------------------++-- | The `LensRep` profunctor precisely characterizes a 'Lens'.+--+data LensRep a b s t = LensRep (s -> a) (s -> b -> t)++instance Profunctor (LensRep a b) where+  dimap f g (LensRep sa sbt) = LensRep (sa . f) (\s -> g . sbt (f s))++instance Strong (LensRep a b) where+  first' (LensRep sa sbt) =+    LensRep (\(a, _) -> sa a) (\(s, c) b -> (sbt s b, c))++  second' (LensRep sa sbt) =+    LensRep (\(_, a) -> sa a) (\(c, s) b -> (c, sbt s b))++instance Sieve (LensRep a b) (Index a b) where+  sieve (LensRep sa sbt) s = Index (sa s) (sbt s)++instance Representable (LensRep a b) where+  type Rep (LensRep a b) = Index a b++  tabulate f = LensRep (\s -> info (f s)) (\s -> vals (f s))++---------------------------------------------------------------------+-- IxlensRep+---------------------------------------------------------------------++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))++instance Strong (IxlensRep i a b) where+  first' (IxlensRep sia sbt) =+    IxlensRep (\(a, _) -> sia a) (\(s, c) b -> (sbt s b, c))++  second' (IxlensRep sia sbt) =+    IxlensRep (\(_, a) -> sia a) (\(c, s) b -> (c, sbt s b))++---------------------------------------------------------------------+-- GrateRep+---------------------------------------------------------------------++-- | The 'GrateRep' profunctor precisely characterizes 'Grate'.+--+newtype GrateRep a b s t = GrateRep { unGrateRep :: ((s -> a) -> b) -> t }++instance Profunctor (GrateRep a b) where+  dimap f g (GrateRep z) = GrateRep $ \d -> g (z $ \k -> d (k . f))++instance Closed (GrateRep a b) where+  closed (GrateRep sabt) = GrateRep $ \xsab x -> sabt $ \sa -> xsab $ \xs -> sa (xs x)++instance Costrong (GrateRep a b) where+  unfirst = unfirstCorep++instance Cosieve (GrateRep a b) (Coindex a b) where+  cosieve (GrateRep f) (Coindex g) = f g++instance Corepresentable (GrateRep a b) where+  type Corep (GrateRep a b) = Coindex a b++  cotabulate f = GrateRep $ f . Coindex++---------------------------------------------------------------------+-- CxgrateRep+---------------------------------------------------------------------++newtype CxgrateRep k a b s t = CxgrateRep { unCxgrateRep :: ((s -> a) -> k -> b) -> t }++--TODO Closed, Costrong++---------------------------------------------------------------------+-- AffineRep+---------------------------------------------------------------------++-- | The `AffineRep` profunctor precisely characterizes an 'Affine'.+data AffineRep a b s t = AffineRep (s -> t + a) (s -> b -> t)++instance Profunctor (AffineRep a b) where+  dimap f g (AffineRep sta sbt) = AffineRep+      (\a -> first g $ sta (f a))+      (\a v -> g (sbt (f a) v))++instance Strong (AffineRep a b) where+  first' (AffineRep sta sbt) = AffineRep+      (\(a, c) -> first (,c) $ sta a)+      (\(a, c) v -> (sbt a v, c))++instance Choice (AffineRep a b) where+  right' (AffineRep sta sbt) = AffineRep+      (\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 Representable (AffineRep a b) where+  type Rep (AffineRep a b) = IndexA a b++  tabulate f = AffineRep (info0 . f) (values0 . f)++data IndexA a b r = IndexA (r + a) (b -> r)++values0 :: IndexA a b r -> b -> r+values0 (IndexA _ br) = br++info0 :: IndexA a b r -> r + a+info0 (IndexA a _) = a++instance Functor (IndexA a b) where+  fmap f (IndexA ra br) = IndexA (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)++---------------------------------------------------------------------+-- 'GrismRep'+---------------------------------------------------------------------++--TODO: Corepresentable, Coapplicative (Corep)++-- | The 'GrismRep' profunctor precisely characterizes 'Grism'.+--+newtype GrismRep a b s t = GrismRep { unGrismRep :: ((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 Closed (GrismRep a b) where+  closed (GrismRep stabt) =+    GrismRep $ \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++---------------------------------------------------------------------+-- OptionRep+---------------------------------------------------------------------++newtype OptionRep r a b = OptionRep { runOptionRep :: a -> Maybe r }++--todo coerce+instance Functor (OptionRep r a) where+  fmap _ (OptionRep p) = OptionRep p++instance Contravariant (OptionRep r a) where+  contramap _ (OptionRep p) = OptionRep p++instance Profunctor (OptionRep r) where+  dimap f _ (OptionRep p) = OptionRep (p . f)++instance Choice (OptionRep r) where+  left' (OptionRep p) = OptionRep (either p (const Nothing))+  right' (OptionRep p) = OptionRep (either (const Nothing) p)++instance Cochoice (OptionRep r) where+  unleft  (OptionRep k) = OptionRep (k . Left)+  unright (OptionRep k) = OptionRep (k . Right)++instance Strong (OptionRep r) where+  first' (OptionRep p) = OptionRep (p . fst)+  second' (OptionRep p) = OptionRep (p . snd)++instance Sieve (OptionRep r) (Pre r) where+  sieve = (Pre .) . runOptionRep++instance Representable (OptionRep r) where+  type Rep (OptionRep r) = Pre r+  tabulate = OptionRep . (getPre .)+  {-# INLINE tabulate #-}++-- | 'Pre' is 'Maybe' with a phantom type variable.+--+newtype Pre a b = Pre { getPre :: Maybe a } deriving (Eq, Ord, Show)++instance Functor (Pre a) where fmap _ (Pre p) = Pre p++instance Contravariant (Pre a) where contramap _ (Pre p) = Pre p

@@ -0,0 +1,147 @@+{-# 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.Int.Instance ()+-- >>> import Data.List.NonEmpty (NonEmpty(..))+-- >>> import Data.Functor.Identity+-- >>> import Data.List.Index+-- >>> :load Data.Profunctor.Optic+-- >>> let catchOn :: Int -> Cxprism' Int (Maybe String) String ; catchOn n = kjust $ \k -> if k==n then Just "caught" else Nothing++---------------------------------------------------------------------+-- '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 #-}

@@ -5,6 +5,7 @@ {-# LANGUAGE TupleSections         #-} {-# LANGUAGE TypeOperators         #-} {-# LANGUAGE TypeFamilies          #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Data.Profunctor.Optic.Fold (     -- * Fold & Ixfold     Fold@@ -12,114 +13,112 @@   , fold_   , folding    , foldVl+  , ifoldVl   , toFold-  , cloneFold+  , afold+  , aifold+    -- * Fold1 & Ixfold1+  , Fold1+  , Ixfold1+  , fold1_+  , folding1+  , fold1Vl+  , toFold1+  , afold1     -- * Optics   , folded-  , folded_ +  , folded_+  , folded1 +  , folded1_+  , ifoldedRep   , unital+  , nonunital+  , presemiring   , summed+  , summed1   , multiplied+  , multiplied1     -- * Primitive operators   , withFold   , withIxfold+  , withFold1+  , withIxfold1     -- * Operators+  , lists   , (^..)-  , (^??)+  , ilists+  , ilistsFrom+  , (^%%)+  , nelists   , folds+  , ifolds+  , folds1   , foldsa   , foldsp+  , folds1p   , foldsr+  , ifoldsr+  , ifoldsrFrom   , foldsl+  , ifoldsl+  , ifoldslFrom+  , foldsr'+  , ifoldsr'   , foldsl'-  , lists+  , ifoldsl'+  , foldsrM+  , ifoldsrM+  , foldslM+  , ifoldslM   , traverses_-  , concats-  , finds-  , has-  , hasnt -  , nulls-  , asums-  , joins-  , joins'-  , meets-  , meets'-  , pelem-    -- * Indexed operators-  , (^%%)-  , ixfoldsr-  , ixfoldsrFrom-  , ixfoldsl-  , ixfoldslFrom-  , ixfoldsrM-  , ixfoldsrMFrom-  , ixfoldslM-  , ixfoldslMFrom-  , ixlists-  , ixlistsFrom-  , ixtraverses_-  , ixconcats-  , ixfinds+  , itraverses_     -- * Auxilliary Types   , All, Any-    -- * Carriers-  , FoldRep-  , AFold-  , AIxfold-  , afold-  , Star(..)-  , Costar(..)-    -- * Classes-  , Representable(..)-  , Corepresentable(..)-  , Contravariant(..)-  , Bifunctor(..)+  , Nedl(..) ) where -import Control.Applicative import Control.Monad (void) import Control.Monad.Reader as Reader hiding (lift) import Data.Bifunctor (Bifunctor(..)) import Data.Bool.Instance () -- Semigroup / Monoid / Semiring instances import Data.Foldable (Foldable, foldMap, traverse_)-import Data.Maybe import Data.Monoid hiding (All(..), Any(..))-import Data.Prd (Prd(..), Min(..), Max(..))-import Data.Prd.Lattice (Lattice(..))+import Data.Profunctor.Optic.Carrier import Data.Profunctor.Optic.Import-import Data.Profunctor.Optic.Type-import Data.Profunctor.Optic.View (AView, to, withPrimView, view, cloneView)+import Data.Profunctor.Optic.Traversal+import Data.Profunctor.Optic.Types+import Data.Profunctor.Optic.View import Data.Semiring (Semiring(..), Prod(..))-import qualified Data.Prd as Prd++import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.Functor.Rep as F import qualified Data.Semiring as Rng+import qualified Data.List.NonEmpty as NEL  -- $setup -- >>> :set -XNoOverloadedStrings -- >>> :set -XTypeApplications -- >>> :set -XFlexibleContexts+-- >>> :set -XRankNTypes -- >>> import Control.Exception hiding (catches) -- >>> import Data.Functor.Identity--- >>> import Data.List.Index+-- >>> import Data.List.Index as LI -- >>> import Data.Int.Instance ()+-- >>> import Data.List.NonEmpty (NonEmpty(..))+-- >>> import qualified Data.List.NonEmpty as NE+-- >>> import Data.Map.NonEmpty as Map1 -- >>> import Data.Map as Map--- >>> import Data.Sequence as Seq hiding ((><)) -- >>> import Data.Maybe -- >>> import Data.Monoid -- >>> import Data.Semiring hiding (unital,nonunital,presemiring) -- >>> :load Data.Profunctor.Optic--- >>> let ixtraversed :: Ixtraversal Int [a] [b] a b ; ixtraversed = ixtraversalVl itraverse+-- >>> 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)   --------------------------------------------------------------------- -- 'Fold' & 'Ixfold' --------------------------------------------------------------------- -type FoldRep r = Star (Const r)--type AFold r s a = Optic' (FoldRep r) s a---type AFold s a = forall r. Monoid r => Optic' (FoldRep r) s a--type AIxfold r i s a = IndexedOptic' (FoldRep r) i s a- -- | Obtain a 'Fold' directly. -- -- @ @@ -130,7 +129,7 @@ -- -- See 'Data.Profunctor.Optic.Property'. ----- This can be useful to repn operations from @Data.List@ and elsewhere into a 'Fold'.+-- This can be useful to lift operations from @Data.List@ and elsewhere into a 'Fold'. -- -- >>> [1,2,3,4] ^.. fold_ tail -- [2,3,4]@@ -153,22 +152,93 @@ -- | Obtain a 'Fold' from a Van Laarhoven 'Fold'. -- foldVl :: (forall f. Applicative f => (a -> f b) -> s -> f t) -> Fold s a-foldVl f = coercer . repn f . coercer+foldVl f = coercer . traversalVl f . coercer {-# INLINE foldVl #-} +-- | Obtain a 'Fold' 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 #-}+ -- | Obtain a 'Fold' from a 'View' or 'AFold'. -- toFold :: AView s a -> Fold s a toFold = to . view {-# INLINE toFold #-} --- | Obtain a 'Fold' from a 'AFold'.+-- | TODO: Document ---cloneFold :: Monoid a => AFold a s a -> View s a-cloneFold = cloneView-{-# INLINE cloneFold #-}+-- @+-- afold :: ((a -> r) -> s -> r) -> AFold r s a+-- @+--+afold :: ((a -> r) -> s -> r) -> APrimView r s t a b+afold f = Star #. (Const #.) #. f .# (getConst #.) .# runStar+{-# INLINE afold #-} +-- | TODO: Document+--+aifold :: ((i -> a -> r) -> s -> r) -> AIxfold r i s a+aifold f = afold $ \iar s -> f (curry iar) $ snd s+{-# INLINE aifold #-}+ ---------------------------------------------------------------------+-- 'Fold1' & 'Ixfold1'+---------------------------------------------------------------------++-- | Obtain a 'Fold1' directly.+--+-- @ +-- 'fold1_' ('nelists' o) ≡ o+-- 'fold1_' f ≡ 'to' f . 'fold1Vl' 'traverse1_'+-- 'fold1_' f ≡ 'coercer' . 'lmap' f . 'lift' 'traverse1_'+-- @+--+-- See 'Data.Profunctor.Optic.Property'.+--+-- This can be useful to repn operations from @Data.List.NonEmpty@ and elsewhere into a 'Fold1'.+--+fold1_ :: Foldable1 f => (s -> f a) -> Fold1 s a+fold1_ f = to f . fold1Vl traverse1_+{-# INLINE fold1_ #-}++-- | Obtain a 'Fold1' from a 'Traversable1' functor.+--+-- @+-- 'folding1' f ≡ 'traversed1' . 'to' f+-- 'folding1' f ≡ 'fold1Vl' 'traverse1' . 'to' f+-- @+--+folding1 :: Traversable1 f => (s -> a) -> Fold1 (f s) a+folding1 f = fold1Vl traverse1 . to f+{-# INLINE folding1 #-}++-- | Obtain a 'Fold1' from a Van Laarhoven 'Fold1'.+--+-- See 'Data.Profunctor.Optic.Property'.+--+fold1Vl :: (forall f. Apply f => (a -> f b) -> s -> f t) -> Fold1 s a+fold1Vl f = coercer . repn f . coercer+{-# INLINE fold1Vl #-}++-- | Obtain a 'Fold1' from a 'View' or 'AFold1'.+--+toFold1 :: AView s a -> Fold1 s a+toFold1 = to . view+{-# INLINE toFold1 #-}++-- | TODO: Document+--+-- @+-- afold1 :: ((a -> r) -> s -> r) -> AFold1 r s a+-- @+--+afold1 :: ((a -> r) -> s -> r) -> APrimView r s t a b+afold1 f = Star #. (Const #.) #. f .# (getConst #.) .# runStar+{-# INLINE afold1 #-}++--------------------------------------------------------------------- -- Optics  --------------------------------------------------------------------- @@ -188,6 +258,28 @@ folded_ = fold_ id {-# INLINE folded_ #-} +-- | Obtain a 'Fold1' from a 'Traversable1' functor.+--+folded1 :: Traversable1 f => Fold1 (f a) a+folded1 = folding1 id+{-# INLINE folded1 #-}++-- | The canonical 'Fold1'.+--+-- @+-- 'Data.Semigroup.Foldable.foldMap1' ≡ 'withFold1' 'folded1_''+-- @+--+folded1_ :: Foldable1 f => Fold1 (f a) a+folded1_ = fold1_ id+{-# INLINE folded1_ #-}++-- | 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 #-}+ -- | Expression in a unital semiring  -- -- @ @@ -209,6 +301,29 @@ unital = summed . multiplied {-# INLINE unital #-} +-- | Expression in a semiring expression with no multiplicative unit.+--+-- @ +-- 'nonunital' ≡ 'summed' . 'multiplied1'+-- @+--+-- >>> folds1 nonunital $ (fmap . fmap) Just [1 :| [2], 3 :| [4 :: Int]]+-- Just 14+--+nonunital :: Foldable f => Foldable1 g => Monoid r => Semiring r => AFold r (f (g a)) a+nonunital = summed . multiplied1+{-# INLINE nonunital #-}++-- | Expression in a semiring with no additive or multiplicative unit.+--+-- @ +-- 'presemiring' ≡ 'summed1' . 'multiplied1'+-- @+--+presemiring :: Foldable1 f => Foldable1 g => Semiring r => AFold1 r (f (g a)) a+presemiring = summed1 . multiplied1+{-# INLINE presemiring #-}+ -- | Monoidal sum of a foldable collection. -- -- >>> 1 <> 2 <> 3 <> 4 :: Int@@ -231,6 +346,17 @@ summed = afold foldMap {-# INLINE summed #-} +-- | Semigroup sum of a non-empty foldable collection.+--+-- >>> 1 <> 2 <> 3 <> 4 :: Int+-- 10+-- >>> folds1 summed1 $ 1 :| [2,3,4 :: Int]+-- 10+--+summed1 :: Foldable1 f => Semigroup r => AFold1 r (f a) a+summed1 = afold foldMap1+{-# INLINE summed1 #-}+ -- | Semiring product of a foldable collection. -- -- >>> 1 >< 2 >< 3 >< 4 :: Int@@ -250,6 +376,15 @@ multiplied = afold Rng.product {-# INLINE multiplied #-} +-- | Semiring product of a non-empty foldable collection. +--+-- >>> folds1 multiplied1 $ fmap Just (1 :| [2..(5 :: Int)])+-- Just 120 +--+multiplied1 :: Foldable1 f => Semiring r => AFold1 r (f a) a+multiplied1 = afold Rng.product1+{-# INLINE multiplied1 #-}+ --------------------------------------------------------------------- -- Primitive operators ---------------------------------------------------------------------@@ -263,48 +398,68 @@ -- >>> withFold both id (["foo"], ["bar", "baz"]) -- ["foo","bar","baz"] ----- >>> :t withFold . fold_--- withFold . fold_---   :: (Monoid r, Foldable f) => (s -> f a) -> (a -> r) -> s -> r--- -- >>> :t withFold traversed -- withFold traversed --   :: (Monoid r, Traversable f) => (a -> r) -> f a -> r ----- >>> :t withFold left--- withFold left :: Monoid r => (a -> r) -> (a + c) -> r------ >>> :t withFold t21--- withFold t21 :: Monoid r => (a -> r) -> (a, b) -> r------ >>> :t withFold $ selected even--- withFold $ selected even---   :: (Monoid r, Integral a) => (b -> r) -> (a, b) -> r------ >>> :t flip withFold Seq.singleton--- flip withFold Seq.singleton :: AFold (Seq a) s a -> s -> Seq a+-- @+-- 'withFold' :: 'Monoid' r => 'AFold' r s a -> (a -> r) -> s -> r+-- @ ---withFold :: Monoid r => AFold r s a -> (a -> r) -> s -> r+withFold :: Monoid r => APrimView r s t a b -> (a -> r) -> s -> r withFold = withPrimView {-# INLINE withFold #-} --- | TODO: Document+-- | Map an indexed optic to a monoid and combine the results. ----- >>> :t flip withIxfold Map.singleton--- flip withIxfold Map.singleton---   :: AIxfold (Map i a) i s a -> i -> s -> Map i a+-- Note that most indexed optics do not use their output index: ---withIxfold :: AIxfold r i s a -> (i -> a -> r) -> i -> s -> r-withIxfold o f = curry $ withPrimView o (uncurry f)+-- >>> withIxfold itraversed const 100 [1..5]+-- 10+-- >>> withIxfold itraversed const 100 []+-- 0+--+withIxfold :: Monoid r => AIxfold r i s a -> (i -> a -> r) -> i -> s -> r+withIxfold o f = curry $ withFold o (uncurry f) {-# INLINE withIxfold #-} +-- | Map an optic to a semigroup and combine the results.+--+-- @+-- 'withFold1' :: 'Semigroup' r => 'AFold1' r s a -> (a -> r) -> s -> r+-- @+--+withFold1 :: Semigroup r => APrimView r s t a b -> (a -> r) -> s -> r+withFold1 = withPrimView+{-# INLINE withFold1 #-}++-- | 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+--+-- @+-- 'withIxfold1' :: 'Semigroup' r => 'AIxfold1' r s a -> (i -> a -> r) -> i -> s -> r+-- @+--+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 --------------------------------------------------------------------- +-- | Collect the foci of an optic into a list.+--+lists :: AFold (Endo [a]) s a -> s -> [a]+lists o = foldsr o (:) []+{-# INLINE lists #-}+ infixl 8 ^.. --- | Infix version of 'lists'.+-- | Infix alias of 'lists'. -- -- @ -- 'Data.Foldable.toList' xs ≡ xs '^..' 'folding'@@ -335,14 +490,42 @@ (^..) = flip lists {-# INLINE (^..) #-} -infixl 8 ^??+-- | 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 #-} --- | Return a semigroup aggregation of the foci, if they exist.+-- | Collect the foci of an indexed optic into a list of index-value pairs. ---(^??) :: Semigroup a => s -> AFold (Maybe a) s a -> Maybe a-s ^?? o = withFold o Just s-{-# INLINE (^??) #-}+-- @+-- 'lists' l ≡ 'map' 'snd' '.' 'ilists' l+-- @+--+ilists :: 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'.+--+(^%%) :: 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")+-- ('h' :| "ello") :| ['w' :| "orld"]+--+nelists :: AFold1 (Nedl a) s a -> s -> NonEmpty a+nelists l = flip getNedl [] . withFold1 l (Nedl #. (:|))+{-# INLINE nelists #-}+ -- | TODO: Document -- folds :: Monoid a => AFold a s a -> s -> a@@ -350,6 +533,18 @@ {-# INLINE folds #-}  -- | TODO: Document+--+ifolds :: Monoid i => Monoid a => AIxfold (i, a) i s a -> s -> (i, a)+ifolds o = withIxfold o (,) mempty+{-# INLINE ifolds #-}++-- | TODO: Document+--+folds1 :: Semigroup a => AFold1 a s a -> s -> a+folds1 = flip withFold1 id+{-# INLINE folds1 #-}++-- | TODO: Document --  -- @ -- foldsa :: Fold s a -> s -> [a]@@ -373,6 +568,12 @@ foldsp o p = getProd . withFold o (Prod . p) {-# INLINE foldsp #-} +-- | Compute the semiring product of the foci of an optic.+--+folds1p :: Semiring r => AFold (Prod r) s a -> (a -> r) -> s -> r+folds1p o p = getProd . withFold1 o (Prod . p)+{-# INLINE folds1p #-}+ -- | Right fold over an optic. -- -- >>> foldsr folded (<>) 0 [1..5::Int]@@ -382,268 +583,137 @@ foldsr o f r = (`appEndo` r) . withFold o (Endo . f) {-# INLINE foldsr #-} --- | Left fold over an optic.----foldsl :: AFold (Dual (Endo r)) s a -> (r -> a -> r) -> r -> s -> r-foldsl o f r = (`appEndo` r) . getDual . withFold o (Dual . Endo . flip f)-{-# INLINE foldsl #-}---- | Fold repn the elements of a structure, associating to the left, but strictly.+-- | Indexed right fold over an indexed optic. -- -- @--- 'Data.Foldable.foldl'' ≡ 'foldsl'' 'folding'+-- 'foldsr' o ≡ 'ifoldsr' o '.' 'const' -- @ ----- @--- 'foldsl'' :: 'Iso'' s a        -> (c -> a -> c) -> c -> s -> c--- 'foldsl'' :: 'Lens'' s a       -> (c -> a -> c) -> c -> s -> c--- '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'' :: 'Traversal0'' s a -> (c -> a -> c) -> c -> s -> c--- @+-- >>> ifoldsr itraversed (\i a -> ((show i ++ ":" ++ show a ++ ", ") ++)) [] [1,3,5,7,9]+-- "0:1, 1:3, 2:5, 3:7, 4:9, " ---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' #-}+ifoldsr :: Monoid i => AIxfold (Endo r) i s a -> (i -> a -> r -> r) -> r -> s -> r+ifoldsr o f = ifoldsrFrom o f mempty+{-# INLINE ifoldsr #-} --- | Collect an applicative over the foci of an optic.------ >>> traverses_ both putStrLn ("hello","world")--- hello--- world+-- | Indexed right fold over an indexed optic, using an initial index value. ----- @--- 'Data.Foldable.traverse_' ≡ 'traverses_' 'folded'--- @+-- This is only for use with the few indexed optics that don't ignore their +-- output index. You most likely want to use 'ifoldsr'. ---traverses_ :: Applicative f => AFold (Endo (f ())) s a -> (a -> f r) -> s -> f ()-traverses_ p f = foldsr p (\a fu -> void (f a) *> fu) (pure ())-{-# INLINE traverses_ #-}+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 #-} --- | Collect the foci of an optic into a list.+-- | Left fold over an optic. ---lists :: AFold (Endo [a]) s a -> s -> [a]-lists o = foldsr o (:) []-{-# INLINE lists #-}+foldsl :: AFold (Dual (Endo r)) s a -> (r -> a -> r) -> r -> s -> r+foldsl o f r = (`appEndo` r) . getDual . withFold o (Dual . Endo . flip f)+{-# INLINE foldsl #-} --- | Map a function over all 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'--- @+-- | Left fold over an indexed optic. ---concats :: AFold [r] s a -> (a -> [r]) -> s -> [r]-concats = withFold-{-# INLINE concats #-}+ifoldsl :: Monoid i => AIxfold (Dual (Endo r)) i s a -> (i -> r -> a -> r) -> r -> s -> r+ifoldsl o f = ifoldslFrom o f mempty+{-# INLINE ifoldsl #-} --- | 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'--- @+-- | Left fold over an indexed optic, using an initial index value. ---finds :: AFold (Endo (Maybe a)) s a -> (a -> Bool) -> s -> Maybe a-finds o f = foldsr o (\a y -> if f a then Just a else y) Nothing-{-# INLINE finds #-}---- | Determine whether an optic has at least one focus.+-- This is only for use with the few indexed optics that don't ignore their +-- output index. You most likely want to use 'ifoldsl'. ---has :: AFold Any s a -> s -> Bool-has o = withFold o (const True)-{-# INLINE has #-}+ifoldslFrom :: AIxfold (Dual (Endo 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 #-} --- | Determine whether an optic does not have a focus.+-- | Strict right fold over an optic. ---hasnt :: AFold All s a -> s -> Bool-hasnt o = foldsp o (const False)-{-# INLINE hasnt #-}+foldsr' :: AFold (Dual (Endo (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' #-} --- | TODO: Document+-- | Strict right fold over an indexed optic. ---nulls :: AFold All s a -> s -> Bool-nulls o = foldsp o (const False)-{-# INLINE nulls #-}+ifoldsr' :: Monoid i => AIxfold (Dual (Endo (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' #-} --- | The sum of a collection of actions, generalizing 'concatOf'.------ >>> asums both ("hello","world")--- "helloworld"------ >>> asums both (Nothing, Just "hello")--- Just "hello"+-- | Strict left fold over an optic. -- -- @--- 'asum' ≡ 'asums' 'folded'+-- 'Data.Foldable.foldl'' ≡ 'foldsl'' 'folding' -- @ ---asums :: Alternative f => AFold (Endo (Endo (f a))) s (f a) -> s -> f a-asums o = foldsl' o (<|>) empty-{-# INLINE asums #-}---- | 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 => Min 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 => Max a => AFold (Endo (Endo a)) s a -> s -> a-meets' o = meets o maximal-{-# INLINE meets' #-}---- | Determine whether the foci of an optic contain an element equivalent to a given element.----pelem :: Prd a => AFold Any s a -> a -> s -> Bool-pelem o a = withFold o (Prd.=~ a)-{-# INLINE pelem #-}----------------------------------------------------------------------------------- Indexed operators---------------------------------------------------------------------------------infixl 8 ^%%---- | Infix version of 'ixlists'.----(^%%) :: Monoid i => s -> AIxfold (Endo [(i, a)]) i s a -> [(i, a)]-(^%%) = flip ixlists-{-# INLINE (^%%) #-}---- | Indexed right fold over an indexed optic.--- -- @--- 'foldsr' o ≡ 'ixfoldsr' o '.' 'const'--- @------ >>> ixfoldsr ixtraversed (\i a -> ((show i ++ ":" ++ show a ++ ", ") ++)) [] [1,3,5,7,9]--- "0:1, 1:3, 2:5, 3:7, 4:9, "----ixfoldsr :: Monoid i => AIxfold (Endo r) i s a -> (i -> a -> r -> r) -> r -> s -> r-ixfoldsr o f = ixfoldsrFrom o f mempty-{-# INLINE ixfoldsr #-}---- | Indexed right fold over an indexed optic, using an initial index value.----ixfoldsrFrom :: AIxfold (Endo r) i s a -> (i -> a -> r -> r) -> i -> r -> s -> r-ixfoldsrFrom o f i r = (`appEndo` r) . withIxfold o (\i -> Endo . f i) i-{-# INLINE ixfoldsrFrom #-}---- | Indexed left fold over an indexed optic.------ @--- 'foldsl' ≡ 'ixfoldsl' '.' 'const'+-- 'foldsl'' :: 'Iso'' s a        -> (c -> a -> c) -> c -> s -> c+-- 'foldsl'' :: 'Lens'' s a       -> (c -> a -> c) -> c -> s -> c+-- '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 -- @ ---ixfoldsl :: Monoid i => AIxfold (Dual (Endo r)) i s a -> (i -> r -> a -> r) -> r -> s -> r-ixfoldsl o f = ixfoldslFrom o f mempty -{-# INLINE ixfoldsl #-}---- | Indexed left fold over an indexed optic, using an initial index value.----ixfoldslFrom :: AIxfold (Dual (Endo r)) i s a -> (i -> r -> a -> r) -> i -> r -> s -> r-ixfoldslFrom o f i r = (`appEndo` r) . getDual . withIxfold o (\i -> Dual . Endo . flip (f i)) i-{-# INLINE ixfoldslFrom #-}+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' #-} --- | Indexed monadic right fold over an indexed optic.------ @--- 'foldsrM' ≡ 'ixfoldrM' '.' 'const'--- @+-- | Strict left fold over an indexed optic. ---ixfoldsrM :: Monoid i => Monad m => AIxfold (Dual (Endo (r -> m r))) i s a -> (i -> a -> r -> m r) -> r -> s -> m r-ixfoldsrM o f z0 xs = ixfoldsl o f' return xs z0-  where f' i k x z = f i x z >>= k-{-# INLINE ixfoldsrM #-}+ifoldsl' :: 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' #-} --- | Indexed monadic right fold over an 'Ixfold', using an initial index value.+-- | Monadic right fold over an optic. ---ixfoldsrMFrom :: Monad m => AIxfold (Dual (Endo (r -> m r))) i s a -> (i -> a -> r -> m r) -> i -> r -> s -> m r-ixfoldsrMFrom o f i z0 xs = ixfoldslFrom o f' i return xs z0-  where f' i k x z = f i x z >>= k-{-# INLINE ixfoldsrMFrom #-}+foldsrM :: Monad m => AFold (Dual (Endo (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 #-} --- | Indexed monadic left fold over an indexed optic.+-- | Monadic right fold over an indexed optic. -- -- @--- 'foldslM' ≡ 'ixfoldslM' '.' 'const'+-- 'foldsrM' ≡ 'ifoldrM' '.' 'const' -- @ ---ixfoldslM :: Monoid i => Monad m => AIxfold (Endo (r -> m r)) i s a -> (i -> r -> a -> m r) -> r -> s -> m r-ixfoldslM o f z0 xs = ixfoldsr o f' return xs z0-  where f' i x k z = f i z x >>= k-{-# INLINE ixfoldslM #-}+ifoldsrM :: Monoid i => Monad m => AIxfold (Dual (Endo (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 #-} --- | Indexed monadic left fold over an indexed optic, using an initial index value.+-- | Monadic left fold over an optic. ---ixfoldslMFrom :: Monad m => AIxfold (Endo (r -> m r)) i s a -> (i -> r -> a -> m r) -> i -> r -> s -> m r-ixfoldslMFrom o f i z0 xs = ixfoldsrFrom o f' i return xs z0-  where f' i x k z = f i z x >>= k-{-# INLINE ixfoldslMFrom #-}+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 #-} --- | Extract the key-value pairs from the foci of an indexed optic.+-- | Monadic left fold over an indexed optic. -- -- @--- 'lists' l ≡ 'map' 'snd' '.' 'ixlists' l+-- 'foldslM' ≡ 'ifoldslM' '.' 'const' -- @ ---ixlists :: Monoid i => AIxfold (Endo [(i, a)]) i s a -> s -> [(i, a)]-ixlists o = ixfoldsr o (\i a -> ((i,a):)) []-{-# INLINE ixlists #-}---- | Extract key-value pairs from the foci of an indexed optic, using an initial index value.----ixlistsFrom :: AIxfold (Endo [(i, a)]) i s a -> i -> s -> [(i, a)]-ixlistsFrom o i = ixfoldsrFrom o (\i a -> ((i,a):)) i []-{-# INLINE ixlistsFrom #-}+ifoldslM :: 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 #-} --- | Collect an applicative over the foci of an indexed optic.+-- | Applicative fold over an optic. ---ixtraverses_ :: Monoid i => Applicative f => AIxfold (Endo (f ())) i s a -> (i -> a -> f r) -> s -> f ()-ixtraverses_ p f = ixfoldsr p (\i a fu -> void (f i a) *> fu) (pure ())-{-# INLINE ixtraverses_ #-}---- | Concatenate the results of a function of the foci of an indexed optic.+-- >>> traverses_ both putStrLn ("hello","world")+-- hello+-- world -- -- @--- 'concats' o ≡ 'ixconcats' o '.' 'const'+-- 'Data.Foldable.traverse_' ≡ 'traverses_' 'folded' -- @ ----- >>> ixconcats ixtraversed (\i x -> [i + x, i + x + 1]) [1,2,3,4]--- [1,2,3,4,5,6,7,8]----ixconcats :: Monoid i => AIxfold [r] i s a -> (i -> a -> [r]) -> s -> [r]-ixconcats o f = withIxfold o f mempty-{-# INLINE ixconcats #-}+traverses_ :: Applicative f => AFold (Endo (f ())) s a -> (a -> f r) -> s -> f ()+traverses_ p f = foldsr p (\a fu -> void (f a) *> fu) (pure ())+{-# INLINE traverses_ #-} --- | Find the first focus of an indexed optic that satisfies a predicate, if one exists.+-- | Applicative fold over an indexed optic. ---ixfinds :: Monoid i => AIxfold (Endo (Maybe (i, a))) i s a -> (i -> a -> Bool) -> s -> Maybe (i, a)-ixfinds o f = ixfoldsr o (\i a y -> if f i a then Just (i,a) else y) Nothing-{-# INLINE ixfinds #-}+itraverses_ :: 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_ #-}  ------------------------------------------------------------------------------ -- Auxilliary Types@@ -653,12 +723,8 @@  type Any = Bool ------------------------------------------------------------------------- Carriers----------------------------------------------------------------------+-- A non-empty difference list.+newtype Nedl a = Nedl { getNedl :: [a] -> NEL.NonEmpty a } --- | TODO: Document----afold :: ((a -> r) -> s -> r) -> AFold r s a-afold o = Star #. (Const #.) #. o .# (getConst #.) .# runStar-{-# INLINE afold #-}+instance Semigroup (Nedl a) where+  Nedl f <> Nedl g = Nedl (f . NEL.toList . g)

@@ -1,341 +0,0 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TupleSections         #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE TypeFamilies          #-}-module Data.Profunctor.Optic.Fold0 (-    -- * Fold0 & Ixfold0-    Fold0-  , fold0-  , ixfold0-  , failing-  , toFold0-  , fromFold0 -    -- * Optics-  , folded0-    -- * Primitive operators-  , withFold0-  , withIxfold0-    -- * Operators-  , (^?)-  , preview -  , preuse-    -- * Indexed operators-  , ixpreview-  , ixpreviews-    -- * MonadUnliftIO -  , tries-  , tries_ -  , catches-  , catches_-  , handles-  , handles_-    -- * Carriers-  , Fold0Rep(..)-  , AFold0-  , AIxfold0-  , Pre(..)-    -- * Classes-  , Strong(..)-  , Choice(..)-) where--import Control.Applicative-import Control.Exception (Exception)-import Control.Monad ((<=<), void)-import Control.Monad.IO.Unlift-import Control.Monad.Reader as Reader hiding (lift)-import Control.Monad.State as State hiding (lift)-import Data.Foldable (Foldable, foldMap, traverse_)-import Data.Maybe-import Data.Monoid hiding (All(..), Any(..))-import Data.Prd (Prd(..), Min(..), Max(..))-import Data.Prd.Lattice (Lattice(..))-import Data.Profunctor.Optic.Import-import Data.Profunctor.Optic.Prism (right, just, async)-import Data.Profunctor.Optic.Traversal0 (ixtraversal0Vl, is)-import Data.Profunctor.Optic.Type-import Data.Profunctor.Optic.View (AView, to, from, withPrimView, view, cloneView)-import Data.Semiring (Semiring(..), Prod(..))-import qualified Control.Exception as Ex-import qualified Data.List.NonEmpty as NEL-import qualified Data.Prd as Prd-import qualified Data.Semiring as Rng---- $setup--- >>> :set -XNoOverloadedStrings--- >>> :set -XTypeApplications--- >>> :set -XFlexibleContexts--- >>> import Control.Exception hiding (catches)--- >>> import Data.Functor.Identity--- >>> import Data.List.Index--- >>> import Data.List.NonEmpty (NonEmpty(..))--- >>> import Data.Map as Map--- >>> import Data.Maybe--- >>> import Data.Monoid--- >>> import Data.Semiring hiding (unital,nonunital,presemiring)--- >>> import Data.Sequence as Seq--- >>> import qualified Data.List.NonEmpty as NE--- >>> :load Data.Profunctor.Optic--- >>> let ixtraversed :: Ixtraversal Int [a] [b] a b ; ixtraversed = ixtraversalVl itraverse-------------------------------------------------------------------------- 'Fold0' & 'Ixfold0'------------------------------------------------------------------------type AFold0 r s a = Optic' (Fold0Rep r) s a--type AIxfold0 r i s a = IndexedOptic' (Fold0Rep r) i s a---- | Obtain a 'Fold0' directly.------ @--- 'fold0' . '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 #-}---- | Create an 'Ixfold0' from a partial function.-ixfold0 :: (s -> Maybe (i, a)) -> Ixfold0 i s a-ixfold0 g = ixtraversal0Vl (\point f s -> maybe (point s) (uncurry f) $ g s) . coercer-{-# INLINE ixfold0 #-}--infixl 3 `failing` -- Same as (<|>)---- | Try the first 'Fold0'. If it returns no entry, try the second one.----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 partial 'View' from a 'Fold0' ----fromFold0 ::  AFold0 a s a -> View s (Maybe a)-fromFold0 = to . preview-{-# INLINE fromFold0 #-}-------------------------------------------------------------------------- Optics -------------------------------------------------------------------------- | Obtain a 'Fold0' from a partial function.------ >>> [Just 1, Nothing] ^.. folded . folded0--- [1]----folded0 :: Fold0 (Maybe a) a-folded0 = fold0 id-{-# INLINE folded0 #-}-------------------------------------------------------------------------- Primitive operators-------------------------------------------------------------------------- | TODO: Document----withFold0 :: Optic (Fold0Rep r) s t a b -> (a -> Maybe r) -> s -> Maybe r-withFold0 o = runFold0Rep #. o .# Fold0Rep-{-# INLINE withFold0 #-}---- | TODO: Document----withIxfold0 :: AIxfold0 r i s a -> (i -> a -> Maybe r) -> i -> s -> Maybe r-withIxfold0 o f = curry $ withFold0 o (uncurry f)-{-# INLINE withIxfold0 #-}-------------------------------------------------------------------------- Operators------------------------------------------------------------------------infixl 8 ^?---- | An infix variant of '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 -> AFold0 a s a -> Maybe a-(^?) = flip preview-{-# INLINE (^?) #-}---- | TODO: Document----preview :: MonadReader s m => AFold0 a s a -> m (Maybe a)-preview o = Reader.asks $ withFold0 o Just-{-# INLINE preview #-}---- | TODO: Document----preuse :: MonadState s m => AFold0 a s a -> m (Maybe a)-preuse o = State.gets $ preview o-{-# INLINE preuse #-}----------------------------------------------------------------------------------- Indexed operators----------------------------------------------------------------------------------- | TODO: Document ----ixpreview :: Monoid i => AIxfold0 (i , a) i s a -> s -> Maybe (i , a)-ixpreview o = ixpreviews o (,)-{-# INLINE ixpreview #-}---- | TODO: Document ----ixpreviews :: Monoid i => AIxfold0 r i s a -> (i -> a -> r) -> s -> Maybe r-ixpreviews o f = withIxfold0 o (\i -> Just . f i) mempty-{-# INLINE ixpreviews #-}----------------------------------------------------------------------------------- 'MonadUnliftIO'----------------------------------------------------------------------------------- | Test for synchronous exceptions that match a given optic.------ In the style of 'safe-exceptions' this function rethrows async exceptions --- synchronously in order to preserve async behavior,--- --- @--- 'tries' :: 'MonadUnliftIO' m => 'AFold0' e 'Ex.SomeException' e -> m a -> m ('Either' e a)--- 'tries' 'exception' :: 'MonadUnliftIO' m => 'Exception' e => m a -> m ('Either' e a)--- @----tries :: MonadUnliftIO m => Exception ex => AFold0 e ex e -> m a -> m (Either e a)-tries o a = withRunInIO $ \run -> run (Right `liftM` a) `Ex.catch` \e ->-  if is async e then throwM e else run $ maybe (throwM e) (return . Left) (preview o e)-{-# INLINE tries #-}---- | A variant of 'tries' that returns synchronous exceptions.----tries_ :: MonadUnliftIO m => Exception ex => AFold0 e ex e -> m a -> m (Maybe a)-tries_ o a = preview right `liftM` tries o a-{-# INLINE tries_ #-}---- | Catch synchronous exceptions that match a given optic.------ Rethrows async exceptions synchronously in order to preserve async behavior.------ @--- 'catches' :: 'MonadUnliftIO' m => 'AFold0' e 'Ex.SomeException' e -> m a -> (e -> m a) -> m a--- 'catches' 'exception' :: 'MonadUnliftIO' m => Exception e => m a -> (e -> m a) -> m a--- @------ >>> catches (only Overflow) (throwIO Overflow) (\_ -> return "caught")--- "caught"----catches :: MonadUnliftIO m => Exception ex => AFold0 e ex e -> m a -> (e -> m a) -> m a-catches o a ea = withRunInIO $ \run -> run a `Ex.catch` \e ->-  if is async e then throwM e else run $ maybe (throwM e) ea (preview o e)-{-# INLINE catches #-}---- | Catch synchronous exceptions that match a given optic, discarding the match.------ >>> catches_ (only Overflow) (throwIO Overflow) (return "caught")--- "caught"----catches_ :: MonadUnliftIO m => Exception ex => AFold0 e ex e -> m a -> m a -> m a-catches_ o x y = catches o x $ const y-{-# INLINE catches_ #-}---- | Flipped variant of 'catches'.------ >>> handles (only Overflow) (\_ -> return "caught") $ throwIO Overflow--- "caught"----handles :: MonadUnliftIO m => Exception ex => AFold0 e ex e -> (e -> m a) -> m a -> m a-handles o = flip $ catches o-{-# INLINE handles #-}---- | Flipped variant of 'catches_'.------ >>> handles_ (only Overflow) (return "caught") $ throwIO Overflow--- "caught"----handles_ :: MonadUnliftIO m => Exception ex => AFold0 e ex e -> m a -> m a -> m a-handles_ o = flip $ catches_ o-{-# INLINE handles_ #-}--throwM :: MonadIO m => Exception e => e -> m a-throwM = liftIO . Ex.throwIO-{-# INLINE throwM #-}-------------------------------------------------------------------------- 'Fold0Rep'------------------------------------------------------------------------newtype Fold0Rep r a b = Fold0Rep { runFold0Rep :: a -> Maybe r }--instance Functor (Fold0Rep r a) where-  fmap _ (Fold0Rep p) = Fold0Rep p--instance Contravariant (Fold0Rep r a) where-  contramap _ (Fold0Rep p) = Fold0Rep p--instance Profunctor (Fold0Rep r) where-  dimap f _ (Fold0Rep p) = Fold0Rep (p . f)--instance Choice (Fold0Rep r) where-  left' (Fold0Rep p) = Fold0Rep (either p (const Nothing))-  right' (Fold0Rep p) = Fold0Rep (either (const Nothing) p)--instance Cochoice (Fold0Rep r) where-  unleft  (Fold0Rep k) = Fold0Rep (k . Left)-  unright (Fold0Rep k) = Fold0Rep (k . Right)--instance Strong (Fold0Rep r) where-  first' (Fold0Rep p) = Fold0Rep (p . fst)-  second' (Fold0Rep p) = Fold0Rep (p . snd)--instance Sieve (Fold0Rep r) (Pre r) where-  sieve = (Pre .) . runFold0Rep--instance Representable (Fold0Rep r) where-  type Rep (Fold0Rep r) = Pre r-  tabulate = Fold0Rep . (getPre .)-  {-# INLINE tabulate #-}---- | 'Pre' is 'Maybe' with a phantom type variable.----newtype Pre a b = Pre { getPre :: Maybe a } deriving (Eq, Ord, Show)--instance Functor (Pre a) where fmap _ (Pre p) = Pre p--instance Contravariant (Pre a) where contramap _ (Pre p) = Pre p

@@ -1,335 +0,0 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TupleSections         #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE TypeFamilies          #-}-module Data.Profunctor.Optic.Fold1 (-    -- * Fold1 & Ixfold1-    Fold1-  , fold1_-  , folding1-  , fold1Vl-  , toFold1-  , cloneFold1-    -- * Cofold1 & Cxfold-  , Cofold1-  , cofold1Vl -  , cofolding1-    -- * Optics-  , folded1 -  , cofolded1 -  , folded1_-  , nonunital-  , presemiring-  , summed1-  , multiplied1-    -- * Primitive operators-  , withFold1 -  , withCofold1-    -- * Operators-  , folds1-  , cofolds1-  , folds1p-  , nelists-    -- * Carriers-  , FoldRep-  , AFold1-  , Cofold1Rep-  , ACofold1-  , afold1-  , acofold1-  , Star(..)-  , Costar(..)-    -- * Classes-  , Representable(..)-  , Corepresentable(..)-  , Contravariant(..)-  , Bifunctor(..)-    -- * Auxilliary Types-  , Nedl(..)-) where--import Control.Applicative-import Control.Monad ((<=<), void)-import Control.Monad.Reader as Reader hiding (lift)-import Control.Monad.State as State hiding (lift)-import Data.Foldable (Foldable, foldMap, traverse_)-import Data.List.NonEmpty (NonEmpty(..))-import Data.Maybe-import Data.Monoid hiding (All(..), Any(..))-import Data.Prd (Prd(..), Min(..), Max(..))-import Data.Prd.Lattice (Lattice(..))-import Data.Profunctor.Optic.Import-import Data.Profunctor.Optic.Fold-import Data.Profunctor.Optic.Prism (right, just, async)-import Data.Profunctor.Optic.Traversal1-import Data.Profunctor.Optic.Type-import Data.Profunctor.Optic.View (AView, to, from, withPrimView, view, cloneView)-import Data.Semiring (Semiring(..), Prod(..))-import qualified Control.Exception as Ex-import qualified Data.List.NonEmpty as NEL-import qualified Data.Prd as Prd-import qualified Data.Semiring as Rng---- $setup--- >>> :set -XNoOverloadedStrings--- >>> :set -XTypeApplications--- >>> :set -XFlexibleContexts--- >>> import Control.Exception hiding (catches)--- >>> import Data.Functor.Identity--- >>> import Data.List.Index--- >>> import Data.List.NonEmpty (NonEmpty(..))--- >>> import Data.Map as Map--- >>> import Data.Maybe--- >>> import Data.Monoid--- >>> import Data.Semiring hiding (unital,nonunital,presemiring)--- >>> import Data.Sequence as Seq--- >>> import qualified Data.List.NonEmpty as NE--- >>> :load Data.Profunctor.Optic--- >>> let ixtraversed :: Ixtraversal Int [a] [b] a b ; ixtraversed = ixtraversalVl itraverse-------------------------------------------------------------------------- 'Fold1' & 'Ixfold1'------------------------------------------------------------------------type AFold1 r s a = Optic' (FoldRep r) s a---- | Obtain a 'Fold1' directly.------ @ --- 'fold1_' ('nelists' o) ≡ o--- 'fold1_' f ≡ 'to' f . 'fold1Vl' 'traverse1_'--- 'fold1_' f ≡ 'coercer' . 'lmap' f . 'lift' 'traverse1_'--- @------ See 'Data.Profunctor.Optic.Property'.------ This can be useful to repn operations from @Data.List.NonEmpty@ and elsewhere into a 'Fold1'.----fold1_ :: Foldable1 f => (s -> f a) -> Fold1 s a-fold1_ f = to f . fold1Vl traverse1_-{-# INLINE fold1_ #-}---- | Obtain a 'Fold1' from a 'Traversable1' functor.------ @--- 'folding1' f ≡ 'traversed1' . 'to' f--- 'folding1' f ≡ 'fold1Vl' 'traverse1' . 'to' f--- @----folding1 :: Traversable1 f => (s -> a) -> Fold1 (f s) a-folding1 f = fold1Vl traverse1 . to f-{-# INLINE folding1 #-}---- | Obtain a 'Fold1' from a Van Laarhoven 'Fold1'.------ See 'Data.Profunctor.Optic.Property'.----fold1Vl :: (forall f. Apply f => (a -> f b) -> s -> f t) -> Fold1 s a-fold1Vl f = coercer . repn f . coercer-{-# INLINE fold1Vl #-}---- | Obtain a 'Fold1' from a 'View' or 'AFold1'.----toFold1 :: AView s a -> Fold1 s a-toFold1 = to . view-{-# INLINE toFold1 #-}---- | TODO: Document----afold1 :: Semigroup r => ((a -> r) -> s -> r) -> AFold1 r s a-afold1 o = Star #. (Const #.) #. o .# (getConst #.) .# runStar-{-# INLINE afold1 #-}---- | Obtain a 'Fold1' from a 'AFold1'.----cloneFold1 :: Semigroup a => AFold1 a s a -> View s a-cloneFold1 = cloneView-{-# INLINE cloneFold1 #-}-------------------------------------------------------------------------- 'Cofold1' & 'Cxfold'------------------------------------------------------------------------type Cofold1Rep r = Costar (Const r)--type ACofold1 r t b = Optic' (Cofold1Rep r) t b---- | Obtain an 'Cofold1' from a 'Distributive' functor. ------ @--- 'cofolding1' f ≡ 'cotraversed1' . 'from' f--- 'cofolding1' f ≡ 'cofold1Vl' 'cotraverse' . 'from' f--- @----cofolding1 :: Distributive f => (b -> t) -> Cofold1 (f t) b-cofolding1 f = cofold1Vl cotraverse . from f-{-# INLINE cofolding1 #-}---- | Obtain a 'Cofold1' from a Van Laarhoven 'Cofold1'.----cofold1Vl :: (forall f. Apply f => (f a -> b) -> f s -> t) -> Cofold1 t b-cofold1Vl f = coercel . corepn f . coercel-{-# INLINE cofold1Vl #-}---- | TODO: Document----acofold1 :: ((r -> b) -> r -> t) -> ACofold1 r t b-acofold1 o = Costar #. (.# getConst) #. o .#  (.# Const) .# runCostar  -{-# INLINE acofold1 #-}-------------------------------------------------------------------------- Optics -------------------------------------------------------------------------- | Obtain a 'Fold1' from a 'Traversable1' functor.----folded1 :: Traversable1 f => Fold1 (f a) a-folded1 = folding1 id-{-# INLINE folded1 #-}---- | Obtain an 'Cofold1' from a 'Distributive' functor. ----cofolded1 :: Distributive f => Cofold1 (f b) b-cofolded1 = cofolding1 id-{-# INLINE cofolded1 #-}---- | The canonical 'Fold1'.------ @--- 'Data.Semigroup.Foldable.foldMap1' ≡ 'withFold1' 'folded1_''--- @----folded1_ :: Foldable1 f => Fold1 (f a) a-folded1_ = fold1_ id-{-# INLINE folded1_ #-}---- | Expression in a semiring expression with no multiplicative unit.------ @ --- 'nonunital' ≡ 'summed' . 'multiplied1'--- @------ >>> foldOf nonunital $ (fmap . fmap) Just [1 :| [2], 3 :| [4 :: Int]]--- Just 14----nonunital :: Foldable f => Foldable1 g => Monoid r => Semiring r => AFold r (f (g a)) a-nonunital = summed . multiplied1-{-# INLINE nonunital #-}---- | Expression in a semiring with no additive or multiplicative unit.------ @ --- 'presemiring' ≡ 'summed1' . 'multiplied1'--- @----presemiring :: Foldable1 f => Foldable1 g => Semiring r => AFold1 r (f (g a)) a-presemiring = summed1 . multiplied1-{-# INLINE presemiring #-}---- | Semigroup sum of a non-empty foldable collection.------ >>> 1 <> 2 <> 3 <> 4 :: Int--- 10--- >>> fold1Of summed1 $ 1 :| [2,3,4 :: Int]--- 10----summed1 :: Foldable1 f => Semigroup r => AFold1 r (f a) a-summed1 = afold1 foldMap1-{-# INLINE summed1 #-}---- | Semiring product of a non-empty foldable collection. ------ >>> fold1Of multiplied1 $ fmap Just (1 :| [2..(5 :: Int)])--- Just 120 ----multiplied1 :: Foldable1 f => Semiring r => AFold1 r (f a) a-multiplied1 = afold1 Rng.product1-{-# INLINE multiplied1 #-}-------------------------------------------------------------------------- Primitive operators-------------------------------------------------------------------------- | Map an optic to a semigroup and combine the results.----withFold1 :: Semigroup r => AFold1 r s a -> (a -> r) -> s -> r-withFold1 = withPrimView-{-# INLINE withFold1 #-}---- | TODO: Document------ >>> withCofold1 (from succ) (*2) 3--- 7------ Compare 'Data.Profunctor.Optic.View.withPrimReview'.----withCofold1 :: ACofold1 r t b -> (r -> b) -> r -> t-withCofold1 o = (.# Const) #. runCostar #. o .# Costar .# (.# getConst)-{-# INLINE withCofold1 #-}-------------------------------------------------------------------------- Operators-------------------------------------------------------------------------- | TODO: Document----folds1 :: Semigroup a => AFold1 a s a -> s -> a-folds1 = flip withFold1 id-{-# INLINE folds1 #-}---- | TODO: Document----cofolds1 :: ACofold1 b t b -> b -> t-cofolds1 = flip withCofold1 id-{-# INLINE cofolds1 #-}---- | Compute the semiring product of the foci of an optic.------ For semirings without a multiplicative unit this is equivalent to @const mempty@:------ >>> productOf folded Just [1..(5 :: Int)]--- Just 0------ In this situation you most likely want to use 'folds1p'.----folds1p :: Semiring r => AFold (Prod r) s a -> (a -> r) -> s -> r-folds1p o p = getProd . withFold1 o (Prod . p)-{-# INLINE folds1p #-}--{-->>> nelists bitraversed1 ('h' :| "ello", 'w' :| "orld")- "hello" :| ["world"]--}---- | Extract a 'NonEmpty' of the foci of an optic.--------- @--- 'nelists' :: 'View' s a        -> s -> NonEmpty a--- 'nelists' :: 'Fold1' s a       -> s -> NonEmpty a--- 'nelists' :: 'Lens'' s a       -> s -> NonEmpty a--- 'nelists' :: 'Iso'' s a        -> s -> NonEmpty a--- 'nelists' :: 'Traversal1'' s a -> s -> NonEmpty a--- 'nelists' :: 'Prism'' s a      -> s -> NonEmpty a--- @----nelists :: AFold1 (Nedl a) s a -> s -> NonEmpty a-nelists l = flip getNedl [] . withFold1 l (Nedl #. (:|))-{-# INLINE nelists #-}----------------------------------------------------------------------------------- Indexed operators------------------------------------------------------------------------------------------------------------------------------------------------------------------ Auxilliary Types----------------------------------------------------------------------------------- A non-empty difference list.-newtype Nedl a = Nedl { getNedl :: [a] -> NEL.NonEmpty a }--instance Semigroup (Nedl a) where-  Nedl f <> Nedl g = Nedl (f . NEL.toList . g)

@@ -6,43 +6,44 @@ {-# LANGUAGE TypeOperators         #-} {-# LANGUAGE TypeFamilies          #-} module Data.Profunctor.Optic.Grate  (-    -- * Types-    Closed(..)-  , Grate+    -- * Grate & Cxgrate+    Grate   , Grate'   , Cxgrate   , Cxgrate'-  , AGrate-  , AGrate'     -- * Constructors   , grate-  , cxgrate   , grateVl-  , cxgrateVl+  , kgrateVl   , inverting   , cloneGrate-    -- * Carriers-  , GrateRep(..)-    -- * Primitive operators-  , withGrate -  , constOf-  , zipWithOf-  , zipWith3Of-  , zipWith4Of -  , zipWithFOf      -- * Optics-  --, closed-  , cxclosed-  , cxfirst-  , cxsecond+  , represented   , distributed+  , endomorphed   , connected-  , forwarded   , continued+  , continuedT+  , calledCC   , unlifted+    -- * Indexed optics+  , kclosed+  , kfirst+  , ksecond+    -- * Primitive operators+  , withGrate +  , withGrateVl     -- * Operators-  , toEnvironment+  , coview+  , zipsWith+  , kzipsWith+  , zipsWith3+  , zipsWith4    , toClosure+  , toEnvironment+    -- * Classes+  , Closed(..)+  , Costrong(..) ) where  import Control.Monad.Reader@@ -50,13 +51,18 @@ import Control.Monad.IO.Unlift import Data.Distributive import Data.Connection (Conn(..))+import Data.Monoid (Endo(..)) import Data.Profunctor.Closed-import Data.Profunctor.Optic.Iso-import Data.Profunctor.Optic.Type+import Data.Profunctor.Optic.Carrier+import Data.Profunctor.Optic.Types import Data.Profunctor.Optic.Import import Data.Profunctor.Optic.Index-import Data.Profunctor.Rep (unfirstCorep)+import Data.Profunctor.Optic.Iso (tabulated) +import qualified Data.Functor.Rep as F++import qualified Data.Functor.Rep as F+ -- $setup -- >>> :set -XNoOverloadedStrings -- >>> :set -XTypeApplications@@ -65,6 +71,8 @@ -- >>> import Control.Exception -- >>> import Control.Monad.Reader -- >>> import Data.Connection.Int+-- >>> import Data.List as L+-- >>> import Data.Monoid (Endo(..)) -- >>> :load Data.Profunctor.Optic  ---------------------------------------------------------------------@@ -79,7 +87,7 @@ -- A 'Grate' lets you lift a profunctor through any representable  -- functor (aka Naperian container). In the special case where the  -- indexing type is finitary (e.g. 'Bool') then the tabulated type is --- isomorphic to a fixed length vector (e.g. 'V2 a').+-- isomorphic to a fied length vector (e.g. 'V2 a'). -- -- The identity container is representable, and representable functors  -- are closed under composition.@@ -94,7 +102,7 @@ -- -- * @sabt ($ s) ≡ s@ ----- * @sabt (\k -> h (k . sabt)) ≡ sabt (\k -> h ($ k))@+-- * @sabt (\k -> f (k . sabt)) ≡ sabt (\k -> f ($ k))@ -- -- More generally, a profunctor optic must be monoidal as a natural  -- transformation:@@ -108,22 +116,26 @@ grate :: (((s -> a) -> b) -> t) -> Grate s t a b grate sabt = dimap (flip ($)) sabt . closed --- | TODO: Document----cxgrate :: (((s -> a) -> k -> b) -> t) -> Cxgrate k s t a b-cxgrate f = grate $ \sakb _ -> f sakb- -- | Transform a Van Laarhoven grate into a profunctor grate. ----- Compare 'Data.Profunctor.Optic.Lens.vlens' & 'Data.Profunctor.Optic.Traversal.cotraversalVl'.+-- 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 ---cxgrateVl :: (forall f. Functor f => (k -> f a -> b) -> f s -> t) -> Cxgrate k s t a b-cxgrateVl f = grateVl $ \kab -> const . f (flip kab) +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. --@@ -136,159 +148,181 @@ cloneGrate k = withGrate k grate  ------------------------------------------------------------------------ 'GrateRep'-------------------------------------------------------------------------- | The 'GrateRep' profunctor precisely characterizes 'Grate'.----newtype GrateRep a b s t = GrateRep { unGrateRep :: ((s -> a) -> b) -> t }--type AGrate s t a b = Optic (GrateRep a b) s t a b--type AGrate' s a = AGrate s s a a--instance Profunctor (GrateRep a b) where-  dimap f g (GrateRep z) = GrateRep $ \d -> g (z $ \k -> d (k . f))--instance Closed (GrateRep a b) where-  closed (GrateRep sabt) = GrateRep $ \xsab x -> sabt $ \sa -> xsab $ \xs -> sa (xs x)--instance Costrong (GrateRep a b) where-  unfirst = unfirstCorep--instance Cosieve (GrateRep a b) (Coindex a b) where-  cosieve (GrateRep f) (Coindex g) = f g--instance Corepresentable (GrateRep a b) where-  type Corep (GrateRep a b) = Coindex a b--  cotabulate f = GrateRep $ f . Coindex-------------------------------------------------------------------------- Primitive operators+-- Optics  --------------------------------------------------------------------- --- | Extract the function that characterizes a 'Lens'.----withGrate :: AGrate s t a b -> ((((s -> a) -> b) -> t) -> r) -> r-withGrate o k = case o (GrateRep $ \f -> f id) of GrateRep sabt -> k sabt---- | Set all fields to the given value.----constOf :: AGrate s t a b -> b -> t-constOf o b = withGrate o $ \sabt -> sabt (const b)---- | Zip over a 'Grate'. ------ @\f -> 'zipWithOf' 'closed' ('zipWithOf' 'closed' f) ≡ 'zipWithOf' ('closed' . 'closed')@----zipWithOf :: AGrate s t a b -> (a -> a -> b) -> s -> s -> t-zipWithOf o comb s1 s2 = withGrate o $ \sabt -> sabt $ \get -> comb (get s1) (get s2)---- | Zip over a 'Grate' with 3 arguments.----zipWith3Of :: AGrate s t a b -> (a -> a -> a -> b) -> (s -> s -> s -> t)-zipWith3Of o comb s1 s2 s3 = withGrate o $ \sabt -> sabt $ \get -> comb (get s1) (get s2) (get s3)---- | Zip over a 'Grate' with 4 arguments.----zipWith4Of :: AGrate s t a b -> (a -> a -> a -> a -> b) -> (s -> s -> s -> s -> t)-zipWith4Of o comb s1 s2 s3 s4 = withGrate o $ \sabt -> sabt $ \get -> comb (get s1) (get s2) (get s3) (get s4)---- | Transform a profunctor grate into a Van Laarhoven grate.------ This is a more restricted version of 'Data.Profunctor.Optic.Repn.corepnOf'+-- | Obtain a 'Grate' from a 'F.Representable' functor. ---zipWithFOf :: Functor f => AGrate s t a b -> (f a -> b) -> f s -> t-zipWithFOf o comb fs = withGrate o $ \sabt -> sabt $ \get -> comb (fmap get fs)-------------------------------------------------------------------------- Optics ----------------------------------------------------------------------+represented :: F.Representable f => Grate (f a) (f b) a b+represented = tabulated . closed+{-# INLINE represented #-} --- | Access the contents of a distributive functor.+-- | Obtain a 'Grate' from a distributive functor. -- distributed :: Distributive f => Grate (f a) (f b) a b distributed = grate (`cotraverse` id) {-# INLINE distributed #-} --- | Lift a Galois connection into a 'Grate'. +-- | 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. ----- >>> zipWithOf (connected i08i16) (+) 126 1+-- >>> zipsWith (connected i08i16) (+) 126 1 -- 127--- >>> zipWithOf (connected i08i16) (+) 126 2+-- >>> zipsWith (connected i08i16) (+) 126 2 -- 127 -- connected :: Conn s a -> Grate' s a connected (Conn f g) = inverting f g {-# INLINE connected #-} --- | Lift an action into a 'MonadReader'.----forwarded :: Distributive m => MonadReader r m => Grate (m a) (m b) a b-forwarded = distributed-{-# INLINE forwarded #-}---- | Lift an action into a continuation.+-- | Obtain a 'Grate' from a continuation. -- -- @--- 'zipWithOf' 'continued' :: (r -> r -> r) -> s -> s -> Cont r s+-- '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' ≡ 'constOf' 'unlifted'+-- 'liftIO' ≡ 'coview' 'unlifted' -- @ -- -- >>> let catchA = catch @ArithException--- >>> zipWithOf unlifted (flip catchA . const) (throwIO Overflow) (print "caught") +-- >>> 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 #-} --- >>> cxover cxclosed (,) (*2) 5+---------------------------------------------------------------------+-- Indexed optics+---------------------------------------------------------------------++-- >>> kover kclosed (,) (*2) 5 -- ((),10) ---cxclosed :: Cxgrate k (c -> a) (c -> b) a b-cxclosed = rmap flip . closed-{-# INLINE cxclosed #-}+kclosed :: Cxgrate k (c -> a) (c -> b) a b+kclosed = rmap flip . closed+{-# INLINE kclosed #-}  -- | TODO: Document ---cxfirst :: Cxgrate k a b (a , c) (b , c)-cxfirst = rmap (unfirst . uncurry . flip) . curry'-{-# INLINE cxfirst #-}+kfirst :: Cxgrate k a b (a , c) (b , c)+kfirst = rmap (unfirst . uncurry . flip) . curry'+{-# INLINE kfirst #-}  -- | TODO: Document ---cxsecond :: Cxgrate k a b (c , a) (c , b)-cxsecond = rmap (unsecond . uncurry) . curry' . lmap swap-{-# INLINE cxsecond #-}+ksecond :: Cxgrate k a b (c , a) (c , b)+ksecond = rmap (unsecond . uncurry) . curry' . lmap swap+{-# INLINE ksecond #-}  ---------------------------------------------------------------------+-- 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 --------------------------------------------------------------------- --- | Use a 'Grate' to construct an 'Environment'.+-- | Set all fields to the given value. ---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 #-}+-- 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 :: 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 #-}

@@ -8,6 +8,7 @@   module Export ) where +import Control.Arrow as Export ((|||),(&&&),(+++),(***)) import Control.Applicative as Export (liftA2, Alternative(..)) import Control.Category as Export hiding ((.), id) import Control.Monad as Export hiding (void, join)@@ -22,9 +23,14 @@ import Data.Functor.Const as Export import Data.Functor.Contravariant as Export import Data.Functor.Identity as Export-import Data.Profunctor.Arrow 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(..))+import Data.Profunctor.Choice as Export (Choice(..), Cochoice(..))+import Data.Profunctor.Closed as Export (Closed(..))+import Data.Profunctor.Sieve as Export (Sieve(..), Cosieve(..))+import Data.Profunctor.Rep as Export (Representable(..), Corepresentable(..)) import Data.Tagged as Export import Data.Void as Export-import Prelude as Export hiding (Num(..), Foldable(..), all, any, min, max, head, tail, elem, notElem, userError)+import Prelude as Export hiding (Num(..), all, any, min, max, head, tail, elem, notElem, userError)

@@ -10,56 +10,70 @@ module Data.Profunctor.Optic.Index (      -- * Indexing     (%)-  , ixinit-  , ixlast+  , iinit+  , ilast   , reix-  , ixmap+  , imap   , withIxrepn     -- * Coindexing   , (#)-  , cxinit-  , cxlast+  , kinit+  , klast   , recx-  , cxmap+  , kmap   , cxed-  , cxjoin-  , cxreturn+  , kjoin+  , kreturn   , type Cx'-  , cxunit-  , cxpastro-  , cxfirst'+  , kunit+  , kpastro+  , kfirst'   , withCxrepn     -- * Index   , Index(..)-  , values+  , vals   , info     -- * Coindex   , Coindex(..)   , trivial   , noindex   , coindex-  , (##)+  , (.#.)+    -- * Coindex+  , Conjoin(..) ) where +import Control.Arrow as Arrow+import Control.Category (Category)+import Control.Comonad+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-import Data.Profunctor.Optic.Type+import Data.Profunctor.Optic.Types import Data.Profunctor.Strong import GHC.Generics (Generic) +import qualified Control.Category as C+ -- $setup -- >>> :set -XNoOverloadedStrings -- >>> :set -XTypeApplications -- >>> :set -XFlexibleContexts -- >>> :set -XTupleSections+-- >>> :set -XRankNTypes -- >>> import Data.Semigroup -- >>> import Data.Semiring -- >>> import Data.Int.Instance () -- >>> import Data.Map -- >>> :load Data.Profunctor.Optic--- >>> let ixtraversed :: Ord k => Ixtraversal k (Map k a) (Map k b) a b ; ixtraversed = ixtraversalVl traverseWithKey+-- >>> let itraversed :: Ord k => Ixtraversal k (Map k a) (Map k b) a b ; itraversed = itraversalVl traverseWithKey -- >>> let foobar = fromList [(0::Int, fromList [(0,"foo"), (1,"bar")]), (1, fromList [(0,"baz"), (1,"bip")])] -- >>> let exercises :: Map String (Map String Int); exercises = fromList [("Monday", fromList [("pushups", 10), ("crunches", 20)]), ("Wednesday", fromList [("pushups", 15), ("handstands", 3)]), ("Friday", fromList [("crunches", 25), ("handstands", 5)])]  @@ -73,19 +87,21 @@ -- -- 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 /./:+-- >>> ilists (itraversed . itraversed) exercises+-- [("crunches",25),("handstands",5),("crunches",20),("pushups",10),("handstands",3),("pushups",15)] ----- >>> ixlists (ixtraversed . ixtraversed) foobar--- [(0,"foo"),(1,"bar"),(0,"baz"),(1,"bip")]+-- >>> ilists (itraversed % itraversed) exercises +-- [("Fridaycrunches",25),("Fridayhandstands",5),("Mondaycrunches",20),("Mondaypushups",10),("Wednesdayhandstands",3),("Wednesdaypushups",15)] ----- >>> ixlistsFrom (ixlast ixtraversed % ixlast ixtraversed) (Last 0) foobar & fmapped . t21 ..~ getLast+-- If you only need the final index then use /./:+--+-- >>> ilists (itraversed . itraversed) foobar -- [(0,"foo"),(1,"bar"),(0,"baz"),(1,"bip")] ----- >>> ixlists (ixtraversed . ixtraversed) exercises--- [("crunches",25),("handstands",5),("crunches",20),("pushups",10),("handstands",3),("pushups",15)]+-- This is identical to the more convoluted: ----- >>> ixlists (ixtraversed % ixtraversed) exercises --- [("Fridaycrunches",25),("Fridayhandstands",5),("Mondaycrunches",20),("Mondaypushups",10),("Wednesdayhandstands",3),("Wednesdaypushups",15)]+-- >>> ilistsFrom (ilast itraversed % ilast itraversed) (Last 0) foobar & fmapped . first' ..~ getLast+-- [(0,"foo"),(1,"bar"),(0,"baz"),(1,"bip")] -- (%) :: 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) -> @@ -93,15 +109,15 @@             withIxrepn f ib b1 $ \ia a1 -> ia1a2 (ib <> ia, a1) {-# INLINE (%) #-} -ixinit :: Profunctor p => IndexedOptic p i s t a b -> IndexedOptic p (First i) s t a b-ixinit = reix First getFirst+iinit :: Profunctor p => IndexedOptic p i s t a b -> IndexedOptic p (First i) s t a b+iinit = reix First getFirst -ixlast :: Profunctor p => IndexedOptic p i s t a b -> IndexedOptic p (Last i) s t a b-ixlast = reix Last getLast+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. ----- >>> ixlists (ixtraversed . reix (<>10) id ixtraversed) foobar+-- >>> ilists (itraversed . reix (<>10) id itraversed) foobar -- [(10,"foo"),(11,"bar"),(10,"baz"),(11,"bip")] -- -- See also 'Data.Profunctor.Optic.Iso.reixed'.@@ -109,10 +125,10 @@ reix :: Profunctor p => (i -> j) -> (j -> i) -> IndexedOptic p i s t a b -> IndexedOptic p j s t a b reix ij ji = (. lmap (first' ij)) . (lmap (first' ji) .) --- >>> ixlists (ixtraversed . ixmap head pure) [[1,2,3],[4,5,6]]+-- >>> ilists (itraversed . imap head pure) [[1,2,3],[4,5,6]] -- [(0,1),(1,4)]-ixmap :: Profunctor p => (s -> a) -> (b -> t) -> IndexedOptic p i s t a b-ixmap sa bt = dimap (fmap sa) bt+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)@@ -127,7 +143,7 @@ -- -- 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 /./+-- If you only need the final index then use /./. -- (#) :: Semigroup k => Corepresentable p => CoindexedOptic p k b1 b2 a1 a2 -> CoindexedOptic p k c1 c2 b1 b2 -> CoindexedOptic p k c1 c2 a1 a2 f # g = corepn $ \a1ka2 c1 kc -> @@ -135,11 +151,11 @@             withCxrepn f b1 kb $ \a1 ka -> a1ka2 a1 (kb <> ka) {-# INLINE (#) #-} -cxinit :: Profunctor p => CoindexedOptic p k s t a b -> CoindexedOptic p (First k) s t a b-cxinit = recx First getFirst+kinit :: Profunctor p => CoindexedOptic p k s t a b -> CoindexedOptic p (First k) s t a b+kinit = recx First getFirst -cxlast :: Profunctor p => CoindexedOptic p k s t a b -> CoindexedOptic p (Last k) s t a b-cxlast = recx Last getLast+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. --@@ -148,8 +164,8 @@ recx :: Profunctor p => (k -> l) -> (l -> k) -> CoindexedOptic p k s t a b -> CoindexedOptic p l s t a b recx kl lk = (. rmap (. kl)) . (rmap (. lk) .) -cxmap :: Profunctor p => (s -> a) -> (b -> t) -> CoindexedOptic p k s t a b -cxmap sa bt = dimap sa (fmap bt)+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)@@ -157,26 +173,26 @@ type Cx' p a b = Cx p a a b  cxed :: Strong p => Iso (Cx p s s t) (Cx p k a b) (p s t) (p a b)-cxed = dimap cxjoin cxreturn+cxed = dimap kjoin kreturn -cxjoin :: Strong p => Cx p a a b -> p a b-cxjoin = peval+kjoin :: Strong p => Cx p a a b -> p a b+kjoin = peval -cxreturn :: Profunctor p => p a b -> Cx p k a b-cxreturn = rmap const+kreturn :: Profunctor p => p a b -> Cx p k a b+kreturn = rmap const -cxunit :: Strong p => Cx' p :-> p-cxunit p = dimap fork apply (first' p)+kunit :: Strong p => Cx' p :-> p+kunit p = dimap fork apply (first' p) -cxpastro :: Profunctor p => Iso (Cx' p a b) (Cx' p c d) (Pastro p a b) (Pastro p c d)-cxpastro = dimap (\p -> Pastro apply p fork) (\(Pastro l m r) -> dimap (fst . r) (\y a -> l (y, (snd (r a)))) m)+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>. ---cxfirst' :: Profunctor p => Cx' p a b -> Cx' p (a, c) (b, c)-cxfirst' = dimap fst (B.first @(,))+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@@ -187,28 +203,30 @@  -- | An indexed store that characterizes a 'Data.Profunctor.Optic.Lens.Lens' ----- @'Index' a b r ≡ forall f. 'Functor' f => (a -> f b) -> f r@,+-- @'Index' a b s ≡ forall f. 'Functor' f => (a -> f b) -> f s@, ---data Index a b r = Index a (b -> r)+-- See also 'Data.Profunctor.Optic.Lens.withLensVl'.+--+data Index a b s = Index a (b -> s) deriving Generic -values :: Index a b r -> b -> r-values (Index _ br) = br-{-# INLINE values #-}+vals :: Index a b s -> b -> s+vals (Index _ bs) = bs+{-# INLINE vals #-} -info :: Index a b r -> a+info :: Index a b s -> a info (Index a _) = a {-# INLINE info #-}  instance Functor (Index a b) where-  fmap f (Index a br) = Index a (f . br)+  fmap f (Index a bs) = Index a (f . bs)   {-# INLINE fmap #-}  instance Profunctor (Index a) where-  dimap f g (Index a br) = Index a (g . br . f)+  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 br) = f . br $ b+  foldMap f (Index b bs) = f . bs $ b  --------------------------------------------------------------------- -- Coindex@@ -216,9 +234,9 @@  -- | An indexed continuation that characterizes a 'Data.Profunctor.Optic.Grate.Grate' ----- @'Coindex' a b k ≡ forall f. 'Functor' f => (f a -> b) -> f k@,+-- @'Coindex' a b s ≡ forall f. 'Functor' f => (f a -> b) -> f s@, ----- See also 'Data.Profunctor.Optic.Grate.zipWithFOf'.+-- See also 'Data.Profunctor.Optic.Grate.withGrateVl'. -- -- 'Coindex' can also be used to compose indexed maps, folds, or traversals directly. --@@ -230,18 +248,16 @@ --  Coindex traverseWithKey :: Applicative t => Coindex (a -> t b) (Map k a -> t (Map k b)) k -- @ ---newtype Coindex a b k = Coindex { runCoindex :: (k -> a) -> b } deriving Generic+newtype Coindex a b s = Coindex { runCoindex :: (s -> a) -> b } deriving Generic --- | Change the @Monoid@ used to combine indices.--- instance Functor (Coindex a b) where-  fmap kl (Coindex abk) = Coindex $ \la -> abk (la . kl)+  fmap sl (Coindex abs) = Coindex $ \la -> abs (la . sl)  instance a ~ b => Apply (Coindex a b) where-  (Coindex klab) <.> (Coindex abk) = Coindex $ \la -> klab $ \kl -> abk (la . kl) +  (Coindex slab) <.> (Coindex abs) = Coindex $ \la -> slab $ \sl -> abs (la . sl)   instance a ~ b => Applicative (Coindex a b) where-  pure k = Coindex ($k)+  pure s = Coindex ($s)   (<*>) = (<.>)  trivial :: Coindex a b a -> b@@ -253,23 +269,23 @@ -- For example, to traverse two layers, keeping only the first index: -- -- @---  Coindex 'Data.Map.mapWithKey' ## noindex 'Data.Map.map'+--  Coindex 'Data.Map.mapWithKey' .#. noindex 'Data.Map.map' --    :: Monoid k => --       Coindex (a -> b) (Map k (Map j a) -> Map k (Map j b)) k -- @ ---noindex :: Monoid k => (a -> b) -> Coindex a b k+noindex :: Monoid s => (a -> b) -> Coindex a b s noindex f = Coindex $ \a -> f (a mempty) -coindex :: Functor f => k -> (a -> b) -> Coindex (f a) (f b) k-coindex k ab = Coindex $ \kfa -> fmap ab (kfa k)+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 ##+infixr 9 .#.  -- | Compose two coindexes. ----- When /k/ is a 'Monoid', 'Coindex' can be used to compose indexed traversals, folds, etc.+-- 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@: --@@ -283,5 +299,114 @@ --  fmap (:[]) :: Coindex a b c -> Coindex a b [c] -- @ ---(##) :: Semigroup k => Coindex b c k -> Coindex a b k -> Coindex a c k-Coindex f ## Coindex g = Coindex $ \b -> f $ \k1 -> g $ \k2 -> b (k1 <> k2)+(.#.) :: 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 #-}

@@ -10,14 +10,13 @@     -- * Types     Equality   , Equality'-  , As   , Iso   , Iso'     -- * Constructors   , iso   , isoVl-  , ixmapping-  , cxmapping+  , imapping+  , kmapping   , fmapping   , contramapping   , dimapping@@ -29,29 +28,28 @@   , coerced   , wrapped   , rewrapped-  , rewrapping+  , rewrapped'   , generic   , generic1+  , adjuncted+  , tabulated+  , transposed   , flipped    , curried+  , unzipped+  , cozipped   , swapped -  , eswapped +  , coswapped    , associated -  , eassociated +  , coassociated   , involuted    , added    , subtracted-  , viewedl-  , viewedr   , non    , anon-  , u1-  , par1-  , rec1-  , k1-  , m1     -- * Primitive operators   , withIso+    -- * Operators   , invert   , reover   , reixed@@ -62,24 +60,23 @@   , ala     -- * Auxilliary Types   , Re(..)-    -- * Carriers-  , AIso -  , AIso'-  , IsoRep(..) ) where  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.Type hiding (Rep)+import Data.Profunctor.Optic.Types import Data.Profunctor.Yoneda (Coyoneda(..), Yoneda(..))-import Data.Sequence as Seq-import GHC.Generics hiding (from, to)+++import qualified Data.Functor.Rep as F import qualified Control.Monad as M (join)-import qualified GHC.Generics as GHC (to, from, to1, from1)+import qualified GHC.Generics as G  -- $setup -- >>> :set -XNoOverloadedStrings@@ -92,8 +89,9 @@ -- >>> import Data.Sequence as Seq hiding (reverse) -- >>> import Data.Functor.Identity -- >>> import Data.Functor.Const+-- >>> import Data.Profunctor.Types -- >>> :load Data.Profunctor.Optic--- >>> let ixtraversed :: Ixtraversal Int [a] [b] a b ; ixtraversed = ixtraversalVl itraverse+-- >>> let itraversed :: Ixtraversal Int [a] [b] a b ; itraversed = itraversalVl itraverse  --------------------------------------------------------------------- -- 'Iso' @@ -101,6 +99,13 @@  -- | Obtain an 'Iso' from two inverses. --+-- @+-- o . 're' o ≡ 'id'+-- 're' o . o ≡ 'id'+-- 'Data.Profunctor.Optic.View.view' o ('Data.Profunctor.Optic.View.review' o b) ≡ b+-- 'Data.Profunctor.Optic.View.review' o ('Data.Profunctor.Optic.View.view' o s) ≡ s+-- @+-- -- /Caution/: In order for the generated optic to be well-defined, -- you must ensure that the input functions satisfy the following -- properties:@@ -132,30 +137,26 @@  -- | Lift an 'Iso' into an indexed version.  ----- >>> ixlists (ixtraversed . ixmapping swapped) [(40,'f'),(41,'o'),(42,'o')]+-- >>> ilists (itraversed . imapping swapped) [(40,'f'),(41,'o'),(42,'o')] -- [(0,('f',40)),(1,('o',41)),(2,('o',42))] ---ixmapping :: Profunctor p => AIso s t a b -> IndexedOptic p i s t a b-ixmapping o = withIso o ixmap-{-# INLINE ixmapping #-}+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.  ---cxmapping :: Profunctor p => AIso s t a b -> CoindexedOptic p k s t a b-cxmapping o = withIso o cxmap-{-# INLINE cxmapping #-}+kmapping :: Profunctor p => AIso s t a b -> CoindexedOptic p k s t a b+kmapping o = withIso o kmap+{-# INLINE kmapping #-} --- | TODO: Document+-- | 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)+fmapping :: Functor f => Functor g => AIso s t a b -> Iso (f s) (g t) (f a) (g b) fmapping l = withIso l $ \sa bt -> iso (fmap sa) (fmap bt) {-# INLINE fmapping #-} --- | Lift an 'Iso' into a 'Contravariant' functor.+-- | Lift an 'Iso' into a pair of 'Contravariant' functors. -- -- @ -- contramapping :: 'Contravariant' f => 'Iso' s t a b -> 'Iso' (f a) (f b) (f s) (f t)@@ -165,16 +166,12 @@ contramapping f = withIso f $ \sa bt -> iso (contramap sa) (contramap bt) {-# INLINE contramapping #-} --- | TODO: Document+-- | Lift a pair of 'Iso's into a pair of profunctors.  ---dimapping-  :: Profunctor p-  => Profunctor q-  => AIso s1 t1 a1 b1-  -> AIso s2 t2 a2 b2-  -> Iso (p a1 s2) (q b1 t2) (p s1 a2) (q t1 b2)-dimapping f g = withIso f $ \sa1 bt1 -> -  withIso g $ \sa2 bt2 -> iso (dimap sa1 sa2) (dimap bt1 bt2)+--+--+dimapping :: Profunctor p => Profunctor q => AIso s1 t1 a1 b1 -> AIso s2 t2 a2 b2 -> Iso (p a1 s2) (q b1 t2) (p s1 a2) (q t1 b2)+dimapping f g = withIso f $ \sa1 bt1 -> withIso g $ \sa2 bt2 -> iso (dimap sa1 sa2) (dimap bt1 bt2) {-# INLINE dimapping #-}  -- | Lift an 'Iso' into a 'Yoneda'.@@ -199,7 +196,7 @@ -- Optics --------------------------------------------------------------------- --- | Capture type constraints as an 'Iso''.+-- | Obtain an 'Iso'' directly from type equality constraints. -- -- >>> :t (^. equaled) -- (^. equaled) :: b -> b@@ -208,7 +205,7 @@ equaled = id {-# INLINE equaled #-} --- | Data types that are representationally equal.+-- | Obtain an 'Iso' from data types that are representationally equal. -- -- >>> view coerced 'x' :: Identity Char -- Identity 'x'@@ -217,11 +214,11 @@ coerced = dimap coerce coerce {-# INLINE coerced #-} --- | Work under a newtype wrapper.+-- | Obtain an 'Iso' from a newtype. -- -- @--- 'view wrapped' f '.' f ≡ 'id'--- f '.' 'view wrapped' f ≡ 'id'+-- 'Data.Profunctor.Optic.View.view' 'wrapped' f '.' f ≡ 'id'+-- f '.' 'Data.Profunctor.Optic.View.view' 'wrapped' f ≡ 'id' -- @ -- -- >>> view wrapped $ Identity 'x'@@ -245,25 +242,49 @@  -- | Variant of 'rewrapped' that ignores its argument. ---rewrapping :: Newtype s => Newtype t => (O s -> s) -> Iso s t (O s) (O t)-rewrapping _ = rewrapped-{-# INLINE rewrapping #-}+rewrapped' :: Newtype s => Newtype t => (O s -> s) -> Iso s t (O s) (O t)+rewrapped' _ = rewrapped+{-# INLINE rewrapped' #-} --- | Convert between a data type and its 'Generic' representation.+-- | Obtain an 'Iso' from a 'Generic' representation. -- -- >>> view (generic . re generic) "hello" :: String -- "hello" ---generic :: Generic a => Generic b => Iso a b (Rep a c) (Rep b c)-generic = iso GHC.from GHC.to+generic :: G.Generic a => G.Generic b => Iso a b (G.Rep a c) (G.Rep b c)+generic = iso G.from G.to {-# INLINE generic #-} --- | Convert between a data type and its 'Generic1' representation.+-- | Obtain an 'Iso' from a 'Generic1' representation. ---generic1 :: Generic1 f => Generic1 g => Iso (f a) (g b) (Rep1 f a) (Rep1 g b)-generic1 = iso GHC.from1 GHC.to1+generic1 :: G.Generic1 f => G.Generic1 g => Iso (f a) (g b) (G.Rep1 f a) (G.Rep1 g b)+generic1 = iso G.from1 G.to1 {-# INLINE generic1 #-} +-- | Obtain an 'Iso' from a functor and its adjoint.+--+-- Useful for converting between lens-like optics and grate-like optics:+--+-- @+-- 'Data.Profunctor.Optic.Setter.over' 'adjuncted' :: 'Adjunction' f u => ((a -> u b) -> s -> u t) -> (f a -> b) -> f s -> t+-- @+--+adjuncted :: Adjunction f u => Iso (f a -> b) (f s -> t) (a -> u b) (s -> u t)+adjuncted = iso leftAdjunct rightAdjunct+{-# INLINE adjuncted #-}++-- | Obtain an 'Iso' from a functor and its function representation.+--+tabulated :: F.Representable f => F.Representable g => Iso (f a) (g b) (F.Rep f -> a) (F.Rep g -> b)+tabulated = iso F.index F.tabulate+{-# INLINE tabulated #-}++-- | TODO: Document+--+transposed :: Functor f => Distributive g => Iso (f (g a)) (g (f a)) (g (f a)) (f (g a))+transposed = involuted distribute+{-# INLINE transposed #-}+ -- | Flip two arguments of a function. -- -- >>> (view flipped (,)) 1 2@@ -273,29 +294,38 @@ flipped = iso flip flip {-# INLINE flipped #-} --- | TODO: Document------ >>> (fst ^. curried) 3 4--- 3+-- | Curry a function. ----- >>> view curried fst 3 4+-- >>> (fst ^. invert curried) 3 4 -- 3 ---curried :: Iso ((a , b) -> c) ((d , e) -> f) (a -> b -> c) (d -> e -> f)-curried = iso curry uncurry+curried :: Iso (a -> b -> c) (d -> e -> f) ((a , b) -> c) ((d , e) -> f)+curried = iso uncurry curry {-# INLINE curried #-} --- | TODO: Document+-- | A right adjoint admits an intrinsic notion of zipping. --+unzipped :: Adjunction f u => Iso (u a , u b) (u c , u d) (u (a , b)) (u (c , d)) +unzipped = iso zipR unzipR+{-# INLINE unzipped #-}++-- | A left adjoint must be inhabited by exactly one element.+--+cozipped :: Adjunction f u => Iso ((f a) + (f b)) ((f c) + (f d)) (f (a + b)) (f (c + d))+cozipped = iso uncozipL cozipL+{-# INLINE cozipped #-}++-- | Swap sides of a product.+-- swapped :: Iso (a , b) (c , d) (b , a) (d , c) swapped = iso swap swap {-# INLINE swapped #-} --- | TODO: Document+-- | Swap sides of a sum. ---eswapped :: Iso (a + b) (c + d) (b + a) (d + c)-eswapped = iso eswap eswap-{-# INLINE eswapped #-}+coswapped :: Iso (a + b) (c + d) (b + a) (d + c)+coswapped = iso eswap eswap+{-# INLINE coswapped #-}  -- | 'Iso' defined by left-association of nested tuples. --@@ -305,9 +335,9 @@  -- | 'Iso' defined by left-association of nested tuples. ---eassociated :: Iso (a + (b + c)) (d + (e + f)) ((a + b) + c) ((d + e) + f)-eassociated = iso eassocl eassocr-{-# INLINE eassociated #-}+coassociated :: Iso (a + (b + c)) (d + (e + f)) ((a + b) + c) ((d + e) + f)+coassociated = iso eassocl eassocr+{-# INLINE coassociated #-}  -- | Obtain an 'Iso' from a function that is its own inverse. --@@ -341,50 +371,6 @@ subtracted n = iso (<< n) (<> n) {-# INLINE subtracted #-} --- | A 'Seq' is isomorphic to a 'ViewL'------ @'viewl' m ≡ m 'Data.Profunctor.Optic.Operator.^.' 'viewedl'@------ >>> Seq.fromList [1,2,3] ^. viewedl--- 1 :< fromList [2,3]------ >>> Seq.empty ^. viewedl--- EmptyL------ >>> EmptyL ^. re viewedl--- fromList []------ >>> review viewedl $ 1 Seq.:< fromList [2,3]--- fromList [1,2,3]----viewedl :: Iso (Seq a) (Seq b) (ViewL a) (ViewL b)-viewedl = iso viewl $ \xs -> case xs of-  EmptyL      -> mempty-  a Seq.:< as -> a Seq.<| as-{-# INLINE viewedl #-}---- | A 'Seq' is isomorphic to a 'ViewR'------ @'viewr' m ≡ m 'Data.Profunctor.Optic.Operator.^.' 'viewedr'@------ >>> Seq.fromList [1,2,3] ^. viewedr--- fromList [1,2] :> 3------ >>> Seq.empty ^. viewedr--- EmptyR------ >>> EmptyR ^. re viewedr--- fromList []------ >>> review viewedr $ fromList [1,2] Seq.:> 3--- fromList [1,2,3]----viewedr :: Iso (Seq a) (Seq b) (ViewR a) (ViewR b)-viewedr = iso viewr $ \xs -> case xs of-  EmptyR      -> mempty-  as Seq.:> a -> as Seq.|> a-{-# INLINE viewedr #-}- -- | Remove a single value from a type. -- -- @@@ -413,35 +399,19 @@        | otherwise = Just b {-# INLINE anon #-} -u1 :: Iso (U1 p) (U1 q) () ()-u1 = iso (const ()) (const U1)-{-# INLINE u1 #-}--k1 :: Iso (K1 i c p) (K1 j d q) c d-k1 = iso unK1 K1-{-# INLINE k1 #-}--m1 :: Iso (M1 i c f p) (M1 j d g q) (f p) (g q)-m1 = iso unM1 M1-{-# INLINE m1 #-}--par1 :: Iso (Par1 p) (Par1 q) p q-par1 = iso unPar1 Par1-{-# INLINE par1 #-}+---------------------------------------------------------------------+-- Primitive operators+--------------------------------------------------------------------- -rec1 :: Iso (Rec1 f p) (Rec1 g q) (f p) (g q)-rec1 = iso unRec1 Rec1-{-# INLINE rec1 #-}+--withIsoVl  ------------------------------------------------------------------------ Primitive operators+-- Operators --------------------------------------------------------------------- --- | Extract the two functions that characterize an 'Iso'.----withIso :: AIso s t a b -> ((s -> a) -> (b -> t) -> r) -> r-withIso x k = case x (IsoRep id id) of IsoRep sa bt -> k sa bt-{-# INLINE withIso #-}+---------------------------------------------------------------------+-- Operators+---------------------------------------------------------------------  -- | Invert an isomorphism. --@@ -453,13 +423,13 @@ invert o = withIso o $ \sa bt -> iso bt sa {-# INLINE invert #-} --- | Given a conversion on one side of an 'Iso', reover the other.+-- | Given a conversion on one side of an 'Iso', recover the other. -- -- @ -- 'reover' ≡ 'over' '.' 're' -- @ ----- Compare 'Data.Profunctor.Optic.Setter.reover'.+-- Compare 'Data.Profunctor.Optic.Setter.over'. -- reover :: AIso s t a b -> (t -> s) -> b -> a reover o = withIso o $ \sa bt ts -> sa . ts . bt@@ -481,7 +451,7 @@ -- -- This version is generalized to accept any 'Iso', not just a @newtype@. ----- >>> au (rewrapping Sum) foldMap [1,2,3,4]+-- >>> au (rewrapped' Sum) foldMap [1,2,3,4] -- 10 -- -- You may want to think of this combinator as having the following, simpler type:@@ -506,7 +476,7 @@  -- | This combinator is based on @ala@ from Conor McBride's work on Epigram. ----- As with '_Wrapping', the user supplied function for the newtype is /ignored/.+-- As with 'rewrapped'', the user supplied function for the newtype is /ignored/. -- -- >>> ala Sum foldMap [1,2,3,4] -- 10@@ -531,36 +501,5 @@ -- @ -- ala :: Newtype s => Newtype t => Functor f => (O s -> s) -> ((O t -> t) -> f s) -> f (O s) -ala = au . rewrapping+ala = au . rewrapped' {-# INLINE ala #-}-------------------------------------------------------------------------- Carriers-------------------------------------------------------------------------- | The 'IsoRep' profunctor precisely characterizes an 'Iso'.-data IsoRep a b s t = IsoRep (s -> a) (b -> t)---- | When you see this as an argument to a function, it expects an 'Iso'.-type AIso s t a b = Optic (IsoRep a b) s t a b--type AIso' s a = AIso s s a a--instance Functor (IsoRep a b s) where-  fmap f (IsoRep sa bt) = IsoRep sa (f . bt)-  {-# INLINE fmap #-}--instance Profunctor (IsoRep a b) where-  dimap f g (IsoRep sa bt) = IsoRep (sa . f) (g . bt)-  {-# INLINE dimap #-}-  lmap f (IsoRep sa bt) = IsoRep (sa . f) bt-  {-# INLINE lmap #-}-  rmap f (IsoRep sa bt) = IsoRep sa (f . bt)-  {-# INLINE rmap #-}--instance Sieve (IsoRep a b) (Index a b) where-  sieve (IsoRep sa bt) s = Index (sa s) bt--instance Cosieve (IsoRep a b) (Coindex a b) where-  cosieve (IsoRep sa bt) (Coindex sab) = bt (sab sa)-

@@ -8,72 +8,43 @@ module Data.Profunctor.Optic.Lens (     -- * Lens & Ixlens     Lens-  , Ixlens   , Lens'+  , Ixlens   , Ixlens'   , lens-  , ixlens+  , ilens   , lensVl-  , ixlensVl+  , ilensVl   , matching   , cloneLens-    -- * Colens & Cxlens-  , Colens-  , Cxlens-  , Colens'-  , Cxlens'-  , colens-  --, cxlens-  , colensVl-  , comatching-  --, cloneColens     -- * Optics-  , ixfirst-  , cofirst-  , ixsecond-  , cosecond   , united   , voided-  , valued-  , root-  , branches+    -- * Indexed optics+  , ifirst+  , isecond     -- * Primitive operators   , withLens+  , withLensVl   , withIxlens-  --, withColens     -- * Operators   , toPastro   , toTambara-    -- * Carriers-  , ALens-  , ALens'-  , AIxlens-  , AIxlens'-  , LensRep(..)-  , IxlensRep(..)- -- , AColens- -- , AColens'-  --, ColensRep(..)     -- * Classes   , Strong(..)-  , Costrong(..) ) where  import Data.Profunctor.Strong-import Data.Profunctor.Optic.Iso+import Data.Profunctor.Optic.Carrier import Data.Profunctor.Optic.Import import Data.Profunctor.Optic.Index-import Data.Profunctor.Optic.Type-import Data.Tree-import Data.Void (Void, absurd)-import GHC.Generics hiding (from, to)+import Data.Profunctor.Optic.Types import qualified Data.Bifunctor as B  -- $setup -- >>> :set -XNoOverloadedStrings -- >>> :set -XTypeApplications -- >>> :set -XFlexibleContexts--- >>> import Data.Tree -- >>> import Data.Int.Instance -- >>> :load Data.Profunctor.Optic @@ -101,7 +72,7 @@  -- | Obtain an indexed 'Lens' from an indexed getter and a setter. ----- Compare 'lens' and 'Data.Profunctor.Optic.Traversal.ixtraversal'.+-- 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 @@ -115,9 +86,9 @@ -- -- See 'Data.Profunctor.Optic.Property'. ---ixlens :: (s -> (i , a)) -> (s -> b -> t) -> Ixlens i s t a b-ixlens sia sbt = ixlensVl $ \iab s -> sbt s <$> uncurry iab (sia s)-{-# INLINE ixlens #-}+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. --@@ -138,14 +109,14 @@ -- * @o ('Data.Profunctor.Composition.Procompose' p q) ≡ 'Data.Profunctor.Composition.Procompose' (o p) (o q)@ -- lensVl :: (forall f. Functor f => (a -> f b) -> s -> f t) -> Lens s t a b-lensVl o = dimap ((info &&& values) . o (flip Index id)) (uncurry id . swap) . first'+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'. -- -- An 'Ixlens' is a valid 'Lens' and a valid 'IxTraversal'.  ----- Compare 'lensVl' & 'Data.Profunctor.Optic.Traversal.ixtraversalVl'.+-- Compare 'lensVl' & 'Data.Profunctor.Optic.Traversal.itraversalVl'. -- -- /Caution/: In order for the generated optic to be well-defined, -- you must ensure that the input satisfies the following properties:@@ -163,9 +134,9 @@ -- -- See 'Data.Profunctor.Optic.Property'. ---ixlensVl :: (forall f. Functor f => (i -> a -> f b) -> s -> f t) -> Ixlens i s t a b-ixlensVl f = lensVl $ \iab -> f (curry iab) . snd-{-# INLINE ixlensVl #-}+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 #-}  -- | Obtain a 'Lens' from its free tensor representation. --@@ -178,108 +149,35 @@ cloneLens o = withLens o lens   ------------------------------------------------------------------------ 'Colens' & 'Cxlens'+-- Primitive operators --------------------------------------------------------------------- --- | Obtain a 'Colens' from a getter and setter. ------ @--- 'colens' f g ≡ \\f g -> 're' ('lens' f g)--- 'colens' bsia bt ≡ 'colensVl' '$' \\ts b -> bsia b '<$>' (ts . bt '$' b)--- 'review' $ 'colens' f g ≡ f--- 'set' . 're' $ 're' ('lens' f g) ≡ g--- @------ A 'Colens' is a 'Review', so you can specialise types to obtain:------ @ 'review' :: 'Colens'' s a -> a -> s @------ /Caution/: In addition to the normal optic laws, the input functions--- must have the correct < https://wiki.haskell.org/Lazy_pattern_match laziness > annotations.------ For example, this is a perfectly valid 'Colens':+-- | Extract the higher order function that characterizes a 'Lens'. --+-- The lens laws can be stated in terms of 'withLens':+-- +-- Identity:+--  -- @--- co1 :: Colens a b (a, c) (b, c)--- co1 = flip colens fst $ \ ~(_,y) b -> (b,y)+-- withLensVl o Identity ≡ Identity -- @------ However removing the annotation will result in a faulty optic. -- --- See 'Data.Profunctor.Optic.Property'.----colens :: (b -> s -> a) -> (b -> t) -> Colens s t a b-colens bsa bt = unsecond . dimap (uncurry bsa) (id &&& bt)---- | Transform a Van Laarhoven colens into a profunctor colens.------ Compare 'Data.Profunctor.Optic.Grate.grateVl'.------ /Caution/: In addition to the normal optic laws, the input functions--- must have the correct laziness annotations.------ For example, this is a perfectly valid 'Colens':---+-- Composition:+--  -- @ --- co1 = colensVl $ \f ~(a,b) -> (,b) <$> f a+-- Compose . fmap (withLensVl o f) . withLensVl o g ≡ withLensVl o (Compose . fmap f . g) -- @ ----- However removing the annotation will result in a faulty optic.--- -colensVl :: (forall f. Functor f => (t -> f s) -> b -> f a) -> Colens s t a b-colensVl o = unfirst . dimap (uncurry id . swap) ((info &&& values) . o (flip Index id))---- | Obtain a 'Colens' from its free tensor representation.----comatching :: ((c , s) -> a) -> (b -> (c , t)) -> Colens s t a b-comatching csa bct = unsecond . dimap csa bct-------------------------------------------------------------------------- Primitive operators-------------------------------------------------------------------------- | Extract the two functions that characterize a 'Lens'.+-- See 'Data.Profunctor.Optic.Property'. ---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+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)  --------------------------------------------------------------------- -- Optics  --------------------------------------------------------------------- --- | TODO: Document----cofirst :: Colens a b (a , c) (b , c)-cofirst = unfirst---- | TODO: Document----cosecond :: Colens a b (c , a) (c , b)-cosecond = unsecond---- | TODO: Document------ >>> ixlists (ix @Int traversed . ix first' . ix traversed) [("foo",1), ("bar",2)]--- [(0,'f'),(1,'o'),(2,'o'),(0,'b'),(1,'a'),(2,'r')]------ >>> ixlists (ix @Int traversed . ixfirst . ix traversed) [("foo",1), ("bar",2)]--- [(0,'f'),(1,'o'),(2,'o'),(0,'b'),(1,'a'),(2,'r')]------ >>> ixlists (ix @Int traversed % ix first' % ix traversed) [("foo",1), ("bar",2)]--- [(0,'f'),(1,'o'),(2,'o'),(1,'b'),(2,'a'),(3,'r')]------ >>> ixlists (ix @Int traversed % ixfirst % ix traversed) [("foo",1), ("bar",2)]--- [(0,'f'),(1,'o'),(2,'o'),(2,'b'),(3,'a'),(4,'r')]----ixfirst :: Ixlens i (a , c) (b , c) a b-ixfirst = lmap assocl . first'---- | TODO: Document----ixsecond :: Ixlens i (c , a) (c , b) a b-ixsecond = lmap (\(i, (c, a)) -> (c, (i, a))) . second'---- | There is a `Unit` in everything.+-- | There is a '()' in everything. -- -- >>> "hello" ^. united -- ()@@ -289,7 +187,7 @@ united :: Lens' a () united = lens (const ()) const --- | There is everything in a `Void`.+-- | There is everything in a 'Void'. -- -- >>> [] & fmapped . voided <>~ "Void"  -- []@@ -301,27 +199,25 @@  -- | TODO: Document ----- Compare 'Data.Profunctor.Optic.Prism.keyed'.+-- >>> ilists (ix @Int traversed . ix first' . ix traversed) [("foo",1), ("bar",2)]+-- [(0,'f'),(1,'o'),(2,'o'),(0,'b'),(1,'a'),(2,'r')] ---valued :: Eq k => k -> Lens' (k -> v) v-valued k = lens ($ k) (\g v' x -> if (k == x) then v' else g x)---- | A 'Lens' that focuses on the root of a 'Tree'.+-- >>> ilists (ix @Int traversed . ifirst . ix traversed) [("foo",1), ("bar",2)]+-- [(0,'f'),(1,'o'),(2,'o'),(0,'b'),(1,'a'),(2,'r')] ----- >>> view root $ Node 42 []--- 42+-- >>> ilists (ix @Int traversed % ix first' % ix traversed) [("foo",1), ("bar",2)]+-- [(0,'f'),(1,'o'),(2,'o'),(1,'b'),(2,'a'),(3,'r')] ---root :: Lens' (Tree a) a-root = lensVl $ \f (Node a as) -> (`Node` as) <$> f a-{-# INLINE root #-}---- | A 'Lens' returning the direct descendants of the root of a 'Tree'+-- >>> ilists (ix @Int traversed % ifirst % ix traversed) [("foo",1), ("bar",2)]+-- [(0,'f'),(1,'o'),(2,'o'),(2,'b'),(3,'a'),(4,'r')] ----- @'Data.Profunctor.Optic.View.view' 'branches' ≡ 'subForest'@+ifirst :: Ixlens i (a , c) (b , c) a b+ifirst = lmap assocl . first'++-- | TODO: Document ---branches :: Lens' (Tree a) [Tree a]-branches = lensVl $ \f (Node a as) -> Node a <$> f as-{-# INLINE branches #-}+isecond :: Ixlens i (c , a) (c , b) a b+isecond = lmap (\(i, (c, a)) -> (c, (i, a))) . second'  --------------------------------------------------------------------- -- Operators@@ -336,58 +232,3 @@ -- 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)-------------------------------------------------------------------------- LensRep-------------------------------------------------------------------------- | The `LensRep` profunctor precisely characterizes a 'Lens'.----data LensRep a b s t = LensRep (s -> a) (s -> b -> t)--type ALens s t a b = Optic (LensRep a b) s t a b--type ALens' s a = ALens s s a a--instance Profunctor (LensRep a b) where-  dimap f g (LensRep sa sbt) = LensRep (sa . f) (\s -> g . sbt (f s))--instance Strong (LensRep a b) where-  first' (LensRep sa sbt) =-    LensRep (\(a, _) -> sa a) (\(s, c) b -> (sbt s b, c))--  second' (LensRep sa sbt) =-    LensRep (\(_, a) -> sa a) (\(c, s) b -> (c, sbt s b))--instance Sieve (LensRep a b) (Index a b) where-  sieve (LensRep sa sbt) s = Index (sa s) (sbt s)--instance Representable (LensRep a b) where-  type Rep (LensRep a b) = Index a b--  tabulate f = LensRep (\s -> info (f s)) (\s -> values (f s))-------------------------------------------------------------------------- IxlensRep------------------------------------------------------------------------data IxlensRep i a b s t = IxlensRep (s -> (i , a)) (s -> b -> t)--type AIxlens i s t a b = IndexedOptic (IxlensRep i a b) i s t a b--type AIxlens' i s a = AIxlens i s s a a--instance Profunctor (IxlensRep i a b) where-  dimap f g (IxlensRep sia sbt) = IxlensRep (sia . f) (\s -> g . sbt (f s))--instance Strong (IxlensRep i a b) where-  first' (IxlensRep sia sbt) =-    IxlensRep (\(a, _) -> sia a) (\(s, c) b -> (sbt s b, c))--  second' (IxlensRep sia sbt) =-    IxlensRep (\(_, a) -> sia a) (\(c, s) b -> (c, sbt s b))---- | Extract the two functions that characterize a 'Lens'.----withIxlens :: Monoid i => AIxlens i s t a b -> ((s -> (i , a)) -> (s -> b -> t) -> r) -> r-withIxlens o f = case o (IxlensRep id $ flip const) of IxlensRep x y -> f (x . (mempty,)) (\s b -> y (mempty, s) b)

@@ -1,46 +1,194 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TupleSections         #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeFamilies          #-} module Data.Profunctor.Optic.Operator (-    re-  , invert-  , view-  , review-  , preview-  , over-  , under-  , set-  , reset-  , is-  , matches-  , (&)+    (&)   , (%)   , (#)   , (^.)   , (^%)   , (#^)-  , (^?)-  , (^..)-  , (^%%)-  , (.~)-  , (%~)   , (..~)-  , (%%~)-  , (/~)-  , (#~)+  , (.~)+  , (**~)+  , (*~)   , (//~)+  , (/~)+  , (%%~)+  , (%~)   , (##~)-  , (?~)-  , (<>~)-  , (><~)-  , module Extra+  , (#~) ) where  import Data.Function-import Data.Profunctor.Optic.Type-import Data.Profunctor.Optic.Iso-import Data.Profunctor.Optic.View+import Data.Profunctor.Optic.Carrier+import Data.Profunctor.Optic.Types+import Data.Profunctor.Optic.Import import Data.Profunctor.Optic.Index-import Data.Profunctor.Optic.Setter-import Data.Profunctor.Optic.Fold-import Data.Profunctor.Optic.Fold0-import Data.Profunctor.Optic.Traversal-import Data.Profunctor.Optic.Traversal0-import Data.Profunctor.Extra as Extra++import qualified Data.Bifunctor as B++-- $setup+-- >>> :set -XNoOverloadedStrings+-- >>> :set -XTypeApplications+-- >>> :set -XFlexibleContexts+-- >>> :set -XRankNTypes+-- >>> import Data.List.Index as LI+-- >>> import Data.Int.Instance ()+-- >>> import Data.Maybe+-- >>> import Data.Monoid+-- >>> :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) ++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")+--+-- >>> [(0,'f'),(1,'o'),(2,'o') :: (Int, Char)] ^% iat 2 . ifirst+-- (Just 2,2)+--+-- In order to 'iview' a 'Choice' optic (e.g. 'Ixaffine', 'Ixtraversal', 'Ixfold', etc),+-- /a/ must have a 'Monoid' instance:+--+-- >>> ([] :: [Int]) ^% iat 0+-- (Nothing,0)+--+-- >>> ([1] :: [Int]) ^% iat 0+-- (Just 0,1)+--+(^%) :: Monoid i => s -> AIxview i s a -> (Maybe i, a)+(^%) s o = withPrimView o (B.first Just) . (mempty,) $ 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 a representable optic.+--+(**~) :: Optic (Star f) s t a b -> (a -> f b) -> s -> f t+(**~) = withStar+{-# INLINE (**~) #-}++-- | Set the focus of a representable optic.+--+(*~) :: Optic (Star f) s t a b -> f b -> s -> f t+(*~) o b = withStar o (const b)+{-# INLINE (*~) #-}++-- | Map over a co-representable optic.+--+(//~) :: Optic (Costar f) s t a b -> (f a -> b) -> f s -> t+(//~) = withCostar+{-# INLINE (//~) #-}++-- | Set the focus of a co-representable optic.+--+(/~) :: Optic (Costar f) s t a b -> b -> f s -> t+(/~) o b = withCostar o (const b)+{-# INLINE (/~) #-}++-- | Map over an indexed optic.+--+-- See also '##~'.+--+(%%~) :: Monoid i => AIxsetter i s t a b -> (i -> a -> b) -> s -> t+(%%~) o f = withIxsetter o f mempty+{-# INLINE (%%~) #-}++-- | Set the focus of an indexed optic.+--+--  See also '#~'.+--+-- /Note/ if you're looking for the infix 'over' it is '..~'.+--+(%~) :: 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 '%%~'.+--+(##~) :: Monoid k => ACxsetter k s t a b -> (k -> a -> b) -> s -> t +(##~) o f = withCxsetter o f mempty+{-# INLINE (##~) #-}++-- | Set the focus of a coindexed optic.+--+--  See also '%~'.+--+(#~) :: Monoid k => ACxsetter k s t a b -> (k -> b) -> s -> t +(#~) o kb = o ##~ flip (const kb) +{-# INLINE (#~) #-}

@@ -0,0 +1,274 @@+{-# 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+    -- * 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 (affineVl, iaffineVl, is)+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 #-}++------------------------------------------------------------------------------+-- Indexed operators+------------------------------------------------------------------------------++-- | TODO: Document +--+ipreview :: Monoid i => AIxoption (i , a) i s a -> s -> Maybe (i , a)+ipreview o = ipreviews o (,)+{-# INLINE ipreview #-}++-- | TODO: Document +--+ipreviews :: 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 #-}

@@ -0,0 +1,263 @@+{-# 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+  , foldsp+  , foldsr+  , ifoldsr+  , ifoldsrFrom+  , foldsl+  , ifoldsl+  , ifoldslFrom+  , foldsr'+  , ifoldsr'+  , foldsl'+  , ifoldsl'+  , foldsrM+  , ifoldsrM+  , foldslM+  , ifoldslM+  , traverses_+  , itraverses_+  , asums+  , concats+  , iconcats+  , endo+  , endoM+  , finds+  , ifinds+  , has+  , hasnt +  , elem+  , pelem+  , joins+  , joins'+  , meets+  , meets'+  , min +  , max +) where++import Control.Monad (void)+import Control.Monad.Reader as Reader hiding (lift)+import Data.Bifunctor (Bifunctor(..))+import Data.Bool.Instance () -- Semigroup / Monoid / Semiring instances+import Data.Foldable (Foldable, foldMap, traverse_)+import Data.Function+import Data.Maybe+import Data.Monoid hiding (All(..), Any(..))+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.Traversal+import Data.Profunctor.Optic.Affine+import Data.Prd (Prd, Minimal(..), Maximal(..))+import Data.Prd.Lattice (Lattice(..))+import Data.Semiring (Semiring(..), Prod(..))++import qualified Control.Applicative as A+import qualified Data.Prd as Prd+import qualified Data.Semiring as Rng+import qualified Prelude as Pre++-- $setup+-- >>> :set -XNoOverloadedStrings+-- >>> :set -XTypeApplications+-- >>> :set -XFlexibleContexts+-- >>> import Control.Exception hiding (catches)+-- >>> import Data.Functor.Identity+-- >>> import Data.List.Optic+-- >>> import Data.Int.Instance ()+-- >>> 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 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 :: Monoid i => AIxfold [r] i s a -> (i -> a -> [r]) -> s -> [r]+iconcats o f = withIxfold o f mempty+{-# 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 (Endo (Maybe a)) s a -> (a -> Bool) -> s -> Maybe a+finds o f = foldsr o (\a y -> if f a then Just a else y) Nothing+{-# INLINE finds #-}++-- | Find the first focus of an indexed optic that satisfies a predicate, if one exists.+--+ifinds :: Monoid i => AIxfold (Endo (Maybe (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 Any s a -> s -> Bool+has o = withFold o (const True)+{-# INLINE has #-}++-- | Determine whether an optic does not have a focus.+--+hasnt :: AFold All s a -> s -> Bool+hasnt o = foldsp o (const False)+{-# INLINE hasnt #-}++-- | Determine whether the targets of a `Fold` contain a given element.+--+elem :: Eq a => AFold Any s a -> a -> s -> Bool+elem o a = withFold o (== a)++-- | Determine whether the foci of an optic contain an element equivalent to a given element.+--+pelem :: Prd a => AFold Any s a -> a -> s -> Bool+pelem o a = withFold o (Prd.=~ a)+{-# INLINE pelem #-}++-- | Compute the minimum of the targets of a totally ordered fold. +--+min :: Ord a => AFold (Endo (Endo a)) s a -> a -> s -> a+min o = foldsl' o Pre.min++-- | Compute the maximum of the targets of a totally ordered fold.+--+max :: Ord a => AFold (Endo (Endo a)) s a -> a -> s -> a+max 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' #-}

@@ -11,35 +11,16 @@   , Prism'   , Cxprism   , Cxprism'-  , APrism-  , APrism'   , prism   , prism'-  , cxprism+  , kprism   , handling   , clonePrism-    -- * Coprism & Ixprism-  , Coprism-  , Coprism'-  , Ixprism-  , Ixprism'-  , ACoprism-  , ACoprism'-  , coprism-  , coprism'-  , rehandling-  , cloneCoprism     -- * Optics-  , l1-  , r1-  , left-  , right-  , cxright+  , kright   , just+  , kjust   , nothing-  , cxjust-  , keyed-  , filtered   , compared   , prefixed   , only@@ -51,19 +32,14 @@   , asyncException     -- * Primitive operators   , withPrism-  , withCoprism     -- * Operators   , aside   , without   , below   , toPastroSum   , toTambaraSum-    -- * Carriers-  , PrismRep(..)-  , CoprismRep(..)     -- * Classes   , Choice(..)-  , Cochoice(..) ) where  import Control.Exception@@ -73,11 +49,10 @@ 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.Type--import GHC.Generics hiding (from, to)+import Data.Profunctor.Optic.Types  -- $setup -- >>> :set -XNoOverloadedStrings@@ -86,9 +61,10 @@ -- >>> :set -XTypeOperators -- >>> :set -XRankNTypes -- >>> import Data.Int.Instance ()+-- >>> import Data.List.NonEmpty -- >>> :load Data.Profunctor.Optic--- >>> let catchOn :: Int -> Cxprism' Int (Maybe String) String ; catchOn n = cxjust $ \k -> if k==n then Just "caught" else Nothing--- >>> let catchFoo :: b -> Cxprism String (String + a) (String + b) a b; catchFoo b = cxright $ \e k -> if e == "fooError" && k == mempty then Right b else Left e+-- >>> let catchOn :: Int -> Cxprism' Int (Maybe String) String ; catchOn n = kjust $ \k -> if k==n then Just "caught" else Nothing+-- >>> let catchFoo :: b -> Cxprism String (String + a) (String + b) a b; catchFoo b = kright $ \e k -> if e == "fooError" && k == mempty then Right b else Left e  --------------------------------------------------------------------- -- 'Prism' & 'Cxprism'@@ -125,8 +101,8 @@  -- | Obtain a 'Cxprism'' from a reviewer and a matcher function that returns either a match or a failure handler. ---cxprism :: (s -> (k -> t) + a) -> (b -> t) -> Cxprism k s t a b-cxprism skta bt = prism skta (bt .)+kprism :: (s -> (k -> t) + a) -> (b -> t) -> Cxprism k s t a b+kprism skta bt = prism skta (bt .)  -- | Obtain a 'Prism' from its free tensor representation. --@@ -141,128 +117,31 @@ clonePrism o = withPrism o prism  ------------------------------------------------------------------------ 'Coprism' & 'Ixprism'-------------------------------------------------------------------------- | 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 --------------------------------------------------------------------- -l1 :: Prism ((a :+: c) t) ((b :+: c) t) (a t) (b t)-l1 = prism sta L1-  where-    sta (L1 v) = Right v-    sta (R1 v) = Left (R1 v)-{-# INLINE l1 #-}--r1 :: Prism ((c :+: a) t) ((c :+: b) t) (a t) (b t)-r1 = prism sta R1-  where-    sta (R1 v) = Right v-    sta (L1 v) = Left (L1 v)-{-# INLINE r1 #-}---- | 'Prism' into the `Left` constructor of `Either`.----left :: Prism (a + c) (b + c) a b-left = left'---- | 'Prism' into the `Right` constructor of `Either`.----right :: Prism (c + a) (c + b) a b-right = right'---- | Coindexed prism into the `Right` constructor of `Either`.+-- | Focus on the `Just` constructor of `Maybe`. ----- >>>  cxset (catchFoo "Caught foo") id $ Left "fooError"--- Right "Caught foo"--- >>>  cxset (catchFoo "Caught foo") id $ Left "barError"--- Left "barError"+-- >>> Just 1 :| [Just 2, Just 3] & just //~ sum+-- Just 6 ---cxright :: (e -> k -> e + b) -> Cxprism k (e + a) (e + b) a b-cxright ekeb = flip cxprism Right $ either (Left . ekeb) Right---- | 'Prism' into the `Just` constructor of `Maybe`.+-- >>> Nothing :| [Just 2, Just 3] & just //~ sum+-- Just 5 -- just :: Prism (Maybe a) (Maybe b) a b just = flip prism Just $ maybe (Left Nothing) Right --- | 'Prism' into the `Nothing` constructor of `Maybe`.+-- | Focus on the `Nothing` constructor of `Maybe`. -- nothing :: Prism (Maybe a) (Maybe b) () () nothing = flip prism (const Nothing) $ maybe (Right ()) (const $ Left Nothing) --- | Coindexed prism into the `Just` constructor of `Maybe`.------ >>> Just "foo" & catchOn 1 ##~ (\k msg -> show k ++ ": " ++ msg)--- Just "0: foo"------ >>> Nothing & catchOn 1 ##~ (\k msg -> show k ++ ": " ++ msg)--- Nothing------ >>> Nothing & catchOn 0 ##~ (\k msg -> show k ++ ": " ++ msg)--- Just "caught"----cxjust :: (k -> Maybe b) -> Cxprism k (Maybe a) (Maybe b) a b-cxjust kb = flip cxprism Just $ maybe (Left kb) Right---- | Match a given key to obtain the associated value. ----keyed :: Eq a => a -> Prism' (a , b) b-keyed x = flip prism ((,) x) $ \kv@(k,v) -> branch (==x) kv v k---- | Filter another optic.------ >>> [1..10] ^.. folded . filtered even--- [2,4,6,8,10]----filtered :: (a -> Bool) -> Prism' a a-filtered f = iso (branch' f) join . right - -- | Focus on comparability to a given element of a partial order. -- compared :: Eq a => Prd a => a -> Prism' a Ordering compared x = flip prism' (const x) (pcompare x) --- | 'Prism' into the remainder of a list with a given prefix.+-- | Focus on the remainder of a list with a given prefix. -- prefixed :: Eq a => [a] -> Prism' [a] [a] prefixed ps = prism' (stripPrefix ps) (ps ++)@@ -274,6 +153,17 @@  -- | Create a 'Prism' from a value and a predicate. --+-- >>> nearly [] null #^ ()+-- []+--+-- >>> [1,2,3,4] ^? nearly [] null+-- Nothing+--+-- @'nearly' [] 'Prelude.null' :: 'Prism'' [a] ()@+--+-- /Caution/: In order for the generated optic to be well-defined,+-- you must ensure that @f x@ holds iff @x ≡ a@. +-- nearly :: a -> (a -> Bool) -> Prism' a () nearly x f = prism' (guard . f) (const x) @@ -282,43 +172,60 @@ nthbit :: Bits s => Int -> Prism' s () nthbit n = prism' (guard . (flip testBit n)) (const $ bit n) --- | Check whether an exception is synchronous.+-- | Focus on whether an exception is synchronous. -- sync :: Exception e => Prism' e e -sync = filtered $ \e -> case fromException (toException e) of+sync = filterOn $ \e -> case fromException (toException e) of   Just (SomeAsyncException _) -> False   Nothing -> True+  where filterOn f = iso (branch' f) join . right' --- | Check whether an exception is asynchronous.+-- | Focus on whether an exception is asynchronous. -- async :: Exception e => Prism' e e -async = filtered $ \e -> case fromException (toException e) of+async = filterOn $ \e -> case fromException (toException e) of   Just (SomeAsyncException _) -> True   Nothing -> False+  where filterOn f = iso (branch' f) join . right' --- | TODO: Document+-- | Focus on whether a given exception has occurred. -- exception :: Exception e => Prism' SomeException e exception = prism' fromException toException --- | TODO: Document+-- | Focus on whether a given asynchronous exception has occurred. -- asyncException :: Exception e => Prism' SomeException e asyncException = prism' asyncExceptionFromException asyncExceptionToException  ------------------------------------------------------------------------ Primitive operators+-- Coindexed optics --------------------------------------------------------------------- --- | Extract the two functions that characterize a 'Prism'.+-- | Coindexed prism into the `Right` constructor of `Either`. ---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+-- >>> kset (catchFoo "Caught foo") id $ Left "fooError"+-- Right "Caught foo"+--+-- >>> kset (catchFoo "Caught foo") id $ Left "barError"+-- Left "barError"+--+kright :: (e -> k -> e + b) -> Cxprism k (e + a) (e + b) a b+kright ekeb = flip kprism Right $ either (Left . ekeb) Right --- | Extract the two functions that characterize a 'Coprism'.+-- | Coindexed prism into the `Just` constructor of `Maybe`. ---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+-- >>> Just "foo" & catchOn 1 ##~ (\k msg -> show k ++ ": " ++ msg)+-- Just "0: foo"+--+-- >>> Nothing & catchOn 1 ##~ (\k msg -> show k ++ ": " ++ msg)+-- Nothing+--+-- >>> Nothing & catchOn 0 ##~ (\k msg -> show k ++ ": " ++ msg)+-- Just "caught"+--+kjust :: (k -> Maybe b) -> Cxprism k (Maybe a) (Maybe b) a b+kjust kb = flip kprism Just $ maybe (Left kb) Right  --------------------------------------------------------------------- -- Operators@@ -350,10 +257,10 @@ --  -- Returns a 'Prism' that matches only if each element matches the original 'Prism'. ----- >>> [Left 1, Right "foo", Left 4, Right "woot"] ^.. below right+-- >>> [Left 1, Right "foo", Left 4, Right "woot"] ^.. below right' -- [] ----- >>> [Right "hail hydra!", Right "foo", Right "blah", Right "woot"] ^.. below right+-- >>> [Right "hail hydra!", Right "foo", Right "blah", Right "woot"] ^.. below right' -- [["hail hydra!","foo","blah","woot"]] -- below :: Traversable f => APrism' s a -> Prism' (f s) (f a)@@ -373,58 +280,4 @@ -- | Use a 'Prism' to construct a 'TambaraSum'. -- toTambaraSum :: Choice p => APrism s t a b -> p a b -> TambaraSum p s t-toTambaraSum o p = withPrism o $ \sta bt -> TambaraSum (left . prism sta bt $ p)-------------------------------------------------------------------------- 'PrismRep' & 'CoprismRep'------------------------------------------------------------------------type APrism s t a b = Optic (PrismRep a b) s t a b--type APrism' s a = APrism s s a a---- | The 'PrismRep' profunctor precisely characterizes a 'Prism'.----data PrismRep a b s t = PrismRep (s -> t + a) (b -> t)--instance Functor (PrismRep a b s) where-  fmap f (PrismRep sta bt) = PrismRep (first f . sta) (f . bt)-  {-# INLINE fmap #-}--instance Profunctor (PrismRep a b) where-  dimap f g (PrismRep sta bt) = PrismRep (first g . sta . f) (g . bt)-  {-# INLINE dimap #-}--  lmap f (PrismRep sta bt) = PrismRep (sta . f) bt-  {-# INLINE lmap #-}--  rmap = fmap-  {-# INLINE rmap #-}--instance Choice (PrismRep a b) where-  left' (PrismRep sta bt) = PrismRep (either (first Left . sta) (Left . Right)) (Left . bt)-  {-# INLINE left' #-}--  right' (PrismRep sta bt) = PrismRep (either (Left . Left) (first Right . sta)) (Right . bt)-  {-# INLINE right' #-}--type ACoprism s t a b = Optic (CoprismRep a b) s t a b--type ACoprism' s a = ACoprism s s a a--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 #-}+toTambaraSum o p = withPrism o $ \sta bt -> TambaraSum (left' . prism sta bt $ p)

@@ -17,36 +17,42 @@   , idempotent_prism      -- * Lens   , Lens+  , id_lens   , tofrom_lens   , fromto_lens   , idempotent_lens     -- * Grate   , Grate-  , pure_grate+  , id_grate+  , const_grate   , compose_grate-    -- * Traversal0-  , Traversal0-  , tofrom_traversal0-  , fromto_traversal0-  , idempotent_traversal0-    -- * Traversal & Traversal1+    -- * Affine+  , Affine+  , tofrom_affine+  , fromto_affine+  , idempotent_affine+    -- * Traversal   , Traversal+  , id_traversal+  , id_traversal1   , pure_traversal   , compose_traversal   , compose_traversal1-    -- * Cotraversal1-  , Cotraversal1 -  , compose_cotraversal1+    -- * Cotraversal+  , Cotraversal+  --, compose_cotraversal     -- * Setter   , Setter-  , pure_setter+  , id_setter   , compose_setter   , idempotent_setter ) where  +import Control.Monad as M (join) import Control.Applicative+import Data.Profunctor.Optic.Carrier import Data.Profunctor.Optic.Import-import Data.Profunctor.Optic.Type+import Data.Profunctor.Optic.Types import Data.Profunctor.Optic.Iso --import Data.Profunctor.Optic.View import Data.Profunctor.Optic.Setter@@ -55,7 +61,8 @@ import Data.Profunctor.Optic.Grate --import Data.Profunctor.Optic.Fold import Data.Profunctor.Optic.Traversal-import Data.Profunctor.Optic.Traversal0+import Data.Profunctor.Optic.Cotraversal+import Data.Profunctor.Optic.Affine  --------------------------------------------------------------------- -- 'Iso'@@ -82,7 +89,6 @@ tofrom_prism :: Eq s => Prism' s a -> s -> Bool tofrom_prism o s = withPrism o $ \sta bt -> either id bt (sta s) == s - -- | If we build a whole from a focus, that whole must contain the focus. -- -- * @sta (bt b) ≡ Right b@@@ -95,14 +101,19 @@ -- * @left sta (sta s) ≡ left Left (sta s)@ -- idempotent_prism :: Eq s => Eq a => Prism' s a -> s -> Bool-idempotent_prism o s = withPrism o $ \sta _ -> left sta (sta s) == left Left (sta s)+idempotent_prism o s = withPrism o $ \sta _ -> left' sta (sta s) == left' Left (sta s)  --------------------------------------------------------------------- -- '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+id_lens o = M.join invertible $ runIdentity . withLensVl o Identity + -- | You get back what you put in. -- -- * @view o (set o b a) ≡ b@@@ -130,113 +141,92 @@  -- The 'Grate' laws are that of an algebra for the parameterised continuation 'Coindex'. +id_grate :: Eq s => Grate' s a -> s -> Bool+id_grate o = M.join invertible $ withGrateVl o runIdentity . Identity + -- | -- -- * @sabt ($ s) ≡ s@ ---pure_grate :: Eq s => Grate' s a -> s -> Bool-pure_grate o s = withGrate o $ \sabt -> sabt ($ s) == s+const_grate :: Eq s => Grate' s a -> s -> Bool+const_grate o s = withGrate o $ \sabt -> sabt ($ s) == s --- |------ * @sabt (\k -> h (k . sabt)) ≡ sabt (\k -> h ($ k))@----compose_grate :: Eq s => Grate' s a -> ((((s -> a) -> a) -> a) -> a) -> Bool-compose_grate o f = withGrate o $ \sabt -> sabt (\k -> f (k . sabt)) == sabt (\k -> f ($ k))+compose_grate :: Eq s => Functor f => Functor g => Grate' s a -> (f a -> a) -> (g a -> a) -> f (g s) -> Bool+compose_grate o f g = liftA2 (==) lhs rhs+  where lhs = withGrateVl o f . fmap (withGrateVl o g) +        rhs = withGrateVl o (f . fmap g . getCompose) . Compose  ------------------------------------------------------------------------ 'Traversal0'+-- 'Affine' ---------------------------------------------------------------------  -- | You get back what you put in. -- -- * @sta (sbt a s) ≡ either (Left . const a) Right (sta s)@ ---tofrom_traversal0 :: Eq a => Eq s => Traversal0' s a -> s -> a -> Bool-tofrom_traversal0 o s a = withTraversal0 o $ \sta sbt -> sta (sbt s a) == either (Left . flip const a) Right (sta s)+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)  -- | Putting back what you got doesn't change anything. -- -- * @either id (sbt s) (sta s) ≡ s@ ---fromto_traversal0 :: Eq s => Traversal0' s a -> s -> Bool-fromto_traversal0 o s = withTraversal0 o $ \sta sbt -> either id (sbt s) (sta s) == s+fromto_affine :: Eq s => Affine' s a -> s -> Bool+fromto_affine 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_traversal0 :: Eq s => Traversal0' s a -> s -> a -> a -> Bool-idempotent_traversal0 o s a1 a2 = withTraversal0 o $ \_ sbt -> sbt (sbt s a1) a2 == sbt s a2+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  ------------------------------------------------------------------------ 'Traversal' & 'Traversal1'+-- 'Traversal' --------------------------------------------------------------------- --- | A 'Traversal' is a valid 'Setter' with the following additional laws:------ * @abst pure ≡ pure@------ * @fmap (abst f) . abst g ≡ getCompose . abst (Compose . fmap f . g)@------ These can be restated in terms of 'withTraversal':------ * @withTraversal abst (Identity . f) ≡  Identity . fmap f@------ * @Compose . fmap (withTraversal abst f) . withTraversal abst g == withTraversal abst (Compose . fmap f . g)@------ See also < https://www.cs.ox.ac.uk/jeremy.gibbons/publications/iterator.pdf >----pure_traversal-  :: Eq (f s) -  => Applicative f-  => ((a -> f a) -> s -> f s)-  -> s -> Bool-pure_traversal abst = liftA2 (==) (abst pure) pure+-- A 'Traversal' is a valid 'Setter' with the following additional laws: -compose_traversal-  :: Eq (f (g s))-  => Applicative f-  => Applicative g -  => (forall f. Applicative f => (a -> f a) -> s -> f s) -  -> (a -> g a) -> (a -> f a) -> s -> Bool-compose_traversal abst f g = liftA2 (==) (fmap (abst f) . abst g)-                                         (getCompose . abst (Compose . fmap f . g))+id_traversal :: Eq s => Traversal' s a -> s -> Bool+id_traversal o = M.join invertible $ runIdentity . withTraversal o Identity  -compose_traversal1-  :: Eq (f (g s))-  => Apply f-  => Apply g -  => (forall f. Apply f => (a -> f a) -> s -> f s) -  -> (a -> g a) -> (a -> f a) -> s -> Bool-compose_traversal1 abst f g = liftF2 (==) (fmap (abst f) . abst g)-                                         (getCompose . abst (Compose . fmap f . g))+id_traversal1 :: Eq s => Traversal1' s a -> s -> Bool+id_traversal1 o = M.join invertible $ runIdentity . withTraversal1 o Identity  +pure_traversal :: Eq (f s) => Applicative f => ATraversal' f s a -> s -> Bool+pure_traversal o = liftA2 (==) (withTraversal 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 o f g = liftA2 (==) lhs rhs+  where lhs = fmap (withTraversal o f) . withTraversal o g+        rhs = getCompose . withTraversal 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)+ ------------------------------------------------------------------------ 'Cotraversal1'+-- 'Cotraversal' ------------------------------------------------------------------------- | A 'Cotraversal1' is a valid 'Resetter' with the following additional law:+{-+-- | A 'Cotraversal' is a valid 'Resetter' with the following additional law: -- -- * @abst f . fmap (abst g) ≡ abst (f . fmap g . getCompose) . Compose @ ----- These can be restated in terms of 'cowithTraversal1':+-- The cotraversal laws can be restated in terms of 'cowithTraversal1': ----- * @cowithTraversal1 abst (f . runIdentity) ≡  fmap f . runIdentity @+-- * @withCotraversal o (f . runIdentity) ≡  fmap f . runIdentity @ ----- * @cowithTraversal1 abst f . fmap (cowithTraversal1 abst g) . getCompose == cowithTraversal1 abst (f . fmap g . getCompose)@+-- * @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 > ---compose_cotraversal1-  :: Eq s-  => Apply f -  => Apply g -  => (forall f. Apply f => (f a -> a) -> f s -> s) -  -> (g a -> a) -> (f a -> a) -> g (f s) -> Bool-compose_cotraversal1 abst f g = liftF2 (==) (abst f . fmap (abst g))-                                            (abst (f . fmap g . getCompose) . Compose)-+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+-} --------------------------------------------------------------------- -- 'Setter' ---------------------------------------------------------------------@@ -245,8 +235,8 @@ -- -- * @over o id ≡ id@ ---pure_setter :: Eq s => Setter' s a -> s -> Bool-pure_setter o s = over o id s == s+id_setter :: Eq s => Setter' s a -> s -> Bool+id_setter o s = over o id s == s  -- | --

@@ -10,97 +10,77 @@     Setter   , Setter'   , setter-  , ixsetter+  , isetter   , closing     -- * Resetter   , Resetter   , Resetter'   , resetter-  , cxsetter+  , ksetter     -- * Optics   , cod   , dom   , bound    , fmapped+  , imappedRep   , contramapped-  , setmapped-  , isetmapped-  , foldmapped+  , exmapped   , liftedA   , liftedM-  , locally+  , forwarded+  , censored+  , seeked   , zipped-  , cond   , modded-  , reviewed-  , composed-  , exmapped+  , cond     -- * Primitive operators-  , over-  , ixover-  , under-  , cxover-  , through+  , withIxsetter+  , withCxsetter     -- * Operators-  , assignA   , set-  , ixset-  , reset-  , cxset+  , iset+  , kset   , (.~)-  , (..~)-  , (/~)-  , (//~)-  , (?~)-  , (<>~)-  , (><~)-    -- * Indexed Operators   , (%~)-  , (%%~)   , (#~)+  , over+  , iover+  , kover+  , (..~)+  , (%%~)   , (##~)-    -- * MonadState+  , (<>~)+  , (><~)+    -- * mtl+  , locally+  , scribe   , assigns   , modifies   , (.=)-  , (..=)   , (%=)-  , (%%=)-  , (//=)   , (#=)+  , (..=)+  , (%%=)   , (##=)-  , (?=)   , (<>=)   , (><=)-  , zoom-    -- * Carriers-  , ASetter-  , ASetter'-  , Star(..)-  , AResetter-  , AResetter'-  , Costar(..)-    -- * Classes-  , Representable(..)-  , Corepresentable(..) ) where  import Control.Applicative (liftA)+import Control.Comonad.Store.Class (ComonadStore, seeks) import Control.Exception (Exception(..)) import Control.Monad.Reader as Reader import Control.Monad.State as State import Control.Monad.Writer as Writer-import Data.Foldable (Foldable, foldMap)-import Data.Profunctor.Arrow+import Data.Profunctor.Optic.Carrier import Data.Profunctor.Optic.Import hiding ((&&&))-import Data.Profunctor.Optic.Index (Index(..), Coindex(..), trivial)-import Data.Profunctor.Optic.Type+import Data.Profunctor.Optic.Index+import Data.Profunctor.Optic.Operator+import Data.Profunctor.Optic.Types import Data.Semiring -import Data.IntSet as IntSet-import Data.Set as Set-import Prelude (Num(..)) import qualified Control.Exception as Ex+import qualified Data.Functor.Rep as F  -- $setup -- >>> :set -XNoOverloadedStrings@@ -113,28 +93,21 @@ -- >>> import Control.Monad.State -- >>> import Control.Monad.Reader -- >>> import Control.Monad.Writer+-- >>> import Data.Bool (bool)+-- >>> import Data.Bool.Instance ()+-- >>> import Data.Complex+-- >>> import Data.Functor.Rep -- >>> import Data.Functor.Identity -- >>> import Data.Functor.Contravariant -- >>> import Data.Int.Instance () -- >>> import Data.List.Index as LI -- >>> import Data.IntSet as IntSet -- >>> import Data.Set as Set+-- >>> import Data.Tuple (swap) -- >>> :load Data.Profunctor.Optic--- >>> let catchOn :: Int -> Cxprism' Int (Maybe String) String ; catchOn n = cxjust $ \k -> if k==n then Just "caught" else Nothing--- >>> let ixtraversed :: Ixtraversal Int [a] [b] a b ; ixtraversed = ixtraversalVl itraverse--- >>> let ixat :: Int -> Ixtraversal0' Int [a] a; ixat = inserted (\i s -> flip LI.ifind s $ \n _ -> n == i) (\i a s -> LI.modifyAt i (const a) s)--type ASetter s t a b = ARepn Identity s t a b--type ASetter' s a = ASetter s s a a--type AIxsetter i s t a b = AIxrepn Identity i s t a b--type AResetter s t a b = ACorepn Identity s t a b--type AResetter' s a = AResetter s s a a--type ACxsetter k s t a b = ACxrepn Identity k s t a b+-- >>> let catchOn :: Int -> Cxprism' Int (Maybe String) String ; catchOn n = kjust $ \k -> if k==n then Just "caught" else Nothing+-- >>> 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)   --------------------------------------------------------------------- -- Setter@@ -144,7 +117,7 @@ -- -- To demote an optic to a semantic edit combinator, use the section @(l ..~)@ or @over l@. ----- >>> [("The",0),("quick",1),("brown",1),("fox",2)] & setter fmap . t21 ..~ Prelude.length+-- >>> [("The",0),("quick",1),("brown",1),("fox",2)] & setter fmap . first' ..~ Prelude.length -- [(3,0),(5,1),(5,1),(3,2)] -- -- /Caution/: In order for the generated optic to be well-defined,@@ -171,8 +144,8 @@ -- | Build an 'Ixsetter' from an indexed function. -- -- @--- 'ixsetter' '.' 'ixover' ≡ 'id'--- 'ixover' '.' 'ixsetter' ≡ 'id'+-- 'isetter' '.' 'iover' ≡ 'id'+-- 'iover' '.' 'isetter' ≡ 'id' -- @ -- -- /Caution/: In order for the generated optic to be well-defined,@@ -184,10 +157,20 @@ -- -- See 'Data.Profunctor.Optic.Property'. ---ixsetter :: ((i -> a -> b) -> s -> t) -> Ixsetter i s t a b-ixsetter f = setter $ \iab -> f (curry iab) . snd -{-# INLINE ixsetter #-}+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+closing sabt = setter $ \ab s -> sabt $ \sa -> ab (sa s)+{-# INLINE closing #-}++---------------------------------------------------------------------+-- Resetter+---------------------------------------------------------------------+ -- | Obtain a 'Resetter' from a <http://conal.net/blog/posts/semantic-editor-combinators SEC>. -- -- /Caution/: In order for the generated optic to be well-defined,@@ -213,115 +196,9 @@ -- -- See 'Data.Profunctor.Optic.Property'. ---cxsetter :: ((k -> a -> t) -> s -> t) -> Cxsetter k s t a t-cxsetter f = resetter $ \kab -> const . f (flip kab)-{-# INLINE cxsetter #-}---- | Every valid 'Grate' is a 'Setter'.----closing :: (((s -> a) -> b) -> t) -> Setter s t a b-closing sabt = setter $ \ab s -> sabt $ \sa -> ab (sa s)-{-# INLINE closing #-}-------------------------------------------------------------------------- Primitive operators-------------------------------------------------------------------------- | Extract a SEC from a 'Setter'.------ Used to modify the target of a 'Lens' or all the targets of a 'Setter' --- or 'Traversal'.------ @--- 'over' o 'id' ≡ 'id' --- 'over' o f '.' 'over' o g ≡ 'over' o (f '.' g)--- 'setter' '.' 'over' ≡ 'id'--- 'over' '.' 'setter' ≡ 'id'--- @------ >>> over fmapped (+1) (Just 1)--- Just 2------ >>> over fmapped (*10) [1,2,3]--- [10,20,30]------ >>> over t21 (+1) (1,2)--- (2,2)------ >>> over t21 show (10,20)--- ("10",20)------ @--- over :: Setter s t a b -> (a -> r) -> s -> r--- over :: Monoid r => Fold s t a b -> (a -> r) -> s -> r--- @----over :: ASetter s t a b -> (a -> b) -> s -> t-over o = (runIdentity #.) #. runStar #. o .# Star .# (Identity #. ) -{-# INLINE over #-}---- |------ >>> ixover (ixat 1) (+) [1,2,3 :: Int]--- [1,3,3]------ >>> ixover (ixat 5) (+) [1,2,3 :: Int]--- [1,2,3]----ixover :: Monoid i => AIxsetter i s t a b -> (i -> a -> b) -> s -> t-ixover o f = curry (over o (uncurry f)) mempty-{-# INLINE ixover #-}---- | Extract a SEC from a 'Resetter'.------ @--- 'under' o 'id' ≡ 'id' --- 'under' o f '.' 'under' o g ≡ 'under' o (f '.' g)--- 'resetter' '.' 'under' ≡ 'id'--- 'under' '.' 'resetter' ≡ 'id'--- @------ Note that 'under' (more properly co-/over/) is distinct from 'Data.Profunctor.Optic.Iso.reover':------ >>> :t under $ wrapped @(Identity Int)--- under $ wrapped @(Identity Int)---   :: (Int -> Int) -> Identity Int -> Identity Int--- >>> :t over $ wrapped @(Identity Int)--- over $ wrapped @(Identity Int)---   :: (Int -> Int) -> Identity Int -> Identity Int--- >>> :t over . re $ wrapped @(Identity Int)--- over . re $ wrapped @(Identity Int)---   :: (Identity Int -> Identity Int) -> Int -> Int--- >>> :t reover $ wrapped @(Identity Int)--- reover $ wrapped @(Identity Int)---   :: (Identity Int -> Identity Int) -> Int -> Int------ Compare to the /lens-family/ <http://hackage.haskell.org/package/lens-family-2.0.0/docs/Lens-Family2.html#v:under version>.----under :: AResetter s t a b -> (a -> b) -> s -> t-under o = (.# Identity) #. runCostar #. o .# Costar .# (.# runIdentity)-{-# INLINE under #-}---- |------ >>> cxover (catchOn 42) (\k msg -> show k ++ ": " ++ msg) $ Just "foo"--- Just "0: foo"------ >>> cxover (catchOn 42) (\k msg -> show k ++ ": " ++ msg) Nothing--- Nothing------ >>> cxover (catchOn 0) (\k msg -> show k ++ ": " ++ msg) Nothing--- Just "caught"----cxover :: Monoid k => ACxsetter k s t a b -> (k -> a -> b) -> s -> t -cxover o f = flip (under o (flip f)) mempty-{-# INLINE cxover #-}---- | The join of 'under' and 'over'.----through :: Optic (->) s t a b -> (a -> b) -> s -> t-through = id-{-# INLINE through #-}+ksetter :: ((k -> a -> t) -> s -> t) -> Cxsetter k s t a t+ksetter f = resetter $ \kab -> const . f (flip kab)+{-# INLINE ksetter #-}  --------------------------------------------------------------------- -- Optics @@ -370,8 +247,17 @@ fmapped = setter fmap {-# INLINE fmapped #-} --- | This 'Setter' can be used to map over all of the inputs to a 'Contravariant'.+-- | '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 #-}++-- | 'Setter' on each value of a contravariant functor.+-- -- @ -- 'contramap' ≡ 'over' 'contramapped' -- @@@ -386,29 +272,20 @@ contramapped = setter contramap {-# INLINE contramapped #-} --- | +-- | Map one exception into another as proposed in the paper "A semantics for imprecise exceptions". ----- >>> over setmapped (+1) (Set.fromList [1,2,3,4])--- fromList [2,3,4,5]-setmapped :: Ord b => Setter (Set a) (Set b) a b-setmapped = setter Set.map-{-# INLINE setmapped #-}---- |+-- >>> handles (only Overflow) (\_ -> return "caught") $ assert False (return "uncaught") & (exmapped ..~ \ (AssertionFailed _) -> Overflow)+-- "caught" ----- >>> over isetmapped (+1) (IntSet.fromList [1,2,3,4])--- fromList [2,3,4,5]-isetmapped :: Setter' IntSet Int-isetmapped = setter IntSet.map-{-# INLINE isetmapped #-}---- | TODO: Document+-- @+-- exmapped :: Exception e => Setter s s SomeException e+-- @ ---foldmapped :: Foldable f => Monoid m => Setter (f a) m a m-foldmapped = setter foldMap-{-# INLINE foldmapped #-}+exmapped :: Exception e1 => Exception e2 => Setter s s e1 e2+exmapped = setter Ex.mapException+{-# INLINE exmapped #-} --- | This 'setter' can be used to modify all of the values in an 'Applicative'.+-- | 'Setter' on each value of an applicative. -- -- @ -- 'liftA' ≡ 'setter' 'liftedA'@@ -424,36 +301,43 @@ liftedA = setter liftA {-# INLINE liftedA #-} --- | TODO: Document+-- | 'Setter' on each value of a monad. -- liftedM :: Monad m => Setter (m a) (m b) a b liftedM = setter liftM {-# INLINE liftedM #-} --- | Modify the local environment of a 'Reader'. +-- | 'Setter' on the local environment of a 'Reader'.  -- -- Use to lift reader actions into a larger environment: ----- >>> runReader ( ask & locally ..~ fst ) (1,2)+-- >>> runReader (ask & forwarded ..~ fst) (1,2) -- 1 ---locally :: Setter (ReaderT r2 m a) (ReaderT r1 m a) r1 r2-locally = setter withReaderT-{-# INLINE locally #-}+forwarded :: Setter (ReaderT r2 m a) (ReaderT r1 m a) r1 r2+forwarded = setter withReaderT+{-# INLINE forwarded #-}  -- | TODO: Document ---zipped :: Setter (u -> v -> a) (u -> v -> b) a b-zipped = setter ((.)(.)(.))-{-# INLINE zipped #-}+censored :: Writer.MonadWriter w m => Setter' (m a) w+censored = setter Writer.censor+{-# INLINE censored #-} --- | Apply a function only when the given condition holds.+-- | 'Setter' on the  ----- See also 'Data.Profunctor.Optic.Affine.predicated' & 'Data.Profunctor.Optic.Prism.filtered'.+seeked :: ComonadStore a w => Setter' (w s) a+seeked = setter seeks+{-# INLINE seeked #-}++-- | 'Setter' on the codomain of a zipping function. ---cond :: (a -> Bool) -> Setter' a a-cond p = setter $ \f a -> if p a then f a else a-{-# INLINE cond #-}+-- >>> ((,) & zipped ..~ swap) 1 2+-- (2,1)+--+zipped :: Setter (u -> v -> a) (u -> v -> b) a b+zipped = setter ((.)(.)(.))+{-# INLINE zipped #-}  -- | TODO: Document --@@ -461,210 +345,106 @@ modded p = setter $ \mods f a -> if p a then mods (f a) else f a {-# INLINE modded #-} --- | TODO: Document----reviewed :: Setter (b -> t) (((s -> a) -> b) -> t) s a-reviewed = setter $ \sa bt sab -> bt (sab sa)-{-# INLINE reviewed #-}---- | TODO: Document----composed :: Setter (s -> a) ((a -> b) -> s -> t) b t-composed = setter between-{-# INLINE composed #-}---- | 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"+-- | Apply a function only when the given condition holds. ----- @--- exmapped :: Exception e => Setter s s SomeException e--- @+-- See also 'Data.Profunctor.Optic.Affine.predicated' & 'Data.Profunctor.Optic.Prism.filtered'. ---exmapped :: Exception e1 => Exception e2 => Setter s s e1 e2-exmapped = setter Ex.mapException-{-# INLINE exmapped #-}+cond :: (a -> Bool) -> Setter' a a+cond p = setter $ \f a -> if p a then f a else a+{-# INLINE cond #-}  --------------------------------------------------------------------- -- Operators --------------------------------------------------------------------- -infixr 4 .~, ..~, %~, %%~, /~, //~, #~, ##~, ?~, <>~, ><~---- | Run a profunctor arrow command and set the optic targets to the result.------ Similar to 'assign', except that the type of the object being modified can change.------ >>> getVal1 = Right 3--- >>> getVal2 = Right False--- >>> action = assignA t21 (Kleisli (const getVal1)) >>> assignA t22 (Kleisli (const getVal2))--- >>> runKleisli action ((), ())--- Right (3,False)------ @--- 'assignA' :: 'Category' p => 'Iso' s t a b       -> 'Lenslike' p s t s b--- 'assignA' :: 'Category' p => 'Lens' s t a b      -> 'Lenslike' p s t s b--- 'assignA' :: 'Category' p => 'Grate' s t a b     -> 'Lenslike' p s t s b--- 'assignA' :: 'Category' p => 'Setter' s t a b    -> 'Lenslike' p s t s b--- 'assignA' :: 'Category' p => 'Traversal' s t a b -> 'Lenslike' p s t s b--- @----assignA :: Category p => Strong p => ASetter s t a b -> Optic p s t s b -assignA o p = arr (flip $ set o) &&& p >>> arr (uncurry id)-{-# INLINE assignA #-}+infixr 4 <>~, ><~ --- | Set all referenced fields to the given value.+-- | Prefix variant of '.~'. -- -- @ 'set' l y ('set' l x a) ≡ 'set' l y a @ ---set :: ASetter s t a b -> b -> s -> t-set o b = over o (const b)+set :: Optic (->) s t a b -> b -> s -> t+set = (.~) {-# INLINE set #-} --- | Set with index. Equivalent to 'ixover' with the current value ignored.+-- | Prefix alias of '%~'. ----- When you do not need access to the index, then 'set' is more liberal in what it can accept.+-- Equivalent to 'iover' with the current value ignored. -- -- @--- 'set' o ≡ 'ixset' o '.' 'const'+-- 'set' o ≡ 'iset' o '.' 'const' -- @ ----- >>> ixset (ixat 2) (2-) [1,2,3 :: Int]+-- >>> iset (iat 2) (2-) [1,2,3 :: Int] -- [1,2,0] ----- >>> ixset (ixat 5) (const 0) [1,2,3 :: Int]+-- >>> iset (iat 5) (const 0) [1,2,3 :: Int] -- [1,2,3] ---ixset :: Monoid i => AIxsetter i s t a b -> (i -> b) -> s -> t-ixset o = ixover o . (const .)-{-# INLINE ixset #-}---- | Set all referenced fields to the given value.------ @--- 'reset' ≡ 'set' '.' 're'--- @--- -reset :: AResetter s t a b -> b -> s -> t-reset o b = under o (const b)-{-# INLINE reset #-}+iset :: Monoid i => AIxsetter i s t a b -> (i -> b) -> s -> t+iset o = iover o . (const .)+{-# INLINE iset #-} --- | Dual set with index. Equivalent to 'cxover' with the current value ignored.------ >>> cxset (catchOn 42) show $ Just "foo"--- Just "0"------ >>> cxset (catchOn 42) show Nothing--- Nothing------ >>> cxset (catchOn 0) show Nothing--- Just "caught"+-- | Prefix alias of '#~'. ---cxset :: Monoid k => ACxsetter k s t a b -> (k -> b) -> s -> t -cxset o kb = cxover o $ flip (const kb)-{-# INLINE cxset #-}---- | TODO: Document+-- Equivalent to 'kover' with the current value ignored. ---(.~) :: ASetter s t a b -> b -> s -> t-(.~) = set-{-# INLINE (.~) #-}+kset :: Monoid k => ACxsetter k s t a b -> (k -> b) -> s -> t +kset o kb = kover o $ flip (const kb)+{-# INLINE kset #-} --- | TODO: Document------ >>> Nothing & just ..~ (+1)--- Nothing+-- | Prefix alias of '..~'. ---(..~) :: ASetter s t a b -> (a -> b) -> s -> t-(..~) = over-{-# INLINE (..~) #-}---- | An infix variant of 'ixset'. Dual to '#~'.+-- @+-- 'over' o 'id' ≡ 'id' +-- 'over' o f '.' 'over' o g ≡ 'over' o (f '.' g)+-- 'over' '.' 'setter' ≡ 'id'+-- 'over' '.' 'resetter' ≡ 'id'+-- @ ---(%~) :: Monoid i => AIxsetter i s t a b -> (i -> b) -> s -> t-(%~) = ixset-{-# INLINE (%~) #-}---- | An infix variant of 'ixover'. Dual to '##~'.+-- >>> over fmapped (+1) (Just 1)+-- Just 2 ---(%%~) :: Monoid i => AIxsetter i s t a b -> (i -> a -> b) -> s -> t-(%%~) = ixover-{-# INLINE (%%~) #-}---- | An infix variant of 'reset'. Dual to '.~'.+-- >>> over fmapped (*10) [1,2,3]+-- [10,20,30] ---(/~) :: AResetter s t a b -> b -> s -> t-(/~) = reset-{-# INLINE (/~) #-}---- | An infix variant of 'under'. Dual to '..~'.+-- >>> over first' (+1) (1,2)+-- (2,2) ---(//~) :: AResetter s t a b -> (a -> b) -> s -> t-(//~) = under-{-# INLINE (//~) #-}---- | An infix variant of 'cxset'. Dual to '%~'.+-- >>> over first' show (10,20)+-- ("10",20) ---(#~) :: Monoid k => ACxsetter k s t a b -> (k -> b) -> s -> t -(#~) = cxset-{-# INLINE (#~) #-}+over :: Optic (->) s t a b -> (a -> b) -> s -> t+over = id+{-# INLINE over #-} --- | An infix variant of 'cxover'. Dual to '%%~'.+-- | Prefix alias of '%%~'. ----- >>> Just "foo" & catchOn 0 ##~ (\k msg -> show k ++ ": " ++ msg)--- Just "0: foo"+-- >>> iover (iat 1) (+) [1,2,3 :: Int]+-- [1,3,3] ----- >>> Nothing & catchOn 0 ##~ (\k msg -> show k ++ ": " ++ msg)--- Just "caught"+-- >>> iover (iat 5) (+) [1,2,3 :: Int]+-- [1,2,3] ---(##~) :: Monoid k => ACxsetter k s t a b -> (k -> a -> b) -> s -> t -(##~) = cxover-{-# INLINE (##~) #-}+iover :: Monoid i => AIxsetter i s t a b -> (i -> a -> b) -> s -> t+iover = (%%~)+{-# INLINE iover #-} --- | Set the target of a settable optic to 'Just' a value.------ @--- l '?~' t ≡ 'set' l ('Just' t)--- @------ >>> Nothing & id ?~ 1--- Just 1------ '?~' can be used type-changily:------ >>> ('a', ('b', 'c')) & t22 . both ?~ 'x'--- ('a',(Just 'x',Just 'x'))------ @--- ('?~') :: 'Iso' s t a ('Maybe' b)       -> b -> s -> t--- ('?~') :: 'Lens' s t a ('Maybe' b)      -> b -> s -> t--- ('?~') :: 'Grate' s t a ('Maybe' b)     -> b -> s -> t--- ('?~') :: 'Setter' s t a ('Maybe' b)    -> b -> s -> t--- ('?~') :: 'Traversal' s t a ('Maybe' b) -> b -> s -> t--- @+-- | Prefix alias of '##~'. ---(?~) :: ASetter s t a (Maybe b) -> b -> s -> t-o ?~ b = set o (Just b)-{-# INLINE (?~) #-}+kover :: Monoid k => ACxsetter k s t a b -> (k -> a -> b) -> s -> t +kover = (##~)+{-# INLINE kover #-}  -- | Modify the target by adding another value. ----- >>> both <>~ False $ (False,True)--- (False,True)------ >>> both <>~ "!!!" $ ("hello","world")--- ("hello!!!","world!!!")+-- >>> both <>~ True $ (False,True)+-- (True,True) ----- @--- ('<>~') :: 'Semigroup' a => 'Iso' s t a a       -> a -> s -> t--- ('<>~') :: 'Semigroup' a => 'Lens' s t a a      -> a -> s -> t--- ('<>~') :: 'Semigroup' a => 'Grate' s t a a     -> a -> s -> t--- ('<>~') :: 'Semigroup' a => 'Setter' s t a a    -> a -> s -> t--- ('<>~') :: 'Semigroup' a => 'Traversal' s t a a -> a -> s -> t--- @+-- >>> both <>~ "!" $ ("bar","baz")+-- ("bar!","baz!") ---(<>~) :: Semigroup a => ASetter s t a a -> a -> s -> t+(<>~) :: Semigroup a => Optic (->) s t a a -> a -> s -> t l <>~ n = over l (<> n) {-# INLINE (<>~) #-} @@ -673,150 +453,111 @@ -- >>> both ><~ False $ (False,True) -- (False,False) ----- @--- ('><~') :: 'Semiring' a => 'Iso' s t a a       -> a -> s -> t--- ('><~') :: 'Semiring' a => 'Lens' s t a a      -> a -> s -> t--- ('><~') :: 'Semiring' a => 'Grate' s t a a     -> a -> s -> t--- ('><~') :: 'Semiring' a => 'Setter' s t a a    -> a -> s -> t--- ('><~') :: 'Semiring' a => 'Traversal' s t a a -> a -> s -> t--- @+-- >>> both ><~ ["!"] $ (["bar","baz"], [])+-- (["bar!","baz!"],[]) ---(><~) :: Semiring a => ASetter s t a a -> a -> s -> t+(><~) :: Semiring a => Optic (->) s t a a -> a -> s -> t l ><~ n = over l (>< n) {-# INLINE (><~) #-}  ------------------------------------------------------------------------ MonadState+-- Mtl --------------------------------------------------------------------- -infix 4 .=, ..=, %=, %%=, //=, #=, ##=, ?=, <>=, ><=---- | Replace the target(s) of a settable in a monadic state.+-- | Modify the value of a 'Reader' environment. -- -- @--- 'assigns' :: 'MonadState' s m => 'Iso'' s a       -> a -> m ()--- 'assigns' :: 'MonadState' s m => 'Lens'' s a      -> a -> m ()--- 'assigns' :: 'MonadState' s m => 'Grate'' s a     -> a -> m ()--- 'assigns' :: 'MonadState' s m => 'Prism'' s a     -> a -> m ()--- 'assigns' :: 'MonadState' s m => 'Setter'' s a    -> a -> m ()--- 'assigns' :: 'MonadState' s m => 'Traversal'' s a -> a -> m ()+-- 'locally' l 'id' a ≡ a+-- 'locally' l f '.' locally l g ≡ 'locally' l (f '.' g) -- @ ---assigns :: MonadState s m => ASetter s s a b -> b -> m ()+-- >>> (1,1) & locally first' (+1) (uncurry (+))+-- 3+--+-- >>> "," & locally (setter ($)) ("Hello" <>) (<> " world!")+-- "Hello, world!"+--+-- Compare 'forwarded'.+--+locally :: MonadReader s m => Optic (->) s s a b -> (a -> b) -> m r -> m r+locally o f = Reader.local $ o ..~ f+{-# INLINE locally #-}++-- | Write to a fragment of a larger 'Writer' format.+--+scribe :: MonadWriter w m => Monoid b => Optic (->) s w a b -> s -> m ()+scribe o s = Writer.tell $ set o mempty s+{-# INLINE scribe #-}++infix 4 .=, ..=, %=, %%=, #=, ##=, <>=, ><=++-- | Replace the target(s) of a settable in a monadic state.+--+assigns :: MonadState s m => Optic (->) s s a b -> b -> m () assigns o b = State.modify (set o b) {-# INLINE assigns #-}  -- | Map over the target(s) of a 'Setter' in a monadic state. ----- @--- 'modifies' :: 'MonadState' s m => 'Iso'' s a       -> (a -> a) -> m ()--- 'modifies' :: 'MonadState' s m => 'Lens'' s a      -> (a -> a) -> m ()--- 'modifies' :: 'MonadState' s m => 'Grate'' s a     -> (a -> a) -> m ()--- 'modifies' :: 'MonadState' s m => 'Prism'' s a     -> (a -> a) -> m ()--- 'modifies' :: 'MonadState' s m => 'Setter'' s a    -> (a -> a) -> m ()--- 'modifies' :: 'MonadState' s m => 'Traversal'' s a -> (a -> a) -> m ()--- @----modifies :: MonadState s m => ASetter s s a b -> (a -> b) -> m ()+modifies :: MonadState s m => Optic (->) s s a b -> (a -> b) -> m () modifies o f = State.modify (over o f) {-# INLINE modifies #-}  -- | Replace the target(s) of a settable in a monadic state. ----- This is an infix version of 'assigns'.+-- This is an infixversion of 'assigns'. ----- >>> execState (do t21 .= 1; t22 .= 2) (3,4)+-- >>> execState (do first' .= 1; second' .= 2) (3,4) -- (1,2) -- -- >>> execState (both .= 3) (1,2) -- (3,3) ----- @--- ('.=') :: 'MonadState' s m => 'Iso'' s a       -> a -> m ()--- ('.=') :: 'MonadState' s m => 'Lens'' s a      -> a -> m ()--- ('.=') :: 'MonadState' s m => 'Grate'' s a    -> a -> m ()--- ('.=') :: 'MonadState' s m => 'Prism'' s a    -> a -> m ()--- ('.=') :: 'MonadState' s m => 'Setter'' s a    -> a -> m ()--- ('.=') :: 'MonadState' s m => 'Traversal'' s a -> a -> m ()--- @----(.=) :: MonadState s m => ASetter s s a b -> b -> m ()+(.=) :: MonadState s m => Optic (->) s s a b -> b -> m () o .= b = State.modify (o .~ b) {-# INLINE (.=) #-} +-- | TODO: Document +--+(%=) :: MonadState s m => Monoid i => AIxsetter i s s a b -> (i -> b) -> m ()+o %= b = State.modify (o %~ b)+{-# INLINE (%=) #-}++-- | TODO: Document +--+(#=) :: MonadState s m => 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 infix version of 'modifies'.+-- This is an infixversion of 'modifies'. -- -- >>> execState (do just ..= (+1) ) Nothing -- Nothing ----- >>> execState (do t21 ..= (+1) ;t22 ..= (+2)) (1,2)+-- >>> execState (do first' ..= (+1) ;second' ..= (+2)) (1,2) -- (2,4) -- -- >>> execState (do both ..= (+1)) (1,2) -- (2,3) ----- @--- ('..=') :: 'MonadState' s m => 'Iso'' s a       -> (a -> a) -> m ()--- ('..=') :: 'MonadState' s m => 'Lens'' s a      -> (a -> a) -> m ()--- ('..=') :: 'MonadState' s m => 'Grate'' s a     -> (a -> a) -> m ()--- ('..=') :: 'MonadState' s m => 'Prism'' s a     -> (a -> a) -> m ()--- ('..=') :: 'MonadState' s m => 'Setter'' s a    -> (a -> a) -> m ()--- ('..=') :: 'MonadState' s m => 'Traversal'' s a -> (a -> a) -> m ()--- @----(..=) :: MonadState s m => ASetter s s a b -> (a -> b) -> m ()+(..=) :: MonadState s m => Optic (->) s s a b -> (a -> b) -> m () o ..= f = State.modify (o ..~ f) {-# INLINE (..=) #-}  -- | TODO: Document  ---(%=) :: MonadState s m => Monoid i => AIxsetter i s s a b -> (i -> b) -> m ()-o %= b = State.modify (o %~ b)---- | TODO: Document --- (%%=) :: MonadState s m => Monoid i => AIxsetter i s s a b -> (i -> a -> b) -> m ()  o %%= f = State.modify (o %%~ f) {-# INLINE (%%=) #-}  -- | TODO: Document  ---(//=) :: MonadState s m => AResetter s s a b -> (a -> b) -> m ()-o //= f = State.modify (o //~ f)-{-# INLINE (//=) #-}---- | TODO: Document ----(#=) :: MonadState s m => Monoid k => ACxsetter k s s a b -> (k -> b) -> m ()-o #= f = State.modify (o #~ f)-{-# INLINE (#=) #-}---- | TODO: Document --- (##=) :: MonadState s m => Monoid k => ACxsetter k s s a b -> (k -> a -> b) -> m ()  o ##= f = State.modify (o ##~ f) {-# INLINE (##=) #-} --- | Replace the target(s) of a settable optic with 'Just' a new value.------ >>> execState (do t21 ?= 1; t22 ?= 2) (Just 1, Nothing)--- (Just 1,Just 2)------ @--- ('?=') :: 'MonadState' s m => 'Iso'' s ('Maybe' a)       -> a -> m ()--- ('?=') :: 'MonadState' s m => 'Lens'' s ('Maybe' a)      -> a -> m ()--- ('?=') :: 'MonadState' s m => 'Grate'' s ('Maybe' a)     -> a -> m ()--- ('?=') :: 'MonadState' s m => 'Prism'' s ('Maybe' a)     -> a -> m ()--- ('?=') :: 'MonadState' s m => 'Setter'' s ('Maybe' a)    -> a -> m ()--- ('?=') :: 'MonadState' s m => 'Traversal'' s ('Maybe' a) -> a -> m ()--- @----(?=) :: MonadState s m => ASetter s s a (Maybe b) -> b -> m ()-o ?= b = State.modify (o ?~ b)-{-# INLINE (?=) #-}- -- | Modify the target(s) of a settable optic by adding a value. -- -- >>> execState (both <>= False) (False,True)@@ -825,16 +566,7 @@ -- >>> execState (both <>= "!!!") ("hello","world") -- ("hello!!!","world!!!") ----- @--- ('<>=') :: 'MonadState' s m => 'Semigroup' a => 'Iso'' s a -> a -> m ()--- ('<>=') :: 'MonadState' s m => 'Semigroup' a => 'Lens'' s a -> a -> m ()--- ('<>=') :: 'MonadState' s m => 'Semigroup' a => 'Grate'' s a -> a -> m ()--- ('<>=') :: 'MonadState' s m => 'Semigroup' a => 'Prism'' s a -> a -> m ()--- ('<>=') :: 'MonadState' s m => 'Semigroup' a => 'Setter'' s a -> a -> m ()--- ('<>=') :: 'MonadState' s m => 'Semigroup' a => 'Traversal'' s a -> a -> m ()--- @----(<>=) :: MonadState s m => Semigroup a => ASetter' s a -> a -> m ()+(<>=) :: MonadState s m => Semigroup a => Optic' (->) s a -> a -> m () o <>= a = State.modify (o <>~ a) {-# INLINE (<>=) #-} @@ -843,25 +575,6 @@ -- >>> execState (both ><= False) (False,True) -- (False,False) ----- @--- ('><=') :: 'MonadState' s m => 'Semiring' a => 'Iso'' s a -> a -> m ()--- ('><=') :: 'MonadState' s m => 'Semiring' a => 'Lens'' s a -> a -> m ()--- ('><=') :: 'MonadState' s m => 'Semiring' a => 'Grate'' s a -> a -> m ()--- ('><=') :: 'MonadState' s m => 'Semiring' a => 'Prism'' s a -> a -> m ()--- ('><=') :: 'MonadState' s m => 'Semiring' a => 'Setter'' s a -> a -> m ()--- ('><=') :: 'MonadState' s m => 'Semiring' a => 'Traversal'' s a -> a -> m ()--- @----(><=) :: MonadState s m => Semiring a => ASetter' s a -> a -> m ()+(><=) :: MonadState s m => Semiring a => Optic' (->) s a -> a -> m () o ><= a = State.modify (o ><~ a) {-# INLINE (><=) #-}---- @--- zoom :: Functor m => Lens' ta a -> StateT a m c -> StateT ta m c--- zoom :: (Monoid c, Applicative m) => Traversal' ta a -> StateT a m c -> StateT ta m c--- @-zoom :: Functor m => Optic' (Star (Compose m ((,) c))) ta a -> StateT a m c -> StateT ta m c-zoom o (StateT m) = StateT . out . o . into $ m- where-  into f = Star (Compose . f)-  out (Star f) = getCompose . f