Control.Lensの再発明(2) Getterのほう

gistfile1.hs

{-# LANGUAGE RankNTypes #-}

module Main where
import Data.Functor.Constant
import Data.Foldable
import Data.Traversable
import Data.Monoid
import Control.Applicative

infixl 8 ^.

instance Show a => Show (Constant a b) where
  show x = "Const " ++ (show $ getConstant x)

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

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

folds :: ((a -> r) -> s -> r) -> Getting r s a
folds l f = Constant . l (getConstant . f)

folded :: Foldable f => Fold (f a) (f a) a a
folded = folds foldMap

_1 :: Fold (a, v) (b, v) a b
_1 f (x, _) = Constant (getConstant . f $ x)

_2 :: Fold (v, a) (v, b) a b
_2 f (_, y) = Constant (getConstant . f $ y)

(^.) :: s -> Getting a s a -> a
v ^. l = foldMapOf l id v