{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE LinearTypes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_HADDOCK hide #-}

module Control.Optics.Linear.Internal
  ( -- * Types
    Optic_ (..),
    Optic,
    Iso,
    Iso',
    Lens,
    Lens',
    Prism,
    Prism',
    Traversal,
    Traversal',

    -- * Composing optics
    (.>),

    -- * Common optics
    swap,
    assoc,
    _1,
    _2,
    _Left,
    _Right,
    _Just,
    _Nothing,
    traversed,

    -- * Using optics
    get,
    set,
    gets,
    setSwap,
    match,
    build,
    over,
    overU,
    traverseOf,
    traverseOfU,
    toListOf,
    lengthOf,
    reifyLens,
    withIso,
    withLens,
    withPrism,

    -- * Constructing optics
    iso,
    lens,
    prism,
    traversal,
  )
where

import qualified Control.Arrow as NonLinear
import qualified Control.Functor.Linear as Control
import Data.Bifunctor.Linear (SymmetricMonoidal)
import qualified Data.Bifunctor.Linear as Bifunctor
import Data.Functor.Compose hiding (getCompose)
import Data.Functor.Linear
import qualified Data.Profunctor.Kleisli.Linear as Linear
import Data.Profunctor.Linear
import Data.Void
import GHC.Exts (FUN)
import GHC.Types
import Prelude.Linear
import qualified Prelude

newtype Optic_ arr s t a b = Optical (a `arr` b -> s `arr` t)

type Optic c s t a b =
  forall arr. c arr => Optic_ arr s t a b

type Iso s t a b = Optic Profunctor s t a b

type Iso' s a = Iso s s a a

type Lens s t a b = Optic (Strong (,) ()) s t a b

type Lens' s a = Lens s s a a

type Prism s t a b = Optic (Strong Either Void) s t a b

type Prism' s a = Prism s s a a

type Traversal s t a b = Optic Wandering s t a b

type Traversal' s a = Traversal s s a a

swap :: SymmetricMonoidal m u => Iso (a `m` b) (c `m` d) (b `m` a) (d `m` c)
swap :: forall (m :: * -> * -> *) u a b c d.
SymmetricMonoidal m u =>
Iso (m a b) (m c d) (m b a) (m d c)
swap = forall s a b t. (s %1 -> a) -> (b %1 -> t) -> Iso s t a b
iso forall (m :: * -> * -> *) u a b.
SymmetricMonoidal m u =>
m a b %1 -> m b a
Bifunctor.swap forall (m :: * -> * -> *) u a b.
SymmetricMonoidal m u =>
m a b %1 -> m b a
Bifunctor.swap

assoc :: SymmetricMonoidal m u => Iso (a `m` (b `m` c)) (d `m` (e `m` f)) ((a `m` b) `m` c) ((d `m` e) `m` f)
assoc :: forall (m :: * -> * -> *) u a b c d e f.
SymmetricMonoidal m u =>
Iso (m a (m b c)) (m d (m e f)) (m (m a b) c) (m (m d e) f)
assoc = forall s a b t. (s %1 -> a) -> (b %1 -> t) -> Iso s t a b
iso forall (m :: * -> * -> *) u a b c.
SymmetricMonoidal m u =>
m a (m b c) %1 -> m (m a b) c
Bifunctor.lassoc forall (m :: * -> * -> *) u a b c.
SymmetricMonoidal m u =>
m (m a b) c %1 -> m a (m b c)
Bifunctor.rassoc

(.>) :: Optic_ arr s t a b -> Optic_ arr a b x y -> Optic_ arr s t x y
Optical arr a b -> arr s t
f .> :: forall (arr :: * -> * -> *) s t a b x y.
Optic_ arr s t a b -> Optic_ arr a b x y -> Optic_ arr s t x y
.> Optical arr x y -> arr a b
g = forall (arr :: * -> * -> *) s t a b.
(arr a b -> arr s t) -> Optic_ arr s t a b
Optical (arr a b -> arr s t
f forall b c a. (b -> c) -> (a -> b) -> a -> c
Prelude.. arr x y -> arr a b
g)

infixr 9 .> -- same fixity as lens..>

lens :: (s %1 -> (a, b %1 -> t)) -> Lens s t a b
lens :: forall s a b t. (s %1 -> (a, b %1 -> t)) -> Lens s t a b
lens s %1 -> (a, b %1 -> t)
k = forall (arr :: * -> * -> *) s t a b.
(arr a b -> arr s t) -> Optic_ arr s t a b
Optical forall a b (p :: Multiplicity) (q :: Multiplicity).
(a %p -> b) %q -> a %p -> b
$ \arr a b
f -> forall (arr :: * -> * -> *) s a b t.
Profunctor arr =>
(s %1 -> a) -> (b %1 -> t) -> arr a b -> arr s t
dimap s %1 -> (a, b %1 -> t)
k (\(b
x, b %1 -> t
g) -> b %1 -> t
g forall a b (p :: Multiplicity) (q :: Multiplicity).
(a %p -> b) %q -> a %p -> b
$ b
x) (forall (m :: * -> * -> *) u (arr :: * -> * -> *) a b c.
Strong m u arr =>
arr a b -> arr (m a c) (m b c)
first arr a b
f)

prism :: (b %1 -> t) -> (s %1 -> Either t a) -> Prism s t a b
prism :: forall b t s a.
(b %1 -> t) -> (s %1 -> Either t a) -> Prism s t a b
prism b %1 -> t
b s %1 -> Either t a
s = forall (arr :: * -> * -> *) s t a b.
(arr a b -> arr s t) -> Optic_ arr s t a b
Optical forall a b (p :: Multiplicity) (q :: Multiplicity).
(a %p -> b) %q -> a %p -> b
$ \arr a b
f -> forall (arr :: * -> * -> *) s a b t.
Profunctor arr =>
(s %1 -> a) -> (b %1 -> t) -> arr a b -> arr s t
dimap s %1 -> Either t a
s (forall a c b. (a %1 -> c) -> (b %1 -> c) -> Either a b %1 -> c
either forall a (q :: Multiplicity). a %q -> a
id forall a (q :: Multiplicity). a %q -> a
id) (forall (m :: * -> * -> *) u (arr :: * -> * -> *) b c a.
Strong m u arr =>
arr b c -> arr (m a b) (m a c)
second (forall (arr :: * -> * -> *) b t s.
Profunctor arr =>
(b %1 -> t) -> arr s b -> arr s t
rmap b %1 -> t
b arr a b
f))

traversal :: (forall f. Control.Applicative f => (a %1 -> f b) -> s %1 -> f t) -> Traversal s t a b
traversal :: forall a b s t.
(forall (f :: * -> *).
 Applicative f =>
 (a %1 -> f b) -> s %1 -> f t)
-> Traversal s t a b
traversal forall (f :: * -> *). Applicative f => (a %1 -> f b) -> s %1 -> f t
trav = forall (arr :: * -> * -> *) s t a b.
(arr a b -> arr s t) -> Optic_ arr s t a b
Optical forall a b (p :: Multiplicity) (q :: Multiplicity).
(a %p -> b) %q -> a %p -> b
$ forall (arr :: * -> * -> *) s t a b.
Wandering arr =>
(forall (f :: * -> *).
 Applicative f =>
 (a %1 -> f b) -> s %1 -> f t)
-> arr a b -> arr s t
wander forall (f :: * -> *). Applicative f => (a %1 -> f b) -> s %1 -> f t
trav

_1 :: Lens (a, c) (b, c) a b
_1 :: forall a c b. Lens (a, c) (b, c) a b
_1 = forall (arr :: * -> * -> *) s t a b.
(arr a b -> arr s t) -> Optic_ arr s t a b
Optical forall (m :: * -> * -> *) u (arr :: * -> * -> *) a b c.
Strong m u arr =>
arr a b -> arr (m a c) (m b c)
first

_2 :: Lens (c, a) (c, b) a b
_2 :: forall c a b. Lens (c, a) (c, b) a b
_2 = forall (arr :: * -> * -> *) s t a b.
(arr a b -> arr s t) -> Optic_ arr s t a b
Optical forall (m :: * -> * -> *) u (arr :: * -> * -> *) b c a.
Strong m u arr =>
arr b c -> arr (m a b) (m a c)
second

_Left :: Prism (Either a c) (Either b c) a b
_Left :: forall a c b. Prism (Either a c) (Either b c) a b
_Left = forall (arr :: * -> * -> *) s t a b.
(arr a b -> arr s t) -> Optic_ arr s t a b
Optical forall (m :: * -> * -> *) u (arr :: * -> * -> *) a b c.
Strong m u arr =>
arr a b -> arr (m a c) (m b c)
first

_Right :: Prism (Either c a) (Either c b) a b
_Right :: forall c a b. Prism (Either c a) (Either c b) a b
_Right = forall (arr :: * -> * -> *) s t a b.
(arr a b -> arr s t) -> Optic_ arr s t a b
Optical forall (m :: * -> * -> *) u (arr :: * -> * -> *) b c a.
Strong m u arr =>
arr b c -> arr (m a b) (m a c)
second

_Just :: Prism (Maybe a) (Maybe b) a b
_Just :: forall a b. Prism (Maybe a) (Maybe b) a b
_Just = forall b t s a.
(b %1 -> t) -> (s %1 -> Either t a) -> Prism s t a b
prism forall a. a -> Maybe a
Just (forall b a. b -> (a %1 -> b) -> Maybe a %1 -> b
maybe (forall a b. a -> Either a b
Left forall a. Maybe a
Nothing) forall a b. b -> Either a b
Right)

_Nothing :: Prism' (Maybe a) ()
_Nothing :: forall a. Prism' (Maybe a) ()
_Nothing = forall b t s a.
(b %1 -> t) -> (s %1 -> Either t a) -> Prism s t a b
prism (\() -> forall a. Maybe a
Nothing) forall a b. a -> Either a b
Left

traversed :: Traversable t => Traversal (t a) (t b) a b
traversed :: forall (t :: * -> *) a b.
Traversable t =>
Traversal (t a) (t b) a b
traversed = forall (arr :: * -> * -> *) s t a b.
(arr a b -> arr s t) -> Optic_ arr s t a b
Optical forall a b (p :: Multiplicity) (q :: Multiplicity).
(a %p -> b) %q -> a %p -> b
$ forall (arr :: * -> * -> *) s t a b.
Wandering arr =>
(forall (f :: * -> *).
 Applicative f =>
 (a %1 -> f b) -> s %1 -> f t)
-> arr a b -> arr s t
wander forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a %1 -> f b) -> t a %1 -> f (t b)
traverse

