content: {-# 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 = iso Bifunctor.swap 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 = iso Bifunctor.lassoc Bifunctor.rassoc
  
  (.>) :: Optic_ arr s t a b -> Optic_ arr a b x y -> Optic_ arr s t x y
  Optical f .> Optical g = Optical (f Prelude.. g)
  
  infixr 9 .> -- same fixity as lens..>
  
  lens :: (s %1 -> (a, b %1 -> t)) -> Lens s t a b
  lens k = Optical $ \f -> dimap k (\(x, g) -> g $ x) (first f)
  
  prism :: (b %1 -> t) -> (s %1 -> Either t a) -> Prism s t a b
  prism b s = Optical $ \f -> dimap s (either id id) (second (rmap b f))
  
  traversal :: (forall f. (Control.Applicative f) => (a %1 -> f b) -> s %1 -> f t) -> Traversal s t a b
  traversal trav = Optical $ wander trav
  
  _1 :: Lens (a, c) (b, c) a b
  _1 = Optical first
  
  _2 :: Lens (c, a) (c, b) a b
  _2 = Optical second
  
  _Left :: Prism (Either a c) (Either b c) a b
  _Left = Optical first
  
  _Right :: Prism (Either c a) (Either c b) a b
  _Right = Optical second
  
  _Just :: Prism (Maybe a) (Maybe b) a b
  _Just = prism Just (maybe (Left Nothing) Right)
  
  _Nothing :: Prism' (Maybe a) ()
  _Nothing = prism (\() -> Nothing) Left
  
  traversed :: (Traversable t) => Traversal (t a) (t b) a b
  traversed = Optical $ wander traverse
  
  over :: Optic_ (FUN 'One) s t a b -> (a %1 -> b) -> s %1 -> t
  over (Optical l) f = l f
  
  traverseOf :: Optic_ (Linear.Kleisli f) s t a b -> (a %1 -> f b) -> s %1 -> f t
  traverseOf (Optical l) f = Linear.runKleisli (l (Linear.Kleisli f))
  
  toListOf :: Optic_ (NonLinear.Kleisli (Const [a])) s t a b -> s -> [a]
  toListOf l = gets l (\a -> [a])
  
  get :: Optic_ (NonLinear.Kleisli (Const a)) s t a b -> s -> a
  get l = gets l Prelude.id
  
  gets :: Optic_ (NonLinear.Kleisli (Const r)) s t a b -> (a -> r) -> s -> r
  gets (Optical l) f s = getConst' (NonLinear.runKleisli (l (NonLinear.Kleisli (Const Prelude.. f))) s)
  
  set :: Optic_ (->) s t a b -> b -> s -> t
  set (Optical l) x = l (const x)
  
  setSwap :: Optic_ (Linear.Kleisli (Compose (FUN 'One b) ((,) a))) s t a b -> s %1 -> b %1 -> (a, t)
  setSwap (Optical l) s = getCompose (Linear.runKleisli (l (Linear.Kleisli (\a -> Compose (\b -> (a, b))))) s)
  
  match :: Optic_ (Market a b) s t a b -> s %1 -> Either t a
  match (Optical l) = Prelude.snd (runMarket (l (Market id Right)))
  
  build :: Optic_ (Linear.CoKleisli (Const b)) s t a b -> b %1 -> t
  build (Optical l) x = Linear.runCoKleisli (l (Linear.CoKleisli getConst')) (Const 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' (Const x) = x
  
  lengthOf :: (MultIdentity r) => Optic_ (NonLinear.Kleisli (Const (Sum r))) s t a b -> s -> r
  lengthOf l s =
    case gets l (const (Sum one)) s of
      Sum 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 (Optical l) f = l f
  
  traverseOfU :: Optic_ (NonLinear.Kleisli f) s t a b -> (a -> f b) -> s -> f t
  traverseOfU (Optical l) f = NonLinear.runKleisli (l (NonLinear.Kleisli f))
  
  iso :: (s %1 -> a) -> (b %1 -> t) -> Iso s t a b
  iso f g = Optical (dimap f g)
  
  withIso :: Optic_ (Exchange a b) s t a b -> ((s %1 -> a) -> (b %1 -> t) -> r) -> r
  withIso (Optical l) f = f fro to
    where
      Exchange fro to = l (Exchange id id)
  
  withPrism :: Optic_ (Market a b) s t a b -> ((b %1 -> t) -> (s %1 -> Either t a) -> r) -> r
  withPrism (Optical l) f = f b m
    where
      Market b m = l (Market id 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 l k = k (Bifunctor.swap . (reifyLens l)) (uncurry ($))
  
  reifyLens :: Optic_ (Linear.Kleisli (Compose ((,) a) (FUN 'One b))) s t a b -> s %1 -> (a, b %1 -> t)
  reifyLens (Optical l) s = getCompose (Linear.runKleisli (l (Linear.Kleisli (\a -> Compose (a, id)))) s)
  
  -- linear variant of getCompose
  getCompose :: Compose f g a %1 -> f (g a)
  getCompose (Compose x) = x
  