Pure profunctor lenses

Pp.hs

{-# LANGUAGE RankNTypes, LiberalTypeSynonyms, DeriveFunctor, LambdaCase #-}

module Pp where

import Data.Monoid

class Profunctor p where
  dimap :: (a -> b) -> (s -> t) -> p b s -> p a t

class Profunctor p => Strong p where
  first  :: p a b -> p (a, x) (b, x)
  second :: p a b -> p (x, a) (x, b)

class Profunctor p => Choice p where
  left  :: p a b -> p (Either a x) (Either b x)
  right :: p a b -> p (Either x a) (Either x b)

instance Profunctor (->) where
  dimap f g h = g . h . f

instance Strong (->) where
  first  f (a, x) = (f a, x)
  second f (x, a) = (x, f a)

instance Choice (->) where
  left  f = either (Left . f) Right
  right f = either Left (Right . f)

type Lensy p s t a b = p a b -> p s t

type Iso   s t a b = forall p . Profunctor p => Lensy p s t a b
type Lens  s t a b = forall p . Strong p     => Lensy p s t a b
type Prism s t a b = forall p . Choice p     => Lensy p s t a b

newtype Forget r a b = Forget { runForget :: a -> r }

instance Profunctor (Forget r) where
  dimap f _ (Forget q) = Forget (q . f)

instance Strong (Forget r) where
  first  (Forget f) = Forget (\(a, _) -> f a)
  second (Forget f) = Forget (\(_, a) -> f a)

instance Monoid r => Choice (Forget r) where
  left  (Forget f) = Forget (either f (const mempty))
  right (Forget f) = Forget (either (const mempty) f)

iso :: (s -> a) -> (b -> t) -> Iso s t a b
iso = dimap

lensIso :: (s -> a) -> (s -> b -> t) -> Iso s t (a, s) (b, s)
lensIso gt st = iso (\s -> (gt s, s)) (\(b, s) -> st s b)

lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
lens gt st = lensIso gt st . first

_1 :: Lens (a, b) (x, b) a x
_1 = lens fst (\(_, b) x -> (x, b))

prismIso :: (b -> t) -> (s -> Either t a) -> Iso s t (Either t a) (Either t b)
prismIso review peel = iso peel (either id review)

prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
prism review peel = prismIso review peel . right

_Left :: Prism (Either a b) (Either x b) a x
_Left = prism Left (either Right (Left . Right))

over :: Lensy (->) s t a b -> (a -> b) -> s -> t
over l = l

set :: Lensy (->) s t a b -> b -> s -> t
set l s = l (const s)

view :: Lensy (Forget a) s t a b -> s -> a
view l = runForget (l (Forget id))

preview :: Lensy (Forget (Maybe a)) s t a b -> s -> Maybe a
preview l = runForget (l (Forget Just))