diff --git a/profunctor-optics.cabal b/profunctor-optics.cabal --- a/profunctor-optics.cabal +++ b/profunctor-optics.cabal @@ -1,18 +1,16 @@ cabal-version: >= 1.10 name: profunctor-optics -version: 0.0.1 -synopsis: An optics library compatible with the typeclasses in 'profunctors'. +version: 0.0.2 +synopsis: A compact optics library compatible with the typeclasses in profunctors. description: This package provides utilities for creating and manipulating profunctor-based optics. Some highlights: . - Full complement of isos, prisms, lenses, grates, affines, traversals, cotraversals, views, setters, folds, and more. - . - Composable indexed or co-indexed variants of most of the above. + Full complement of isos, prisms, lenses, grates, traversals, cotraversals, views, setters, folds, and more. . - Compact & straight-forward implementation. No inscrutable internal modules, lawless or otherwise ancillary typeclasses, or heavy type-level machinery. + Compact & straight-forward implementation. . - Fully interoperable. All that is required to create optics (standard, indexable, or co-indexable) is the `profunctors` package. Optics compose with (.) from `Prelude` as is typical. If you want to provide profunctor optics for your own types in your own libraries, you can do so without incurring a dependency on this package. Conversions to & from the Van Laarhoven representations are provided for each optic type. + Fully interoperable. All that is required to create optics is the `profunctors` package. Optics compose with (.) from `Prelude` as is typical. Conversions to & from the Van Laarhoven representations are provided for each optic type. . Well-documented properties and exportable predicates for testing your own optics. . @@ -37,33 +35,24 @@ library exposed-modules: - Control.Exception.Optic - - Data.Either.Optic Data.Tuple.Optic + Data.Either.Optic Data.Profunctor.Optic Data.Profunctor.Optic.Types Data.Profunctor.Optic.Property Data.Profunctor.Optic.Carrier - Data.Profunctor.Optic.Operator - Data.Profunctor.Optic.Index + Data.Profunctor.Optic.Combinator Data.Profunctor.Optic.Iso Data.Profunctor.Optic.Prism Data.Profunctor.Optic.Lens - Data.Profunctor.Optic.Grate - Data.Profunctor.Optic.Affine - Data.Profunctor.Optic.Option Data.Profunctor.Optic.Traversal Data.Profunctor.Optic.Fold - Data.Profunctor.Optic.Cotraversal Data.Profunctor.Optic.Setter Data.Profunctor.Optic.View Data.Profunctor.Optic.Zoom - Data.Profunctor.Optic.Prelude - other-modules: Data.Profunctor.Optic.Import default-language: Haskell2010 @@ -90,37 +79,17 @@ build-depends: base >= 4.9 && < 5.0 , adjunctions >= 4.4 && < 5.0 - , connections >= 0.0.3 && < 0.1 + , coapplicative >= 0.0.1 && < 0.2 , distributive >= 0.3 && < 1 - , keys >= 3.12 && < 3.13 + , lawz >= 0.1.1 && < 0.2 , mtl >= 2.0.1 && < 2.3 , newtype-generics >= 0.5.3 && < 0.6 - , profunctor-arrows >= 0.0.0.3 && < 0.0.1 , profunctors >= 5.4 && < 6 - , rings >= 0.0.3.1 && < 0.0.4 - , magmas >= 0.0.1 && < 0.1 + , rings >= 0.1.3 && < 0.1.4 , semigroupoids >= 5 && < 6 , tagged >= 0.4.4 && < 1 , transformers >= 0.5 && < 0.6 - , unliftio-core >= 0.1.2 && < 0.2 -test-suite test - type: exitcode-stdio-1.0 - main-is: test.hs - ghc-options: -Wall -threaded - hs-source-dirs: test - default-language: Haskell2010 - other-modules: Test.Data.Connection.Optic.Int - build-depends: - base == 4.* - , connections - , profunctor-optics - , hedgehog - default-extensions: - ScopedTypeVariables, - TypeApplications - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall - executable doctest main-is: doctest.hs ghc-options: -Wall -threaded @@ -130,11 +99,7 @@ build-depends: base - , adjunctions - , containers - , connections , doctest >= 0.8 - , ilist , mtl , profunctor-optics diff --git a/src/Control/Exception/Optic.hs b/src/Control/Exception/Optic.hs deleted file mode 100644 --- a/src/Control/Exception/Optic.hs +++ /dev/null @@ -1,418 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} -module Control.Exception.Optic ( - -- * Common optics - non' - , unlifted - , exmapped - , exception - , pattern Exception - -- * Derived operators - , throws - , throws_ - , throwsTo - , tries - , tries_ - , catches - , catches_ - , handles - , handles_ - , ioException - -- * IO Error Fields - , ioeLocation - , ioeDescription - , ioeHandle - , ioeFileName - , ioeErrno - , ioeErrorType - -- * IO Error Types - , alreadyExists - , noSuchThing - , resourceBusy - , resourceExhausted - , eof - , illegalOperation - , permissionDenied - , userError - , unsatisfiedConstraints - , systemError - , protocolError - , otherError - , invalidArgument - , inappropriateType - , hardwareFault - , unsupportedOperation - -- * Async Exceptions - , sync - , async - , asyncException - , pattern AsyncException - , timeExpired - , resourceVanished - , interrupted - , stackOverflow - , heapOverflow - , threadKilled - , userInterrupt - -- * Arithmetic exceptions - , overflow - , underflow - , lossOfPrecision - , divideByZero - , denormal - , ratioZeroDenominator - -- * Array Exceptions - , indexOutOfBounds - , undefinedElement - -- * Miscellaneous Exceptions - , illegal - , assertionFailed - , nonTermination - , nestedAtomically - , blockedIndefinitelyOnMVar - , blockedIndefinitelyOnSTM - , deadlock - , noMethodError - , patternMatchFail - , recConError - , recSelError - , recUpdError - , errorCall - , allocationLimitExceeded -) where - -import Control.Exception (Exception(..), SomeException, - AsyncException(..), IOException, ArithException(..), ArrayException(..)) -import Data.Maybe (fromMaybe) -import Data.Profunctor.Optic -import Data.Profunctor.Optic.Import -import Foreign.C.Types -import GHC.IO.Exception (IOErrorType) -import System.IO -import Prelude (String) -import qualified Control.Exception as Ex -import qualified GHC.IO.Exception as Ghc - -pattern Exception :: forall a. Exception a => a -> SomeException -pattern Exception e <- (preview exception -> Just e) where Exception e = review exception e - -pattern AsyncException :: forall a. Exception a => a -> SomeException -pattern AsyncException e <- (preview asyncException -> Just e) where AsyncException e = review asyncException e - --- | Generate an isomorphism between @'Maybe' (a | 'isnt' p a)@ and @a@. --- --- @'non'' p@ generalizes @'non' (p # ())@ to take any unit 'Prism' --- -non' :: Prism' a () -> Iso' (Maybe a) a -non' p = iso (fromMaybe def) go where - def = review p () - go b | p `isnt` b = Just b - | otherwise = Nothing -{-# INLINE non' #-} - ----------------------------------------------------------------------------------------------------- --- IO Exceptions ----------------------------------------------------------------------------------------------------- - --- | Exceptions that occur in the 'IO' 'Monad'. --- --- An 'IOException' records a more specific error type, a descriptive string and possibly the handle --- that was used when the error was flagged. --- -ioException :: Prism' SomeException IOException -ioException = exception - --- | Where the error happened. --- -ioeLocation :: Lens' IOException String -ioeLocation = lens Ghc.ioe_location $ \s e -> s { Ghc.ioe_location = e } - --- | Error type specific information. --- -ioeDescription :: Lens' IOException String -ioeDescription = lens Ghc.ioe_description $ \s e -> s { Ghc.ioe_description = e } - --- | The handle used by the action flagging this error. --- -ioeHandle :: Lens' IOException (Maybe Handle) -ioeHandle = lens Ghc.ioe_handle $ \s e -> s { Ghc.ioe_handle = e } - --- | 'fileName' the error is related to. --- -ioeFileName :: Lens' IOException (Maybe FilePath) -ioeFileName = lens Ghc.ioe_filename $ \s e -> s { Ghc.ioe_filename = e } - --- | 'errno' leading to this error, if any. --- -ioeErrno :: Lens' IOException (Maybe CInt) -ioeErrno = lens Ghc.ioe_errno $ \s e -> s { Ghc.ioe_errno = e } - -ioeErrorType :: Lens' IOException IOErrorType -ioeErrorType = lens Ghc.ioe_type $ \s e -> s { Ghc.ioe_type = e } - ----------------------------------------------------------------------------------------------------- --- IO Error Types ----------------------------------------------------------------------------------------------------- - --- | TODO: Document --- -alreadyExists :: Prism' IOErrorType () -alreadyExists = only Ghc.AlreadyExists - --- | TODO: Document --- -noSuchThing :: Prism' IOErrorType () -noSuchThing = only Ghc.NoSuchThing - --- | TODO: Document --- -resourceBusy :: Prism' IOErrorType () -resourceBusy = only Ghc.ResourceBusy - --- | TODO: Document --- -resourceExhausted :: Prism' IOErrorType () -resourceExhausted = only Ghc.ResourceExhausted - --- | TODO: Document --- -eof :: Prism' IOErrorType () -eof = only Ghc.EOF - --- | TODO: Document --- -illegalOperation :: Prism' IOErrorType () -illegalOperation = only Ghc.IllegalOperation - --- | TODO: Document --- -permissionDenied :: Prism' IOErrorType () -permissionDenied = only Ghc.PermissionDenied - --- | TODO: Document --- -userError :: Prism' IOErrorType () -userError = only Ghc.UserError - --- | TODO: Document --- -unsatisfiedConstraints :: Prism' IOErrorType () -unsatisfiedConstraints = only Ghc.UnsatisfiedConstraints - --- | TODO: Document --- -systemError :: Prism' IOErrorType () -systemError = only Ghc.SystemError - --- | TODO: Document --- -protocolError :: Prism' IOErrorType () -protocolError = only Ghc.ProtocolError - --- | TODO: Document --- -otherError :: Prism' IOErrorType () -otherError = only Ghc.OtherError - --- | TODO: Document --- -invalidArgument :: Prism' IOErrorType () -invalidArgument = only Ghc.InvalidArgument - --- | TODO: Document --- -inappropriateType :: Prism' IOErrorType () -inappropriateType = only Ghc.InappropriateType - --- | TODO: Document --- -hardwareFault :: Prism' IOErrorType () -hardwareFault = only Ghc.HardwareFault - --- | TODO: Document --- -unsupportedOperation :: Prism' IOErrorType () -unsupportedOperation = only Ghc.UnsupportedOperation - --- | TODO: Document --- -timeExpired :: Prism' IOErrorType () -timeExpired = only Ghc.TimeExpired - --- | TODO: Document --- -resourceVanished :: Prism' IOErrorType () -resourceVanished = only Ghc.ResourceVanished - --- | TODO: Document --- -interrupted :: Prism' IOErrorType () -interrupted = only Ghc.Interrupted - ----------------------------------------------------------------------------------------------------- --- Async Exceptions ----------------------------------------------------------------------------------------------------- - --- | The current thread's stack exceeded its limit. Since an 'Exception' has --- been raised, the thread's stack will certainly be below its limit again, --- but the programmer should take remedial action immediately. --- -stackOverflow :: Prism' AsyncException () -stackOverflow = only Ex.StackOverflow - --- | The program's heap usage has exceeded its limit. --- --- See 'GHC.IO.Exception' for more information. --- -heapOverflow :: Prism' AsyncException () -heapOverflow = only Ex.HeapOverflow - --- | This 'Exception' is raised by another thread calling --- 'Control.Concurrent.killThread', or by the system if it needs to terminate --- the thread for some reason. --- -threadKilled :: Prism' AsyncException () -threadKilled = only Ex.ThreadKilled - --- | This 'Exception' is raised by default in the main thread of the program when --- the user requests to terminate the program via the usual mechanism(s) --- (/e.g./ Control-C in the console). --- -userInterrupt :: Prism' AsyncException () -userInterrupt = only Ex.UserInterrupt - ----------------------------------------------------------------------------------------------------- --- Arithmetic exceptions ----------------------------------------------------------------------------------------------------- - --- | Detect arithmetic overflow. --- -overflow :: Prism' ArithException () -overflow = only Ex.Overflow - --- | Detect arithmetic underflow. --- -underflow :: Prism' ArithException () -underflow = only Ex.Underflow - --- | Detect arithmetic loss of precision. --- -lossOfPrecision :: Prism' ArithException () -lossOfPrecision = only Ex.LossOfPrecision - --- | Detect division by zero. --- -divideByZero :: Prism' ArithException () -divideByZero = only Ex.DivideByZero - --- | Detect whether a FLOP was performed on a subnormal number. --- -denormal :: Prism' ArithException () -denormal = only Ex.Denormal - --- | Detect zero denominators. --- -ratioZeroDenominator :: Prism' ArithException () -ratioZeroDenominator = only Ex.RatioZeroDenominator - ----------------------------------------------------------------------------------------------------- --- Array Exceptions ----------------------------------------------------------------------------------------------------- - --- | Detect attempts to index an array outside its declared bounds. --- -indexOutOfBounds :: Prism' ArrayException String -indexOutOfBounds = dimap sta join . right' . rmap Ex.IndexOutOfBounds - where sta (Ex.IndexOutOfBounds r) = Right r - sta t = Left t - --- | Detect attempts to evaluate an element of an array that has not been initialized. --- -undefinedElement :: Prism' ArrayException String -undefinedElement = dimap sta join . right' . rmap Ex.UndefinedElement - where sta (Ex.UndefinedElement r) = Right r - sta t = Left t - ----------------------------------------------------------------------------------------------------- --- Miscellaneous Exceptions ----------------------------------------------------------------------------------------------------- - --- hack to get prisms for exceptions w/o an Eq instance -illegal :: Profunctor p => t -> Optic' p t () -illegal t = const () `dimap` const t - -assertionFailed :: Prism' Ex.AssertionFailed String -assertionFailed = iso (\(Ex.AssertionFailed a) -> a) Ex.AssertionFailed - --- | Thrown when the runtime system detects that the computation is guaranteed --- not to terminate. Note that there is no guarantee that the runtime system --- will notice whether any given computation is guaranteed to terminate or not. --- -nonTermination :: Prism' Ex.NonTermination () -nonTermination = illegal Ex.NonTermination - --- | Thrown when the program attempts to call atomically, from the --- 'Control.Monad.STM' package, inside another call to atomically. --- -nestedAtomically :: Prism' Ex.NestedAtomically () -nestedAtomically = illegal Ex.NestedAtomically - --- | The thread is blocked on an 'Control.Concurrent.MVar.MVar', but there --- are no other references to the 'Control.Concurrent.MVar.MVar' so it can't --- ever continue. --- -blockedIndefinitelyOnMVar :: Prism' Ex.BlockedIndefinitelyOnMVar () -blockedIndefinitelyOnMVar = illegal Ex.BlockedIndefinitelyOnMVar - --- | The thread is waiting to retry an 'Control.Monad.STM.STM' transaction, --- but there are no other references to any TVars involved, so it can't ever --- continue. --- -blockedIndefinitelyOnSTM :: Prism' Ex.BlockedIndefinitelyOnSTM () -blockedIndefinitelyOnSTM = illegal Ex.BlockedIndefinitelyOnSTM - --- | There are no runnable threads, so the program is deadlocked. The --- 'Deadlock' 'Exception' is raised in the main thread only. --- -deadlock :: Prism' Ex.Deadlock () -deadlock = illegal Ex.Deadlock - --- | A class method without a definition (neither a default definition, --- nor a definition in the appropriate instance) was called. --- -noMethodError :: Prism' Ex.NoMethodError String -noMethodError = iso (\(Ex.NoMethodError a) -> a) Ex.NoMethodError - --- | A pattern match failed. --- -patternMatchFail :: Prism' Ex.PatternMatchFail String -patternMatchFail = iso (\(Ex.PatternMatchFail a) -> a) Ex.PatternMatchFail - --- | An uninitialised record field was used. --- -recConError :: Prism' Ex.RecConError String -recConError = iso (\(Ex.RecConError a) -> a) Ex.RecConError - --- | A record selector was applied to a constructor without the appropriate --- field. This can only happen with a datatype with multiple constructors, --- where some fields are in one constructor but not another. --- -recSelError :: Prism' Ex.RecSelError String -recSelError = iso (\(Ex.RecSelError a) -> a) Ex.RecSelError - --- | A record update was performed on a constructor without the --- appropriate field. This can only happen with a datatype with multiple --- constructors, where some fields are in one constructor but not another. --- -recUpdError :: Prism' Ex.RecUpdError String -recUpdError = iso (\(Ex.RecUpdError a) -> a) Ex.RecUpdError - --- | Thrown when the user calls 'Prelude.error'. --- -errorCall :: Prism' Ex.ErrorCall String -errorCall = iso (\(Ex.ErrorCall a) -> a) Ex.ErrorCall - --- | This thread has exceeded its allocation limit. --- -allocationLimitExceeded :: Prism' Ex.AllocationLimitExceeded () -allocationLimitExceeded = illegal Ex.AllocationLimitExceeded 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 @@ -6,39 +6,29 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} module Data.Profunctor.Optic ( - module Type - , module Property + module Types , module Carrier , module Operator - , module Index , module Iso - , module Lens , module Prism - , module Grate - , module Affine - , module Option + , module Lens , module Traversal , module Fold - , module Cotraversal , module View , module Setter + , module Tuple , module Zoom ) where -import Data.Profunctor.Optic.Types as Type -import Data.Profunctor.Optic.Property as Property +import Data.Profunctor.Optic.Types as Types import Data.Profunctor.Optic.Carrier as Carrier -import Data.Profunctor.Optic.Operator as Operator -import Data.Profunctor.Optic.Index as Index +import Data.Profunctor.Optic.Combinator as Operator import Data.Profunctor.Optic.Iso as Iso -import Data.Profunctor.Optic.Lens as Lens import Data.Profunctor.Optic.Prism as Prism -import Data.Profunctor.Optic.Grate as Grate -import Data.Profunctor.Optic.Affine as Affine -import Data.Profunctor.Optic.Option as Option +import Data.Profunctor.Optic.Lens as Lens import Data.Profunctor.Optic.Traversal as Traversal import Data.Profunctor.Optic.Fold as Fold -import Data.Profunctor.Optic.Cotraversal as Cotraversal import Data.Profunctor.Optic.View as View import Data.Profunctor.Optic.Setter as Setter import Data.Profunctor.Optic.Zoom as Zoom +import Data.Tuple.Optic as Tuple diff --git a/src/Data/Profunctor/Optic/Affine.hs b/src/Data/Profunctor/Optic/Affine.hs deleted file mode 100644 --- a/src/Data/Profunctor/Optic/Affine.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -module Data.Profunctor.Optic.Affine ( - -- * Affine & Ixaffine - Affine - , Affine' - , Ixaffine - , Ixaffine' - , affine - , affine' - , iaffine - , iaffine' - , affineVl - , iaffineVl - -- * Optics - , nulled - , selected - -- * Primitive operators - , withAffine - -- * Operators - , matches - -- * Classes - , Strong(..) - , Choice(..) -) where - -import Data.Bifunctor (first, second) -import Data.Profunctor.Optic.Carrier -import Data.Profunctor.Optic.Lens -import Data.Profunctor.Optic.Prism -import Data.Profunctor.Optic.Import -import Data.Profunctor.Optic.Types hiding (branch) - --- $setup --- >>> :set -XNoOverloadedStrings --- >>> :set -XFlexibleContexts --- >>> :set -XTypeApplications --- >>> :set -XTupleSections --- >>> :set -XRankNTypes --- >>> import Data.Maybe --- >>> import Data.List.NonEmpty (NonEmpty(..)) --- >>> import qualified Data.List.NonEmpty as NE --- >>> import Data.Functor.Identity --- >>> import Data.List.Index --- >>> :load Data.Profunctor.Optic - ---------------------------------------------------------------------- --- 'Affine' & 'Ixaffine' ---------------------------------------------------------------------- - --- | Create a 'Affine' from match and constructor functions. --- --- /Caution/: In order for the 'Affine' to be well-defined, --- you must ensure that the input functions satisfy the following --- properties: --- --- * @sta (sbt a s) ≡ either (Left . const a) Right (sta s)@ --- --- * @either id (sbt s) (sta s) ≡ s@ --- --- * @sbt (sbt s a1) a2 ≡ sbt s a2@ --- --- More generally, a profunctor optic must be monoidal as a natural --- transformation: --- --- * @o id ≡ id@ --- --- * @o ('Data.Profunctor.Composition.Procompose' p q) ≡ 'Data.Profunctor.Composition.Procompose' (o p) (o q)@ --- --- See 'Data.Profunctor.Optic.Property'. --- -affine :: (s -> t + a) -> (s -> b -> t) -> Affine s t a b -affine sta sbt = dimap (\s -> (s,) <$> sta s) (id ||| uncurry sbt) . right' . second' - --- | Obtain a 'Affine'' from match and constructor functions. --- -affine' :: (s -> Maybe a) -> (s -> a -> s) -> Affine' s a -affine' sa sas = flip affine sas $ \s -> maybe (Left s) Right (sa s) - --- | TODO: Document --- -iaffine :: (s -> t + (i , a)) -> (s -> b -> t) -> Ixaffine i s t a b -iaffine stia sbt = iaffineVl $ \point f s -> either point (fmap (sbt s) . uncurry f) (stia s) - --- | TODO: Document --- -iaffine' :: (s -> Maybe (i , a)) -> (s -> a -> s) -> Ixaffine' i s a -iaffine' sia = iaffine $ \s -> maybe (Left s) Right (sia s) - --- | Transform a Van Laarhoven 'Affine' into a profunctor 'Affine'. --- -affineVl :: (forall f. Functor f => (forall c. c -> f c) -> (a -> f b) -> s -> f t) -> Affine s t a b -affineVl f = dimap (\s -> (s,) <$> eswap (sat s)) (id ||| uncurry sbt) . right' . second' - where - sat = f Right Left - sbt s b = runIdentity $ f Identity (\_ -> Identity b) s - --- | Transform an indexed Van Laarhoven 'Affine' into an indexed profunctor 'Affine'. --- -iaffineVl :: (forall f. Functor f => (forall c. c -> f c) -> (i -> a -> f b) -> s -> f t) -> Ixaffine i s t a b -iaffineVl f = affineVl $ \cc iab -> f cc (curry iab) . snd - ---------------------------------------------------------------------- --- Optics ---------------------------------------------------------------------- - --- | TODO: Document --- -nulled :: Affine' s a -nulled = affine Left const -{-# INLINE nulled #-} - --- | TODO: Document --- -selected :: (a -> Bool) -> Affine' (a, b) b -selected p = affine (\kv@(k,v) -> branch p kv v k) (\kv@(k,_) v' -> if p k then (k,v') else kv) -{-# INLINE selected #-} - ---------------------------------------------------------------------- --- Operators ---------------------------------------------------------------------- - --- | Test whether the optic matches or not. --- --- >>> matches just (Just 2) --- Right 2 --- --- >>> matches just (Nothing :: Maybe Int) :: Either (Maybe Bool) Int --- Left Nothing --- -matches :: AAffine s t a b -> s -> t + a -matches o = withAffine o $ \sta _ -> sta -{-# INLINE matches #-} diff --git a/src/Data/Profunctor/Optic/Carrier.hs b/src/Data/Profunctor/Optic/Carrier.hs --- a/src/Data/Profunctor/Optic/Carrier.hs +++ b/src/Data/Profunctor/Optic/Carrier.hs @@ -5,52 +5,37 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} module Data.Profunctor.Optic.Carrier ( -- * Carrier types AIso , AIso' , APrism , APrism' + , ACoprism + , ACoprism' , ALens , ALens' - , AIxlens - , AIxlens' - , AGrate - , AGrate' - , ACxgrate - , ACxgrate' - , AAffine - , AAffine' - , AOption - , AIxoption - , AGrism - , AGrism' + , AColens + , AColens' , ARepn , ARepn' - , AIxrepn - , AIxrepn' + , AGrate + , AGrate' + , ACorepn + , ACorepn' + , ATraversal0 + , ATraversal0' , ATraversal , ATraversal' - , AIxtraversal - , AIxtraversal' , ATraversal1 , ATraversal1' - , AIxtraversal1 - , AIxtraversal1' - , AFold - , AIxfold - , AFold1 - , AIxfold1 - , APrimView - , AView - , AIxview - , AIxsetter - , AIxsetter' - , ACorepn - , ACorepn' - , ACxrepn' + , ACotraversal0 + , ACotraversal0' , ACotraversal , ACotraversal' + , ACotraversal1 + , ACotraversal1' , AList , AList' , AList1 @@ -59,65 +44,81 @@ , AScope' , AScope1 , AScope1' - , APrimReview + , AFold0 + , AFold + , AFold1 + , ACofold + , AView , AReview - , ACxview - , ACxsetter - , ACxsetter' -- * Primitive operators , withIso , withPrism + , withCoprism , withLens - , withIxlens + , withColens + , withLensVl , withGrate - , withCxgrate + , withGrateVl , withAffine - , withGrism - , withOption - , withIxoption , withStar + , withCoaffine , withCostar - , withPrimView - , withPrimReview - , withIxsetter - , withCxsetter + , withFold0 + , withFold + , withFold1 + , withCofold + , withView + , withReview -- * Carrier profunctors , IsoRep(..) , PrismRep(..) + , CoprismRep(..) + , Cotraversal0Rep(..) , LensRep(..) - , IxlensRep(..) + , ColensRep(..) , GrateRep(..) - , CxgrateRep(..) - , AffineRep(..) - , GrismRep(..) - , OptionRep(..) + , Traversal0Rep(..) + , Fold0Rep(..) , Star(..) , Costar(..) , Tagged(..) + -- * Index + , Index(..) + , vals + , info + -- * Coindex + , Coindex(..) + , trivial + , noindex + , coindex + , (.#.) + -- * Conjoin + , Conjoin(..) ) where +import Control.Category (Category) +import Control.Monad.Fix (MonadFix(..)) import Data.Profunctor.Types as Export (Star(..), Costar(..)) import Data.Bifunctor as B import Data.Function import Data.Profunctor.Optic.Types import Data.Profunctor.Optic.Import -import Data.Profunctor.Optic.Index -import Data.Profunctor.Extra as Extra +import Data.Profunctor.Optic.Combinator import Data.Profunctor.Rep (unfirstCorep) +import GHC.Generics (Generic) -import qualified Data.Bifunctor as B +import qualified Control.Arrow as A +import qualified Control.Category as C + -- $setup -- >>> :set -XNoOverloadedStrings -- >>> :set -XTypeApplications -- >>> :set -XFlexibleContexts -- >>> :set -XRankNTypes --- >>> import Control.Exception hiding (catches) -- >>> import Data.Functor.Identity --- >>> import Data.List.Index as LI -- >>> import Data.Map as Map -- >>> import Data.Maybe -- >>> import Data.Monoid --- >>> import Data.Semiring hiding (unital,nonunital,presemiring) -- >>> :load Data.Profunctor.Optic --------------------------------------------------------------------- @@ -132,87 +133,61 @@ type APrism' s a = APrism s s a a +type ACoprism s t a b = Optic (CoprismRep a b) s t a b + +type ACoprism' s a = ACoprism s s a a + type ALens s t a b = Optic (LensRep a b) s t a b type ALens' s a = ALens s s a a -type AIxlens i s t a b = IndexedOptic (IxlensRep i a b) i s t a b +type AColens s t a b = Optic (ColensRep a b) s t a b -type AIxlens' i s a = AIxlens i s s a a +type AColens' s a = AColens s s a a type AGrate s t a b = Optic (GrateRep a b) s t a b type AGrate' s a = AGrate s s a a -type ACxgrate k s t a b = CoindexedOptic (CxgrateRep k a b) k s t a b - -type ACxgrate' k s a = ACxgrate k s s a a - -type AAffine s t a b = Optic (AffineRep a b) s t a b - -type AAffine' s a = AAffine s s a a - -type AOption r s a = Optic' (OptionRep r) s a - -type AIxoption r i s a = IndexedOptic' (OptionRep r) i s a - -type AGrism s t a b = Optic (GrismRep a b) s t a b - -type AGrism' s a = AGrism s s a a - type ARepn f s t a b = Optic (Star f) s t a b type ARepn' f s a = ARepn f s s a a -type AIxrepn f i s t a b = IndexedOptic (Star f) i s t a b +type ACorepn f s t a b = Optic (Costar f) s t a b -type AIxrepn' f i s a = AIxrepn f i s s a a +type ACorepn' f t b = ACorepn f t t b b -type ATraversal f s t a b = Applicative f => ARepn f s t a b +type ATraversal0 s t a b = Optic (Traversal0Rep a b) s t a b -type ATraversal' f s a = ATraversal f s s a a +type ATraversal0' s a = ATraversal0 s s a a -type AIxtraversal f i s t a b = Applicative f => AIxrepn f i s t a b +type ATraversal f s t a b = Applicative f => ARepn f s t a b -type AIxtraversal' f i s a = AIxtraversal f i s s a a +type ATraversal' f s a = ATraversal f s s a a type ATraversal1 f s t a b = Apply f => ARepn f s t a b type ATraversal1' f s a = ATraversal1 f s s a a -type AIxtraversal1 f i s t a b = Apply f => AIxrepn f i s t a b - -type AIxtraversal1' f i s a = AIxtraversal1 f i s s a a - -type AFold r s a = ARepn' (Const r) s a - -type AIxfold r i s a = AIxrepn' (Const r) i s a - -type AFold1 r s a = ARepn' (Const r) s a - -type AIxfold1 r i s a = AIxrepn' (Const r) i s a - -type APrimView r s t a b = ARepn (Const r) s t a b - -type AView s a = ARepn' (Const a) s a +type ACotraversal0 s t a b = Optic (Cotraversal0Rep a b) s t a b -type AIxview i s a = AIxrepn' (Const (Maybe i , a)) i s a +type ACotraversal0' s a = ACotraversal0 s s a a -type AIxsetter i s t a b = IndexedOptic (->) i s t a b +type ACotraversal f s t a b = Coapplicative f => ACorepn f s t a b -type AIxsetter' i s a = AIxsetter i s s a a +type ACotraversal' f s a = ACotraversal f s s a a -type ACorepn f s t a b = Optic (Costar f) s t a b +type ACotraversal1 f s t a b = Coapply f => ACorepn f s t a b -type ACorepn' f t b = ACorepn f t t b b +type ACotraversal1' f s a = ACotraversal1 f s s a a -type ACxrepn f k s t a b = CoindexedOptic (Costar f) k s t a b +type AFold0 r s a = Optic' (Fold0Rep r) s a -type ACxrepn' f k t b = ACxrepn f k t t b b +type AFold r s a = Monoid r => ARepn' (Const r) s a -type ACotraversal f s t a b = Coapplicative f => ACorepn f s t a b +type AFold1 r s a = Semigroup r => ARepn' (Const r) s a -type ACotraversal' f s a = ACotraversal f s s a a +type ACofold r t b = ACorepn' (Const r) t b type AList f s t a b = Foldable f => ACorepn f s t a b @@ -230,16 +205,10 @@ type AScope1' f s a = AScope1 f s s a a -type APrimReview s t a b = Optic Tagged s t a b +type AView r s a = ARepn' (Const r) s a type AReview t b = Optic' Tagged t b -type ACxview k t b = CoindexedOptic' Tagged k t b - -type ACxsetter k s t a b = CoindexedOptic (->) k s t a b - -type ACxsetter' k t b = ACxsetter k t t b b - -- | Extract the two functions that characterize an 'Iso'. -- withIso :: AIso s t a b -> ((s -> a) -> (b -> t) -> r) -> r @@ -250,47 +219,76 @@ -- withPrism :: APrism s t a b -> ((s -> t + a) -> (b -> t) -> r) -> r withPrism o f = case o (PrismRep Right id) of PrismRep g h -> f g h +{-# INLINE withPrism #-} +-- | Extract the two functions that characterize a 'Coprism'. +-- +withCoprism :: ACoprism s t a b -> ((s -> a) -> (b -> a + t) -> r) -> r +withCoprism o f = case o (CoprismRep id Right) of CoprismRep g h -> f g h + -- | Extract the two functions that characterize a 'Lens'. -- withLens :: ALens s t a b -> ((s -> a) -> (s -> b -> t) -> r) -> r withLens o f = case o (LensRep id (flip const)) of LensRep x y -> f x y +{-# INLINE withLens #-} --- | Extract the two functions that characterize a 'Lens'. +-- | Extract the two functions that characterize a 'Colens'. -- -withIxlens :: (Additive-Monoid) i => AIxlens i s t a b -> ((s -> (i , a)) -> (s -> b -> t) -> r) -> r -withIxlens o f = case o (IxlensRep id $ flip const) of IxlensRep x y -> f (x . (zero,)) (\s b -> y (zero, s) b) +withColens :: AColens s t a b -> ((b -> s -> a) -> (b -> t) -> r) -> r +withColens l f = case l (ColensRep (flip const) id) of ColensRep x y -> f x y +-- | Extract the higher order function that characterizes a 'Lens'. +-- +-- The lens laws can be stated in terms of 'withLens': +-- +-- Identity: +-- +-- @ +-- withLensVl o Identity ≡ Identity +-- @ +-- +-- Composition: +-- +-- @ +-- Compose . fmap (withLensVl o f) . withLensVl o g ≡ withLensVl o (Compose . fmap f . g) +-- @ +-- +-- See 'Data.Profunctor.Optic.Property'. +-- +withLensVl :: Functor f => ALens s t a b -> (a -> f b) -> s -> f t +withLensVl o ab s = withLens o $ \sa sbt -> sbt s <$> ab (sa s) + -- | Extract the function that characterizes a 'Grate'. -- withGrate :: AGrate s t a b -> ((((s -> a) -> b) -> t) -> r) -> r withGrate o f = case o (GrateRep $ \k -> k id) of GrateRep sabt -> f sabt {-# INLINE withGrate #-} -withCxgrate :: (Additive-Monoid) k => ACxgrate k s t a b -> ((((s -> a) -> k -> b) -> t) -> r) -> r -withCxgrate o sakbtr = case o (CxgrateRep $ \f -> f id) of CxgrateRep sakbt -> sakbtr $ flip sakbt zero - --- | TODO: Document --- -withAffine :: AAffine s t a b -> ((s -> t + a) -> (s -> b -> t) -> r) -> r -withAffine o k = case o (AffineRep Right $ const id) of AffineRep x y -> k x y - --- | TODO: Document +-- | Extract the higher order function that characterizes a 'Grate'. -- -withGrism :: AGrism s t a b -> ((((s -> t + a) -> b) -> t) -> r) -> r -withGrism o k = case o (GrismRep $ \f -> f Right) of GrismRep g -> k g - --- | TODO: Document +-- The grate laws can be stated in terms or 'withGrate': +-- +-- Identity: +-- +-- @ +-- withGrateVl o runIdentity ≡ runIdentity +-- @ +-- +-- Composition: +-- +-- @ +-- withGrateVl o f . fmap (withGrateVl o g) ≡ withGrateVl o (f . fmap g . getCompose) . Compose +-- @ -- -withOption :: Optic (OptionRep r) s t a b -> (a -> Maybe r) -> s -> Maybe r -withOption o = runOptionRep #. o .# OptionRep -{-# INLINE withOption #-} +withGrateVl :: Functor f => AGrate s t a b -> (f a -> b) -> f s -> t +withGrateVl o ab s = withGrate o $ \sabt -> sabt $ \get -> ab (fmap get s) +{-# INLINE withGrateVl #-} -- | TODO: Document -- -withIxoption :: (Additive-Monoid) i => AIxoption r i s a -> (i -> a -> Maybe r) -> s -> Maybe r -withIxoption o f = flip curry zero $ withOption o (uncurry f) -{-# INLINE withIxoption #-} +withAffine :: ATraversal0 s t a b -> ((s -> t + a) -> (s -> b -> t) -> r) -> r +withAffine o k = case o (Traversal0Rep Right $ const id) of Traversal0Rep x y -> k x y +{-# INLINE withAffine #-} -- | TODO: Document -- @@ -300,33 +298,66 @@ -- | TODO: Document -- +withCoaffine :: ACotraversal0 s t a b -> ((((s -> t + a) -> b) -> t) -> r) -> r +withCoaffine o k = case o (Cotraversal0Rep $ \f -> f Right) of Cotraversal0Rep g -> k g +{-# INLINE withCoaffine #-} + +-- | TODO: Document +-- withCostar :: ACorepn f s t a b -> (f a -> b) -> (f s -> t) withCostar o = runCostar #. o .# Costar {-# INLINE withCostar #-} -- | TODO: Document -- -withPrimView :: APrimView r s t a b -> (a -> r) -> s -> r -withPrimView o = (getConst #.) #. withStar o .# (Const #.) -{-# INLINE withPrimView #-} +withFold0 :: Optic (Fold0Rep r) s t a b -> (a -> Maybe r) -> s -> Maybe r +withFold0 o = runFold0Rep #. o .# Fold0Rep +{-# INLINE withFold0 #-} +-- | Map an optic to a monoid and combine the results. +-- +-- @ +-- 'Data.Foldable.foldMap' = 'withFold' 'folded_' +-- @ +-- +-- >>> withFold both id (["foo"], ["bar", "baz"]) +-- ["foo","bar","baz"] +-- >>> :t withFold traversed +-- withFold traversed +-- :: (Monoid r, Traversable f) => (a -> r) -> f a -> r +-- +withFold :: Monoid r => AFold r s a -> (a -> r) -> s -> r +withFold o = (getConst #.) #. withStar o .# (Const #.) +{-# INLINE withFold #-} + +-- | Map an optic to a semigroup and combine the results. +-- +withFold1 :: Semigroup r => AFold1 r s a -> (a -> r) -> s -> r +withFold1 o = (getConst #.) #. withStar o .# (Const #.) +{-# INLINE withFold1 #-} + -- | TODO: Document -- -withPrimReview :: APrimReview s t a b -> (t -> r) -> b -> r -withPrimReview o f = f . unTagged #. o .# Tagged -{-# INLINE withPrimReview #-} +-- >>> withCofold (from succ) (*2) 3 +-- 7 +-- +-- Compare 'Data.Profunctor.Optic.View.withReview'. +-- +withCofold :: ACofold r t b -> (r -> b) -> r -> t +withCofold o = (.# Const) #. withCostar o .# (.# getConst) +{-# INLINE withCofold #-} -- | TODO: Document -- -withIxsetter :: IndexedOptic (->) i s t a b -> (i -> a -> b) -> i -> s -> t -withIxsetter o = unConjoin #. corepn o .# Conjoin -{-# INLINE withIxsetter #-} +withView :: AView r s a -> (a -> r) -> s -> r +withView o = (getConst #.) #. withStar o .# (Const #.) +{-# INLINE withView #-} -- | TODO: Document -- -withCxsetter :: CoindexedOptic (->) k s t a b -> (k -> a -> b) -> k -> s -> t -withCxsetter o = unConjoin #. repn o .# Conjoin -{-# INLINE withCxsetter #-} +withReview :: AReview t b -> (t -> r) -> b -> r +withReview o f = f . unTagged #. o .# Tagged +{-# INLINE withReview #-} --------------------------------------------------------------------- -- IsoRep @@ -374,6 +405,23 @@ right' (PrismRep sta bt) = PrismRep (either (Left . Left) (first Right . sta)) (Right . bt) {-# INLINE right' #-} +data CoprismRep a b s t = CoprismRep (s -> a) (b -> a + t) + +instance Functor (CoprismRep a b s) where + fmap f (CoprismRep sa bat) = CoprismRep sa (second f . bat) + {-# INLINE fmap #-} + +instance Profunctor (CoprismRep a b) where + lmap f (CoprismRep sa bat) = CoprismRep (sa . f) bat + {-# INLINE lmap #-} + + rmap = fmap + {-# INLINE rmap #-} + +instance Cochoice (CoprismRep a b) where + unleft (CoprismRep sca batc) = CoprismRep (sca . Left) (forgetr $ either (eassocl . batc) Right) + {-# INLINE unleft #-} + --------------------------------------------------------------------- -- LensRep --------------------------------------------------------------------- @@ -401,20 +449,20 @@ tabulate f = LensRep (\s -> info (f s)) (\s -> vals (f s)) --------------------------------------------------------------------- --- IxlensRep +-- ColensRep --------------------------------------------------------------------- -data IxlensRep i a b s t = IxlensRep (s -> (i , a)) (s -> b -> t) - -instance Profunctor (IxlensRep i a b) where - dimap f g (IxlensRep sia sbt) = IxlensRep (sia . f) (\s -> g . sbt (f s)) +data ColensRep a b s t = ColensRep (b -> s -> a) (b -> t) -instance Strong (IxlensRep i a b) where - first' (IxlensRep sia sbt) = - IxlensRep (\(a, _) -> sia a) (\(s, c) b -> (sbt s b, c)) +instance Profunctor (ColensRep a b) where + dimap f g (ColensRep bsa bt) = ColensRep (\b s -> bsa b (f s)) (g . bt) - second' (IxlensRep sia sbt) = - IxlensRep (\(_, a) -> sia a) (\(c, s) b -> (c, sbt s b)) +{- +instance Costrong (ColensRep a b) where + unfirst (ColensRep baca bbc) = ColensRep (curry foo) (forget2 $ bbc . fst) + where foo = uncurry baca . shuffle . B.second bbc --_ . swap --TODO: B.second bbc + shuffle (x,(y,z)) = (y,(x,z)) +-} --------------------------------------------------------------------- -- GrateRep @@ -442,118 +490,105 @@ cotabulate f = GrateRep $ f . Coindex --------------------------------------------------------------------- --- CxgrateRep ---------------------------------------------------------------------- - -newtype CxgrateRep k a b s t = CxgrateRep { unCxgrateRep :: ((s -> a) -> k -> b) -> t } - -instance Profunctor (CxgrateRep k a b) where - dimap f g (CxgrateRep z) = CxgrateRep $ \d -> g (z $ \k -> d (k . f)) - -instance Closed (CxgrateRep k a b) where - closed (CxgrateRep sabt) = CxgrateRep $ \xsab x -> sabt $ \sa -> xsab $ \xs -> sa (xs x) - ---------------------------------------------------------------------- --- AffineRep +-- Traversal0Rep --------------------------------------------------------------------- --- | The `AffineRep` profunctor precisely characterizes an 'Affine'. -data AffineRep a b s t = AffineRep (s -> t + a) (s -> b -> t) +-- | The `Traversal0Rep` profunctor precisely characterizes an 'Traversal0'. +data Traversal0Rep a b s t = Traversal0Rep (s -> t + a) (s -> b -> t) -instance Profunctor (AffineRep a b) where - dimap f g (AffineRep sta sbt) = AffineRep +instance Profunctor (Traversal0Rep a b) where + dimap f g (Traversal0Rep sta sbt) = Traversal0Rep (\a -> first g $ sta (f a)) (\a v -> g (sbt (f a) v)) -instance Strong (AffineRep a b) where - first' (AffineRep sta sbt) = AffineRep +instance Strong (Traversal0Rep a b) where + first' (Traversal0Rep sta sbt) = Traversal0Rep (\(a, c) -> first (,c) $ sta a) (\(a, c) v -> (sbt a v, c)) -instance Choice (AffineRep a b) where - right' (AffineRep sta sbt) = AffineRep +instance Choice (Traversal0Rep a b) where + right' (Traversal0Rep sta sbt) = Traversal0Rep (\eca -> eassocl (second sta eca)) (\eca v -> second (`sbt` v) eca) -instance Sieve (AffineRep a b) (IndexA a b) where - sieve (AffineRep sta sbt) s = IndexA (sta s) (sbt s) +instance Sieve (Traversal0Rep a b) (Index0 a b) where + sieve (Traversal0Rep sta sbt) s = Index0 (sta s) (sbt s) -instance Representable (AffineRep a b) where - type Rep (AffineRep a b) = IndexA a b +instance Representable (Traversal0Rep a b) where + type Rep (Traversal0Rep a b) = Index0 a b - tabulate f = AffineRep (info0 . f) (values0 . f) + tabulate f = Traversal0Rep (info0 . f) (values0 . f) -data IndexA a b r = IndexA (r + a) (b -> r) +data Index0 a b r = Index0 (r + a) (b -> r) -values0 :: IndexA a b r -> b -> r -values0 (IndexA _ br) = br +values0 :: Index0 a b r -> b -> r +values0 (Index0 _ br) = br -info0 :: IndexA a b r -> r + a -info0 (IndexA a _) = a +info0 :: Index0 a b r -> r + a +info0 (Index0 a _) = a -instance Functor (IndexA a b) where - fmap f (IndexA ra br) = IndexA (first f ra) (f . br) +instance Functor (Index0 a b) where + fmap f (Index0 ra br) = Index0 (first f ra) (f . br) -instance Applicative (IndexA a b) where - pure r = IndexA (Left r) (const r) - liftA2 f (IndexA ra1 br1) (IndexA ra2 br2) = IndexA (eswap $ liftA2 f (eswap ra1) (eswap ra2)) (liftA2 f br1 br2) +instance Applicative (Index0 a b) where + pure r = Index0 (Left r) (const r) + liftA2 f (Index0 ra1 br1) (Index0 ra2 br2) = Index0 (eswap $ liftA2 f (eswap ra1) (eswap ra2)) (liftA2 f br1 br2) --------------------------------------------------------------------- --- 'GrismRep' +-- Cotraversal0Rep --------------------------------------------------------------------- --TODO: Corepresentable, Coapplicative (Corep) --- | The 'GrismRep' profunctor precisely characterizes 'Grism'. +-- | The 'Cotraversal0Rep' profunctor precisely characterizes 'Cotraversal0'. -- -newtype GrismRep a b s t = GrismRep { unGrismRep :: ((s -> t + a) -> b) -> t } +newtype Cotraversal0Rep a b s t = Cotraversal0Rep { unCotraversal0Rep :: ((s -> t + a) -> b) -> t } -instance Profunctor (GrismRep a b) where - dimap us tv (GrismRep stabt) = - GrismRep $ \f -> tv (stabt $ \sta -> f (first tv . sta . us)) +instance Profunctor (Cotraversal0Rep a b) where + dimap us tv (Cotraversal0Rep stabt) = + Cotraversal0Rep $ \f -> tv (stabt $ \sta -> f (first tv . sta . us)) -instance Closed (GrismRep a b) where - closed (GrismRep stabt) = - GrismRep $ \f x -> stabt $ \sta -> f $ \xs -> first const $ sta (xs x) +instance Closed (Cotraversal0Rep a b) where + closed (Cotraversal0Rep stabt) = + Cotraversal0Rep $ \f x -> stabt $ \sta -> f $ \xs -> first const $ sta (xs x) -instance Choice (GrismRep a b) where - left' (GrismRep stabt) = - GrismRep $ \f -> Left $ stabt $ \sta -> f $ eassocl . fmap eswap . eassocr . first sta +instance Choice (Cotraversal0Rep a b) where + left' (Cotraversal0Rep stabt) = + Cotraversal0Rep $ \f -> Left $ stabt $ \sta -> f $ eassocl . fmap eswap . eassocr . first sta --------------------------------------------------------------------- --- OptionRep +-- Fold0Rep --------------------------------------------------------------------- -newtype OptionRep r a b = OptionRep { runOptionRep :: a -> Maybe r } +newtype Fold0Rep r a b = Fold0Rep { runFold0Rep :: a -> Maybe r } ---todo coerce -instance Functor (OptionRep r a) where - fmap _ (OptionRep p) = OptionRep p +instance Functor (Fold0Rep r a) where + fmap _ (Fold0Rep p) = Fold0Rep p -instance Contravariant (OptionRep r a) where - contramap _ (OptionRep p) = OptionRep p +instance Contravariant (Fold0Rep r a) where + contramap _ (Fold0Rep p) = Fold0Rep p -instance Profunctor (OptionRep r) where - dimap f _ (OptionRep p) = OptionRep (p . f) +instance Profunctor (Fold0Rep r) where + dimap f _ (Fold0Rep p) = Fold0Rep (p . f) -instance Choice (OptionRep r) where - left' (OptionRep p) = OptionRep (either p (const Nothing)) - right' (OptionRep p) = OptionRep (either (const Nothing) p) +instance Choice (Fold0Rep r) where + left' (Fold0Rep p) = Fold0Rep (either p (const Nothing)) + right' (Fold0Rep p) = Fold0Rep (either (const Nothing) p) -instance Cochoice (OptionRep r) where - unleft (OptionRep k) = OptionRep (k . Left) - unright (OptionRep k) = OptionRep (k . Right) +instance Cochoice (Fold0Rep r) where + unleft (Fold0Rep k) = Fold0Rep (k . Left) + unright (Fold0Rep k) = Fold0Rep (k . Right) -instance Strong (OptionRep r) where - first' (OptionRep p) = OptionRep (p . fst) - second' (OptionRep p) = OptionRep (p . snd) +instance Strong (Fold0Rep r) where + first' (Fold0Rep p) = Fold0Rep (p . fst) + second' (Fold0Rep p) = Fold0Rep (p . snd) -instance Sieve (OptionRep r) (Pre r) where - sieve = (Pre .) . runOptionRep +instance Sieve (Fold0Rep r) (Pre r) where + sieve = (Pre .) . runFold0Rep -instance Representable (OptionRep r) where - type Rep (OptionRep r) = Pre r - tabulate = OptionRep . (getPre .) +instance Representable (Fold0Rep r) where + type Rep (Fold0Rep r) = Pre r + tabulate = Fold0Rep . (getPre .) {-# INLINE tabulate #-} -- | 'Pre' is 'Maybe' with a phantom type variable. @@ -563,3 +598,218 @@ instance Functor (Pre a) where fmap _ (Pre p) = Pre p instance Contravariant (Pre a) where contramap _ (Pre p) = Pre p + + +--------------------------------------------------------------------- +-- Index +--------------------------------------------------------------------- + +-- | An indexed store that characterizes a 'Data.Profunctor.Optic.Lens.Lens' +-- +-- @'Index' a b s ≡ forall f. 'Functor' f => (a -> f b) -> f s@, +-- +-- See also 'Data.Profunctor.Optic.Lens.withLensVl'. +-- +data Index a b s = Index a (b -> s) deriving Generic + +vals :: Index a b s -> b -> s +vals (Index _ bs) = bs +{-# INLINE vals #-} + +info :: Index a b s -> a +info (Index a _) = a +{-# INLINE info #-} + +instance Functor (Index a b) where + fmap f (Index a bs) = Index a (f . bs) + {-# INLINE fmap #-} + +instance Profunctor (Index a) where + dimap f g (Index a bs) = Index a (g . bs . f) + {-# INLINE dimap #-} + +instance a ~ b => Foldable (Index a b) where + foldMap f (Index b bs) = f . bs $ b + +--------------------------------------------------------------------- +-- Coindex +--------------------------------------------------------------------- + +-- | An indexed continuation that characterizes a 'Data.Profunctor.Optic.Grate.Grate' +-- +-- @'Coindex' a b s ≡ forall f. 'Functor' f => (f a -> b) -> f s@, +-- +-- See also 'Data.Profunctor.Optic.Grate.withGrateVl'. +-- +-- 'Coindex' can also be used to compose indexed maps, folds, or traversals directly. +-- +-- For example, using the @containers@ library: +-- +-- @ +-- Coindex mapWithKey :: Coindex (a -> b) (Map k a -> Map k b) k +-- Coindex foldMapWithKey :: Monoid m => Coindex (a -> m) (Map k a -> m) k +-- Coindex traverseWithKey :: Applicative t => Coindex (a -> t b) (Map k a -> t (Map k b)) k +-- @ +-- +newtype Coindex a b s = Coindex { runCoindex :: (s -> a) -> b } deriving Generic + +instance Functor (Coindex a b) where + fmap sl (Coindex ab) = Coindex $ \la -> ab (la . sl) + +instance a ~ b => Apply (Coindex a b) where + (Coindex slab) <.> (Coindex ab) = Coindex $ \la -> slab $ \sl -> ab (la . sl) + +instance a ~ b => Applicative (Coindex a b) where + pure s = Coindex ($s) + (<*>) = (<.>) + +trivial :: Coindex a b a -> b +trivial (Coindex f) = f id +{-# INLINE trivial #-} + +-- | Lift a regular function into a coindexed function. +-- +-- For example, to traverse two layers, keeping only the first index: +-- +-- @ +-- Coindex 'Data.Map.mapWithKey' .#. noindex 'Data.Map.map' +-- :: Monoid k => +-- Coindex (a -> b) (Map k (Map j a) -> Map k (Map j b)) k +-- @ +-- +noindex :: Monoid s => (a -> b) -> Coindex a b s +noindex f = Coindex $ \a -> f (a mempty) + +coindex :: Functor f => s -> (a -> b) -> Coindex (f a) (f b) s +coindex s ab = Coindex $ \sfa -> fmap ab (sfa s) +{-# INLINE coindex #-} + +infixr 9 .#. + +-- | Compose two coindexes. +-- +-- When /s/ is a 'Monoid', 'Coindex' can be used to compose indexed traversals, folds, etc. +-- +-- For example, to keep track of only the first index seen, use @Data.Monoid.First@: +-- +-- @ +-- fmap (First . pure) :: Coindex a b c -> Coindex a b (First c) +-- @ +-- +-- or keep track of all indices using a list: +-- +-- @ +-- fmap (:[]) :: Coindex a b c -> Coindex a b [c] +-- @ +-- +(.#.) :: Semigroup s => Coindex b c s -> Coindex a b s -> Coindex a c s +Coindex f .#. Coindex g = Coindex $ \b -> f $ \s1 -> g $ \s2 -> b (s1 <> s2) + +--------------------------------------------------------------------- +-- Conjoin +--------------------------------------------------------------------- + +-- '(->)' is simultaneously both indexed and co-indexed. +newtype Conjoin j a b = Conjoin { unConjoin :: j -> a -> b } + +instance Functor (Conjoin j a) where + fmap g (Conjoin f) = Conjoin $ \j a -> g (f j a) + {-# INLINE fmap #-} + +instance Apply (Conjoin j a) where + Conjoin f <.> Conjoin g = Conjoin $ \j a -> f j a (g j a) + {-# INLINE (<.>) #-} + +instance Applicative (Conjoin j a) where + pure b = Conjoin $ \_ _ -> b + {-# INLINE pure #-} + Conjoin f <*> Conjoin g = Conjoin $ \j a -> f j a (g j a) + {-# INLINE (<*>) #-} + +instance Monad (Conjoin j a) where + return = pure + {-# INLINE return #-} + Conjoin f >>= k = Conjoin $ \j a -> unConjoin (k (f j a)) j a + {-# INLINE (>>=) #-} + +instance MonadFix (Conjoin j a) where + mfix f = Conjoin $ \ j a -> let o = unConjoin (f o) j a in o + {-# INLINE mfix #-} + +instance Profunctor (Conjoin j) where + dimap ab cd jbc = Conjoin $ \j -> cd . unConjoin jbc j . ab + {-# INLINE dimap #-} + lmap ab jbc = Conjoin $ \j -> unConjoin jbc j . ab + {-# INLINE lmap #-} + rmap bc jab = Conjoin $ \j -> bc . unConjoin jab j + {-# INLINE rmap #-} + +instance Closed (Conjoin j) where + closed (Conjoin jab) = Conjoin $ \j xa x -> jab j (xa x) + +instance Costrong (Conjoin j) where + unfirst (Conjoin jadbd) = Conjoin $ \j a -> let + (b, d) = jadbd j (a, d) + in b + +instance Sieve (Conjoin j) ((->) j) where + sieve = flip . unConjoin + {-# INLINE sieve #-} + +instance Representable (Conjoin j) where + type Rep (Conjoin j) = (->) j + tabulate = Conjoin . flip + {-# INLINE tabulate #-} + +instance Cosieve (Conjoin j) ((,) j) where + cosieve = uncurry . unConjoin + {-# INLINE cosieve #-} + +instance Corepresentable (Conjoin j) where + type Corep (Conjoin j) = (,) j + cotabulate = Conjoin . curry + {-# INLINE cotabulate #-} + +instance Choice (Conjoin j) where + right' = A.right + {-# INLINE right' #-} + +instance Strong (Conjoin j) where + second' = A.second + {-# INLINE second' #-} + +instance Category (Conjoin j) where + id = Conjoin (const id) + {-# INLINE id #-} + Conjoin f . Conjoin g = Conjoin $ \j -> f j . g j + {-# INLINE (.) #-} + +instance A.Arrow (Conjoin j) where + arr f = Conjoin (\_ -> f) + {-# INLINE arr #-} + first f = Conjoin (A.first . unConjoin f) + {-# INLINE first #-} + second f = Conjoin (A.second . unConjoin f) + {-# INLINE second #-} + Conjoin f *** Conjoin g = Conjoin $ \j -> f j A.*** g j + {-# INLINE (***) #-} + Conjoin f &&& Conjoin g = Conjoin $ \j -> f j A.&&& g j + {-# INLINE (&&&) #-} + +instance A.ArrowChoice (Conjoin j) where + left f = Conjoin (A.left . unConjoin f) + {-# INLINE left #-} + right f = Conjoin (A.right . unConjoin f) + {-# INLINE right #-} + Conjoin f +++ Conjoin g = Conjoin $ \j -> f j A.+++ g j + {-# INLINE (+++) #-} + Conjoin f ||| Conjoin g = Conjoin $ \j -> f j A.||| g j + {-# INLINE (|||) #-} + +instance A.ArrowApply (Conjoin j) where + app = Conjoin $ \i (f, b) -> unConjoin f i b + {-# INLINE app #-} + +instance A.ArrowLoop (Conjoin j) where + loop (Conjoin f) = Conjoin $ \j b -> let (c,d) = f j (b, d) in c + {-# INLINE loop #-} diff --git a/src/Data/Profunctor/Optic/Combinator.hs b/src/Data/Profunctor/Optic/Combinator.hs new file mode 100644 --- /dev/null +++ b/src/Data/Profunctor/Optic/Combinator.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +module Data.Profunctor.Optic.Combinator ( + type (+) + , (&) + -- * Operations on (->) profunctors + , rgt + , rgt' + , lft + , lft' + , swap + , eswap + , fork + , join + , eval + , apply + , branch + , branch' + , assocl + , assocr + , assocl' + , assocr' + , eassocl + , eassocr + , forget1 + , forget2 + , forgetl + , forgetr + -- * Operations on arbitrary profunctors + , constl + , constr + , shiftl + , shiftr + , coercel + , coercer + -- * Operations on (co)-strong profunctors + , strong + , costrong + , choice + , cochoice + , pull + , peval + , pushl + , pushr + -- * Operations on (co)-representable profunctors + , star + , costar + , unstar + , uncostar + , sieve' + , cosieve' + , tabulate' + , cotabulate' + , repn + , corepn + , pure' + , copure' + , pappend + , liftR2 + -- * Arrow-style combinators + , (<<*>>) + , (****) + , (++++) + , (&&&&) + , (||||) + -- * Divisible-style combinators + , divide + , divide' + , codivide + , codivide' + , choose + , choose' + , cochoose + , cochoose' +) where + +import Data.Function +import Data.Profunctor.Closed +import Data.Profunctor.Optic.Types +import Data.Profunctor.Optic.Import + +branch :: (a -> Bool) -> b -> c -> a -> b + c +branch f y z x = if f x then Right z else Left y +{-# INLINE branch #-} + +branch' :: (a -> Bool) -> a -> a + a +branch' f x = branch f x x x +{-# INLINE branch' #-} + +assocl :: (a , (b , c)) -> ((a , b) , c) +assocl (a, (b, c)) = ((a, b), c) +{-# INLINE assocl #-} + +assocr :: ((a , b) , c) -> (a , (b , c)) +assocr ((a, b), c) = (a, (b, c)) +{-# INLINE assocr #-} + +assocl' :: (a , b + c) -> (a , b) + c +assocl' = eswap . traverse eswap +{-# INLINE assocl' #-} + +assocr' :: (a + b , c) -> a + (b , c) +assocr' (f, b) = fmap (,b) f +{-# INLINE assocr' #-} + +eassocl :: a + (b + c) -> (a + b) + c +eassocl (Left a) = Left (Left a) +eassocl (Right (Left b)) = Left (Right b) +eassocl (Right (Right c)) = Right c +{-# INLINE eassocl #-} + +eassocr :: (a + b) + c -> a + (b + c) +eassocr (Left (Left a)) = Left a +eassocr (Left (Right b)) = Right (Left b) +eassocr (Right c) = Right (Right c) +{-# INLINE eassocr #-} + +forget1 :: ((c, a) -> (c, b)) -> a -> b +forget1 f a = b where (c, b) = f (c, a) +{-# INLINE forget1 #-} + +forget2 :: ((a, c) -> (b, c)) -> a -> b +forget2 f a = b where (b, c) = f (a, c) +{-# INLINE forget2 #-} + +forgetl :: (c + a -> c + b) -> a -> b +forgetl f = go . Right where go = either (go . Left) id . f +{-# INLINE forgetl #-} + +forgetr :: (a + c -> b + c) -> a -> b +forgetr f = go . Left where go = either id (go . Right) . f +{-# INLINE forgetr #-} + +--------------------------------------------------------------------- +-- Operations on arbitrary profunctors +--------------------------------------------------------------------- + +constl :: Profunctor p => b -> p b c -> p a c +constl = lmap . const +{-# INLINE constl #-} + +constr :: Profunctor p => c -> p a b -> p a c +constr = rmap . const +{-# INLINE constr #-} + +shiftl :: Profunctor p => p (a + b) c -> p b (c + d) +shiftl = dimap Right Left +{-# INLINE shiftl #-} + +shiftr :: Profunctor p => p b (c , d) -> p (a , b) c +shiftr = dimap snd fst +{-# INLINE shiftr #-} + +coercel :: Profunctor p => CoerceL p => p a b -> p c b +coercel = first absurd . lmap absurd +{-# INLINE coercel #-} + +coercer :: Profunctor p => CoerceR p => p a b -> p a c +coercer = rmap absurd . contramap absurd +{-# INLINE coercer #-} + +--------------------------------------------------------------------- +-- Operations on (co)-strong profunctors +--------------------------------------------------------------------- + +strong :: Strong p => ((a , b) -> c) -> p a b -> p a c +strong f = dimap fork f . second' +{-# INLINE strong #-} + +costrong :: Costrong p => ((a , b) -> c) -> p c a -> p b a +costrong f = unsecond . dimap f fork +{-# INLINE costrong #-} + +choice :: Choice p => (c -> (a + b)) -> p b a -> p c a +choice f = dimap f join . right' +{-# INLINE choice #-} + +cochoice :: Cochoice p => (c -> (a + b)) -> p a c -> p a b +cochoice f = unright . dimap join f +{-# INLINE cochoice #-} + +pull :: Strong p => p a b -> p a (a , b) +pull = lmap fork . second' +{-# INLINE pull #-} + +peval :: Strong p => p a (a -> b) -> p a b +peval = rmap eval . pull +{-# INLINE peval #-} + +pushl :: Closed p => Traversing1 p => p a c -> p b c -> p a (b -> c) +pushl p q = curry' $ divide id p q +{-# INLINE pushl #-} + +pushr :: Closed p => Traversing1 p => p (a , b) c -> p a b -> p a c +pushr = (<<*>>) . curry' +{-# INLINE pushr #-} + +--------------------------------------------------------------------- +-- Operations on (co)-representable profunctors +--------------------------------------------------------------------- + +star :: Applicative f => Star f a a +star = Star pure +{-# INLINE star #-} + +costar :: Coapplicative f => Costar f a a +costar = Costar copure +{-# INLINE costar #-} + +unstar :: Coapplicative f => Star f a b -> a -> b +unstar f = copure . runStar f +{-# INLINE unstar #-} + +uncostar :: Applicative f => Costar f a b -> a -> b +uncostar f = runCostar f . pure +{-# INLINE uncostar #-} + +sieve' :: Sieve p f => p d c -> Star f d c +sieve' = Star . sieve +{-# INLINE sieve' #-} + +cosieve' :: Cosieve p f => p a b -> Costar f a b +cosieve' = Costar . cosieve +{-# INLINE cosieve' #-} + +tabulate' :: Representable p => Star (Rep p) a b -> p a b +tabulate' = tabulate . runStar +{-# INLINE tabulate' #-} + +cotabulate' :: Corepresentable p => Costar (Corep p) a b -> p a b +cotabulate' = cotabulate . runCostar +{-# INLINE cotabulate' #-} + +repn :: Representable p => ((a -> Rep p b) -> s -> Rep p t) -> p a b -> p s t +repn f = tabulate . f . sieve +{-# INLINE repn #-} + +corepn :: Corepresentable p => ((Corep p a -> b) -> Corep p s -> t) -> p a b -> p s t +corepn f = cotabulate . f . cosieve +{-# INLINE corepn #-} + +pure' :: Traversing p => (a -> b) -> p a b +pure' = tabulate . (pure .) +{-# INLINE pure' #-} + +copure' :: Cotraversing p => (a -> b) -> p a b +copure' = cotabulate . (. copure) +{-# INLINE copure' #-} + +pappend :: Traversing1 p => p a b -> p a b -> p a b +pappend = divide fork +{-# INLINE pappend #-} + +liftR2 :: Traversing1 p => (b -> c -> d) -> p a b -> p a c -> p a d +liftR2 f x y = tabulate $ \s -> liftF2 f (sieve x s) (sieve y s) +{-# INLINE liftR2 #-} + +--------------------------------------------------------------------- +-- Arrow-style combinators +--------------------------------------------------------------------- + +infixl 4 <<*>> + +-- | Profunctor version of '<*>'. +-- +(<<*>>) :: Traversing1 p => p a (b -> c) -> p a b -> p a c +(<<*>>) = liftR2 ($) +{-# INLINE (<<*>>) #-} + +infixr 3 **** + +-- | Profunctor version of '***'. +-- +(****) :: Traversing1 p => p a1 b1 -> p a2 b2 -> p (a1 , a2) (b1 , b2) +p **** q = dimap fst (,) p <<*>> lmap snd q +{-# INLINE (****) #-} + +infixr 2 ++++ + +-- | Profunctor version of '+++'. +-- +(++++) :: Cotraversing1 p => p a1 b1 -> p a2 b2 -> p (a1 + a2) (b1 + b2) +p ++++ q = cotabulate $ bimap (cosieve p) (cosieve q) . coapply +{-# INLINE (++++) #-} + +infixr 3 &&&& + +-- | Profunctor version of '&&&'. +-- +(&&&&) :: Traversing1 p => p a b1 -> p a b2 -> p a (b1 , b2) +p &&&& q = liftR2 (,) p q +{-# INLINE (&&&&) #-} + +infixr 2 |||| + +-- | Profunctor version of '|||'. +-- +(||||) :: Cotraversing1 p => p a1 b -> p a2 b -> p (a1 + a2) b +p |||| q = cotabulate $ either (cosieve p) (cosieve q) . coapply +{-# INLINE (||||) #-} + +--------------------------------------------------------------------- +-- Divisible-style combinators +--------------------------------------------------------------------- + +-- | Profunctor version of < hackage.haskell.org/package/contravariant/docs/Data-Functor-Contravariant-Divisible.html#v:divide divide >. +-- +divide :: Traversing1 p => (a -> (a1 , a2)) -> p a1 b -> p a2 b -> p a b +divide f p q = dimap f fst $ p **** q +{-# INLINE divide #-} + +divide' :: Traversing1 p => p a1 b -> p a2 b -> p (a1 , a2) b +divide' = divide id +{-# INLINE divide' #-} + +codivide :: Cotraversing1 p => ((b1 + b2) -> b) -> p a b1 -> p a b2 -> p a b +codivide f p q = dimap Left f $ p ++++ q +{-# INLINE codivide #-} + +codivide' :: Cotraversing1 p => p a b1 -> p a b2 -> p a (b1 + b2) +codivide' = codivide id +{-# INLINE codivide' #-} + +-- | Profunctor version of < hackage.haskell.org/package/contravariant/docs/Data-Functor-Contravariant-Divisible.html#v:choose choose >. +-- +choose :: Cotraversing1 p => (a -> (a1 + a2)) -> p a1 b -> p a2 b -> p a b +choose f p q = dimap f join $ p ++++ q +{-# INLINE choose #-} + +choose' :: Cotraversing1 p => p a1 b -> p a2 b -> p (a1 + a2) b +choose' = choose id +{-# INLINE choose' #-} + +cochoose :: Traversing1 p => ((b1 , b2) -> b) -> p a b1 -> p a b2 -> p a b +cochoose f p q = dimap fork f $ p **** q +{-# INLINE cochoose #-} + +cochoose' :: Traversing1 p => p a b1 -> p a b2 -> p a (b1, b2) +cochoose' = cochoose id +{-# INLINE cochoose' #-} diff --git a/src/Data/Profunctor/Optic/Cotraversal.hs b/src/Data/Profunctor/Optic/Cotraversal.hs deleted file mode 100644 --- a/src/Data/Profunctor/Optic/Cotraversal.hs +++ /dev/null @@ -1,143 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -module Data.Profunctor.Optic.Cotraversal ( - -- * Cotraversal & Cxtraversal - Cotraversal - , Cotraversal' - , cotraversing - , retraversing - , cotraversalVl - -- * Optics - , cotraversed - -- * Operators - , withCotraversal - , distributes -) where - -import Data.Bitraversable -import Data.List.NonEmpty as NonEmpty -import Data.Profunctor.Optic.Carrier -import Data.Profunctor.Optic.Grate -import Data.Profunctor.Optic.Lens -import Data.Profunctor.Optic.Import hiding (id,(.)) -import Data.Profunctor.Optic.Types -import Data.Profunctor.Optic.Operator -import Data.Semigroupoid -import Data.Semiring -import Control.Monad.Trans.State -import Prelude (Foldable(..), reverse) -import qualified Data.Functor.Rep as F - -import Control.Applicative -import Data.Ord -import Data.Function -import Prelude -import Data.Semigroup.Foldable as F1 -import Data.Foldable as F -import Data.List as L -import Data.List.NonEmpty as L1 - --- $setup --- >>> :set -XNoOverloadedStrings --- >>> :set -XFlexibleContexts --- >>> :set -XTypeApplications --- >>> :set -XTupleSections --- >>> :set -XRankNTypes --- >>> import Data.Maybe --- >>> import Data.List.NonEmpty (NonEmpty(..)) --- >>> import Data.Functor.Identity --- >>> import Data.List.Index --- >>> :load Data.Profunctor.Optic - ---------------------------------------------------------------------- --- 'Cotraversal' ---------------------------------------------------------------------- - --- | Obtain a 'Cotraversal' by embedding a continuation into a 'Distributive' functor. --- --- @ --- 'withGrate' o 'cotraversing' ≡ 'cotraversed' . o --- @ --- --- /Caution/: In order for the generated optic to be well-defined, --- you must ensure that the input function satisfies the following --- properties: --- --- * @sabt ($ s) ≡ s@ --- --- * @sabt (\k -> f (k . sabt)) ≡ sabt (\k -> f ($ k))@ --- -cotraversing :: Distributive g => (((s -> a) -> b) -> t) -> Cotraversal (g s) (g t) a b -cotraversing sabt = corepn cotraverse . grate sabt - --- | Obtain a 'Cotraversal' by embedding a reversed lens getter and setter into a 'Distributive' functor. --- --- @ --- 'withLens' ('re' o) 'cotraversing' ≡ 'cotraversed' . o --- @ --- -retraversing :: Distributive g => (b -> t) -> (b -> s -> a) -> Cotraversal (g s) (g t) a b -retraversing bsa bt = corepn cotraverse . (re $ lens bsa bt) - --- | Obtain a profunctor 'Cotraversal' from a Van Laarhoven 'Cotraversal'. --- --- /Caution/: In order for the generated optic to be well-defined, --- you must ensure that the input satisfies the following properties: --- --- * @abst runIdentity ≡ runIdentity@ --- --- * @abst f . fmap (abst g) ≡ abst (f . fmap g . getCompose) . Compose@ --- --- See 'Data.Profunctor.Optic.Property'. --- -cotraversalVl :: (forall f. Coapplicative f => (f a -> b) -> f s -> t) -> Cotraversal s t a b -cotraversalVl abst = cotabulate . abst . cosieve - ---------------------------------------------------------------------- --- Optics ---------------------------------------------------------------------- - --- | TODO: Document --- -cotraversed :: Distributive f => Cotraversal (f a) (f b) a b -cotraversed = cotraversalVl cotraverse -{-# INLINE cotraversed #-} - ---------------------------------------------------------------------- --- Operators ---------------------------------------------------------------------- - --- | --- --- @ --- 'withCotraversal' $ 'Data.Profuncto.Optic.Grate.grate' (flip 'Data.Distributive.cotraverse' id) ≡ 'Data.Distributive.cotraverse' --- @ --- --- The cotraversal laws can be restated in terms of 'withCotraversal': --- --- * @withCotraversal o (f . runIdentity) ≡ fmap f . runIdentity@ --- --- * @withCotraversal o f . fmap (withCotraversal o g) == withCotraversal o (f . fmap g . getCompose) . Compose@ --- --- See also < https://www.cs.ox.ac.uk/jeremy.gibbons/publications/iterator.pdf > --- -withCotraversal :: Coapplicative f => ACotraversal f s t a b -> (f a -> b) -> (f s -> t) -withCotraversal = withCostar -{-# INLINE withCotraversal #-} - --- | TODO: Document --- --- >>> distributes left' (1, Left "foo") --- Left (1,"foo") --- --- >>> distributes left' (1, Right "foo") --- Right "foo" --- -distributes :: Coapplicative f => ACotraversal f s t a (f a) -> f s -> t -distributes o = withCotraversal o id -{-# INLINE distributes #-} 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 @@ -7,85 +7,84 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Data.Profunctor.Optic.Fold ( - -- * Fold & Ixfold - Fold - , Ixfold + -- * Fold0 + Fold0 + , fold0 + , failing + , toFold0 + , fromFold0 + -- * Fold + , Fold , fold_ , folding , foldVl - , ifoldVl , afold - , aifold - -- * Fold1 & Ixfold1 + -- * Fold1 , Fold1 - , Ixfold1 , fold1_ , folding1 , fold1Vl - , ifold1Vl , afold1 - , aifold1 -- * Optics + , folded0 + , filtered , folded , folded_ , folded1 , folded1_ - -- * Indexed optics - , ifolded - , ifoldedRep - , ifolded1 - , aifolded - , aifolded1 - -- * Primitive operators - , withFold - , withIxfold - , withFold1 - , withIxfold1 -- * Operators + , (^?) + , preview + , preuse + , is + , isnt , lists , (^..) - , ilists - , ilistsFrom - , (^%%) , nelists , folds - , ifolds , folds1 , foldsa , foldsr - , ifoldsr - , ifoldsrFrom , foldsl - , ifoldsl - , ifoldslFrom , foldsr' - , ifoldsr' , foldsl' - , ifoldsl' , foldsrM - , ifoldsrM , foldslM - , ifoldslM , traverses_ - , itraverses_ + , concats + , aconcats + , mins + , maxes + , sums + , multiplies + , endo + , endoM + , finds + , has + , hasnt + , contains -- * Auxilliary Types , Nedl(..) ) where +import Control.Applicative as A import Control.Monad (void) import Control.Monad.Reader as Reader hiding (lift) -import Data.Foldable (Foldable, foldMap, traverse_) +import Control.Monad.State as State hiding (lift) +import Data.Foldable (Foldable, traverse_) import Data.List.NonEmpty (NonEmpty(..)) -import Data.Key as K +import Data.Maybe import Data.Monoid import Data.Semiring as Rng import Data.Profunctor.Optic.Carrier +import Data.Profunctor.Optic.Combinator import Data.Profunctor.Optic.Import import Data.Profunctor.Optic.Traversal import Data.Profunctor.Optic.Types +import Data.Profunctor.Optic.Prism import Data.Profunctor.Optic.View -import qualified Data.Functor.Rep as F +import Prelude (Ord,min,max) import qualified Data.List.NonEmpty as NEL -- $setup @@ -95,7 +94,6 @@ -- >>> :set -XRankNTypes -- >>> import Control.Exception hiding (catches) -- >>> import Data.Functor.Identity --- >>> import Data.List.Index as LI -- >>> import Data.List.NonEmpty (NonEmpty(..)) -- >>> import qualified Data.List.NonEmpty as NE -- >>> import Data.Int @@ -103,12 +101,60 @@ -- >>> import Data.Maybe -- >>> import Data.Monoid -- >>> :load Data.Profunctor.Optic --- >>> let itraversed :: Ixtraversal Int [a] [b] a b ; itraversed = itraversalVl itraverse --------------------------------------------------------------------- --- 'Fold' & 'Ixfold' +-- 'Fold0' --------------------------------------------------------------------- +-- | Obtain a 'Fold0' directly. +-- +-- @ +-- 'fold0' . 'preview' ≡ id +-- 'fold0' ('view' o) ≡ o . 'just' +-- @ +-- +-- >>> preview (fold0 . preview $ selected even) (2, "yes") +-- Just "yes" +-- +-- >>> preview (fold0 . preview $ selected even) (3, "no") +-- Nothing +-- +-- >>> preview (fold0 listToMaybe) "foo" +-- Just 'f' +-- +fold0 :: (s -> Maybe a) -> Fold0 s a +fold0 f = to (\s -> maybe (Left s) Right (f s)) . right' +{-# INLINE fold0 #-} + +infixl 3 `failing` + +-- | If the first 'Fold0' has no focus then try the second one. +-- +failing :: AFold0 a s a -> AFold0 a s a -> Fold0 s a +failing a b = fold0 $ \s -> maybe (preview b s) Just (preview a s) +{-# INLINE failing #-} + +-- | Obtain a 'Fold0' from a 'View'. +-- +-- @ +-- 'toFold0' o ≡ o . 'just' +-- 'toFold0' o ≡ 'fold0' ('view' o) +-- @ +-- +toFold0 :: View s (Maybe a) -> Fold0 s a +toFold0 = (. just) +{-# INLINE toFold0 #-} + +-- | Obtain a 'View' from a 'Fold0' +-- +fromFold0 :: AFold0 a s a -> View s (Maybe a) +fromFold0 = to . preview +{-# INLINE fromFold0 #-} + +--------------------------------------------------------------------- +-- 'Fold' +--------------------------------------------------------------------- + -- | Obtain a 'Fold' directly. -- -- @ @@ -145,30 +191,14 @@ foldVl f = coercer . traversalVl f . coercer {-# INLINE foldVl #-} --- | Obtain a 'Ixfold' from a Van Laarhoven 'Fold'. --- -ifoldVl :: (forall f. Applicative f => (i -> a -> f b) -> s -> f t) -> Ixfold i s a -ifoldVl f = coercer . itraversalVl f . coercer -{-# INLINE ifoldVl #-} - -- | TODO: Document -- --- @ --- afold :: Monoid r => ((a -> r) -> s -> r) -> AFold r s a --- @ --- -afold :: Monoid r => ((a -> r) -> s -> r) -> APrimView r s t a b -afold f = Star #. (Const #.) #. f .# (getConst #.) .# runStar +afold :: Monoid r => ((a -> r) -> s -> r) -> AFold r s a +afold = afold1 {-# INLINE afold #-} --- | TODO: Document --- -aifold :: Monoid r => ((i -> a -> r) -> s -> r) -> AIxfold r i s a -aifold f = afold $ \iar s -> f (curry iar) $ snd s -{-# INLINE aifold #-} - --------------------------------------------------------------------- --- 'Fold1' & 'Ixfold1' +-- 'Fold1' --------------------------------------------------------------------- -- | Obtain a 'Fold1' directly. @@ -206,32 +236,34 @@ fold1Vl f = coercer . repn f . coercer {-# INLINE fold1Vl #-} --- | Obtain a 'Ixfold1' from a Van Laarhoven 'Fold1'. --- -ifold1Vl :: (forall f. Apply f => (i -> a -> f b) -> s -> f t) -> Ixfold1 i s a -ifold1Vl f = coercer . itraversal1Vl f . coercer -{-# INLINE ifold1Vl #-} - -- | TODO: Document -- --- @ --- afold1 :: ((a -> r) -> s -> r) -> AFold1 r s a --- @ --- -afold1 :: ((a -> r) -> s -> r) -> APrimView r s t a b +afold1 :: Semigroup r => ((a -> r) -> s -> r) -> AFold1 r s a afold1 f = Star #. (Const #.) #. f .# (getConst #.) .# runStar {-# INLINE afold1 #-} --- | TODO: Document --- -aifold1 :: ((i -> a -> r) -> s -> r) -> AIxfold1 r i s a -aifold1 f = afold1 $ \iar s -> f (curry iar) $ snd s -{-# INLINE aifold1 #-} - --------------------------------------------------------------------- -- Optics --------------------------------------------------------------------- +-- | The canonical 'Fold0'. +-- +-- >>> [Just 1, Nothing] ^.. folded . folded0 +-- [1] +-- +folded0 :: Fold0 (Maybe a) a +folded0 = fold0 id +{-# INLINE folded0 #-} + +-- | Filter another optic. +-- +-- >>> [1..10] ^.. folded . filtered even +-- [2,4,6,8,10] +-- +filtered :: (a -> Bool) -> Fold0 a a +filtered p = traversal0Vl (\point f a -> if p a then f a else point a) . coercer +{-# INLINE filtered #-} + -- | Obtain a 'Fold' from a 'Traversable' functor. -- folded :: Traversable f => Fold (f a) a @@ -265,104 +297,61 @@ {-# INLINE folded1_ #-} --------------------------------------------------------------------- --- Indexed optics +-- Operators --------------------------------------------------------------------- --- | Obtain an 'AIxfold' from a 'FoldableWithKey'. --- --- @ --- f '^%%' 'ifolded' ≡ 'toKeyedList' f --- @ --- -ifolded :: FoldableWithKey f => Ixfold (Key f) (f a) a -ifolded = ifoldVl K.traverseWithKey_ -{-# INLINE ifolded #-} - --- | Obtain an 'Ixfold' from a 'F.Representable' functor. --- -ifoldedRep :: F.Representable f => Traversable f => Ixfold (F.Rep f) (f a) a -ifoldedRep = ifoldVl F.itraverseRep -{-# INLINE ifoldedRep #-} - --- | Obtain an 'Ixfold1' from a 'FoldableWithKey1'. --- -ifolded1 :: FoldableWithKey1 f => Ixfold1 (Key f) (f a) a -ifolded1 = ifold1Vl K.traverseWithKey1_ -{-# INLINE ifolded1 #-} - --- | Obtain an 'AIxfold' from a 'FoldableWithKey'. --- -aifolded :: FoldableWithKey f => Monoid r => AIxfold r (Key f) (f a) a -aifolded = aifold K.foldMapWithKey -{-# INLINE aifolded #-} - --- | Obtain an 'AIxfold1' from a 'FoldableWithKey1'. --- -aifolded1 :: FoldableWithKey1 f => Semigroup r => AIxfold1 r (Key f) (f a) a -aifolded1 = aifold1 K.foldMapWithKey1 -{-# INLINE aifolded1 #-} - ---------------------------------------------------------------------- --- Primitive operators ---------------------------------------------------------------------- +infixl 8 ^? --- | Map an optic to a monoid and combine the results. +-- | An infix alias for 'preview''. -- -- @ --- 'Data.Foldable.foldMap' = 'withFold' 'folded_' +-- ('^?') ≡ 'flip' 'preview'' -- @ -- --- >>> withFold both id (["foo"], ["bar", "baz"]) --- ["foo","bar","baz"] +-- Perform a safe 'head' of a 'Fold' or 'Traversal' or retrieve 'Just' +-- the result from a 'View' or 'Lens'. -- --- >>> :t withFold traversed --- withFold traversed --- :: (Monoid r, Traversable f) => (a -> r) -> f a -> r +-- When using a 'Traversal' as a partial 'Lens', or a 'Fold' as a partial +-- 'View' this can be a convenient way to extract the optional value. -- --- @ --- 'withFold' :: 'Monoid' r => 'AFold' r s a -> (a -> r) -> s -> r --- @ +-- >>> Left 4 ^? left' +-- Just 4 +-- >>> Right 4 ^? left' +-- Nothing -- -withFold :: Monoid r => APrimView r s t a b -> (a -> r) -> s -> r -withFold = withPrimView -{-# INLINE withFold #-} +(^?) :: s -> AFold0 a s a -> Maybe a +(^?) = flip preview +{-# INLINE (^?) #-} --- | Map an indexed optic to a monoid and combine the results. --- --- Note that most indexed optics do not use their output index: +-- | TODO: Document -- +preview :: MonadReader s m => AFold0 a s a -> m (Maybe a) +preview o = Reader.asks $ withFold0 o Just +{-# INLINE preview #-} + +-- | TODO: Document -- -withIxfold :: Monoid r => AIxfold r i s a -> (i -> a -> r) -> i -> s -> r -withIxfold o f = curry $ withFold o (uncurry f) -{-# INLINE withIxfold #-} +preuse :: MonadState s m => AFold0 a s a -> m (Maybe a) +preuse o = State.gets $ preview o +{-# INLINE preuse #-} --- | Map an optic to a semigroup and combine the results. +-- | Check whether the optic is matched. -- --- @ --- 'withFold1' :: 'Semigroup' r => 'AFold1' r s a -> (a -> r) -> s -> r --- @ +-- >>> is just Nothing +-- False -- -withFold1 :: Semigroup r => APrimView r s t a b -> (a -> r) -> s -> r -withFold1 = withPrimView -{-# INLINE withFold1 #-} +is :: AFold0 a s a -> s -> Bool +is o s = isJust (preview o s) +{-# INLINE is #-} --- | Map an indexed optic to a semigroup and combine the results. --- --- >>> :t flip withIxfold1 Map.singleton --- flip withIxfold1 Map.singleton --- :: Ord i => AIxfold1 (Map i a) i s a -> i -> s -> Map i a +-- | Check whether the optic isn't matched. -- --- @ --- 'withIxfold1' :: 'Semigroup' r => 'AIxfold1' r s a -> (i -> a -> r) -> i -> s -> r --- @ +-- >>> isnt just Nothing +-- True -- -withIxfold1 :: Semigroup r => AIxfold1 r i s a -> (i -> a -> r) -> i -> s -> r -withIxfold1 o f = curry $ withFold1 o (uncurry f) -{-# INLINE withIxfold1 #-} - ---------------------------------------------------------------------- --- Operators ---------------------------------------------------------------------- +isnt :: AFold0 a s a -> s -> Bool +isnt o s = not (isJust (preview o s)) +{-# INLINE isnt #-} -- | Collect the foci of an optic into a list. -- @@ -396,43 +385,13 @@ -- ('^..') :: s -> 'Iso'' s a -> [a] -- ('^..') :: s -> 'Traversal'' s a -> [a] -- ('^..') :: s -> 'Prism'' s a -> [a] --- ('^..') :: s -> 'Affine'' s a -> [a] +-- ('^..') :: s -> 'Traversal0'' s a -> [a] -- @ -- (^..) :: s -> AFold (Endo [a]) s a -> [a] (^..) = flip lists {-# INLINE (^..) #-} --- | Collect the foci of an indexed optic into a list of index-value pairs. --- --- This is only for use with the few indexed optics that don't ignore their --- output index. You most likely want to use 'ilists'. --- -ilistsFrom :: AIxfold (Endo [(i, a)]) i s a -> i -> s -> [(i, a)] -ilistsFrom o i = ifoldsrFrom o (\i a -> ((i,a):)) i [] -{-# INLINE ilistsFrom #-} - --- | Collect the foci of an indexed optic into a list of index-value pairs. --- --- @ --- 'lists' l ≡ 'map' 'snd' '.' 'ilists' l --- @ --- --- >>> ilists (itraversed . imapping swapped) [(40,'f'),(41,'o'),(42,'o')] --- [(0,('f',40)),(1,('o',41)),(2,('o',42))] --- -ilists :: (Additive-Monoid) i => AIxfold (Endo [(i, a)]) i s a -> s -> [(i, a)] -ilists o = ifoldsr o (\i a -> ((i,a):)) [] -{-# INLINE ilists #-} - -infixl 8 ^%% - --- | Infix version of 'ilists'. --- -(^%%) :: (Additive-Monoid) i => s -> AIxfold (Endo [(i, a)]) i s a -> [(i, a)] -(^%%) = flip ilists -{-# INLINE (^%%) #-} - -- | Extract a 'NonEmpty' of the foci of an optic. -- -- >>> nelists bitraversed1 ('h' :| "ello", 'w' :| "orld") @@ -450,12 +409,6 @@ -- | TODO: Document -- -ifolds :: (Additive-Monoid) i => Monoid a => AIxfold (Additive i, a) i s a -> s -> (i, a) -ifolds o = first unAdditive . withIxfold o (\i a -> (Additive i, a)) zero -{-# INLINE ifolds #-} - --- | TODO: Document --- folds1 :: Semigroup a => AFold1 a s a -> s -> a folds1 = flip withFold1 id {-# INLINE folds1 #-} @@ -480,72 +433,18 @@ foldsr o f r = (`appEndo` r) . withFold o (Endo . f) {-# INLINE foldsr #-} --- | Indexed right fold over an indexed optic. --- --- @ --- 'foldsr' o ≡ 'ifoldsr' o '.' 'const' --- 'foldrWithKey' f ≡ 'ifoldsr' 'ifolded' f --- @ --- --- >>> ifoldsr itraversed (\i a -> ((show i ++ ":" ++ show a ++ ", ") ++)) [] [1,3,5,7,9] --- "0:1, 1:3, 2:5, 3:7, 4:9, " --- -ifoldsr :: (Additive-Monoid) i => AIxfold (Endo r) i s a -> (i -> a -> r -> r) -> r -> s -> r -ifoldsr o f = ifoldsrFrom o f zero -{-# INLINE ifoldsr #-} - --- | Indexed right fold over an indexed optic, using an initial index value. --- --- This is only for use with the few indexed optics that don't ignore their --- output index. You most likely want to use 'ifoldsr'. --- -ifoldsrFrom :: AIxfold (Endo r) i s a -> (i -> a -> r -> r) -> i -> r -> s -> r -ifoldsrFrom o f i r = (`appEndo` r) . withIxfold o (\j -> Endo . f j) i -{-# INLINE ifoldsrFrom #-} - -- | Left fold over an optic. -- foldsl :: AFold ((Endo-Dual) r) s a -> (r -> a -> r) -> r -> s -> r foldsl o f r = (`appEndo` r) . getDual . withFold o (Dual . Endo . flip f) {-# INLINE foldsl #-} --- | Left fold over an indexed optic. --- --- @ --- 'foldsl' o ≡ 'ifoldsl' o '.' 'const' --- 'foldlWithKey' f ≡ 'ifoldsl' 'ifolded' f --- @ --- -ifoldsl :: (Additive-Monoid) i => AIxfold ((Endo-Dual) r) i s a -> (i -> r -> a -> r) -> r -> s -> r -ifoldsl o f = ifoldslFrom o f zero -{-# INLINE ifoldsl #-} - --- | Left fold over an indexed optic, using an initial index value. --- --- This is only for use with the few indexed optics that don't ignore their --- output index. You most likely want to use 'ifoldsl'. --- -ifoldslFrom :: AIxfold ((Endo-Dual) r) i s a -> (i -> r -> a -> r) -> i -> r -> s -> r -ifoldslFrom o f i r = (`appEndo` r) . getDual . withIxfold o (\i -> Dual . Endo . flip (f i)) i -{-# INLINE ifoldslFrom #-} - -- | Strict right fold over an optic. -- foldsr' :: AFold ((Endo-Dual) (Endo r)) s a -> (a -> r -> r) -> r -> s -> r foldsr' l f z0 xs = foldsl l f' (Endo id) xs `appEndo` z0 where f' (Endo k) x = Endo $ \ z -> k $! f x z {-# INLINE foldsr' #-} --- | Strict right fold over an indexed optic. --- --- @ --- 'foldsr'' o ≡ 'ifoldsr'' o '.' 'const' --- 'foldrWithKey'' f ≡ 'ifoldsr'' 'ifolded' f --- @ --- -ifoldsr' :: (Additive-Monoid) i => AIxfold ((Endo-Dual) (r -> r)) i s a -> (i -> a -> r -> r) -> r -> s -> r -ifoldsr' l f z0 xs = ifoldsl l f' id xs z0 where f' i k x z = k $! f i x z -{-# INLINE ifoldsr' #-} - -- | Strict left fold over an optic. -- -- @ @@ -558,56 +457,25 @@ -- 'foldsl'' :: 'View' s a -> (c -> a -> c) -> c -> s -> c -- 'foldsl'' :: 'Fold' s a -> (c -> a -> c) -> c -> s -> c -- 'foldsl'' :: 'Traversal'' s a -> (c -> a -> c) -> c -> s -> c --- 'foldsl'' :: 'Affine'' s a -> (c -> a -> c) -> c -> s -> c +-- 'foldsl'' :: 'Traversal0'' s a -> (c -> a -> c) -> c -> s -> c -- @ -- foldsl' :: AFold ((Endo-Endo) r) s a -> (r -> a -> r) -> r -> s -> r foldsl' o f r s = foldsr o f' (Endo id) s `appEndo` r where f' x (Endo k) = Endo $ \z -> k $! f z x {-# INLINE foldsl' #-} --- | Strict left fold over an indexed optic. --- --- @ --- 'foldsl'' o ≡ 'ifoldsl'' o '.' 'const' --- 'foldlWithKey'' f ≡ 'ifoldsl'' 'ifolded' f --- @ --- -ifoldsl' :: (Additive-Monoid) i => AIxfold (Endo (r -> r)) i s a -> (i -> r -> a -> r) -> r -> s -> r -ifoldsl' l f z0 xs = ifoldsr l f' id xs z0 where f' i x k z = k $! f i z x -{-# INLINE ifoldsl' #-} - -- | Monadic right fold over an optic. -- foldsrM :: Monad m => AFold ((Endo-Dual) (r -> m r)) s a -> (a -> r -> m r) -> r -> s -> m r foldsrM l f z0 xs = foldsl l f' return xs z0 where f' k x z = f x z >>= k {-# INLINE foldsrM #-} --- | Monadic right fold over an indexed optic. --- --- @ --- 'foldsrM' ≡ 'ifoldrM' '.' 'const' --- @ --- -ifoldsrM :: (Additive-Monoid) i => Monad m => AIxfold ((Endo-Dual) (r -> m r)) i s a -> (i -> a -> r -> m r) -> r -> s -> m r -ifoldsrM o f z0 xs = ifoldsl o f' return xs z0 where f' i k x z = f i x z >>= k -{-# INLINE ifoldsrM #-} - -- | Monadic left fold over an optic. -- foldslM :: Monad m => AFold (Endo (r -> m r)) s a -> (r -> a -> m r) -> r -> s -> m r foldslM o f z0 xs = foldsr o f' return xs z0 where f' x k z = f z x >>= k {-# INLINE foldslM #-} --- | Monadic left fold over an indexed optic. --- --- @ --- 'foldslM' ≡ 'ifoldslM' '.' 'const' --- @ --- -ifoldslM :: (Additive-Monoid) i => Monad m => AIxfold (Endo (r -> m r)) i s a -> (i -> r -> a -> m r) -> r -> s -> m r -ifoldslM o f z0 xs = ifoldsr o f' return xs z0 where f' i x k z = f i z x >>= k -{-# INLINE ifoldslM #-} - -- | Applicative fold over an optic. -- -- >>> traverses_ both putStrLn ("hello","world") @@ -622,11 +490,100 @@ traverses_ p f = foldsr p (\a fu -> void (f a) *> fu) (pure ()) {-# INLINE traverses_ #-} --- | Applicative fold over an indexed optic. +-- | Map a function over the foci of an optic and concatenate the resulting lists. -- -itraverses_ :: (Additive-Monoid) i => Applicative f => AIxfold (Endo (f ())) i s a -> (i -> a -> f r) -> s -> f () -itraverses_ p f = ifoldsr p (\i a fu -> void (f i a) *> fu) (pure ()) -{-# INLINE itraverses_ #-} +-- >>> concats both (\x -> [x, x + 1]) (1,3) +-- [1,2,3,4] +-- +-- @ +-- 'concatMap' ≡ 'concats' 'folded' +-- @ +-- +concats :: AFold [r] s a -> (a -> [r]) -> s -> [r] +concats = withFold +{-# INLINE concats #-} + +-- | The sum of a collection of actions, generalizing 'concats'. +-- +-- >>> aconcats both ("hello","world") +-- "helloworld" +-- +-- >>> aconcats both (Nothing, Just "hello") +-- Just "hello" +-- +-- @ +-- 'asum' ≡ 'aconcats' 'folded' +-- @ +-- +aconcats :: Alternative f => AFold ((Endo-Endo) (f a)) s (f a) -> s -> f a +aconcats o = foldsl' o (<|>) A.empty +{-# INLINE aconcats #-} + +-- | Compute the minimum of the targets of a totally ordered fold. +-- +mins :: Ord a => AFold ((Endo-Endo) a) s a -> a -> s -> a +mins o = foldsl' o min + +-- | Compute the maximum of the targets of a totally ordered fold. +-- +maxes :: Ord a => AFold ((Endo-Endo) a) s a -> a -> s -> a +maxes o = foldsl' o max + +-- | The sum of a collection. +-- +sums :: (Additive-Monoid) a => AFold ((Endo-Endo) a) s a -> s -> a +sums o = foldsl' o (+) zero + +-- | The product of a collection. +-- +multiplies :: (Multiplicative-Monoid) a => AFold ((Endo-Endo) a) s a -> s -> a +multiplies o = foldsl' o (*) one + + +-- | TODO: Document +-- +endo :: AFold (Endo (a -> a)) s (a -> a) -> s -> a -> a +endo o = foldsr o (.) id + +-- | TODO: Document +-- +endoM :: Monad m => AFold (Endo (a -> m a)) s (a -> m a) -> s -> a -> m a +endoM o = foldsr o (<=<) pure + +-- | Find the first focus of an optic that satisfies a predicate, if one exists. +-- +-- >>> finds both even (1,4) +-- Just 4 +-- +-- >>> finds folded even [1,3,5,7] +-- Nothing +-- +-- @ +-- 'Data.Foldable.find' ≡ 'finds' 'folded' +-- @ +-- +finds :: AFold ((Maybe-Endo) a) s a -> (a -> Bool) -> s -> Maybe a +finds o f = foldsr o (\a y -> if f a then Just a else y) Nothing +{-# INLINE finds #-} + +-- | Determine whether an optic has at least one focus. +-- +has :: AFold (Additive Bool) s a -> s -> Bool +has o s = unAdditive $ withFold o (const $ Additive True) s +{-# INLINE has #-} + +-- | Determine whether an optic does not have a focus. +-- +hasnt :: AFold (Multiplicative Bool) s a -> s -> Bool +hasnt o s = unMultiplicative $ withFold o (const $ Multiplicative False) s +{-# INLINE hasnt #-} + +-- | Determine whether the targets of a `Fold` contain a given element. +-- +contains :: Eq a => AFold (Additive Bool) s a -> a -> s -> Bool +contains o a s = unAdditive $ withFold o (\x -> Additive $ x == a) s +{-# INLINE contains #-} + ------------------------------------------------------------------------------ -- Auxilliary Types diff --git a/src/Data/Profunctor/Optic/Grate.hs b/src/Data/Profunctor/Optic/Grate.hs deleted file mode 100644 --- a/src/Data/Profunctor/Optic/Grate.hs +++ /dev/null @@ -1,343 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -module Data.Profunctor.Optic.Grate ( - -- * Grate & Cxgrate - Grate - , Grate' - , Cxgrate - , Cxgrate' - , grate - , grateVl - , kgrateVl - , inverting - , cloneGrate - -- * Optics - , represented - , distributed - , endomorphed - , connected - , continued - , continuedT - , calledCC - , unlifted - -- * Indexed optics - , kclosed - , kfirst - , ksecond - , coindexed - -- * Primitive operators - , withGrate - , withGrateVl - -- * Operators - , coview - , zipsWith - , kzipsWith - , zipsWith3 - , zipsWith4 - , toClosure - , toEnvironment - -- * Classes - , Closed(..) - , Costrong(..) -) where - -import Control.Monad.Reader -import Control.Monad.Cont -import Control.Monad.IO.Unlift -import Data.Distributive -import Data.Connection (Conn(..)) -import Data.Monoid (Endo(..)) -import Data.Profunctor.Closed -import Data.Profunctor.Optic.Carrier -import Data.Profunctor.Optic.Types -import Data.Profunctor.Optic.Import -import Data.Profunctor.Optic.Index -import Data.Profunctor.Optic.Iso (tabulated) - -import Prelude (IO) -import qualified Data.Functor.Rep as F - --- $setup --- >>> :set -XNoOverloadedStrings --- >>> :set -XTypeApplications --- >>> :set -XFlexibleContexts --- >>> :set -XTupleSections --- >>> import Control.Exception --- >>> import Control.Monad.Reader --- >>> import Data.Complex --- >>> import Data.Connection.Int --- >>> import Data.List as L --- >>> import Data.Monoid (Endo(..)) --- >>> :load Data.Profunctor.Optic - ---------------------------------------------------------------------- --- 'Grate' ---------------------------------------------------------------------- - --- | Obtain a 'Grate' from a nested continuation. --- --- The resulting optic is the corepresentable counterpart to 'Lens', --- and sits between 'Iso' and 'Setter'. --- --- A 'Grate' lets you lift a profunctor through any representable --- functor (aka Naperian container). In the special case where the --- indexing type is finitary (e.g. 'Bool') then the tabulated type is --- isomorphic to a fied length vector (e.g. 'V2 a'). --- --- The identity container is representable, and representable functors --- are closed under composition. --- --- See --- section 4.6 for more background on 'Grate's, and compare to the --- /lens-family/ . --- --- /Caution/: In order for the generated optic to be well-defined, --- you must ensure that the input function satisfies the following --- properties: --- --- * @sabt ($ s) ≡ s@ --- --- * @sabt (\k -> f (k . sabt)) ≡ sabt (\k -> f ($ k))@ --- --- More generally, a profunctor optic must be monoidal as a natural --- transformation: --- --- * @o id ≡ id@ --- --- * @o ('Data.Profunctor.Composition.Procompose' p q) ≡ 'Data.Profunctor.Composition.Procompose' (o p) (o q)@ --- --- See 'Data.Profunctor.Optic.Property'. --- -grate :: (((s -> a) -> b) -> t) -> Grate s t a b -grate sabt = dimap (flip ($)) sabt . closed - --- | Transform a Van Laarhoven grate into a profunctor grate. --- --- Compare 'Data.Profunctor.Optic.Lens.lensVl' & 'Data.Profunctor.Optic.Traversal.cotraversalVl'. --- --- /Caution/: In order for the generated family to be well-defined, --- you must ensure that the traversal1 law holds for the input function: --- --- * @abst runIdentity ≡ runIdentity@ --- --- * @abst f . fmap (abst g) ≡ abst (f . fmap g . getCompose) . Compose@ --- --- See 'Data.Profunctor.Optic.Property'. --- -grateVl :: (forall f. Functor f => (f a -> b) -> f s -> t) -> Grate s t a b -grateVl o = dimap (curry eval) ((o trivial) . Coindex) . closed - --- | TODO: Document --- -kgrateVl :: (forall f. Functor f => (k -> f a -> b) -> f s -> t) -> Cxgrate k s t a b -kgrateVl f = grateVl $ \kab -> const . f (flip kab) - --- | Construct a 'Grate' from a pair of inverses. --- -inverting :: (s -> a) -> (b -> t) -> Grate s t a b -inverting sa bt = grate $ \sab -> bt (sab sa) - --- | TODO: Document --- -cloneGrate :: AGrate s t a b -> Grate s t a b -cloneGrate k = withGrate k grate - ---------------------------------------------------------------------- --- Optics ---------------------------------------------------------------------- - --- | Obtain a 'Grate' from a 'F.Representable' functor. --- -represented :: F.Representable f => Grate (f a) (f b) a b -represented = tabulated . closed -{-# INLINE represented #-} - --- | Obtain a 'Grate' from a distributive functor. --- -distributed :: Distributive f => Grate (f a) (f b) a b -distributed = grate (`cotraverse` id) -{-# INLINE distributed #-} - --- | Obtain a 'Grate' from an endomorphism. --- --- >>> flip appEndo 2 $ zipsWith endomorphed (+) (Endo (*3)) (Endo (*4)) --- 14 --- -endomorphed :: Grate' (Endo a) a -endomorphed = dimap appEndo Endo . closed -{-# INLINE endomorphed #-} - --- | Obtain a 'Grate' from a Galois connection. --- --- Useful for giving precise semantics to numerical computations. --- --- This is an example of a 'Grate' that would not be a legal 'Iso', --- as Galois connections are not in general inverses. --- --- >>> zipsWith (connected i08i16) (+) 126 1 --- 127 --- >>> zipsWith (connected i08i16) (+) 126 2 --- 127 --- -connected :: Conn s a -> Grate' s a -connected (Conn f g) = inverting f g -{-# INLINE connected #-} - --- | Obtain a 'Grate' from a continuation. --- --- @ --- 'zipsWith' 'continued' :: (r -> r -> r) -> s -> s -> 'Cont' r s --- @ --- -continued :: Grate a (Cont r a) r r -continued = grate cont -{-# INLINE continued #-} - --- | Obtain a 'Grate' from a continuation. --- --- @ --- 'zipsWith' 'continued' :: (m r -> m r -> m r) -> s -> s -> 'ContT' r m s --- @ --- -continuedT :: Grate a (ContT r m a) (m r) (m r) -continuedT = grate ContT -{-# INLINE continuedT #-} - --- | Lift the current continuation into the calling context. --- --- @ --- 'zipsWith' 'calledCC' :: 'MonadCont' m => (m b -> m b -> m s) -> s -> s -> m s --- @ --- -calledCC :: MonadCont m => Grate a (m a) (m b) (m a) -calledCC = grate callCC -{-# INLINE calledCC #-} - --- | Unlift an action into an 'IO' context. --- --- @ --- 'liftIO' ≡ 'coview' 'unlifted' --- @ --- --- >>> let catchA = catch @ArithException --- >>> zipsWith unlifted (flip catchA . const) (throwIO Overflow) (print "caught") --- "caught" --- -unlifted :: MonadUnliftIO m => Grate (m a) (m b) (IO a) (IO b) -unlifted = grate withRunInIO -{-# INLINE unlifted #-} - ---------------------------------------------------------------------- --- Indexed optics ---------------------------------------------------------------------- - --- >>> kover kclosed (,) (*2) 5 --- ((),10) --- -kclosed :: Cxgrate k (c -> a) (c -> b) a b -kclosed = rmap flip . closed -{-# INLINE kclosed #-} - --- | TODO: Document --- -kfirst :: Cxgrate k a b (a , c) (b , c) -kfirst = rmap (unfirst . uncurry . flip) . curry' -{-# INLINE kfirst #-} - --- | TODO: Document --- -ksecond :: Cxgrate k a b (c , a) (c , b) -ksecond = rmap (unsecond . uncurry) . curry' . lmap swap -{-# INLINE ksecond #-} - --- | Obtain a 'Cxgrate' from a representable functor. --- --- >>> kzipsWith (coindexed @Complex) (\t -> if t then (+) else (*)) (2 :+ 2) (3 :+ 4) --- 6 :+ 6 --- --- See also 'Data.Profunctor.Optic.Lens.indexed'. --- -coindexed :: F.Representable f => (Additive-Monoid) (F.Rep f) => Cxgrate (F.Rep f) (f a) (f b) a b -coindexed = kgrateVl grateRep -{-# INLINE coindexed #-} - -grateRep :: F.Representable f => forall g. Functor g => (F.Rep f -> g a1 -> a2) -> g (f a1) -> f a2 -grateRep iab s = F.tabulate $ \i -> iab i (fmap (`F.index` i) s) -{-# INLINE grateRep #-} - ---------------------------------------------------------------------- --- Primitive operators ---------------------------------------------------------------------- - --- | Extract the higher order function that characterizes a 'Grate'. --- --- The grate laws can be stated in terms or 'withGrate': --- --- Identity: --- --- @ --- withGrateVl o runIdentity ≡ runIdentity --- @ --- --- Composition: --- --- @ --- withGrateVl o f . fmap (withGrateVl o g) ≡ withGrateVl o (f . fmap g . getCompose) . Compose --- @ --- -withGrateVl :: Functor f => AGrate s t a b -> (f a -> b) -> f s -> t -withGrateVl o ab s = withGrate o $ \sabt -> sabt $ \get -> ab (fmap get s) -{-# INLINE withGrateVl #-} - ---------------------------------------------------------------------- --- Operators ---------------------------------------------------------------------- - --- | Set all fields to the given value. --- --- This is essentially a restricted variant of 'Data.Profunctor.Optic.View.review'. --- -coview :: AGrate s t a b -> b -> t -coview o b = withGrate o $ \sabt -> sabt (const b) -{-# INLINE coview #-} - --- | Zip over a 'Grate'. --- --- @\\f -> 'zipsWith' 'closed' ('zipsWith' 'closed' f) ≡ 'zipsWith' ('closed' . 'closed')@ --- -zipsWith :: AGrate s t a b -> (a -> a -> b) -> s -> s -> t -zipsWith o aab s1 s2 = withGrate o $ \sabt -> sabt $ \get -> aab (get s1) (get s2) -{-# INLINE zipsWith #-} - -kzipsWith :: (Additive-Monoid) k => ACxgrate k s t a b -> (k -> a -> a -> b) -> s -> s -> t -kzipsWith o kaab s1 s2 = withCxgrate o $ \sakbt -> sakbt $ \sa k -> kaab k (sa s1) (sa s2) -{-# INLINE kzipsWith #-} - --- | Zip over a 'Grate' with 3 arguments. --- -zipsWith3 :: AGrate s t a b -> (a -> a -> a -> b) -> (s -> s -> s -> t) -zipsWith3 o aaab s1 s2 s3 = withGrate o $ \sabt -> sabt $ \sa -> aaab (sa s1) (sa s2) (sa s3) -{-# INLINE zipsWith3 #-} - --- | Zip over a 'Grate' with 4 arguments. --- -zipsWith4 :: AGrate s t a b -> (a -> a -> a -> a -> b) -> (s -> s -> s -> s -> t) -zipsWith4 o aaaab s1 s2 s3 s4 = withGrate o $ \sabt -> sabt $ \sa -> aaaab (sa s1) (sa s2) (sa s3) (sa s4) -{-# INLINE zipsWith4 #-} - --- | Use a 'Grate' to construct a 'Closure'. --- -toClosure :: Closed p => AGrate s t a b -> p a b -> Closure p s t -toClosure o p = withGrate o $ \sabt -> Closure (closed . grate sabt $ p) -{-# INLINE toClosure #-} - --- | Use a 'Grate' to construct an 'Environment'. --- -toEnvironment :: Closed p => AGrate s t a b -> p a b -> Environment p s t -toEnvironment o p = withGrate o $ \sabt -> Environment sabt p (curry eval) -{-# INLINE toEnvironment #-} 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 @@ -10,21 +10,25 @@ import Control.Arrow as Export ((|||),(&&&),(+++),(***)) import Control.Applicative as Export (liftA2, Alternative(..)) +import Control.Coapplicative as Export hiding (apply, branch) import Control.Category as Export hiding ((.), id) import Control.Monad as Export hiding (void, join) +import Data.Bifunctor as Export +import Data.Bool as Export import Data.Distributive as Export +import Data.Foldable as Export (foldr') import Data.Function as Export ((&)) import Data.Functor as Export hiding (void) import Data.Functor.Apply as Export +import Data.Functor.Coapply as Export hiding (apply, branch) import Data.Semigroup.Foldable as Export import Data.Semigroup.Traversable as Export -import Data.Semiring as Export (type (-), Additive(..), Multiplicative(..)) +import Data.Semiring as Export hiding (eval) import Data.Foldable as Export (foldr) import Data.Functor.Compose as Export import Data.Functor.Const as Export import Data.Functor.Contravariant as Export import Data.Functor.Identity as Export -import Data.Profunctor.Extra as Export import Data.Profunctor.Unsafe as Export import Data.Profunctor.Types as Export import Data.Profunctor.Strong as Export (Strong(..), Costrong(..)) @@ -32,6 +36,8 @@ import Data.Profunctor.Closed as Export (Closed(..)) import Data.Profunctor.Sieve as Export (Sieve(..), Cosieve(..)) import Data.Profunctor.Rep as Export (Representable(..), Corepresentable(..)) +import Data.Tuple as Export import Data.Tagged as Export import Data.Void as Export -import Numeric.Prelude as Export +import Test.Logic as Export +import Prelude as Export hiding (Num(..),subtract,sum,product,(^)) diff --git a/src/Data/Profunctor/Optic/Index.hs b/src/Data/Profunctor/Optic/Index.hs deleted file mode 100644 --- a/src/Data/Profunctor/Optic/Index.hs +++ /dev/null @@ -1,379 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DeriveGeneric #-} -module Data.Profunctor.Optic.Index ( - -- * Indexing - (%) - , iinit - , ilast - , reix - , imap - , withIxrepn - -- * Coindexing - , (#) - , kinit - , klast - , recx - , kmap - , cxed - , kjoin - , kreturn - , type Cx' - , kunit - , kpastro - , kfirst' - , withCxrepn - -- * Index - , Index(..) - , vals - , info - -- * Coindex - , Coindex(..) - , trivial - , noindex - , coindex - , (.#.) - -- * Coindex - , Conjoin(..) -) where - -import Control.Arrow as Arrow -import Control.Category (Category) -import Control.Monad -import Control.Monad.Fix -import Data.Profunctor.Closed -import Data.Profunctor.Rep -import Data.Profunctor.Sieve - -import Data.Bifunctor as B -import Data.Foldable -import Data.Semigroup -import Data.Profunctor.Optic.Import as I -import Data.Profunctor.Optic.Types -import Data.Profunctor.Strong -import GHC.Generics (Generic) - -import qualified Control.Category as C - ---------------------------------------------------------------------- --- Indexing ---------------------------------------------------------------------- - -infixr 8 % - -(%) :: (Additive-Semigroup) i => Representable p => IndexedOptic p i b1 b2 a1 a2 -> IndexedOptic p i c1 c2 b1 b2 -> IndexedOptic p i c1 c2 a1 a2 -f % g = repn $ \ia1a2 (ic,c1) -> - withIxrepn g ic c1 $ \ib b1 -> - withIxrepn f ib b1 $ \ia a1 -> ia1a2 (ib I.+ ia, a1) -{-# INLINE (%) #-} - -{- -iadd :: Profunctor p => IndexedOptic p i s t a b -> IndexedOptic p (Additive i) s t a b -iadd = reix Additive unAdditive - -imul :: Profunctor p => IndexedOptic p i s t a b -> IndexedOptic p (Multiplicative i) s t a b -imul = reix Multiplicative unMultiplicative --} -iinit :: Profunctor p => IndexedOptic p i s t a b -> IndexedOptic p (First i) s t a b -iinit = reix First getFirst - -ilast :: Profunctor p => IndexedOptic p i s t a b -> IndexedOptic p (Last i) s t a b -ilast = reix Last getLast - - --- | Map over the indices of an indexed optic. --- --- See also 'Data.Profunctor.Optic.Iso.reixed'. --- -reix :: Profunctor p => (i -> j) -> (j -> i) -> IndexedOptic p i s t a b -> IndexedOptic p j s t a b -reix ij ji = (. lmap (first' ij)) . (lmap (first' ji) .) - -imap :: Profunctor p => (s -> a) -> (b -> t) -> IndexedOptic p i s t a b -imap sa bt = dimap (fmap sa) bt - -withIxrepn :: Representable p => IndexedOptic p i s t a b -> i -> s -> (i -> a -> Rep p b) -> Rep p t -withIxrepn abst i s iab = (sieve . abst . tabulate $ uncurry iab) (i, s) - ---------------------------------------------------------------------- --- Coindexing ---------------------------------------------------------------------- - -infixr 8 # - --- | Compose two coindexed traversals, combining indices. --- --- Its precedence is one lower than that of function composition, which allows /./ to be nested in /#/. --- --- If you only need the final index then use /./. --- -(#) :: (Additive-Semigroup) k => Corepresentable p => CoindexedOptic p k b1 b2 a1 a2 -> CoindexedOptic p k c1 c2 b1 b2 -> CoindexedOptic p k c1 c2 a1 a2 -f # g = corepn $ \a1ka2 c1 kc -> - withCxrepn g c1 kc $ \b1 kb -> - withCxrepn f b1 kb $ \a1 ka -> a1ka2 a1 (kb I.+ ka) -{-# INLINE (#) #-} - -kinit :: Profunctor p => CoindexedOptic p k s t a b -> CoindexedOptic p (First k) s t a b -kinit = recx First getFirst - -klast :: Profunctor p => CoindexedOptic p k s t a b -> CoindexedOptic p (Last k) s t a b -klast = recx Last getLast - --- | Map over the indices of a coindexed optic. --- --- See also 'Data.Profunctor.Optic.Iso.recxed'. --- -recx :: Profunctor p => (k -> l) -> (l -> k) -> CoindexedOptic p k s t a b -> CoindexedOptic p l s t a b -recx kl lk = (. rmap (. kl)) . (rmap (. lk) .) - -kmap :: Profunctor p => (s -> a) -> (b -> t) -> CoindexedOptic p k s t a b -kmap sa bt = dimap sa (fmap bt) - --- | Generic type for a co-indexed optic. -type Cx p k a b = p a (k -> b) - -type Cx' p a b = Cx p a a b - -cxed :: Strong p => Iso (Cx p s s t) (Cx p k a b) (p s t) (p a b) -cxed = dimap kjoin kreturn - -kjoin :: Strong p => Cx p a a b -> p a b -kjoin = peval - -kreturn :: Profunctor p => p a b -> Cx p k a b -kreturn = rmap const - -kunit :: Strong p => Cx' p :-> p -kunit p = dimap fork apply (first' p) - -kpastro :: Profunctor p => Iso (Cx' p a b) (Cx' p c d) (Pastro p a b) (Pastro p c d) -kpastro = dimap (\p -> Pastro apply p fork) (\(Pastro l m r) -> dimap (fst . r) (\y a -> l (y, (snd (r a)))) m) - --- | 'Cx'' is freely strong. --- --- See . --- -kfirst' :: Profunctor p => Cx' p a b -> Cx' p (a, c) (b, c) -kfirst' = dimap fst (B.first @(,)) - -withCxrepn :: Corepresentable p => CoindexedOptic p k s t a b -> Corep p s -> k -> (Corep p a -> k -> b) -> t -withCxrepn abst s k akb = (cosieve . abst $ cotabulate akb) s k - ---------------------------------------------------------------------- --- Index ---------------------------------------------------------------------- - --- | An indexed store that characterizes a 'Data.Profunctor.Optic.Lens.Lens' --- --- @'Index' a b s ≡ forall f. 'Functor' f => (a -> f b) -> f s@, --- --- See also 'Data.Profunctor.Optic.Lens.withLensVl'. --- -data Index a b s = Index a (b -> s) deriving Generic - -vals :: Index a b s -> b -> s -vals (Index _ bs) = bs -{-# INLINE vals #-} - -info :: Index a b s -> a -info (Index a _) = a -{-# INLINE info #-} - -instance Functor (Index a b) where - fmap f (Index a bs) = Index a (f . bs) - {-# INLINE fmap #-} - -instance Profunctor (Index a) where - dimap f g (Index a bs) = Index a (g . bs . f) - {-# INLINE dimap #-} - -instance a ~ b => Foldable (Index a b) where - foldMap f (Index b bs) = f . bs $ b - ---------------------------------------------------------------------- --- Coindex ---------------------------------------------------------------------- - --- | An indexed continuation that characterizes a 'Data.Profunctor.Optic.Grate.Grate' --- --- @'Coindex' a b s ≡ forall f. 'Functor' f => (f a -> b) -> f s@, --- --- See also 'Data.Profunctor.Optic.Grate.withGrateVl'. --- --- 'Coindex' can also be used to compose indexed maps, folds, or traversals directly. --- --- For example, using the @containers@ library: --- --- @ --- Coindex mapWithKey :: Coindex (a -> b) (Map k a -> Map k b) k --- Coindex foldMapWithKey :: Monoid m => Coindex (a -> m) (Map k a -> m) k --- Coindex traverseWithKey :: Applicative t => Coindex (a -> t b) (Map k a -> t (Map k b)) k --- @ --- -newtype Coindex a b s = Coindex { runCoindex :: (s -> a) -> b } deriving Generic - -instance Functor (Coindex a b) where - fmap sl (Coindex abs) = Coindex $ \la -> abs (la . sl) - -instance a ~ b => Apply (Coindex a b) where - (Coindex slab) <.> (Coindex abs) = Coindex $ \la -> slab $ \sl -> abs (la . sl) - -instance a ~ b => Applicative (Coindex a b) where - pure s = Coindex ($s) - (<*>) = (<.>) - -trivial :: Coindex a b a -> b -trivial (Coindex f) = f id -{-# INLINE trivial #-} - --- | Lift a regular function into a coindexed function. --- --- For example, to traverse two layers, keeping only the first index: --- --- @ --- Coindex 'Data.Map.mapWithKey' .#. noindex 'Data.Map.map' --- :: Monoid k => --- Coindex (a -> b) (Map k (Map j a) -> Map k (Map j b)) k --- @ --- -noindex :: Monoid s => (a -> b) -> Coindex a b s -noindex f = Coindex $ \a -> f (a mempty) - -coindex :: Functor f => s -> (a -> b) -> Coindex (f a) (f b) s -coindex s ab = Coindex $ \sfa -> fmap ab (sfa s) -{-# INLINE coindex #-} - -infixr 9 .#. - --- | Compose two coindexes. --- --- When /s/ is a 'Monoid', 'Coindex' can be used to compose indexed traversals, folds, etc. --- --- For example, to keep track of only the first index seen, use @Data.Monoid.First@: --- --- @ --- fmap (First . pure) :: Coindex a b c -> Coindex a b (First c) --- @ --- --- or keep track of all indices using a list: --- --- @ --- fmap (:[]) :: Coindex a b c -> Coindex a b [c] --- @ --- -(.#.) :: Semigroup s => Coindex b c s -> Coindex a b s -> Coindex a c s -Coindex f .#. Coindex g = Coindex $ \b -> f $ \s1 -> g $ \s2 -> b (s1 <> s2) - ---------------------------------------------------------------------- --- Conjoin ---------------------------------------------------------------------- - --- '(->)' is simultaneously both indexed and co-indexed. -newtype Conjoin j a b = Conjoin { unConjoin :: j -> a -> b } - -instance Functor (Conjoin j a) where - fmap g (Conjoin f) = Conjoin $ \j a -> g (f j a) - {-# INLINE fmap #-} - -instance Apply (Conjoin j a) where - Conjoin f <.> Conjoin g = Conjoin $ \j a -> f j a (g j a) - {-# INLINE (<.>) #-} - -instance Applicative (Conjoin j a) where - pure b = Conjoin $ \_ _ -> b - {-# INLINE pure #-} - Conjoin f <*> Conjoin g = Conjoin $ \j a -> f j a (g j a) - {-# INLINE (<*>) #-} - -instance Monad (Conjoin j a) where - return = pure - {-# INLINE return #-} - Conjoin f >>= k = Conjoin $ \j a -> unConjoin (k (f j a)) j a - {-# INLINE (>>=) #-} - -instance MonadFix (Conjoin j a) where - mfix f = Conjoin $ \ j a -> let o = unConjoin (f o) j a in o - {-# INLINE mfix #-} - -instance Profunctor (Conjoin j) where - dimap ab cd jbc = Conjoin $ \j -> cd . unConjoin jbc j . ab - {-# INLINE dimap #-} - lmap ab jbc = Conjoin $ \j -> unConjoin jbc j . ab - {-# INLINE lmap #-} - rmap bc jab = Conjoin $ \j -> bc . unConjoin jab j - {-# INLINE rmap #-} - -instance Closed (Conjoin j) where - closed (Conjoin jab) = Conjoin $ \j xa x -> jab j (xa x) - -instance Costrong (Conjoin j) where - unfirst (Conjoin jadbd) = Conjoin $ \j a -> let - (b, d) = jadbd j (a, d) - in b - -instance Sieve (Conjoin j) ((->) j) where - sieve = flip . unConjoin - {-# INLINE sieve #-} - -instance Representable (Conjoin j) where - type Rep (Conjoin j) = (->) j - tabulate = Conjoin . flip - {-# INLINE tabulate #-} - -instance Cosieve (Conjoin j) ((,) j) where - cosieve = uncurry . unConjoin - {-# INLINE cosieve #-} - -instance Corepresentable (Conjoin j) where - type Corep (Conjoin j) = (,) j - cotabulate = Conjoin . curry - {-# INLINE cotabulate #-} - -instance Choice (Conjoin j) where - right' = right - {-# INLINE right' #-} - -instance Strong (Conjoin j) where - second' = Arrow.second - {-# INLINE second' #-} - -instance Category (Conjoin j) where - id = Conjoin (const id) - {-# INLINE id #-} - Conjoin f . Conjoin g = Conjoin $ \j -> f j . g j - {-# INLINE (.) #-} - -instance Arrow (Conjoin j) where - arr f = Conjoin (\_ -> f) - {-# INLINE arr #-} - first f = Conjoin (Arrow.first . unConjoin f) - {-# INLINE first #-} - second f = Conjoin (Arrow.second . unConjoin f) - {-# INLINE second #-} - Conjoin f *** Conjoin g = Conjoin $ \j -> f j *** g j - {-# INLINE (***) #-} - Conjoin f &&& Conjoin g = Conjoin $ \j -> f j &&& g j - {-# INLINE (&&&) #-} - -instance ArrowChoice (Conjoin j) where - left f = Conjoin (left . unConjoin f) - {-# INLINE left #-} - right f = Conjoin (right . unConjoin f) - {-# INLINE right #-} - Conjoin f +++ Conjoin g = Conjoin $ \j -> f j +++ g j - {-# INLINE (+++) #-} - Conjoin f ||| Conjoin g = Conjoin $ \j -> f j ||| g j - {-# INLINE (|||) #-} - -instance ArrowApply (Conjoin j) where - app = Conjoin $ \i (f, b) -> unConjoin f i b - {-# INLINE app #-} - -instance ArrowLoop (Conjoin j) where - loop (Conjoin f) = Conjoin $ \j b -> let (c,d) = f j (b, d) in c - {-# INLINE loop #-} 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 @@ -14,8 +14,6 @@ , Iso' , iso , isoVl - , imapping - , kmapping , fmapping , contramapping , dimapping @@ -41,18 +39,14 @@ , coswapped , associated , coassociated - , involuted - , added - , subtracted - , non + , involuted , anon + , non -- * Primitive operators , withIso -- * Operators , invert , reover - , reixed - , recxed , op , au , aup @@ -64,11 +58,10 @@ import Control.Newtype.Generics (Newtype(..), op) import Data.Coerce import Data.Functor.Adjunction hiding (adjuncted) -import Data.Group import Data.Maybe (fromMaybe) import Data.Profunctor.Optic.Carrier import Data.Profunctor.Optic.Import -import Data.Profunctor.Optic.Index +import Data.Profunctor.Optic.Combinator import Data.Profunctor.Optic.Types import Data.Profunctor.Yoneda (Coyoneda(..), Yoneda(..)) @@ -130,18 +123,6 @@ g = runIdentity . (abst (Identity . getConst)) . Const {-# INLINE isoVl #-} --- | Lift an 'Iso' into an indexed version. --- -imapping :: Profunctor p => AIso s t a b -> IndexedOptic p i s t a b -imapping o = withIso o imap -{-# INLINE imapping #-} - --- | Lift an 'Iso' into a coindexed version. --- -kmapping :: Profunctor p => AIso s t a b -> CoindexedOptic p k s t a b -kmapping o = withIso o kmap -{-# INLINE kmapping #-} - -- | Lift an 'Iso' into a pair of functors. -- fmapping :: Functor f => Functor g => AIso s t a b -> Iso (f s) (g t) (f a) (g b) @@ -345,33 +326,22 @@ involuted = M.join iso {-# INLINE involuted #-} --- | The group isomorphism defined by an element's action. --- -added :: Group a => a -> Iso' a a -added n = iso (<> n) (<< n) -{-# INLINE added #-} - --- | The group isomorphism defined by an element's inverse action. +-- | Generalize @'non' a@ to take any value and a predicate. -- --- @ --- 'subtracted' n = 're' ('added' n) --- @ +-- Assumes that @p a@ holds @'True'@ and generates an isomorphism between @'Maybe' (a | 'not' (p a))@ and @a@. -- -subtracted :: Group a => a -> Iso' a a -subtracted n = iso (<< n) (<> n) -{-# INLINE subtracted #-} +anon :: a -> (a -> Bool) -> Iso' (Maybe a) a +anon a p = iso (fromMaybe a) go where + go b | p b = Nothing + | otherwise = Just b +{-# INLINE anon #-} -- | Remove a single value from a type. -- --- @ --- 'non' ≡ 'non'' '.' 'only' --- @ --- --- >>> non 0 #^ rem 10 4 --- Just 2 --- --- >>> non 0 #^ rem 10 5 +-- >>> review (non "foo") "foo" -- Nothing +-- >>> review (non "foo") "foobar" +-- Just "foobar" -- non :: Eq a => a -> Iso' (Maybe a) a non def = iso (fromMaybe def) g @@ -379,30 +349,10 @@ | otherwise = Just a {-# INLINE non #-} --- | Generalize @'non' a@ to take any value and a predicate. --- --- Assumes that @p a@ holds @'True'@ and generates an isomorphism between @'Maybe' (a | 'not' (p a))@ and @a@. --- -anon :: a -> (a -> Bool) -> Iso' (Maybe a) a -anon a p = iso (fromMaybe a) go where - go b | p b = Nothing - | otherwise = Just b -{-# INLINE anon #-} - --------------------------------------------------------------------- --- Primitive operators ---------------------------------------------------------------------- - ---withIsoVl - ---------------------------------------------------------------------- -- Operators --------------------------------------------------------------------- ---------------------------------------------------------------------- --- Operators ---------------------------------------------------------------------- - -- | Invert an isomorphism. -- -- @ @@ -425,18 +375,6 @@ reover o = withIso o $ \sa bt ts -> sa . ts . bt {-# INLINE reover #-} --- | Remap the indices of an indexed optic. --- -reixed :: Profunctor p => AIso' i j -> IndexedOptic p i s t a b -> IndexedOptic p j s t a b -reixed o = withIso o reix -{-# INLINE reixed #-} - --- | Remap the indices of a coindexed optic. --- -recxed :: Profunctor p => AIso' k l -> CoindexedOptic p k s t a b -> CoindexedOptic p l s t a b -recxed o = withIso o recx -{-# INLINE recxed #-} - -- | Based on /ala/ from Conor McBride's work on Epigram. -- -- This version is generalized to accept any 'Iso', not just a @newtype@. @@ -447,7 +385,7 @@ -- You may want to think of this combinator as having the following, simpler type: -- -- @ --- au :: AnIso s t a b -> ((b -> t) -> e -> s) -> e -> a +-- 'au' :: 'AIso' s t a b -> ((b -> t) -> e -> s) -> e -> a -- @ -- au :: Functor f => AIso s t a b -> ((b -> t) -> f s) -> f a @@ -456,9 +394,9 @@ -- | Variant of 'au' for profunctors. -- --- >>> :t flip aup runStar --- flip aup runStar --- :: Functor f => AIso s t a (f a) -> Star f c s -> c -> t +-- @ +-- 'flip' 'aup' 'runStar' :: Functor f => AIso s t a (f a) -> Star f c s -> c -> t +-- @ -- aup :: Profunctor p => Functor f => AIso s t a b -> (p c a -> f b) -> p c s -> f t aup o = withIso o $ \sa bt f g -> fmap bt (f (rmap sa g)) @@ -470,24 +408,19 @@ -- -- >>> ala Sum foldMap [1,2,3,4] -- 10 --- -- >>> ala All foldMap [True,True] -- True --- -- >>> ala All foldMap [True,False] -- False --- -- >>> ala Any foldMap [False,False] -- False --- -- >>> ala Any foldMap [True,False] -- True --- -- >>> ala Product foldMap [1,2,3,4] -- 24 -- -- @ --- ala :: Newtype s => Newtype t => (O s -> s) -> ((O t -> t) -> e -> s) -> e -> O s +-- 'ala' :: 'Newtype' s => 'Newtype' t => ('O' s -> s) -> (('O' t -> t) -> e -> s) -> e -> O s -- @ -- ala :: Newtype s => Newtype t => Functor f => (O s -> s) -> ((O t -> t) -> f s) -> f (O s) 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 @@ -6,53 +6,82 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} module Data.Profunctor.Optic.Lens ( - -- * Lens & Ixlens + -- * Lens Lens , Lens' - , Ixlens - , Ixlens' + , Colens + , Colens' , lens - , ilens , lensVl - , ilensVl , matching , cloneLens + , colens + , colensVl + , comatching + , cloneColens + -- * Grate + , Grate + , Grate' + , grate + , grateVl + , inverting + , cloneGrate -- * Optics , united , voided - , indexed - -- * Indexed optics - , ifirst - , isecond - -- * Primitive operators - , withLens - , withLensVl - , withIxlens + , represented + , distributed + , endomorphed + , precomposed + , dotted + , continued + , continuedT + , calledCC -- * Operators + , zipsWith0 + , zipsWith2 + , zipsWith3 + , zipsWith4 + , zipsWithF , toPastro , toTambara + , toClosure + , toEnvironment -- * Classes , Strong(..) + , Costrong(..) + , Closed(..) ) where -import Data.Profunctor.Strong +import Control.Monad.Cont +import Data.Distributive +import Data.Monoid (Endo(..)) +import Data.Profunctor.Closed import Data.Profunctor.Optic.Carrier +import Data.Profunctor.Optic.Combinator import Data.Profunctor.Optic.Import -import Data.Profunctor.Optic.Index +import Data.Profunctor.Optic.Iso import Data.Profunctor.Optic.Types - +import Data.Profunctor.Strong +import Data.Semimodule.Free import qualified Data.Functor.Rep as F -- $setup -- >>> :set -XNoOverloadedStrings -- >>> :set -XTypeApplications +-- >>> :set -XTypeFamilies -- >>> :set -XFlexibleContexts --- >>> import Data.Semimodule.Free --- >>> import Data.Semimodule.Basis +-- >>> :set -XTupleSections +-- >>> import Control.Arrow +-- >>> import Control.Monad.Reader +-- >>> import Data.Int +-- >>> import Data.Complex +-- >>> import Data.List as L +-- >>> import Data.Monoid (Endo(..)) -- >>> :load Data.Profunctor.Optic --------------------------------------------------------------------- --- 'Lens' & 'Ixlens' +-- 'Lens' --------------------------------------------------------------------- -- | Obtain a 'Lens' from a getter and setter. @@ -73,26 +102,6 @@ lens sa sbt = dimap (id &&& sa) (uncurry sbt) . second' {-# INLINE lens #-} --- | Obtain an indexed 'Lens' from an indexed getter and a setter. --- --- Compare 'lens' and 'Data.Profunctor.Optic.Traversal.itraversal'. --- --- /Caution/: In order for the generated optic to be well-defined, --- you must ensure that the input functions constitute a legal --- indexed lens: --- --- * @snd . sia (sbt s a) ≡ a@ --- --- * @sbt s (snd $ sia s) ≡ s@ --- --- * @sbt (sbt s a1) a2 ≡ sbt s a2@ --- --- See 'Data.Profunctor.Optic.Property'. --- -ilens :: (s -> (i , a)) -> (s -> b -> t) -> Ixlens i s t a b -ilens sia sbt = ilensVl $ \iab s -> sbt s <$> uncurry iab (sia s) -{-# INLINE ilens #-} - -- | Transform a Van Laarhoven lens into a profunctor lens. -- -- Compare 'Data.Profunctor.Optic.Grate.grateVl' and 'Data.Profunctor.Optic.Traversal.traversalVl'. @@ -115,65 +124,143 @@ lensVl abst = dimap ((info &&& vals) . abst (flip Index id)) (uncurry id . swap) . first' {-# INLINE lensVl #-} --- | Transform an indexed Van Laarhoven lens into an indexed profunctor 'Lens'. +-- | Obtain a 'Lens' from its free tensor representation. -- --- An 'Ixlens' is a valid 'Ixtraversal'. Compare 'Data.Profunctor.Optic.Traversal.itraversalVl'. +matching :: (s -> (c , a)) -> ((c , b) -> t) -> Lens s t a b +matching sca cbt = dimap sca cbt . second' + +-- | TODO: Document -- --- /Caution/: In order for the generated optic to be well-defined, --- you must ensure that the input satisfies the following properties: +cloneLens :: ALens s t a b -> Lens s t a b +cloneLens o = withLens o lens + +-- | Obtain a 'Colens' from a getter and setter. -- --- * @iabst (const Identity) ≡ Identity@ +-- @ +-- 'colens' f g ≡ \\f g -> 're' ('lens' f g) +-- 'colens' bsia bt ≡ 'colensVl' '$' \\ts b -> bsia b '<$>' (ts . bt '$' b) +-- 'review' $ 'colens' f g ≡ f +-- 'set' . 're' $ 're' ('lens' f g) ≡ g +-- @ -- --- * @fmap (iabst $ const f) . (iabst $ const g) ≡ getCompose . iabst (const $ Compose . fmap f . g)@ +-- /Caution/: Colenses are recursive, similar to < http://hackage.haskell.org/package/base-4.12.0.0/docs/Control-Arrow.html#t:ArrowLoop ArrowLoop >. +-- In addition to the normal optic laws, the input functions must have +-- the correct < https://wiki.haskell.org/Lazy_pattern_match laziness > annotations. -- --- More generally, a profunctor optic must be monoidal as a natural --- transformation: --- --- * @o id ≡ id@ +-- For example, this is a perfectly valid 'Colens': -- --- * @o ('Data.Profunctor.Composition.Procompose' p q) ≡ 'Data.Profunctor.Composition.Procompose' (o p) (o q)@ +-- @ +-- ct21 :: Colens a b (a, c) (b, c) +-- ct21 = flip colens fst $ \ ~(_,c) b -> (b,c) +-- @ -- +-- However removing the annotation will result in a faulty optic. +-- -- See 'Data.Profunctor.Optic.Property'. -- -ilensVl :: (forall f. Functor f => (i -> a -> f b) -> s -> f t) -> Ixlens i s t a b -ilensVl f = lensVl $ \iab -> f (curry iab) . snd -{-# INLINE ilensVl #-} +colens :: (b -> s -> a) -> (b -> t) -> Colens s t a b +colens bsa bt = unsecond . dimap (uncurry bsa) (id &&& bt) --- | Obtain a 'Lens' from its free tensor representation. +-- | Transform a Van Laarhoven colens into a profunctor colens. -- -matching :: (s -> (c , a)) -> ((c , b) -> t) -> Lens s t a b -matching sca cbt = dimap sca cbt . second' +-- Compare 'grateVl'. +-- +-- /Caution/: In addition to the normal optic laws, the input functions +-- must have the correct laziness annotations. +-- +-- For example, this is a perfectly valid 'Colens': +-- +-- @ +-- ct21 :: Colens a b (a, c) (b, c) +-- ct21 = colensVl $ \f ~(a,b) -> (,b) <$> f a +-- @ +-- +-- However removing the annotation will result in a faulty optic. +-- +colensVl :: (forall f. Functor f => (t -> f s) -> b -> f a) -> Colens s t a b +colensVl o = unfirst . dimap (uncurry id . swap) ((info &&& vals) . o (flip Index id)) +-- | Obtain a 'Colens' from its free tensor representation. +-- +-- >>> fib = comatching (uncurry L.take . swap) (id &&& L.reverse) --fib :: Colens Int [Int] [Int] [Int] +-- >>> 10 & fib ..~ \xs -> 1 : 1 : Prelude.zipWith (+) xs (Prelude.tail xs) +-- [89,55,34,21,13,8,5,3,2,1,1] +-- +comatching :: ((c , s) -> a) -> (b -> (c , t)) -> Colens s t a b +comatching csa bct = unsecond . dimap csa bct + -- | TODO: Document -- -cloneLens :: ALens s t a b -> Lens s t a b -cloneLens o = withLens o lens +cloneColens :: AColens s t a b -> Colens s t a b +cloneColens o = withColens o colens --------------------------------------------------------------------- --- Primitive operators +-- 'Grate' --------------------------------------------------------------------- --- | Extract the higher order function that characterizes a 'Lens'. +-- | Obtain a 'Grate' from a nested continuation. -- --- The lens laws can be stated in terms of 'withLens': --- --- Identity: --- --- @ --- withLensVl o Identity ≡ Identity --- @ --- --- Composition: +-- The resulting optic is the corepresentable counterpart to 'Lens', +-- and sits between 'Iso' and 'Setter'. +-- +-- A 'Grate' lets you lift a profunctor through any representable +-- functor (aka Naperian container). In the special case where the +-- indexing type is finitary (e.g. 'Bool') then the tabulated type is +-- isomorphic to a fied length vector (e.g. 'V2 a'). +-- +-- The identity container is representable, and representable functors +-- are closed under composition. +-- +-- See +-- section 4.6 for more background on 'Grate's, and compare to the +-- /lens-family/ . +-- +-- /Caution/: In order for the generated optic to be well-defined, +-- you must ensure that the input function satisfies the following +-- properties: +-- +-- * @sabt ($ s) ≡ s@ +-- +-- * @sabt (\k -> f (k . sabt)) ≡ sabt (\k -> f ($ k))@ +-- +-- More generally, a profunctor optic must be monoidal as a natural +-- transformation: -- --- @ --- Compose . fmap (withLensVl o f) . withLensVl o g ≡ withLensVl o (Compose . fmap f . g) --- @ +-- * @o id ≡ id@ -- +-- * @o ('Data.Profunctor.Composition.Procompose' p q) ≡ 'Data.Profunctor.Composition.Procompose' (o p) (o q)@ +-- -- See 'Data.Profunctor.Optic.Property'. -- -withLensVl :: Functor f => ALens s t a b -> (a -> f b) -> s -> f t -withLensVl o ab s = withLens o $ \sa sbt -> sbt s <$> ab (sa s) +grate :: (((s -> a) -> b) -> t) -> Grate s t a b +grate sabt = dimap (flip ($)) sabt . closed +-- | Transform a Van Laarhoven grate into a profunctor grate. +-- +-- Compare 'Data.Profunctor.Optic.Lens.lensVl' & 'Data.Profunctor.Optic.Traversal.cotraversalVl'. +-- +-- /Caution/: In order for the generated family to be well-defined, +-- you must ensure that the traversal1 law holds for the input function: +-- +-- * @abst runIdentity ≡ runIdentity@ +-- +-- * @abst f . fmap (abst g) ≡ abst (f . fmap g . getCompose) . Compose@ +-- +-- See 'Data.Profunctor.Optic.Property'. +-- +grateVl :: (forall f. Functor f => (f a -> b) -> f s -> t) -> Grate s t a b +grateVl o = dimap (curry eval) ((o trivial) . Coindex) . closed + +-- | Construct a 'Grate' from a pair of inverses. +-- +inverting :: (s -> a) -> (b -> t) -> Grate s t a b +inverting sa bt = grate $ \sab -> bt (sab sa) + +-- | TODO: Document +-- +cloneGrate :: AGrate s t a b -> Grate s t a b +cloneGrate k = withGrate k grate + --------------------------------------------------------------------- -- Optics --------------------------------------------------------------------- @@ -198,45 +285,121 @@ voided :: Lens' Void a voided = lens absurd const --- | Obtain a 'Lens' from a representable functor. +-- | Obtain a 'Grate' from a 'F.Representable' functor. -- --- >>> V2 3 1 ^. indexed E21 --- 3 --- >>> V3 "foo" "bar" "baz" & indexed E32 .~ "bip" --- V3 "foo" "bip" "baz" +represented :: F.Representable f => Grate (f a) (f b) a b +represented = tabulated . closed +{-# INLINE represented #-} + +-- | Obtain a 'Grate' from a distributive functor. -- -indexed :: F.Representable f => Eq (F.Rep f) => F.Rep f -> Lens' (f a) a -indexed i = lensVl $ lensRep i +distributed :: Distributive f => Grate (f a) (f b) a b +distributed = grate (`cotraverse` id) +{-# INLINE distributed #-} -lensRep :: F.Representable f => Eq (F.Rep f) => F.Rep f -> forall g. Functor g => (a -> g a) -> f a -> g (f a) -lensRep i f s = setter s <$> f (getter s) - where getter = flip F.index i - setter s' b = F.tabulate $ \j -> bool (F.index s' j) b (i == j) -{-# INLINE lensRep #-} +-- | Obtain a 'Grate' from an endomorphism. +-- +-- >>> flip appEndo 2 $ zipsWith2 endomorphed (+) (Endo (*3)) (Endo (*4)) +-- 14 +-- +endomorphed :: Grate' (Endo a) a +endomorphed = dimap appEndo Endo . closed +{-# INLINE endomorphed #-} ---------------------------------------------------------------------- --- Indexed optics ---------------------------------------------------------------------- +-- | Obtain a 'Grate' from a linear map. +-- +precomposed :: Grate (Lin a b1 c) (Lin a b2 c) (Vec a b1) (Vec a b2) +precomposed = dimap runLin Lin . closed . dimap Vec runVec +{-# INLINE precomposed #-} --- | TODO: Document +-- | Obtain a 'Grate' from a linear functional. -- --- >>> ilists (ix @Int traversed . ifirst . ix traversed) [("foo",1), ("bar",2)] --- [(0,'f'),(1,'o'),(2,'o'),(0,'b'),(1,'a'),(2,'r')] --- >>> ilists (ix @Int traversed % ifirst % ix traversed) [("foo",1), ("bar",2)] --- [(0,'f'),(1,'o'),(2,'o'),(2,'b'),(3,'a'),(4,'r')] +dotted :: Grate c (Cov a c) a a +dotted = grate Cov +{-# INLINE dotted #-} + +-- | Obtain a 'Grate' from a continuation. -- -ifirst :: Ixlens i (a , c) (b , c) a b -ifirst = lmap assocl . first' +-- @ +-- 'zipsWith2' 'continued' :: (a -> a -> a) -> c -> c -> 'Cont' a c +-- @ +-- +continued :: Grate c (Cont a c) a a +continued = grate cont +{-# INLINE continued #-} --- | TODO: Document +-- | Obtain a 'Grate' from a continuation. -- -isecond :: Ixlens i (c , a) (c , b) a b -isecond = lmap (\(i, (c, a)) -> (c, (i, a))) . second' +-- @ +-- 'zipsWith2' 'continued' :: (m a -> m a -> m a) -> c -> c -> 'ContT' a m c +-- @ +-- +continuedT :: Grate c (ContT a m c) (m a) (m a) +continuedT = grate ContT +{-# INLINE continuedT #-} +-- | Lift the current continuation into the calling context. +-- +-- @ +-- 'zipsWith2' 'calledCC' :: 'MonadCont' m => (m b -> m b -> m s) -> s -> s -> m s +-- @ +-- +calledCC :: MonadCont m => Grate a (m a) (m b) (m a) +calledCC = grate callCC +{-# INLINE calledCC #-} + --------------------------------------------------------------------- -- Operators --------------------------------------------------------------------- +-- | Set all fields to the given value. +-- +-- This is essentially a restricted variant of 'Data.Profunctor.Optic.View.review'. +-- +zipsWith0 :: AGrate s t a b -> b -> t +zipsWith0 o b = withGrate o $ \sabt -> sabt (const b) +{-# INLINE zipsWith0 #-} + +-- | Zip over a 'Grate'. +-- +-- @\\f -> 'zipsWith2' 'closed' ('zipsWith2' 'closed' f) ≡ 'zipsWith2' ('closed' . 'closed')@ +-- +zipsWith2 :: AGrate s t a b -> (a -> a -> b) -> s -> s -> t +zipsWith2 o aab s1 s2 = withGrate o $ \sabt -> sabt $ \get -> aab (get s1) (get s2) +{-# INLINE zipsWith2 #-} + +-- | Zip over a 'Grate' with 3 arguments. +-- +zipsWith3 :: AGrate s t a b -> (a -> a -> a -> b) -> (s -> s -> s -> t) +zipsWith3 o aaab s1 s2 s3 = withGrate o $ \sabt -> sabt $ \sa -> aaab (sa s1) (sa s2) (sa s3) +{-# INLINE zipsWith3 #-} + +-- | Zip over a 'Grate' with 4 arguments. +-- +zipsWith4 :: AGrate s t a b -> (a -> a -> a -> a -> b) -> (s -> s -> s -> s -> t) +zipsWith4 o aaaab s1 s2 s3 s4 = withGrate o $ \sabt -> sabt $ \sa -> aaaab (sa s1) (sa s2) (sa s3) (sa s4) +{-# INLINE zipsWith4 #-} + +-- | Extract the higher order function that characterizes a 'Grate'. +-- +-- The grate laws can be stated in terms or 'withGrate': +-- +-- Identity: +-- +-- @ +-- zipsWithF o runIdentity ≡ runIdentity +-- @ +-- +-- Composition: +-- +-- @ +-- zipsWithF o f . fmap (zipsWithF o g) ≡ zipsWithF o (f . fmap g . getCompose) . Compose +-- @ +-- +zipsWithF :: Functor f => AGrate s t a b -> (f a -> b) -> f s -> t +zipsWithF = withGrateVl +{-# INLINE zipsWithF #-} + -- | Use a 'Lens' to construct a 'Pastro'. -- toPastro :: ALens s t a b -> p a b -> Pastro p s t @@ -246,3 +409,15 @@ -- toTambara :: Strong p => ALens s t a b -> p a b -> Tambara p s t toTambara o p = withLens o $ \sa sbt -> Tambara (first' . lens sa sbt $ p) + +-- | Use a 'Grate' to construct a 'Closure'. +-- +toClosure :: Closed p => AGrate s t a b -> p a b -> Closure p s t +toClosure o p = withGrate o $ \sabt -> Closure (closed . grate sabt $ p) +{-# INLINE toClosure #-} + +-- | Use a 'Grate' to construct an 'Environment'. +-- +toEnvironment :: Closed p => AGrate s t a b -> p a b -> Environment p s t +toEnvironment o p = withGrate o $ \sabt -> Environment sabt p (curry eval) +{-# INLINE toEnvironment #-} diff --git a/src/Data/Profunctor/Optic/Operator.hs b/src/Data/Profunctor/Optic/Operator.hs deleted file mode 100644 --- a/src/Data/Profunctor/Optic/Operator.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -module Data.Profunctor.Optic.Operator ( - (&) - , (%) - , (#) - , (^.) - , (^%) - , (#^) - , (..~) - , (.~) - , (%%~) - , (%~) - , (##~) - , (#~) -) where - -import Data.Function -import Data.Profunctor.Optic.Carrier -import Data.Profunctor.Optic.Types -import Data.Profunctor.Optic.Import -import Data.Profunctor.Optic.Index - -import qualified Data.Bifunctor as B - --- $setup --- >>> :set -XNoOverloadedStrings --- >>> :set -XTypeApplications --- >>> :set -XFlexibleContexts --- >>> :set -XRankNTypes --- >>> import Data.List.Index as LI --- >>> import Data.Maybe --- >>> import Data.Monoid --- >>> :load Data.Profunctor.Optic - -infixr 4 .~, ..~, %~, %%~, #~, ##~ - -infixl 8 ^., ^% - -infixr 8 #^ - --- | View the focus of an optic. --- --- Fixity and semantics are such that subsequent field accesses can be --- performed with ('Prelude..'). --- --- >>> ("hello","world") ^. second' --- "world" --- --- >>> 5 ^. to succ --- 6 --- --- >>> import Data.Complex --- >>> ((0, 1 :+ 2), 3) ^. first' . second' . to magnitude --- 2.23606797749979 --- -(^.) :: s -> AView s a -> a -(^.) s o = withPrimView o id s -{-# INLINE ( ^. ) #-} - --- | View the focus of an indexed optic along with its index. --- --- >>> ("foo", 42) ^% ifirst --- (Just (),"foo") --- -(^%) :: (Additive-Monoid) i => s -> AIxview i s a -> (Maybe i, a) -(^%) s o = withPrimView o (B.first Just) . (zero,) $ s -{-# INLINE (^%) #-} - --- | Dual to '^.'. --- --- @ --- 'from' f #^ x ≡ f x --- o #^ x ≡ x '^.' 're' o --- @ --- --- This is commonly used when using a 'Prism' as a smart constructor. --- --- >>> left' #^ 4 --- Left 4 --- -(#^) :: AReview t b -> b -> t -o #^ b = withPrimReview o id b -{-# INLINE (#^) #-} - --- | Map over an optic. --- --- >>> Just 1 & just ..~ (+1) --- Just 2 --- --- >>> Nothing & just ..~ (+1) --- Nothing --- --- >>> [1,2,3] & fmapped ..~ (*10) --- [10,20,30] --- --- >>> (1,2) & first' ..~ (+1) --- (2,2) --- --- >>> (10,20) & first' ..~ show --- ("10",20) --- -(..~) :: Optic (->) s t a b -> (a -> b) -> s -> t -(..~) = id -{-# INLINE (..~) #-} - --- | Set all referenced fields to the given value. --- -(.~) :: Optic (->) s t a b -> b -> s -> t -(.~) o b = o (const b) -{-# INLINE (.~) #-} - --- | Map over an indexed optic. --- --- See also '##~'. --- -(%%~) :: (Additive-Monoid) i => AIxsetter i s t a b -> (i -> a -> b) -> s -> t -(%%~) o f = withIxsetter o f zero -{-# INLINE (%%~) #-} - --- | Set the focus of an indexed optic. --- --- See also '#~'. --- --- /Note/ if you're looking for the infix 'over' it is '..~'. --- -(%~) :: (Additive-Monoid) i => AIxsetter i s t a b -> (i -> b) -> s -> t -(%~) o = (%%~) o . (const .) -{-# INLINE (%~) #-} - --- | Map over a coindexed optic. --- --- Infix variant of 'kover'. --- --- See also '%%~'. --- -(##~) :: (Additive-Monoid) k => ACxsetter k s t a b -> (k -> a -> b) -> s -> t -(##~) o f = withCxsetter o f zero -{-# INLINE (##~) #-} - --- | Set the focus of a coindexed optic. --- --- See also '%~'. --- -(#~) :: (Additive-Monoid) k => ACxsetter k s t a b -> (k -> b) -> s -> t -(#~) o kb = o ##~ flip (const kb) -{-# INLINE (#~) #-} diff --git a/src/Data/Profunctor/Optic/Option.hs b/src/Data/Profunctor/Optic/Option.hs deleted file mode 100644 --- a/src/Data/Profunctor/Optic/Option.hs +++ /dev/null @@ -1,293 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -module Data.Profunctor.Optic.Option ( - -- * Option & Ixoption - Option - , option - , ioption - , failing - , toOption - , fromOption - -- * Optics - , optioned - , filtered - -- * Primitive operators - , withOption - , withIxoption - -- * Operators - , (^?) - , preview - , preuse - , is - , isnt - -- * Indexed operators - , ipreview - , ipreviews - -- * MonadUnliftIO - , tries - , tries_ - , catches - , catches_ - , handles - , handles_ -) where - -import Control.Exception (Exception) -import Control.Monad.IO.Unlift -import Control.Monad.Reader as Reader hiding (lift) -import Control.Monad.State as State hiding (lift) -import Data.Maybe -import Data.Monoid hiding (All(..), Any(..)) -import Data.Profunctor.Optic.Carrier -import Data.Profunctor.Optic.Import -import Data.Profunctor.Optic.Prism (just, async) -import Data.Profunctor.Optic.Affine -import Data.Profunctor.Optic.Types -import Data.Profunctor.Optic.View -import qualified Control.Exception as Ex - --- $setup --- >>> :set -XNoOverloadedStrings --- >>> :set -XTypeApplications --- >>> :set -XFlexibleContexts --- >>> :set -XRankNTypes --- >>> import Control.Exception hiding (catches) --- >>> import Data.Functor.Identity --- >>> import Data.List.Index as LI --- >>> import Data.Map as Map --- >>> import Data.Maybe --- >>> import Data.Monoid --- >>> import Data.Semiring hiding (unital,nonunital,presemiring) --- >>> import Data.Sequence as Seq --- >>> import qualified Data.List.NonEmpty as NE --- >>> :load Data.Profunctor.Optic --- >>> let itraversed :: Ixtraversal Int [a] [b] a b ; itraversed = itraversalVl itraverse --- >>> let iat :: Int -> Ixaffine' Int [a] a; iat i = iaffine' (\s -> flip LI.ifind s $ \n _ -> n==i) (\s a -> LI.modifyAt i (const a) s) - ---------------------------------------------------------------------- --- 'Option' & 'Ixoption' ---------------------------------------------------------------------- - --- | Obtain a 'Option' directly. --- --- @ --- 'option' . 'preview' ≡ id --- 'option' ('view' o) ≡ o . 'just' --- @ --- --- >>> preview (option . preview $ selected even) (2, "yes") --- Just "yes" --- --- >>> preview (option . preview $ selected even) (3, "no") --- Nothing --- --- >>> preview (option listToMaybe) "foo" --- Just 'f' --- -option :: (s -> Maybe a) -> Option s a -option f = to (\s -> maybe (Left s) Right (f s)) . right' -{-# INLINE option #-} - --- | Obtain an 'Ixoption' directly. --- -ioption :: (s -> Maybe (i, a)) -> Ixoption i s a -ioption g = iaffineVl (\point f s -> maybe (point s) (uncurry f) $ g s) . coercer -{-# INLINE ioption #-} - -infixl 3 `failing` -- Same as (<|>) - --- | If the first 'Option' has no focus then try the second one. --- -failing :: AOption a s a -> AOption a s a -> Option s a -failing a b = option $ \s -> maybe (preview b s) Just (preview a s) -{-# INLINE failing #-} - --- | Obtain a 'Option' from a 'View'. --- --- @ --- 'toOption' o ≡ o . 'just' --- 'toOption' o ≡ 'option' ('view' o) --- @ --- -toOption :: View s (Maybe a) -> Option s a -toOption = (. just) -{-# INLINE toOption #-} - --- | Obtain a 'View' from a 'Option' --- -fromOption :: AOption a s a -> View s (Maybe a) -fromOption = to . preview -{-# INLINE fromOption #-} - ---------------------------------------------------------------------- --- Optics ---------------------------------------------------------------------- - --- | The canonical 'Option'. --- --- >>> [Just 1, Nothing] ^.. folded . optioned --- [1] --- -optioned :: Option (Maybe a) a -optioned = option id -{-# INLINE optioned #-} - --- | Filter another optic. --- --- >>> [1..10] ^.. folded . filtered even --- [2,4,6,8,10] --- -filtered :: (a -> Bool) -> Option a a -filtered p = affineVl (\point f a -> if p a then f a else point a) . coercer -{-# INLINE filtered #-} - ---------------------------------------------------------------------- --- Operators ---------------------------------------------------------------------- - -infixl 8 ^? - --- | An infix alias for 'preview''. --- --- @ --- ('^?') ≡ 'flip' 'preview'' --- @ --- --- Perform a safe 'head' of a 'Fold' or 'Traversal' or retrieve 'Just' --- the result from a 'View' or 'Lens'. --- --- When using a 'Traversal' as a partial 'Lens', or a 'Fold' as a partial --- 'View' this can be a convenient way to extract the optional value. --- --- >>> Left 4 ^? left' --- Just 4 --- >>> Right 4 ^? left' --- Nothing --- -(^?) :: s -> AOption a s a -> Maybe a -(^?) = flip preview -{-# INLINE (^?) #-} - --- | TODO: Document --- -preview :: MonadReader s m => AOption a s a -> m (Maybe a) -preview o = Reader.asks $ withOption o Just -{-# INLINE preview #-} - --- | TODO: Document --- -preuse :: MonadState s m => AOption a s a -> m (Maybe a) -preuse o = State.gets $ preview o -{-# INLINE preuse #-} - --- | Check whether the optic is matched. --- --- >>> is just Nothing --- False --- -is :: AOption a s a -> s -> Bool -is o s = isJust (preview o s) -{-# INLINE is #-} - --- | Check whether the optic isn't matched. --- --- >>> isnt just Nothing --- True --- -isnt :: AOption a s a -> s -> Bool -isnt o s = not (isJust (preview o s)) -{-# INLINE isnt #-} - ------------------------------------------------------------------------------- --- Indexed operators ------------------------------------------------------------------------------- - --- | TODO: Document --- -ipreview :: (Additive-Monoid) i => AIxoption (i , a) i s a -> s -> Maybe (i , a) -ipreview o = ipreviews o (,) -{-# INLINE ipreview #-} - --- | TODO: Document --- -ipreviews :: (Additive-Monoid) i => AIxoption r i s a -> (i -> a -> r) -> s -> Maybe r -ipreviews o f = withIxoption o (\i -> Just . f i) -{-# INLINE ipreviews #-} - ------------------------------------------------------------------------------- --- 'MonadUnliftIO' ------------------------------------------------------------------------------- - --- | Test for synchronous exceptions that match a given optic. --- --- In the style of 'safe-exceptions' this function rethrows async exceptions --- synchronously in order to preserve async behavior, --- --- @ --- 'tries' :: 'MonadUnliftIO' m => 'AOption' e 'Ex.SomeException' e -> m a -> m ('Either' e a) --- 'tries' 'exception' :: 'MonadUnliftIO' m => 'Exception' e => m a -> m ('Either' e a) --- @ --- -tries :: MonadUnliftIO m => Exception ex => AOption e ex e -> m a -> m (Either e a) -tries o a = withRunInIO $ \run -> run (Right `liftM` a) `Ex.catch` \e -> - if is async e then throwM e else run $ maybe (throwM e) (return . Left) (preview o e) -{-# INLINE tries #-} - --- | A variant of 'tries' that returns synchronous exceptions. --- -tries_ :: MonadUnliftIO m => Exception ex => AOption e ex e -> m a -> m (Maybe a) -tries_ o a = preview right' `liftM` tries o a -{-# INLINE tries_ #-} - --- | Catch synchronous exceptions that match a given optic. --- --- Rethrows async exceptions synchronously in order to preserve async behavior. --- --- @ --- 'catches' :: 'MonadUnliftIO' m => 'AOption' e 'Ex.SomeException' e -> m a -> (e -> m a) -> m a --- 'catches' 'exception' :: 'MonadUnliftIO' m => Exception e => m a -> (e -> m a) -> m a --- @ --- --- >>> catches (only Overflow) (throwIO Overflow) (\_ -> return "caught") --- "caught" --- -catches :: MonadUnliftIO m => Exception ex => AOption e ex e -> m a -> (e -> m a) -> m a -catches o a ea = withRunInIO $ \run -> run a `Ex.catch` \e -> - if is async e then throwM e else run $ maybe (throwM e) ea (preview o e) -{-# INLINE catches #-} - --- | Catch synchronous exceptions that match a given optic, discarding the match. --- --- >>> catches_ (only Overflow) (throwIO Overflow) (return "caught") --- "caught" --- -catches_ :: MonadUnliftIO m => Exception ex => AOption e ex e -> m a -> m a -> m a -catches_ o x y = catches o x $ const y -{-# INLINE catches_ #-} - --- | Flipped variant of 'catches'. --- --- >>> handles (only Overflow) (\_ -> return "caught") $ throwIO Overflow --- "caught" --- -handles :: MonadUnliftIO m => Exception ex => AOption e ex e -> (e -> m a) -> m a -> m a -handles o = flip $ catches o -{-# INLINE handles #-} - --- | Flipped variant of 'catches_'. --- --- >>> handles_ (only Overflow) (return "caught") $ throwIO Overflow --- "caught" --- -handles_ :: MonadUnliftIO m => Exception ex => AOption e ex e -> m a -> m a -> m a -handles_ o = flip $ catches_ o -{-# INLINE handles_ #-} - -throwM :: MonadIO m => Exception e => e -> m a -throwM = liftIO . Ex.throwIO -{-# INLINE throwM #-} diff --git a/src/Data/Profunctor/Optic/Prelude.hs b/src/Data/Profunctor/Optic/Prelude.hs deleted file mode 100644 --- a/src/Data/Profunctor/Optic/Prelude.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.Prelude ( - re - , invert - , (&) - -- * Composition - , (.) - , (%) - , (#) - -- * View operators - , view - , (^.) - , iview - , (^%) - , review - , (#^) - -- * Setter operators - , set - , (.~) - , iset - , (%~) - , kset - , (#~) - , over - , (..~) - , iover - , (%%~) - , kover - , (##~) - , (<>~) - -- * Fold operators - , preview - , (^?) - , is - , isnt - , matches - , lists - , (^..) - , ilists - , ilistsFrom - , (^%%) - , folds - , foldsa - , foldsr - , ifoldsr - , ifoldsrFrom - , foldsl - , ifoldsl - , ifoldslFrom - , foldsr' - , ifoldsr' - , foldsl' - , ifoldsl' - , foldsrM - , ifoldsrM - , foldslM - , ifoldslM - , traverses_ - , itraverses_ - , sums - , multiplies - , asums - , concats - , iconcats - , endo - , endoM - , finds - , ifinds - , has - , hasnt - , elem - , pelem - , joins - , joins' - , meets - , meets' - , mins - , maxes -) where - -import Control.Monad.Reader as Reader hiding (lift) -import Data.Function -import Data.Maybe -import Data.Monoid -import Data.Profunctor.Optic.Carrier -import Data.Profunctor.Optic.Types -import Data.Profunctor.Optic.Iso -import Data.Profunctor.Optic.View -import Data.Profunctor.Optic.Import -import Data.Profunctor.Optic.Index -import Data.Profunctor.Optic.Setter -import Data.Profunctor.Optic.Fold -import Data.Profunctor.Optic.Option -import Data.Profunctor.Optic.Affine -import Data.Prd (Prd, Minimal(..), Maximal(..)) -import Data.Semilattice - -import qualified Control.Applicative as A -import Data.Semiring as Rng -import qualified Prelude as Pre - --- $setup --- >>> :set -XNoOverloadedStrings --- >>> :set -XTypeApplications --- >>> :set -XFlexibleContexts --- >>> import Control.Exception hiding (catches) --- >>> import Data.Functor.Identity --- >>> import Data.List.Optic --- >>> import Data.Map as Map --- >>> import Data.Maybe --- >>> import Data.Monoid --- >>> import Data.Semiring hiding (unital,nonunital,presemiring) --- >>> import Data.Sequence as Seq hiding ((*)) --- >>> :load Data.Profunctor.Optic - - ---------------------------------------------------------------------- --- Fold operators ---------------------------------------------------------------------- - --- | The sum of a collection. --- -sums :: (Additive-Monoid) a => AFold ((Endo-Endo) a) s a -> s -> a -sums o = foldsl' o (+) zero - --- | The product of a collection. --- -multiplies :: (Multiplicative-Monoid) a => AFold ((Endo-Endo) a) s a -> s -> a -multiplies o = foldsl' o (*) one - --- | The sum of a collection of actions, generalizing 'concats'. --- --- >>> asums both ("hello","world") --- "helloworld" --- --- >>> asums both (Nothing, Just "hello") --- Just "hello" --- --- @ --- 'asum' ≡ 'asums' 'folded' --- @ --- -asums :: Alternative f => AFold ((Endo-Endo) (f a)) s (f a) -> s -> f a -asums o = foldsl' o (<|>) A.empty -{-# INLINE asums #-} - --- | Map a function over the foci of an optic and concatenate the resulting lists. --- --- >>> concats both (\x -> [x, x + 1]) (1,3) --- [1,2,3,4] --- --- @ --- 'concatMap' ≡ 'concats' 'folded' --- @ --- -concats :: AFold [r] s a -> (a -> [r]) -> s -> [r] -concats = withFold -{-# INLINE concats #-} - --- | Concatenate the results of a function of the foci of an indexed optic. --- --- @ --- 'concats' o ≡ 'iconcats' o '.' 'const' --- @ --- --- >>> iconcats itraversed (\i x -> [i + x, i + x + 1]) [1,2,3,4] --- [1,2,3,4,5,6,7,8] --- -iconcats :: (Additive-Monoid) i => AIxfold [r] i s a -> (i -> a -> [r]) -> s -> [r] -iconcats o f = withIxfold o f zero -{-# INLINE iconcats #-} - --- | TODO: Document --- -endo :: AFold (Endo (a -> a)) s (a -> a) -> s -> a -> a -endo o = foldsr o (.) id - --- | TODO: Document --- -endoM :: Monad m => AFold (Endo (a -> m a)) s (a -> m a) -> s -> a -> m a -endoM o = foldsr o (<=<) pure - --- | Find the first focus of an optic that satisfies a predicate, if one exists. --- --- >>> finds both even (1,4) --- Just 4 --- --- >>> finds folded even [1,3,5,7] --- Nothing --- --- @ --- 'Data.Foldable.find' ≡ 'finds' 'folded' --- @ --- -finds :: AFold ((Maybe-Endo) a) s a -> (a -> Bool) -> s -> Maybe a -finds o f = foldsr o (\a y -> if f a then Just a else y) Nothing -{-# INLINE finds #-} - --- | Find the first focus of an indexed optic that satisfies a predicate, if one exists. --- -ifinds :: (Additive-Monoid) i => AIxfold ((Maybe-Endo) (i, a)) i s a -> (i -> a -> Bool) -> s -> Maybe (i, a) -ifinds o f = ifoldsr o (\i a y -> if f i a then Just (i,a) else y) Nothing -{-# INLINE ifinds #-} - --- | Determine whether an optic has at least one focus. --- -has :: AFold (Additive Bool) s a -> s -> Bool -has o s = unAdditive $ withFold o (const $ Additive True) s -{-# INLINE has #-} - --- | Determine whether an optic does not have a focus. --- -hasnt :: AFold (Multiplicative Bool) s a -> s -> Bool -hasnt o s = unMultiplicative $ withFold o (const $ Multiplicative False) s -{-# INLINE hasnt #-} - --- | Determine whether the targets of a `Fold` contain a given element. --- -elem :: Eq a => AFold (Additive Bool) s a -> a -> s -> Bool -elem o a s = unAdditive $ withFold o (\x -> Additive $ x == a) s - --- | Determine whether the foci of an optic contain an element equivalent to a given element. --- -pelem :: Prd a => AFold (Additive Bool) s a -> a -> s -> Bool -pelem o a s = unAdditive $ withFold o (\x -> Additive $ x =~ a) s -{-# INLINE pelem #-} - --- | Compute the minimum of the targets of a totally ordered fold. --- -mins :: Pre.Ord a => AFold ((Endo-Endo) a) s a -> a -> s -> a -mins o = foldsl' o Pre.min - --- | Compute the maximum of the targets of a totally ordered fold. --- -maxes :: Pre.Ord a => AFold ((Endo-Endo) a) s a -> a -> s -> a -maxes o = foldsl' o Pre.max - --- | Compute the join of the foci of an optic. --- -joins :: Lattice a => AFold ((Endo-Endo) a) s a -> a -> s -> a -joins o = foldsl' o (∨) -{-# INLINE joins #-} - --- | Compute the join of the foci of an optic including a least element. --- -joins' :: Lattice a => Minimal a => AFold ((Endo-Endo) a) s a -> s -> a -joins' o = joins o minimal -{-# INLINE joins' #-} - --- | Compute the meet of the foci of an optic . --- -meets :: Lattice a => AFold ((Endo-Endo) a) s a -> a -> s -> a -meets o = foldsl' o (∧) -{-# INLINE meets #-} - --- | Compute the meet of the foci of an optic including a greatest element. --- -meets' :: Lattice a => Maximal a => AFold ((Endo-Endo) a) s a -> s -> a -meets' o = meets o maximal -{-# INLINE meets' #-} 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 @@ -9,24 +9,24 @@ -- * Prism & Cxprism Prism , Prism' - , Cxprism - , Cxprism' + , Coprism + , Coprism' , prism , prism' , handling , clonePrism + , coprism + , coprism' + , rehandling + , cloneCoprism -- * Optics , just + , cojust , nothing - , compared , prefixed , only , nearly , nthbit - , sync - , async - , exception - , asyncException -- * Primitive operators , withPrism -- * Operators @@ -39,15 +39,12 @@ , Choice(..) ) where -import Control.Exception import Control.Monad (guard) import Data.Bifunctor as B import Data.Bits (Bits, bit, testBit) import Data.List (stripPrefix,(++)) -import Data.Prd import Data.Profunctor.Choice import Data.Profunctor.Optic.Carrier -import Data.Profunctor.Optic.Iso import Data.Profunctor.Optic.Import import Data.Profunctor.Optic.Types @@ -105,6 +102,44 @@ clonePrism :: APrism s t a b -> Prism s t a b clonePrism o = withPrism o prism +-- | Obtain a 'Cochoice' optic from a constructor and a matcher function. +-- +-- @ +-- coprism f g ≡ \f g -> re (prism f g) +-- @ +-- +-- /Caution/: In order for the generated optic to be well-defined, +-- you must ensure that the input functions satisfy the following +-- properties: +-- +-- * @bat (bt b) ≡ Right b@ +-- +-- * @(id ||| bt) (bat b) ≡ b@ +-- +-- * @left bat (bat b) ≡ left Left (bat b)@ +-- +-- A 'Coprism' is a 'View', so you can specialise types to obtain: +-- +-- @ view :: 'Coprism'' s a -> s -> a @ +-- +coprism :: (s -> a) -> (b -> a + t) -> Coprism s t a b +coprism sa bat = unright . dimap (id ||| sa) bat + +-- | Create a 'Coprism' from a reviewer and a matcher function that produces a 'Maybe'. +-- +coprism' :: (s -> a) -> (a -> Maybe s) -> Coprism' s a +coprism' tb bt = coprism tb $ \b -> maybe (Left b) Right (bt b) + +-- | Obtain a 'Coprism' from its free tensor representation. +-- +rehandling :: (c + s -> a) -> (b -> c + t) -> Coprism s t a b +rehandling csa bct = unright . dimap csa bct + +-- | TODO: Document +-- +cloneCoprism :: ACoprism s t a b -> Coprism s t a b +cloneCoprism o = withCoprism o coprism + --------------------------------------------------------------------- -- Common 'Prism's and 'Coprism's --------------------------------------------------------------------- @@ -113,23 +148,22 @@ -- -- >>> Just 1 :| [Just 2, Just 3] & withCostar just sum -- Just 6 --- -- >>> Nothing :| [Just 2, Just 3] & withCostar just sum -- Nothing -- just :: Prism (Maybe a) (Maybe b) a b just = flip prism Just $ maybe (Left Nothing) Right +-- | Unfocus on the `Just` constructor of `Maybe`. +-- +cojust :: Coprism a b (Maybe a) (Maybe b) +cojust = coprism Just $ maybe (Left Nothing) Right + -- | Focus on the `Nothing` constructor of `Maybe`. -- nothing :: Prism (Maybe a) (Maybe b) () () nothing = flip prism (const Nothing) $ maybe (Right ()) (const $ Left Nothing) --- | Focus on comparability to a given element of a partial order. --- -compared :: Prd a => a -> Prism' a Ordering -compared x = flip prism' (const x) (pcompare x) - -- | Focus on the remainder of a list with a given prefix. -- prefixed :: Eq a => [a] -> Prism' [a] [a] @@ -142,9 +176,8 @@ -- | Create a 'Prism' from a value and a predicate. -- --- >>> nearly [] null #^ () +-- >>> review (nearly [] null) () -- [] --- -- >>> [1,2,3,4] ^? nearly [] null -- Nothing -- @@ -161,33 +194,6 @@ nthbit :: Bits s => Int -> Prism' s () nthbit n = prism' (guard . (flip testBit n)) (const $ bit n) --- | Focus on whether an exception is synchronous. --- -sync :: Exception e => Prism' e e -sync = filterOn $ \e -> case fromException (toException e) of - Just (SomeAsyncException _) -> False - Nothing -> True - where filterOn f = iso (branch' f) join . right' - --- | Focus on whether an exception is asynchronous. --- -async :: Exception e => Prism' e e -async = filterOn $ \e -> case fromException (toException e) of - Just (SomeAsyncException _) -> True - Nothing -> False - where filterOn f = iso (branch' f) join . right' - --- | Focus on whether a given exception has occurred. --- -exception :: Exception e => Prism' SomeException e -exception = prism' fromException toException - --- | Focus on whether a given asynchronous exception has occurred. --- -asyncException :: Exception e => Prism' SomeException e -asyncException = prism' asyncExceptionFromException asyncExceptionToException - - --------------------------------------------------------------------- -- Operators --------------------------------------------------------------------- @@ -220,7 +226,6 @@ -- -- >>> [Left 1, Right "foo", Left 4, Right "woot"] ^.. below right' -- [] --- -- >>> [Right "hail hydra!", Right "foo", Right "blah", Right "woot"] ^.. below right' -- [["hail hydra!","foo","blah","woot"]] -- 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 @@ -26,11 +26,11 @@ , id_grate , const_grate , compose_grate - -- * Affine - , Affine - , tofrom_affine - , fromto_affine - , idempotent_affine + -- * Traversal0 + , Traversal0 + , tofrom_traversal0 + , fromto_traversal0 + , idempotent_traversal0 -- * Traversal , Traversal , id_traversal @@ -53,16 +53,8 @@ import Data.Profunctor.Optic.Carrier import Data.Profunctor.Optic.Import import Data.Profunctor.Optic.Types -import Data.Profunctor.Optic.Iso ---import Data.Profunctor.Optic.View import Data.Profunctor.Optic.Setter -import Data.Profunctor.Optic.Lens -import Data.Profunctor.Optic.Prism -import Data.Profunctor.Optic.Grate ---import Data.Profunctor.Optic.Fold -import Data.Profunctor.Optic.Traversal -import Data.Profunctor.Optic.Cotraversal -import Data.Profunctor.Optic.Affine +import Test.Function.Invertible --------------------------------------------------------------------- -- 'Iso' @@ -107,8 +99,6 @@ -- 'Lens' --------------------------------------------------------------------- -invertible f g a = g (f a) == a - -- A 'Lens' is a valid 'Traversal' with the following additional laws: id_lens :: Eq s => Lens' s a -> s -> Bool @@ -157,29 +147,29 @@ rhs = withGrateVl o (f . fmap g . getCompose) . Compose --------------------------------------------------------------------- --- 'Affine' +-- 'Traversal0' --------------------------------------------------------------------- -- | You get back what you put in. -- -- * @sta (sbt a s) ≡ either (Left . const a) Right (sta s)@ -- -tofrom_affine :: Eq a => Eq s => Affine' s a -> s -> a -> Bool -tofrom_affine o s a = withAffine o $ \sta sbt -> sta (sbt s a) == either (Left . flip const a) Right (sta s) +tofrom_traversal0 :: Eq a => Eq s => Traversal0' s a -> s -> a -> Bool +tofrom_traversal0 o s a = withAffine o $ \sta sbt -> sta (sbt s a) == either (Left . flip const a) Right (sta s) -- | Putting back what you got doesn't change anything. -- -- * @either id (sbt s) (sta s) ≡ s@ -- -fromto_affine :: Eq s => Affine' s a -> s -> Bool -fromto_affine o s = withAffine o $ \sta sbt -> either id (sbt s) (sta s) == s +fromto_traversal0 :: Eq s => Traversal0' s a -> s -> Bool +fromto_traversal0 o s = withAffine o $ \sta sbt -> either id (sbt s) (sta s) == s -- | Setting twice is the same as setting once. -- -- * @sbt (sbt s a1) a2 ≡ sbt s a2@ -- -idempotent_affine :: Eq s => Affine' s a -> s -> a -> a -> Bool -idempotent_affine o s a1 a2 = withAffine o $ \_ sbt -> sbt (sbt s a1) a2 == sbt s a2 +idempotent_traversal0 :: Eq s => Traversal0' s a -> s -> a -> a -> Bool +idempotent_traversal0 o s a1 a2 = withAffine o $ \_ sbt -> sbt (sbt s a1) a2 == sbt s a2 --------------------------------------------------------------------- -- 'Traversal' @@ -188,23 +178,23 @@ -- A 'Traversal' is a valid 'Setter' with the following additional laws: id_traversal :: Eq s => Traversal' s a -> s -> Bool -id_traversal o = M.join invertible $ runIdentity . withTraversal o Identity +id_traversal o = M.join invertible $ runIdentity . withStar o Identity id_traversal1 :: Eq s => Traversal1' s a -> s -> Bool -id_traversal1 o = M.join invertible $ runIdentity . withTraversal1 o Identity +id_traversal1 o = M.join invertible $ runIdentity . withStar o Identity pure_traversal :: Eq (f s) => Applicative f => ATraversal' f s a -> s -> Bool -pure_traversal o = liftA2 (==) (withTraversal o pure) pure +pure_traversal o = liftA2 (==) (withStar o pure) pure -compose_traversal :: Eq (f (g s)) => Applicative f => Applicative g => Traversal' s a -> (a -> g a) -> (a -> f a) -> s -> Bool +compose_traversal :: Eq (f (g s)) => Applicative' f => Applicative' g => Traversal' s a -> (a -> g a) -> (a -> f a) -> s -> Bool compose_traversal o f g = liftA2 (==) lhs rhs - where lhs = fmap (withTraversal o f) . withTraversal o g - rhs = getCompose . withTraversal o (Compose . fmap f . g) + where lhs = fmap (withStar o f) . withStar o g + rhs = getCompose . withStar o (Compose . fmap f . g) compose_traversal1 :: Eq (f (g s)) => Apply f => Apply g => Traversal1' s a -> (a -> g a) -> (a -> f a) -> s -> Bool compose_traversal1 o f g s = lhs s == rhs s - where lhs = fmap (withTraversal1 o f) . withTraversal1 o g - rhs = getCompose . withTraversal1 o (Compose . fmap f . g) + where lhs = fmap (withStar o f) . withStar o g + rhs = getCompose . withStar o (Compose . fmap f . g) --------------------------------------------------------------------- -- 'Cotraversal' @@ -214,18 +204,18 @@ -- -- * @abst f . fmap (abst g) ≡ abst (f . fmap g . getCompose) . Compose @ -- --- The cotraversal laws can be restated in terms of 'cowithTraversal1': +-- The cotraversal laws can be restated in terms of 'cowithStar1': -- --- * @withCotraversal o (f . runIdentity) ≡ fmap f . runIdentity @ +-- * @withCostar o (f . runIdentity) ≡ fmap f . runIdentity @ -- --- * @withCotraversal o f . fmap (withCotraversal o g) == withCotraversal o (f . fmap g . getCompose) . Compose@ +-- * @withCostar o f . fmap (withCostar o g) == withCostar o (f . fmap g . getCompose) . Compose@ -- -- See also < https://www.cs.ox.ac.uk/jeremy.gibbons/publications/iterator.pdf > -- compose_cotraversal :: Eq s => Coapplicative f => Coapplicative g => Cotraversal' s a -> (f a -> a) -> (g a -> a) -> f (g s) -> Bool compose_cotraversal o f g = liftF2 (==) lhs rhs - where lhs = withCotraversal o f . fmap (withCotraversal o g) - rhs = withCotraversal o (f . fmap g . getCompose) . Compose + where lhs = withCostar o f . fmap (withCostar o g) + rhs = withCostar o (f . fmap g . getCompose) . Compose -} --------------------------------------------------------------------- -- 'Setter' 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,21 +10,17 @@ Setter , Setter' , setter - , isetter , closing -- * Resetter , Resetter , Resetter' , resetter - , ksetter -- * Optics , cod , dom , bound , fmapped , contramapped - , exmapped - , adjusted , liftedA , liftedM , forwarded @@ -32,25 +28,11 @@ , zipped , modded , cond - -- * Indexed optics - , imapped - , imappedRep - -- * Primitive operators - , withIxsetter - , withCxsetter -- * Operators , set - , iset - , kset - , (.~) - , (%~) - , (#~) , over - , iover - , kover + , (.~) , (..~) - , (%%~) - , (##~) , (<>~) -- * mtl , locally @@ -58,29 +40,19 @@ , assigns , modifies , (.=) - , (%=) - , (#=) , (..=) - , (%%=) - , (##=) , (<>=) ) where import Control.Applicative (liftA) -import Control.Exception (Exception(..)) import Control.Monad.Reader as Reader import Control.Monad.State as State import Control.Monad.Writer as Writer -import Data.Key as K import Data.Profunctor.Optic.Carrier import Data.Profunctor.Optic.Import hiding ((&&&)) -import Data.Profunctor.Optic.Index -import Data.Profunctor.Optic.Operator +import Data.Profunctor.Optic.Combinator import Data.Profunctor.Optic.Types -import qualified Control.Exception as Ex -import qualified Data.Functor.Rep as F - -- $setup -- >>> :set -XNoOverloadedStrings -- >>> :set -XTypeApplications @@ -88,7 +60,6 @@ -- >>> :set -XRankNTypes -- >>> import Control.Category ((>>>)) -- >>> import Control.Arrow (Kleisli(..)) --- >>> import Control.Exception -- >>> import Control.Monad.State -- >>> import Control.Monad.Reader -- >>> import Control.Monad.Writer @@ -97,14 +68,11 @@ -- >>> import Data.Functor.Rep -- >>> import Data.Functor.Identity -- >>> import Data.Functor.Contravariant --- >>> import Data.List.Index as LI -- >>> import Data.IntSet as IntSet -- >>> import Data.Set as Set -- >>> import Data.Tuple (swap) -- >>> :load Data.Profunctor.Optic --- >>> let iat :: Int -> Ixaffine' Int [a] a; iat i = iaffine' (\s -> flip LI.ifind s $ \n _ -> n==i) (\s a -> LI.modifyAt i (const a) s) - --------------------------------------------------------------------- -- Setter --------------------------------------------------------------------- @@ -137,26 +105,6 @@ setter abst = dimap (flip Index id) (\(Index s ab) -> abst ab s) . repn collect {-# INLINE setter #-} --- | Build an 'Ixsetter' from an indexed function. --- --- @ --- 'isetter' '.' 'iover' ≡ 'id' --- 'iover' '.' 'isetter' ≡ 'id' --- @ --- --- /Caution/: In order for the generated optic to be well-defined, --- you must ensure that the input satisfies the following properties: --- --- * @iabst (const id) ≡ id@ --- --- * @fmap (iabst $ const f) . (iabst $ const g) ≡ iabst (const $ f . g)@ --- --- See 'Data.Profunctor.Optic.Property'. --- -isetter :: ((i -> a -> b) -> s -> t) -> Ixsetter i s t a b -isetter f = setter $ \iab -> f (curry iab) . snd -{-# INLINE isetter #-} - -- | Every valid 'Grate' is a 'Setter'. -- closing :: (((s -> a) -> b) -> t) -> Setter s t a b @@ -181,21 +129,6 @@ resetter abst = dimap (\s -> Coindex $ \ab -> abst ab s) trivial . corepn (\f -> fmap f . sequenceA) {-# INLINE resetter #-} --- | TODO: Document --- --- /Caution/: In order for the generated optic to be well-defined, --- you must ensure that the input satisfies the following properties: --- --- * @kabst (const id) ≡ id@ --- --- * @fmap (kabst $ const f) . (kabst $ const g) ≡ kabst (const $ f . g)@ --- --- See 'Data.Profunctor.Optic.Property'. --- -ksetter :: ((k -> a -> t) -> s -> t) -> Cxsetter k s t a t -ksetter f = resetter $ \kab -> const . f (flip kab) -{-# INLINE ksetter #-} - --------------------------------------------------------------------- -- Optics --------------------------------------------------------------------- @@ -259,25 +192,6 @@ contramapped = setter contramap {-# INLINE contramapped #-} --- | Map one exception into another as proposed in the paper "A semantics for imprecise exceptions". --- --- >>> handles (only Overflow) (\_ -> return "caught") $ assert False (return "uncaught") & (exmapped ..~ \ (AssertionFailed _) -> Overflow) --- "caught" --- --- @ --- exmapped :: Exception e => Setter s s SomeException e --- @ --- -exmapped :: Exception e1 => Exception e2 => Setter s s e1 e2 -exmapped = setter Ex.mapException -{-# INLINE exmapped #-} - --- | 'Setter' on a particular value of an 'Adjustable' container. --- -adjusted :: Adjustable f => Key f -> Setter' (f a) a -adjusted i = setter $ \f -> K.adjust f i -{-# INLINE adjusted #-} - -- | 'Setter' on each value of an applicative. -- -- @ @@ -334,32 +248,13 @@ -- | Apply a function only when the given condition holds. -- --- See also 'Data.Profunctor.Optic.Affine.predicated' & 'Data.Profunctor.Optic.Prism.filtered'. +-- See also 'Data.Profunctor.Optic.Traversal0.predicated' & 'Data.Profunctor.Optic.Prism.filtered'. -- cond :: (a -> Bool) -> Setter' a a cond p = setter $ \f a -> if p a then f a else a {-# INLINE cond #-} --------------------------------------------------------------------- --- Indexed optics ---------------------------------------------------------------------- - --- | 'Ixsetter' on each value of a 'Keyed' container. --- -imapped :: Keyed f => Ixsetter (Key f) (f a) (f b) a b -imapped = isetter K.mapWithKey -{-# INLINE imapped #-} - --- | 'Ixsetter' on each value of a representable functor. --- --- >>> 1 :+ 2 & imappedRep %~ bool 20 10 --- 20 :+ 10 --- -imappedRep :: F.Representable f => Ixsetter (F.Rep f) (f a) (f b) a b -imappedRep = isetter F.imapRep -{-# INLINE imappedRep #-} - ---------------------------------------------------------------------- -- Operators --------------------------------------------------------------------- @@ -373,31 +268,6 @@ set = (.~) {-# INLINE set #-} --- | Prefix alias of '%~'. --- --- Equivalent to 'iover' with the current value ignored. --- --- @ --- 'set' o ≡ 'iset' o '.' 'const' --- @ --- --- >>> iset (iat 2) (2-) [1,2,3 :: Int] --- [1,2,0] --- >>> iset (iat 5) (const 0) [1,2,3 :: Int] --- [1,2,3] --- -iset :: (Additive-Monoid) i => AIxsetter i s t a b -> (i -> b) -> s -> t -iset o = iover o . (const .) -{-# INLINE iset #-} - --- | Prefix alias of '#~'. --- --- Equivalent to 'kover' with the current value ignored. --- -kset :: (Additive-Monoid) k => ACxsetter k s t a b -> (k -> b) -> s -> t -kset o kb = kover o $ flip (const kb) -{-# INLINE kset #-} - -- | Prefix alias of '..~'. -- -- @ @@ -420,22 +290,34 @@ over = id {-# INLINE over #-} --- | Prefix alias of '%%~'. --- --- >>> iover (iat 1) (+) [1,2,3 :: Int] --- [1,3,3] --- >>> iover (iat 5) (+) [1,2,3 :: Int] --- [1,2,3] +infixr 4 .~, ..~ + +-- | Set all referenced fields to the given value. -- -iover :: (Additive-Monoid) i => AIxsetter i s t a b -> (i -> a -> b) -> s -> t -iover = (%%~) -{-# INLINE iover #-} +(.~) :: Optic (->) s t a b -> b -> s -> t +(.~) o b = o (const b) +{-# INLINE (.~) #-} --- | Prefix alias of '##~'. +-- | Map over an optic. -- -kover :: (Additive-Monoid) k => ACxsetter k s t a b -> (k -> a -> b) -> s -> t -kover = (##~) -{-# INLINE kover #-} +-- >>> Just 1 & just ..~ (+1) +-- Just 2 +-- +-- >>> Nothing & just ..~ (+1) +-- Nothing +-- +-- >>> [1,2,3] & fmapped ..~ (*10) +-- [10,20,30] +-- +-- >>> (1,2) & first' ..~ (+1) +-- (2,2) +-- +-- >>> (10,20) & first' ..~ show +-- ("10",20) +-- +(..~) :: Optic (->) s t a b -> (a -> b) -> s -> t +(..~) = id +{-# INLINE (..~) #-} -- | Modify the target by adding another value. -- @@ -474,7 +356,7 @@ scribe o s = Writer.tell $ set o mempty s {-# INLINE scribe #-} -infix 4 .=, ..=, %=, %%=, #=, ##=, <>= +infix 4 .=, ..=, <>= -- | Replace the target(s) of a settable in a monadic state. -- @@ -501,18 +383,6 @@ o .= b = State.modify (o .~ b) {-# INLINE (.=) #-} --- | TODO: Document --- -(%=) :: MonadState s m => (Additive-Monoid) i => AIxsetter i s s a b -> (i -> b) -> m () -o %= b = State.modify (o %~ b) -{-# INLINE (%=) #-} - --- | TODO: Document --- -(#=) :: MonadState s m => (Additive-Monoid) k => ACxsetter k s s a b -> (k -> b) -> m () -o #= f = State.modify (o #~ f) -{-# INLINE (#=) #-} - -- | Map over the target(s) of a 'Setter' in a monadic state. -- -- This is an infixversion of 'modifies'. @@ -527,18 +397,6 @@ (..=) :: MonadState s m => Optic (->) s s a b -> (a -> b) -> m () o ..= f = State.modify (o ..~ f) {-# INLINE (..=) #-} - --- | TODO: Document --- -(%%=) :: MonadState s m => (Additive-Monoid) i => AIxsetter i s s a b -> (i -> a -> b) -> m () -o %%= f = State.modify (o %%~ f) -{-# INLINE (%%=) #-} - --- | TODO: Document --- -(##=) :: MonadState s m => (Additive-Monoid) k => ACxsetter k s s a b -> (k -> a -> b) -> m () -o ##= f = State.modify (o ##~ f) -{-# INLINE (##=) #-} -- | Modify the target(s) of a settable optic by adding a value. -- 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 @@ -6,30 +6,57 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} module Data.Profunctor.Optic.Traversal ( - -- * Traversal & Ixtraversal - Traversal + -- * Traversal0 + Traversal0 + , Traversal0' + , traversal0 + , traversal0' + , traversal0Vl + -- * Traversal + , Traversal , Traversal' - , Ixtraversal - , Ixtraversal' + , Cotraversal + , Cotraversal' , traversing - , itraversing , traversalVl - , itraversalVl - , noix - , ix + , cotraversing + , retraversing + , cotraversalVl -- * Traversal1 , Traversal1 , Traversal1' - , Ixtraversal1 - , Ixtraversal1' + , Cotraversal1 + , Cotraversal1' , traversing1 , traversal1Vl - , itraversal1Vl + , pappend + , (<<*>>) + , (****) + , (&&&&) + , divide + , divide' + , cochoose + , cochoose' + , cotraversing1 + , retraversing1 + , cotraversal1Vl + , (++++) + , (||||) + , codivide + , codivide' + , choose + , choose' -- * Optics + , nulled + , selected , traversed + , cotraversed , traversed1 + , cotraversed1 , both + , coboth , both1 + , coboth1 , duplicated , beside , bitraversed @@ -37,35 +64,33 @@ , repeated , iterated , cycled - -- * Indexed optics - , itraversed - , itraversed1 - , itraversedRep - -- * Primitive operators - , withTraversal - , withIxtraversal - , withTraversal1 - , withIxtraversal1 -- * Operators + , matches + , traverses + , cotraverses + , cotraverses1 + , traverses1 , sequences + , collects , sequences1 + , collects1 + -- * Classes + , Strong(..) + , Choice(..) + , Closed(..) + , Representable(..) + , Corepresentable(..) ) where -import Control.Category -import Control.Arrow +import Data.Function import Data.Bitraversable -import Data.Key as K -import Data.List.NonEmpty as NonEmpty import Data.Profunctor.Optic.Carrier +import Data.Profunctor.Optic.Prism import Data.Profunctor.Optic.Lens -import Data.Profunctor.Optic.Import hiding (id,(.)) +import Data.Profunctor.Optic.Import import Data.Profunctor.Optic.Types -import Data.Profunctor.Optic.Operator +import Data.Profunctor.Optic.Combinator import Data.Semigroup.Bitraversable -import Data.Semiring -import Control.Monad.Trans.State -import Prelude (Foldable(..), reverse) -import qualified Data.Functor.Rep as F -- $setup -- >>> :set -XNoOverloadedStrings @@ -73,18 +98,62 @@ -- >>> :set -XTypeApplications -- >>> :set -XTupleSections -- >>> :set -XRankNTypes +-- >>> import Data.Int +-- >>> import Data.String -- >>> import Data.Maybe -- >>> import Data.List.NonEmpty (NonEmpty(..)) -- >>> import qualified Data.List.NonEmpty as NE -- >>> import Data.Functor.Identity --- >>> import Data.List.Index -- >>> :load Data.Profunctor.Optic --- >>> let itraversed :: Ixtraversal Int Int [a] [b] a b ; itraversed = itraversalVl itraverse --------------------------------------------------------------------- --- 'Traversal' & 'Ixtraversal' +-- 'Traversal0' --------------------------------------------------------------------- +-- | Create a 'Traversal0' from match and constructor functions. +-- +-- /Caution/: In order for the 'Traversal0' to be well-defined, +-- you must ensure that the input functions satisfy the following +-- properties: +-- +-- * @sta (sbt a s) ≡ either (Left . const a) Right (sta s)@ +-- +-- * @either id (sbt s) (sta s) ≡ s@ +-- +-- * @sbt (sbt s a1) a2 ≡ sbt s a2@ +-- +-- More generally, a profunctor optic must be monoidal as a natural +-- transformation: +-- +-- * @o id ≡ id@ +-- +-- * @o ('Data.Profunctor.Composition.Procompose' p q) ≡ 'Data.Profunctor.Composition.Procompose' (o p) (o q)@ +-- +-- See 'Data.Profunctor.Optic.Property'. +-- +traversal0 :: (s -> t + a) -> (s -> b -> t) -> Traversal0 s t a b +traversal0 sta sbt = dimap (\s -> (s,) <$> sta s) (id ||| uncurry sbt) . right' . second' +{-# INLINE traversal0 #-} + +-- | Obtain a 'Traversal0'' from match and constructor functions. +-- +traversal0' :: (s -> Maybe a) -> (s -> a -> s) -> Traversal0' s a +traversal0' sa sas = flip traversal0 sas $ \s -> maybe (Left s) Right (sa s) +{-# INLINE traversal0' #-} + +-- | Transform a Van Laarhoven 'Traversal0' into a profunctor 'Traversal0'. +-- +traversal0Vl :: (forall f. Functor f => (forall c. c -> f c) -> (a -> f b) -> s -> f t) -> Traversal0 s t a b +traversal0Vl f = dimap (\s -> (s,) <$> eswap (sat s)) (id ||| uncurry sbt) . right' . second' + where + sat = f Right Left + sbt s b = runIdentity $ f Identity (\_ -> Identity b) s +{-# INLINE traversal0Vl #-} + +--------------------------------------------------------------------- +-- 'Traversal' +--------------------------------------------------------------------- + -- | Obtain a 'Traversal' by lifting a lens getter and setter into a 'Traversable' functor. -- -- @ @@ -112,27 +181,7 @@ -- traversing :: Traversable f => (s -> a) -> (s -> b -> t) -> Traversal (f s) (f t) a b traversing sa sbt = repn traverse . lens sa sbt - --- | Obtain a 'Ixtraversal' by lifting an indexed lens getter and setter into a 'Traversable' functor. --- --- @ --- 'withIxlens' o 'itraversing' ≡ 'itraversed' . o --- @ --- --- /Caution/: In order for the generated optic to be well-defined, --- you must ensure that the input functions constitute a legal --- indexed lens: --- --- * @snd . sia (sbt s a) ≡ a@ --- --- * @sbt s (snd $ sia s) ≡ s@ --- --- * @sbt (sbt s a1) a2 ≡ sbt s a2@ --- --- See 'Data.Profunctor.Optic.Property'. --- -itraversing :: (Additive-Monoid) i => Traversable f => (s -> (i , a)) -> (s -> b -> t) -> Ixtraversal i (f s) (f t) a b -itraversing sia sbt = repn (\iab -> traverse (curry iab zero) . snd) . ilens sia sbt +{-# INLINE traversing #-} -- | Obtain a profunctor 'Traversal' from a Van Laarhoven 'Traversal'. -- @@ -143,52 +192,63 @@ -- -- * @fmap (abst f) . abst g ≡ getCompose . abst (Compose . fmap f . g)@ -- +-- The traversal laws can be stated in terms of 'withStar': +-- +-- * @withStar t (pure . f) ≡ pure (fmap f)@ +-- +-- * @Compose . fmap (withStar t f) . withStar t g ≡ withStar t (Compose . fmap f . g)@ +-- -- See 'Data.Profunctor.Optic.Property'. -- traversalVl :: (forall f. Applicative f => (a -> f b) -> s -> f t) -> Traversal s t a b traversalVl abst = tabulate . abst . sieve +{-# INLINE traversalVl #-} --- | Lift an indexed VL traversal into an indexed profunctor traversal. +-- | Obtain a 'Cotraversal' by embedding a continuation into a 'Distributive' functor. -- +-- @ +-- 'withGrate' o 'cotraversing' ≡ 'cotraversed' . o +-- @ +-- -- /Caution/: In order for the generated optic to be well-defined, --- you must ensure that the input satisfies the following properties: +-- you must ensure that the input function satisfies the following +-- properties: -- --- * @iabst (const pure) ≡ pure@ +-- * @sabt ($ s) ≡ s@ -- --- * @fmap (iabst $ const f) . (iabst $ const g) ≡ getCompose . iabst (const $ Compose . fmap f . g)@ +-- * @sabt (\k -> f (k . sabt)) ≡ sabt (\k -> f ($ k))@ -- --- See 'Data.Profunctor.Optic.Property'. +cotraversing :: Distributive g => (((s -> a) -> b) -> t) -> Cotraversal (g s) (g t) a b +cotraversing sabt = corepn cotraverse . grate sabt + +-- | Obtain a 'Cotraversal' by embedding a reversed lens getter and setter into a 'Distributive' functor. -- -itraversalVl :: (forall f. Applicative f => (i -> a -> f b) -> s -> f t) -> Ixtraversal i s t a b -itraversalVl f = traversalVl $ \iab -> f (curry iab) . snd +-- @ +-- 'withLens' ('re' o) 'cotraversing' ≡ 'cotraversed' . o +-- @ +-- +retraversing :: Distributive g => (b -> t) -> (b -> s -> a) -> Cotraversal (g s) (g t) a b +retraversing bsa bt = corepn cotraverse . (re $ lens bsa bt) --- | Lift a VL traversal into an indexed profunctor traversal that ignores its input. +-- | Obtain a profunctor 'Cotraversal' from a Van Laarhoven 'Cotraversal'. -- --- Useful as the first optic in a chain when no indexed equivalent is at hand. +-- /Caution/: In order for the generated optic to be well-defined, +-- you must ensure that the input satisfies the following properties: -- --- >>> ilists (noix traversed . itraversed) ["foo", "bar"] --- [(0,'f'),(1,'o'),(2,'o'),(0,'b'),(1,'a'),(2,'r')] --- >>> ilists (itraversed . noix traversed) ["foo", "bar"] --- [(0,'f'),(0,'o'),(0,'o'),(0,'b'),(0,'a'),(0,'r')] +-- * @abst copure ≡ copure@ -- -noix :: (Additive-Monoid) i => Traversal s t a b -> Ixtraversal i s t a b -noix o = itraversalVl $ \iab s -> flip runStar s . o . Star $ iab zero - --- | Index a traversal with a 'Data.Semiring'. +-- * @abst f . fmap (abst g) ≡ abst (f . fmap g . getCompose) . Compose@ -- --- >>> ilists (ix traversed . ix traversed) ["foo", "bar"] --- [((),'f'),((),'o'),((),'o'),((),'b'),((),'a'),((),'r')] --- >>> ilists (ix @Int traversed . ix traversed) ["foo", "bar"] --- [(0,'f'),(1,'o'),(2,'o'),(0,'b'),(1,'a'),(2,'r')] --- >>> ilists (ix @[()] traversed . ix traversed) ["foo", "bar"] --- [([],'f'),([()],'o'),([(),()],'o'),([],'b'),([()],'a'),([(),()],'r')] --- >>> ilists (ix @[()] traversed % ix traversed) ["foo", "bar"] --- [([],'f'),([()],'o'),([(),()],'o'),([()],'b'),([(),()],'a'),([(),(),()],'r')] +-- The cotraversal laws can be restated in terms of 'withCostar': -- -ix :: Semiring i => Traversal s t a b -> Ixtraversal i s t a b -ix o = itraversalVl $ \f s -> - flip evalState zero . getCompose . flip runStar s . o . Star $ \a -> - Compose $ (f <$> get <*> pure a) <* modify (+ one) +-- * @withCostar o (f . copure) ≡ fmap f . copure@ +-- +-- * @withCostar o f . fmap (withCostar o g) == withCostar o (f . fmap g . getCompose) . Compose@ +-- +-- See 'Data.Profunctor.Optic.Property'. +-- +cotraversalVl :: (forall f. Coapplicative f => (f a -> b) -> f s -> t) -> Cotraversal s t a b +cotraversalVl abst = cotabulate . abst . cosieve --------------------------------------------------------------------- -- 'Traversal1' @@ -221,6 +281,7 @@ -- traversing1 :: Traversable1 f => (s -> a) -> (s -> b -> t) -> Traversal1 (f s) (f t) a b traversing1 sa sbt = repn traverse1 . lens sa sbt +{-# INLINE traversing1 #-} -- | Obtain a profunctor 'Traversal1' from a Van Laarhoven 'Traversal1'. -- @@ -233,20 +294,53 @@ -- traversal1Vl :: (forall f. Apply f => (a -> f b) -> s -> f t) -> Traversal1 s t a b traversal1Vl abst = tabulate . abst . sieve +{-# INLINE traversal1Vl #-} --- | Lift an indexed VL traversal into an indexed profunctor traversal. +-- | Obtain a 'Cotraversal1' by embedding a continuation into a 'Distributive1' functor. -- +-- @ +-- 'withGrate' o 'cotraversing1' ≡ 'cotraversed1' . o +-- @ +-- -- /Caution/: In order for the generated optic to be well-defined, +-- you must ensure that the input function satisfies the following +-- properties: +-- +-- * @sabt ($ s) ≡ s@ +-- +-- * @sabt (\k -> f (k . sabt)) ≡ sabt (\k -> f ($ k))@ +-- +cotraversing1 :: Distributive1 g => (((s -> a) -> b) -> t) -> Cotraversal1 (g s) (g t) a b +cotraversing1 sabt = corepn cotraverse1 . grate sabt + +-- | Obtain a 'Cotraversal1' by embedding a reversed lens getter and setter into a 'Distributive1' functor. +-- +-- @ +-- 'withLens' ('re' o) 'cotraversing' ≡ 'cotraversed' . o +-- @ +-- +retraversing1 :: Distributive1 g => (b -> t) -> (b -> s -> a) -> Cotraversal1 (g s) (g t) a b +retraversing1 bsa bt = corepn cotraverse1 . (re $ lens bsa bt) + +-- | Obtain a profunctor 'Cotraversal1' from a Van Laarhoven 'Cotraversal1'. +-- +-- /Caution/: In order for the generated optic to be well-defined, -- you must ensure that the input satisfies the following properties: -- --- * @iabst (const pure) ≡ pure@ +-- * @abst runIdentity ≡ runIdentity@ -- --- * @fmap (iabst $ const f) . (iabst $ const g) ≡ getCompose . iabst (const $ Compose . fmap f . g)@ +-- * @abst f . fmap (abst g) ≡ abst (f . fmap g . getCompose) . Compose@ -- +-- The cotraversal1 laws can be restated in terms of 'withCostar': +-- +-- * @withCostar o (f . runIdentity) ≡ fmap f . runIdentity@ +-- +-- * @withCostar o f . fmap (withCostar o g) == withCostar o (f . fmap g . getCompose) . Compose@ +-- -- See 'Data.Profunctor.Optic.Property'. -- -itraversal1Vl :: (forall f. Apply f => (i -> a -> f b) -> s -> f t) -> Ixtraversal1 i s t a b -itraversal1Vl f = traversal1Vl $ \iab -> f (curry iab) . snd +cotraversal1Vl :: (forall f. Coapply f => (f a -> b) -> f s -> t) -> Cotraversal1 s t a b +cotraversal1Vl abst = cotabulate . abst . cosieve --------------------------------------------------------------------- -- Optics @@ -254,9 +348,29 @@ -- | TODO: Document -- +nulled :: Traversal0' s a +nulled = traversal0 Left const +{-# INLINE nulled #-} + +-- | TODO: Document +-- +selected :: (a -> Bool) -> Traversal0' (a, b) b +selected p = traversal0 (\kv@(k,v) -> branch p kv v k) (\kv@(k,_) v' -> if p k then (k,v') else kv) +{-# INLINE selected #-} + +-- | TODO: Document +-- traversed :: Traversable f => Traversal (f a) (f b) a b traversed = traversalVl traverse +{-# INLINE traversed #-} +-- | TODO: Document +-- +cotraversed :: Distributive f => Cotraversal (f a) (f b) a b +cotraversed = cotraversalVl cotraverse +{-# INLINE cotraversed #-} + + -- | Obtain a 'Traversal1' from a 'Traversable1' functor. -- traversed1 :: Traversable1 t => Traversal1 (t a) (t b) a b @@ -265,42 +379,66 @@ -- | TODO: Document -- --- >>> withTraversal both (pure . length) ("hello","world") +cotraversed1 :: Distributive1 f => Cotraversal1 (f a) (f b) a b +cotraversed1 = cotraversal1Vl cotraverse1 +{-# INLINE cotraversed1 #-} + +-- | TODO: Document +-- +-- >>> traverses both (pure . length) ("hello","world") -- (5,5) -- both :: Traversal (a , a) (b , b) a b both p = p **** p +{-# INLINE both #-} -- | TODO: Document -- --- >>> withTraversal1 both1 (pure . NE.length) ('h' :| "ello", 'w' :| "orld") +coboth :: Cotraversal (a + a) (b + b) a b +coboth p = p ++++ p +{-# INLINE coboth #-} + +-- | TODO: Document +-- +-- >>> traverses both1 (pure . NE.length) ('h' :| "ello", 'w' :| "orld") -- (5,5) -- both1 :: Traversal1 (a , a) (b , b) a b -both1 p = tabulate $ \s -> liftF2 ($) (flip sieve s $ dimap fst (,) p) (flip sieve s $ lmap snd p) +both1 p = p **** p {-# INLINE both1 #-} --- | Duplicate the results of any 'Moore'. +-- | TODO: Document -- +-- >>> cotraverses1 coboth1 (foldMap id) $ Left "foo" :| [Right "bar"] +-- Left "foo" +-- >>> cotraverses1 coboth1 (foldMap id) $ Right "foo" :| [Right "bar"] +-- Right "foobar" +-- +coboth1 :: Cotraversal1 (a + a) (b + b) a b +coboth1 p = p ++++ p +{-# INLINE coboth1 #-} + +-- | Duplicate the results of a 'Traversal'. +-- -- >>> lists (both . duplicated) ("hello","world") -- ["hello","hello","world","world"] -- duplicated :: Traversal a b a b duplicated p = pappend p p +{-# INLINE duplicated #-} -- | TODO: Document -- beside :: Bitraversable r => Traversal s1 t1 a b -> Traversal s2 t2 a b -> Traversal (r s1 s2) (r t1 t2) a b beside x y p = tabulate go where go rss = bitraverse (sieve $ x p) (sieve $ y p) rss +{-# INLINE beside #-} -- | Traverse both parts of a 'Bitraversable' container with matching types. -- --- >>> withTraversal bitraversed (pure . length) (Right "hello") +-- >>> traverses bitraversed (pure . length) (Right "hello") -- Right 5 --- --- >>> withTraversal bitraversed (pure . length) ("hello","world") +-- >>> traverses bitraversed (pure . length) ("hello","world") -- (5,5) --- -- >>> ("hello","world") ^. bitraversed -- "helloworld" -- @@ -315,7 +453,7 @@ -- | Traverse both parts of a 'Bitraversable1' container with matching types. -- --- >>> withTraversal1 bitraversed1 (pure . NE.length) ('h' :| "ello", 'w' :| "orld") +-- >>> traverses bitraversed1 (pure . NE.length) ('h' :| "ello", 'w' :| "orld") -- (5,5) -- bitraversed1 :: Bitraversable1 r => Traversal1 (r a a) (r b b) a b @@ -366,85 +504,77 @@ -- @ -- cycled :: Apply f => ATraversal1' f s a -> ATraversal1' f s a -cycled o = repn $ \g a -> go g a where go g a = (withTraversal1 o g) a .> go g a +cycled o = repn $ \g a -> go g a where go g a = (withStar o g) a .> go g a {-# INLINE cycled #-} --------------------------------------------------------------------- --- Indexed optics +-- Operators --------------------------------------------------------------------- --- | TODO: Document +-- | Test whether the optic matches or not. -- -itraversed :: TraversableWithKey f => Traversable f => Ixtraversal (Key f) (f a) (f b) a b -itraversed = itraversalVl K.traverseWithKey - --- | TODO: Document +-- >>> matches just (Just 2) +-- Right 2 +-- >>> matches just (Nothing :: Maybe Int) :: Either (Maybe Bool) Int +-- Left Nothing -- -itraversed1 :: TraversableWithKey1 f => Traversable1 f => Ixtraversal1 (Key f) (f a) (f b) a b -itraversed1 = itraversal1Vl K.traverseWithKey1 +matches :: ATraversal0 s t a b -> s -> t + a +matches o = withAffine o $ \sta _ -> sta +{-# INLINE matches #-} -- | TODO: Document -- -itraversedRep :: F.Representable f => Traversable f => Ixtraversal (F.Rep f) (f a) (f b) a b -itraversedRep = itraversalVl F.itraverseRep - ---------------------------------------------------------------------- --- Primitive operators ---------------------------------------------------------------------- +traverses :: Applicative f => ATraversal f s t a b -> (a -> f b) -> s -> f t +traverses = withStar +{-# INLINE traverses #-} --- | --- --- The traversal laws can be stated in terms of 'withTraversal': --- --- * @withTraversal t (Identity . f) ≡ Identity (fmap f)@ --- --- * @Compose . fmap (withTraversal t f) . withTraversal t g ≡ withTraversal t (Compose . fmap f . g)@ +-- | TODO: Document -- -withTraversal :: Applicative f => ATraversal f s t a b -> (a -> f b) -> s -> f t -withTraversal = withStar -{-# INLINE withTraversal #-} +cotraverses :: Coapplicative f => ACotraversal f s t a b -> (f a -> b) -> f s -> t +cotraverses = withCostar +{-# INLINE cotraverses #-} -- | TODO: Document -- -withIxtraversal :: Applicative f => AIxtraversal f i s t a b -> (i -> a -> f b) -> i -> s -> f t -withIxtraversal o f = curry $ withTraversal o (uncurry f) -{-# INLINE withIxtraversal #-} +traverses1 :: Apply f => ATraversal1 f s t a b -> (a -> f b) -> s -> f t +traverses1 = withStar +{-# INLINE traverses1 #-} --- | --- --- The traversal laws can be stated in terms of 'withTraversal1': --- --- * @withTraversal1 t (Identity . f) ≡ Identity (fmap f)@ --- --- * @Compose . fmap (withTraversal1 t f) . withTraversal1 t g ≡ withTraversal1 t (Compose . fmap f . g)@ --- --- @ --- withTraversal1 :: Functor f => Lens s t a b -> (a -> f b) -> s -> f t --- withTraversal1 :: Apply f => Traversal1 s t a b -> (a -> f b) -> s -> f t --- @ --- -withTraversal1 :: Apply f => ATraversal1 f s t a b -> (a -> f b) -> s -> f t -withTraversal1 = withStar -{-# INLINE withTraversal1 #-} -- | TODO: Document -- -withIxtraversal1 :: Apply f => AIxtraversal1 f i s t a b -> (i -> a -> f b) -> i -> s -> f t -withIxtraversal1 o f = curry $ withTraversal1 o (uncurry f) -{-# INLINE withIxtraversal1 #-} - ---------------------------------------------------------------------- --- Operators ---------------------------------------------------------------------- +cotraverses1 :: Coapply f => ACotraversal1 f s t a b -> (f a -> b) -> f s -> t +cotraverses1 = withCostar +{-# INLINE cotraverses1 #-} -- | TODO: Document -- sequences :: Applicative f => ATraversal f s t (f a) a -> s -> f t -sequences o = withTraversal o id +sequences o = traverses o id {-# INLINE sequences #-} -- | TODO: Document -- +-- >>> collects left' (1, Left "foo") :: Either (Int8, String) String +-- Left (1,"foo") +-- >>> collects left' (1, Right "foo") +-- Right "foo" +-- +collects :: Coapplicative f => ACotraversal f s t a (f a) -> f s -> t +collects o = cotraverses o id +{-# INLINE collects #-} + +-- | TODO: Document +-- sequences1 :: Apply f => ATraversal1 f s t (f a) a -> s -> f t -sequences1 o = withTraversal1 o id +sequences1 o = traverses1 o id {-# INLINE sequences1 #-} + +-- | TODO: Document +-- +-- >>> collects1 cotraversed1 ["xxx","ooo"] :: [String] +-- ["xo","xo","xo"] +-- +collects1 :: Coapply f => ACotraversal1 f s t a (f a) -> f s -> t +collects1 o = cotraverses1 o id +{-# INLINE collects1 #-} diff --git a/src/Data/Profunctor/Optic/Types.hs b/src/Data/Profunctor/Optic/Types.hs --- a/src/Data/Profunctor/Optic/Types.hs +++ b/src/Data/Profunctor/Optic/Types.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} @@ -9,353 +10,244 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE QuantifiedConstraints #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} #ifndef MIN_VERSION_profunctors #define MIN_VERSION_profunctors(x,y,z) 1 #endif module Data.Profunctor.Optic.Types ( - -- * Optic, IndexedOptic, & CoindexedOptic + -- * Optic Optic, Optic' - , IndexedOptic, IndexedOptic' - , CoindexedOptic, CoindexedOptic' - -- * Iso & Equality - , Iso, Iso', Equality, Equality' - -- * Lens - , Lens, Lens', Ixlens, Ixlens' + -- * Constraints + , Affine, Coaffine + , Traversing, Cotraversing + , Traversing1, Cotraversing1 + , CoerceL, CoerceR + , Mapping, Comapping + , Mapping1, Comapping1 + -- * Equality + , Equality, Equality' + -- * Iso + , Iso, Iso' -- * Prism - , Prism, Prism', Cxprism, Cxprism' + , Prism, Coprism + , Prism', Coprism' + -- * Lens + , Lens, Colens + , Lens', Colens' -- * Grate - , Grate, Grate', Cxgrate, Cxgrate' - -- * Affine & Option - , Affine, Affine', Ixaffine, Ixaffine' - , Option, Ixoption - -- * Grism - , Grism , Grism' - -- * Traversal, Traversal1, Fold & Fold1 - , Traversal , Traversal' , Ixtraversal , Ixtraversal' - , Traversal1 , Traversal1' , Ixtraversal1, Ixtraversal1' - , Fold, Ixfold , Fold1, Ixfold1 - -- * Cotraversal - , Cotraversal , Cotraversal' - -- * View & Review - , PrimView, View, Ixview, PrimReview, Review, Cxview - -- * Setter & Resetter - , Setter, Setter', Ixsetter, Ixsetter' - , Resetter, Resetter', Cxsetter, Cxsetter' - -- * Coapplicative - , Coapplicative(..), Branch(..) - , between + , Grate, Grate' + -- * Traversal + , Traversal0, Cotraversal0 + , Traversal, Cotraversal + , Traversal1, Cotraversal1 + , Traversal0', Cotraversal0' + , Traversal', Cotraversal' + , Traversal1', Cotraversal1' + -- * Fold + , Fold0, Fold, Fold1 + -- * Setter + , Setter, Resetter + , Setter', Resetter' + -- * View + , View, Review -- * 'Re' , Re(..), re + , between , module Export ) where import Data.Bifunctor (Bifunctor(..)) import Data.Functor.Apply (Apply(..)) -import Data.Profunctor.Optic.Import hiding (branch) -import Data.Profunctor.Extra as Export (type (+)) +import Data.Profunctor.Optic.Import import Data.Profunctor.Types as Export -import qualified Control.Arrow as A -import Data.List.NonEmpty as L1 -import qualified Data.Bifunctor as B - -- $setup -- >>> :set -XCPP -- >>> :set -XNoOverloadedStrings -- >>> :load Data.Profunctor.Optic --------------------------------------------------------------------- --- Optic +-- Constraints --------------------------------------------------------------------- -type Optic p s t a b = p a b -> p s t +type Affine p = (Choice p, Strong p) -type Optic' p s a = Optic p s s a a +type Coaffine p = (Choice p, Closed p) -type IndexedOptic p i s t a b = p (i , a) b -> p (i , s) t +type Traversing p = (Representable p, Applicative' (Rep p)) -type IndexedOptic' p i s a = IndexedOptic p i s s a a +type Cotraversing p = (Corepresentable p, Coapplicative (Corep p)) -type CoindexedOptic p k s t a b = p a (k -> b) -> p s (k -> t) +type Traversing1 p = (Representable p, Apply (Rep p)) -type CoindexedOptic' p k t b = CoindexedOptic p k t t b b +type Cotraversing1 p = (Corepresentable p, Coapply (Corep p)) +type CoerceL p = (Bifunctor p) + +type CoerceR p = (forall x. Contravariant (p x)) + +type Mapping p = (Representable p, Distributive (Rep p)) + +type Mapping1 p = (Representable p, Distributive1 (Rep p)) + +type Comapping p = (Corepresentable p, Traversable (Corep p)) + +type Comapping1 p = (Corepresentable p, Traversable1 (Corep p)) + --------------------------------------------------------------------- --- Iso & Equality +-- Optic --------------------------------------------------------------------- --- | 'Iso' --- --- \( \mathsf{Iso}\;S\;A = S \cong A \) --- -type Iso s t a b = forall p. Profunctor p => Optic p s t a b +type Optic p s t a b = p a b -> p s t -type Iso' s a = Iso s s a a +type Optic' p s a = Optic p s s a a +--------------------------------------------------------------------- +-- Equality +--------------------------------------------------------------------- + +-- | \( \mathsf{Equality}\;A = A \cong A \) +-- type Equality s t a b = forall p. Optic p s t a b type Equality' s a = Equality s s a a --------------------------------------------------------------------- --- Lens +-- Iso --------------------------------------------------------------------- --- | Lenses access one piece of a product. --- --- \( \mathsf{Lens}\;S\;A = \exists C, S \cong C \times A \) +-- | \( \mathsf{Iso}\;S\;A = S \cong A \) -- -type Lens s t a b = forall p. Strong p => Optic p s t a b - -type Lens' s a = Lens s s a a - -type Ixlens i s t a b = forall p. Strong p => IndexedOptic p i s t a b +type Iso s t a b = forall p. Profunctor p => Optic p s t a b -type Ixlens' i s a = Ixlens i s s a a +type Iso' s a = Iso s s a a --------------------------------------------------------------------- -- Prism --------------------------------------------------------------------- --- | Prisms access one piece of a sum. --- --- \( \mathsf{Prism}\;S\;A = \exists D, S \cong D + A \) +-- | \( \mathsf{Prism}\;S\;A = \exists D, S \cong D + A \) -- type Prism s t a b = forall p. Choice p => Optic p s t a b -type Prism' s a = Prism s s a a +-- | \( \mathsf{Prism}\;S\;A = \exists D, S + D \cong A \) +-- +type Coprism s t a b = forall p. Cochoice p => Optic p s t a b -type Cxprism k s t a b = forall p. Choice p => CoindexedOptic p k s t a b +type Prism' s a = Prism s s a a -type Cxprism' k s a = Cxprism k s s a a +type Coprism' t b = Coprism t t b b --------------------------------------------------------------------- --- Grate +-- Lens --------------------------------------------------------------------- --- | Grates access the codomain of a function. --- --- \( \mathsf{Grate}\;S\;A = \exists I, S \cong I \to A \) +-- | \( \mathsf{Lens}\;S\;A = \exists C, S \cong C \times A \) -- -type Grate s t a b = forall p. Closed p => Optic p s t a b - -type Grate' s a = Grate s s a a - -type Cxgrate k s t a b = forall p. Closed p => CoindexedOptic p k s t a b - -type Cxgrate' k s a = Cxgrate k s s a a - -type Colens s t a b = forall p. Costrong p => Optic p s t a b +type Lens s t a b = forall p. Strong p => Optic p s t a b -type Colens' s a = Colens s s a a +-- | \( \mathsf{Lens}\;S\;A = \exists C, S \times C \cong A \) +-- +type Colens s t a b = forall p. Costrong p => Optic p s t a b -type Cxlens k s t a b = forall p. Costrong p => CoindexedOptic p k s t a b +-- | \( \mathsf{Grate}\;S\;A = \exists I, S \cong I \to A \) +-- +type Grate s t a b = forall p. Closed p => Optic p s t a b -type Cxlens' k s a = Cxlens k s s a a +type Lens' s a = Lens s s a a -type Cotraversal0 s t a b = forall p. (Choice p, Closed p) => Optic p s t a b +type Colens' t b = Lens t t b b -type Cotraversal0' t b = Cotraversal0 t t b b +type Grate' s a = Grate s s a a --------------------------------------------------------------------- --- Affine & Option +-- Traversal0 --------------------------------------------------------------------- --- | A 'Affine' processes 0 or more parts of the whole, with no interactions. --- --- \( \mathsf{Affine}\;S\;A = \exists C, D, S \cong D + C \times A \) +-- | \( \mathsf{Traversal0}\;S\;A = \exists C, D, S \cong D + C \times A \) -- -type Affine s t a b = forall p. (Choice p, Strong p) => Optic p s t a b - -type Affine' s a = Affine s s a a - -type Ixaffine i s t a b = forall p. (Choice p, Strong p) => IndexedOptic p i s t a b - -type Ixaffine' i s a = Ixaffine i s s a a +type Traversal0 s t a b = forall p. Affine p => Optic p s t a b --- | A 'Option' combines at most one element, with no interactions. +-- | \( \mathsf{Cotraversal0}\;S\;A = \exists D, I, S \cong I \to D + A \) -- -type Option s a = forall p. (Choice p, Strong p, forall x. Contravariant (p x)) => Optic' p s a - -type Ixoption i s a = forall p. (Choice p, Strong p, forall x. Contravariant (p x)) => IndexedOptic' p i s a - ---------------------------------------------------------------------- --- Grism ---------------------------------------------------------------------- +type Cotraversal0 s t a b = forall p. Coaffine p => Optic p s t a b --- | https://en.wikipedia.org/wiki/Grism --- -type Grism s t a b = forall p. (Choice p, Closed p) => Optic p s t a b +type Traversal0' s a = Traversal0 s s a a -type Grism' t b = Grism t t b b +type Cotraversal0' t b = Cotraversal0 t t b b --------------------------------------------------------------------- --- Traversal, Traversal1, Fold, & Fold1 +-- Traversal --------------------------------------------------------------------- --- | A 'Traversal' processes 0 or more parts of the whole, with 'Applicative' interactions. --- --- \( \mathsf{Traversal}\;S\;A = \exists F : \mathsf{Traversable}, S \equiv F\,A \) +-- | \( \mathsf{Traversal}\;S\;A = \exists F : \mathsf{Traversable}, S \equiv F\,A \) -- -type Traversal s t a b = forall p. (Choice p, Strong p, Representable p, Applicative (Rep p)) => Optic p s t a b - -type Traversal' s a = Traversal s s a a - -type Ixtraversal i s t a b = forall p. (Choice p, Strong p, Representable p, Applicative (Rep p)) => IndexedOptic p i s t a b - -type Ixtraversal' i s a = Ixtraversal i s s a a +type Traversal s t a b = forall p. (Affine p, Traversing p) => Optic p s t a b --- | A 'Traversal1' processes 1 or more parts of the whole, with 'Apply' interactions. --- --- \( \mathsf{Traversal1}\;S\;A = \exists F : \mathsf{Traversable1}, S \equiv F\,A \) +-- | \( \mathsf{Cotraversal}\;S\;A = \exists F : \mathsf{Distributive}, S \equiv F\,A \) -- -type Traversal1 s t a b = forall p. (Strong p, Representable p, Apply (Rep p)) => Optic p s t a b - -type Traversal1' s a = Traversal1 s s a a +type Cotraversal s t a b = forall p. (Coaffine p, Cotraversing p) => Optic p s t a b -type Ixtraversal1 i s t a b = forall p. (Strong p, Representable p, Apply (Rep p)) => IndexedOptic p i s t a b +type Traversal' s a = Traversal s s a a -type Ixtraversal1' i s a = Ixtraversal1 i s s a a +type Cotraversal' t b = Cotraversal t t b b -type Cofold0 t b = forall p. (Choice p, Closed p, Strong p, forall x. Contravariant (p x)) => Optic' p t b +--------------------------------------------------------------------- +-- Traversal1 +--------------------------------------------------------------------- --- | A 'Fold1' combines 1 or more elements, with 'Semigroup' interactions. +-- | \( \mathsf{Traversal1}\;S\;A = \exists F : \mathsf{Traversable1}, S \equiv F\,A \) -- -type Fold1 s a = forall p. (Strong p, Representable p, Apply (Rep p), forall x. Contravariant (p x)) => Optic' p s a - -type Ixfold1 i s a = forall p. (Strong p, Representable p, Apply (Rep p), forall x. Contravariant (p x)) => IndexedOptic' p i s a +type Traversal1 s t a b = forall p. (Strong p, Traversing1 p) => Optic p s t a b --- | A 'Fold' combines 0 or more elements, with 'Monoid' interactions. +-- | \( \mathsf{Cotraversal1}\;S\;A = \exists F : \mathsf{Distributive1}, S \equiv F\,A \) -- -type Fold s a = forall p. (Choice p, Representable p, Applicative (Rep p), forall x. Contravariant (p x)) => Optic' p s a +type Cotraversal1 s t a b = forall p. (Closed p, Cotraversing1 p) => Optic p s t a b -type Ixfold i s a = forall p. (Choice p, Representable p, Applicative (Rep p), forall x. Contravariant (p x)) => IndexedOptic' p i s a +type Traversal1' s a = Traversal1 s s a a --- type Cofold t b = forall p. (Closed p, Corepresentable p, Coapplicative (Corep p), Bifunctor p) => Optic' p t b +type Cotraversal1' t b = Cotraversal1 t t b b --------------------------------------------------------------------- --- Cotraversal +-- Fold --------------------------------------------------------------------- -type Cotraversal s t a b = forall p. (Choice p, Closed p, Coapplicative (Corep p), Corepresentable p) => Optic p s t a b +type Fold0 s a = forall p. (Affine p, CoerceR p) => Optic' p s a -type Cotraversal' t b = Cotraversal t t b b +type Fold s a = forall p. (Affine p, Traversing p, CoerceR p) => Optic' p s a +type Fold1 s a = forall p. (Strong p, Traversing1 p, CoerceR p) => Optic' p s a + --------------------------------------------------------------------- --- View & Review +-- View --------------------------------------------------------------------- -type PrimView s t a b = forall p. (Profunctor p, forall x. Contravariant (p x)) => Optic p s t a b - -type View s a = forall p. (Strong p, forall x. Contravariant (p x)) => Optic' p s a - -type Ixview i s a = forall p. (Strong p, forall x. Contravariant (p x)) => IndexedOptic' p i s a - -type PrimReview s t a b = forall p. (Profunctor p, Bifunctor p) => Optic p s t a b - -type Review t b = forall p. (Closed p, Bifunctor p) => Optic' p t b +type View s a = forall p. (Strong p, CoerceR p) => Optic' p s a -type Cxview k t b = forall p. (Closed p, Bifunctor p) => CoindexedOptic' p k t b +type Review t b = forall p. (Closed p, CoerceL p) => Optic' p t b --------------------------------------------------------------------- --- Setter & Resetter +-- Setter --------------------------------------------------------------------- --- | A 'Setter' modifies part of a structure. +-- | \( \mathsf{Setter}\;S\;A = \exists F : \mathsf{Functor}, S \equiv F\,A \) -- --- \( \mathsf{Setter}\;S\;A = \exists F : \mathsf{Functor}, S \equiv F\,A \) +type Setter s t a b = forall p. (Affine p, Traversing p, Mapping p) => Optic p s t a b + +-- | \( \mathsf{Setter}\;S\;A = \exists F : \mathsf{Functor}, F\,S \equiv A \) -- -type Setter s t a b = forall p. (Choice p, Strong p, Representable p, Applicative (Rep p), Distributive (Rep p)) => Optic p s t a b +type Resetter s t a b = forall p. (Coaffine p, Cotraversing p, Comapping p) => Optic p s t a b type Setter' s a = Setter s s a a -type Ixsetter i s t a b = forall p. (Choice p, Strong p, Representable p, Applicative (Rep p), Distributive (Rep p)) => IndexedOptic p i s t a b - -type Ixsetter' i s a = Ixsetter i s s a a - -type Resetter s t a b = forall p. (Choice p, Closed p, Corepresentable p, Coapplicative (Corep p), Traversable (Corep p)) => Optic p s t a b - type Resetter' s a = Resetter s s a a -type Cxsetter k s t a b = forall p. (Choice p, Closed p, Corepresentable p, Coapplicative (Corep p), Traversable (Corep p)) => CoindexedOptic p k s t a b - -type Cxsetter' k t b = Cxsetter k t t b b - - --------------------------------------------------------------------- --- Branch & Coapplicative +-- 'Re' --------------------------------------------------------------------- --- branch . fmap Left == Left --- branch . fmap Right == Right --- (fmap Left ||| fmap Right) . branch == id - --- >>> (fmap Left ||| fmap Right) . branch $ (Left 1) :| [Right 2] --- Left 1 :| [] --- -class Functor f => Branch f where - branch :: f (Either a b) -> Either (f a) (f b) - -cobranch :: Apply f => (f a, f b) -> f (a, b) -cobranch = uncurry $ liftF2 (,) - -instance Branch Identity where - branch (Identity ab) = either (Left . Identity) (Right . Identity) ab - -{- -instance Branch (Const r) where branch (Const r) = Right (Const r) --} - -instance Branch (Tagged k) where - branch (Tagged ab) = either (Left . Tagged) (Right . Tagged) ab - -instance Branch ((,) r) where - branch (r, a) = either (Left . (r,)) (Right . (r,)) a - -instance Monoid m => Branch ((->) m) where - branch f = either (Left . const) (Right . const) $ f mempty - -instance Branch NonEmpty where - branch (Left x :| zs) = Left $ x :| foldr (either (:) (const id)) [] zs - branch (Right y :| zs) = Right $ y :| foldr (either (const id) (:)) [] zs - -instance (Branch f, Branch g) => Branch (Compose f g) where - branch (Compose ab) = B.bimap Compose Compose . branch . fmap branch $ ab - -class Branch f => Coapplicative f where - -- either (f . copure) (g . copure) . branch == either f g . copure - copure :: f a -> a - -instance Coapplicative Identity where - copure (Identity a) = a - -instance Coapplicative (Tagged k) where - copure (Tagged a) = a - -instance Coapplicative ((,) r) where - copure (_, a) = a - -instance Monoid m => Coapplicative ((->) m) where - copure f = f mempty - -instance Coapplicative NonEmpty where - copure = L1.head - -catLefts :: [Either a b] -> [a] -catLefts = foldr (either (:) (const id)) [] - -catRights :: [Either a b] -> [b] -catRights = foldr (either (const id) (:)) [] - -instance (Coapplicative f, Coapplicative g) => Coapplicative (Compose f g) where - copure (Compose a) = copure . fmap copure $ a - -#if MIN_VERSION_profunctors(5,4,0) -instance Coapplicative f => Choice (Costar f) where - left' (Costar f) = Costar $ either (Left . f) (Right . copure) . branch -#endif - -- | Can be used to rewrite -- -- > \g -> f . g . h @@ -368,18 +260,8 @@ between f g = (f .) . (. g) {-# INLINE between #-} ---------------------------------------------------------------------- --- 'Re' ---------------------------------------------------------------------- - -- | Reverse an optic to obtain its dual. -- --- >>> 5 ^. re left' --- Left 5 --- --- >>> 6 ^. re (left' . from succ) --- Left 7 --- -- @ -- 're' . 're' ≡ id -- @ @@ -388,8 +270,13 @@ -- 're' :: 'Iso' s t a b -> 'Iso' b a t s -- 're' :: 'Lens' s t a b -> 'Colens' b a t s -- 're' :: 'Prism' s t a b -> 'Coprism' b a t s +-- 're' :: 'Traversal' s t a b -> 'Cotraversal' b a t s +-- 're' :: 'View' s t a b -> 'Review' b a t s -- @ -- +-- >>> 5 ^. re left' +-- Left 5 +-- re :: Optic (Re p a b) s t a b -> Optic p b a t s re o = (between runRe Re) o id {-# INLINE re #-} @@ -398,6 +285,7 @@ -- newtype Re p s t a b = Re { runRe :: p b a -> p t s } +-- TODO: Closed, Representable, Corepresentable instances instance Profunctor p => Profunctor (Re p s t) where dimap f g (Re p) = Re (p . dimap g f) @@ -441,6 +329,13 @@ second f (Costar g) = Costar $ f . g +#if MIN_VERSION_profunctors(5,4,0) +-- used for Choice operations (e.g. preview) on Cotraversals & Cofolds +-- e.g. +-- distributes left' (1, Left "foo") +instance Coapplicative f => Choice (Costar f) where + left' (Costar f) = Costar $ either (Left . f) (Right . copure) . coapply +#endif {- #if !(MIN_VERSION_profunctors(5,5,0)) @@ -448,12 +343,5 @@ unleft (Forget f) = Forget $ f . Left unright (Forget f) = Forget $ f . Right -#endif - -#if MIN_VERSION_profunctors(5,4,0) -instance Comonad f => Choice (Costar f) where - left' (Costar f) = Costar . runCostar . A.left . Costar $ f - - right' (Costar f) = Costar . runCostar . A.right . Costar $ f #endif -} 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 @@ -6,66 +6,35 @@ module Data.Profunctor.Optic.View ( -- * Types View - , Ixview - , PrimView , Review - , Cxview - , PrimReview -- * Constructors , to - , ito , from - , kfrom , cloneView , cloneReview -- * Optics , like - , ilike , relike - , klike , toProduct , fromSum - -- * Primitive operators - , withPrimView - , withPrimReview -- * Operators , (^.) - , (^%) , view - , iview , views - , iviews , use - , iuse , uses - , iuses - , (#^) , review - , kview , reviews - , kviews , reuse , reuses - , kuse - , kuses - -- * MonadIO - , throws - , throws_ - , throwsTo ) where -import Control.Exception (Exception) -import Control.Monad.IO.Class import Control.Monad.Reader as Reader -import Control.Monad.Writer as Writer hiding (Sum(..)) import Control.Monad.State as State import Data.Profunctor.Optic.Carrier import Data.Profunctor.Optic.Types -import Data.Profunctor.Optic.Operator +import Data.Profunctor.Optic.Combinator import Data.Profunctor.Optic.Import -import GHC.Conc (ThreadId) -import qualified Control.Exception as Ex -import qualified Data.Bifunctor as B -- $setup -- >>> :set -XNoOverloadedStrings @@ -75,9 +44,7 @@ -- >>> import Data.Either -- >>> import Control.Monad.State -- >>> import Control.Monad.Writer --- >>> import Data.List.Index as LI -- >>> :load Data.Profunctor.Optic Data.Either.Optic Data.Tuple.Optic --- >>> let itraversed :: Ixtraversal Int [a] [b] a b ; itraversed = itraversalVl itraverse --------------------------------------------------------------------- -- 'View' & 'Review' @@ -103,53 +70,40 @@ -- 'to' :: (s -> a) -> 'View' s a -- @ -- -to :: (s -> a) -> PrimView s t a b +to :: (s -> a) -> View s a to f = coercer . lmap f {-# INLINE to #-} --- | TODO: Document --- -ito :: (s -> (i , a)) -> Ixview i s a -ito f = to $ f . snd -{-# INLINE ito #-} - -- | Obtain a 'Review' from an arbitrary function. -- -- @ -- 'from' ≡ 're' . 'to' -- @ -- --- >>> (from Prelude.length) #^ [1,2,3] +-- >>> review (from Prelude.length) [1,2,3] -- 3 -- -- @ -- 'from' :: (b -> t) -> 'Review' t b -- @ -- -from :: (b -> t) -> PrimReview s t a b +from :: (b -> t) -> Review t b from f = coercel . rmap f {-# INLINE from #-} -- | TODO: Document -- -kfrom :: ((k -> b) -> t) -> Cxview k t b -kfrom f = from $ \kb _ -> f kb -{-# INLINE kfrom #-} - --- | TODO: Document --- -- @ --- 'cloneView' :: 'AView' s a -> 'View' s a --- 'cloneView' :: 'Monoid' a => 'AView' s a -> 'Fold' s a +-- 'cloneView' :: 'Monoid' a => 'AView' a s a -> 'Fold' s a -- @ -- -cloneView :: AView s a -> PrimView s s a a +cloneView :: AView a s a -> View s a cloneView = to . view {-# INLINE cloneView #-} -- | TODO: Document -- -cloneReview :: AReview t b -> PrimReview t t b b +cloneReview :: AReview t b -> Review t b cloneReview = from . review {-# INLINE cloneReview #-} @@ -173,16 +127,10 @@ -- 'like' :: a -> 'View' s a -- @ -- -like :: a -> PrimView s t a b +like :: a -> View s a like = to . const {-# INLINE like #-} --- | TODO: Document --- -ilike :: i -> a -> Ixview i s a -ilike i a = ito (const (i, a)) -{-# INLINE ilike #-} - -- | Obtain a constant-valued (index-preserving) 'Review' from an arbitrary value. -- -- @ @@ -191,23 +139,17 @@ -- 'relike' a '#' b ≡ 'from' ('const' a) '#' b -- @ -- -relike :: t -> PrimReview s t a b +relike :: t -> Review t b relike = from . const {-# INLINE relike #-} --- | Obtain a constant-valued 'Cxview' from an arbitrary value. --- -klike :: t -> Cxview k t b -klike = kfrom . const -{-# INLINE klike #-} - -- | Combine two 'View's into a 'View' to a product. -- -- @ -- 'toProduct' :: 'View' s a1 -> 'View' s a2 -> 'View' s (a1 , a2) -- @ -- -toProduct :: AView s a1 -> AView s a2 -> PrimView s t (a1 , a2) b +toProduct :: AView a1 s a1 -> AView a2 s a2 -> View s (a1 , a2) toProduct l r = to (view l &&& view r) {-# INLINE toProduct #-} @@ -217,7 +159,7 @@ -- 'fromSum' :: 'Review' t b1 -> 'Review' t b2 -> 'Review' t (b1 + b2) -- @ -- -fromSum :: AReview t b1 -> AReview t b2 -> PrimReview s t a (b1 + b2) +fromSum :: AReview t b1 -> AReview t b2 -> Review t (b1 + b2) fromSum l r = from (review l ||| review r) {-# INLINE fromSum #-} @@ -225,6 +167,27 @@ -- Operators --------------------------------------------------------------------- +infixl 8 ^. + +-- | View the focus of an optic. +-- +-- Fixity and semantics are such that subsequent field accesses can be +-- performed with ('Prelude..'). +-- +-- >>> ("hello","world") ^. second' +-- "world" +-- +-- >>> 5 ^. to succ +-- 6 +-- +-- >>> import Data.Complex +-- >>> ((0, 1 :+ 2), 3) ^. first' . second' . to magnitude +-- 2.23606797749979 +-- +(^.) :: s -> AView a s a -> a +(^.) s o = withView o id s +{-# INLINE ( ^. ) #-} + -- | A prefix alias for '^.'. -- -- @ @@ -240,19 +203,10 @@ -- >>> view (second' . first') ("hello",("world","!!!")) -- "world" -- -view :: MonadReader s m => AView s a -> m a +view :: MonadReader s m => AView a s a -> m a view o = views o id {-# INLINE view #-} --- | A prefix alias for '^%'. --- --- >>> iview ifirst ("foo", 42) --- (Just (),"foo") --- -iview :: MonadReader s m => (Additive-Monoid) i => AIxview i s a -> m (Maybe i , a) -iview o = asks $ withPrimView o (B.first Just) . (zero,) -{-# INLINE iview #-} - -- | Map each part of a structure viewed to a semantic editor combinator. -- -- @ @@ -263,30 +217,16 @@ -- >>> views both id (["foo"], ["bar", "baz"]) -- ["foo","bar","baz"] -- -views :: MonadReader s m => Optic' (Star (Const r)) s a -> (a -> r) -> m r -views o f = asks $ withPrimView o f +views :: MonadReader s m => AView r s a -> (a -> r) -> m r +views o f = asks $ withView o f {-# INLINE views #-} --- | Bring a function of the index and value of an indexed optic into the current environment. --- --- 'iviews' ≡ 'iwithFold' --- --- Use 'iview' if there is a need to disambiguate between 'zero' as a miss vs. as a return value. --- -iviews :: MonadReader s m => (Additive-Monoid) i => IndexedOptic' (Star (Const r)) i s a -> (i -> a -> r) -> m r -iviews o f = asks $ withPrimView o (uncurry f) . (zero,) - -- | TODO: Document -- -use :: MonadState s m => AView s a -> m a +use :: MonadState s m => AView a s a -> m a use o = gets (view o) {-# INLINE use #-} --- | Bring the index and value of an indexed optic into the current environment as a pair. --- -iuse :: MonadState s m => (Additive-Monoid) i => AIxview i s a -> m (Maybe i , a) -iuse o = gets (iview o) - -- | Use the target of a 'Lens', 'Data.Profunctor.Optic.Iso.Iso' or -- 'View' in the current state, or use a summary of a -- 'Data.Profunctor.Optic.Fold.Fold' or 'Data.Profunctor.Optic.Traversal.Traversal' that @@ -299,18 +239,15 @@ uses l f = gets (views l f) {-# INLINE uses #-} --- | Bring a function of the index and value of an indexed optic into the current environment. --- -iuses :: MonadState s m => (Additive-Monoid) i => IndexedOptic' (Star (Const r)) i s a -> (i -> a -> r) -> m r -iuses o f = gets $ withPrimView o (uncurry f) . (zero,) - --- | A prefix alias of '#^'. +-- | A prefix alias of '.^'. -- -- @ -- 'review' ≡ 'view' '.' 're' -- 'review' . 'from' ≡ 'id' -- @ -- +-- >>> review left' 4 +-- Left 4 -- >>> review (from succ) 5 -- 6 -- @@ -318,12 +255,6 @@ review o = reviews o id {-# INLINE review #-} --- | Bring a function of the index of a co-indexed optic into the current environment. --- -kview :: MonadReader b m => ACxview k t b -> m (k -> t) -kview o = kviews o id -{-# INLINE kview #-} - -- | Turn an optic around and look through the other end, applying a function. -- -- @ @@ -338,18 +269,9 @@ -- 8 -- reviews :: MonadReader b m => AReview t b -> (t -> r) -> m r -reviews o f = asks $ withPrimReview o f +reviews o f = asks $ withReview o f {-# INLINE reviews #-} --- | Bring a continuation of the index of a co-indexed optic into the current environment. --- --- @ --- kviews :: ACxview k t b -> ((k -> t) -> r) -> b -> r --- @ --- -kviews :: MonadReader b m => ACxview k t b -> ((k -> t) -> r) -> m r -kviews o f = asks $ withPrimReview o f . const - -- | Turn an optic around and 'use' a value (or the current environment) through it the other way. -- -- @ @@ -367,12 +289,6 @@ reuse o = gets (unTagged #. o .# Tagged) {-# INLINE reuse #-} --- | TODO: Document --- -kuse :: MonadState b m => ACxview k t b -> m (k -> t) -kuse o = gets (kview o) -{-# INLINE kuse #-} - -- | Turn an optic around and 'use' the current state through it the other way, applying a function. -- -- @ @@ -386,37 +302,3 @@ reuses :: MonadState b m => AReview t b -> (t -> r) -> m r reuses o tr = gets (tr . unTagged #. o .# Tagged) {-# INLINE reuses #-} - --- | TODO: Document --- -kuses :: MonadState b m => ACxview k t b -> ((k -> t) -> r) -> m r -kuses o f = gets (kviews o f) -{-# INLINE kuses #-} - ---------------------------------------------------------------------- --- 'MonadIO' ---------------------------------------------------------------------- - --- | Throw an exception described by an optic. --- --- @ --- 'throws' o e \`seq\` x ≡ 'throws' o e --- @ --- -throws :: MonadIO m => Exception e => AReview e b -> b -> m r -throws o = reviews o $ liftIO . Ex.throwIO -{-# INLINE throws #-} - --- | Variant of 'throws' for error constructors with no arguments. --- -throws_ :: MonadIO m => Exception e => AReview e () -> m r -throws_ o = throws o () - --- | Raise an 'Exception' specified by an optic in the target thread. --- --- @ --- 'throwsTo' thread o ≡ 'throwTo' thread . 'review' o --- @ --- -throwsTo :: MonadIO m => Exception e => ThreadId -> AReview e b -> b -> m () -throwsTo tid o = reviews o (liftIO . Ex.throwTo tid) diff --git a/test/Test/Data/Connection/Optic/Int.hs b/test/Test/Data/Connection/Optic/Int.hs deleted file mode 100644 --- a/test/Test/Data/Connection/Optic/Int.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# 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 --- a/test/doctest.hs +++ b/test/doctest.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE NoImplicitPrelude #-} import Test.DocTest import Prelude (IO) @@ -7,16 +6,13 @@ main :: IO () main = doctest [ "-isrc" - , "src/Data/Profunctor/Optic/Operator.hs" + , "src/Data/Profunctor/Optic/Carrier.hs" + , "src/Data/Profunctor/Optic/Combinator.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/test.hs b/test/test.hs deleted file mode 100644 --- a/test/test.hs +++ /dev/null @@ -1,15 +0,0 @@ -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