{-# LANGUAGE RankNTypes #-}

-- | This module provides very basic lens functionality, without extra dependencies.
--
-- For the documentation of the combinators see <http://hackage.haskell.org/package/lens lens> package.
-- This module uses the same vocabulary.
module Distribution.Compat.Lens
  ( -- * Types
    Lens
  , Lens'
  , Traversal
  , Traversal'

    -- ** LensLike
  , LensLike
  , LensLike'

    -- ** rank-1 types
  , Getting
  , AGetter
  , ASetter
  , ALens
  , ALens'

    -- * Getter
  , view
  , use
  , getting

    -- * Setter
  , set
  , over

    -- * Fold
  , toDListOf
  , toListOf
  , toSetOf

    -- * Lens
  , cloneLens
  , aview

    -- * Common lenses
  , _1
  , _2

    -- * Operators
  , (&)
  , (^.)
  , (.~)
  , (?~)
  , (%~)
  , (.=)
  , (?=)
  , (%=)
  , (^#)
  , (#~)
  , (#%~)

    -- * Internal Comonads
  , Pretext (..)

    -- * Cabal developer info
    -- $development
  ) where

import Distribution.Compat.Prelude
import Prelude ()

import Control.Monad.State.Class (MonadState (..), gets, modify)

import qualified Data.Set as Set
import qualified Distribution.Compat.DList as DList

-------------------------------------------------------------------------------
-- Types
-------------------------------------------------------------------------------

type LensLike f s t a b = (a -> f b) -> s -> f t
type LensLike' f s a = (a -> f a) -> s -> f s

type Lens s t a b = forall f. Functor f => LensLike f s t a b
type Traversal s t a b = forall f. Applicative f => LensLike f s t a b

type Lens' s a = Lens s s a a
type Traversal' s a = Traversal s s a a

type Getting r s a = LensLike (Const r) s s a a

type AGetter s a = LensLike (Const a) s s a a -- this doesn't exist in 'lens'
type ASetter s t a b = LensLike Identity s t a b
type ALens s t a b = LensLike (Pretext a b) s t a b

type ALens' s a = ALens s s a a

-------------------------------------------------------------------------------
-- Getter
-------------------------------------------------------------------------------

view :: Getting a s a -> s -> a
view :: forall a s. Getting a s a -> s -> a
view Getting a s a
l s
s = Const a s -> a
forall {k} a (b :: k). Const a b -> a
getConst (Getting a s a
l a -> Const a a
forall {k} a (b :: k). a -> Const a b
Const s
s)
{-# INLINE view #-}

use :: MonadState s m => Getting a s a -> m a
use :: forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting a s a
l = (s -> a) -> m a
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Getting a s a -> s -> a
forall a s. Getting a s a -> s -> a
view Getting a s a
l)
{-# INLINE use #-}

-- | @since 2.4
--
-- >>> (3 :: Int) ^. getting (+2) . getting show
-- "5"
getting :: (s -> a) -> Getting r s a
getting :: forall s a r. (s -> a) -> Getting r s a
getting s -> a
k a -> Const r a
f = r -> Const r s
forall {k} a (b :: k). a -> Const a b
Const (r -> Const r s) -> (s -> r) -> s -> Const r s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const r a -> r
forall {k} a (b :: k). Const a b -> a
getConst (Const r a -> r) -> (s -> Const r a) -> s -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Const r a
f (a -> Const r a) -> (s -> a) -> s -> Const r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> a
k
{-# INLINE getting #-}

-------------------------------------------------------------------------------
-- Setter
-------------------------------------------------------------------------------

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
x = 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 (b -> a -> b
forall a b. a -> b -> a
const b
x)

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 (a -> b
f a
x)) s
s)

-------------------------------------------------------------------------------
-- Fold
-------------------------------------------------------------------------------

toDListOf :: Getting (DList.DList a) s a -> s -> DList.DList a
toDListOf :: forall a s. Getting (DList a) s a -> s -> DList a
toDListOf Getting (DList a) s a
l s
s = Const (DList a) s -> DList a
forall {k} a (b :: k). Const a b -> a
getConst (Getting (DList a) s a
l (\a
x -> DList a -> Const (DList a) a
forall {k} a (b :: k). a -> Const a b
Const (a -> DList a
forall a. a -> DList a
DList.singleton a
x)) s
s)

toListOf :: Getting (DList.DList a) s a -> s -> [a]
toListOf :: forall a s. Getting (DList a) s a -> s -> [a]
toListOf Getting (DList a) s a
l = DList a -> [a]
forall a. DList a -> [a]
DList.runDList (DList a -> [a]) -> (s -> DList a) -> s -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (DList a) s a -> s -> DList a
forall a s. Getting (DList a) s a -> s -> DList a
toDListOf Getting (DList a) s a
l

toSetOf :: Getting (Set.Set a) s a -> s -> Set.Set a
toSetOf :: forall a s. Getting (Set a) s a -> s -> Set a
toSetOf Getting (Set a) s a
l s
s = Const (Set a) s -> Set a
forall {k} a (b :: k). Const a b -> a
getConst (Getting (Set a) s a
l (\a
x -> Set a -> Const (Set a) a
forall {k} a (b :: k). a -> Const a b
Const (a -> Set a
forall a. a -> Set a
Set.singleton a
x)) s
s)

-------------------------------------------------------------------------------
-- Lens
-------------------------------------------------------------------------------

aview :: ALens s t a b -> s -> a
aview :: forall s t a b. ALens s t a b -> s -> a
aview ALens s t a b
l = Pretext a b t -> a
forall a b t. Pretext a b t -> a
pretextPos (Pretext a b t -> a) -> (s -> Pretext a b t) -> s -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ALens s t a b
l a -> Pretext a b b
forall a b. a -> Pretext a b b
pretextSell
{-# INLINE aview #-}

{-
lens :: (s -> a) -> (s -> a -> s) -> Lens' s a
lens sa sbt afb s = sbt s <$> afb (sa s)
-}

-------------------------------------------------------------------------------
-- Common
-------------------------------------------------------------------------------

_1 :: Lens (a, c) (b, c) a b
_1 :: forall a c b (f :: * -> *).
Functor f =>
LensLike f (a, c) (b, c) a b
_1 a -> f b
f (a
a, c
c) = (b -> c -> (b, c)) -> c -> b -> (b, c)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) c
c (b -> (b, c)) -> f b -> f (b, c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a

_2 :: Lens (c, a) (c, b) a b
_2 :: forall c a b (f :: * -> *).
Functor f =>
LensLike f (c, a) (c, b) a b
_2 a -> f b
f (c
c, a
a) = (,) c
c (b -> (c, b)) -> f b -> f (c, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a

-------------------------------------------------------------------------------
-- Operators
-------------------------------------------------------------------------------

-- | '&' is a reverse application operator
(&) :: a -> (a -> b) -> b
& :: forall a b. a -> (a -> b) -> b
(&) = ((a -> b) -> a -> b) -> a -> (a -> b) -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
($)
{-# INLINE (&) #-}

infixl 1 &

infixl 8 ^., ^#
infixr 4 .~, %~, ?~
infixr 4 #~, #%~
infixr 4 .=, %=, ?=

(^.) :: s -> Getting a s a -> a
s
s ^. :: forall s a. s -> Getting a s a -> a
^. Getting a s a
l = Const a s -> a
forall {k} a (b :: k). Const a b -> a
getConst (Getting a s a
l a -> Const a a
forall {k} a (b :: k). a -> Const a b
Const s
s)
{-# INLINE (^.) #-}

(.~) :: ASetter s t a b -> b -> s -> t
.~ :: forall s t a b. ASetter s t a b -> b -> s -> t
(.~) = ASetter s t a b -> b -> s -> t
forall s t a b. ASetter s t a b -> b -> s -> t
set
{-# INLINE (.~) #-}

(?~) :: ASetter s t a (Maybe b) -> b -> s -> t
ASetter s t a (Maybe b)
l ?~ :: forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ b
b = ASetter s t a (Maybe b) -> Maybe b -> s -> t
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter s t a (Maybe b)
l (b -> Maybe b
forall a. a -> Maybe a
Just b
b)
{-# INLINE (?~) #-}

(%~) :: 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
{-# INLINE (%~) #-}

(.=) :: 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
l ASetter s s a b -> b -> s -> s
forall s t a b. ASetter s t a b -> b -> s -> t
.~ b
b)
{-# INLINE (.=) #-}

(?=) :: MonadState s m => ASetter s s a (Maybe b) -> b -> m ()
ASetter s s a (Maybe b)
l ?= :: forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a (Maybe b) -> b -> m ()
?= b
b = (s -> s) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (ASetter s s a (Maybe b)
l ASetter s s a (Maybe b) -> b -> s -> s
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ b
b)
{-# INLINE (?=) #-}

(%=) :: 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
l ASetter s s a b -> (a -> b) -> s -> s
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ a -> b
f)
{-# INLINE (%=) #-}

(^#) :: s -> ALens s t a b -> a
s
s ^# :: forall s t a b. s -> ALens s t a b -> a
^# ALens s t a b
l = ALens s t a b -> s -> a
forall s t a b. ALens s t a b -> s -> a
aview ALens s t a b
l s
s

(#~) :: ALens s t a b -> b -> s -> t
#~ :: forall s t a b. ALens s t a b -> b -> s -> t
(#~) ALens s t a b
l b
b s
s = b -> Pretext a b t -> t
forall b a t. b -> Pretext a b t -> t
pretextPeek b
b (ALens s t a b
l a -> Pretext a b b
forall a b. a -> Pretext a b b
pretextSell s
s)
{-# INLINE (#~) #-}

(#%~) :: ALens s t a b -> (a -> b) -> s -> t
#%~ :: forall s t a b. ALens s t a b -> (a -> b) -> s -> t
(#%~) ALens s t a b
l a -> b
f s
s = (a -> b) -> Pretext a b t -> t
forall a b t. (a -> b) -> Pretext a b t -> t
pretextPeeks a -> b
f (ALens s t a b
l a -> Pretext a b b
forall a b. a -> Pretext a b b
pretextSell s
s)
{-# INLINE (#%~) #-}

pretextSell :: a -> Pretext a b b
pretextSell :: forall a b. a -> Pretext a b b
pretextSell a
a = (forall (f :: * -> *). Functor f => (a -> f b) -> f b)
-> Pretext a b b
forall a b t.
(forall (f :: * -> *). Functor f => (a -> f b) -> f t)
-> Pretext a b t
Pretext (\a -> f b
afb -> a -> f b
afb a
a)
{-# INLINE pretextSell #-}

pretextPeeks :: (a -> b) -> Pretext a b t -> t
pretextPeeks :: forall a b t. (a -> b) -> Pretext a b t -> t
pretextPeeks a -> b
f (Pretext forall (f :: * -> *). Functor f => (a -> f b) -> f t
m) = Identity t -> t
forall a. Identity a -> a
runIdentity (Identity t -> t) -> Identity t -> t
forall a b. (a -> b) -> a -> b
$ (a -> Identity b) -> Identity t
forall (f :: * -> *). Functor f => (a -> f b) -> f t
m (\a
x -> b -> Identity b
forall a. a -> Identity a
Identity (a -> b
f a
x))
{-# INLINE pretextPeeks #-}

pretextPeek :: b -> Pretext a b t -> t
pretextPeek :: forall b a t. b -> Pretext a b t -> t
pretextPeek b
b (Pretext forall (f :: * -> *). Functor f => (a -> f b) -> f t
m) = Identity t -> t
forall a. Identity a -> a
runIdentity (Identity t -> t) -> Identity t -> t
forall a b. (a -> b) -> a -> b
$ (a -> Identity b) -> Identity t
forall (f :: * -> *). Functor f => (a -> f b) -> f t
m (\a
_ -> b -> Identity b
forall a. a -> Identity a
Identity b
b)
{-# INLINE pretextPeek #-}

pretextPos :: Pretext a b t -> a
pretextPos :: forall a b t. Pretext a b t -> a
pretextPos (Pretext forall (f :: * -> *). Functor f => (a -> f b) -> f t
m) = Const a t -> a
forall {k} a (b :: k). Const a b -> a
getConst ((a -> Const a b) -> Const a t
forall (f :: * -> *). Functor f => (a -> f b) -> f t
m a -> Const a b
forall {k} a (b :: k). a -> Const a b
Const)
{-# INLINE pretextPos #-}

cloneLens :: Functor f => ALens s t a b -> LensLike f s t a b
cloneLens :: forall (f :: * -> *) s t a b.
Functor f =>
ALens s t a b -> LensLike f s t a b
cloneLens ALens s t a b
l a -> f b
f s
s = Pretext a b t
-> forall (f :: * -> *). Functor f => (a -> f b) -> f t
forall a b t.
Pretext a b t
-> forall (f :: * -> *). Functor f => (a -> f b) -> f t
runPretext (ALens s t a b
l a -> Pretext a b b
forall a b. a -> Pretext a b b
pretextSell s
s) a -> f b
f
{-# INLINE cloneLens #-}

-------------------------------------------------------------------------------
-- Comonads
-------------------------------------------------------------------------------

-- | @lens@ variant is also parametrised by profunctor.
data Pretext a b t = Pretext {forall a b t.
Pretext a b t
-> forall (f :: * -> *). Functor f => (a -> f b) -> f t
runPretext :: forall f. Functor f => (a -> f b) -> f t}

instance Functor (Pretext a b) where
  fmap :: forall a b. (a -> b) -> Pretext a b a -> Pretext a b b
fmap a -> b
f (Pretext forall (f :: * -> *). Functor f => (a -> f b) -> f a
pretext) = (forall (f :: * -> *). Functor f => (a -> f b) -> f b)
-> Pretext a b b
forall a b t.
(forall (f :: * -> *). Functor f => (a -> f b) -> f t)
-> Pretext a b t
Pretext (\a -> f b
afb -> (a -> b) -> f a -> f b
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f ((a -> f b) -> f a
forall (f :: * -> *). Functor f => (a -> f b) -> f a
pretext a -> f b
afb))

-------------------------------------------------------------------------------
-- Documentation
-------------------------------------------------------------------------------

-- $development
--
-- We cannot depend on @template-haskell@, because Cabal is a boot library.
-- This fact makes defining optics a manual task. Here is a small recipe to
-- make the process less tedious.
--
-- First start a repl
--
-- > cabal new-repl Cabal-tests:hackage-tests
--
-- Because @--extra-package@ isn't yet implemented, we use a test-suite
-- with @generics-sop@ dependency.
--
-- In the repl, we load a helper script:
--
-- > :l ../generics-sop-lens.hs
--
-- Now we are set up to derive lenses!
--
-- > :m +Distribution.Types.SourceRepo
-- > putStr $ genericLenses (Proxy :: Proxy SourceRepo)
--
-- @
-- repoKind :: Lens' SourceRepo RepoKind
-- repoKind f s = fmap (\\x -> s { T.repoKind = x }) (f (T.repoKind s))
-- \{-# INLINE repoKind #-\}
-- ...
-- @
--
-- /Note:/ You may need to adjust type-aliases, e.g. `String` to `FilePath`.