{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
#ifdef TRUSTWORTHY
{-# LANGUAGE Trustworthy #-}
#endif
module Control.Lens.Setter
(
Setter, Setter'
, IndexedSetter, IndexedSetter'
, ASetter, ASetter'
, AnIndexedSetter, AnIndexedSetter'
, Setting, Setting'
, sets, setting
, cloneSetter
, cloneIndexPreservingSetter
, cloneIndexedSetter
, mapped, lifted
, contramapped
, argument
, over
, set
, (.~), (%~)
, (+~), (-~), (*~), (//~), (^~), (^^~), (**~), (||~), (<>~), (&&~), (<.~), (?~), (<?~)
, assign
, (.=), (%=)
, (+=), (-=), (*=), (//=), (^=), (^^=), (**=), (||=), (<>=), (&&=), (<.=), (?=), (<?=)
, (<~)
, scribe
, passing, ipassing
, censoring, icensoring
, set'
, imapOf, iover
, isets
, (%@~), (%@=)
, assignA
, Settable
, Identity(..)
, mapOf
) where
import Control.Applicative
import Control.Arrow
import Control.Comonad
import Control.Lens.Internal.Indexed
import Control.Lens.Internal.Setter
import Control.Lens.Type
import Control.Monad (liftM)
import Control.Monad.State.Class as State
import Control.Monad.Writer.Class as Writer
import Data.Functor.Contravariant
import Data.Functor.Identity
import Data.Monoid
import Data.Profunctor
import Data.Profunctor.Rep
import Data.Profunctor.Unsafe
#ifdef HLINT
{-# ANN module "HLint: ignore Avoid lambda" #-}
#endif
infixr 4 %@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, ||~, %~, <.~, ?~, <?~
infix 4 %@=, .=, +=, *=, -=, //=, ^=, ^^=, **=, &&=, <>=, ||=, %=, <.=, ?=, <?=
infixr 2 <~
type ASetter s t a b = (a -> Identity b) -> s -> Identity t
type ASetter' s a = ASetter s s a a
type AnIndexedSetter i s t a b = Indexed i a (Identity b) -> s -> Identity t
type AnIndexedSetter' i s a = AnIndexedSetter i s s a a
type Setting p s t a b = p a (Identity b) -> s -> Identity t
type Setting' p s a = Setting p s s a a
mapped :: Functor f => Setter (f a) (f b) a b
mapped = sets fmap
{-# INLINE mapped #-}
lifted :: Monad m => Setter (m a) (m b) a b
lifted = sets liftM
{-# INLINE lifted #-}
contramapped :: Contravariant f => Setter (f b) (f a) a b
contramapped = sets contramap
{-# INLINE contramapped #-}
argument :: Profunctor p => Setter (p b r) (p a r) a b
argument = sets lmap
{-# INLINE argument #-}
setting :: ((a -> b) -> s -> t) -> IndexPreservingSetter s t a b
setting l pafb = cotabulate $ \ws -> pure $ l (\a -> untainted (corep pafb (a <$ ws))) (extract ws)
{-# INLINE setting #-}
sets :: (Profunctor p, Profunctor q, Settable f) => (p a b -> q s t) -> Optical p q f s t a b
sets f g = taintedDot (f (untaintedDot g))
{-# INLINE sets #-}
cloneSetter :: ASetter s t a b -> Setter s t a b
cloneSetter l afb = taintedDot $ runIdentity #. l (Identity #. untaintedDot afb)
{-# INLINE cloneSetter #-}
cloneIndexPreservingSetter :: ASetter s t a b -> IndexPreservingSetter s t a b
cloneIndexPreservingSetter l pafb = cotabulate $ \ws ->
taintedDot runIdentity $ l (\a -> Identity (untainted (corep pafb (a <$ ws)))) (extract ws)
{-# INLINE cloneIndexPreservingSetter #-}
cloneIndexedSetter :: AnIndexedSetter i s t a b -> IndexedSetter i s t a b
cloneIndexedSetter l pafb = taintedDot (runIdentity #. l (Indexed $ \i -> Identity #. untaintedDot (indexed pafb i)))
{-# INLINE cloneIndexedSetter #-}
over :: Profunctor p => Setting p s t a b -> p a b -> s -> t
over l f = runIdentity #. l (Identity #. f)
{-# INLINE over #-}
set :: ASetter s t a b -> b -> s -> t
set l b = runIdentity #. l (\_ -> Identity b)
{-# INLINE set #-}
set' :: ASetter' s a -> a -> s -> s
set' l b = runIdentity #. l (\_ -> Identity b)
{-# INLINE set' #-}
(%~) :: Profunctor p => Setting p s t a b -> p a b -> s -> t
(%~) = over
{-# INLINE (%~) #-}
(.~) :: ASetter s t a b -> b -> s -> t
(.~) = set
{-# INLINE (.~) #-}
(?~) :: ASetter s t a (Maybe b) -> b -> s -> t
l ?~ b = set l (Just b)
{-# INLINE (?~) #-}
(<.~) :: ASetter s t a b -> b -> s -> (b, t)
l <.~ b = \s -> (b, set l b s)
{-# INLINE (<.~) #-}
(<?~) :: ASetter s t a (Maybe b) -> b -> s -> (b, t)
l <?~ b = \s -> (b, set l (Just b) s)
{-# INLINE (<?~) #-}
(+~) :: Num a => ASetter s t a a -> a -> s -> t
l +~ n = over l (+ n)
{-# INLINE (+~) #-}
(*~) :: Num a => ASetter s t a a -> a -> s -> t
l *~ n = over l (* n)
{-# INLINE (*~) #-}
(-~) :: Num a => ASetter s t a a -> a -> s -> t
l -~ n = over l (subtract n)
{-# INLINE (-~) #-}
(//~) :: Fractional a => ASetter s t a a -> a -> s -> t
l //~ n = over l (/ n)
{-# INLINE (//~) #-}
(^~) :: (Num a, Integral e) => ASetter s t a a -> e -> s -> t
l ^~ n = over l (^ n)
{-# INLINE (^~) #-}
(^^~) :: (Fractional a, Integral e) => ASetter s t a a -> e -> s -> t
l ^^~ n = over l (^^ n)
{-# INLINE (^^~) #-}
(**~) :: Floating a => ASetter s t a a -> a -> s -> t
l **~ n = over l (** n)
{-# INLINE (**~) #-}
(||~):: ASetter s t Bool Bool -> Bool -> s -> t
l ||~ n = over l (|| n)
{-# INLINE (||~) #-}
(&&~) :: ASetter s t Bool Bool -> Bool -> s -> t
l &&~ n = over l (&& n)
{-# INLINE (&&~) #-}
assign :: MonadState s m => ASetter s s a b -> b -> m ()
assign l b = State.modify (set l b)
{-# INLINE assign #-}
(.=) :: MonadState s m => ASetter s s a b -> b -> m ()
l .= b = State.modify (l .~ b)
{-# INLINE (.=) #-}
(%=) :: (Profunctor p, MonadState s m) => Setting p s s a b -> p a b -> m ()
l %= f = State.modify (l %~ f)
{-# INLINE (%=) #-}
(?=) :: MonadState s m => ASetter s s a (Maybe b) -> b -> m ()
l ?= b = State.modify (l ?~ b)
{-# INLINE (?=) #-}
(+=) :: (MonadState s m, Num a) => ASetter' s a -> a -> m ()
l += b = State.modify (l +~ b)
{-# INLINE (+=) #-}
(-=) :: (MonadState s m, Num a) => ASetter' s a -> a -> m ()
l -= b = State.modify (l -~ b)
{-# INLINE (-=) #-}
(*=) :: (MonadState s m, Num a) => ASetter' s a -> a -> m ()
l *= b = State.modify (l *~ b)
{-# INLINE (*=) #-}
(//=) :: (MonadState s m, Fractional a) => ASetter' s a -> a -> m ()
l //= a = State.modify (l //~ a)
{-# INLINE (//=) #-}
(^=) :: (MonadState s m, Num a, Integral e) => ASetter' s a -> e -> m ()
l ^= e = State.modify (l ^~ e)
{-# INLINE (^=) #-}
(^^=) :: (MonadState s m, Fractional a, Integral e) => ASetter' s a -> e -> m ()
l ^^= e = State.modify (l ^^~ e)
{-# INLINE (^^=) #-}
(**=) :: (MonadState s m, Floating a) => ASetter' s a -> a -> m ()
l **= a = State.modify (l **~ a)
{-# INLINE (**=) #-}
(&&=):: MonadState s m => ASetter' s Bool -> Bool -> m ()
l &&= b = State.modify (l &&~ b)
{-# INLINE (&&=) #-}
(||=) :: MonadState s m => ASetter' s Bool -> Bool -> m ()
l ||= b = State.modify (l ||~ b)
{-# INLINE (||=) #-}
(<~) :: MonadState s m => ASetter s s a b -> m b -> m ()
l <~ mb = mb >>= (l .=)
{-# INLINE (<~) #-}
(<.=) :: MonadState s m => ASetter s s a b -> b -> m b
l <.= b = do
l .= b
return b
{-# INLINE (<.=) #-}
(<?=) :: MonadState s m => ASetter s s a (Maybe b) -> b -> m b
l <?= b = do
l ?= b
return b
{-# INLINE (<?=) #-}
(<>~) :: Monoid a => ASetter s t a a -> a -> s -> t
l <>~ n = over l (`mappend` n)
{-# INLINE (<>~) #-}
(<>=) :: (MonadState s m, Monoid a) => ASetter' s a -> a -> m ()
l <>= a = State.modify (l <>~ a)
{-# INLINE (<>=) #-}
scribe :: (MonadWriter t m, Monoid s) => ASetter s t a b -> b -> m ()
scribe l b = tell (set l b mempty)
{-# INLINE scribe #-}
passing :: MonadWriter w m => Setter w w u v -> m (a, u -> v) -> m a
passing l m = pass $ do
(a, uv) <- m
return (a, over l uv)
{-# INLINE passing #-}
ipassing :: MonadWriter w m => IndexedSetter i w w u v -> m (a, i -> u -> v) -> m a
ipassing l m = pass $ do
(a, uv) <- m
return (a, iover l uv)
{-# INLINE ipassing #-}
censoring :: MonadWriter w m => Setter w w u v -> (u -> v) -> m a -> m a
censoring l uv = censor (over l uv)
{-# INLINE censoring #-}
icensoring :: MonadWriter w m => IndexedSetter i w w u v -> (i -> u -> v) -> m a -> m a
icensoring l uv = censor (iover l uv)
{-# INLINE icensoring #-}
iover :: AnIndexedSetter i s t a b -> (i -> a -> b) -> s -> t
iover l = over l .# Indexed
{-# INLINE iover #-}
isets :: ((i -> a -> b) -> s -> t) -> IndexedSetter i s t a b
isets f = sets (f . indexed)
{-# INLINE isets #-}
(%@~) :: AnIndexedSetter i s t a b -> (i -> a -> b) -> s -> t
l %@~ f = l %~ Indexed f
{-# INLINE (%@~) #-}
(%@=) :: MonadState s m => AnIndexedSetter i s s a b -> (i -> a -> b) -> m ()
l %@= f = State.modify (l %@~ f)
{-# INLINE (%@=) #-}
assignA :: Arrow p => ASetter s t a b -> p s b -> p s t
assignA l p = arr (flip $ set l) &&& p >>> arr (uncurry id)
{-# INLINE assignA #-}
mapOf :: Profunctor p => Setting p s t a b -> p a b -> s -> t
mapOf = over
{-# INLINE mapOf #-}
{-# DEPRECATED mapOf "Use `over`" #-}
imapOf :: AnIndexedSetter i s t a b -> (i -> a -> b) -> s -> t
imapOf = iover
{-# INLINE imapOf #-}
{-# DEPRECATED imapOf "Use `iover`" #-}