Poly.hs

{- | 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 g m = Lens (Point g m)

-- | Create lens from a `Point`.

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

-- | Get the getter arrow from a lens.

get :: Lens cat (f -> g) (o -> i) -> cat f o
get = Point.get . unpack

-- | Get the modifier arrow from a lens.

modify :: Lens cat (f -> g) (o -> i) -> cat (cat o i, f) g
modify = Point.modify . unpack

-- | Get the setter arrow from a lens.

set :: Arrow arr => Lens arr (f -> g) (o -> i) -> arr (i, f) g
set = Point.set . 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 f _) (Iso _ y) = lens f (app . arr (\(m, v) -> (y . m . f, v)))

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

-- | Category instance for monomorphic lenses.

instance ArrowApply arr => Category (Lens arr) where
  id              = Id
  Lens f . Lens g = Lens (compose f g)
  Id     . u      = u
  u      . Id     = 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 (Point f _)) (Lens l) = Point (Point.get l) (Point.modify l . first (arr (f .)))
(>-) (Lens (Point f _)) Id       = Point id (app . first (arr (f .)))
(>-) Id                 l        = unpack 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 = (>-)

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

-- | Convert a polymorphic lens back to point.

unpack :: Lens cat (f -> g) (o -> i) -> Point cat g i f o
unpack Id       = identity
unpack (Lens p) = p