{-# OPTIONS_HADDOCK not-home #-}
{-# OPTIONS_GHC -Wunused-imports #-}

-- | Lenses and other optic-related functions.
module Mikan.Utils.Lens
  ( LensGet
  , LensSet
  , LensMap
  -- * Elementary lens operations
  , set'
  , over'
  , (%~!)
  -- * Reader/State accessors and modifiers
  , (.=!)
  , (%=!)
  , (%==)
  , (%==!)
  , (%%=!)
  , locallyState
  -- * Lenses for collections
  , key
  -- * Re-exports
  , module Control.Lens.Traversal
  , module Control.Lens.Getter
  , module Control.Lens.Setter
  , module Control.Lens.Tuple
  , module Control.Lens.Lens
  , module Control.Lens.Iso
  , module Control.Lens.At

  , (&&&)       -- reexported from Control.Arrow
  , lensProduct -- reexported from Control.Lens.Unsound
  ) where

import Control.Arrow       ( (&&&) )
import Control.Monad.State.Class (MonadState(..), modify, modify')

import Data.Map (Map)
import Data.Map qualified as Map
import Data.Functor.Identity

import Control.Lens.Setter hiding
  ( assign -- conflicts with metavariable assignment
  , set'   -- conflicts with strict version below
  )

import Control.Lens.Getter

import Control.Lens.Lens hiding
  ( Context, Context' -- conflicts with TC context
  , last1             -- conflicts
  )

import Control.Lens.Traversal hiding
  ( elements -- conflicts with Internal.Helpers.elements
  )
import Control.Lens.Tuple
import Control.Lens.Iso
import Control.Lens.At

import Control.Lens.Unsound

--------------------------------------------------------------------------------

-- | Van Laarhoven style homogeneous lenses.
-- Mnemonic: "Lens outer inner", same type argument order as @get :: o -> i@.
type LensGet o i = o -> i
type LensSet o i = i -> o -> o
type LensMap o i = (i -> i) -> o -> o

--------------------------------------------------------------------------------
-- Elementary lens operations

{-# INLINE set' #-}
-- | Strictly set inner part @i@ of structure @o@ as designated by @Lens' o i@.
set' :: ASetter s t a b -> b -> s -> t
set' :: forall s t a b. ASetter s t a b -> b -> s -> t
set' ASetter s t a b
l = \ !b
b -> ASetter s t a b -> (a -> b) -> s -> t
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter s t a b
l (\a
_ -> b
b)

{-# INLINE over' #-}
-- | Strictly modify inner part @i@ of structure @o@ using a function @i -> i@.
over' :: ASetter s t a b -> (a -> b) -> s -> t
over' :: forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over' ASetter s t a b
l = \a -> b
f s
s -> Identity t -> t
forall a. Identity a -> a
runIdentity (ASetter s t a b
l (\a
x -> b -> Identity b
forall a. a -> Identity a
Identity (b -> Identity b) -> b -> Identity b
forall a b. (a -> b) -> a -> b
$! a -> b
f a
x) s
s)

infixr 4 %~!
(%~!) :: ASetter s t a b -> (a -> b) -> s -> t
%~! :: forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
(%~!) = ASetter s t a b -> (a -> b) -> s -> t
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over'

--------------------------------------------------------------------------------
-- Reader/State accessors and modifiers

{-# INLINE (.=!) #-}
infix 4 .=!
-- | Strictly write a part of the state.
(.=!) :: MonadState s m => ASetter s s a b -> b -> m ()
ASetter s s a b
l .=! :: forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.=! b
b = (s -> s) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (ASetter s s a b -> b -> s -> s
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter s s a b
l b
b)

{-# INLINE (%=!) #-}
infix 4 %=!
-- | Strictly modify a part of the state.
(%=!) :: MonadState s m => ASetter s s a b -> (a -> b) -> m ()
ASetter s s a b
l %=! :: forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%=! a -> b
f = (s -> s) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (ASetter s s a b -> (a -> b) -> s -> s
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter s s a b
l a -> b
f)

{-# INLINE (%==) #-}
infix 4 %==
-- | Modify a part of the state monadically.
(%==) :: MonadState s m => Lens' s a -> (a -> m a) -> m ()
Lens' s a
l %== :: forall s (m :: * -> *) a.
MonadState s m =>
Lens' s a -> (a -> m a) -> m ()
%== a -> m a
f = do
  a <- Getting a s a -> m a
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting a s a
Lens' s a
l
  a <- f a
  modify (set l a)

{-# INLINE (%==!) #-}
infix 4 %==!
-- | Strictly modify a part of the state monadically.
(%==!) :: MonadState s m => Lens' s a -> (a -> m a) -> m ()
Lens' s a
l %==! :: forall s (m :: * -> *) a.
MonadState s m =>
Lens' s a -> (a -> m a) -> m ()
%==! a -> m a
f = do
  a <- Getting a s a -> m a
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting a s a
Lens' s a
l
  a <- f a
  modify' (set l a)

{-# INLINE (%%=!) #-}
infix 4 %%=!
-- | Strictly modify a part of the state monadically, and return some result.
(%%=!) :: MonadState o m => Lens' o i -> (i -> m (i, r)) -> m r
Lens' o i
l %%=! :: forall o (m :: * -> *) i r.
MonadState o m =>
Lens' o i -> (i -> m (i, r)) -> m r
%%=! i -> m (i, r)
f = do
  i <- Getting i o i -> m i
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting i o i
Lens' o i
l
  (!i', !r) <- f i
  l .= i'
  return r

{-# INLINE locallyState #-}
-- | Modify a part of the state locally.
locallyState :: MonadState o m => Lens' o i -> (i -> i) -> m r -> m r
locallyState :: forall o (m :: * -> *) i r.
MonadState o m =>
Lens' o i -> (i -> i) -> m r -> m r
locallyState Lens' o i
l i -> i
f m r
k = do
  old <- Getting i o i -> m i
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting i o i
Lens' o i
l
  l %= f
  x <- k
  l .= old
  return x

--------------------------------------------------------------------------------
-- Lenses for collections

{-# INLINE key #-}
-- | Access a map value at a given key.
key :: Ord k => k -> Lens' (Map k v) (Maybe v)
key :: forall k v. Ord k => k -> Lens' (Map k v) (Maybe v)
key k
k = \Maybe v -> f (Maybe v)
f Map k v
s -> (Maybe v -> f (Maybe v)) -> k -> Map k v -> f (Map k v)
forall (f :: * -> *) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
Map.alterF Maybe v -> f (Maybe v)
f k
k Map k v
s