{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RankNTypes #-}

module Calligraphy.Util.Lens
  ( Traversal,
    Traversal',
    over,
    forT_,
  )
where

import Data.Functor.Identity

type Traversal s t a b = forall m. Applicative m => (a -> m b) -> (s -> m t)

type Traversal' s a = Traversal s s a a

newtype ConstT m a = ConstT {ConstT m a -> m ()
unConstT :: m ()}
  deriving ((a -> b) -> ConstT m a -> ConstT m b
(forall a b. (a -> b) -> ConstT m a -> ConstT m b)
-> (forall a b. a -> ConstT m b -> ConstT m a)
-> Functor (ConstT m)
forall a b. a -> ConstT m b -> ConstT m a
forall a b. (a -> b) -> ConstT m a -> ConstT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (m :: * -> *) a b. a -> ConstT m b -> ConstT m a
forall (m :: * -> *) a b. (a -> b) -> ConstT m a -> ConstT m b
<$ :: a -> ConstT m b -> ConstT m a
$c<$ :: forall (m :: * -> *) a b. a -> ConstT m b -> ConstT m a
fmap :: (a -> b) -> ConstT m a -> ConstT m b
$cfmap :: forall (m :: * -> *) a b. (a -> b) -> ConstT m a -> ConstT m b
Functor)

instance Applicative m => Applicative (ConstT m) where
  {-# INLINE pure #-}
  pure :: a -> ConstT m a
pure a
_ = m () -> ConstT m a
forall (m :: * -> *) a. m () -> ConstT m a
ConstT (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  {-# INLINE (<*>) #-}
  ConstT m ()
mf <*> :: ConstT m (a -> b) -> ConstT m a -> ConstT m b
<*> ConstT m ()
ma = m () -> ConstT m b
forall (m :: * -> *) a. m () -> ConstT m a
ConstT (m ()
mf m () -> m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m ()
ma)

{-# INLINE over #-}
over :: Traversal s t a b -> (a -> b) -> (s -> t)
over :: Traversal s t a b -> (a -> b) -> s -> t
over Traversal s t a b
t a -> b
f = Identity t -> t
forall a. Identity a -> a
runIdentity (Identity t -> t) -> (s -> Identity t) -> s -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Identity b) -> s -> Identity t
Traversal s t a b
t (b -> Identity b
forall a. a -> Identity a
Identity (b -> Identity b) -> (a -> b) -> a -> Identity b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

{-# INLINE mapT_ #-}
mapT_ :: Applicative m => Traversal s t a b -> (a -> m ()) -> s -> m ()
mapT_ :: Traversal s t a b -> (a -> m ()) -> s -> m ()
mapT_ Traversal s t a b
t a -> m ()
f = ConstT m t -> m ()
forall (m :: * -> *) a. ConstT m a -> m ()
unConstT (ConstT m t -> m ()) -> (s -> ConstT m t) -> s -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> ConstT m b) -> s -> ConstT m t
Traversal s t a b
t (m () -> ConstT m b
forall (m :: * -> *) a. m () -> ConstT m a
ConstT (m () -> ConstT m b) -> (a -> m ()) -> a -> ConstT m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m ()
f)

{-# INLINE forT_ #-}
forT_ :: Applicative m => Traversal s t a b -> s -> (a -> m ()) -> m ()
forT_ :: Traversal s t a b -> s -> (a -> m ()) -> m ()
forT_ Traversal s t a b
t = ((a -> m ()) -> s -> m ()) -> s -> (a -> m ()) -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Traversal s t a b -> (a -> m ()) -> s -> m ()
forall (m :: * -> *) s t a b.
Applicative m =>
Traversal s t a b -> (a -> m ()) -> s -> m ()
mapT_ Traversal s t a b
t)