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