{- | Lenses that allow polymorphic updates. -}

{-# LANGUAGE
    FlexibleInstances
  , GADTs
  , MultiParamTypeClasses
  , TypeOperators #-}

module Data.Label.Poly
(

-- * The polymorphic Lens type.
  Lens
, lens
, point
, get
, modify
, set
, iso
, (>-)
, for
)
where

import Control.Category
import Control.Arrow
import Prelude ()
import Data.Label.Point (Point (Point), Iso(..), identity, compose)

import qualified Data.Label.Point as Point

{-# INLINE lens   #-}
{-# INLINE get    #-}
{-# INLINE modify #-}
{-# INLINE set    #-}
{-# INLINE (>-)   #-}
{-# INLINE point  #-}
{-# INLINE unpack #-}

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

-- | Abstract polymorphic lens datatype. The getter and setter functions work
-- in some category. Categories allow for effectful lenses, for example, lenses
-- that might fail or use state.

data Lens cat f o where
  Lens :: !(Point cat g i f o) -> Lens cat (f -> g) (o -> i)
  Id   :: ArrowApply cat => Lens cat f f

-- | Create a lens out of a getter and setter.

lens :: cat f o             -- ^ Getter.
     -> cat (cat o i, f) g  -- ^ Modifier.
     -> Lens cat (f -> g) (o -> i)
lens :: forall (cat :: * -> * -> *) f o i g.
cat f o -> cat (cat o i, f) g -> Lens cat (f -> g) (o -> i)
lens cat f o
g cat (cat o i, f) g
m = forall (cat :: * -> * -> *) g i f o.
Point cat g i f o -> Lens cat (f -> g) (o -> i)
Lens (forall (cat :: * -> * -> *) g i f o.
cat f o -> cat (cat o i, f) g -> Point cat g i f o
Point cat f o
g cat (cat o i, f) g
m)

-- | Create lens from a `Point`.

point :: Point cat g i f o -> Lens cat (f -> g) (o -> i)
point :: forall (cat :: * -> * -> *) g i f o.
Point cat g i f o -> Lens cat (f -> g) (o -> i)
point = forall (cat :: * -> * -> *) g i f o.
Point cat g i f o -> Lens cat (f -> g) (o -> i)
Lens

-- | Get the getter arrow from a lens.

get :: Lens cat (f -> g) (o -> i) -> cat f o
get :: forall (cat :: * -> * -> *) f g o i.
Lens cat (f -> g) (o -> i) -> cat f o
get = forall (cat :: * -> * -> *) g i f o. Point cat g i f o -> cat f o
Point.get forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (cat :: * -> * -> *) f g o i.
Lens cat (f -> g) (o -> i) -> Point cat g i f o
unpack

-- | Get the modifier arrow from a lens.

modify :: Lens cat (f -> g) (o -> i) -> cat (cat o i, f) g
modify :: forall (cat :: * -> * -> *) f g o i.
Lens cat (f -> g) (o -> i) -> cat (cat o i, f) g
modify = forall (cat :: * -> * -> *) g i f o.
Point cat g i f o -> cat (cat o i, f) g
Point.modify forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (cat :: * -> * -> *) f g o i.
Lens cat (f -> g) (o -> i) -> Point cat g i f o
unpack

-- | Get the setter arrow from a lens.

set :: Arrow arr => Lens arr (f -> g) (o -> i) -> arr (i, f) g
set :: forall (arr :: * -> * -> *) f g o i.
Arrow arr =>
Lens arr (f -> g) (o -> i) -> arr (i, f) g
set = forall (arr :: * -> * -> *) g i f o.
Arrow arr =>
Point arr g i f o -> arr (i, f) g
Point.set forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (cat :: * -> * -> *) f g o i.
Lens cat (f -> g) (o -> i) -> Point cat g i f o
unpack

-- | Lift a polymorphic isomorphism into a `Lens`.
--
-- The isomorphism needs to be passed in twice to properly unify.

iso :: ArrowApply cat => Iso cat f o -> Iso cat g i -> Lens cat (f -> g) (o -> i)
iso :: forall (cat :: * -> * -> *) f o g i.
ArrowApply cat =>
Iso cat f o -> Iso cat g i -> Lens cat (f -> g) (o -> i)
iso (Iso cat f o
f cat o f
_) (Iso cat g i
_ cat i g
y) = forall (cat :: * -> * -> *) f o i g.
cat f o -> cat (cat o i, f) g -> Lens cat (f -> g) (o -> i)
lens cat f o
f (forall (a :: * -> * -> *) b c. ArrowApply a => a (a b c, b) c
app forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\(cat o i
m, f
v) -> (cat i g
y forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. cat o i
m forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. cat f o
f, f
v)))

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

-- | Category instance for monomorphic lenses.

instance ArrowApply arr => Category (Lens arr) where
  id :: forall a. Lens arr a a
id              = forall (cat :: * -> * -> *) f. ArrowApply cat => Lens cat f f
Id
  Lens Point arr g i f o
f . :: forall b c a. Lens arr b c -> Lens arr a b -> Lens arr a c
. Lens Point arr g i f o
g = forall (cat :: * -> * -> *) g i f o.
Point cat g i f o -> Lens cat (f -> g) (o -> i)
Lens (forall (cat :: * -> * -> *) t i b o g f.
ArrowApply cat =>
Point cat t i b o -> Point cat g t f b -> Point cat g i f o
compose Point arr g i f o
f Point arr g i f o
g)
  Lens arr b c
Id     . Lens arr a b
u      = Lens arr a b
u
  Lens arr b c
u      . Lens arr a b
Id     = Lens arr b c
u
  {-# INLINE id  #-}
  {-# INLINE (.) #-}

-- | Make a Lens output diverge by changing the input of the modifier. The
-- operator can be read as /points-to/.

infix 7 >-

(>-) :: Arrow arr => Lens arr (j -> a) (i -> b) -> Lens arr (f -> g) (o -> i) -> Point arr g j f o
>- :: forall (arr :: * -> * -> *) j a i b f g o.
Arrow arr =>
Lens arr (j -> a) (i -> b)
-> Lens arr (f -> g) (o -> i) -> Point arr g j f o
(>-) (Lens (Point arr f o
f arr (arr o i, f) g
_)) (Lens Point arr g i f o
l) = forall (cat :: * -> * -> *) g i f o.
cat f o -> cat (cat o i, f) g -> Point cat g i f o
Point (forall (cat :: * -> * -> *) g i f o. Point cat g i f o -> cat f o
Point.get Point arr g i f o
l) (forall (cat :: * -> * -> *) g i f o.
Point cat g i f o -> cat (cat o i, f) g
Point.modify Point arr g i f o
l forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (arr f o
f forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.)))
(>-) (Lens (Point arr f o
f arr (arr o i, f) g
_)) Lens arr (f -> g) (o -> i)
Id       = forall (cat :: * -> * -> *) g i f o.
cat f o -> cat (cat o i, f) g -> Point cat g i f o
Point forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id (forall (a :: * -> * -> *) b c. ArrowApply a => a (a b c, b) c
app forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (arr f o
f forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.)))
(>-) Lens arr (j -> a) (i -> b)
Id                 Lens arr (f -> g) (o -> i)
l        = forall (cat :: * -> * -> *) f g o i.
Lens cat (f -> g) (o -> i) -> Point cat g i f o
unpack Lens arr (f -> g) (o -> i)
l

-- | Non-operator version of `>-`, since it clashes with an operator
-- when the Arrows language extension is used.

infix 7 `for`

for :: Arrow arr => Lens arr (j -> a) (i -> b) -> Lens arr (f -> g) (o -> i) -> Point arr g j f o
for :: forall (arr :: * -> * -> *) j a i b f g o.
Arrow arr =>
Lens arr (j -> a) (i -> b)
-> Lens arr (f -> g) (o -> i) -> Point arr g j f o
for = forall (arr :: * -> * -> *) j a i b f g o.
Arrow arr =>
Lens arr (j -> a) (i -> b)
-> Lens arr (f -> g) (o -> i) -> Point arr g j f o
(>-)

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

-- | Convert a polymorphic lens back to point.

unpack :: Lens cat (f -> g) (o -> i) -> Point cat g i f o
unpack :: forall (cat :: * -> * -> *) f g o i.
Lens cat (f -> g) (o -> i) -> Point cat g i f o
unpack Lens cat (f -> g) (o -> i)
Id       = forall (arr :: * -> * -> *) f o.
ArrowApply arr =>
Point arr f f o o
identity
unpack (Lens Point cat g i f o
p) = Point cat g i f o
p