{-# OPTIONS_HADDOCK not-home #-}
module Optics.Internal.Utils
( Identity'(..)
, wrapIdentity'
, unwrapIdentity'
, Traversed(..)
, runTraversed
, OrT(..)
, wrapOrT
, (#.)
, (.#)
, uncurry'
) where
import qualified Data.Semigroup as SG
import Data.Profunctor.Indexed
data Identity' a = Identity' {-# UNPACK #-} !() a
deriving forall a b. a -> Identity' b -> Identity' a
forall a b. (a -> b) -> Identity' a -> Identity' b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Identity' b -> Identity' a
$c<$ :: forall a b. a -> Identity' b -> Identity' a
fmap :: forall a b. (a -> b) -> Identity' a -> Identity' b
$cfmap :: forall a b. (a -> b) -> Identity' a -> Identity' b
Functor
instance Applicative Identity' where
pure :: forall a. a -> Identity' a
pure a
a = forall a. () -> a -> Identity' a
Identity' () a
a
Identity' () a -> b
f <*> :: forall a b. Identity' (a -> b) -> Identity' a -> Identity' b
<*> Identity' () a
x = forall a. () -> a -> Identity' a
Identity' () (a -> b
f a
x)
instance Mapping (Star Identity') where
roam :: forall a b s t i.
((a -> b) -> s -> t)
-> Star Identity' i a b -> Star Identity' i s t
roam (a -> b) -> s -> t
f (Star a -> Identity' b
k) = forall (f :: * -> *) i a b. (a -> f b) -> Star f i a b
Star forall a b. (a -> b) -> a -> b
$ forall a. a -> Identity' a
wrapIdentity' forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> s -> t
f (forall a. Identity' a -> a
unwrapIdentity' forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Identity' b
k)
iroam :: forall i a b s t j.
((i -> a -> b) -> s -> t)
-> Star Identity' j a b -> Star Identity' (i -> j) s t
iroam (i -> a -> b) -> s -> t
f (Star a -> Identity' b
k) = forall (f :: * -> *) i a b. (a -> f b) -> Star f i a b
Star forall a b. (a -> b) -> a -> b
$ forall a. a -> Identity' a
wrapIdentity' forall b c a. (b -> c) -> (a -> b) -> a -> c
. (i -> a -> b) -> s -> t
f (\i
_ -> forall a. Identity' a -> a
unwrapIdentity' forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Identity' b
k)
instance Mapping (IxStar Identity') where
roam :: forall a b s t i.
((a -> b) -> s -> t)
-> IxStar Identity' i a b -> IxStar Identity' i s t
roam (a -> b) -> s -> t
f (IxStar i -> a -> Identity' b
k) =
forall (f :: * -> *) i a b. (i -> a -> f b) -> IxStar f i a b
IxStar forall a b. (a -> b) -> a -> b
$ \i
i -> forall a. a -> Identity' a
wrapIdentity' forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> s -> t
f (forall a. Identity' a -> a
unwrapIdentity' forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> a -> Identity' b
k i
i)
iroam :: forall i a b s t j.
((i -> a -> b) -> s -> t)
-> IxStar Identity' j a b -> IxStar Identity' (i -> j) s t
iroam (i -> a -> b) -> s -> t
f (IxStar j -> a -> Identity' b
k) =
forall (f :: * -> *) i a b. (i -> a -> f b) -> IxStar f i a b
IxStar forall a b. (a -> b) -> a -> b
$ \i -> j
ij -> forall a. a -> Identity' a
wrapIdentity' forall b c a. (b -> c) -> (a -> b) -> a -> c
. (i -> a -> b) -> s -> t
f (\i
i -> forall a. Identity' a -> a
unwrapIdentity' forall b c a. (b -> c) -> (a -> b) -> a -> c
. j -> a -> Identity' b
k (i -> j
ij i
i))
wrapIdentity' :: a -> Identity' a
wrapIdentity' :: forall a. a -> Identity' a
wrapIdentity' a
a = forall a. () -> a -> Identity' a
Identity' (a
a seq :: forall a b. a -> b -> b
`seq` ()) a
a
unwrapIdentity' :: Identity' a -> a
unwrapIdentity' :: forall a. Identity' a -> a
unwrapIdentity' (Identity' () a
a) = a
a
newtype Traversed f a = Traversed (f a)
runTraversed :: Functor f => Traversed f a -> f ()
runTraversed :: forall (f :: * -> *) a. Functor f => Traversed f a -> f ()
runTraversed (Traversed f a
fa) = () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f a
fa
instance Applicative f => SG.Semigroup (Traversed f a) where
Traversed f a
ma <> :: Traversed f a -> Traversed f a -> Traversed f a
<> Traversed f a
mb = forall (f :: * -> *) a. f a -> Traversed f a
Traversed (f a
ma forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> f a
mb)
instance Applicative f => Monoid (Traversed f a) where
mempty :: Traversed f a
mempty = forall (f :: * -> *) a. f a -> Traversed f a
Traversed (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. HasCallStack => [Char] -> a
error [Char]
"Traversed: value used"))
mappend :: Traversed f a -> Traversed f a -> Traversed f a
mappend = forall a. Semigroup a => a -> a -> a
(SG.<>)
data OrT f a = OrT !Bool (f a)
deriving forall a b. a -> OrT f b -> OrT f a
forall a b. (a -> b) -> OrT f a -> OrT f b
forall (f :: * -> *) a b. Functor f => a -> OrT f b -> OrT f a
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> OrT f a -> OrT f b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> OrT f b -> OrT f a
$c<$ :: forall (f :: * -> *) a b. Functor f => a -> OrT f b -> OrT f a
fmap :: forall a b. (a -> b) -> OrT f a -> OrT f b
$cfmap :: forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> OrT f a -> OrT f b
Functor
instance Applicative f => Applicative (OrT f) where
pure :: forall a. a -> OrT f a
pure = forall (f :: * -> *) a. Bool -> f a -> OrT f a
OrT Bool
False forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
OrT Bool
a f (a -> b)
f <*> :: forall a b. OrT f (a -> b) -> OrT f a -> OrT f b
<*> OrT Bool
b f a
x = forall (f :: * -> *) a. Bool -> f a -> OrT f a
OrT (Bool
a Bool -> Bool -> Bool
|| Bool
b) (f (a -> b)
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f a
x)
wrapOrT :: f a -> OrT f a
wrapOrT :: forall (f :: * -> *) a. f a -> OrT f a
wrapOrT = forall (f :: * -> *) a. Bool -> f a -> OrT f a
OrT Bool
True
uncurry' :: (a -> b -> c) -> (a, b) -> c
uncurry' :: forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry' a -> b -> c
f (a
a, b
b) = a -> b -> c
f a
a b
b