module Data.Lens.Light.Core
  ( Lens(..)
  , lens
  , iso
  , getL
  , setL
  , modL
  , modL'
  , (^.)
  , vanLaarhoven
  )
  where

import Prelude hiding (id, (.))
import Control.Category

-- | Simple lens data type
newtype Lens a b = Lens { Lens a b -> a -> (b -> a, b)
runLens :: a -> (b -> a, b) }

instance Category Lens where
  id :: Lens a a
id = (a -> a) -> (a -> a) -> Lens a a
forall a b. (a -> b) -> (b -> a) -> Lens a b
iso a -> a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id a -> a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
  Lens b c
x . :: Lens b c -> Lens a b -> Lens a c
. Lens a b
y =
    (a -> c) -> (c -> a -> a) -> Lens a c
forall a b. (a -> b) -> (b -> a -> a) -> Lens a b
lens
      (Lens b c -> b -> c
forall a b. Lens a b -> a -> b
getL Lens b c
x (b -> c) -> (a -> b) -> a -> c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Lens a b -> a -> b
forall a b. Lens a b -> a -> b
getL Lens a b
y)
      (\c
b -> Lens a b -> (b -> b) -> a -> a
forall a b. Lens a b -> (b -> b) -> a -> a
modL Lens a b
y ((b -> b) -> a -> a) -> (b -> b) -> a -> a
forall a b. (a -> b) -> a -> b
$ Lens b c -> c -> b -> b
forall a b. Lens a b -> b -> a -> a
setL Lens b c
x c
b)

-- | Build a lens out of a getter and setter
lens :: (a -> b) -> (b -> a -> a) -> Lens a b
lens :: (a -> b) -> (b -> a -> a) -> Lens a b
lens a -> b
get b -> a -> a
set = (a -> (b -> a, b)) -> Lens a b
forall a b. (a -> (b -> a, b)) -> Lens a b
Lens ((a -> (b -> a, b)) -> Lens a b) -> (a -> (b -> a, b)) -> Lens a b
forall a b. (a -> b) -> a -> b
$ \a
a -> ((b -> a -> a) -> a -> b -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> a -> a
set a
a, a -> b
get a
a)

-- | Build a lens out of an isomorphism
iso :: (a -> b) -> (b -> a) -> Lens a b
iso :: (a -> b) -> (b -> a) -> Lens a b
iso a -> b
f b -> a
g = (a -> b) -> (b -> a -> a) -> Lens a b
forall a b. (a -> b) -> (b -> a -> a) -> Lens a b
lens a -> b
f (\b
x a
_ -> b -> a
g b
x)

-- | Get the getter function from a lens
getL :: Lens a b -> a -> b
getL :: Lens a b -> a -> b
getL Lens a b
l = (b -> a, b) -> b
forall a b. (a, b) -> b
snd ((b -> a, b) -> b) -> (a -> (b -> a, b)) -> a -> b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Lens a b -> a -> (b -> a, b)
forall a b. Lens a b -> a -> (b -> a, b)
runLens Lens a b
l

-- | Get the setter function from a lens
setL :: Lens a b -> b -> a -> a
setL :: Lens a b -> b -> a -> a
setL Lens a b
l = (a -> b -> a) -> b -> a -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((a -> b -> a) -> b -> a -> a) -> (a -> b -> a) -> b -> a -> a
forall a b. (a -> b) -> a -> b
$ (b -> a, b) -> b -> a
forall a b. (a, b) -> a
fst ((b -> a, b) -> b -> a) -> (a -> (b -> a, b)) -> a -> b -> a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Lens a b -> a -> (b -> a, b)
forall a b. Lens a b -> a -> (b -> a, b)
runLens Lens a b
l

-- | Get the modifier function from a lens
modL :: Lens a b -> (b -> b) -> a -> a
modL :: Lens a b -> (b -> b) -> a -> a
modL Lens a b
l b -> b
f a
a =
  case Lens a b -> a -> (b -> a, b)
forall a b. Lens a b -> a -> (b -> a, b)
runLens Lens a b
l a
a of
    (b -> a
setx, b
x) -> b -> a
setx (b -> b
f b
x)

-- | Get the modifier function from a lens. Forces function application.
modL' :: Lens a b -> (b -> b) -> a -> a
modL' :: Lens a b -> (b -> b) -> a -> a
modL' Lens a b
l b -> b
f a
a =
  case Lens a b -> a -> (b -> a, b)
forall a b. Lens a b -> a -> (b -> a, b)
runLens Lens a b
l a
a of
    (b -> a
setx, b
x) -> b -> a
setx (b -> a) -> b -> a
forall a b. (a -> b) -> a -> b
$! b -> b
f b
x

-- | Infix version of 'getL' (with the reverse order of the arguments)
infixl 9 ^.
(^.) :: b -> Lens b c -> c
^. :: b -> Lens b c -> c
(^.) = (Lens b c -> b -> c) -> b -> Lens b c -> c
forall a b c. (a -> b -> c) -> b -> a -> c
flip Lens b c -> b -> c
forall a b. Lens a b -> a -> b
getL

-- | Convert a lens to its van Laarhoven representation
vanLaarhoven :: Functor f => Lens a b -> (b -> f b) -> (a -> f a)
vanLaarhoven :: Lens a b -> (b -> f b) -> a -> f a
vanLaarhoven Lens a b
l b -> f b
f a
a =
  let
    fb :: f b
fb = b -> f b
f (a
a a -> Lens a b -> b
forall b c. b -> Lens b c -> c
^. Lens a b
l)
    fa :: f a
fa = (b -> a) -> f b -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\b
b -> Lens a b -> b -> a -> a
forall a b. Lens a b -> b -> a -> a
setL Lens a b
l b
b a
a) f b
fb
  in f a
fa