Control.Lensの再発明(3) でけたー！！！

gistfile1.hs

{-# LANGUAGE RankNTypes #-}

module Main where
import Data.Functor.Identity
import Data.Functor.Constant

infixl 8 ^.
infixr 4 .~
infixl 1 &

-----
-- Lens

--type Setter s t a b =                      (a -> Identity   b) -> s -> Identity   t
--type Fold s t a b  = forall m. Monoid m => (a -> Constant m b) -> s -> Constant m t
--type Getting r s a =                       (a -> Constant r a) -> s -> Constant r s
type Lens s t a b = forall f . Functor f =>  (a -> f          b) -> s -> f          t

_1 :: Lens (a, v) (b, v) a b
_1 f (x, y) = fmap (\x' -> (x', y)) (f x)

_2 :: Lens (v, a) (v, b) a b
_2 f (x, y) = fmap (\y' -> (x, y')) (f y)

-----
-- Setter

(&) = flip ($)

--over :: Setter s t a b -> (a -> b) -> s -> t
--over l f = runIdentity . l (Identity . f)
--a .~ v = over a (const v)

(.~) :: Lens s t a b -> b -> s -> t
f .~ v = runIdentity . f (Identity . const v)

-----
-- Getter

----foldMap ::                  (a -> m) -> t a -> m
--foldMapOf :: Getting r s a -> (a -> r) -> s   -> r
--foldMapOf l f = getConstant . l (Constant . f)
--(^.) :: s -> Getting a s a -> a
--v ^. f = foldMapOf f id v

(^.) :: s -> Lens s s a a -> a
v ^. f = getConstant . f Constant $ v

-----
-- Test

main = let
  test1 = ("Hello", ((), "World"))&_2._1.~"Lens"
  test2 = ("Hello", ("Lens", "World"))^._2._1
  in do
    print test1 -- => ("Hello",("Lens","World"))
    print test2 -- => "Lens"