Skip to content

@gelisam /IdiomaticLens.hs
Last active

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Idiomatic Lens
-- 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.