Idiomatic Lens

IdiomaticLens.hs

-- in reply to http://www.reddit.com/r/haskell/comments/23uzpg/lens_is_unidiomatic_haskell/
-- 
-- What the lens library might look like if Getter, Setter, Fold, Traversal,
-- Lens, Review, and Prism were separate datatypes.
-- 
-- For each optic, I only define enough combinators to explore pairs/sums
-- and lists of integers. Whenever possible, I reimplement the same
-- combinators and the same examples with all optics.

module IdiomaticLens where

import Prelude hiding (id, (.))
import Control.Applicative
import Control.Category
import Control.Monad
import Data.Foldable
import Data.Traversable


-- | Gets one a from an s
data Getter s a = Getter { runGetter :: s -> a }

instance Category Getter where
  id = Getter id
  Getter f . Getter g = Getter (f . g)

get :: Getter s a -> s -> a
get = runGetter

fstGetter :: Getter (a, b) a
fstGetter = Getter fst

sndGetter :: Getter (a, b) b
sndGetter = Getter snd

-- |
-- >>> let v = (((0, 0), 0), ((1, 0), 0))
-- 
-- Getters compose in the same order as accessors.
-- >>> (fst . fst . snd) v
-- 1
-- >>> get (fstGetter . fstGetter . sndGetter) v
-- 1
caadr_getter :: Getter (a, ((b, c), d)) b
caadr_getter = fstGetter . fstGetter . sndGetter


-- Sets any number of a in s
type Setter' s a = Setter s s a a
data Setter s t a b = Setter { runSetter :: (a -> b) -> s -> t }

-- instance Category Setter' where
--   id = Setter id
--   Setter f . Setter g = Setter (g . f)

class Category4 f where
  id4 :: f a b a b
  compose4 :: f u v a b -> f s t u v -> f s t a b

instance Category4 Setter where
  id4 = Setter id
  Setter f `compose4` Setter g = Setter (g . f)

modify :: Setter s t a b -> (a -> b) -> s -> t
modify = runSetter

set :: Setter s t a b -> b -> s -> t
set s = modify s . const

delete :: Setter s t a (Maybe b) -> s -> t
delete s = modify s (const Nothing)