over :: Optic_ (FUN 'One) s t a b -> (a %1 -> b) -> s %1 -> t
over :: forall s t a b.
Optic_ (FUN 'One) s t a b -> (a %1 -> b) -> s %1 -> t
over (Optical (a %1 -> b) -> s %1 -> t
l) a %1 -> b
f = (a %1 -> b) -> s %1 -> t
l a %1 -> b
f

traverseOf :: Optic_ (Linear.Kleisli f) s t a b -> (a %1 -> f b) -> s %1 -> f t
traverseOf :: forall (f :: * -> *) s t a b.
Optic_ (Kleisli f) s t a b -> (a %1 -> f b) -> s %1 -> f t
traverseOf (Optical Kleisli f a b -> Kleisli f s t
l) a %1 -> f b
f = forall (m :: * -> *) a b. Kleisli m a b -> a %1 -> m b
Linear.runKleisli (Kleisli f a b -> Kleisli f s t
l (forall (m :: * -> *) a b. (a %1 -> m b) -> Kleisli m a b
Linear.Kleisli a %1 -> f b
f))

toListOf :: Optic_ (NonLinear.Kleisli (Const [a])) s t a b -> s -> [a]
toListOf :: forall a s t b. Optic_ (Kleisli (Const [a])) s t a b -> s -> [a]
toListOf Optic_ (Kleisli (Const [a])) s t a b
l = forall r s t a b.
Optic_ (Kleisli (Const r)) s t a b -> (a -> r) -> s -> r
gets Optic_ (Kleisli (Const [a])) s t a b
l (\a
a -> [a
a])

get :: Optic_ (NonLinear.Kleisli (Const a)) s t a b -> s -> a
get :: forall a s t b. Optic_ (Kleisli (Const a)) s t a b -> s -> a
get Optic_ (Kleisli (Const a)) s t a b
l = forall r s t a b.
Optic_ (Kleisli (Const r)) s t a b -> (a -> r) -> s -> r
gets Optic_ (Kleisli (Const a)) s t a b
l forall a. a -> a
Prelude.id

gets :: Optic_ (NonLinear.Kleisli (Const r)) s t a b -> (a -> r) -> s -> r
gets :: forall r s t a b.
Optic_ (Kleisli (Const r)) s t a b -> (a -> r) -> s -> r
gets (Optical Kleisli (Const r) a b -> Kleisli (Const r) s t
l) a -> r
f s
s = forall a b. Const a b %1 -> a
getConst' (forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
NonLinear.runKleisli (Kleisli (Const r) a b -> Kleisli (Const r) s t
l (forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
NonLinear.Kleisli (forall {k} a (b :: k). a -> Const a b
Const forall b c a. (b -> c) -> (a -> b) -> a -> c
Prelude.. a -> r
f))) s
s)

set :: Optic_ (->) s t a b -> b -> s -> t
set :: forall s t a b. Optic_ (->) s t a b -> b -> s -> t
set (Optical (a -> b) -> s -> t
l) b
x = (a -> b) -> s -> t
l (forall a b (q :: Multiplicity). a %q -> b -> a
const b
x)

setSwap :: Optic_ (Linear.Kleisli (Compose (FUN 'One b) ((,) a))) s t a b -> s %1 -> b %1 -> (a, t)
setSwap :: forall b a s t.
Optic_ (Kleisli (Compose (FUN 'One b) ((,) a))) s t a b
-> s %1 -> b %1 -> (a, t)
setSwap (Optical Kleisli (Compose (FUN 'One b) ((,) a)) a b
-> Kleisli (Compose (FUN 'One b) ((,) a)) s t
l) s
s = forall (f :: * -> *) (g :: * -> *) a. Compose f g a %1 -> f (g a)
getCompose (forall (m :: * -> *) a b. Kleisli m a b -> a %1 -> m b
Linear.runKleisli (Kleisli (Compose (FUN 'One b) ((,) a)) a b
-> Kleisli (Compose (FUN 'One b) ((,) a)) s t
l (forall (m :: * -> *) a b. (a %1 -> m b) -> Kleisli m a b
Linear.Kleisli (\a
a -> forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (\b
b -> (a
a, b
b))))) s
s)

match :: Optic_ (Market a b) s t a b -> s %1 -> Either t a
match :: forall a b s t. Optic_ (Market a b) s t a b -> s %1 -> Either t a
match (Optical Market a b a b -> Market a b s t
l) = forall a b. (a, b) -> b
Prelude.snd (forall a b s t.
Market a b s t %1 -> (b %1 -> t, s %1 -> Either t a)
runMarket (Market a b a b -> Market a b s t
l (forall a b s t.
(b %1 -> t) -> (s %1 -> Either t a) -> Market a b s t
Market forall a (q :: Multiplicity). a %q -> a
id forall a b. b -> Either a b
Right)))

build :: Optic_ (Linear.CoKleisli (Const b)) s t a b -> b %1 -> t
build :: forall b s t a. Optic_ (CoKleisli (Const b)) s t a b -> b %1 -> t
build (Optical CoKleisli (Const b) a b -> CoKleisli (Const b) s t
l) b
x = forall (w :: * -> *) a b. CoKleisli w a b -> w a %1 -> b
Linear.runCoKleisli (CoKleisli (Const b) a b -> CoKleisli (Const b) s t
l (forall (w :: * -> *) a b. (w a %1 -> b) -> CoKleisli w a b
Linear.CoKleisli forall a b. Const a b %1 -> a
getConst')) (forall {k} a (b :: k). a -> Const a b
Const b
x)

-- XXX: move this to Prelude

-- | Linearly typed patch for the newtype deconstructor. (Temporary until
-- inference will get this from the newtype declaration.)
getConst' :: Const a b %1 -> a
getConst' :: forall a b. Const a b %1 -> a
getConst' (Const a
x) = a
x

lengthOf :: MultIdentity r => Optic_ (NonLinear.Kleisli (Const (Sum r))) s t a b -> s -> r
lengthOf :: forall r s t a b.
MultIdentity r =>
Optic_ (Kleisli (Const (Sum r))) s t a b -> s -> r
lengthOf Optic_ (Kleisli (Const (Sum r))) s t a b
l s
s =
  (forall r s t a b.
Optic_ (Kleisli (Const r)) s t a b -> (a -> r) -> s -> r
gets Optic_ (Kleisli (Const (Sum r))) s t a b
l (forall a b (q :: Multiplicity). a %q -> b -> a
const (forall a. a -> Sum a
Sum forall a. MultIdentity a => a
one)) s
s) forall a b (p :: Multiplicity) (q :: Multiplicity).
a %p -> (a %p -> b) %q -> b
& \case
    Sum r
r -> r
r

-- XXX: the below two functions will be made redundant with multiplicity
-- polymorphism on over and traverseOfU
overU :: Optic_ (->) s t a b -> (a -> b) -> s -> t
overU :: forall s t a b. Optic_ (->) s t a b -> (a -> b) -> s -> t
overU (Optical (a -> b) -> s -> t
l) a -> b
f = (a -> b) -> s -> t
l a -> b
f

traverseOfU :: Optic_ (NonLinear.Kleisli f) s t a b -> (a -> f b) -> s -> f t
traverseOfU :: forall (f :: * -> *) s t a b.
Optic_ (Kleisli f) s t a b -> (a -> f b) -> s -> f t
traverseOfU (Optical Kleisli f a b -> Kleisli f s t
l) a -> f b
f = forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
NonLinear.runKleisli (Kleisli f a b -> Kleisli f s t
l (forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
NonLinear.Kleisli a -> f b
f))

iso :: (s %1 -> a) -> (b %1 -> t) -> Iso s t a b
iso :: forall s a b t. (s %1 -> a) -> (b %1 -> t) -> Iso s t a b
iso s %1 -> a
f b %1 -> t
g = forall (arr :: * -> * -> *) s t a b.
(arr a b -> arr s t) -> Optic_ arr s t a b
Optical (forall (arr :: * -> * -> *) s a b t.
Profunctor arr =>
(s %1 -> a) -> (b %1 -> t) -> arr a b -> arr s t
dimap s %1 -> a
f b %1 -> t
g)

withIso :: Optic_ (Exchange a b) s t a b -> ((s %1 -> a) -> (b %1 -> t) -> r) -> r
withIso :: forall a b s t r.
Optic_ (Exchange a b) s t a b
-> ((s %1 -> a) -> (b %1 -> t) -> r) -> r
withIso (Optical Exchange a b a b -> Exchange a b s t
l) (s %1 -> a) -> (b %1 -> t) -> r
f = (s %1 -> a) -> (b %1 -> t) -> r
f s %1 -> a
fro b %1 -> t
to
  where
    Exchange s %1 -> a
fro b %1 -> t
to = Exchange a b a b -> Exchange a b s t
l (forall a b s t. (s %1 -> a) -> (b %1 -> t) -> Exchange a b s t
Exchange forall a (q :: Multiplicity). a %q -> a
id forall a (q :: Multiplicity). a %q -> a
id)

withPrism :: Optic_ (Market a b) s t a b -> ((b %1 -> t) -> (s %1 -> Either t a) -> r) -> r
withPrism :: forall a b s t r.
Optic_ (Market a b) s t a b
-> ((b %1 -> t) -> (s %1 -> Either t a) -> r) -> r
withPrism (Optical Market a b a b -> Market a b s t
l) (b %1 -> t) -> (s %1 -> Either t a) -> r
f = (b %1 -> t) -> (s %1 -> Either t a) -> r
f b %1 -> t
b s %1 -> Either t a
m
  where
    Market b %1 -> t
b s %1 -> Either t a
m = Market a b a b -> Market a b s t
l (forall a b s t.
(b %1 -> t) -> (s %1 -> Either t a) -> Market a b s t
Market forall a (q :: Multiplicity). a %q -> a
id forall a b. b -> Either a b
Right)

-- XXX: probably a direct implementation would be better
withLens ::
  Optic_ (Linear.Kleisli (Compose ((,) a) (FUN 'One b))) s t a b ->
  (forall c. (s %1 -> (c, a)) -> ((c, b) %1 -> t) -> r) ->
  r
withLens :: forall a b s t r.
Optic_ (Kleisli (Compose ((,) a) (FUN 'One b))) s t a b
-> (forall c. (s %1 -> (c, a)) -> ((c, b) %1 -> t) -> r) -> r
withLens Optic_ (Kleisli (Compose ((,) a) (FUN 'One b))) s t a b
l forall c. (s %1 -> (c, a)) -> ((c, b) %1 -> t) -> r
k = forall c. (s %1 -> (c, a)) -> ((c, b) %1 -> t) -> r
k (forall (m :: * -> * -> *) u a b.
SymmetricMonoidal m u =>
m a b %1 -> m b a
Bifunctor.swap forall b c a (q :: Multiplicity) (m :: Multiplicity)
       (n :: Multiplicity).
(b %1 -> c) %q -> (a %1 -> b) %m -> a %n -> c
. (forall a b s t.
Optic_ (Kleisli (Compose ((,) a) (FUN 'One b))) s t a b
-> s %1 -> (a, b %1 -> t)
reifyLens Optic_ (Kleisli (Compose ((,) a) (FUN 'One b))) s t a b
l)) (forall a b c (p :: Multiplicity) (q :: Multiplicity).
(a %p -> b %p -> c) %q -> (a, b) %p -> c
uncurry forall a b (p :: Multiplicity) (q :: Multiplicity).
(a %p -> b) %q -> a %p -> b
($))

reifyLens :: Optic_ (Linear.Kleisli (Compose ((,) a) (FUN 'One b))) s t a b -> s %1 -> (a, b %1 -> t)
reifyLens :: forall a b s t.
Optic_ (Kleisli (Compose ((,) a) (FUN 'One b))) s t a b
-> s %1 -> (a, b %1 -> t)
reifyLens (Optical Kleisli (Compose ((,) a) (FUN 'One b)) a b
-> Kleisli (Compose ((,) a) (FUN 'One b)) s t
l) s
s = forall (f :: * -> *) (g :: * -> *) a. Compose f g a %1 -> f (g a)
getCompose (forall (m :: * -> *) a b. Kleisli m a b -> a %1 -> m b
Linear.runKleisli (Kleisli (Compose ((,) a) (FUN 'One b)) a b
-> Kleisli (Compose ((,) a) (FUN 'One b)) s t
l (forall (m :: * -> *) a b. (a %1 -> m b) -> Kleisli m a b
Linear.Kleisli (\a
a -> forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (a
a, forall a (q :: Multiplicity). a %q -> a
id)))) s
s)

-- linear variant of getCompose
getCompose :: Compose f g a %1 -> f (g a)
getCompose :: forall (f :: * -> *) (g :: * -> *) a. Compose f g a %1 -> f (g a)
getCompose (Compose f (g a)
x) = f (g a)
x