summaryrefslogtreecommitdiff
path: root/src/Data/Profunctor/Optic/Setter.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Data/Profunctor/Optic/Setter.hs')
-rw-r--r--src/Data/Profunctor/Optic/Setter.hs882
1 files changed, 738 insertions, 144 deletions
diff --git a/src/Data/Profunctor/Optic/Setter.hs b/src/Data/Profunctor/Optic/Setter.hs
index b864e57..84ace9b 100644
--- a/src/Data/Profunctor/Optic/Setter.hs
+++ b/src/Data/Profunctor/Optic/Setter.hs
@@ -1,197 +1,412 @@
-{-# LANGUAGE DeriveFunctor #-}
-
-module Data.Profunctor.Optic.Setter where
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+module Data.Profunctor.Optic.Setter (
+ -- * Setter
+ Setter
+ , Setter'
+ , setter
+ , ixsetter
+ , closing
+ -- * Resetter
+ , Resetter
+ , Resetter'
+ , resetter
+ , cxsetter
+ -- * Optics
+ , cod
+ , dom
+ , bound
+ , fmapped
+ , contramapped
+ , setmapped
+ , isetmapped
+ , foldmapped
+ , liftedA
+ , liftedM
+ , locally
+ , zipped
+ , cond
+ , modded
+ , reviewed
+ , composed
+ , exmapped
+ -- * Primitive operators
+ , over
+ , ixover
+ , under
+ , cxover
+ , through
+ -- * Operators
+ , assignA
+ , set
+ , ixset
+ , reset
+ , cxset
+ , (.~)
+ , (..~)
+ , (/~)
+ , (//~)
+ , (?~)
+ , (<>~)
+ , (><~)
+ -- * Indexed Operators
+ , (%~)
+ , (%%~)
+ , (#~)
+ , (##~)
+ -- * MonadState
+ , assigns
+ , modifies
+ , (.=)
+ , (..=)
+ , (%=)
+ , (%%=)
+ , (//=)
+ , (#=)
+ , (##=)
+ , (?=)
+ , (<>=)
+ , (><=)
+ , zoom
+ -- * Carriers
+ , ASetter
+ , ASetter'
+ , Star(..)
+ , AResetter
+ , AResetter'
+ , Costar(..)
+ -- * Classes
+ , Representable(..)
+ , Corepresentable(..)
+) where
import Control.Applicative (liftA)
-import Control.Exception (Exception(..), SomeException)
-import Control.Monad.Reader as Reader hiding (lift)
-import Control.Monad.Writer as Writer hiding (lift)
+import Control.Exception (Exception(..))
+import Control.Monad.Reader as Reader
+import Control.Monad.State as State
+import Control.Monad.Writer as Writer
import Data.Foldable (Foldable, foldMap)
-import Data.Profunctor.Optic.Iso (PStore(..))
-import Data.Profunctor.Optic.Prelude hiding (Bifunctor(..))
+import Data.Profunctor.Arrow
+import Data.Profunctor.Optic.Import hiding ((&&&))
+import Data.Profunctor.Optic.Index (Index(..), Coindex(..), trivial)
import Data.Profunctor.Optic.Type
import Data.Semiring
+
+import Data.IntSet as IntSet
+import Data.Set as Set
+import Prelude (Num(..))
import qualified Control.Exception as Ex
+-- $setup
+-- >>> :set -XNoOverloadedStrings
+-- >>> :set -XTypeApplications
+-- >>> :set -XFlexibleContexts
+-- >>> :set -XRankNTypes
+-- >>> import Control.Category ((>>>))
+-- >>> import Control.Arrow (Kleisli(..))
+-- >>> import Control.Exception
+-- >>> import Control.Monad.State
+-- >>> import Control.Monad.Reader
+-- >>> import Control.Monad.Writer
+-- >>> import Data.Functor.Identity
+-- >>> import Data.Functor.Contravariant
+-- >>> import Data.Int.Instance ()
+-- >>> import Data.List.Index as LI
+-- >>> import Data.IntSet as IntSet
+-- >>> import Data.Set as Set
+-- >>> :load Data.Profunctor.Optic
+-- >>> let catchOn :: Int -> Cxprism' Int (Maybe String) String ; catchOn n = cxjust $ \k -> if k==n then Just "caught" else Nothing
+-- >>> let ixtraversed :: Ixtraversal Int [a] [b] a b ; ixtraversed = ixtraversalVl itraverse
+-- >>> let ixat :: Int -> Ixtraversal0' Int [a] a; ixat = inserted (\i s -> flip LI.ifind s $ \n _ -> n == i) (\i a s -> LI.modifyAt i (const a) s)
+
+type ASetter s t a b = ARepn Identity s t a b
+
+type ASetter' s a = ASetter s s a a
+
+type AIxsetter i s t a b = AIxrepn Identity i s t a b
+
+type AResetter s t a b = ACorepn Identity s t a b
+
+type AResetter' s a = AResetter s s a a
+
+type ACxsetter k s t a b = ACxrepn Identity k s t a b
+
---------------------------------------------------------------------
-- Setter
---------------------------------------------------------------------
--- | Promote a <http://conal.net/blog/posts/semantic-editor-combinators semantic editor combinator> to a modify-only optic.
+-- | Obtain a 'Setter' from a <http://conal.net/blog/posts/semantic-editor-combinators SEC>.
--
--- To demote an optic to a semantic edit combinator, use the section @(l %~)@ or @over l@.
+-- To demote an optic to a semantic edit combinator, use the section @(l ..~)@ or @over l@.
--
--- >>> [("The",0),("quick",1),("brown",1),("fox",2)] & setter map . _1 %~ length
+-- >>> [("The",0),("quick",1),("brown",1),("fox",2)] & setter fmap . t21 ..~ Prelude.length
-- [(3,0),(5,1),(5,1),(3,2)]
--
--- /Caution/: In order for the generated family to be well-defined, you must ensure that the two functor laws hold:
+-- /Caution/: In order for the generated optic to be well-defined,
+-- you must ensure that the input function satisfies the following
+-- properties:
+--
+-- * @abst id ≡ id@
--
--- * @sec id ≡ id@
+-- * @abst f . abst g ≡ abst (f . g)@
+--
+-- More generally, a profunctor optic must be monoidal as a natural
+-- transformation:
+--
+-- * @o id ≡ id@
--
--- * @sec f . sec g ≡ sec (f . g)@
+-- * @o ('Data.Profunctor.Composition.Procompose' p q) ≡ 'Data.Profunctor.Composition.Procompose' (o p) (o q)@
--
-- See 'Data.Profunctor.Optic.Property'.
--
setter :: ((a -> b) -> s -> t) -> Setter s t a b
-setter sec = dimap (flip PStore id) (\(PStore s ab) -> sec ab s) . lift collect
+setter abst = dimap (flip Index id) (\(Index s ab) -> abst ab s) . repn collect
+{-# INLINE setter #-}
--- | Every 'Grate' is a 'Setter'.
+-- | Build an 'Ixsetter' from an indexed function.
--
-closing :: (((s -> a) -> b) -> t) -> Setter s t a b
-closing sabt = setter $ \ab s -> sabt $ \sa -> ab (sa s)
-
-infixl 6 %
+-- @
+-- 'ixsetter' '.' 'ixover' ≡ 'id'
+-- 'ixover' '.' 'ixsetter' ≡ 'id'
+-- @
+--
+-- /Caution/: In order for the generated optic to be well-defined,
+-- you must ensure that the input satisfies the following properties:
+--
+-- * @iabst (const id) ≡ id@
+--
+-- * @fmap (iabst $ const f) . (iabst $ const g) ≡ iabst (const $ f . g)@
+--
+-- See 'Data.Profunctor.Optic.Property'.
+--
+ixsetter :: ((i -> a -> b) -> s -> t) -> Ixsetter i s t a b
+ixsetter f = setter $ \iab -> f (curry iab) . snd
+{-# INLINE ixsetter #-}
--- | Sum two SECs
+-- | Obtain a 'Resetter' from a <http://conal.net/blog/posts/semantic-editor-combinators SEC>.
+--
+-- /Caution/: In order for the generated optic to be well-defined,
+-- you must ensure that the input function satisfies the following
+-- properties:
--
-(%) :: Setter' a a -> Setter' a a -> Setter' a a
-(%) f g = setter $ \h -> (f %~ h) . (g %~ h)
+-- * @abst id ≡ id@
+--
+-- * @abst f . abst g ≡ abst (f . g)@
+--
+resetter :: ((a -> t) -> s -> t) -> Resetter s t a t
+resetter abst = dimap (\s -> Coindex $ \ab -> abst ab s) trivial . corepn (\f -> fmap f . sequenceA)
+{-# INLINE resetter #-}
--- >>> toSemiring $ zero % one :: Int
--- 1
--- >>> toSemiring $ zero . one :: Int
--- 0
-toSemiring :: Monoid a => Semiring a => Setter' a a -> a
-toSemiring a = over a (unit <>) mempty
+-- | TODO: Document
+--
+-- /Caution/: In order for the generated optic to be well-defined,
+-- you must ensure that the input satisfies the following properties:
+--
+-- * @kabst (const id) ≡ id@
+--
+-- * @fmap (kabst $ const f) . (kabst $ const g) ≡ kabst (const $ f . g)@
+--
+-- See 'Data.Profunctor.Optic.Property'.
+--
+cxsetter :: ((k -> a -> t) -> s -> t) -> Cxsetter k s t a t
+cxsetter f = resetter $ \kab -> const . f (flip kab)
+{-# INLINE cxsetter #-}
-fromSemiring :: Monoid a => Semiring a => a -> Setter' a a
-fromSemiring a = setter $ \ f y -> a >< f mempty <> y
+-- | Every valid 'Grate' is a 'Setter'.
+--
+closing :: (((s -> a) -> b) -> t) -> Setter s t a b
+closing sabt = setter $ \ab s -> sabt $ \sa -> ab (sa s)
+{-# INLINE closing #-}
---------------------------------------------------------------------
-- Primitive operators
---------------------------------------------------------------------
--- | Modify the target of a 'Lens' or all the targets of a 'Setter' or 'Traversal'.
+-- | Extract a SEC from a 'Setter'.
--
--- @ 'over' l 'id' ≡ 'id' @
+-- Used to modify the target of a 'Lens' or all the targets of a 'Setter'
+-- or 'Traversal'.
--
-- @
--- 'over' l f '.' 'over' l g ≡ 'over' l (f '.' g)
+-- 'over' o 'id' ≡ 'id'
+-- 'over' o f '.' 'over' o g ≡ 'over' o (f '.' g)
+-- 'setter' '.' 'over' ≡ 'id'
+-- 'over' '.' 'setter' ≡ 'id'
-- @
--
--- >>> over mapped f (over mapped g [a,b,c]) == over mapped (f . g) [a,b,c]
--- True
---
--- >>> over mapped f (Just a)
--- Just (f a)
+-- >>> over fmapped (+1) (Just 1)
+-- Just 2
--
--- >>> over mapped (*10) [1,2,3]
+-- >>> over fmapped (*10) [1,2,3]
-- [10,20,30]
--
--- >>> over _1 f (a,b)
--- (f a,b)
+-- >>> over t21 (+1) (1,2)
+-- (2,2)
--
--- >>> over _1 show (10,20)
+-- >>> over t21 show (10,20)
-- ("10",20)
--
-- @
--- 'fmap' ≡ 'over' 'mapped'
--- 'setter' '.' 'over' ≡ 'id'
--- 'over' '.' 'setter' ≡ 'id'
--- @
---
--- @ 'over' ('cayley' a) ('Data.Semiring.unit' <>) 'Data.Monoid.mempty' ≡ a @
---
--- @
-- over :: Setter s t a b -> (a -> r) -> s -> r
-- over :: Monoid r => Fold s t a b -> (a -> r) -> s -> r
-- @
--
-over :: Optic (->) s t a b -> (a -> b) -> s -> t
-over = id
+over :: ASetter s t a b -> (a -> b) -> s -> t
+over o = (runIdentity #.) #. runStar #. o .# Star .# (Identity #. )
+{-# INLINE over #-}
--- | TODO: Document
+-- |
--
-reover :: Optic (Re (->) a b) s t a b -> (t -> s) -> (b -> a)
-reover = re
-
----------------------------------------------------------------------
--- Derived operators
----------------------------------------------------------------------
-
-infixr 4 %~
-
--- | TODO: Document
+-- >>> ixover (ixat 1) (+) [1,2,3 :: Int]
+-- [1,3,3]
--
-(%~) :: Optic (->) s t a b -> (a -> b) -> s -> t
-(%~) = id
-{-# INLINE (%~) #-}
-
-infixr 4 .~
+-- >>> ixover (ixat 5) (+) [1,2,3 :: Int]
+-- [1,2,3]
+--
+ixover :: Monoid i => AIxsetter i s t a b -> (i -> a -> b) -> s -> t
+ixover o f = curry (over o (uncurry f)) mempty
+{-# INLINE ixover #-}
--- | TODO: Document
+-- | Extract a SEC from a 'Resetter'.
--
-(.~) :: Optic (->) s t a b -> b -> s -> t
-(.~) = set
-{-# INLINE (.~) #-}
+-- @
+-- 'under' o 'id' ≡ 'id'
+-- 'under' o f '.' 'under' o g ≡ 'under' o (f '.' g)
+-- 'resetter' '.' 'under' ≡ 'id'
+-- 'under' '.' 'resetter' ≡ 'id'
+-- @
+--
+-- Note that 'under' (more properly co-/over/) is distinct from 'Data.Profunctor.Optic.Iso.reover':
+--
+-- >>> :t under $ wrapped @(Identity Int)
+-- under $ wrapped @(Identity Int)
+-- :: (Int -> Int) -> Identity Int -> Identity Int
+-- >>> :t over $ wrapped @(Identity Int)
+-- over $ wrapped @(Identity Int)
+-- :: (Int -> Int) -> Identity Int -> Identity Int
+-- >>> :t over . re $ wrapped @(Identity Int)
+-- over . re $ wrapped @(Identity Int)
+-- :: (Identity Int -> Identity Int) -> Int -> Int
+-- >>> :t reover $ wrapped @(Identity Int)
+-- reover $ wrapped @(Identity Int)
+-- :: (Identity Int -> Identity Int) -> Int -> Int
+--
+-- Compare to the /lens-family/ <http://hackage.haskell.org/package/lens-family-2.0.0/docs/Lens-Family2.html#v:under version>.
+--
+under :: AResetter s t a b -> (a -> b) -> s -> t
+under o = (.# Identity) #. runCostar #. o .# Costar .# (.# runIdentity)
+{-# INLINE under #-}
--- | Set all referenced fields to the given value.
+-- |
+--
+-- >>> cxover (catchOn 42) (\k msg -> show k ++ ": " ++ msg) $ Just "foo"
+-- Just "0: foo"
--
--- @ set l y (set l x a) ≡ set l y a @
+-- >>> cxover (catchOn 42) (\k msg -> show k ++ ": " ++ msg) Nothing
+-- Nothing
--
-set :: Optic (->) s t a b -> b -> s -> t
-set o b = o (const b)
+-- >>> cxover (catchOn 0) (\k msg -> show k ++ ": " ++ msg) Nothing
+-- Just "caught"
+--
+cxover :: Monoid k => ACxsetter k s t a b -> (k -> a -> b) -> s -> t
+cxover o f = flip (under o (flip f)) mempty
+{-# INLINE cxover #-}
+
+-- | The join of 'under' and 'over'.
+--
+through :: Optic (->) s t a b -> (a -> b) -> s -> t
+through = id
+{-# INLINE through #-}
---------------------------------------------------------------------
--- Common setters
+-- Optics
---------------------------------------------------------------------
--- | The unit SEC
+-- | Map covariantly over the output of a 'Profunctor'.
--
-one :: Monoid a => Semiring a => Setter' a a
-one = setter id
-
--- | The zero SEC
+-- The most common profunctor to use this with is @(->)@.
--
-zero :: Monoid a => Semiring a => Setter' a a
-zero = setter $ const id
-
--- | Map contravariantly by setter the input of a 'Profunctor'.
+-- @
+-- (dom ..~ f) g x ≡ f (g x)
+-- cod @(->) ≡ 'Data.Profunctor.Optic.Grate.withGrate' 'Data.Profunctor.Closed.closed' 'Data.Profunctor.Optic.Setter.closing'
+-- @
--
+-- >>> (cod ..~ show) length [1,2,3]
+-- "3"
+--
+cod :: Profunctor p => Setter (p r a) (p r b) a b
+cod = setter rmap
+{-# INLINE cod #-}
+
+-- | Map contravariantly over the input of a 'Profunctor'.
--
-- The most common profunctor to use this with is @(->)@.
--
--- >>> (dom %~ f) g x
--- g (f x)
+-- @
+-- (dom ..~ f) g x ≡ g (f x)
+-- @
--
--- >>> (dom %~ show) length [1,2,3]
+-- >>> (dom ..~ show) length [1,2,3]
-- 7
--
--- >>> (dom %~ f) h x y
--- h (f x) y
---
--- Map setter the second arg of a function:
---
--- >>> (mapped . dom %~ f) h x y
--- h x (f y)
---
dom :: Profunctor p => Setter (p b r) (p a r) a b
dom = setter lmap
{-# INLINE dom #-}
--- | A grate accessing the codomain of a function.
+-- | 'Setter' for monadically transforming a monadic value.
+--
+bound :: Monad m => Setter (m a) (m b) a (m b)
+bound = setter (=<<)
+{-# INLINE bound #-}
+
+-- | 'Setter' on each value of a functor.
+--
+fmapped :: Functor f => Setter (f a) (f b) a b
+fmapped = setter fmap
+{-# INLINE fmapped #-}
+
+-- | This 'Setter' can be used to map over all of the inputs to a 'Contravariant'.
--
-- @
--- cod @(->) == lowerGrate range
+-- 'contramap' ≡ 'over' 'contramapped'
-- @
--
-cod :: Profunctor p => Setter (p r a) (p r b) a b
-cod = setter rmap
+-- >>> getPredicate (over contramapped (*2) (Predicate even)) 5
+-- True
+--
+-- >>> getOp (over contramapped (*5) (Op show)) 100
+-- "500"
+--
+contramapped :: Contravariant f => Setter (f b) (f a) a b
+contramapped = setter contramap
+{-# INLINE contramapped #-}
--- | SEC for monadically transforming a monadic value.
+-- |
--
-bound :: Monad m => Setter (m a) (m b) a (m b)
-bound = setter (=<<)
+-- >>> over setmapped (+1) (Set.fromList [1,2,3,4])
+-- fromList [2,3,4,5]
+setmapped :: Ord b => Setter (Set a) (Set b) a b
+setmapped = setter Set.map
+{-# INLINE setmapped #-}
--- | SEC on each value of a functor.
+-- |
--
-fmapped :: Functor f => Setter (f a) (f b) a b
-fmapped = setter fmap
+-- >>> over isetmapped (+1) (IntSet.fromList [1,2,3,4])
+-- fromList [2,3,4,5]
+isetmapped :: Setter' IntSet Int
+isetmapped = setter IntSet.map
+{-# INLINE isetmapped #-}
-- | TODO: Document
--
-foldMapped :: Foldable f => Monoid m => Setter (f a) m a m
-foldMapped = setter foldMap
+foldmapped :: Foldable f => Monoid m => Setter (f a) m a m
+foldmapped = setter foldMap
+{-# INLINE foldmapped #-}
-- | This 'setter' can be used to modify all of the values in an 'Applicative'.
--
@@ -199,75 +414,454 @@ foldMapped = setter foldMap
-- 'liftA' ≡ 'setter' 'liftedA'
-- @
--
--- >>> setter liftedA f [a,b,c]
--- [f a,f b,f c]
+-- >>> setter liftedA Identity [1,2,3]
+-- [Identity 1,Identity 2,Identity 3]
+--
+-- >>> set liftedA 2 (Just 1)
+-- Just 2
--
--- >>> set liftedA b (Just a)
--- Just b
liftedA :: Applicative f => Setter (f a) (f b) a b
liftedA = setter liftA
+{-# INLINE liftedA #-}
-- | TODO: Document
--
liftedM :: Monad m => Setter (m a) (m b) a b
liftedM = setter liftM
+{-# INLINE liftedM #-}
--- | Set a value using an SEC.
+-- | Modify the local environment of a 'Reader'.
+--
+-- Use to lift reader actions into a larger environment:
--
-sets :: Setter b (a -> c) a c
-sets = setter const
+-- >>> runReader ( ask & locally ..~ fst ) (1,2)
+-- 1
+--
+locally :: Setter (ReaderT r2 m a) (ReaderT r1 m a) r1 r2
+locally = setter withReaderT
+{-# INLINE locally #-}
-- | TODO: Document
--
zipped :: Setter (u -> v -> a) (u -> v -> b) a b
zipped = setter ((.)(.)(.))
+{-# INLINE zipped #-}
+
+-- | Apply a function only when the given condition holds.
+--
+-- See also 'Data.Profunctor.Optic.Affine.predicated' & 'Data.Profunctor.Optic.Prism.filtered'.
+--
+cond :: (a -> Bool) -> Setter' a a
+cond p = setter $ \f a -> if p a then f a else a
+{-# INLINE cond #-}
+
+-- | TODO: Document
+--
+modded :: (a -> Bool) -> Setter' (a -> b) b
+modded p = setter $ \mods f a -> if p a then mods (f a) else f a
+{-# INLINE modded #-}
-- | TODO: Document
--
-modded :: Setter (b -> t) (((s -> a) -> b) -> t) s a
-modded = setter $ \sa bt sab -> bt (sab sa)
+reviewed :: Setter (b -> t) (((s -> a) -> b) -> t) s a
+reviewed = setter $ \sa bt sab -> bt (sab sa)
+{-# INLINE reviewed #-}
-- | TODO: Document
--
composed :: Setter (s -> a) ((a -> b) -> s -> t) b t
composed = setter between
+{-# INLINE composed #-}
--- | Apply a function only when the given predicate holds.
+-- | Map one exception into another as proposed in the paper "A semantics for imprecise exceptions".
--
-branched :: (a -> Bool) -> Setter' a a
-branched p = setter $ \f a -> if p a then f a else a
+-- >>> handles (only Overflow) (\_ -> return "caught") $ assert False (return "uncaught") & (exmapped ..~ \ (AssertionFailed _) -> Overflow)
+-- "caught"
+--
+-- @
+-- exmapped :: Exception e => Setter s s SomeException e
+-- @
+--
+exmapped :: Exception e1 => Exception e2 => Setter s s e1 e2
+exmapped = setter Ex.mapException
+{-# INLINE exmapped #-}
--- | TODO: Document
+---------------------------------------------------------------------
+-- Operators
+---------------------------------------------------------------------
+
+infixr 4 .~, ..~, %~, %%~, /~, //~, #~, ##~, ?~, <>~, ><~
+
+-- | Run a profunctor arrow command and set the optic targets to the result.
+--
+-- Similar to 'assign', except that the type of the object being modified can change.
+--
+-- >>> getVal1 = Right 3
+-- >>> getVal2 = Right False
+-- >>> action = assignA t21 (Kleisli (const getVal1)) >>> assignA t22 (Kleisli (const getVal2))
+-- >>> runKleisli action ((), ())
+-- Right (3,False)
+--
+-- @
+-- 'assignA' :: 'Category' p => 'Iso' s t a b -> 'Lenslike' p s t s b
+-- 'assignA' :: 'Category' p => 'Lens' s t a b -> 'Lenslike' p s t s b
+-- 'assignA' :: 'Category' p => 'Grate' s t a b -> 'Lenslike' p s t s b
+-- 'assignA' :: 'Category' p => 'Setter' s t a b -> 'Lenslike' p s t s b
+-- 'assignA' :: 'Category' p => 'Traversal' s t a b -> 'Lenslike' p s t s b
+-- @
--
-branched' :: (k -> Bool) -> Setter' (k -> v) v
-branched' p = setter $ \md f a -> if p a then md (f a) else f a
+assignA :: Category p => Strong p => ASetter s t a b -> Optic p s t s b
+assignA o p = arr (flip $ set o) &&& p >>> arr (uncurry id)
+{-# INLINE assignA #-}
--- | This 'Setter' can be used to purely map over the 'Exception's an
--- arbitrary expression might throw; it is a variant of 'mapException' in
--- the same way that 'mapped' is a variant of 'fmap'.
+-- | Set all referenced fields to the given value.
--
--- > 'mapException' ≡ 'over' 'excepted'
+-- @ 'set' l y ('set' l x a) ≡ 'set' l y a @
--
--- This view that every Haskell expression can be regarded as carrying a bag
--- of 'Exception's is detailed in “A Semantics for Imprecise Exceptions” by
--- Peyton Jones & al. at PLDI ’99.
+set :: ASetter s t a b -> b -> s -> t
+set o b = over o (const b)
+{-# INLINE set #-}
+
+-- | Set with index. Equivalent to 'ixover' with the current value ignored.
--
--- The following maps failed assertions to arithmetic overflow:
+-- When you do not need access to the index, then 'set' is more liberal in what it can accept.
--
--- >>> handleOf _Overflow (\_ -> return "caught") $ assert False (return "uncaught") & (exmapped %~ \ (AssertionFailed _) -> Overflow)
--- "caught"
+-- @
+-- 'set' o ≡ 'ixset' o '.' 'const'
+-- @
+--
+-- >>> ixset (ixat 2) (2-) [1,2,3 :: Int]
+-- [1,2,0]
+--
+-- >>> ixset (ixat 5) (const 0) [1,2,3 :: Int]
+-- [1,2,3]
+--
+ixset :: Monoid i => AIxsetter i s t a b -> (i -> b) -> s -> t
+ixset o = ixover o . (const .)
+{-# INLINE ixset #-}
+
+-- | Set all referenced fields to the given value.
+--
+-- @
+-- 'reset' ≡ 'set' '.' 're'
+-- @
--
-exmapped :: Exception e0 => Exception e1 => Setter s s e0 e1
-exmapped = setter Ex.mapException
+reset :: AResetter s t a b -> b -> s -> t
+reset o b = under o (const b)
+{-# INLINE reset #-}
--- | A type restricted version of 'mappedException'.
+-- | Dual set with index. Equivalent to 'cxover' with the current value ignored.
--
--- This function avoids the type ambiguity in the input 'Exception' when using 'set'.
+-- >>> cxset (catchOn 42) show $ Just "foo"
+-- Just "0"
--
--- The following maps any exception to arithmetic overflow:
+-- >>> cxset (catchOn 42) show Nothing
+-- Nothing
--
--- >>> handleOf _Overflow (\_ -> return "caught") $ assert False (return "uncaught") & (exmapped' .~ Overflow)
--- "caught"
+-- >>> cxset (catchOn 0) show Nothing
+-- Just "caught"
+--
+cxset :: Monoid k => ACxsetter k s t a b -> (k -> b) -> s -> t
+cxset o kb = cxover o $ flip (const kb)
+{-# INLINE cxset #-}
+
+-- | TODO: Document
+--
+(.~) :: ASetter s t a b -> b -> s -> t
+(.~) = set
+{-# INLINE (.~) #-}
+
+-- | TODO: Document
+--
+-- >>> Nothing & just ..~ (+1)
+-- Nothing
+--
+(..~) :: ASetter s t a b -> (a -> b) -> s -> t
+(..~) = over
+{-# INLINE (..~) #-}
+
+-- | An infix variant of 'ixset'. Dual to '#~'.
+--
+(%~) :: Monoid i => AIxsetter i s t a b -> (i -> b) -> s -> t
+(%~) = ixset
+{-# INLINE (%~) #-}
+
+-- | An infix variant of 'ixover'. Dual to '##~'.
+--
+(%%~) :: Monoid i => AIxsetter i s t a b -> (i -> a -> b) -> s -> t
+(%%~) = ixover
+{-# INLINE (%%~) #-}
+
+-- | An infix variant of 'reset'. Dual to '.~'.
+--
+(/~) :: AResetter s t a b -> b -> s -> t
+(/~) = reset
+{-# INLINE (/~) #-}
+
+-- | An infix variant of 'under'. Dual to '..~'.
+--
+(//~) :: AResetter s t a b -> (a -> b) -> s -> t
+(//~) = under
+{-# INLINE (//~) #-}
+
+-- | An infix variant of 'cxset'. Dual to '%~'.
+--
+(#~) :: Monoid k => ACxsetter k s t a b -> (k -> b) -> s -> t
+(#~) = cxset
+{-# INLINE (#~) #-}
+
+-- | An infix variant of 'cxover'. Dual to '%%~'.
+--
+-- >>> Just "foo" & catchOn 0 ##~ (\k msg -> show k ++ ": " ++ msg)
+-- Just "0: foo"
+--
+-- >>> Nothing & catchOn 0 ##~ (\k msg -> show k ++ ": " ++ msg)
+-- Just "caught"
+--
+(##~) :: Monoid k => ACxsetter k s t a b -> (k -> a -> b) -> s -> t
+(##~) = cxover
+{-# INLINE (##~) #-}
+
+-- | Set the target of a settable optic to 'Just' a value.
+--
+-- @
+-- l '?~' t ≡ 'set' l ('Just' t)
+-- @
+--
+-- >>> Nothing & id ?~ 1
+-- Just 1
+--
+-- '?~' can be used type-changily:
+--
+-- >>> ('a', ('b', 'c')) & t22 . both ?~ 'x'
+-- ('a',(Just 'x',Just 'x'))
+--
+-- @
+-- ('?~') :: 'Iso' s t a ('Maybe' b) -> b -> s -> t
+-- ('?~') :: 'Lens' s t a ('Maybe' b) -> b -> s -> t
+-- ('?~') :: 'Grate' s t a ('Maybe' b) -> b -> s -> t
+-- ('?~') :: 'Setter' s t a ('Maybe' b) -> b -> s -> t
+-- ('?~') :: 'Traversal' s t a ('Maybe' b) -> b -> s -> t
+-- @
+--
+(?~) :: ASetter s t a (Maybe b) -> b -> s -> t
+o ?~ b = set o (Just b)
+{-# INLINE (?~) #-}
+
+-- | Modify the target by adding another value.
+--
+-- >>> both <>~ False $ (False,True)
+-- (False,True)
+--
+-- >>> both <>~ "!!!" $ ("hello","world")
+-- ("hello!!!","world!!!")
+--
+-- @
+-- ('<>~') :: 'Semigroup' a => 'Iso' s t a a -> a -> s -> t
+-- ('<>~') :: 'Semigroup' a => 'Lens' s t a a -> a -> s -> t
+-- ('<>~') :: 'Semigroup' a => 'Grate' s t a a -> a -> s -> t
+-- ('<>~') :: 'Semigroup' a => 'Setter' s t a a -> a -> s -> t
+-- ('<>~') :: 'Semigroup' a => 'Traversal' s t a a -> a -> s -> t
+-- @
+--
+(<>~) :: Semigroup a => ASetter s t a a -> a -> s -> t
+l <>~ n = over l (<> n)
+{-# INLINE (<>~) #-}
+
+-- | Modify the target by multiplying by another value.
+--
+-- >>> both ><~ False $ (False,True)
+-- (False,False)
+--
+-- @
+-- ('><~') :: 'Semiring' a => 'Iso' s t a a -> a -> s -> t
+-- ('><~') :: 'Semiring' a => 'Lens' s t a a -> a -> s -> t
+-- ('><~') :: 'Semiring' a => 'Grate' s t a a -> a -> s -> t
+-- ('><~') :: 'Semiring' a => 'Setter' s t a a -> a -> s -> t
+-- ('><~') :: 'Semiring' a => 'Traversal' s t a a -> a -> s -> t
+-- @
--
-exmapped' :: Exception e => Setter s s SomeException e
-exmapped' = exmapped
+(><~) :: Semiring a => ASetter s t a a -> a -> s -> t
+l ><~ n = over l (>< n)
+{-# INLINE (><~) #-}
+
+---------------------------------------------------------------------
+-- MonadState
+---------------------------------------------------------------------
+
+infix 4 .=, ..=, %=, %%=, //=, #=, ##=, ?=, <>=, ><=
+
+-- | Replace the target(s) of a settable in a monadic state.
+--
+-- @
+-- 'assigns' :: 'MonadState' s m => 'Iso'' s a -> a -> m ()
+-- 'assigns' :: 'MonadState' s m => 'Lens'' s a -> a -> m ()
+-- 'assigns' :: 'MonadState' s m => 'Grate'' s a -> a -> m ()
+-- 'assigns' :: 'MonadState' s m => 'Prism'' s a -> a -> m ()
+-- 'assigns' :: 'MonadState' s m => 'Setter'' s a -> a -> m ()
+-- 'assigns' :: 'MonadState' s m => 'Traversal'' s a -> a -> m ()
+-- @
+--
+assigns :: MonadState s m => ASetter s s a b -> b -> m ()
+assigns o b = State.modify (set o b)
+{-# INLINE assigns #-}
+
+-- | Map over the target(s) of a 'Setter' in a monadic state.
+--
+-- @
+-- 'modifies' :: 'MonadState' s m => 'Iso'' s a -> (a -> a) -> m ()
+-- 'modifies' :: 'MonadState' s m => 'Lens'' s a -> (a -> a) -> m ()
+-- 'modifies' :: 'MonadState' s m => 'Grate'' s a -> (a -> a) -> m ()
+-- 'modifies' :: 'MonadState' s m => 'Prism'' s a -> (a -> a) -> m ()
+-- 'modifies' :: 'MonadState' s m => 'Setter'' s a -> (a -> a) -> m ()
+-- 'modifies' :: 'MonadState' s m => 'Traversal'' s a -> (a -> a) -> m ()
+-- @
+--
+modifies :: MonadState s m => ASetter s s a b -> (a -> b) -> m ()
+modifies o f = State.modify (over o f)
+{-# INLINE modifies #-}
+
+-- | Replace the target(s) of a settable in a monadic state.
+--
+-- This is an infix version of 'assigns'.
+--
+-- >>> execState (do t21 .= 1; t22 .= 2) (3,4)
+-- (1,2)
+--
+-- >>> execState (both .= 3) (1,2)
+-- (3,3)
+--
+-- @
+-- ('.=') :: 'MonadState' s m => 'Iso'' s a -> a -> m ()
+-- ('.=') :: 'MonadState' s m => 'Lens'' s a -> a -> m ()
+-- ('.=') :: 'MonadState' s m => 'Grate'' s a -> a -> m ()
+-- ('.=') :: 'MonadState' s m => 'Prism'' s a -> a -> m ()
+-- ('.=') :: 'MonadState' s m => 'Setter'' s a -> a -> m ()
+-- ('.=') :: 'MonadState' s m => 'Traversal'' s a -> a -> m ()
+-- @
+--
+(.=) :: MonadState s m => ASetter s s a b -> b -> m ()
+o .= b = State.modify (o .~ b)
+{-# INLINE (.=) #-}
+
+-- | Map over the target(s) of a 'Setter' in a monadic state.
+--
+-- This is an infix version of 'modifies'.
+--
+-- >>> execState (do just ..= (+1) ) Nothing
+-- Nothing
+--
+-- >>> execState (do t21 ..= (+1) ;t22 ..= (+2)) (1,2)
+-- (2,4)
+--
+-- >>> execState (do both ..= (+1)) (1,2)
+-- (2,3)
+--
+-- @
+-- ('..=') :: 'MonadState' s m => 'Iso'' s a -> (a -> a) -> m ()
+-- ('..=') :: 'MonadState' s m => 'Lens'' s a -> (a -> a) -> m ()
+-- ('..=') :: 'MonadState' s m => 'Grate'' s a -> (a -> a) -> m ()
+-- ('..=') :: 'MonadState' s m => 'Prism'' s a -> (a -> a) -> m ()
+-- ('..=') :: 'MonadState' s m => 'Setter'' s a -> (a -> a) -> m ()
+-- ('..=') :: 'MonadState' s m => 'Traversal'' s a -> (a -> a) -> m ()
+-- @
+--
+(..=) :: MonadState s m => ASetter s s a b -> (a -> b) -> m ()
+o ..= f = State.modify (o ..~ f)
+{-# INLINE (..=) #-}
+
+-- | TODO: Document
+--
+(%=) :: MonadState s m => Monoid i => AIxsetter i s s a b -> (i -> b) -> m ()
+o %= b = State.modify (o %~ b)
+
+-- | TODO: Document
+--
+(%%=) :: MonadState s m => Monoid i => AIxsetter i s s a b -> (i -> a -> b) -> m ()
+o %%= f = State.modify (o %%~ f)
+{-# INLINE (%%=) #-}
+
+-- | TODO: Document
+--
+(//=) :: MonadState s m => AResetter s s a b -> (a -> b) -> m ()
+o //= f = State.modify (o //~ f)
+{-# INLINE (//=) #-}
+
+-- | TODO: Document
+--
+(#=) :: MonadState s m => Monoid k => ACxsetter k s s a b -> (k -> b) -> m ()
+o #= f = State.modify (o #~ f)
+{-# INLINE (#=) #-}
+
+-- | TODO: Document
+--
+(##=) :: MonadState s m => Monoid k => ACxsetter k s s a b -> (k -> a -> b) -> m ()
+o ##= f = State.modify (o ##~ f)
+{-# INLINE (##=) #-}
+
+-- | Replace the target(s) of a settable optic with 'Just' a new value.
+--
+-- >>> execState (do t21 ?= 1; t22 ?= 2) (Just 1, Nothing)
+-- (Just 1,Just 2)
+--
+-- @
+-- ('?=') :: 'MonadState' s m => 'Iso'' s ('Maybe' a) -> a -> m ()
+-- ('?=') :: 'MonadState' s m => 'Lens'' s ('Maybe' a) -> a -> m ()
+-- ('?=') :: 'MonadState' s m => 'Grate'' s ('Maybe' a) -> a -> m ()
+-- ('?=') :: 'MonadState' s m => 'Prism'' s ('Maybe' a) -> a -> m ()
+-- ('?=') :: 'MonadState' s m => 'Setter'' s ('Maybe' a) -> a -> m ()
+-- ('?=') :: 'MonadState' s m => 'Traversal'' s ('Maybe' a) -> a -> m ()
+-- @
+--
+(?=) :: MonadState s m => ASetter s s a (Maybe b) -> b -> m ()
+o ?= b = State.modify (o ?~ b)
+{-# INLINE (?=) #-}
+
+-- | Modify the target(s) of a settable optic by adding a value.
+--
+-- >>> execState (both <>= False) (False,True)
+-- (False,True)
+--
+-- >>> execState (both <>= "!!!") ("hello","world")
+-- ("hello!!!","world!!!")
+--
+-- @
+-- ('<>=') :: 'MonadState' s m => 'Semigroup' a => 'Iso'' s a -> a -> m ()
+-- ('<>=') :: 'MonadState' s m => 'Semigroup' a => 'Lens'' s a -> a -> m ()
+-- ('<>=') :: 'MonadState' s m => 'Semigroup' a => 'Grate'' s a -> a -> m ()
+-- ('<>=') :: 'MonadState' s m => 'Semigroup' a => 'Prism'' s a -> a -> m ()
+-- ('<>=') :: 'MonadState' s m => 'Semigroup' a => 'Setter'' s a -> a -> m ()
+-- ('<>=') :: 'MonadState' s m => 'Semigroup' a => 'Traversal'' s a -> a -> m ()
+-- @
+--
+(<>=) :: MonadState s m => Semigroup a => ASetter' s a -> a -> m ()
+o <>= a = State.modify (o <>~ a)
+{-# INLINE (<>=) #-}
+
+-- | Modify the target(s) of a settable optic by mulitiplying by a value.
+--
+-- >>> execState (both ><= False) (False,True)
+-- (False,False)
+--
+-- @
+-- ('><=') :: 'MonadState' s m => 'Semiring' a => 'Iso'' s a -> a -> m ()
+-- ('><=') :: 'MonadState' s m => 'Semiring' a => 'Lens'' s a -> a -> m ()
+-- ('><=') :: 'MonadState' s m => 'Semiring' a => 'Grate'' s a -> a -> m ()
+-- ('><=') :: 'MonadState' s m => 'Semiring' a => 'Prism'' s a -> a -> m ()
+-- ('><=') :: 'MonadState' s m => 'Semiring' a => 'Setter'' s a -> a -> m ()
+-- ('><=') :: 'MonadState' s m => 'Semiring' a => 'Traversal'' s a -> a -> m ()
+-- @
+--
+(><=) :: MonadState s m => Semiring a => ASetter' s a -> a -> m ()
+o ><= a = State.modify (o ><~ a)
+{-# INLINE (><=) #-}
+
+-- @
+-- zoom :: Functor m => Lens' ta a -> StateT a m c -> StateT ta m c
+-- zoom :: (Monoid c, Applicative m) => Traversal' ta a -> StateT a m c -> StateT ta m c
+-- @
+zoom :: Functor m => Optic' (Star (Compose m ((,) c))) ta a -> StateT a m c -> StateT ta m c
+zoom o (StateT m) = StateT . out . o . into $ m
+ where
+ into f = Star (Compose . f)
+ out (Star f) = getCompose . f