fstSetter :: Setter (a, b) (a', b) a a'
fstSetter = Setter go
  where
    go f (x, y) = (f x, y)

sndSetter :: Setter (a, b) (a, b') b b'
sndSetter = Setter go
  where
    go f (x, y) = (x, f y)

-- |
-- >>> let v = (((0, 0), 0), ((1, 0), 0))
-- 
-- Setters compose in the same order as accessors.
-- >>> (fst . fst . snd) v
-- 1
-- >>> set caadr_setter 2 v
-- (((0,0),0),((2,0),0))
caadr_setter :: Setter (a, ((b, c), d)) (a, ((b', c), d)) b b'
caadr_setter = fstSetter `compose4` fstSetter `compose4` sndSetter

bothSetter :: Setter s1 t1 a b -> Setter s2 t2 a b -> Setter (s1,s2) (t1,t2) a b
bothSetter (Setter s1) (Setter s2) = Setter go
  where
    go f (x, y) = (s1 f x, s2 f y)

functorSetter :: Functor f => Setter (f a) (f b) a b
functorSetter = Setter fmap

filterSetter :: (a -> Bool) -> Setter' a a
filterSetter p = Setter go
  where
    go f x | p x = f x
    go f x       = x

-- |
-- >>> modify odd_setter (+1) ([1..10],11)
-- ([2,2,4,4,6,6,8,8,10,10],12)
odd_setter :: Setter' ([Int], Int) Int
odd_setter = filterSetter odd `compose4` (functorSetter `bothSetter` id4)

nullableSetter :: MonadPlus m => Setter (m a) (m b) (Maybe a) (Maybe b)
nullableSetter = Setter go
  where
    go f mx = do
        x <- mx
        case f (Just x) of
          Just y -> return y
          Nothing -> mzero

-- |
-- >>> delete nullable_odd_setter ([1..10],11)
-- ([2,4,6,8,10],11)
nullable_odd_setter :: Setter' ([Int], Int) (Maybe Int)
nullable_odd_setter = filterSetter (maybe True odd) `compose4` nullableSetter `compose4` fstSetter


-- Gets any number of a in s
data Fold s a = Fold { runFold :: s -> [a] }

instance Category Fold where
  id = Fold return
  Fold f . Fold g = Fold (f <=< g)

getterFold :: Getter s a -> Fold s a
getterFold (Getter f) = Fold (return . f)

fstFold :: Fold (a, b) a
fstFold = getterFold fstGetter

sndFold :: Fold (a, b) b
sndFold = getterFold sndGetter

-- |
-- >>> let v = (((0, 0), 0), ((1, 0), 0))
-- 
-- Folds compose in the same order as accessors.
-- >>> (fst . fst . snd) v
-- 1
-- >>> runFold (fstFold . fstFold . sndFold) v
-- [1]
caadr_fold :: Fold (a, ((b, c), d)) b
caadr_fold = fstFold . fstFold . sndFold

bothFold :: Fold s a -> Fold t a -> Fold (s, t) a
bothFold (Fold f) (Fold g) = Fold go
  where
    go (x, y) = f x ++ g y

foldableFold :: Foldable f => Fold (f a) a
foldableFold = Fold toList

filterFold :: (a -> Bool) -> Fold a a
filterFold p = Fold go
  where
    go x | p x = [x]
    go _       = []

-- |
-- >>> runFold odd_fold ([1..10],11)
-- [1,3,5,7,9,11]
odd_fold :: Fold ([Int], Int) Int
odd_fold = filterFold odd . (foldableFold `bothFold` id)


-- Gets or Sets any number of 'a' in 's'
type Traversal' s a = Traversal s s a a
data Traversal s t a b = Traversal
  { listAll :: Fold s a
  , setAll :: Setter s t a b
  }

instance Category4 Traversal where
  id4 = Traversal id id4
  Traversal f1 s1 `compose4` Traversal f2 s2 = Traversal (f1 . f2) (s1 `compose4` s2)

fstTraversal :: Traversal (a, b) (a', b) a a'
fstTraversal = Traversal fstFold fstSetter

sndTraversal :: Traversal (a, b) (a, b') b b'
sndTraversal = Traversal sndFold sndSetter

-- |
-- >>> let v = (((0, 0), 0), ((1, 0), 0))
-- 
-- Traversals compose in the same order as accessors.
-- >>> (fst . fst . snd) v
-- 1
-- >>> runFold (listAll caadr_traversal) v
-- [1]
-- >>> set (setAll caadr_traversal) 2 v
-- (((0,0),0),((2,0),0))
caadr_traversal :: Traversal (a, ((b, c), d)) (a, ((b', c), d)) b b'
caadr_traversal = fstTraversal `compose4` fstTraversal `compose4` sndTraversal

bothTraversal :: Traversal s1 t1 a b -> Traversal s2 t2 a b -> Traversal (s1,s2) (t1,t2) a b
bothTraversal (Traversal f1 s1) (Traversal f2 s2) = Traversal (f1 `bothFold` f2) (s1 `bothSetter` s2)

traversableTraversal :: Traversable f => Traversal (f a) (f b) a b
traversableTraversal = Traversal foldableFold functorSetter

filterTraversal :: (a -> Bool) -> Traversal' a a
filterTraversal p = Traversal (filterFold p) (filterSetter p)

-- |
-- >>> runFold (listAll odd_traversal) ([1..10],11)
-- [1,3,5,7,9,11]
-- >>> modify (setAll odd_traversal) (+1) ([1..10],11)
-- ([2,2,4,4,6,6,8,8,10,10],12)
odd_traversal :: Traversal' ([Int], Int) Int
odd_traversal = filterTraversal odd `compose4` (traversableTraversal `bothTraversal` id4)

nullableTraversal :: Traversal [a] [b] (Maybe a) (Maybe b)
nullableTraversal = Traversal (Fold $ map Just) nullableSetter

-- |
-- >>> delete (setAll nullable_odd_traversal) ([1..10],11)
-- ([2,4,6,8,10],11)
nullable_odd_traversal :: Traversal' ([Int], Int) (Maybe Int)
nullable_odd_traversal = filterTraversal (maybe True odd) `compose4` nullableTraversal `compose4` fstTraversal


-- Gets or Sets one a in s
type Lens' s a = Lens s s a a
data Lens s t a b = Lens
  { getter :: Getter s a
  , setter :: Setter s t a b
  }

instance Category4 Lens where
  id4 = Lens id id4
  Lens g1 s1 `compose4` Lens g2 s2 = Lens (g1 . g2) (s1 `compose4` s2)

fstLens :: Lens (a, b) (a', b) a a'
fstLens = Lens fstGetter fstSetter

sndLens :: Lens (a, b) (a, b') b b'
sndLens = Lens sndGetter sndSetter

-- |
-- >>> let v = (((0, 0), 0), ((1, 0), 0))
-- 
-- Lenses compose in the same order as accessors.
-- >>> (fst . fst . snd) v
-- 1
-- >>> get (getter caadr_lens) v
-- 1
-- >>> set (setter caadr_lens) 2 v
-- (((0,0),0),((2,0),0))
caadr_lens :: Lens (a, ((b, c), d)) (a, ((b', c), d)) b b'
caadr_lens = fstLens `compose4` fstLens `compose4` sndLens


-- Can construct s from a
data Review s a = Review { runReview :: a -> s }

instance Category Review where
  id = Review id
  Review f . Review g = Review (g . f)

leftReview :: Review (Either a b) a
leftReview = Review Left

rightReview :: Review (Either a b) b
rightReview = Review Right

-- |
-- >>> let v = Right (Left (Left 1))
-- >>> let fromLeft (Left x) = x
-- >>> let fromRight (Right y) = y
-- 
-- Reviews compose in the same order as accessors.
-- >>> (fromLeft . fromLeft . fromRight) v
-- 1
-- >>> runReview (leftReview . leftReview . rightReview) 1
-- Right (Left (Left 1))
caadr_review :: Review (Either a (Either (Either b c) d)) b
caadr_review = leftReview . leftReview . rightReview


-- Gets zero or one a in s / Can construct s from a
data Prism s a = Prism
  { check :: s -> Maybe a  -- shouldn't there be an optic with only check?
  , review :: Review s a
  }

instance Category Prism where
  id = Prism Just id
  Prism c1 r1 . Prism c2 r2 = Prism (c1 <=< c2) (r1 . r2)

leftPrism :: Prism (Either a b) a
leftPrism = Prism checkLeft leftReview
  where
    checkLeft (Left x) = Just x
    checkLeft _        = Nothing

rightPrism :: Prism (Either a b) b
rightPrism = Prism checkRight rightReview
  where
    checkRight (Right x) = Just x
    checkRight _         = Nothing

-- |
-- >>> let v = Right (Left (Left 1))
-- >>> let fromLeft (Left x) = x
-- >>> let fromRight (Right y) = y
-- 
-- Prisms compose in the same order as accessors.
-- >>> (fromLeft . fromLeft . fromRight) v
-- 1
-- >>> check (leftPrism . leftPrism . rightPrism) v
-- Just 1
-- >>> runReview (review caadr_prism) 1
-- Right (Left (Left 1))
caadr_prism :: Prism (Either a (Either (Either b c) d)) b
caadr_prism = leftPrism . leftPrism . rightPrism