diff --git a/profunctor-optics.cabal b/profunctor-optics.cabal --- a/profunctor-optics.cabal +++ b/profunctor-optics.cabal @@ -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 file for more information. + See the 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 diff --git a/src/Data/Connection/Optic/Float.hs b/src/Data/Connection/Optic/Float.hs --- a/src/Data/Connection/Optic/Float.hs +++ b/src/Data/Connection/Optic/Float.hs @@ -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 +-} diff --git a/src/Data/Either/Optic.hs b/src/Data/Either/Optic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Either/Optic.hs @@ -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' diff --git a/src/Data/Profunctor/Optic.hs b/src/Data/Profunctor/Optic.hs --- a/src/Data/Profunctor/Optic.hs +++ b/src/Data/Profunctor/Optic.hs @@ -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 diff --git a/src/Data/Profunctor/Optic/Affine.hs b/src/Data/Profunctor/Optic/Affine.hs new file mode 100644 --- /dev/null +++ b/src/Data/Profunctor/Optic/Affine.hs @@ -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 #-} diff --git a/src/Data/Profunctor/Optic/Carrier.hs b/src/Data/Profunctor/Optic/Carrier.hs new file mode 100644 --- /dev/null +++ b/src/Data/Profunctor/Optic/Carrier.hs @@ -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 diff --git a/src/Data/Profunctor/Optic/Cotraversal.hs b/src/Data/Profunctor/Optic/Cotraversal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Profunctor/Optic/Cotraversal.hs @@ -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 #-} diff --git a/src/Data/Profunctor/Optic/Fold.hs b/src/Data/Profunctor/Optic/Fold.hs --- a/src/Data/Profunctor/Optic/Fold.hs +++ b/src/Data/Profunctor/Optic/Fold.hs @@ -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) diff --git a/src/Data/Profunctor/Optic/Fold0.hs b/src/Data/Profunctor/Optic/Fold0.hs deleted file mode 100644 --- a/src/Data/Profunctor/Optic/Fold0.hs +++ /dev/null @@ -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 diff --git a/src/Data/Profunctor/Optic/Fold1.hs b/src/Data/Profunctor/Optic/Fold1.hs deleted file mode 100644 --- a/src/Data/Profunctor/Optic/Fold1.hs +++ /dev/null @@ -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) diff --git a/src/Data/Profunctor/Optic/Grate.hs b/src/Data/Profunctor/Optic/Grate.hs --- a/src/Data/Profunctor/Optic/Grate.hs +++ b/src/Data/Profunctor/Optic/Grate.hs @@ -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 #-} diff --git a/src/Data/Profunctor/Optic/Import.hs b/src/Data/Profunctor/Optic/Import.hs --- a/src/Data/Profunctor/Optic/Import.hs +++ b/src/Data/Profunctor/Optic/Import.hs @@ -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) diff --git a/src/Data/Profunctor/Optic/Index.hs b/src/Data/Profunctor/Optic/Index.hs --- a/src/Data/Profunctor/Optic/Index.hs +++ b/src/Data/Profunctor/Optic/Index.hs @@ -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 . -- -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 #-} diff --git a/src/Data/Profunctor/Optic/Iso.hs b/src/Data/Profunctor/Optic/Iso.hs --- a/src/Data/Profunctor/Optic/Iso.hs +++ b/src/Data/Profunctor/Optic/Iso.hs @@ -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) - diff --git a/src/Data/Profunctor/Optic/Lens.hs b/src/Data/Profunctor/Optic/Lens.hs --- a/src/Data/Profunctor/Optic/Lens.hs +++ b/src/Data/Profunctor/Optic/Lens.hs @@ -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) diff --git a/src/Data/Profunctor/Optic/Operator.hs b/src/Data/Profunctor/Optic/Operator.hs --- a/src/Data/Profunctor/Optic/Operator.hs +++ b/src/Data/Profunctor/Optic/Operator.hs @@ -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 (#~) #-} diff --git a/src/Data/Profunctor/Optic/Option.hs b/src/Data/Profunctor/Optic/Option.hs new file mode 100644 --- /dev/null +++ b/src/Data/Profunctor/Optic/Option.hs @@ -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 #-} diff --git a/src/Data/Profunctor/Optic/Prelude.hs b/src/Data/Profunctor/Optic/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Data/Profunctor/Optic/Prelude.hs @@ -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' #-} diff --git a/src/Data/Profunctor/Optic/Prism.hs b/src/Data/Profunctor/Optic/Prism.hs --- a/src/Data/Profunctor/Optic/Prism.hs +++ b/src/Data/Profunctor/Optic/Prism.hs @@ -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) diff --git a/src/Data/Profunctor/Optic/Property.hs b/src/Data/Profunctor/Optic/Property.hs --- a/src/Data/Profunctor/Optic/Property.hs +++ b/src/Data/Profunctor/Optic/Property.hs @@ -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 -- | -- diff --git a/src/Data/Profunctor/Optic/Setter.hs b/src/Data/Profunctor/Optic/Setter.hs --- a/src/Data/Profunctor/Optic/Setter.hs +++ b/src/Data/Profunctor/Optic/Setter.hs @@ -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 . -- -- /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/ . --- -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 diff --git a/src/Data/Profunctor/Optic/Traversal.hs b/src/Data/Profunctor/Optic/Traversal.hs --- a/src/Data/Profunctor/Optic/Traversal.hs +++ b/src/Data/Profunctor/Optic/Traversal.hs @@ -11,37 +11,57 @@ , Traversal' , Ixtraversal , Ixtraversal' - , ATraversal - , ATraversal' , traversing - , ixtraversing + , itraversing , traversalVl - , ixtraversalVl + , itraversalVl , noix , ix - -- * Primitive operators - , withTraversal + -- * Traversal1 + , Traversal1 + , Traversal1' + , Ixtraversal1 + , Ixtraversal1' + , traversing1 + , traversal1Vl + , itraversal1Vl -- * Optics , traversed + , traversed1 + , itraversedRep , both + , both1 , duplicated + , beside , bitraversed + , bitraversed1 + , repeated + , iterated + , cycled -- * Operators + , withTraversal + , withTraversal1 + -- * Operators + , (*~) + , (**~) , sequences - -- * Carriers - , Star(..) - , Costar(..) - -- * Classes - , Representable(..) - , Corepresentable(..) + , sequences1 ) where +import Control.Category +import Control.Arrow import Data.Bitraversable +import Data.List.NonEmpty as NonEmpty +import Data.Profunctor.Optic.Carrier import Data.Profunctor.Optic.Lens -import Data.Profunctor.Optic.Import -import Data.Profunctor.Optic.Type +import Data.Profunctor.Optic.Import hiding (id,(.)) +import Data.Profunctor.Optic.Types +import Data.Profunctor.Optic.Operator +import Data.Semigroup.Bitraversable import Data.Semiring import Control.Monad.Trans.State +import Prelude (Foldable(..), reverse) +import qualified Data.Functor.Rep as F -- $setup -- >>> :set -XNoOverloadedStrings @@ -56,24 +76,20 @@ -- >>> import Data.Functor.Identity -- >>> import Data.List.Index -- >>> :load Data.Profunctor.Optic --- >>> let catchOn :: Int -> Cxprism' Int (Maybe String) String ; catchOn n = cxjust $ \k -> if k==n then Just "caught" else Nothing --- >>> let ixtraversed :: Ixtraversal Int [a] [b] a b ; ixtraversed = ixtraversalVl itraverse +-- >>> 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 --------------------------------------------------------------------- -- 'Traversal' & 'Ixtraversal' --------------------------------------------------------------------- -type ATraversal f s t a b = Applicative f => ARepn f s t a b - -type ATraversal' f s a = ATraversal f s s a a - -- | Obtain a 'Traversal' by lifting a lens getter and setter into a 'Traversable' functor. -- -- @ -- 'withLens' o 'traversing' ≡ 'traversed' . o -- @ -- --- Compare 'Data.Profunctor.Optic.Fold.folding'. +-- Compare 'Data.Profunctor.Optic.Moore.folding'. -- -- /Caution/: In order for the generated optic to be well-defined, -- you must ensure that the input functions constitute a legal lens: @@ -98,7 +114,7 @@ -- | Obtain a 'Ixtraversal' by lifting an indexed lens getter and setter into a 'Traversable' functor. -- -- @ --- 'withIxlens' o 'ixtraversing' ≡ 'ixtraversed' . o +-- 'withIxlens' o 'itraversing' ≡ 'itraversed' . o -- @ -- -- /Caution/: In order for the generated optic to be well-defined, @@ -113,8 +129,8 @@ -- -- See 'Data.Profunctor.Optic.Property'. -- -ixtraversing :: Monoid i => Traversable f => (s -> (i , a)) -> (s -> b -> t) -> Ixtraversal i (f s) (f t) a b -ixtraversing sia sbt = repn (\iab -> traverse (curry iab mempty) . snd) . ixlens sia sbt +itraversing :: Monoid i => Traversable f => (s -> (i , a)) -> (s -> b -> t) -> Ixtraversal i (f s) (f t) a b +itraversing sia sbt = repn (\iab -> traverse (curry iab mempty) . snd) . ilens sia sbt -- | Obtain a profunctor 'Traversal' from a Van Laarhoven 'Traversal'. -- @@ -141,71 +157,101 @@ -- -- See 'Data.Profunctor.Optic.Property'. -- -ixtraversalVl :: (forall f. Applicative f => (i -> a -> f b) -> s -> f t) -> Ixtraversal i s t a b -ixtraversalVl f = traversalVl $ \iab -> f (curry iab) . snd +itraversalVl :: (forall f. Applicative f => (i -> a -> f b) -> s -> f t) -> Ixtraversal i s t a b +itraversalVl f = traversalVl $ \iab -> f (curry iab) . snd -- | Lift a VL traversal into an indexed profunctor traversal that ignores its input. -- -- Useful as the first optic in a chain when no indexed equivalent is at hand. -- --- >>> ixlists (noix traversed . ixtraversed) ["foo", "bar"] +-- >>> ilists (noix traversed . itraversed) ["foo", "bar"] -- [(0,'f'),(1,'o'),(2,'o'),(0,'b'),(1,'a'),(2,'r')] -- --- >>> ixlists (ixtraversed . noix traversed) ["foo", "bar"] +-- >>> ilists (itraversed . noix traversed) ["foo", "bar"] -- [(0,'f'),(0,'o'),(0,'o'),(0,'b'),(0,'a'),(0,'r')] -- noix :: Monoid i => Traversal s t a b -> Ixtraversal i s t a b -noix o = ixtraversalVl $ \iab s -> flip runStar s . o . Star $ iab mempty +noix o = itraversalVl $ \iab s -> flip runStar s . o . Star $ iab mempty -- | Index a traversal with a 'Data.Semiring'. -- --- >>> ixlists (ix traversed . ix traversed) ["foo", "bar"] +-- >>> ilists (ix traversed . ix traversed) ["foo", "bar"] -- [((),'f'),((),'o'),((),'o'),((),'b'),((),'a'),((),'r')] -- --- >>> ixlists (ix @Int traversed . ix traversed) ["foo", "bar"] +-- >>> ilists (ix @Int traversed . ix traversed) ["foo", "bar"] -- [(0,'f'),(1,'o'),(2,'o'),(0,'b'),(1,'a'),(2,'r')] -- --- >>> ixlists (ix @[()] traversed . ix traversed) ["foo", "bar"] +-- >>> ilists (ix @[()] traversed . ix traversed) ["foo", "bar"] -- [([],'f'),([()],'o'),([(),()],'o'),([],'b'),([()],'a'),([(),()],'r')] -- --- >>> ixlists (ix @[()] traversed % ix traversed) ["foo", "bar"] +-- >>> ilists (ix @[()] traversed % ix traversed) ["foo", "bar"] -- [([],'f'),([()],'o'),([(),()],'o'),([()],'b'),([(),()],'a'),([(),(),()],'r')] -- ix :: Monoid i => Semiring i => Traversal s t a b -> Ixtraversal i s t a b -ix o = ixtraversalVl $ \f s -> +ix o = itraversalVl $ \f s -> flip evalState mempty . getCompose . flip runStar s . o . Star $ \a -> Compose $ (f <$> get <*> pure a) <* modify (<> sunit) --------------------------------------------------------------------- --- Primitive operators +-- 'Traversal1' --------------------------------------------------------------------- --- | +-- | Obtain a 'Traversal' by lifting a lens getter and setter into a 'Traversable' functor. -- --- The traversal laws can be stated in terms of 'withTraversal': --- --- Identity: --- -- @ --- withTraversal t (Identity . f) ≡ Identity (fmap f) --- @ --- --- Composition: --- --- @ --- Compose . fmap (withTraversal t f) . withTraversal t g ≡ withTraversal t (Compose . fmap f . g) +-- 'withLens' o 'traversing' ≡ 'traversed' . o -- @ -- --- @ --- withTraversal :: Functor f => Lens s t a b -> (a -> f b) -> s -> f t --- withTraversal :: Applicative f => Traversal s t a b -> (a -> f b) -> s -> f t --- @ +-- /Caution/: In order for the generated optic to be well-defined, +-- you must ensure that the input functions constitute a legal lens: -- -withTraversal :: Applicative f => ATraversal f s t a b -> (a -> f b) -> s -> f t -withTraversal o = runStar #. o .# Star +-- * @sa (sbt s a) ≡ a@ +-- +-- * @sbt s (sa s) ≡ s@ +-- +-- * @sbt (sbt s a1) a2 ≡ sbt s a2@ +-- +-- See 'Data.Profunctor.Optic.Property'. +-- +-- The resulting optic can detect copies of the lens stucture inside +-- any 'Traversable' container. For example: +-- +-- >>> lists (traversing snd $ \(s,_) b -> (s,b)) [(0,'f'),(1,'o'),(2,'o'),(3,'b'),(4,'a'),(5,'r')] +-- "foobar" +-- +-- Compare 'Data.Profunctor.Optic.Fold.folding'. +-- +traversing1 :: Traversable1 f => (s -> a) -> (s -> b -> t) -> Traversal1 (f s) (f t) a b +traversing1 sa sbt = repn traverse1 . lens sa sbt +-- | Obtain a profunctor 'Traversal1' from a Van Laarhoven 'Traversal1'. +-- +-- /Caution/: In order for the generated family to be well-defined, +-- you must ensure that the traversal1 law holds for the input function: +-- +-- * @fmap (abst f) . abst g ≡ getCompose . abst (Compose . fmap f . g)@ +-- +-- See 'Data.Profunctor.Optic.Property'. +-- +traversal1Vl :: (forall f. Apply f => (a -> f b) -> s -> f t) -> Traversal1 s t a b +traversal1Vl abst = tabulate . abst . sieve + +-- | Lift an indexed VL traversal into an indexed profunctor traversal. +-- +-- /Caution/: In order for the generated optic to be well-defined, +-- you must ensure that the input satisfies the following properties: +-- +-- * @iabst (const pure) ≡ pure@ +-- +-- * @fmap (iabst $ const f) . (iabst $ const g) ≡ getCompose . iabst (const $ Compose . fmap f . g)@ +-- +-- See 'Data.Profunctor.Optic.Property'. +-- +itraversal1Vl :: (forall f. Apply f => (i -> a -> f b) -> s -> f t) -> Ixtraversal1 i s t a b +itraversal1Vl f = traversal1Vl $ \iab -> f (curry iab) . snd + --------------------------------------------------------------------- --- Common 'Traversal0's, 'Traversal's, 'Traversal1's, & 'Cotraversal1's +-- Optics --------------------------------------------------------------------- -- | TODO: Document @@ -213,22 +259,48 @@ traversed :: Traversable f => Traversal (f a) (f b) a b traversed = traversalVl traverse +-- | Obtain a 'Traversal1' from a 'Traversable1' functor. +-- +traversed1 :: Traversable1 t => Traversal1 (t a) (t b) a b +traversed1 = traversal1Vl traverse1 +{-# INLINE traversed1 #-} + -- | TODO: Document -- +itraversedRep :: F.Representable f => Traversable f => Ixtraversal (F.Rep f) (f a) (f b) a b +itraversedRep = itraversalVl F.itraverseRep + +-- | TODO: Document +-- -- >>> withTraversal both (pure . length) ("hello","world") -- (5,5) -- both :: Traversal (a , a) (b , b) a b both p = p **** p --- | Duplicate the results of any 'Fold'. +-- | TODO: Document -- +-- >>> withTraversal1 both1 (pure . NE.length) ('h' :| "ello", 'w' :| "orld") +-- (5,5) +-- +both1 :: Traversal1 (a , a) (b , b) a b +both1 p = tabulate $ \s -> liftF2 ($) (flip sieve s $ dimap fst (,) p) (flip sieve s $ lmap snd p) +{-# INLINE both1 #-} + +-- | Duplicate the results of any 'Moore'. +-- -- >>> lists (both . duplicated) ("hello","world") -- ["hello","hello","world","world"] -- duplicated :: Traversal a b a b duplicated p = pappend p p +-- | TODO: Document +-- +beside :: Bitraversable r => Traversal s1 t1 a b -> Traversal s2 t2 a b -> Traversal (r s1 s2) (r t1 t2) a b +beside x y p = tabulate go where go rss = bitraverse (sieve $ x p) (sieve $ y p) rss + --go :: r s s' -> Rep p (r t t') + -- | Traverse both parts of a 'Bitraversable' container with matching types. -- -- >>> withTraversal bitraversed (pure . length) (Right "hello") @@ -249,7 +321,96 @@ bitraversed = repn $ \f -> bitraverse f f {-# INLINE bitraversed #-} +-- | Traverse both parts of a 'Bitraversable1' container with matching types. +-- +-- >>> withTraversal1 bitraversed1 (pure . NE.length) ('h' :| "ello", 'w' :| "orld") +-- (5,5) +-- +bitraversed1 :: Bitraversable1 r => Traversal1 (r a a) (r b b) a b +bitraversed1 = repn $ \f -> bitraverse1 f f +{-# INLINE bitraversed1 #-} + +-- | Obtain a 'Traversal1'' by repeating the input forever. +-- +-- @ +-- 'repeat' ≡ 'lists' 'repeated' +-- @ +-- +-- >>> take 5 $ 5 ^.. repeated +-- [5,5,5,5,5] +-- +-- @ +-- repeated :: Fold1 a a +-- @ +-- +repeated :: Traversal1' a a +repeated = repn $ \g a -> go g a where go g a = g a .> go g a +{-# INLINE repeated #-} + +-- | @x '^.' 'iterated' f@ returns an infinite 'Traversal1'' of repeated applications of @f@ to @x@. +-- +-- @ +-- 'lists' ('iterated' f) a ≡ 'iterate' f a +-- @ +-- +-- >>> take 3 $ (1 :: Int) ^.. iterated (+1) +-- [1,2,3] +-- +-- @ +-- iterated :: (a -> a) -> 'Fold1' a a +-- @ +-- +iterated :: (a -> a) -> Traversal1' a a +iterated f = repn $ \g a0 -> go g a0 where go g a = g a .> go g (f a) +{-# INLINE iterated #-} + +-- | Transform a 'Traversal1'' into a 'Traversal1'' that loops over its elements repeatedly. +-- +-- >>> take 7 $ (1 :| [2,3]) ^.. cycled traversed1 +-- [1,2,3,1,2,3,1] +-- +-- @ +-- cycled :: 'Fold1' s a -> 'Fold1' s a +-- @ +-- +cycled :: Apply f => ATraversal1' f s a -> ATraversal1' f s a +cycled o = repn $ \g a -> go g a where go g a = (withTraversal1 o g) a .> go g a +{-# INLINE cycled #-} + --------------------------------------------------------------------- +-- Primitive operators +--------------------------------------------------------------------- + +-- | +-- +-- The traversal laws can be stated in terms of 'withTraversal': +-- +-- * @withTraversal t (Identity . f) ≡ Identity (fmap f)@ +-- +-- * @Compose . fmap (withTraversal t f) . withTraversal t g ≡ withTraversal t (Compose . fmap f . g)@ +-- +withTraversal :: Applicative f => ATraversal f s t a b -> (a -> f b) -> s -> f t +withTraversal = withStar +{-# INLINE withTraversal #-} + +-- | +-- +-- The traversal laws can be stated in terms of 'withTraversal1': +-- +-- * @withTraversal1 t (Identity . f) ≡ Identity (fmap f)@ +-- +-- * @Compose . fmap (withTraversal1 t f) . withTraversal1 t g ≡ withTraversal1 t (Compose . fmap f . g)@ +-- +-- @ +-- withTraversal1 :: Functor f => Lens s t a b -> (a -> f b) -> s -> f t +-- withTraversal1 :: Apply f => Traversal1 s t a b -> (a -> f b) -> s -> f t +-- @ +-- +withTraversal1 :: Apply f => ATraversal1 f s t a b -> (a -> f b) -> s -> f t +withTraversal1 = withStar +{-# INLINE withTraversal1 #-} + +--------------------------------------------------------------------- -- Operators --------------------------------------------------------------------- @@ -258,3 +419,9 @@ sequences :: Applicative f => ATraversal f s t (f a) a -> s -> f t sequences o = withTraversal o id {-# INLINE sequences #-} + +-- | TODO: Document +-- +sequences1 :: Apply f => ATraversal1 f s t (f a) a -> s -> f t +sequences1 o = withTraversal1 o id +{-# INLINE sequences1 #-} diff --git a/src/Data/Profunctor/Optic/Traversal0.hs b/src/Data/Profunctor/Optic/Traversal0.hs deleted file mode 100644 --- a/src/Data/Profunctor/Optic/Traversal0.hs +++ /dev/null @@ -1,266 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -module Data.Profunctor.Optic.Traversal0 ( - -- * Traversal0 & Ixtraversal0 - Traversal0 - , Traversal0' - , Ixtraversal0 - , Ixtraversal0' - , ATraversal0 - , ATraversal0' - , traversal0 - , traversal0' - , ixtraversal0 - , ixtraversal0' - , traversal0Vl - , ixtraversal0Vl - -- * Carriers - , Traversal0Rep(..) - -- * Primitive operators - , withTraversal0 - -- * Optics - , nulled - , inserted - , selected - , predicated - -- * Operators - , is - , isnt - , matches -) where - -import Data.Bifunctor (first, second) -import Data.Bitraversable -import Data.List.Index -import Data.Map as Map -import Data.Semigroup.Bitraversable -import Data.Profunctor.Optic.Lens hiding (first, second, unit) -import Data.Profunctor.Optic.Import -import Data.Profunctor.Optic.Prism (prism) -import Data.Profunctor.Optic.Grate -import Data.Profunctor.Optic.Type -import Data.Semiring -import Control.Monad.Trans.State -import Data.Profunctor.Optic.Iso -import qualified Data.Bifunctor as B - --- $setup --- >>> :set -XNoOverloadedStrings --- >>> :set -XFlexibleContexts --- >>> :set -XTypeApplications --- >>> :set -XTupleSections --- >>> :set -XRankNTypes --- >>> import Data.Maybe --- >>> import Data.List.NonEmpty (NonEmpty(..)) --- >>> import qualified Data.List.NonEmpty as NE --- >>> import Data.Functor.Identity --- >>> import Data.List.Index --- >>> :load Data.Profunctor.Optic --- >>> let catchOn :: Int -> Cxprism' Int (Maybe String) String ; catchOn n = cxjust $ \k -> if k==n then Just "caught" else Nothing --- >>> let ixtraversed :: Ixtraversal Int [a] [b] a b ; ixtraversed = ixtraversalVl itraverse - ---------------------------------------------------------------------- --- 'Traversal0' & 'Ixtraversal0' ---------------------------------------------------------------------- - -type ATraversal0 s t a b = Optic (Traversal0Rep a b) s t a b - -type ATraversal0' s a = ATraversal0 s s a a - --- | Create a 'Traversal0' from a constructor and a matcheser. --- --- /Caution/: In order for the 'Traversal0' to be well-defined, --- you must ensure that the input functions satisfy the following --- properties: --- --- * @sta (sbt a s) ≡ either (Left . const a) Right (sta s)@ --- --- * @either id (sbt s) (sta s) ≡ s@ --- --- * @sbt (sbt s a1) a2 ≡ sbt s a2@ --- --- More generally, a profunctor optic must be monoidal as a natural --- transformation: --- --- * @o id ≡ id@ --- --- * @o ('Data.Profunctor.Composition.Procompose' p q) ≡ 'Data.Profunctor.Composition.Procompose' (o p) (o q)@ --- --- See 'Data.Profunctor.Optic.Property'. --- -traversal0 :: (s -> t + a) -> (s -> b -> t) -> Traversal0 s t a b -traversal0 sta sbt = dimap (\s -> (s,) <$> sta s) (id ||| uncurry sbt) . right' . second' - --- | Obtain a 'Traversal0'' from a constructor and a matcheser function. --- -traversal0' :: (s -> Maybe a) -> (s -> a -> s) -> Traversal0' s a -traversal0' sa sas = flip traversal0 sas $ \s -> maybe (Left s) Right (sa s) - --- | TODO: Document --- -ixtraversal0 :: (s -> t + (i , a)) -> (s -> b -> t) -> Ixtraversal0 i s t a b -ixtraversal0 stia sbt = ixtraversal0Vl $ \point f s -> either point (fmap (sbt s) . uncurry f) (stia s) - --- | TODO: Document --- -ixtraversal0' :: (s -> Maybe (i , a)) -> (s -> a -> s) -> Ixtraversal0' i s a -ixtraversal0' sia = ixtraversal0 $ \s -> maybe (Left s) Right (sia s) - --- | Transform a Van Laarhoven 'Traversal0' into a profunctor 'Traversal0'. --- -traversal0Vl :: (forall f. Functor f => (forall c. c -> f c) -> (a -> f b) -> s -> f t) -> Traversal0 s t a b -traversal0Vl f = dimap (\s -> (s,) <$> eswap (sat s)) (id ||| uncurry sbt) . right' . second' - where - sat = f Right Left - sbt s b = runIdentity $ f Identity (\_ -> Identity b) s - --- | Transform an indexed Van Laarhoven 'Traversal0' into an indexed profunctor 'Traversal0'. --- -ixtraversal0Vl :: (forall f. Functor f => (forall c. c -> f c) -> (i -> a -> f b) -> s -> f t) -> Ixtraversal0 i s t a b -ixtraversal0Vl f = traversal0Vl $ \cc iab -> f cc (curry iab) . snd - ---------------------------------------------------------------------- --- Primitive operators ---------------------------------------------------------------------- - --- | TODO: Document --- -withTraversal0 :: ATraversal0 s t a b -> ((s -> t + a) -> (s -> b -> t) -> r) -> r -withTraversal0 o k = case o (Traversal0Rep Right $ const id) of Traversal0Rep x y -> k x y - ---------------------------------------------------------------------- --- Common 'Traversal0's, 'Traversal's, 'Traversal1's, & 'Cotraversal1's ---------------------------------------------------------------------- - --- | TODO: Document --- -nulled :: Traversal0' s a -nulled = traversal0 Left const -{-# INLINE nulled #-} - --- | Obtain a 'Ixtraversal0'' from a pair of lookup and insert functions. --- --- @ --- inserted (\i s -> flip 'Data.List.Index.ifind' s $ \n _ -> n == i) (\i a s -> 'Data.List.Index.modifyAt' i (const a) s) :: Int -> Ixtraversal0' Int [a] a --- inserted 'Data.Map.lookupGT' 'Data.Map.insert' :: Ord i => i -> Ixtraversal0' i (Map i a) a --- inserted 'Data.IntMap.lookupGT' 'Data.IntMap.insert' :: Int -> Ixtraversal0' Int (IntMap a) a --- @ --- -inserted :: (i -> s -> Maybe (i, a)) -> (i -> a -> s -> s) -> i -> Ixtraversal0' i s a -inserted isia iasa i = ixtraversal0Vl $ \point f s -> - case isia i s of - Nothing -> point s - Just (i', a) -> f i' a <&> \a -> iasa i' a s -{-# INLINE inserted #-} - --- | TODO: Document --- --- See also 'Data.Profunctor.Optic.Prism.keyed'. --- --- >>> preview (selected even) (2, "hi") --- Just "hi" --- >>> preview (selected even) (3, "hi") --- Nothing --- -selected :: (a -> Bool) -> Traversal0' (a, b) b -selected p = traversal0 (\kv@(k,v) -> branch p kv v k) (\kv@(k,_) v' -> if p k then (k,v') else kv) -{-# INLINE selected #-} - --- | Filter result(s) that don't satisfy a predicate. --- --- /Caution/: While this is a valid 'Traversal0', it is only a valid 'Traversal' --- if the predicate always evaluates to 'True' on the targets of the 'Traversal'. --- --- @ --- 'predicated' p ≡ 'traversal0Vl' $ \point f a -> if p a then f a else point a --- @ --- --- >>> [1..10] ^.. folded . predicated even --- [2,4,6,8,10] --- --- See also 'Data.Profunctor.Optic.Prism.filtered'. --- -predicated :: (a -> Bool) -> Traversal0' a a -predicated p = traversal0 (branch' p) (flip const) -{-# INLINE predicated #-} - ---------------------------------------------------------------------- --- Operators ---------------------------------------------------------------------- - --- | Check whether the optic is matchesed. --- --- >>> is just Nothing --- False --- -is :: ATraversal0 s t a b -> s -> Bool -is o = either (const False) (const True) . matches o -{-# INLINE is #-} - --- | Check whether the optic isn't matchesed. --- --- >>> isnt just Nothing --- True --- -isnt :: ATraversal0 s t a b -> s -> Bool -isnt o = either (const True) (const False) . matches o -{-# INLINE isnt #-} - --- | Test whether the optic matches or not. --- --- >>> matches just (Just 2) --- Right 2 --- --- >>> matches just (Nothing :: Maybe Int) :: Either (Maybe Bool) Int --- Left Nothing --- -matches :: ATraversal0 s t a b -> s -> t + a -matches o = withTraversal0 o $ \sta _ -> sta -{-# INLINE matches #-} - ---------------------------------------------------------------------- --- 'Traversal0Rep' ---------------------------------------------------------------------- - --- | The `Traversal0Rep` profunctor precisely characterizes an 'Traversal0'. -data Traversal0Rep a b s t = Traversal0Rep (s -> t + a) (s -> b -> t) - -instance Profunctor (Traversal0Rep u v) where - dimap f g (Traversal0Rep getter setter) = Traversal0Rep - (\a -> first g $ getter (f a)) - (\a v -> g (setter (f a) v)) - -instance Strong (Traversal0Rep u v) where - first' (Traversal0Rep getter setter) = Traversal0Rep - (\(a, c) -> first (,c) $ getter a) - (\(a, c) v -> (setter a v, c)) - -instance Choice (Traversal0Rep u v) where - right' (Traversal0Rep getter setter) = Traversal0Rep - (\eca -> eassocl (second getter eca)) - (\eca v -> second (`setter` v) eca) - -instance Sieve (Traversal0Rep a b) (Index0 a b) where - sieve (Traversal0Rep sta sbt) s = Index0 (sta s) (sbt s) - -instance Representable (Traversal0Rep a b) where - type Rep (Traversal0Rep a b) = Index0 a b - - tabulate f = Traversal0Rep (info0 . f) (values0 . f) - -data Index0 a b r = Index0 (r + a) (b -> r) - -values0 :: Index0 a b r -> b -> r -values0 (Index0 _ br) = br - -info0 :: Index0 a b r -> r + a -info0 (Index0 a _) = a - -instance Functor (Index0 a b) where - fmap f (Index0 ra br) = Index0 (first f ra) (f . br) - {-# INLINE fmap #-} diff --git a/src/Data/Profunctor/Optic/Traversal1.hs b/src/Data/Profunctor/Optic/Traversal1.hs deleted file mode 100644 --- a/src/Data/Profunctor/Optic/Traversal1.hs +++ /dev/null @@ -1,326 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -module Data.Profunctor.Optic.Traversal1 ( - -- * Traversal1 - Traversal1 - , Traversal1' - , ATraversal1 - , ATraversal1' - , traversal1 - , traversal1Vl - -- * Cotraversal1 & Cxtraversal1 - , Cotraversal1 - , Cotraversal1' - , Cxtraversal1 - , Cxtraversal1' - , ACotraversal1 - , ACotraversal1' - , cotraversal1 - , cotraversing1 - , retraversing1 - , cotraversal1Vl - , cxtraversal1Vl - , nocx1 - -- * Optics - , traversed1 - , cotraversed1 - , both1 - , bitraversed1 - , repeated - , iterated - , cycled - -- * Primitive operators - , withTraversal1 - , withCotraversal1 - -- * Operators - , sequences1 - , distributes1 - -- * Carriers - , Star(..) - , Costar(..) - -- * Classes - , Representable(..) - , Corepresentable(..) -) where - -import Data.Bifunctor (first, second) -import Data.List.Index -import Data.Map as Map -import Data.Semigroup.Bitraversable -import Data.Profunctor.Optic.Lens hiding (first, second, unit) -import Data.Profunctor.Optic.Import -import Data.Profunctor.Optic.Prism (prism) -import Data.Profunctor.Optic.Grate -import Data.Profunctor.Optic.Type -import Data.Semiring -import Control.Monad.Trans.State -import Data.Profunctor.Optic.Iso -import qualified Data.Bifunctor as B - --- $setup --- >>> :set -XNoOverloadedStrings --- >>> :set -XFlexibleContexts --- >>> :set -XTypeApplications --- >>> :set -XTupleSections --- >>> :set -XRankNTypes --- >>> import Data.Maybe --- >>> import Data.List.NonEmpty (NonEmpty(..)) --- >>> import qualified Data.List.NonEmpty as NE --- >>> import Data.Functor.Identity --- >>> import Data.List.Index --- >>> :load Data.Profunctor.Optic --- >>> let catchOn :: Int -> Cxprism' Int (Maybe String) String ; catchOn n = cxjust $ \k -> if k==n then Just "caught" else Nothing --- >>> let ixtraversed :: Ixtraversal Int [a] [b] a b ; ixtraversed = ixtraversalVl itraverse - ---------------------------------------------------------------------- --- 'Traversal1' ---------------------------------------------------------------------- - -type ATraversal1 f s t a b = Apply f => ARepn f s t a b - -type ATraversal1' f s a = ATraversal1 f s s a a - --- | Obtain a 'Traversal1' optic from a getter and setter. --- --- \( \mathsf{Traversal1}\;S\;A = \exists F : \mathsf{Traversable1}, S \equiv F\,A \) --- -traversal1 :: Traversable1 f => (s -> f a) -> (s -> f b -> t) -> Traversal1 s t a b -traversal1 sa sbt = lens sa sbt . repn traverse1 - --- | Obtain a 'Traversal' by lifting a lens getter and setter into a 'Traversable' functor. --- --- @ --- 'withLens' o 'traversing' ≡ 'traversed' . o --- @ --- --- /Caution/: In order for the generated optic to be well-defined, --- you must ensure that the input functions constitute a legal lens: --- --- * @sa (sbt s a) ≡ a@ --- --- * @sbt s (sa s) ≡ s@ --- --- * @sbt (sbt s a1) a2 ≡ sbt s a2@ --- --- See 'Data.Profunctor.Optic.Property'. --- --- The resulting optic can detect copies of the lens stucture inside --- any 'Traversable' container. For example: --- --- >>> lists (traversing snd $ \(s,_) b -> (s,b)) [(0,'f'),(1,'o'),(2,'o'),(3,'b'),(4,'a'),(5,'r')] --- "foobar" --- --- Compare 'Data.Profunctor.Optic.Fold.folding'. --- -traversing1 :: Traversable1 f => (s -> a) -> (s -> b -> t) -> Traversal1 (f s) (f t) a b -traversing1 sa sbt = repn traverse1 . lens sa sbt - --- | Obtain a profunctor 'Traversal1' from a Van Laarhoven 'Traversal1'. --- --- /Caution/: In order for the generated family to be well-defined, --- you must ensure that the traversal1 law holds for the input function: --- --- * @fmap (abst f) . abst g ≡ getCompose . abst (Compose . fmap f . g)@ --- --- See 'Data.Profunctor.Optic.Property'. --- -traversal1Vl :: (forall f. Apply f => (a -> f b) -> s -> f t) -> Traversal1 s t a b -traversal1Vl abst = tabulate . abst . sieve - ---------------------------------------------------------------------- --- 'Cotraversal1' & 'Cxtraversal11' ---------------------------------------------------------------------- - -type ACotraversal1 f s t a b = Apply f => ACorepn f s t a b - -type ACotraversal1' f s a = ACotraversal1 f s s a a - --- | Obtain a 'Cotraversal1' directly. --- -cotraversal1 :: Distributive g => (g b -> s -> g a) -> (g b -> t) -> Cotraversal1 s t a b -cotraversal1 bsa bt = colens bsa bt . corepn cotraverse - --- | Obtain a 'Cotraversal1' by embedding a reversed lens getter and setter into a 'Distributive' functor. --- --- @ --- 'withColens' o 'cotraversing' ≡ 'cotraversed' . o --- @ --- -cotraversing1 :: Distributive g => (b -> s -> a) -> (b -> t) -> Cotraversal1 (g s) (g t) a b -cotraversing1 bsa bt = corepn cotraverse . colens bsa bt - --- | Obtain a 'Cotraversal1' by embedding a grate continuation into a 'Distributive' functor. --- --- @ --- 'withGrate' o 'retraversing' ≡ 'cotraversed' . o --- @ --- -retraversing1 :: Distributive g => (((s -> a) -> b) -> t) -> Cotraversal1 (g s) (g t) a b -retraversing1 sabt = corepn cotraverse . grate sabt - --- | Obtain a profunctor 'Cotraversal1' from a Van Laarhoven 'Cotraversal1'. --- --- /Caution/: In order for the generated optic to be well-defined, --- you must ensure that the input satisfies the following properties: --- --- * @abst f . fmap (abst g) ≡ abst (f . fmap g . getCompose) . Compose@ --- --- See 'Data.Profunctor.Optic.Property'. --- -cotraversal1Vl :: (forall f. Apply f => (f a -> b) -> f s -> t) -> Cotraversal1 s t a b -cotraversal1Vl abst = cotabulate . abst . cosieve - --- | Lift an indexed VL cotraversal into a (co-)indexed profunctor cotraversal. --- --- /Caution/: In order for the generated optic to be well-defined, --- you must ensure that the input satisfies the following properties: --- --- * @kabst (const extract) ≡ extract@ --- --- * @kabst (const f) . fmap (kabst $ const g) ≡ kabst ((const f) . fmap (const g) . getCompose) . Compose@ --- --- See 'Data.Profunctor.Optic.Property'. --- -cxtraversal1Vl :: (forall f. Apply f => (k -> f a -> b) -> f s -> t) -> Cxtraversal1 k s t a b -cxtraversal1Vl kabst = cotraversal1Vl $ \kab -> const . kabst (flip kab) - --- | Lift a VL cotraversal into an (co-)indexed profunctor cotraversal that ignores its input. --- --- Useful as the first optic in a chain when no indexed equivalent is at hand. --- -nocx1 :: Monoid k => Cotraversal1 s t a b -> Cxtraversal1 k s t a b -nocx1 o = cxtraversal1Vl $ \kab s -> flip runCostar s . o . Costar $ kab mempty - ---------------------------------------------------------------------- --- Primitive operators ---------------------------------------------------------------------- - --- | --- --- The traversal laws can be stated in terms or 'withTraversal1': --- --- Identity: --- --- @ --- withTraversal1 t (Identity . f) ≡ Identity (fmap f) --- @ --- --- Composition: --- --- @ --- Compose . fmap (withTraversal1 t f) . withTraversal1 t g ≡ withTraversal1 t (Compose . fmap f . g) --- @ --- --- @ --- withTraversal1 :: Functor f => Lens s t a b -> (a -> f b) -> s -> f t --- withTraversal1 :: Apply f => Traversal1 s t a b -> (a -> f b) -> s -> f t --- @ --- -withTraversal1 :: Apply f => ATraversal1 f s t a b -> (a -> f b) -> s -> f t -withTraversal1 o = runStar #. o .# Star - --- | TODO: Document --- --- @ --- 'withCotraversal1' $ 'Data.Profuncto.Optic.Grate.grate' (flip 'Data.Distributive.cotraverse' id) ≡ 'Data.Distributive.cotraverse' --- @ --- -withCotraversal1 :: Functor f => Optic (Costar f) s t a b -> (f a -> b) -> (f s -> t) -withCotraversal1 o = runCostar #. o .# Costar - ---------------------------------------------------------------------- --- Optics ---------------------------------------------------------------------- - - --- | Obtain a 'Traversal1' from a 'Traversable1' functor. --- -traversed1 :: Traversable1 t => Traversal1 (t a) (t b) a b -traversed1 = traversal1Vl traverse1 - --- | TODO: Document --- -cotraversed1 :: Distributive f => Cotraversal1 (f a) (f b) a b -cotraversed1 = cotraversal1Vl cotraverse - --- | TODO: Document --- --- >>> withTraversal1 both1 (pure . NE.length) ('h' :| "ello", 'w' :| "orld") --- (5,5) --- -both1 :: Traversal1 (a , a) (b , b) a b -both1 p = tabulate $ \s -> liftF2 ($) (flip sieve s $ dimap fst (,) p) (flip sieve s $ lmap snd p) - --- | Traverse both parts of a 'Bitraversable1' container with matching types. --- --- >>> withTraversal1 bitraversed1 (pure . NE.length) ('h' :| "ello", 'w' :| "orld") --- (5,5) --- -bitraversed1 :: Bitraversable1 r => Traversal1 (r a a) (r b b) a b -bitraversed1 = repn $ \f -> bitraverse1 f f -{-# INLINE bitraversed1 #-} - --- | Obtain a 'Traversal1'' by repeating the input forever. --- --- @ --- 'repeat' ≡ 'lists' 'repeated' --- @ --- --- >>> take 5 $ 5 ^.. repeated --- [5,5,5,5,5] --- --- @ --- repeated :: Fold1 a a --- @ --- -repeated :: Traversal1' a a -repeated = repn $ \g a -> go g a where go g a = g a .> go g a -{-# INLINE repeated #-} - --- | @x '^.' 'iterated' f@ returns an infinite 'Traversal1'' of repeated applications of @f@ to @x@. --- --- @ --- 'lists' ('iterated' f) a ≡ 'iterate' f a --- @ --- --- >>> take 3 $ (1 :: Int) ^.. iterated (+1) --- [1,2,3] --- --- @ --- iterated :: (a -> a) -> 'Fold1' a a --- @ -iterated :: (a -> a) -> Traversal1' a a -iterated f = repn $ \g a0 -> go g a0 where go g a = g a .> go g (f a) -{-# INLINE iterated #-} - --- | Transform a 'Traversal1'' into a 'Traversal1'' that loops repn its elements repeatedly. --- --- >>> take 7 $ (1 :| [2,3]) ^.. cycled traversed1 --- [1,2,3,1,2,3,1] --- --- @ --- cycled :: 'Fold1' s a -> 'Fold1' s a --- @ --- -cycled :: Apply f => ATraversal1' f s a -> ATraversal1' f s a -cycled o = repn $ \g a -> go g a where go g a = (withTraversal1 o g) a .> go g a -{-# INLINE cycled #-} - ---------------------------------------------------------------------- --- Operators ---------------------------------------------------------------------- - --- | TODO: Document --- -sequences1 :: Apply f => ATraversal1 f s t (f a) a -> s -> f t -sequences1 o = withTraversal1 o id - --- | TODO: Document --- -distributes1 :: Apply f => ACotraversal1 f s t a (f a) -> f s -> t -distributes1 o = withCotraversal1 o id diff --git a/src/Data/Profunctor/Optic/Type.hs b/src/Data/Profunctor/Optic/Type.hs deleted file mode 100644 --- a/src/Data/Profunctor/Optic/Type.hs +++ /dev/null @@ -1,389 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE QuantifiedConstraints #-} -module Data.Profunctor.Optic.Type ( - -- * Optics - Optic, Optic', between - , IndexedOptic, IndexedOptic' - , CoindexedOptic, CoindexedOptic' - -- * Equality - , Equality, Equality', As - -- * Isos - , Iso, Iso' - -- * Lenses & Colenses - , Lens, Lens', Ixlens, Ixlens', Colens, Colens', Cxlens, Cxlens' - -- * Prisms & Coprisms - , Prism, Prism', Cxprism, Cxprism', Coprism, Coprism', Ixprism, Ixprism' - -- * Grates - , Grate, Grate', Cxgrate, Cxgrate' - -- * Traversals - , Traversal , Traversal' , Ixtraversal , Ixtraversal' - -- * Affine traversals & cotraversals - , Traversal0 , Traversal0' , Ixtraversal0, Ixtraversal0' - -- * Non-empty traversals & cotraversals - , Traversal1 , Traversal1' - , Cotraversal1 , Cotraversal1', Cxtraversal1, Cxtraversal1' - -- * Affine folds, general & non-empty folds, & cofolds - , Fold0, Ixfold0, Fold, Ixfold, Fold1, Cofold1 - -- * Views & Reviews - , PrimView, View, Ixview, PrimReview, Review, Cxview - -- * Setters & Resetters - , Setter, Setter', Ixsetter, Resetter, Resetter', Cxsetter - -- * Common represenable and corepresentable carriers - , ARepn, ARepn', AIxrepn, AIxrepn', ACorepn, ACorepn', ACxrepn, ACxrepn' - -- * 'Re' - , Re(..), re - , module Export -) where - -import Data.Bifunctor (Bifunctor(..)) -import Data.Functor.Apply (Apply(..)) -import Data.Profunctor.Optic.Import -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(..)) - --- $setup --- >>> :set -XNoOverloadedStrings --- >>> :load Data.Profunctor.Optic - ---------------------------------------------------------------------- --- 'Optic' ---------------------------------------------------------------------- - -type Optic p s t a b = p a b -> p s t - -type Optic' p s a = Optic p s s a a - -type IndexedOptic p i s t a b = p (i , a) b -> p (i , s) t - -type IndexedOptic' p i s a = IndexedOptic p i s s a a - -type CoindexedOptic p k s t a b = p a (k -> b) -> p s (k -> t) - -type CoindexedOptic' p k t b = CoindexedOptic p k t t b b - --- | Can be used to rewrite --- --- > \g -> f . g . h --- --- to --- --- > between f h --- -between :: (c -> d) -> (a -> b) -> (b -> c) -> a -> d -between f g = (f .) . (. g) -{-# INLINE between #-} - ---------------------------------------------------------------------- --- 'Equality' ---------------------------------------------------------------------- - -type Equality s t a b = forall p. Optic p s t a b - -type Equality' s a = Equality s s a a - -type As a = Equality' a a - ---------------------------------------------------------------------- --- 'Iso' ---------------------------------------------------------------------- - --- | 'Iso' --- --- \( \mathsf{Iso}\;S\;A = S \cong A \) --- --- For any valid 'Iso' /o/ we have: --- @ --- o . re o ≡ id --- re o . o ≡ id --- view o (review o b) ≡ b --- review o (view o s) ≡ s --- @ --- -type Iso s t a b = forall p. Profunctor p => Optic p s t a b - -type Iso' s a = Iso s s a a - ---------------------------------------------------------------------- --- 'Lens' & 'Colens' ---------------------------------------------------------------------- - --- | Lenses access one piece of a product. --- --- \( \mathsf{Lens}\;S\;A = \exists C, S \cong C \times A \) --- -type Lens s t a b = forall p. Strong p => Optic p s t a b - -type Lens' s a = Lens s s a a - -type Ixlens i s t a b = forall p. Strong p => IndexedOptic p i s t a b - -type Ixlens' i s a = Ixlens i s s a a - -type Colens s t a b = forall p. Costrong p => Optic p s t a b - -type Colens' s a = Colens s s a a - -type Cxlens k s t a b = forall p. Costrong p => CoindexedOptic p k s t a b - -type Cxlens' k s a = Cxlens k s s a a - ---------------------------------------------------------------------- --- 'Prism' & 'Coprism' ---------------------------------------------------------------------- - --- | Prisms access one piece of a sum. --- --- \( \mathsf{Prism}\;S\;A = \exists D, S \cong D + A \) --- -type Prism s t a b = forall p. Choice p => Optic p s t a b - -type Prism' s a = Prism s s a a - -type Cxprism k s t a b = forall p. Choice p => CoindexedOptic p k s t a b - -type Cxprism' k s a = Cxprism k s s a a - -type Coprism s t a b = forall p. Cochoice p => Optic p s t a b - -type Coprism' t b = Coprism t t b b - -type Ixprism i s t a b = forall p. Cochoice p => IndexedOptic p i s t a b - -type Ixprism' i s a = Coprism s s a a - ---------------------------------------------------------------------- --- 'Grate' ---------------------------------------------------------------------- - --- | Grates access the codomain of a function. --- --- \( \mathsf{Grate}\;S\;A = \exists I, S \cong I \to A \) --- -type Grate s t a b = forall p. Closed p => Optic p s t a b - -type Grate' s a = Grate s s a a - -type Cxgrate k s t a b = forall p. Closed p => CoindexedOptic p k s t a b - -type Cxgrate' k s a = Cxgrate k s s a a - ---------------------------------------------------------------------- --- 'Traversal' & 'Cotraversal' ---------------------------------------------------------------------- - --- | A 'Traversal' processes 0 or more parts of the whole, with 'Applicative' interactions. --- --- \( \mathsf{Traversal}\;S\;A = \exists F : \mathsf{Traversable}, S \equiv F\,A \) --- -type Traversal s t a b = forall p. (Choice p, Representable p, Applicative (Rep p)) => Optic p s t a b - -type Traversal' s a = Traversal s s a a - -type Ixtraversal i s t a b = forall p. (Choice p, Representable p, Applicative (Rep p)) => IndexedOptic p i s t a b - -type Ixtraversal' i s a = Ixtraversal i s s a a - ---------------------------------------------------------------------- --- 'Traversal0' & 'Cotraversal0' ---------------------------------------------------------------------- - --- | A 'Traversal0' processes at most one part of the whole, with no interactions. --- --- \( \mathsf{Traversal0}\;S\;A = \exists C, D, S \cong D + C \times A \) --- -type Traversal0 s t a b = forall p. (Strong p, Choice p) => Optic p s t a b - -type Traversal0' s a = Traversal0 s s a a - -type Ixtraversal0 i s t a b = forall p. (Strong p, Choice p) => IndexedOptic p i s t a b - -type Ixtraversal0' i s a = Ixtraversal0 i s s a a - ---------------------------------------------------------------------- --- 'Traversal1' & 'Cotraversal1' ---------------------------------------------------------------------- - --- | A 'Traversal1' processes 1 or more parts of the whole, with 'Apply' interactions. --- --- \( \mathsf{Traversal1}\;S\;A = \exists F : \mathsf{Traversable1}, S \equiv F\,A \) --- -type Traversal1 s t a b = forall p. (Choice p, Representable p, Apply (Rep p)) => Optic p s t a b - -type Traversal1' s a = Traversal1 s s a a - -type Cotraversal1 s t a b = forall p. (Closed p, Corepresentable p, Apply (Corep p)) => Optic p s t a b - -type Cotraversal1' s a = Cotraversal1 s s a a - -type Cxtraversal1 k s t a b = forall p. (Closed p, Corepresentable p, Apply (Corep p)) => CoindexedOptic p k s t a b - -type Cxtraversal1' k s a = Cxtraversal1 k s s a a - ---------------------------------------------------------------------- --- 'Fold0', 'Fold', 'Fold1' & 'Cofold1' ---------------------------------------------------------------------- - --- | A 'Fold0' combines at most one element, with no interactions. --- -type Fold0 s a = forall p. (Choice p, Representable p, Applicative (Rep p), forall x. Contravariant (p x)) => Optic' p s a - -type Ixfold0 i s a = forall p. (Choice p, Strong p, forall x. Contravariant (p x)) => IndexedOptic' p i s a - --- | A 'Fold' combines 0 or more elements, with 'Monoid' interactions. --- -type Fold s a = forall p. (Choice p, Representable p, Applicative (Rep p), forall x. Contravariant (p x)) => Optic' p s a - -type Ixfold i s a = forall p. (Choice p, Representable p, Applicative (Rep p), forall x. Contravariant (p x)) => IndexedOptic' p i s a - --- | A 'Fold1' combines 1 or more elements, with 'Semigroup' interactions. --- -type Fold1 s a = forall p. (Choice p, Representable p, Apply (Rep p), forall x. Contravariant (p x)) => Optic p s s a a - -type Cofold1 t b = forall p. (Cochoice p, Corepresentable p, Apply (Corep p), Bifunctor p) => Optic p t t b b - ---------------------------------------------------------------------- --- 'View' & 'Review' ---------------------------------------------------------------------- - -type PrimView s t a b = forall p. (Profunctor p, forall x. Contravariant (p x)) => Optic p s t a b - -type View s a = forall p. (Strong p, forall x. Contravariant (p x)) => Optic' p s a - -type Ixview i s a = forall p. (Strong p, forall x. Contravariant (p x)) => IndexedOptic' p i s a - -type PrimReview s t a b = forall p. (Profunctor p, Bifunctor p) => Optic p s t a b - -type Review t b = forall p. (Costrong p, Bifunctor p) => Optic' p t b - -type Cxview k t b = forall p. (Costrong p, Bifunctor p) => CoindexedOptic' p k t b - ---------------------------------------------------------------------- --- 'Setter' & 'Resetter' ---------------------------------------------------------------------- - --- | A 'Setter' modifies part of a structure. --- --- \( \mathsf{Setter}\;S\;A = \exists F : \mathsf{Functor}, S \equiv F\,A \) --- -type Setter s t a b = forall p. (Closed p, Choice p, Representable p, Applicative (Rep p), Distributive (Rep p)) => Optic p s t a b - -type Setter' s a = Setter s s a a - -type Ixsetter i s t a b = forall p. (Closed p, Choice p, Representable p, Applicative (Rep p), Distributive (Rep p)) => IndexedOptic p i s t a b - -type Ixsetter' i s a = Ixsetter i s s a a - -type Resetter s t a b = forall p. (Closed p, Cochoice p, Corepresentable p, Apply (Corep p), Traversable (Corep p)) => Optic p s t a b - -type Resetter' s a = Resetter s s a a - -type Cxsetter k s t a b = forall p. (Closed p, Cochoice p, Corepresentable p, Apply (Corep p), Traversable (Corep p)) => CoindexedOptic p k s t a b - ---------------------------------------------------------------------- --- Common 'Representable' and 'Corepresentable' carriers ---------------------------------------------------------------------- - -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 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 - ---------------------------------------------------------------------- --- 'Re' ---------------------------------------------------------------------- - --- | Reverse an optic to obtain its dual. --- --- >>> 5 ^. re left --- Left 5 --- --- >>> 6 ^. re (left . from succ) --- Left 7 --- --- @ --- 're' . 're' ≡ id --- @ --- --- @ --- 're' :: 'Iso' s t a b -> 'Iso' b a t s --- 're' :: 'Lens' s t a b -> 'Colens' b a t s --- 're' :: 'Prism' s t a b -> 'Coprism' b a t s --- @ --- -re :: Optic (Re p a b) s t a b -> Optic p b a t s -re o = (between runRe Re) o id -{-# INLINE re #-} - --- | The 'Re' type and its instances witness the symmetry between the parameters of a 'Profunctor'. --- -newtype Re p s t a b = Re { runRe :: p b a -> p t s } - -instance Profunctor p => Profunctor (Re p s t) where - dimap f g (Re p) = Re (p . dimap g f) - -instance Strong p => Costrong (Re p s t) where - unfirst (Re p) = Re (p . first') - -instance Costrong p => Strong (Re p s t) where - first' (Re p) = Re (p . unfirst) - -instance Choice p => Cochoice (Re p s t) where - unright (Re p) = Re (p . right') - -instance Cochoice p => Choice (Re p s t) where - right' (Re p) = Re (p . unright) - -instance (Profunctor p, forall x. Contravariant (p x)) => Bifunctor (Re p s t) where - first f (Re p) = Re (p . contramap f) - - second f (Re p) = Re (p . lmap f) - -instance Bifunctor p => Contravariant (Re p s t a) where - contramap f (Re p) = Re (p . first f) - ---------------------------------------------------------------------- --- Orphan instances ---------------------------------------------------------------------- - -instance Apply f => Apply (Star f a) where - Star ff <.> Star fx = Star $ \a -> ff a <.> fx a - -instance Contravariant f => Contravariant (Star f a) where - contramap f (Star g) = Star $ contramap f . g - -instance Contravariant f => Bifunctor (Costar f) where - first f (Costar g) = Costar $ g . contramap f - - second f (Costar g) = Costar $ f . g - -instance Cochoice (Forget r) where - unleft (Forget f) = Forget $ f . Left - - unright (Forget f) = Forget $ f . Right - -instance Comonad f => Strong (Costar f) where - first' (Costar f) = Costar $ \x -> (f (fmap fst x), snd (extract x)) - - second' (Costar f) = Costar $ \x -> (fst (extract x), f (fmap snd x)) diff --git a/src/Data/Profunctor/Optic/Types.hs b/src/Data/Profunctor/Optic/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Profunctor/Optic/Types.hs @@ -0,0 +1,457 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE QuantifiedConstraints #-} + +#ifndef MIN_VERSION_profunctors +#define MIN_VERSION_profunctors(x,y,z) 1 +#endif + +module Data.Profunctor.Optic.Types ( + -- * Optic, IndexedOptic, & CoindexedOptic + Optic, Optic' + , IndexedOptic, IndexedOptic' + , CoindexedOptic, CoindexedOptic' + -- * Iso & Equality + , Iso, Iso', Equality, Equality' + -- * Lens + , Lens, Lens', Ixlens, Ixlens' + -- * Prism + , Prism, Prism', Cxprism, Cxprism' + -- * Grate + , Grate, Grate', Cxgrate, Cxgrate' + -- * Affine & Option + , Affine, Affine', Ixaffine, Ixaffine' + , Option, Ixoption + -- * Grism + , Grism , Grism' + -- * Traversal, Traversal1, Fold & Fold1 + , Traversal , Traversal' , Ixtraversal , Ixtraversal' + , Traversal1 , Traversal1' , Ixtraversal1, Ixtraversal1' + , Fold, Ixfold , Fold1, Ixfold1 + -- * Cotraversal + , Cotraversal , Cotraversal' + -- * View & Review + , PrimView, View, Ixview, PrimReview, Review, Cxview + -- * Setter & Resetter + , Setter, Setter', Ixsetter, Ixsetter' + , Resetter, Resetter', Cxsetter, Cxsetter' + -- * Coapplicative + , Coapplicative(..), Branch(..) + , between + -- * 'Re' + , Re(..), re + , module Export +) where + +import Data.Bifunctor (Bifunctor(..)) +import Data.Functor.Apply (Apply(..)) +import Data.Profunctor.Optic.Import hiding (branch) +import Data.Profunctor.Extra as Export (type (+)) +import Data.Profunctor.Types as Export +import qualified Control.Arrow as A + +import Data.List.NonEmpty as L1 +import qualified Data.Bifunctor as B + +-- $setup +-- >>> :set -XCPP +-- >>> :set -XNoOverloadedStrings +-- >>> :load Data.Profunctor.Optic + +--------------------------------------------------------------------- +-- Optic +--------------------------------------------------------------------- + +type Optic p s t a b = p a b -> p s t + +type Optic' p s a = Optic p s s a a + +type IndexedOptic p i s t a b = p (i , a) b -> p (i , s) t + +type IndexedOptic' p i s a = IndexedOptic p i s s a a + +type CoindexedOptic p k s t a b = p a (k -> b) -> p s (k -> t) + +type CoindexedOptic' p k t b = CoindexedOptic p k t t b b + +--------------------------------------------------------------------- +-- Iso & Equality +--------------------------------------------------------------------- + +-- | 'Iso' +-- +-- \( \mathsf{Iso}\;S\;A = S \cong A \) +-- +type Iso s t a b = forall p. Profunctor p => Optic p s t a b + +type Iso' s a = Iso s s a a + +type Equality s t a b = forall p. Optic p s t a b + +type Equality' s a = Equality s s a a + +--------------------------------------------------------------------- +-- Lens +--------------------------------------------------------------------- + +-- | Lenses access one piece of a product. +-- +-- \( \mathsf{Lens}\;S\;A = \exists C, S \cong C \times A \) +-- +type Lens s t a b = forall p. Strong p => Optic p s t a b + +type Lens' s a = Lens s s a a + +type Ixlens i s t a b = forall p. Strong p => IndexedOptic p i s t a b + +type Ixlens' i s a = Ixlens i s s a a + +--------------------------------------------------------------------- +-- Prism +--------------------------------------------------------------------- + +-- | Prisms access one piece of a sum. +-- +-- \( \mathsf{Prism}\;S\;A = \exists D, S \cong D + A \) +-- +type Prism s t a b = forall p. Choice p => Optic p s t a b + +type Prism' s a = Prism s s a a + +type Cxprism k s t a b = forall p. Choice p => CoindexedOptic p k s t a b + +type Cxprism' k s a = Cxprism k s s a a + +--------------------------------------------------------------------- +-- Grate +--------------------------------------------------------------------- + +-- | Grates access the codomain of a function. +-- +-- \( \mathsf{Grate}\;S\;A = \exists I, S \cong I \to A \) +-- +type Grate s t a b = forall p. Closed p => Optic p s t a b + +type Grate' s a = Grate s s a a + +type Cxgrate k s t a b = forall p. Closed p => CoindexedOptic p k s t a b + +type Cxgrate' k s a = Cxgrate k s s a a + +type Colens s t a b = forall p. Costrong p => Optic p s t a b + +type Colens' s a = Colens s s a a + +type Cxlens k s t a b = forall p. Costrong p => CoindexedOptic p k s t a b + +type Cxlens' k s a = Cxlens k s s a a + +type Cotraversal0 s t a b = forall p. (Choice p, Closed p) => Optic p s t a b + +type Cotraversal0' t b = Cotraversal0 t t b b + +--------------------------------------------------------------------- +-- Affine & Option +--------------------------------------------------------------------- + +-- | A 'Affine' processes 0 or more parts of the whole, with no interactions. +-- +-- \( \mathsf{Affine}\;S\;A = \exists C, D, S \cong D + C \times A \) +-- +type Affine s t a b = forall p. (Choice p, Strong p) => Optic p s t a b + +type Affine' s a = Affine s s a a + +type Ixaffine i s t a b = forall p. (Choice p, Strong p) => IndexedOptic p i s t a b + +type Ixaffine' i s a = Ixaffine i s s a a + +-- | A 'Option' combines at most one element, with no interactions. +-- +type Option s a = forall p. (Choice p, Strong p, forall x. Contravariant (p x)) => Optic' p s a + +type Ixoption i s a = forall p. (Choice p, Strong p, forall x. Contravariant (p x)) => IndexedOptic' p i s a + +--------------------------------------------------------------------- +-- Grism +--------------------------------------------------------------------- + +-- | https://en.wikipedia.org/wiki/Grism +-- +type Grism s t a b = forall p. (Choice p, Closed p) => Optic p s t a b + +type Grism' t b = Grism t t b b + +--------------------------------------------------------------------- +-- Traversal, Traversal1, Fold, & Fold1 +--------------------------------------------------------------------- + +-- | A 'Traversal' processes 0 or more parts of the whole, with 'Applicative' interactions. +-- +-- \( \mathsf{Traversal}\;S\;A = \exists F : \mathsf{Traversable}, S \equiv F\,A \) +-- +type Traversal s t a b = forall p. (Choice p, Strong p, Representable p, Applicative (Rep p)) => Optic p s t a b + +type Traversal' s a = Traversal s s a a + +type Ixtraversal i s t a b = forall p. (Choice p, Strong p, Representable p, Applicative (Rep p)) => IndexedOptic p i s t a b + +type Ixtraversal' i s a = Ixtraversal i s s a a + +-- | A 'Traversal1' processes 1 or more parts of the whole, with 'Apply' interactions. +-- +-- \( \mathsf{Traversal1}\;S\;A = \exists F : \mathsf{Traversable1}, S \equiv F\,A \) +-- +type Traversal1 s t a b = forall p. (Strong p, Representable p, Apply (Rep p)) => Optic p s t a b + +type Traversal1' s a = Traversal1 s s a a + +type Ixtraversal1 i s t a b = forall p. (Strong p, Representable p, Apply (Rep p)) => IndexedOptic p i s t a b + +type Ixtraversal1' i s a = Ixtraversal1 i s s a a + +type Cofold0 t b = forall p. (Choice p, Closed p, Strong p, forall x. Contravariant (p x)) => Optic' p t b + +-- | A 'Fold1' combines 1 or more elements, with 'Semigroup' interactions. +-- +type Fold1 s a = forall p. (Strong p, Representable p, Apply (Rep p), forall x. Contravariant (p x)) => Optic' p s a + +type Ixfold1 i s a = forall p. (Strong p, Representable p, Apply (Rep p), forall x. Contravariant (p x)) => IndexedOptic' p i s a + +-- | A 'Fold' combines 0 or more elements, with 'Monoid' interactions. +-- +type Fold s a = forall p. (Choice p, Representable p, Applicative (Rep p), forall x. Contravariant (p x)) => Optic' p s a + +type Ixfold i s a = forall p. (Choice p, Representable p, Applicative (Rep p), forall x. Contravariant (p x)) => IndexedOptic' p i s a + +-- type Cofold t b = forall p. (Closed p, Corepresentable p, Coapplicative (Corep p), Bifunctor p) => Optic' p t b + +--------------------------------------------------------------------- +-- Cotraversal +--------------------------------------------------------------------- + +type Cotraversal s t a b = forall p. (Choice p, Closed p, Coapplicative (Corep p), Corepresentable p) => Optic p s t a b + +type Cotraversal' t b = Cotraversal t t b b + +--------------------------------------------------------------------- +-- View & Review +--------------------------------------------------------------------- + +type PrimView s t a b = forall p. (Profunctor p, forall x. Contravariant (p x)) => Optic p s t a b + +type View s a = forall p. (Strong p, forall x. Contravariant (p x)) => Optic' p s a + +type Ixview i s a = forall p. (Strong p, forall x. Contravariant (p x)) => IndexedOptic' p i s a + +type PrimReview s t a b = forall p. (Profunctor p, Bifunctor p) => Optic p s t a b + +type Review t b = forall p. (Closed p, Bifunctor p) => Optic' p t b + +type Cxview k t b = forall p. (Closed p, Bifunctor p) => CoindexedOptic' p k t b + +--------------------------------------------------------------------- +-- Setter & Resetter +--------------------------------------------------------------------- + +-- | A 'Setter' modifies part of a structure. +-- +-- \( \mathsf{Setter}\;S\;A = \exists F : \mathsf{Functor}, S \equiv F\,A \) +-- +type Setter s t a b = forall p. (Choice p, Strong p, Representable p, Applicative (Rep p), Distributive (Rep p)) => Optic p s t a b + +type Setter' s a = Setter s s a a + +type Ixsetter i s t a b = forall p. (Choice p, Strong p, Representable p, Applicative (Rep p), Distributive (Rep p)) => IndexedOptic p i s t a b + +type Ixsetter' i s a = Ixsetter i s s a a + +type Resetter s t a b = forall p. (Choice p, Closed p, Corepresentable p, Coapplicative (Corep p), Traversable (Corep p)) => Optic p s t a b + +type Resetter' s a = Resetter s s a a + +type Cxsetter k s t a b = forall p. (Choice p, Closed p, Corepresentable p, Coapplicative (Corep p), Traversable (Corep p)) => CoindexedOptic p k s t a b + +type Cxsetter' k t b = Cxsetter k t t b b + + +--------------------------------------------------------------------- +-- Branch & Coapplicative +--------------------------------------------------------------------- + +-- branch . fmap Left == Left +-- branch . fmap Right == Right +-- (fmap Left ||| fmap Right) . branch == id + +-- >>> (fmap Left ||| fmap Right) . branch $ (Left 1) :| [Right 2] +-- Left 1 :| [] +-- +class Functor f => Branch f where + branch :: f (Either a b) -> Either (f a) (f b) + +cobranch :: Apply f => (f a, f b) -> f (a, b) +cobranch = uncurry $ liftF2 (,) + +instance Branch Identity where + branch (Identity ab) = either (Left . Identity) (Right . Identity) ab + +{- +instance Branch (Const r) where branch (Const r) = Right (Const r) +-} + +instance Branch (Tagged k) where + branch (Tagged ab) = either (Left . Tagged) (Right . Tagged) ab + +instance Branch ((,) r) where + branch (r, a) = either (Left . (r,)) (Right . (r,)) a + +instance Monoid m => Branch ((->) m) where + branch f = either (Left . const) (Right . const) $ f mempty + +instance Branch NonEmpty where + branch (Left x :| zs) = Left $ x :| foldr (either (:) (const id)) [] zs + branch (Right y :| zs) = Right $ y :| foldr (either (const id) (:)) [] zs + +instance (Branch f, Branch g) => Branch (Compose f g) where + branch (Compose ab) = B.bimap Compose Compose . branch . fmap branch $ ab + +class Branch f => Coapplicative f where + -- either (f . copure) (g . copure) . branch == either f g . copure + copure :: f a -> a + +instance Coapplicative Identity where + copure (Identity a) = a + +instance Coapplicative (Tagged k) where + copure (Tagged a) = a + +instance Coapplicative ((,) r) where + copure (_, a) = a + +instance Monoid m => Coapplicative ((->) m) where + copure f = f mempty + +instance Coapplicative NonEmpty where + copure = L1.head + +catLefts :: [Either a b] -> [a] +catLefts = foldr (either (:) (const id)) [] + +catRights :: [Either a b] -> [b] +catRights = foldr (either (const id) (:)) [] + +instance (Coapplicative f, Coapplicative g) => Coapplicative (Compose f g) where + copure (Compose a) = copure . fmap copure $ a + +instance Coapplicative f => Choice (Costar f) where + left' (Costar f) = Costar $ either (Left . f) (Right . copure) . branch + +-- | Can be used to rewrite +-- +-- > \g -> f . g . h +-- +-- to +-- +-- > between f h +-- +between :: (c -> d) -> (a -> b) -> (b -> c) -> a -> d +between f g = (f .) . (. g) +{-# INLINE between #-} + +--------------------------------------------------------------------- +-- 'Re' +--------------------------------------------------------------------- + +-- | Reverse an optic to obtain its dual. +-- +-- >>> 5 ^. re left' +-- Left 5 +-- +-- >>> 6 ^. re (left' . from succ) +-- Left 7 +-- +-- @ +-- 're' . 're' ≡ id +-- @ +-- +-- @ +-- 're' :: 'Iso' s t a b -> 'Iso' b a t s +-- 're' :: 'Lens' s t a b -> 'Colens' b a t s +-- 're' :: 'Prism' s t a b -> 'Coprism' b a t s +-- @ +-- +re :: Optic (Re p a b) s t a b -> Optic p b a t s +re o = (between runRe Re) o id +{-# INLINE re #-} + +-- | The 'Re' type and its instances witness the symmetry between the parameters of a 'Profunctor'. +-- +newtype Re p s t a b = Re { runRe :: p b a -> p t s } + +instance Profunctor p => Profunctor (Re p s t) where + dimap f g (Re p) = Re (p . dimap g f) + +instance Strong p => Costrong (Re p s t) where + unfirst (Re p) = Re (p . first') + +instance Costrong p => Strong (Re p s t) where + first' (Re p) = Re (p . unfirst) + +instance Choice p => Cochoice (Re p s t) where + unright (Re p) = Re (p . right') + +instance Cochoice p => Choice (Re p s t) where + right' (Re p) = Re (p . unright) + +instance (Profunctor p, forall x. Contravariant (p x)) => Bifunctor (Re p s t) where + first f (Re p) = Re (p . contramap f) + + second f (Re p) = Re (p . lmap f) + +instance Bifunctor p => Contravariant (Re p s t a) where + contramap f (Re p) = Re (p . first f) + +--------------------------------------------------------------------- +-- Orphan instances +--------------------------------------------------------------------- + +instance Apply f => Apply (Star f a) where + Star ff <.> Star fx = Star $ \a -> ff a <.> fx a + +instance Apply (Costar f a) where + Costar ff <.> Costar fx = Costar $ \a -> ff a (fx a) + +#if !(MIN_VERSION_profunctors(5,4,0)) +instance Contravariant f => Contravariant (Star f a) where + contramap f (Star g) = Star $ contramap f . g +#endif + +instance Contravariant f => Bifunctor (Costar f) where + first f (Costar g) = Costar $ g . contramap f + + second f (Costar g) = Costar $ f . g + + +{- +#if !(MIN_VERSION_profunctors(5,5,0)) +instance Cochoice (Forget r) where + unleft (Forget f) = Forget $ f . Left + + unright (Forget f) = Forget $ f . Right +#endif + +#if MIN_VERSION_profunctors(5,4,0) +instance Comonad f => Choice (Costar f) where + left' (Costar f) = Costar . runCostar . A.left . Costar $ f + + right' (Costar f) = Costar . runCostar . A.right . Costar $ f +#endif +-} diff --git a/src/Data/Profunctor/Optic/View.hs b/src/Data/Profunctor/Optic/View.hs --- a/src/Data/Profunctor/Optic/View.hs +++ b/src/Data/Profunctor/Optic/View.hs @@ -5,27 +5,23 @@ module Data.Profunctor.Optic.View ( -- * Types View - , AView , Ixview - , AIxview , PrimView , Review - , AReview , Cxview - , ACxview , PrimReview -- * Constructors , to - , ixto + , ito , from - , cxfrom + , kfrom , cloneView , cloneReview -- * Optics , like - , ixlike + , ilike , relike - , cxlike + , klike , toProduct , fromSum -- * Primitive operators @@ -35,29 +31,26 @@ , (^.) , (^%) , view - , ixview + , iview , views - , ixviews + , iviews , use - , ixuse + , iuse , uses - , ixuses + , iuses , (#^) , review - , cxview + , kview , reviews - , cxviews + , kviews , reuse , reuses - , cxuse - , cxuses + , kuse + , kuses -- * MonadIO , throws , throws_ , throwsTo - -- * Carriers - , Star(..) - , Tagged(..) ) where import Control.Exception (Exception) @@ -65,9 +58,10 @@ import Control.Monad.Reader as Reader import Control.Monad.Writer as Writer hiding (Sum(..)) import Control.Monad.State as State -import Data.Profunctor.Optic.Type +import Data.Profunctor.Optic.Carrier +import Data.Profunctor.Optic.Types +import Data.Profunctor.Optic.Operator import Data.Profunctor.Optic.Import -import Data.Profunctor.Optic.Index import GHC.Conc (ThreadId) import qualified Control.Exception as Ex import qualified Data.Bifunctor as B @@ -82,28 +76,15 @@ -- >>> import Control.Monad.Writer -- >>> import Data.Int.Instance () -- >>> import Data.List.Index as LI --- >>> :load Data.Profunctor.Optic --- >>> let catchOn :: Int -> Cxprism' Int (Maybe String) String ; catchOn n = cxjust $ \k -> if k==n then Just "caught" else Nothing --- >>> let ixtraversed :: Ixtraversal Int [a] [b] a b ; ixtraversed = ixtraversalVl LI.itraverse --- >>> let ixat :: Int -> Ixtraversal0' Int [a] a; ixat = inserted (\i s -> flip LI.ifind s $ \n _ -> n == i) (\i a s -> LI.modifyAt i (const a) s) - -type APrimView r s t a b = Optic (Star (Const r)) s t a b - -type AView s a = Optic' (Star (Const a)) s a - -type AIxview r i s a = IndexedOptic' (Star (Const (Maybe i , r))) i s a - -type APrimReview s t a b = Optic Tagged s t a b - -type AReview t b = Optic' Tagged t b - -type ACxview k t b = CoindexedOptic' Tagged k t b +-- >>> :load Data.Profunctor.Optic Data.Either.Optic Data.Tuple.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 +-- >>> 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) --------------------------------------------------------------------- -- 'View' & 'Review' --------------------------------------------------------------------- - -- | Obtain a 'View' from an arbitrary function. -- -- @ @@ -117,7 +98,7 @@ -- >>> 5 ^. to succ -- 6 -- --- >>> (0, -5) ^. t22 . to abs +-- >>> (0, -5) ^. second' . to abs -- 5 -- -- @ @@ -130,9 +111,9 @@ -- | TODO: Document -- -ixto :: (s -> (i , a)) -> Ixview i s a -ixto f = to $ f . snd -{-# INLINE ixto #-} +ito :: (s -> (i , a)) -> Ixview i s a +ito f = to $ f . snd +{-# INLINE ito #-} -- | Obtain a 'Review' from an arbitrary function. -- @@ -153,9 +134,9 @@ -- | TODO: Document -- -cxfrom :: ((k -> b) -> t) -> Cxview k t b -cxfrom f = from $ \kb _ -> f kb -{-# INLINE cxfrom #-} +kfrom :: ((k -> b) -> t) -> Cxview k t b +kfrom f = from $ \kb _ -> f kb +{-# INLINE kfrom #-} -- | TODO: Document -- @@ -175,22 +156,6 @@ {-# INLINE cloneReview #-} --------------------------------------------------------------------- --- Primitive operators ---------------------------------------------------------------------- - --- | TODO: Document --- -withPrimView :: APrimView r s t a b -> (a -> r) -> s -> r -withPrimView o = (getConst #.) #. runStar #. o .# Star .# (Const #.) -{-# INLINE withPrimView #-} - --- | TODO: Document --- -withPrimReview :: APrimReview s t a b -> (t -> r) -> b -> r -withPrimReview o f = f . unTagged #. o .# Tagged -{-# INLINE withPrimReview #-} - ---------------------------------------------------------------------- -- Optics --------------------------------------------------------------------- @@ -216,9 +181,9 @@ -- | TODO: Document -- -ixlike :: i -> a -> Ixview i s a -ixlike i a = ixto (const (i, a)) -{-# INLINE ixlike #-} +ilike :: i -> a -> Ixview i s a +ilike i a = ito (const (i, a)) +{-# INLINE ilike #-} -- | Obtain a constant-valued (index-preserving) 'Review' from an arbitrary value. -- @@ -234,9 +199,9 @@ -- | Obtain a constant-valued 'Cxview' from an arbitrary value. -- -cxlike :: t -> Cxview k t b -cxlike = cxfrom . const -{-# INLINE cxlike #-} +klike :: t -> Cxview k t b +klike = kfrom . const +{-# INLINE klike #-} -- | Combine two 'View's into a 'View' to a product. -- @@ -262,97 +227,52 @@ -- Operators --------------------------------------------------------------------- -infixl 8 ^. - --- | An infix alias for 'view'. Dual to '#'. --- --- Fixity and semantics are such that subsequent field accesses can be --- performed with ('Prelude..'). --- --- >>> ("hello","world") ^. t22 --- "world" --- --- >>> import Data.Complex --- >>> ((0, 1 :+ 2), 3) ^. t21 . t22 . to magnitude --- 2.23606797749979 --- --- @ --- ('^.') :: s -> 'View' s a -> a --- ('^.') :: 'Data.Monoid.Monoid' m => s -> 'Data.Profunctor.Optic.Fold.Fold' s m -> m --- ('^.') :: s -> 'Data.Profunctor.Optic.Iso.Iso'' s a -> a --- ('^.') :: s -> 'Data.Profunctor.Optic.Lens.Lens'' s a -> a --- ('^.') :: s -> 'Data.Profunctor.Optic.Prism.Coprism'' s a -> a --- ('^.') :: 'Data.Monoid.Monoid' m => s -> 'Data.Profunctor.Optic.Traversal.Traversal'' s m -> m --- @ --- -(^.) :: s -> AView s a -> a -(^.) = flip view -{-# INLINE ( ^. ) #-} - -infixl 8 ^% - --- | Bring the index and value of a indexed optic into the current environment as a pair. --- --- This a flipped, infix variant of 'ixview' and an indexed variant of '^.'. --- --- The fixity and semantics are such that subsequent field accesses can be --- performed with ('Prelude..'). --- --- The result probably doesn't have much meaning when applied to an 'Ixfold'. --- -(^%) :: Monoid i => s -> AIxview a i s a -> (Maybe i , a) -(^%) = flip ixview -{-# INLINE (^%) #-} - --- | View the value pointed to by a 'View', 'Data.Profunctor.Optic.Iso.Iso' or --- 'Lens' or the result of folding over all the results of a --- 'Data.Profunctor.Optic.Fold.Fold' or 'Data.Profunctor.Optic.Traversal.Traversal' that points --- at a monoidal value. +-- | A prefix alias for '^.'. -- -- @ -- 'view' '.' 'to' ≡ 'id' -- @ -- --- >>> view t22 (1, "hello") +-- >>> view second' (1, "hello") -- "hello" -- -- >>> view (to succ) 5 -- 6 -- --- >>> view (t22 . t21) ("hello",("world","!!!")) +-- >>> view (second' . first') ("hello",("world","!!!")) -- "world" -- view :: MonadReader s m => AView s a -> m a view o = views o id {-# INLINE view #-} --- | Bring the index and value of a indexed optic into the current environment as a pair. +-- | A prefix alias for '^%'. -- --- >>> ixview ixfirst ("foo", 42) +-- >>> iview ifirst ("foo", 42) -- (Just (),"foo") -- --- >>> ixview (ixat 3 . ixfirst) [(0,'f'),(1,'o'),(2,'o'),(3,'b'),(4,'a'),(5,'r') :: (Int, Char)] +-- >>> iview (iat 3 . ifirst) [(0,'f'),(1,'o'),(2,'o'),(3,'b'),(4,'a'),(5,'r') :: (Int, Char)] -- (Just 3,3) -- --- In order to 'ixview' a 'Choice' optic (e.g. 'Ixtraversal0', 'Ixtraversal', 'Ixfold', etc), +-- In order to 'iview' a 'Choice' optic (e.g. 'Ixaffine', 'Ixtraversal', 'Ixfold', etc), -- /a/ must have a 'Monoid' instance: -- --- >>> ixview (ixat 0) ([] :: [Int]) +-- >>> iview (iat 0) ([] :: [Int]) -- (Nothing,0) --- >>> ixview (ixat 0) ([1] :: [Int]) +-- >>> iview (iat 0) ([1] :: [Int]) -- (Just 0,1) -- --- /Note/ when applied to a 'Ixtraversal' or 'Ixfold', then 'ixview' will return a monoidal +-- /Note/ when applied to a 'Ixtraversal' or 'Ixfold', then 'iview' will return a monoidal -- summary of the indices tupled with a monoidal summary of the values: -- --- >>> (ixview @_ @_ @Int @Int) ixtraversed [1,2,3,4] +-- >>> (iview @_ @_ @Int @Int) itraversed [1,2,3,4] -- (Just 6,10) -- -ixview :: MonadReader s m => Monoid i => AIxview a i s a -> m (Maybe i , a) -ixview o = asks $ withPrimView o (B.first Just) . (mempty,) -{-# INLINE ixview #-} +iview :: MonadReader s m => Monoid i => AIxview i s a -> m (Maybe i , a) +iview o = asks $ withPrimView o (B.first Just) . (mempty,) +{-# INLINE iview #-} --- | Map each part of a structure viewed to a semantic edixtor combinator. +-- | Map each part of a structure viewed to a semantic editor combinator. -- -- @ -- 'views o f ≡ withFold o f' @@ -379,21 +299,21 @@ -- | Bring a function of the index and value of an indexed optic into the current environment. -- --- 'ixviews' ≡ 'iwithFold' +-- 'iviews' ≡ 'iwithFold' -- --- >>> ixviews (ixat 2) (-) ([0,1,2] :: [Int]) +-- >>> iviews (iat 2) (-) ([0,1,2] :: [Int]) -- 0 -- --- In order to 'ixviews' a 'Choice' optic (e.g. 'Ixtraversal0', 'Ixtraversal', 'Ixfold', etc), +-- In order to 'iviews' a 'Choice' optic (e.g. 'Ixaffine', 'Ixtraversal', 'Ixfold', etc), -- /a/ must have a 'Monoid' instance (here from the 'rings' package): -- --- >>> ixviews (ixat 3) (flip const) ([1] :: [Int]) +-- >>> iviews (iat 3) (flip const) ([1] :: [Int]) -- 0 -- --- Use 'ixview' if there is a need to disambiguate between 'mempty' as a miss vs. as a return value. +-- Use 'iview' if there is a need to disambiguate between 'mempty' as a miss vs. as a return value. -- -ixviews :: MonadReader s m => Monoid i => IndexedOptic' (Star (Const r)) i s a -> (i -> a -> r) -> m r -ixviews o f = asks $ withPrimView o (uncurry f) . (mempty,) +iviews :: MonadReader s m => Monoid i => IndexedOptic' (Star (Const r)) i s a -> (i -> a -> r) -> m r +iviews o f = asks $ withPrimView o (uncurry f) . (mempty,) -- | TODO: Document -- @@ -403,15 +323,15 @@ -- | Bring the index and value of an indexed optic into the current environment as a pair. -- -ixuse :: MonadState s m => Monoid i => AIxview a i s a -> m (Maybe i , a) -ixuse o = gets (ixview o) +iuse :: MonadState s m => Monoid i => AIxview i s a -> m (Maybe i , a) +iuse o = gets (iview o) -- | Use the target of a 'Lens', 'Data.Profunctor.Optic.Iso.Iso' or -- 'View' in the current state, or use a summary of a -- 'Data.Profunctor.Optic.Fold.Fold' or 'Data.Profunctor.Optic.Traversal.Traversal' that -- points to a monoidal value. -- --- >>> evalState (uses t21 length) ("hello","world!") +-- >>> evalState (uses first' length) ("hello","world!") -- 5 -- -- @ @@ -433,36 +353,10 @@ -- | Bring a function of the index and value of an indexed optic into the current environment. -- -ixuses :: MonadState s m => Monoid i => IndexedOptic' (Star (Const r)) i s a -> (i -> a -> r) -> m r -ixuses o f = gets $ withPrimView o (uncurry f) . (mempty,) - -infixr 8 #^ - --- | An infix variant of 'review'. Dual to '^.'. --- --- @ --- 'from' f #^ x ≡ f x --- o #^ x ≡ x '^.' 're' o --- @ --- --- This is commonly used when using a 'Prism' as a smart constructor. --- --- >>> left #^ 4 --- Left 4 --- --- @ --- (#^) :: 'Iso'' s a -> a -> s --- (#^) :: 'Prism'' s a -> a -> s --- (#^) :: 'Colens'' s a -> a -> s --- (#^) :: 'Review' s a -> a -> s --- (#^) :: 'Equality'' s a -> a -> s --- @ --- -(#^) :: AReview t b -> b -> t -o #^ b = review o b -{-# INLINE (#^) #-} +iuses :: MonadState s m => Monoid i => IndexedOptic' (Star (Const r)) i s a -> (i -> a -> r) -> m r +iuses o f = gets $ withPrimView o (uncurry f) . (mempty,) --- | Turn an optic around and look through the other end. +-- | A prefix alias of '#^'. -- -- @ -- 'review' ≡ 'view' '.' 're' @@ -484,9 +378,9 @@ -- | Bring a function of the index of a co-indexed optic into the current environment. -- -cxview :: MonadReader b m => ACxview k t b -> m (k -> t) -cxview o = cxviews o id -{-# INLINE cxview #-} +kview :: MonadReader b m => ACxview k t b -> m (k -> t) +kview o = kviews o id +{-# INLINE kview #-} -- | Turn an optic around and look through the other end, applying a function. -- @@ -495,7 +389,7 @@ -- 'reviews' ('from' f) g ≡ g '.' f -- @ -- --- >>> reviews left isRight "mustard" +-- >>> reviews left' isRight "mustard" -- False -- -- >>> reviews (from succ) (*2) 3 @@ -514,11 +408,11 @@ -- | Bring a continuation of the index of a co-indexed optic into the current environment. -- -- @ --- cxviews :: ACxview k t b -> ((k -> t) -> r) -> b -> r +-- kviews :: ACxview k t b -> ((k -> t) -> r) -> b -> r -- @ -- -cxviews :: MonadReader b m => ACxview k t b -> ((k -> t) -> r) -> m r -cxviews o f = asks $ withPrimReview o f . const +kviews :: MonadReader b m => ACxview k t b -> ((k -> t) -> r) -> m r +kviews o f = asks $ withPrimReview o f . const -- | Turn an optic around and 'use' a value (or the current environment) through it the other way. -- @@ -527,7 +421,7 @@ -- 'reuse' '.' 'from' ≡ 'gets' -- @ -- --- >>> evalState (reuse left) 5 +-- >>> evalState (reuse left') 5 -- Left 5 -- -- >>> evalState (reuse (from succ)) 5 @@ -545,9 +439,9 @@ -- | TODO: Document -- -cxuse :: MonadState b m => ACxview k t b -> m (k -> t) -cxuse o = gets (cxview o) -{-# INLINE cxuse #-} +kuse :: MonadState b m => ACxview k t b -> m (k -> t) +kuse o = gets (kview o) +{-# INLINE kuse #-} -- | Turn an optic around and 'use' the current state through it the other way, applying a function. -- @@ -556,7 +450,7 @@ -- 'reuses' ('from' f) g ≡ 'gets' (g '.' f) -- @ -- --- >>> evalState (reuses left isLeft) (5 :: Int) +-- >>> evalState (reuses left' isLeft) (5 :: Int) -- True -- -- @ @@ -571,9 +465,9 @@ -- | TODO: Document -- -cxuses :: MonadState b m => ACxview k t b -> ((k -> t) -> r) -> m r -cxuses o f = gets (cxviews o f) -{-# INLINE cxuses #-} +kuses :: MonadState b m => ACxview k t b -> ((k -> t) -> r) -> m r +kuses o f = gets (kviews o f) +{-# INLINE kuses #-} --------------------------------------------------------------------- -- 'MonadIO' diff --git a/src/Data/Profunctor/Optic/Zoom.hs b/src/Data/Profunctor/Optic/Zoom.hs new file mode 100644 --- /dev/null +++ b/src/Data/Profunctor/Optic/Zoom.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +module Data.Profunctor.Optic.Zoom where + +import Control.Monad.Reader as Reader +import Control.Monad.State as State +import Control.Monad.Trans.State.Lazy as Lazy +import Control.Monad.Trans.State.Strict as Strict +import Control.Monad.Trans.RWS.Lazy as Lazy +import Control.Monad.Trans.RWS.Strict as Strict +import Control.Monad.Trans.Identity +import Data.Profunctor.Optic.Import +import Data.Profunctor.Optic.Types + +-- $setup +-- >>> :set -XNoOverloadedStrings +-- >>> :set -XTypeApplications +-- >>> :set -XFlexibleContexts +-- >>> :set -XFlexibleInstances +-- >>> :set -XRankNTypes +-- >>> import Control.Monad.State +-- >>> :load Data.Profunctor.Optic + +infixr 2 `zoom` + +type family Zoomed (m :: * -> *) :: * -> * -> * + +type instance Zoomed (IdentityT m) = Zoomed m +type instance Zoomed (ReaderT e m) = Zoomed m +type instance Zoomed (Strict.StateT s z) = StateTRep z +type instance Zoomed (Lazy.StateT s z) = StateTRep z +type instance Zoomed (Strict.RWST r w s z) = RWSTRep w z +type instance Zoomed (Lazy.RWST r w s z) = RWSTRep w z + +class (MonadState s m, MonadState t n) => Zoom m n s t | m -> s, n -> t, m t -> n, n s -> m where + + -- | Run a monadic action in a larger 'State' than it was defined in. + -- + -- Used to lift actions into a 'State' 'Monad' with a larger 'State' type. + -- + -- >>> flip evalState (1,"foo") $ zoom first' $ use id + -- 1 + -- + -- >>> flip evalState [Right "foo", Right "bar"] $ zoom traversed $ use right' + -- "foobar" + -- + -- >>> flip execState (1,"foo") $ zoom first' $ id .= 2 + -- (2,"foo") + -- + -- >>> flip execState [(1,"foo"), (2,"foo")] $ zoom traversed $ second' ..= (<>"bar") + -- [(1,"foobar"),(2,"foobar")] + -- + -- >>> flip execState [Left "foo", Right "bar"] $ zoom traversed $ right' ..= (<>"baz") + -- [Left "foo",Right "barbaz"] + -- + -- >>> flip evalState ("foo","bar") $ zoom both (use id) + -- "foobar" + -- + zoom :: Optic' (Star (Zoomed m c)) t s -> m c -> n c + +instance Zoom m n s t => Zoom (IdentityT m) (IdentityT n) s t where + zoom l (IdentityT m) = IdentityT (zoom l m) + {-# INLINE zoom #-} + +instance Zoom m n s t => Zoom (ReaderT e m) (ReaderT e n) s t where + zoom l (ReaderT m) = ReaderT (zoom l . m) + {-# INLINE zoom #-} + +instance Monad z => Zoom (Strict.StateT s z) (Strict.StateT t z) s t where + zoom o m = Strict.StateT $ unStateTRep #. (runStar #. o .# Star) (StateTRep #. (Strict.runStateT m)) + {-# INLINE zoom #-} + +instance Monad z => Zoom (Lazy.StateT s z) (Lazy.StateT t z) s t where + zoom o m = Lazy.StateT $ unStateTRep #. (runStar #. o .# Star) (StateTRep #. (Lazy.runStateT m)) + {-# INLINE zoom #-} + +instance (Monoid w, Monad z) => Zoom (Strict.RWST r w s z) (Strict.RWST r w t z) s t where + zoom o m = Strict.RWST $ \r -> unRWSTRep #. (runStar #. o .# Star) (RWSTRep #. (Strict.runRWST m r)) + {-# INLINE zoom #-} + +instance (Monoid w, Monad z) => Zoom (Lazy.RWST r w s z) (Lazy.RWST r w t z) s t where + zoom o m = Lazy.RWST $ \r -> unRWSTRep #. (runStar #. o .# Star) (RWSTRep #. (Lazy.runRWST m r)) + {-# INLINE zoom #-} + +---------------------------------------------------------------------- +-- StateTRep +---------------------------------------------------------------------- + +newtype StateTRep m s a = StateTRep { unStateTRep :: m (s, a) } + +instance Monad m => Functor (StateTRep m s) where + fmap f (StateTRep m) = StateTRep $ do + (s, a) <- m + return (s, f a) + {-# INLINE fmap #-} + +instance (Monad m, Semigroup s) => Apply (StateTRep m s) where + StateTRep mf <.> StateTRep ma = StateTRep $ do + (s, f) <- mf + (s', a) <- ma + return (s <> s', f a) + {-# INLINE (<.>) #-} + +instance (Monad m, Monoid s) => Applicative (StateTRep m s) where + pure a = StateTRep (return (mempty, a)) + {-# INLINE pure #-} + StateTRep mf <*> StateTRep ma = StateTRep $ do + (s, f) <- mf + (s', a) <- ma + return (mappend s s', f a) + {-# INLINE (<*>) #-} + +------------------------------------------------------------------------------ +-- RWSTRep +------------------------------------------------------------------------------ + +newtype RWSTRep w m s a = RWSTRep { unRWSTRep :: m (s, a, w) } + +instance Monad m => Functor (RWSTRep w m s) where + fmap f (RWSTRep m) = RWSTRep $ do + (s, a, w) <- m + return (s, f a, w) + {-# INLINE fmap #-} + +instance (Monad m, Semigroup s, Semigroup w) => Apply (RWSTRep w m s) where + RWSTRep mf <.> RWSTRep ma = RWSTRep $ do + (s, f, w) <- mf + (s', a, w') <- ma + return (s <> s', f a, w <> w') + {-# INLINE (<.>) #-} + +instance (Monad m, Monoid s, Monoid w) => Applicative (RWSTRep w m s) where + pure a = RWSTRep (return (mempty, a, mempty)) + {-# INLINE pure #-} + RWSTRep mf <*> RWSTRep ma = RWSTRep $ do + (s, f, w) <- mf + (s', a, w') <- ma + return (mappend s s', f a, mappend w w') + {-# INLINE (<*>) #-} diff --git a/src/Data/Tuple/Optic.hs b/src/Data/Tuple/Optic.hs --- a/src/Data/Tuple/Optic.hs +++ b/src/Data/Tuple/Optic.hs @@ -9,6 +9,8 @@ curried , swapped , associated + , first + , second , t21 , t22 , t31 @@ -28,11 +30,16 @@ import Data.Profunctor.Optic.Import import Data.Profunctor.Optic.Iso import Data.Profunctor.Optic.Lens -import Data.Profunctor.Optic.Type --------------------------------------------------------------------- -- Optics --------------------------------------------------------------------- + +first :: Lens (a , c) (b , c) a b +first = first' + +second :: Lens (c , a) (c , b) a b +second = second' t21 :: Lens (a,b) (a',b) a a' t21 = lensVl $ \f ~(a,b) -> (\a' -> (a',b)) <$> f a diff --git a/test/Test/Data/Connection/Optic/Int.hs b/test/Test/Data/Connection/Optic/Int.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Connection/Optic/Int.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE TemplateHaskell #-} +module Test.Data.Connection.Optic.Int where + +import Control.Applicative +import Data.Int +import Data.Word +import Data.Prd + +import Data.Connection.Optic.Int as I +import Data.Profunctor.Optic + +import Hedgehog +import qualified Hedgehog.Gen as G +import qualified Hedgehog.Range as R + +data V3 a = V3 !a !a !a deriving (Eq,Ord,Show) + +instance Functor V3 where fmap f (V3 a b c) = V3 (f a) (f b) (f c) + +--TODO replace w/ semiring ops +add3 :: Num a => V3 a -> a +add3 (V3 x y z) = x + y + z + +sub3 :: Num a => V3 a -> a +sub3 (V3 x y z) = x - y - z + +mul3 :: Num a => V3 a -> a +mul3 (V3 x y z) = x + y + z + +v3 :: Gen a -> Gen (V3 a) +v3 g = liftA3 V3 g g g + +i08 :: Gen Int8 +i08 = G.int8 R.linearBounded + +i32 :: Gen Int32 +i32 = G.int32 R.linearBounded + +i64 :: Gen Int64 +i64 = G.int64 R.linearBounded + +prop_i08w08 :: Property +prop_i08w08 = withTests 1000 . property $ do + x <- forAll i08 + vvx <- forAll (v3 . v3 $ i08) + assert $ id_grate I.i08w08 x + assert $ const_grate I.i08w08 x + assert $ compose_grate I.i08w08 add3 mul3 vvx + assert $ compose_grate I.i08w08 sub3 mul3 vvx diff --git a/test/doctest.hs b/test/doctest.hs new file mode 100644 --- /dev/null +++ b/test/doctest.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE CPP #-} +import Test.DocTest + +main :: IO () +main = doctest + [ "-isrc" + , "src/Data/Profunctor/Optic/Operator.hs" + , "src/Data/Profunctor/Optic/Fold.hs" + , "src/Data/Profunctor/Optic/Option.hs" + , "src/Data/Profunctor/Optic/Grate.hs" + , "src/Data/Profunctor/Optic/Iso.hs" + , "src/Data/Profunctor/Optic/Lens.hs" + , "src/Data/Profunctor/Optic/Prism.hs" + , "src/Data/Profunctor/Optic/Setter.hs" + , "src/Data/Profunctor/Optic/Traversal.hs" + , "src/Data/Profunctor/Optic/Cotraversal.hs" + , "src/Data/Profunctor/Optic/Affine.hs" + , "src/Data/Profunctor/Optic/View.hs" + ] diff --git a/test/doctests.hs b/test/doctests.hs deleted file mode 100644 --- a/test/doctests.hs +++ /dev/null @@ -1,14 +0,0 @@ -import Test.DocTest - -main :: IO () -main = doctest - [ "-isrc" - , "src/Data/Profunctor/Optic/Fold.hs" - , "src/Data/Profunctor/Optic/Grate.hs" - , "src/Data/Profunctor/Optic/Iso.hs" - , "src/Data/Profunctor/Optic/Lens.hs" - , "src/Data/Profunctor/Optic/Prism.hs" - , "src/Data/Profunctor/Optic/Setter.hs" - , "src/Data/Profunctor/Optic/Traversal.hs" - , "src/Data/Profunctor/Optic/View.hs" - ] diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -0,0 +1,15 @@ +import Control.Monad +import System.Exit (exitFailure) +import System.IO (BufferMode(..), hSetBuffering, stdout, stderr) + +tests :: IO [Bool] +tests = sequence [] -- [CI.tests, CW.tests, F.tests] + +main :: IO () +main = do + hSetBuffering stdout LineBuffering + hSetBuffering stderr LineBuffering + + results <- tests + + unless (and results) exitFailure