{- | 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 :: 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 = Point cat g i f o -> Lens cat (f -> g) (o -> i)
forall (cat :: * -> * -> *) g i f o.
Point cat g i f o -> Lens cat (f -> g) (o -> i)
Lens (cat f o -> cat (cat o i, f) g -> Point cat g i f o
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 :: Point cat g i f o -> Lens cat (f -> g) (o -> i)
point = Point cat g i f o -> Lens cat (f -> g) (o -> i)
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 :: Lens cat (f -> g) (o -> i) -> cat f o
get = Point cat g i f o -> cat f o
forall (cat :: * -> * -> *) g i f o. Point cat g i f o -> cat f o
Point.get (Point cat g i f o -> cat f o)
-> (Lens cat (f -> g) (o -> i) -> Point cat g i f o)
-> Lens cat (f -> g) (o -> i)
-> cat f o
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Lens cat (f -> g) (o -> i) -> Point cat g i f o
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 :: Lens cat (f -> g) (o -> i) -> cat (cat o i, f) g
modify = Point cat g i f o -> cat (cat o i, f) g
forall (cat :: * -> * -> *) g i f o.
Point cat g i f o -> cat (cat o i, f) g
Point.modify (Point cat g i f o -> cat (cat o i, f) g)
-> (Lens cat (f -> g) (o -> i) -> Point cat g i f o)
-> Lens cat (f -> g) (o -> i)
-> cat (cat o i, f) g
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Lens cat (f -> g) (o -> i) -> Point cat g i f o
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 :: Lens arr (f -> g) (o -> i) -> arr (i, f) g
set = Point arr g i f o -> arr (i, f) g
forall (arr :: * -> * -> *) g i f o.
Arrow arr =>
Point arr g i f o -> arr (i, f) g
Point.set (Point arr g i f o -> arr (i, f) g)
-> (Lens arr (f -> g) (o -> i) -> Point arr g i f o)
-> Lens arr (f -> g) (o -> i)
-> arr (i, f) g
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Lens arr (f -> g) (o -> i) -> Point arr g i f o
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 :: 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) = cat f o -> cat (cat o i, f) g -> Lens cat (f -> g) (o -> i)
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 (cat (cat f g, f) g
forall (a :: * -> * -> *) b c. ArrowApply a => a (a b c, b) c
app cat (cat f g, f) g
-> cat (cat o i, f) (cat f g, f) -> cat (cat o i, f) g
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, f) -> (cat f g, f)) -> cat (cat o i, f) (cat f g, f)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\(cat o i
m, f
v) -> (cat i g
y cat i g -> cat f i -> cat f g
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 cat o i -> cat f o -> cat f i
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 :: Lens arr a a
id              = Lens arr a a
forall (cat :: * -> * -> *) f. ArrowApply cat => Lens cat f f
Id
  Lens Point arr g i f o
f . :: Lens arr b c -> Lens arr a b -> Lens arr a c
. Lens Point arr g i f o
g = Point arr g i f o -> Lens arr (f -> g) (o -> i)
forall (cat :: * -> * -> *) g i f o.
Point cat g i f o -> Lens cat (f -> g) (o -> i)
Lens (Point arr g i f o -> Point arr g g f f -> Point arr g i f o
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 g f f
Point arr g i f o
g)
  Lens arr b c
Id     . Lens arr a b
u      = Lens arr a b
Lens arr a c
u
  Lens arr b c
u      . Lens arr a b
Id     = Lens arr b c
Lens arr a 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
>- :: 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) = arr f o -> arr (arr o f, f) g -> Point arr g f f o
forall (cat :: * -> * -> *) g i f o.
cat f o -> cat (cat o i, f) g -> Point cat g i f o
Point (Point arr g i f o -> arr f o
forall (cat :: * -> * -> *) g i f o. Point cat g i f o -> cat f o
Point.get Point arr g i f o
l) (Point arr g i f o -> arr (arr o i, f) g
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 arr (arr o i, f) g
-> arr (arr o f, f) (arr o i, f) -> arr (arr o f, f) g
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. arr (arr o f) (arr o o) -> arr (arr o f, f) (arr o o, f)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((arr o f -> arr o o) -> arr (arr o f) (arr o o)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (arr f o
f arr f o -> arr o f -> arr o o
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       = arr f f -> arr (arr f f, f) o -> Point arr o f f f
forall (cat :: * -> * -> *) g i f o.
cat f o -> cat (cat o i, f) g -> Point cat g i f o
Point arr f f
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id (arr (arr f o, f) o
forall (a :: * -> * -> *) b c. ArrowApply a => a (a b c, b) c
app arr (arr f o, f) o
-> arr (arr f f, f) (arr f o, f) -> arr (arr f f, f) o
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. arr (arr f f) (arr f o) -> arr (arr f f, f) (arr f o, f)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((arr f f -> arr f o) -> arr (arr f f) (arr f o)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (arr f o
f arr f o -> arr f f -> arr f o
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        = Lens arr (f -> g) (o -> i) -> Point arr g i f o
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 :: Lens arr (j -> a) (i -> b)
-> Lens arr (f -> g) (o -> i) -> Point arr g j f o
for = 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
(>-)

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

-- | Convert a polymorphic lens back to point.

unpack :: Lens cat (f -> g) (o -> i) -> Point cat g i f o
unpack :: Lens cat (f -> g) (o -> i) -> Point cat g i f o
unpack Lens cat (f -> g) (o -> i)
Id       = Point cat g i f o
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
Point cat g i f o
p