gelisam / IdiomaticLens.hs

Last active April 26, 2014

-- 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